From 5c69acb32329d49e58c26fa41ae74229a52b9106 Mon Sep 17 00:00:00 2001 From: Martin Liska Date: Fri, 14 Jan 2022 16:56:44 +0100 Subject: Rename .c files to .cc files. gcc/ada/ChangeLog: * adadecode.c: Moved to... * adadecode.cc: ...here. * affinity.c: Moved to... * affinity.cc: ...here. * argv-lynxos178-raven-cert.c: Moved to... * argv-lynxos178-raven-cert.cc: ...here. * argv.c: Moved to... * argv.cc: ...here. * aux-io.c: Moved to... * aux-io.cc: ...here. * cio.c: Moved to... * cio.cc: ...here. * cstreams.c: Moved to... * cstreams.cc: ...here. * env.c: Moved to... * env.cc: ...here. * exit.c: Moved to... * exit.cc: ...here. * expect.c: Moved to... * expect.cc: ...here. * final.c: Moved to... * final.cc: ...here. * gcc-interface/cuintp.c: Moved to... * gcc-interface/cuintp.cc: ...here. * gcc-interface/decl.c: Moved to... * gcc-interface/decl.cc: ...here. * gcc-interface/misc.c: Moved to... * gcc-interface/misc.cc: ...here. * gcc-interface/targtyps.c: Moved to... * gcc-interface/targtyps.cc: ...here. * gcc-interface/trans.c: Moved to... * gcc-interface/trans.cc: ...here. * gcc-interface/utils.c: Moved to... * gcc-interface/utils.cc: ...here. * gcc-interface/utils2.c: Moved to... * gcc-interface/utils2.cc: ...here. * init.c: Moved to... * init.cc: ...here. * initialize.c: Moved to... * initialize.cc: ...here. * libgnarl/thread.c: Moved to... * libgnarl/thread.cc: ...here. * link.c: Moved to... * link.cc: ...here. * locales.c: Moved to... * locales.cc: ...here. * mkdir.c: Moved to... * mkdir.cc: ...here. * raise.c: Moved to... * raise.cc: ...here. * rtfinal.c: Moved to... * rtfinal.cc: ...here. * rtinit.c: Moved to... * rtinit.cc: ...here. * seh_init.c: Moved to... * seh_init.cc: ...here. * sigtramp-armdroid.c: Moved to... * sigtramp-armdroid.cc: ...here. * sigtramp-ios.c: Moved to... * sigtramp-ios.cc: ...here. * sigtramp-qnx.c: Moved to... * sigtramp-qnx.cc: ...here. * sigtramp-vxworks.c: Moved to... * sigtramp-vxworks.cc: ...here. * socket.c: Moved to... * socket.cc: ...here. * tracebak.c: Moved to... * tracebak.cc: ...here. * version.c: Moved to... * version.cc: ...here. * vx_stack_info.c: Moved to... * vx_stack_info.cc: ...here. gcc/ChangeLog: * adjust-alignment.c: Moved to... * adjust-alignment.cc: ...here. * alias.c: Moved to... * alias.cc: ...here. * alloc-pool.c: Moved to... * alloc-pool.cc: ...here. * asan.c: Moved to... * asan.cc: ...here. * attribs.c: Moved to... * attribs.cc: ...here. * auto-inc-dec.c: Moved to... * auto-inc-dec.cc: ...here. * auto-profile.c: Moved to... * auto-profile.cc: ...here. * bb-reorder.c: Moved to... * bb-reorder.cc: ...here. * bitmap.c: Moved to... * bitmap.cc: ...here. * btfout.c: Moved to... * btfout.cc: ...here. * builtins.c: Moved to... * builtins.cc: ...here. * caller-save.c: Moved to... * caller-save.cc: ...here. * calls.c: Moved to... * calls.cc: ...here. * ccmp.c: Moved to... * ccmp.cc: ...here. * cfg.c: Moved to... * cfg.cc: ...here. * cfganal.c: Moved to... * cfganal.cc: ...here. * cfgbuild.c: Moved to... * cfgbuild.cc: ...here. * cfgcleanup.c: Moved to... * cfgcleanup.cc: ...here. * cfgexpand.c: Moved to... * cfgexpand.cc: ...here. * cfghooks.c: Moved to... * cfghooks.cc: ...here. * cfgloop.c: Moved to... * cfgloop.cc: ...here. * cfgloopanal.c: Moved to... * cfgloopanal.cc: ...here. * cfgloopmanip.c: Moved to... * cfgloopmanip.cc: ...here. * cfgrtl.c: Moved to... * cfgrtl.cc: ...here. * cgraph.c: Moved to... * cgraph.cc: ...here. * cgraphbuild.c: Moved to... * cgraphbuild.cc: ...here. * cgraphclones.c: Moved to... * cgraphclones.cc: ...here. * cgraphunit.c: Moved to... * cgraphunit.cc: ...here. * collect-utils.c: Moved to... * collect-utils.cc: ...here. * collect2-aix.c: Moved to... * collect2-aix.cc: ...here. * collect2.c: Moved to... * collect2.cc: ...here. * combine-stack-adj.c: Moved to... * combine-stack-adj.cc: ...here. * combine.c: Moved to... * combine.cc: ...here. * common/common-targhooks.c: Moved to... * common/common-targhooks.cc: ...here. * common/config/aarch64/aarch64-common.c: Moved to... * common/config/aarch64/aarch64-common.cc: ...here. * common/config/alpha/alpha-common.c: Moved to... * common/config/alpha/alpha-common.cc: ...here. * common/config/arc/arc-common.c: Moved to... * common/config/arc/arc-common.cc: ...here. * common/config/arm/arm-common.c: Moved to... * common/config/arm/arm-common.cc: ...here. * common/config/avr/avr-common.c: Moved to... * common/config/avr/avr-common.cc: ...here. * common/config/bfin/bfin-common.c: Moved to... * common/config/bfin/bfin-common.cc: ...here. * common/config/bpf/bpf-common.c: Moved to... * common/config/bpf/bpf-common.cc: ...here. * common/config/c6x/c6x-common.c: Moved to... * common/config/c6x/c6x-common.cc: ...here. * common/config/cr16/cr16-common.c: Moved to... * common/config/cr16/cr16-common.cc: ...here. * common/config/cris/cris-common.c: Moved to... * common/config/cris/cris-common.cc: ...here. * common/config/csky/csky-common.c: Moved to... * common/config/csky/csky-common.cc: ...here. * common/config/default-common.c: Moved to... * common/config/default-common.cc: ...here. * common/config/epiphany/epiphany-common.c: Moved to... * common/config/epiphany/epiphany-common.cc: ...here. * common/config/fr30/fr30-common.c: Moved to... * common/config/fr30/fr30-common.cc: ...here. * common/config/frv/frv-common.c: Moved to... * common/config/frv/frv-common.cc: ...here. * common/config/gcn/gcn-common.c: Moved to... * common/config/gcn/gcn-common.cc: ...here. * common/config/h8300/h8300-common.c: Moved to... * common/config/h8300/h8300-common.cc: ...here. * common/config/i386/i386-common.c: Moved to... * common/config/i386/i386-common.cc: ...here. * common/config/ia64/ia64-common.c: Moved to... * common/config/ia64/ia64-common.cc: ...here. * common/config/iq2000/iq2000-common.c: Moved to... * common/config/iq2000/iq2000-common.cc: ...here. * common/config/lm32/lm32-common.c: Moved to... * common/config/lm32/lm32-common.cc: ...here. * common/config/m32r/m32r-common.c: Moved to... * common/config/m32r/m32r-common.cc: ...here. * common/config/m68k/m68k-common.c: Moved to... * common/config/m68k/m68k-common.cc: ...here. * common/config/mcore/mcore-common.c: Moved to... * common/config/mcore/mcore-common.cc: ...here. * common/config/microblaze/microblaze-common.c: Moved to... * common/config/microblaze/microblaze-common.cc: ...here. * common/config/mips/mips-common.c: Moved to... * common/config/mips/mips-common.cc: ...here. * common/config/mmix/mmix-common.c: Moved to... * common/config/mmix/mmix-common.cc: ...here. * common/config/mn10300/mn10300-common.c: Moved to... * common/config/mn10300/mn10300-common.cc: ...here. * common/config/msp430/msp430-common.c: Moved to... * common/config/msp430/msp430-common.cc: ...here. * common/config/nds32/nds32-common.c: Moved to... * common/config/nds32/nds32-common.cc: ...here. * common/config/nios2/nios2-common.c: Moved to... * common/config/nios2/nios2-common.cc: ...here. * common/config/nvptx/nvptx-common.c: Moved to... * common/config/nvptx/nvptx-common.cc: ...here. * common/config/or1k/or1k-common.c: Moved to... * common/config/or1k/or1k-common.cc: ...here. * common/config/pa/pa-common.c: Moved to... * common/config/pa/pa-common.cc: ...here. * common/config/pdp11/pdp11-common.c: Moved to... * common/config/pdp11/pdp11-common.cc: ...here. * common/config/pru/pru-common.c: Moved to... * common/config/pru/pru-common.cc: ...here. * common/config/riscv/riscv-common.c: Moved to... * common/config/riscv/riscv-common.cc: ...here. * common/config/rs6000/rs6000-common.c: Moved to... * common/config/rs6000/rs6000-common.cc: ...here. * common/config/rx/rx-common.c: Moved to... * common/config/rx/rx-common.cc: ...here. * common/config/s390/s390-common.c: Moved to... * common/config/s390/s390-common.cc: ...here. * common/config/sh/sh-common.c: Moved to... * common/config/sh/sh-common.cc: ...here. * common/config/sparc/sparc-common.c: Moved to... * common/config/sparc/sparc-common.cc: ...here. * common/config/tilegx/tilegx-common.c: Moved to... * common/config/tilegx/tilegx-common.cc: ...here. * common/config/tilepro/tilepro-common.c: Moved to... * common/config/tilepro/tilepro-common.cc: ...here. * common/config/v850/v850-common.c: Moved to... * common/config/v850/v850-common.cc: ...here. * common/config/vax/vax-common.c: Moved to... * common/config/vax/vax-common.cc: ...here. * common/config/visium/visium-common.c: Moved to... * common/config/visium/visium-common.cc: ...here. * common/config/xstormy16/xstormy16-common.c: Moved to... * common/config/xstormy16/xstormy16-common.cc: ...here. * common/config/xtensa/xtensa-common.c: Moved to... * common/config/xtensa/xtensa-common.cc: ...here. * compare-elim.c: Moved to... * compare-elim.cc: ...here. * config/aarch64/aarch64-bti-insert.c: Moved to... * config/aarch64/aarch64-bti-insert.cc: ...here. * config/aarch64/aarch64-builtins.c: Moved to... * config/aarch64/aarch64-builtins.cc: ...here. * config/aarch64/aarch64-c.c: Moved to... * config/aarch64/aarch64-c.cc: ...here. * config/aarch64/aarch64-d.c: Moved to... * config/aarch64/aarch64-d.cc: ...here. * config/aarch64/aarch64.c: Moved to... * config/aarch64/aarch64.cc: ...here. * config/aarch64/cortex-a57-fma-steering.c: Moved to... * config/aarch64/cortex-a57-fma-steering.cc: ...here. * config/aarch64/driver-aarch64.c: Moved to... * config/aarch64/driver-aarch64.cc: ...here. * config/aarch64/falkor-tag-collision-avoidance.c: Moved to... * config/aarch64/falkor-tag-collision-avoidance.cc: ...here. * config/aarch64/host-aarch64-darwin.c: Moved to... * config/aarch64/host-aarch64-darwin.cc: ...here. * config/alpha/alpha.c: Moved to... * config/alpha/alpha.cc: ...here. * config/alpha/driver-alpha.c: Moved to... * config/alpha/driver-alpha.cc: ...here. * config/arc/arc-c.c: Moved to... * config/arc/arc-c.cc: ...here. * config/arc/arc.c: Moved to... * config/arc/arc.cc: ...here. * config/arc/driver-arc.c: Moved to... * config/arc/driver-arc.cc: ...here. * config/arm/aarch-common.c: Moved to... * config/arm/aarch-common.cc: ...here. * config/arm/arm-builtins.c: Moved to... * config/arm/arm-builtins.cc: ...here. * config/arm/arm-c.c: Moved to... * config/arm/arm-c.cc: ...here. * config/arm/arm-d.c: Moved to... * config/arm/arm-d.cc: ...here. * config/arm/arm.c: Moved to... * config/arm/arm.cc: ...here. * config/arm/driver-arm.c: Moved to... * config/arm/driver-arm.cc: ...here. * config/avr/avr-c.c: Moved to... * config/avr/avr-c.cc: ...here. * config/avr/avr-devices.c: Moved to... * config/avr/avr-devices.cc: ...here. * config/avr/avr-log.c: Moved to... * config/avr/avr-log.cc: ...here. * config/avr/avr.c: Moved to... * config/avr/avr.cc: ...here. * config/avr/driver-avr.c: Moved to... * config/avr/driver-avr.cc: ...here. * config/avr/gen-avr-mmcu-specs.c: Moved to... * config/avr/gen-avr-mmcu-specs.cc: ...here. * config/avr/gen-avr-mmcu-texi.c: Moved to... * config/avr/gen-avr-mmcu-texi.cc: ...here. * config/bfin/bfin.c: Moved to... * config/bfin/bfin.cc: ...here. * config/bpf/bpf.c: Moved to... * config/bpf/bpf.cc: ...here. * config/bpf/coreout.c: Moved to... * config/bpf/coreout.cc: ...here. * config/c6x/c6x.c: Moved to... * config/c6x/c6x.cc: ...here. * config/cr16/cr16.c: Moved to... * config/cr16/cr16.cc: ...here. * config/cris/cris.c: Moved to... * config/cris/cris.cc: ...here. * config/csky/csky.c: Moved to... * config/csky/csky.cc: ...here. * config/darwin-c.c: Moved to... * config/darwin-c.cc: ...here. * config/darwin-d.c: Moved to... * config/darwin-d.cc: ...here. * config/darwin-driver.c: Moved to... * config/darwin-driver.cc: ...here. * config/darwin-f.c: Moved to... * config/darwin-f.cc: ...here. * config/darwin.c: Moved to... * config/darwin.cc: ...here. * config/default-c.c: Moved to... * config/default-c.cc: ...here. * config/default-d.c: Moved to... * config/default-d.cc: ...here. * config/dragonfly-d.c: Moved to... * config/dragonfly-d.cc: ...here. * config/epiphany/epiphany.c: Moved to... * config/epiphany/epiphany.cc: ...here. * config/epiphany/mode-switch-use.c: Moved to... * config/epiphany/mode-switch-use.cc: ...here. * config/epiphany/resolve-sw-modes.c: Moved to... * config/epiphany/resolve-sw-modes.cc: ...here. * config/fr30/fr30.c: Moved to... * config/fr30/fr30.cc: ...here. * config/freebsd-d.c: Moved to... * config/freebsd-d.cc: ...here. * config/frv/frv.c: Moved to... * config/frv/frv.cc: ...here. * config/ft32/ft32.c: Moved to... * config/ft32/ft32.cc: ...here. * config/gcn/driver-gcn.c: Moved to... * config/gcn/driver-gcn.cc: ...here. * config/gcn/gcn-run.c: Moved to... * config/gcn/gcn-run.cc: ...here. * config/gcn/gcn-tree.c: Moved to... * config/gcn/gcn-tree.cc: ...here. * config/gcn/gcn.c: Moved to... * config/gcn/gcn.cc: ...here. * config/gcn/mkoffload.c: Moved to... * config/gcn/mkoffload.cc: ...here. * config/glibc-c.c: Moved to... * config/glibc-c.cc: ...here. * config/glibc-d.c: Moved to... * config/glibc-d.cc: ...here. * config/h8300/h8300.c: Moved to... * config/h8300/h8300.cc: ...here. * config/host-darwin.c: Moved to... * config/host-darwin.cc: ...here. * config/host-hpux.c: Moved to... * config/host-hpux.cc: ...here. * config/host-linux.c: Moved to... * config/host-linux.cc: ...here. * config/host-netbsd.c: Moved to... * config/host-netbsd.cc: ...here. * config/host-openbsd.c: Moved to... * config/host-openbsd.cc: ...here. * config/host-solaris.c: Moved to... * config/host-solaris.cc: ...here. * config/i386/djgpp.c: Moved to... * config/i386/djgpp.cc: ...here. * config/i386/driver-i386.c: Moved to... * config/i386/driver-i386.cc: ...here. * config/i386/driver-mingw32.c: Moved to... * config/i386/driver-mingw32.cc: ...here. * config/i386/gnu-property.c: Moved to... * config/i386/gnu-property.cc: ...here. * config/i386/host-cygwin.c: Moved to... * config/i386/host-cygwin.cc: ...here. * config/i386/host-i386-darwin.c: Moved to... * config/i386/host-i386-darwin.cc: ...here. * config/i386/host-mingw32.c: Moved to... * config/i386/host-mingw32.cc: ...here. * config/i386/i386-builtins.c: Moved to... * config/i386/i386-builtins.cc: ...here. * config/i386/i386-c.c: Moved to... * config/i386/i386-c.cc: ...here. * config/i386/i386-d.c: Moved to... * config/i386/i386-d.cc: ...here. * config/i386/i386-expand.c: Moved to... * config/i386/i386-expand.cc: ...here. * config/i386/i386-features.c: Moved to... * config/i386/i386-features.cc: ...here. * config/i386/i386-options.c: Moved to... * config/i386/i386-options.cc: ...here. * config/i386/i386.c: Moved to... * config/i386/i386.cc: ...here. * config/i386/intelmic-mkoffload.c: Moved to... * config/i386/intelmic-mkoffload.cc: ...here. * config/i386/msformat-c.c: Moved to... * config/i386/msformat-c.cc: ...here. * config/i386/winnt-cxx.c: Moved to... * config/i386/winnt-cxx.cc: ...here. * config/i386/winnt-d.c: Moved to... * config/i386/winnt-d.cc: ...here. * config/i386/winnt-stubs.c: Moved to... * config/i386/winnt-stubs.cc: ...here. * config/i386/winnt.c: Moved to... * config/i386/winnt.cc: ...here. * config/i386/x86-tune-sched-atom.c: Moved to... * config/i386/x86-tune-sched-atom.cc: ...here. * config/i386/x86-tune-sched-bd.c: Moved to... * config/i386/x86-tune-sched-bd.cc: ...here. * config/i386/x86-tune-sched-core.c: Moved to... * config/i386/x86-tune-sched-core.cc: ...here. * config/i386/x86-tune-sched.c: Moved to... * config/i386/x86-tune-sched.cc: ...here. * config/ia64/ia64-c.c: Moved to... * config/ia64/ia64-c.cc: ...here. * config/ia64/ia64.c: Moved to... * config/ia64/ia64.cc: ...here. * config/iq2000/iq2000.c: Moved to... * config/iq2000/iq2000.cc: ...here. * config/linux.c: Moved to... * config/linux.cc: ...here. * config/lm32/lm32.c: Moved to... * config/lm32/lm32.cc: ...here. * config/m32c/m32c-pragma.c: Moved to... * config/m32c/m32c-pragma.cc: ...here. * config/m32c/m32c.c: Moved to... * config/m32c/m32c.cc: ...here. * config/m32r/m32r.c: Moved to... * config/m32r/m32r.cc: ...here. * config/m68k/m68k.c: Moved to... * config/m68k/m68k.cc: ...here. * config/mcore/mcore.c: Moved to... * config/mcore/mcore.cc: ...here. * config/microblaze/microblaze-c.c: Moved to... * config/microblaze/microblaze-c.cc: ...here. * config/microblaze/microblaze.c: Moved to... * config/microblaze/microblaze.cc: ...here. * config/mips/driver-native.c: Moved to... * config/mips/driver-native.cc: ...here. * config/mips/frame-header-opt.c: Moved to... * config/mips/frame-header-opt.cc: ...here. * config/mips/mips-d.c: Moved to... * config/mips/mips-d.cc: ...here. * config/mips/mips.c: Moved to... * config/mips/mips.cc: ...here. * config/mmix/mmix.c: Moved to... * config/mmix/mmix.cc: ...here. * config/mn10300/mn10300.c: Moved to... * config/mn10300/mn10300.cc: ...here. * config/moxie/moxie.c: Moved to... * config/moxie/moxie.cc: ...here. * config/msp430/driver-msp430.c: Moved to... * config/msp430/driver-msp430.cc: ...here. * config/msp430/msp430-c.c: Moved to... * config/msp430/msp430-c.cc: ...here. * config/msp430/msp430-devices.c: Moved to... * config/msp430/msp430-devices.cc: ...here. * config/msp430/msp430.c: Moved to... * config/msp430/msp430.cc: ...here. * config/nds32/nds32-cost.c: Moved to... * config/nds32/nds32-cost.cc: ...here. * config/nds32/nds32-fp-as-gp.c: Moved to... * config/nds32/nds32-fp-as-gp.cc: ...here. * config/nds32/nds32-intrinsic.c: Moved to... * config/nds32/nds32-intrinsic.cc: ...here. * config/nds32/nds32-isr.c: Moved to... * config/nds32/nds32-isr.cc: ...here. * config/nds32/nds32-md-auxiliary.c: Moved to... * config/nds32/nds32-md-auxiliary.cc: ...here. * config/nds32/nds32-memory-manipulation.c: Moved to... * config/nds32/nds32-memory-manipulation.cc: ...here. * config/nds32/nds32-pipelines-auxiliary.c: Moved to... * config/nds32/nds32-pipelines-auxiliary.cc: ...here. * config/nds32/nds32-predicates.c: Moved to... * config/nds32/nds32-predicates.cc: ...here. * config/nds32/nds32-relax-opt.c: Moved to... * config/nds32/nds32-relax-opt.cc: ...here. * config/nds32/nds32-utils.c: Moved to... * config/nds32/nds32-utils.cc: ...here. * config/nds32/nds32.c: Moved to... * config/nds32/nds32.cc: ...here. * config/netbsd-d.c: Moved to... * config/netbsd-d.cc: ...here. * config/netbsd.c: Moved to... * config/netbsd.cc: ...here. * config/nios2/nios2.c: Moved to... * config/nios2/nios2.cc: ...here. * config/nvptx/mkoffload.c: Moved to... * config/nvptx/mkoffload.cc: ...here. * config/nvptx/nvptx-c.c: Moved to... * config/nvptx/nvptx-c.cc: ...here. * config/nvptx/nvptx.c: Moved to... * config/nvptx/nvptx.cc: ...here. * config/openbsd-d.c: Moved to... * config/openbsd-d.cc: ...here. * config/or1k/or1k.c: Moved to... * config/or1k/or1k.cc: ...here. * config/pa/pa-d.c: Moved to... * config/pa/pa-d.cc: ...here. * config/pa/pa.c: Moved to... * config/pa/pa.cc: ...here. * config/pdp11/pdp11.c: Moved to... * config/pdp11/pdp11.cc: ...here. * config/pru/pru-passes.c: Moved to... * config/pru/pru-passes.cc: ...here. * config/pru/pru-pragma.c: Moved to... * config/pru/pru-pragma.cc: ...here. * config/pru/pru.c: Moved to... * config/pru/pru.cc: ...here. * config/riscv/riscv-builtins.c: Moved to... * config/riscv/riscv-builtins.cc: ...here. * config/riscv/riscv-c.c: Moved to... * config/riscv/riscv-c.cc: ...here. * config/riscv/riscv-d.c: Moved to... * config/riscv/riscv-d.cc: ...here. * config/riscv/riscv-shorten-memrefs.c: Moved to... * config/riscv/riscv-shorten-memrefs.cc: ...here. * config/riscv/riscv-sr.c: Moved to... * config/riscv/riscv-sr.cc: ...here. * config/riscv/riscv.c: Moved to... * config/riscv/riscv.cc: ...here. * config/rl78/rl78-c.c: Moved to... * config/rl78/rl78-c.cc: ...here. * config/rl78/rl78.c: Moved to... * config/rl78/rl78.cc: ...here. * config/rs6000/driver-rs6000.c: Moved to... * config/rs6000/driver-rs6000.cc: ...here. * config/rs6000/host-darwin.c: Moved to... * config/rs6000/host-darwin.cc: ...here. * config/rs6000/host-ppc64-darwin.c: Moved to... * config/rs6000/host-ppc64-darwin.cc: ...here. * config/rs6000/rbtree.c: Moved to... * config/rs6000/rbtree.cc: ...here. * config/rs6000/rs6000-c.c: Moved to... * config/rs6000/rs6000-c.cc: ...here. * config/rs6000/rs6000-call.c: Moved to... * config/rs6000/rs6000-call.cc: ...here. * config/rs6000/rs6000-d.c: Moved to... * config/rs6000/rs6000-d.cc: ...here. * config/rs6000/rs6000-gen-builtins.c: Moved to... * config/rs6000/rs6000-gen-builtins.cc: ...here. * config/rs6000/rs6000-linux.c: Moved to... * config/rs6000/rs6000-linux.cc: ...here. * config/rs6000/rs6000-logue.c: Moved to... * config/rs6000/rs6000-logue.cc: ...here. * config/rs6000/rs6000-p8swap.c: Moved to... * config/rs6000/rs6000-p8swap.cc: ...here. * config/rs6000/rs6000-pcrel-opt.c: Moved to... * config/rs6000/rs6000-pcrel-opt.cc: ...here. * config/rs6000/rs6000-string.c: Moved to... * config/rs6000/rs6000-string.cc: ...here. * config/rs6000/rs6000.c: Moved to... * config/rs6000/rs6000.cc: ...here. * config/rx/rx.c: Moved to... * config/rx/rx.cc: ...here. * config/s390/driver-native.c: Moved to... * config/s390/driver-native.cc: ...here. * config/s390/s390-c.c: Moved to... * config/s390/s390-c.cc: ...here. * config/s390/s390-d.c: Moved to... * config/s390/s390-d.cc: ...here. * config/s390/s390.c: Moved to... * config/s390/s390.cc: ...here. * config/sh/divtab-sh4-300.c: Moved to... * config/sh/divtab-sh4-300.cc: ...here. * config/sh/divtab-sh4.c: Moved to... * config/sh/divtab-sh4.cc: ...here. * config/sh/divtab.c: Moved to... * config/sh/divtab.cc: ...here. * config/sh/sh-c.c: Moved to... * config/sh/sh-c.cc: ...here. * config/sh/sh.c: Moved to... * config/sh/sh.cc: ...here. * config/sol2-c.c: Moved to... * config/sol2-c.cc: ...here. * config/sol2-cxx.c: Moved to... * config/sol2-cxx.cc: ...here. * config/sol2-d.c: Moved to... * config/sol2-d.cc: ...here. * config/sol2-stubs.c: Moved to... * config/sol2-stubs.cc: ...here. * config/sol2.c: Moved to... * config/sol2.cc: ...here. * config/sparc/driver-sparc.c: Moved to... * config/sparc/driver-sparc.cc: ...here. * config/sparc/sparc-c.c: Moved to... * config/sparc/sparc-c.cc: ...here. * config/sparc/sparc-d.c: Moved to... * config/sparc/sparc-d.cc: ...here. * config/sparc/sparc.c: Moved to... * config/sparc/sparc.cc: ...here. * config/stormy16/stormy16.c: Moved to... * config/stormy16/stormy16.cc: ...here. * config/tilegx/mul-tables.c: Moved to... * config/tilegx/mul-tables.cc: ...here. * config/tilegx/tilegx-c.c: Moved to... * config/tilegx/tilegx-c.cc: ...here. * config/tilegx/tilegx.c: Moved to... * config/tilegx/tilegx.cc: ...here. * config/tilepro/mul-tables.c: Moved to... * config/tilepro/mul-tables.cc: ...here. * config/tilepro/tilepro-c.c: Moved to... * config/tilepro/tilepro-c.cc: ...here. * config/tilepro/tilepro.c: Moved to... * config/tilepro/tilepro.cc: ...here. * config/v850/v850-c.c: Moved to... * config/v850/v850-c.cc: ...here. * config/v850/v850.c: Moved to... * config/v850/v850.cc: ...here. * config/vax/vax.c: Moved to... * config/vax/vax.cc: ...here. * config/visium/visium.c: Moved to... * config/visium/visium.cc: ...here. * config/vms/vms-c.c: Moved to... * config/vms/vms-c.cc: ...here. * config/vms/vms-f.c: Moved to... * config/vms/vms-f.cc: ...here. * config/vms/vms.c: Moved to... * config/vms/vms.cc: ...here. * config/vxworks-c.c: Moved to... * config/vxworks-c.cc: ...here. * config/vxworks.c: Moved to... * config/vxworks.cc: ...here. * config/winnt-c.c: Moved to... * config/winnt-c.cc: ...here. * config/xtensa/xtensa.c: Moved to... * config/xtensa/xtensa.cc: ...here. * context.c: Moved to... * context.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * coverage.c: Moved to... * coverage.cc: ...here. * cppbuiltin.c: Moved to... * cppbuiltin.cc: ...here. * cppdefault.c: Moved to... * cppdefault.cc: ...here. * cprop.c: Moved to... * cprop.cc: ...here. * cse.c: Moved to... * cse.cc: ...here. * cselib.c: Moved to... * cselib.cc: ...here. * ctfc.c: Moved to... * ctfc.cc: ...here. * ctfout.c: Moved to... * ctfout.cc: ...here. * data-streamer-in.c: Moved to... * data-streamer-in.cc: ...here. * data-streamer-out.c: Moved to... * data-streamer-out.cc: ...here. * data-streamer.c: Moved to... * data-streamer.cc: ...here. * dbgcnt.c: Moved to... * dbgcnt.cc: ...here. * dbxout.c: Moved to... * dbxout.cc: ...here. * dce.c: Moved to... * dce.cc: ...here. * ddg.c: Moved to... * ddg.cc: ...here. * debug.c: Moved to... * debug.cc: ...here. * df-core.c: Moved to... * df-core.cc: ...here. * df-problems.c: Moved to... * df-problems.cc: ...here. * df-scan.c: Moved to... * df-scan.cc: ...here. * dfp.c: Moved to... * dfp.cc: ...here. * diagnostic-color.c: Moved to... * diagnostic-color.cc: ...here. * diagnostic-show-locus.c: Moved to... * diagnostic-show-locus.cc: ...here. * diagnostic-spec.c: Moved to... * diagnostic-spec.cc: ...here. * diagnostic.c: Moved to... * diagnostic.cc: ...here. * dojump.c: Moved to... * dojump.cc: ...here. * dominance.c: Moved to... * dominance.cc: ...here. * domwalk.c: Moved to... * domwalk.cc: ...here. * double-int.c: Moved to... * double-int.cc: ...here. * dse.c: Moved to... * dse.cc: ...here. * dumpfile.c: Moved to... * dumpfile.cc: ...here. * dwarf2asm.c: Moved to... * dwarf2asm.cc: ...here. * dwarf2cfi.c: Moved to... * dwarf2cfi.cc: ...here. * dwarf2ctf.c: Moved to... * dwarf2ctf.cc: ...here. * dwarf2out.c: Moved to... * dwarf2out.cc: ...here. * early-remat.c: Moved to... * early-remat.cc: ...here. * edit-context.c: Moved to... * edit-context.cc: ...here. * emit-rtl.c: Moved to... * emit-rtl.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * et-forest.c: Moved to... * et-forest.cc: ...here. * except.c: Moved to... * except.cc: ...here. * explow.c: Moved to... * explow.cc: ...here. * expmed.c: Moved to... * expmed.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * fibonacci_heap.c: Moved to... * fibonacci_heap.cc: ...here. * file-find.c: Moved to... * file-find.cc: ...here. * file-prefix-map.c: Moved to... * file-prefix-map.cc: ...here. * final.c: Moved to... * final.cc: ...here. * fixed-value.c: Moved to... * fixed-value.cc: ...here. * fold-const-call.c: Moved to... * fold-const-call.cc: ...here. * fold-const.c: Moved to... * fold-const.cc: ...here. * fp-test.c: Moved to... * fp-test.cc: ...here. * function-tests.c: Moved to... * function-tests.cc: ...here. * function.c: Moved to... * function.cc: ...here. * fwprop.c: Moved to... * fwprop.cc: ...here. * gcc-ar.c: Moved to... * gcc-ar.cc: ...here. * gcc-main.c: Moved to... * gcc-main.cc: ...here. * gcc-rich-location.c: Moved to... * gcc-rich-location.cc: ...here. * gcc.c: Moved to... * gcc.cc: ...here. * gcov-dump.c: Moved to... * gcov-dump.cc: ...here. * gcov-io.c: Moved to... * gcov-io.cc: ...here. * gcov-tool.c: Moved to... * gcov-tool.cc: ...here. * gcov.c: Moved to... * gcov.cc: ...here. * gcse-common.c: Moved to... * gcse-common.cc: ...here. * gcse.c: Moved to... * gcse.cc: ...here. * genattr-common.c: Moved to... * genattr-common.cc: ...here. * genattr.c: Moved to... * genattr.cc: ...here. * genattrtab.c: Moved to... * genattrtab.cc: ...here. * genautomata.c: Moved to... * genautomata.cc: ...here. * gencfn-macros.c: Moved to... * gencfn-macros.cc: ...here. * gencheck.c: Moved to... * gencheck.cc: ...here. * genchecksum.c: Moved to... * genchecksum.cc: ...here. * gencodes.c: Moved to... * gencodes.cc: ...here. * genconditions.c: Moved to... * genconditions.cc: ...here. * genconfig.c: Moved to... * genconfig.cc: ...here. * genconstants.c: Moved to... * genconstants.cc: ...here. * genemit.c: Moved to... * genemit.cc: ...here. * genenums.c: Moved to... * genenums.cc: ...here. * generic-match-head.c: Moved to... * generic-match-head.cc: ...here. * genextract.c: Moved to... * genextract.cc: ...here. * genflags.c: Moved to... * genflags.cc: ...here. * gengenrtl.c: Moved to... * gengenrtl.cc: ...here. * gengtype-parse.c: Moved to... * gengtype-parse.cc: ...here. * gengtype-state.c: Moved to... * gengtype-state.cc: ...here. * gengtype.c: Moved to... * gengtype.cc: ...here. * genhooks.c: Moved to... * genhooks.cc: ...here. * genmatch.c: Moved to... * genmatch.cc: ...here. * genmddeps.c: Moved to... * genmddeps.cc: ...here. * genmddump.c: Moved to... * genmddump.cc: ...here. * genmodes.c: Moved to... * genmodes.cc: ...here. * genopinit.c: Moved to... * genopinit.cc: ...here. * genoutput.c: Moved to... * genoutput.cc: ...here. * genpeep.c: Moved to... * genpeep.cc: ...here. * genpreds.c: Moved to... * genpreds.cc: ...here. * genrecog.c: Moved to... * genrecog.cc: ...here. * gensupport.c: Moved to... * gensupport.cc: ...here. * gentarget-def.c: Moved to... * gentarget-def.cc: ...here. * genversion.c: Moved to... * genversion.cc: ...here. * ggc-common.c: Moved to... * ggc-common.cc: ...here. * ggc-none.c: Moved to... * ggc-none.cc: ...here. * ggc-page.c: Moved to... * ggc-page.cc: ...here. * ggc-tests.c: Moved to... * ggc-tests.cc: ...here. * gimple-builder.c: Moved to... * gimple-builder.cc: ...here. * gimple-expr.c: Moved to... * gimple-expr.cc: ...here. * gimple-fold.c: Moved to... * gimple-fold.cc: ...here. * gimple-iterator.c: Moved to... * gimple-iterator.cc: ...here. * gimple-laddress.c: Moved to... * gimple-laddress.cc: ...here. * gimple-loop-jam.c: Moved to... * gimple-loop-jam.cc: ...here. * gimple-low.c: Moved to... * gimple-low.cc: ...here. * gimple-match-head.c: Moved to... * gimple-match-head.cc: ...here. * gimple-pretty-print.c: Moved to... * gimple-pretty-print.cc: ...here. * gimple-ssa-backprop.c: Moved to... * gimple-ssa-backprop.cc: ...here. * gimple-ssa-evrp-analyze.c: Moved to... * gimple-ssa-evrp-analyze.cc: ...here. * gimple-ssa-evrp.c: Moved to... * gimple-ssa-evrp.cc: ...here. * gimple-ssa-isolate-paths.c: Moved to... * gimple-ssa-isolate-paths.cc: ...here. * gimple-ssa-nonnull-compare.c: Moved to... * gimple-ssa-nonnull-compare.cc: ...here. * gimple-ssa-split-paths.c: Moved to... * gimple-ssa-split-paths.cc: ...here. * gimple-ssa-sprintf.c: Moved to... * gimple-ssa-sprintf.cc: ...here. * gimple-ssa-store-merging.c: Moved to... * gimple-ssa-store-merging.cc: ...here. * gimple-ssa-strength-reduction.c: Moved to... * gimple-ssa-strength-reduction.cc: ...here. * gimple-ssa-warn-alloca.c: Moved to... * gimple-ssa-warn-alloca.cc: ...here. * gimple-ssa-warn-restrict.c: Moved to... * gimple-ssa-warn-restrict.cc: ...here. * gimple-streamer-in.c: Moved to... * gimple-streamer-in.cc: ...here. * gimple-streamer-out.c: Moved to... * gimple-streamer-out.cc: ...here. * gimple-walk.c: Moved to... * gimple-walk.cc: ...here. * gimple-warn-recursion.c: Moved to... * gimple-warn-recursion.cc: ...here. * gimple.c: Moved to... * gimple.cc: ...here. * gimplify-me.c: Moved to... * gimplify-me.cc: ...here. * gimplify.c: Moved to... * gimplify.cc: ...here. * godump.c: Moved to... * godump.cc: ...here. * graph.c: Moved to... * graph.cc: ...here. * graphds.c: Moved to... * graphds.cc: ...here. * graphite-dependences.c: Moved to... * graphite-dependences.cc: ...here. * graphite-isl-ast-to-gimple.c: Moved to... * graphite-isl-ast-to-gimple.cc: ...here. * graphite-optimize-isl.c: Moved to... * graphite-optimize-isl.cc: ...here. * graphite-poly.c: Moved to... * graphite-poly.cc: ...here. * graphite-scop-detection.c: Moved to... * graphite-scop-detection.cc: ...here. * graphite-sese-to-poly.c: Moved to... * graphite-sese-to-poly.cc: ...here. * graphite.c: Moved to... * graphite.cc: ...here. * haifa-sched.c: Moved to... * haifa-sched.cc: ...here. * hash-map-tests.c: Moved to... * hash-map-tests.cc: ...here. * hash-set-tests.c: Moved to... * hash-set-tests.cc: ...here. * hash-table.c: Moved to... * hash-table.cc: ...here. * hooks.c: Moved to... * hooks.cc: ...here. * host-default.c: Moved to... * host-default.cc: ...here. * hw-doloop.c: Moved to... * hw-doloop.cc: ...here. * hwint.c: Moved to... * hwint.cc: ...here. * ifcvt.c: Moved to... * ifcvt.cc: ...here. * inchash.c: Moved to... * inchash.cc: ...here. * incpath.c: Moved to... * incpath.cc: ...here. * init-regs.c: Moved to... * init-regs.cc: ...here. * input.c: Moved to... * input.cc: ...here. * internal-fn.c: Moved to... * internal-fn.cc: ...here. * intl.c: Moved to... * intl.cc: ...here. * ipa-comdats.c: Moved to... * ipa-comdats.cc: ...here. * ipa-cp.c: Moved to... * ipa-cp.cc: ...here. * ipa-devirt.c: Moved to... * ipa-devirt.cc: ...here. * ipa-fnsummary.c: Moved to... * ipa-fnsummary.cc: ...here. * ipa-icf-gimple.c: Moved to... * ipa-icf-gimple.cc: ...here. * ipa-icf.c: Moved to... * ipa-icf.cc: ...here. * ipa-inline-analysis.c: Moved to... * ipa-inline-analysis.cc: ...here. * ipa-inline-transform.c: Moved to... * ipa-inline-transform.cc: ...here. * ipa-inline.c: Moved to... * ipa-inline.cc: ...here. * ipa-modref-tree.c: Moved to... * ipa-modref-tree.cc: ...here. * ipa-modref.c: Moved to... * ipa-modref.cc: ...here. * ipa-param-manipulation.c: Moved to... * ipa-param-manipulation.cc: ...here. * ipa-polymorphic-call.c: Moved to... * ipa-polymorphic-call.cc: ...here. * ipa-predicate.c: Moved to... * ipa-predicate.cc: ...here. * ipa-profile.c: Moved to... * ipa-profile.cc: ...here. * ipa-prop.c: Moved to... * ipa-prop.cc: ...here. * ipa-pure-const.c: Moved to... * ipa-pure-const.cc: ...here. * ipa-ref.c: Moved to... * ipa-ref.cc: ...here. * ipa-reference.c: Moved to... * ipa-reference.cc: ...here. * ipa-split.c: Moved to... * ipa-split.cc: ...here. * ipa-sra.c: Moved to... * ipa-sra.cc: ...here. * ipa-utils.c: Moved to... * ipa-utils.cc: ...here. * ipa-visibility.c: Moved to... * ipa-visibility.cc: ...here. * ipa.c: Moved to... * ipa.cc: ...here. * ira-build.c: Moved to... * ira-build.cc: ...here. * ira-color.c: Moved to... * ira-color.cc: ...here. * ira-conflicts.c: Moved to... * ira-conflicts.cc: ...here. * ira-costs.c: Moved to... * ira-costs.cc: ...here. * ira-emit.c: Moved to... * ira-emit.cc: ...here. * ira-lives.c: Moved to... * ira-lives.cc: ...here. * ira.c: Moved to... * ira.cc: ...here. * jump.c: Moved to... * jump.cc: ...here. * langhooks.c: Moved to... * langhooks.cc: ...here. * lcm.c: Moved to... * lcm.cc: ...here. * lists.c: Moved to... * lists.cc: ...here. * loop-doloop.c: Moved to... * loop-doloop.cc: ...here. * loop-init.c: Moved to... * loop-init.cc: ...here. * loop-invariant.c: Moved to... * loop-invariant.cc: ...here. * loop-iv.c: Moved to... * loop-iv.cc: ...here. * loop-unroll.c: Moved to... * loop-unroll.cc: ...here. * lower-subreg.c: Moved to... * lower-subreg.cc: ...here. * lra-assigns.c: Moved to... * lra-assigns.cc: ...here. * lra-coalesce.c: Moved to... * lra-coalesce.cc: ...here. * lra-constraints.c: Moved to... * lra-constraints.cc: ...here. * lra-eliminations.c: Moved to... * lra-eliminations.cc: ...here. * lra-lives.c: Moved to... * lra-lives.cc: ...here. * lra-remat.c: Moved to... * lra-remat.cc: ...here. * lra-spills.c: Moved to... * lra-spills.cc: ...here. * lra.c: Moved to... * lra.cc: ...here. * lto-cgraph.c: Moved to... * lto-cgraph.cc: ...here. * lto-compress.c: Moved to... * lto-compress.cc: ...here. * lto-opts.c: Moved to... * lto-opts.cc: ...here. * lto-section-in.c: Moved to... * lto-section-in.cc: ...here. * lto-section-out.c: Moved to... * lto-section-out.cc: ...here. * lto-streamer-in.c: Moved to... * lto-streamer-in.cc: ...here. * lto-streamer-out.c: Moved to... * lto-streamer-out.cc: ...here. * lto-streamer.c: Moved to... * lto-streamer.cc: ...here. * lto-wrapper.c: Moved to... * lto-wrapper.cc: ...here. * main.c: Moved to... * main.cc: ...here. * mcf.c: Moved to... * mcf.cc: ...here. * mode-switching.c: Moved to... * mode-switching.cc: ...here. * modulo-sched.c: Moved to... * modulo-sched.cc: ...here. * multiple_target.c: Moved to... * multiple_target.cc: ...here. * omp-expand.c: Moved to... * omp-expand.cc: ...here. * omp-general.c: Moved to... * omp-general.cc: ...here. * omp-low.c: Moved to... * omp-low.cc: ...here. * omp-offload.c: Moved to... * omp-offload.cc: ...here. * omp-simd-clone.c: Moved to... * omp-simd-clone.cc: ...here. * opt-suggestions.c: Moved to... * opt-suggestions.cc: ...here. * optabs-libfuncs.c: Moved to... * optabs-libfuncs.cc: ...here. * optabs-query.c: Moved to... * optabs-query.cc: ...here. * optabs-tree.c: Moved to... * optabs-tree.cc: ...here. * optabs.c: Moved to... * optabs.cc: ...here. * opts-common.c: Moved to... * opts-common.cc: ...here. * opts-global.c: Moved to... * opts-global.cc: ...here. * opts.c: Moved to... * opts.cc: ...here. * passes.c: Moved to... * passes.cc: ...here. * plugin.c: Moved to... * plugin.cc: ...here. * postreload-gcse.c: Moved to... * postreload-gcse.cc: ...here. * postreload.c: Moved to... * postreload.cc: ...here. * predict.c: Moved to... * predict.cc: ...here. * prefix.c: Moved to... * prefix.cc: ...here. * pretty-print.c: Moved to... * pretty-print.cc: ...here. * print-rtl-function.c: Moved to... * print-rtl-function.cc: ...here. * print-rtl.c: Moved to... * print-rtl.cc: ...here. * print-tree.c: Moved to... * print-tree.cc: ...here. * profile-count.c: Moved to... * profile-count.cc: ...here. * profile.c: Moved to... * profile.cc: ...here. * read-md.c: Moved to... * read-md.cc: ...here. * read-rtl-function.c: Moved to... * read-rtl-function.cc: ...here. * read-rtl.c: Moved to... * read-rtl.cc: ...here. * real.c: Moved to... * real.cc: ...here. * realmpfr.c: Moved to... * realmpfr.cc: ...here. * recog.c: Moved to... * recog.cc: ...here. * ree.c: Moved to... * ree.cc: ...here. * reg-stack.c: Moved to... * reg-stack.cc: ...here. * regcprop.c: Moved to... * regcprop.cc: ...here. * reginfo.c: Moved to... * reginfo.cc: ...here. * regrename.c: Moved to... * regrename.cc: ...here. * regstat.c: Moved to... * regstat.cc: ...here. * reload.c: Moved to... * reload.cc: ...here. * reload1.c: Moved to... * reload1.cc: ...here. * reorg.c: Moved to... * reorg.cc: ...here. * resource.c: Moved to... * resource.cc: ...here. * rtl-error.c: Moved to... * rtl-error.cc: ...here. * rtl-tests.c: Moved to... * rtl-tests.cc: ...here. * rtl.c: Moved to... * rtl.cc: ...here. * rtlanal.c: Moved to... * rtlanal.cc: ...here. * rtlhash.c: Moved to... * rtlhash.cc: ...here. * rtlhooks.c: Moved to... * rtlhooks.cc: ...here. * rtx-vector-builder.c: Moved to... * rtx-vector-builder.cc: ...here. * run-rtl-passes.c: Moved to... * run-rtl-passes.cc: ...here. * sancov.c: Moved to... * sancov.cc: ...here. * sanopt.c: Moved to... * sanopt.cc: ...here. * sbitmap.c: Moved to... * sbitmap.cc: ...here. * sched-deps.c: Moved to... * sched-deps.cc: ...here. * sched-ebb.c: Moved to... * sched-ebb.cc: ...here. * sched-rgn.c: Moved to... * sched-rgn.cc: ...here. * sel-sched-dump.c: Moved to... * sel-sched-dump.cc: ...here. * sel-sched-ir.c: Moved to... * sel-sched-ir.cc: ...here. * sel-sched.c: Moved to... * sel-sched.cc: ...here. * selftest-diagnostic.c: Moved to... * selftest-diagnostic.cc: ...here. * selftest-rtl.c: Moved to... * selftest-rtl.cc: ...here. * selftest-run-tests.c: Moved to... * selftest-run-tests.cc: ...here. * selftest.c: Moved to... * selftest.cc: ...here. * sese.c: Moved to... * sese.cc: ...here. * shrink-wrap.c: Moved to... * shrink-wrap.cc: ...here. * simplify-rtx.c: Moved to... * simplify-rtx.cc: ...here. * sparseset.c: Moved to... * sparseset.cc: ...here. * spellcheck-tree.c: Moved to... * spellcheck-tree.cc: ...here. * spellcheck.c: Moved to... * spellcheck.cc: ...here. * sreal.c: Moved to... * sreal.cc: ...here. * stack-ptr-mod.c: Moved to... * stack-ptr-mod.cc: ...here. * statistics.c: Moved to... * statistics.cc: ...here. * stmt.c: Moved to... * stmt.cc: ...here. * stor-layout.c: Moved to... * stor-layout.cc: ...here. * store-motion.c: Moved to... * store-motion.cc: ...here. * streamer-hooks.c: Moved to... * streamer-hooks.cc: ...here. * stringpool.c: Moved to... * stringpool.cc: ...here. * substring-locations.c: Moved to... * substring-locations.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * target-globals.c: Moved to... * target-globals.cc: ...here. * targhooks.c: Moved to... * targhooks.cc: ...here. * timevar.c: Moved to... * timevar.cc: ...here. * toplev.c: Moved to... * toplev.cc: ...here. * tracer.c: Moved to... * tracer.cc: ...here. * trans-mem.c: Moved to... * trans-mem.cc: ...here. * tree-affine.c: Moved to... * tree-affine.cc: ...here. * tree-call-cdce.c: Moved to... * tree-call-cdce.cc: ...here. * tree-cfg.c: Moved to... * tree-cfg.cc: ...here. * tree-cfgcleanup.c: Moved to... * tree-cfgcleanup.cc: ...here. * tree-chrec.c: Moved to... * tree-chrec.cc: ...here. * tree-complex.c: Moved to... * tree-complex.cc: ...here. * tree-data-ref.c: Moved to... * tree-data-ref.cc: ...here. * tree-dfa.c: Moved to... * tree-dfa.cc: ...here. * tree-diagnostic.c: Moved to... * tree-diagnostic.cc: ...here. * tree-dump.c: Moved to... * tree-dump.cc: ...here. * tree-eh.c: Moved to... * tree-eh.cc: ...here. * tree-emutls.c: Moved to... * tree-emutls.cc: ...here. * tree-if-conv.c: Moved to... * tree-if-conv.cc: ...here. * tree-inline.c: Moved to... * tree-inline.cc: ...here. * tree-into-ssa.c: Moved to... * tree-into-ssa.cc: ...here. * tree-iterator.c: Moved to... * tree-iterator.cc: ...here. * tree-loop-distribution.c: Moved to... * tree-loop-distribution.cc: ...here. * tree-nested.c: Moved to... * tree-nested.cc: ...here. * tree-nrv.c: Moved to... * tree-nrv.cc: ...here. * tree-object-size.c: Moved to... * tree-object-size.cc: ...here. * tree-outof-ssa.c: Moved to... * tree-outof-ssa.cc: ...here. * tree-parloops.c: Moved to... * tree-parloops.cc: ...here. * tree-phinodes.c: Moved to... * tree-phinodes.cc: ...here. * tree-predcom.c: Moved to... * tree-predcom.cc: ...here. * tree-pretty-print.c: Moved to... * tree-pretty-print.cc: ...here. * tree-profile.c: Moved to... * tree-profile.cc: ...here. * tree-scalar-evolution.c: Moved to... * tree-scalar-evolution.cc: ...here. * tree-sra.c: Moved to... * tree-sra.cc: ...here. * tree-ssa-address.c: Moved to... * tree-ssa-address.cc: ...here. * tree-ssa-alias.c: Moved to... * tree-ssa-alias.cc: ...here. * tree-ssa-ccp.c: Moved to... * tree-ssa-ccp.cc: ...here. * tree-ssa-coalesce.c: Moved to... * tree-ssa-coalesce.cc: ...here. * tree-ssa-copy.c: Moved to... * tree-ssa-copy.cc: ...here. * tree-ssa-dce.c: Moved to... * tree-ssa-dce.cc: ...here. * tree-ssa-dom.c: Moved to... * tree-ssa-dom.cc: ...here. * tree-ssa-dse.c: Moved to... * tree-ssa-dse.cc: ...here. * tree-ssa-forwprop.c: Moved to... * tree-ssa-forwprop.cc: ...here. * tree-ssa-ifcombine.c: Moved to... * tree-ssa-ifcombine.cc: ...here. * tree-ssa-live.c: Moved to... * tree-ssa-live.cc: ...here. * tree-ssa-loop-ch.c: Moved to... * tree-ssa-loop-ch.cc: ...here. * tree-ssa-loop-im.c: Moved to... * tree-ssa-loop-im.cc: ...here. * tree-ssa-loop-ivcanon.c: Moved to... * tree-ssa-loop-ivcanon.cc: ...here. * tree-ssa-loop-ivopts.c: Moved to... * tree-ssa-loop-ivopts.cc: ...here. * tree-ssa-loop-manip.c: Moved to... * tree-ssa-loop-manip.cc: ...here. * tree-ssa-loop-niter.c: Moved to... * tree-ssa-loop-niter.cc: ...here. * tree-ssa-loop-prefetch.c: Moved to... * tree-ssa-loop-prefetch.cc: ...here. * tree-ssa-loop-split.c: Moved to... * tree-ssa-loop-split.cc: ...here. * tree-ssa-loop-unswitch.c: Moved to... * tree-ssa-loop-unswitch.cc: ...here. * tree-ssa-loop.c: Moved to... * tree-ssa-loop.cc: ...here. * tree-ssa-math-opts.c: Moved to... * tree-ssa-math-opts.cc: ...here. * tree-ssa-operands.c: Moved to... * tree-ssa-operands.cc: ...here. * tree-ssa-phiopt.c: Moved to... * tree-ssa-phiopt.cc: ...here. * tree-ssa-phiprop.c: Moved to... * tree-ssa-phiprop.cc: ...here. * tree-ssa-pre.c: Moved to... * tree-ssa-pre.cc: ...here. * tree-ssa-propagate.c: Moved to... * tree-ssa-propagate.cc: ...here. * tree-ssa-reassoc.c: Moved to... * tree-ssa-reassoc.cc: ...here. * tree-ssa-sccvn.c: Moved to... * tree-ssa-sccvn.cc: ...here. * tree-ssa-scopedtables.c: Moved to... * tree-ssa-scopedtables.cc: ...here. * tree-ssa-sink.c: Moved to... * tree-ssa-sink.cc: ...here. * tree-ssa-strlen.c: Moved to... * tree-ssa-strlen.cc: ...here. * tree-ssa-structalias.c: Moved to... * tree-ssa-structalias.cc: ...here. * tree-ssa-tail-merge.c: Moved to... * tree-ssa-tail-merge.cc: ...here. * tree-ssa-ter.c: Moved to... * tree-ssa-ter.cc: ...here. * tree-ssa-threadbackward.c: Moved to... * tree-ssa-threadbackward.cc: ...here. * tree-ssa-threadedge.c: Moved to... * tree-ssa-threadedge.cc: ...here. * tree-ssa-threadupdate.c: Moved to... * tree-ssa-threadupdate.cc: ...here. * tree-ssa-uncprop.c: Moved to... * tree-ssa-uncprop.cc: ...here. * tree-ssa-uninit.c: Moved to... * tree-ssa-uninit.cc: ...here. * tree-ssa.c: Moved to... * tree-ssa.cc: ...here. * tree-ssanames.c: Moved to... * tree-ssanames.cc: ...here. * tree-stdarg.c: Moved to... * tree-stdarg.cc: ...here. * tree-streamer-in.c: Moved to... * tree-streamer-in.cc: ...here. * tree-streamer-out.c: Moved to... * tree-streamer-out.cc: ...here. * tree-streamer.c: Moved to... * tree-streamer.cc: ...here. * tree-switch-conversion.c: Moved to... * tree-switch-conversion.cc: ...here. * tree-tailcall.c: Moved to... * tree-tailcall.cc: ...here. * tree-vect-data-refs.c: Moved to... * tree-vect-data-refs.cc: ...here. * tree-vect-generic.c: Moved to... * tree-vect-generic.cc: ...here. * tree-vect-loop-manip.c: Moved to... * tree-vect-loop-manip.cc: ...here. * tree-vect-loop.c: Moved to... * tree-vect-loop.cc: ...here. * tree-vect-patterns.c: Moved to... * tree-vect-patterns.cc: ...here. * tree-vect-slp-patterns.c: Moved to... * tree-vect-slp-patterns.cc: ...here. * tree-vect-slp.c: Moved to... * tree-vect-slp.cc: ...here. * tree-vect-stmts.c: Moved to... * tree-vect-stmts.cc: ...here. * tree-vector-builder.c: Moved to... * tree-vector-builder.cc: ...here. * tree-vectorizer.c: Moved to... * tree-vectorizer.cc: ...here. * tree-vrp.c: Moved to... * tree-vrp.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * tsan.c: Moved to... * tsan.cc: ...here. * typed-splay-tree.c: Moved to... * typed-splay-tree.cc: ...here. * ubsan.c: Moved to... * ubsan.cc: ...here. * valtrack.c: Moved to... * valtrack.cc: ...here. * value-prof.c: Moved to... * value-prof.cc: ...here. * var-tracking.c: Moved to... * var-tracking.cc: ...here. * varasm.c: Moved to... * varasm.cc: ...here. * varpool.c: Moved to... * varpool.cc: ...here. * vec-perm-indices.c: Moved to... * vec-perm-indices.cc: ...here. * vec.c: Moved to... * vec.cc: ...here. * vmsdbgout.c: Moved to... * vmsdbgout.cc: ...here. * vr-values.c: Moved to... * vr-values.cc: ...here. * vtable-verify.c: Moved to... * vtable-verify.cc: ...here. * web.c: Moved to... * web.cc: ...here. * xcoffout.c: Moved to... * xcoffout.cc: ...here. gcc/c-family/ChangeLog: * c-ada-spec.c: Moved to... * c-ada-spec.cc: ...here. * c-attribs.c: Moved to... * c-attribs.cc: ...here. * c-common.c: Moved to... * c-common.cc: ...here. * c-cppbuiltin.c: Moved to... * c-cppbuiltin.cc: ...here. * c-dump.c: Moved to... * c-dump.cc: ...here. * c-format.c: Moved to... * c-format.cc: ...here. * c-gimplify.c: Moved to... * c-gimplify.cc: ...here. * c-indentation.c: Moved to... * c-indentation.cc: ...here. * c-lex.c: Moved to... * c-lex.cc: ...here. * c-omp.c: Moved to... * c-omp.cc: ...here. * c-opts.c: Moved to... * c-opts.cc: ...here. * c-pch.c: Moved to... * c-pch.cc: ...here. * c-ppoutput.c: Moved to... * c-ppoutput.cc: ...here. * c-pragma.c: Moved to... * c-pragma.cc: ...here. * c-pretty-print.c: Moved to... * c-pretty-print.cc: ...here. * c-semantics.c: Moved to... * c-semantics.cc: ...here. * c-ubsan.c: Moved to... * c-ubsan.cc: ...here. * c-warn.c: Moved to... * c-warn.cc: ...here. * cppspec.c: Moved to... * cppspec.cc: ...here. * stub-objc.c: Moved to... * stub-objc.cc: ...here. gcc/c/ChangeLog: * c-aux-info.c: Moved to... * c-aux-info.cc: ...here. * c-convert.c: Moved to... * c-convert.cc: ...here. * c-decl.c: Moved to... * c-decl.cc: ...here. * c-errors.c: Moved to... * c-errors.cc: ...here. * c-fold.c: Moved to... * c-fold.cc: ...here. * c-lang.c: Moved to... * c-lang.cc: ...here. * c-objc-common.c: Moved to... * c-objc-common.cc: ...here. * c-parser.c: Moved to... * c-parser.cc: ...here. * c-typeck.c: Moved to... * c-typeck.cc: ...here. * gccspec.c: Moved to... * gccspec.cc: ...here. * gimple-parser.c: Moved to... * gimple-parser.cc: ...here. gcc/cp/ChangeLog: * call.c: Moved to... * call.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constexpr.c: Moved to... * constexpr.cc: ...here. * cp-gimplify.c: Moved to... * cp-gimplify.cc: ...here. * cp-lang.c: Moved to... * cp-lang.cc: ...here. * cp-objcp-common.c: Moved to... * cp-objcp-common.cc: ...here. * cp-ubsan.c: Moved to... * cp-ubsan.cc: ...here. * cvt.c: Moved to... * cvt.cc: ...here. * cxx-pretty-print.c: Moved to... * cxx-pretty-print.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * decl2.c: Moved to... * decl2.cc: ...here. * dump.c: Moved to... * dump.cc: ...here. * error.c: Moved to... * error.cc: ...here. * except.c: Moved to... * except.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * friend.c: Moved to... * friend.cc: ...here. * g++spec.c: Moved to... * g++spec.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lambda.c: Moved to... * lambda.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * mangle.c: Moved to... * mangle.cc: ...here. * method.c: Moved to... * method.cc: ...here. * name-lookup.c: Moved to... * name-lookup.cc: ...here. * optimize.c: Moved to... * optimize.cc: ...here. * parser.c: Moved to... * parser.cc: ...here. * pt.c: Moved to... * pt.cc: ...here. * ptree.c: Moved to... * ptree.cc: ...here. * rtti.c: Moved to... * rtti.cc: ...here. * search.c: Moved to... * search.cc: ...here. * semantics.c: Moved to... * semantics.cc: ...here. * tree.c: Moved to... * tree.cc: ...here. * typeck.c: Moved to... * typeck.cc: ...here. * typeck2.c: Moved to... * typeck2.cc: ...here. * vtable-class-hierarchy.c: Moved to... * vtable-class-hierarchy.cc: ...here. gcc/fortran/ChangeLog: * arith.c: Moved to... * arith.cc: ...here. * array.c: Moved to... * array.cc: ...here. * bbt.c: Moved to... * bbt.cc: ...here. * check.c: Moved to... * check.cc: ...here. * class.c: Moved to... * class.cc: ...here. * constructor.c: Moved to... * constructor.cc: ...here. * convert.c: Moved to... * convert.cc: ...here. * cpp.c: Moved to... * cpp.cc: ...here. * data.c: Moved to... * data.cc: ...here. * decl.c: Moved to... * decl.cc: ...here. * dependency.c: Moved to... * dependency.cc: ...here. * dump-parse-tree.c: Moved to... * dump-parse-tree.cc: ...here. * error.c: Moved to... * error.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * f95-lang.c: Moved to... * f95-lang.cc: ...here. * frontend-passes.c: Moved to... * frontend-passes.cc: ...here. * gfortranspec.c: Moved to... * gfortranspec.cc: ...here. * interface.c: Moved to... * interface.cc: ...here. * intrinsic.c: Moved to... * intrinsic.cc: ...here. * io.c: Moved to... * io.cc: ...here. * iresolve.c: Moved to... * iresolve.cc: ...here. * match.c: Moved to... * match.cc: ...here. * matchexp.c: Moved to... * matchexp.cc: ...here. * misc.c: Moved to... * misc.cc: ...here. * module.c: Moved to... * module.cc: ...here. * openmp.c: Moved to... * openmp.cc: ...here. * options.c: Moved to... * options.cc: ...here. * parse.c: Moved to... * parse.cc: ...here. * primary.c: Moved to... * primary.cc: ...here. * resolve.c: Moved to... * resolve.cc: ...here. * scanner.c: Moved to... * scanner.cc: ...here. * simplify.c: Moved to... * simplify.cc: ...here. * st.c: Moved to... * st.cc: ...here. * symbol.c: Moved to... * symbol.cc: ...here. * target-memory.c: Moved to... * target-memory.cc: ...here. * trans-array.c: Moved to... * trans-array.cc: ...here. * trans-common.c: Moved to... * trans-common.cc: ...here. * trans-const.c: Moved to... * trans-const.cc: ...here. * trans-decl.c: Moved to... * trans-decl.cc: ...here. * trans-expr.c: Moved to... * trans-expr.cc: ...here. * trans-intrinsic.c: Moved to... * trans-intrinsic.cc: ...here. * trans-io.c: Moved to... * trans-io.cc: ...here. * trans-openmp.c: Moved to... * trans-openmp.cc: ...here. * trans-stmt.c: Moved to... * trans-stmt.cc: ...here. * trans-types.c: Moved to... * trans-types.cc: ...here. * trans.c: Moved to... * trans.cc: ...here. gcc/go/ChangeLog: * go-backend.c: Moved to... * go-backend.cc: ...here. * go-lang.c: Moved to... * go-lang.cc: ...here. * gospec.c: Moved to... * gospec.cc: ...here. gcc/jit/ChangeLog: * dummy-frontend.c: Moved to... * dummy-frontend.cc: ...here. * jit-builtins.c: Moved to... * jit-builtins.cc: ...here. * jit-logging.c: Moved to... * jit-logging.cc: ...here. * jit-playback.c: Moved to... * jit-playback.cc: ...here. * jit-recording.c: Moved to... * jit-recording.cc: ...here. * jit-result.c: Moved to... * jit-result.cc: ...here. * jit-spec.c: Moved to... * jit-spec.cc: ...here. * jit-tempdir.c: Moved to... * jit-tempdir.cc: ...here. * jit-w32.c: Moved to... * jit-w32.cc: ...here. * libgccjit.c: Moved to... * libgccjit.cc: ...here. gcc/lto/ChangeLog: * common.c: Moved to... * common.cc: ...here. * lto-common.c: Moved to... * lto-common.cc: ...here. * lto-dump.c: Moved to... * lto-dump.cc: ...here. * lto-lang.c: Moved to... * lto-lang.cc: ...here. * lto-object.c: Moved to... * lto-object.cc: ...here. * lto-partition.c: Moved to... * lto-partition.cc: ...here. * lto-symtab.c: Moved to... * lto-symtab.cc: ...here. * lto.c: Moved to... * lto.cc: ...here. gcc/objc/ChangeLog: * objc-act.c: Moved to... * objc-act.cc: ...here. * objc-encoding.c: Moved to... * objc-encoding.cc: ...here. * objc-gnu-runtime-abi-01.c: Moved to... * objc-gnu-runtime-abi-01.cc: ...here. * objc-lang.c: Moved to... * objc-lang.cc: ...here. * objc-map.c: Moved to... * objc-map.cc: ...here. * objc-next-runtime-abi-01.c: Moved to... * objc-next-runtime-abi-01.cc: ...here. * objc-next-runtime-abi-02.c: Moved to... * objc-next-runtime-abi-02.cc: ...here. * objc-runtime-shared-support.c: Moved to... * objc-runtime-shared-support.cc: ...here. gcc/objcp/ChangeLog: * objcp-decl.c: Moved to... * objcp-decl.cc: ...here. * objcp-lang.c: Moved to... * objcp-lang.cc: ...here. libcpp/ChangeLog: * charset.c: Moved to... * charset.cc: ...here. * directives.c: Moved to... * directives.cc: ...here. * errors.c: Moved to... * errors.cc: ...here. * expr.c: Moved to... * expr.cc: ...here. * files.c: Moved to... * files.cc: ...here. * identifiers.c: Moved to... * identifiers.cc: ...here. * init.c: Moved to... * init.cc: ...here. * lex.c: Moved to... * lex.cc: ...here. * line-map.c: Moved to... * line-map.cc: ...here. * macro.c: Moved to... * macro.cc: ...here. * makeucnid.c: Moved to... * makeucnid.cc: ...here. * mkdeps.c: Moved to... * mkdeps.cc: ...here. * pch.c: Moved to... * pch.cc: ...here. * symtab.c: Moved to... * symtab.cc: ...here. * traditional.c: Moved to... * traditional.cc: ...here. --- gcc/fortran/arith.c | 2706 ------ gcc/fortran/arith.cc | 2706 ++++++ gcc/fortran/array.c | 2785 ------- gcc/fortran/array.cc | 2785 +++++++ gcc/fortran/bbt.c | 198 - gcc/fortran/bbt.cc | 198 + gcc/fortran/check.c | 7523 ----------------- gcc/fortran/check.cc | 7523 +++++++++++++++++ gcc/fortran/class.c | 3073 ------- gcc/fortran/class.cc | 3073 +++++++ gcc/fortran/constructor.c | 261 - gcc/fortran/constructor.cc | 261 + gcc/fortran/convert.c | 121 - gcc/fortran/convert.cc | 121 + gcc/fortran/cpp.c | 1203 --- gcc/fortran/cpp.cc | 1203 +++ gcc/fortran/data.c | 848 -- gcc/fortran/data.cc | 848 ++ gcc/fortran/decl.c | 11910 -------------------------- gcc/fortran/decl.cc | 11910 ++++++++++++++++++++++++++ gcc/fortran/dependency.c | 2336 ------ gcc/fortran/dependency.cc | 2336 ++++++ gcc/fortran/dump-parse-tree.c | 3924 --------- gcc/fortran/dump-parse-tree.cc | 3924 +++++++++ gcc/fortran/error.c | 1656 ---- gcc/fortran/error.cc | 1656 ++++ gcc/fortran/expr.c | 6507 --------------- gcc/fortran/expr.cc | 6507 +++++++++++++++ gcc/fortran/f95-lang.c | 1306 --- gcc/fortran/f95-lang.cc | 1306 +++ gcc/fortran/frontend-passes.c | 5951 ------------- gcc/fortran/frontend-passes.cc | 5951 +++++++++++++ gcc/fortran/gfortranspec.c | 450 - gcc/fortran/gfortranspec.cc | 450 + gcc/fortran/interface.c | 5589 ------------- gcc/fortran/interface.cc | 5589 +++++++++++++ gcc/fortran/intrinsic.c | 5503 ------------ gcc/fortran/intrinsic.cc | 5503 ++++++++++++ gcc/fortran/io.c | 4899 ----------- gcc/fortran/io.cc | 4899 +++++++++++ gcc/fortran/iresolve.c | 4050 --------- gcc/fortran/iresolve.cc | 4050 +++++++++ gcc/fortran/match.c | 7264 ---------------- gcc/fortran/match.cc | 7264 ++++++++++++++++ gcc/fortran/matchexp.c | 903 -- gcc/fortran/matchexp.cc | 903 ++ gcc/fortran/misc.c | 460 - gcc/fortran/misc.cc | 460 + gcc/fortran/module.c | 7581 ----------------- gcc/fortran/module.cc | 7581 +++++++++++++++++ gcc/fortran/openmp.c | 9411 --------------------- gcc/fortran/openmp.cc | 9411 +++++++++++++++++++++ gcc/fortran/options.c | 914 -- gcc/fortran/options.cc | 914 ++ gcc/fortran/parse.c | 6987 ---------------- gcc/fortran/parse.cc | 6987 ++++++++++++++++ gcc/fortran/primary.c | 4175 ---------- gcc/fortran/primary.cc | 4175 ++++++++++ gcc/fortran/resolve.c | 17582 --------------------------------------- gcc/fortran/resolve.cc | 17582 +++++++++++++++++++++++++++++++++++++++ gcc/fortran/scanner.c | 2903 ------- gcc/fortran/scanner.cc | 2903 +++++++ gcc/fortran/simplify.c | 8966 -------------------- gcc/fortran/simplify.cc | 8966 ++++++++++++++++++++ gcc/fortran/st.c | 334 - gcc/fortran/st.cc | 334 + gcc/fortran/symbol.c | 5251 ------------ gcc/fortran/symbol.cc | 5251 ++++++++++++ gcc/fortran/target-memory.c | 806 -- gcc/fortran/target-memory.cc | 806 ++ gcc/fortran/trans-array.c | 11714 -------------------------- gcc/fortran/trans-array.cc | 11714 ++++++++++++++++++++++++++ gcc/fortran/trans-common.c | 1392 ---- gcc/fortran/trans-common.cc | 1392 ++++ gcc/fortran/trans-const.c | 430 - gcc/fortran/trans-const.cc | 430 + gcc/fortran/trans-decl.c | 7956 ------------------ gcc/fortran/trans-decl.cc | 7956 ++++++++++++++++++ gcc/fortran/trans-expr.c | 12125 --------------------------- gcc/fortran/trans-expr.cc | 12125 +++++++++++++++++++++++++++ gcc/fortran/trans-intrinsic.c | 12457 --------------------------- gcc/fortran/trans-intrinsic.cc | 12457 +++++++++++++++++++++++++++ gcc/fortran/trans-io.c | 2686 ------ gcc/fortran/trans-io.cc | 2686 ++++++ gcc/fortran/trans-openmp.c | 7701 ----------------- gcc/fortran/trans-openmp.cc | 7701 +++++++++++++++++ gcc/fortran/trans-stmt.c | 7468 ----------------- gcc/fortran/trans-stmt.cc | 7468 +++++++++++++++++ gcc/fortran/trans-types.c | 3838 --------- gcc/fortran/trans-types.cc | 3838 +++++++++ gcc/fortran/trans.c | 2452 ------ gcc/fortran/trans.cc | 2452 ++++++ 92 files changed, 216555 insertions(+), 216555 deletions(-) delete mode 100644 gcc/fortran/arith.c create mode 100644 gcc/fortran/arith.cc delete mode 100644 gcc/fortran/array.c create mode 100644 gcc/fortran/array.cc delete mode 100644 gcc/fortran/bbt.c create mode 100644 gcc/fortran/bbt.cc delete mode 100644 gcc/fortran/check.c create mode 100644 gcc/fortran/check.cc delete mode 100644 gcc/fortran/class.c create mode 100644 gcc/fortran/class.cc delete mode 100644 gcc/fortran/constructor.c create mode 100644 gcc/fortran/constructor.cc delete mode 100644 gcc/fortran/convert.c create mode 100644 gcc/fortran/convert.cc delete mode 100644 gcc/fortran/cpp.c create mode 100644 gcc/fortran/cpp.cc delete mode 100644 gcc/fortran/data.c create mode 100644 gcc/fortran/data.cc delete mode 100644 gcc/fortran/decl.c create mode 100644 gcc/fortran/decl.cc delete mode 100644 gcc/fortran/dependency.c create mode 100644 gcc/fortran/dependency.cc delete mode 100644 gcc/fortran/dump-parse-tree.c create mode 100644 gcc/fortran/dump-parse-tree.cc delete mode 100644 gcc/fortran/error.c create mode 100644 gcc/fortran/error.cc delete mode 100644 gcc/fortran/expr.c create mode 100644 gcc/fortran/expr.cc delete mode 100644 gcc/fortran/f95-lang.c create mode 100644 gcc/fortran/f95-lang.cc delete mode 100644 gcc/fortran/frontend-passes.c create mode 100644 gcc/fortran/frontend-passes.cc delete mode 100644 gcc/fortran/gfortranspec.c create mode 100644 gcc/fortran/gfortranspec.cc delete mode 100644 gcc/fortran/interface.c create mode 100644 gcc/fortran/interface.cc delete mode 100644 gcc/fortran/intrinsic.c create mode 100644 gcc/fortran/intrinsic.cc delete mode 100644 gcc/fortran/io.c create mode 100644 gcc/fortran/io.cc delete mode 100644 gcc/fortran/iresolve.c create mode 100644 gcc/fortran/iresolve.cc delete mode 100644 gcc/fortran/match.c create mode 100644 gcc/fortran/match.cc delete mode 100644 gcc/fortran/matchexp.c create mode 100644 gcc/fortran/matchexp.cc delete mode 100644 gcc/fortran/misc.c create mode 100644 gcc/fortran/misc.cc delete mode 100644 gcc/fortran/module.c create mode 100644 gcc/fortran/module.cc delete mode 100644 gcc/fortran/openmp.c create mode 100644 gcc/fortran/openmp.cc delete mode 100644 gcc/fortran/options.c create mode 100644 gcc/fortran/options.cc delete mode 100644 gcc/fortran/parse.c create mode 100644 gcc/fortran/parse.cc delete mode 100644 gcc/fortran/primary.c create mode 100644 gcc/fortran/primary.cc delete mode 100644 gcc/fortran/resolve.c create mode 100644 gcc/fortran/resolve.cc delete mode 100644 gcc/fortran/scanner.c create mode 100644 gcc/fortran/scanner.cc delete mode 100644 gcc/fortran/simplify.c create mode 100644 gcc/fortran/simplify.cc delete mode 100644 gcc/fortran/st.c create mode 100644 gcc/fortran/st.cc delete mode 100644 gcc/fortran/symbol.c create mode 100644 gcc/fortran/symbol.cc delete mode 100644 gcc/fortran/target-memory.c create mode 100644 gcc/fortran/target-memory.cc delete mode 100644 gcc/fortran/trans-array.c create mode 100644 gcc/fortran/trans-array.cc delete mode 100644 gcc/fortran/trans-common.c create mode 100644 gcc/fortran/trans-common.cc delete mode 100644 gcc/fortran/trans-const.c create mode 100644 gcc/fortran/trans-const.cc delete mode 100644 gcc/fortran/trans-decl.c create mode 100644 gcc/fortran/trans-decl.cc delete mode 100644 gcc/fortran/trans-expr.c create mode 100644 gcc/fortran/trans-expr.cc delete mode 100644 gcc/fortran/trans-intrinsic.c create mode 100644 gcc/fortran/trans-intrinsic.cc delete mode 100644 gcc/fortran/trans-io.c create mode 100644 gcc/fortran/trans-io.cc delete mode 100644 gcc/fortran/trans-openmp.c create mode 100644 gcc/fortran/trans-openmp.cc delete mode 100644 gcc/fortran/trans-stmt.c create mode 100644 gcc/fortran/trans-stmt.cc delete mode 100644 gcc/fortran/trans-types.c create mode 100644 gcc/fortran/trans-types.cc delete mode 100644 gcc/fortran/trans.c create mode 100644 gcc/fortran/trans.cc (limited to 'gcc/fortran') diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c deleted file mode 100644 index b3323ec..0000000 --- a/gcc/fortran/arith.c +++ /dev/null @@ -1,2706 +0,0 @@ -/* Compiler arithmetic - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -/* Since target arithmetic must be done on the host, there has to - be some way of evaluating arithmetic expressions as the host - would evaluate them. We use the GNU MP library and the MPFR - library to do arithmetic, and this file provides the interface. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "arith.h" -#include "target-memory.h" -#include "constructor.h" - -bool gfc_seen_div0; - -/* MPFR does not have a direct replacement for mpz_set_f() from GMP. - It's easily implemented with a few calls though. */ - -void -gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where) -{ - mpfr_exp_t e; - - if (mpfr_inf_p (x) || mpfr_nan_p (x)) - { - gfc_error ("Conversion of an Infinity or Not-a-Number at %L " - "to INTEGER", where); - mpz_set_ui (z, 0); - return; - } - - e = mpfr_get_z_exp (z, x); - - if (e > 0) - mpz_mul_2exp (z, z, e); - else - mpz_tdiv_q_2exp (z, z, -e); -} - - -/* Set the model number precision by the requested KIND. */ - -void -gfc_set_model_kind (int kind) -{ - int index = gfc_validate_kind (BT_REAL, kind, false); - int base2prec; - - base2prec = gfc_real_kinds[index].digits; - if (gfc_real_kinds[index].radix != 2) - base2prec *= gfc_real_kinds[index].radix / 2; - mpfr_set_default_prec (base2prec); -} - - -/* Set the model number precision from mpfr_t x. */ - -void -gfc_set_model (mpfr_t x) -{ - mpfr_set_default_prec (mpfr_get_prec (x)); -} - - -/* Given an arithmetic error code, return a pointer to a string that - explains the error. */ - -static const char * -gfc_arith_error (arith code) -{ - const char *p; - - switch (code) - { - case ARITH_OK: - p = G_("Arithmetic OK at %L"); - break; - case ARITH_OVERFLOW: - p = G_("Arithmetic overflow at %L"); - break; - case ARITH_UNDERFLOW: - p = G_("Arithmetic underflow at %L"); - break; - case ARITH_NAN: - p = G_("Arithmetic NaN at %L"); - break; - case ARITH_DIV0: - p = G_("Division by zero at %L"); - break; - case ARITH_INCOMMENSURATE: - p = G_("Array operands are incommensurate at %L"); - break; - case ARITH_ASYMMETRIC: - p = G_("Integer outside symmetric range implied by Standard Fortran" - " at %L"); - break; - case ARITH_WRONGCONCAT: - p = G_("Illegal type in character concatenation at %L"); - break; - - default: - gfc_internal_error ("gfc_arith_error(): Bad error code"); - } - - return p; -} - - -/* Get things ready to do math. */ - -void -gfc_arith_init_1 (void) -{ - gfc_integer_info *int_info; - gfc_real_info *real_info; - mpfr_t a, b; - int i; - - mpfr_set_default_prec (128); - mpfr_init (a); - - /* Convert the minimum and maximum values for each kind into their - GNU MP representation. */ - for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++) - { - /* Huge */ - mpz_init (int_info->huge); - mpz_set_ui (int_info->huge, int_info->radix); - mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits); - mpz_sub_ui (int_info->huge, int_info->huge, 1); - - /* These are the numbers that are actually representable by the - target. For bases other than two, this needs to be changed. */ - if (int_info->radix != 2) - gfc_internal_error ("Fix min_int calculation"); - - /* See PRs 13490 and 17912, related to integer ranges. - The pedantic_min_int exists for range checking when a program - is compiled with -pedantic, and reflects the belief that - Standard Fortran requires integers to be symmetrical, i.e. - every negative integer must have a representable positive - absolute value, and vice versa. */ - - mpz_init (int_info->pedantic_min_int); - mpz_neg (int_info->pedantic_min_int, int_info->huge); - - mpz_init (int_info->min_int); - mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1); - - /* Range */ - mpfr_set_z (a, int_info->huge, GFC_RND_MODE); - mpfr_log10 (a, a, GFC_RND_MODE); - mpfr_trunc (a, a); - int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); - } - - mpfr_clear (a); - - for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++) - { - gfc_set_model_kind (real_info->kind); - - mpfr_init (a); - mpfr_init (b); - - /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */ - /* 1 - b**(-p) */ - mpfr_init (real_info->huge); - mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE); - mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); - mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE); - mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE); - - /* b**(emax-1) */ - mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); - mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE); - - /* (1 - b**(-p)) * b**(emax-1) */ - mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE); - - /* (1 - b**(-p)) * b**(emax-1) * b */ - mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix, - GFC_RND_MODE); - - /* tiny(x) = b**(emin-1) */ - mpfr_init (real_info->tiny); - mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE); - mpfr_pow_si (real_info->tiny, real_info->tiny, - real_info->min_exponent - 1, GFC_RND_MODE); - - /* subnormal (x) = b**(emin - digit) */ - mpfr_init (real_info->subnormal); - mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE); - mpfr_pow_si (real_info->subnormal, real_info->subnormal, - real_info->min_exponent - real_info->digits, GFC_RND_MODE); - - /* epsilon(x) = b**(1-p) */ - mpfr_init (real_info->epsilon); - mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE); - mpfr_pow_si (real_info->epsilon, real_info->epsilon, - 1 - real_info->digits, GFC_RND_MODE); - - /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */ - mpfr_log10 (a, real_info->huge, GFC_RND_MODE); - mpfr_log10 (b, real_info->tiny, GFC_RND_MODE); - mpfr_neg (b, b, GFC_RND_MODE); - - /* a = min(a, b) */ - mpfr_min (a, a, b, GFC_RND_MODE); - mpfr_trunc (a, a); - real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); - - /* precision(x) = int((p - 1) * log10(b)) + k */ - mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); - mpfr_log10 (a, a, GFC_RND_MODE); - mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE); - mpfr_trunc (a, a); - real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE); - - /* If the radix is an integral power of 10, add one to the precision. */ - for (i = 10; i <= real_info->radix; i *= 10) - if (i == real_info->radix) - real_info->precision++; - - mpfr_clears (a, b, NULL); - } -} - - -/* Clean up, get rid of numeric constants. */ - -void -gfc_arith_done_1 (void) -{ - gfc_integer_info *ip; - gfc_real_info *rp; - - for (ip = gfc_integer_kinds; ip->kind; ip++) - { - mpz_clear (ip->min_int); - mpz_clear (ip->pedantic_min_int); - mpz_clear (ip->huge); - } - - for (rp = gfc_real_kinds; rp->kind; rp++) - mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL); - - mpfr_free_cache (); -} - - -/* Given a wide character value and a character kind, determine whether - the character is representable for that kind. */ -bool -gfc_check_character_range (gfc_char_t c, int kind) -{ - /* As wide characters are stored as 32-bit values, they're all - representable in UCS=4. */ - if (kind == 4) - return true; - - if (kind == 1) - return c <= 255 ? true : false; - - gcc_unreachable (); -} - - -/* Given an integer and a kind, make sure that the integer lies within - the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or - ARITH_OVERFLOW. */ - -arith -gfc_check_integer_range (mpz_t p, int kind) -{ - arith result; - int i; - - i = gfc_validate_kind (BT_INTEGER, kind, false); - result = ARITH_OK; - - if (pedantic) - { - if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0) - result = ARITH_ASYMMETRIC; - } - - - if (flag_range_check == 0) - return result; - - if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0 - || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0) - result = ARITH_OVERFLOW; - - return result; -} - - -/* Given a real and a kind, make sure that the real lies within the - range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or - ARITH_UNDERFLOW. */ - -static arith -gfc_check_real_range (mpfr_t p, int kind) -{ - arith retval; - mpfr_t q; - int i; - - i = gfc_validate_kind (BT_REAL, kind, false); - - gfc_set_model (p); - mpfr_init (q); - mpfr_abs (q, p, GFC_RND_MODE); - - retval = ARITH_OK; - - if (mpfr_inf_p (p)) - { - if (flag_range_check != 0) - retval = ARITH_OVERFLOW; - } - else if (mpfr_nan_p (p)) - { - if (flag_range_check != 0) - retval = ARITH_NAN; - } - else if (mpfr_sgn (q) == 0) - { - mpfr_clear (q); - return retval; - } - else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0) - { - if (flag_range_check == 0) - mpfr_set_inf (p, mpfr_sgn (p)); - else - retval = ARITH_OVERFLOW; - } - else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0) - { - if (flag_range_check == 0) - { - if (mpfr_sgn (p) < 0) - { - mpfr_set_ui (p, 0, GFC_RND_MODE); - mpfr_set_si (q, -1, GFC_RND_MODE); - mpfr_copysign (p, p, q, GFC_RND_MODE); - } - else - mpfr_set_ui (p, 0, GFC_RND_MODE); - } - else - retval = ARITH_UNDERFLOW; - } - else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0) - { - mpfr_exp_t emin, emax; - int en; - - /* Save current values of emin and emax. */ - emin = mpfr_get_emin (); - emax = mpfr_get_emax (); - - /* Set emin and emax for the current model number. */ - en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1; - mpfr_set_emin ((mpfr_exp_t) en); - mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent); - mpfr_check_range (q, 0, GFC_RND_MODE); - mpfr_subnormalize (q, 0, GFC_RND_MODE); - - /* Reset emin and emax. */ - mpfr_set_emin (emin); - mpfr_set_emax (emax); - - /* Copy sign if needed. */ - if (mpfr_sgn (p) < 0) - mpfr_neg (p, q, MPFR_RNDN); - else - mpfr_set (p, q, MPFR_RNDN); - } - - mpfr_clear (q); - - return retval; -} - - -/* Low-level arithmetic functions. All of these subroutines assume - that all operands are of the same type and return an operand of the - same type. The other thing about these subroutines is that they - can fail in various ways -- overflow, underflow, division by zero, - zero raised to the zero, etc. */ - -static arith -gfc_arith_not (gfc_expr *op1, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where); - result->value.logical = !op1->value.logical; - *resultp = result; - - return ARITH_OK; -} - - -static arith -gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); - result->value.logical = op1->value.logical && op2->value.logical; - *resultp = result; - - return ARITH_OK; -} - - -static arith -gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); - result->value.logical = op1->value.logical || op2->value.logical; - *resultp = result; - - return ARITH_OK; -} - - -static arith -gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); - result->value.logical = op1->value.logical == op2->value.logical; - *resultp = result; - - return ARITH_OK; -} - - -static arith -gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), - &op1->where); - result->value.logical = op1->value.logical != op2->value.logical; - *resultp = result; - - return ARITH_OK; -} - - -/* Make sure a constant numeric expression is within the range for - its type and kind. Note that there's also a gfc_check_range(), - but that one deals with the intrinsic RANGE function. */ - -arith -gfc_range_check (gfc_expr *e) -{ - arith rc; - arith rc2; - - switch (e->ts.type) - { - case BT_INTEGER: - rc = gfc_check_integer_range (e->value.integer, e->ts.kind); - break; - - case BT_REAL: - rc = gfc_check_real_range (e->value.real, e->ts.kind); - if (rc == ARITH_UNDERFLOW) - mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); - if (rc == ARITH_OVERFLOW) - mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real)); - if (rc == ARITH_NAN) - mpfr_set_nan (e->value.real); - break; - - case BT_COMPLEX: - rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind); - if (rc == ARITH_UNDERFLOW) - mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE); - if (rc == ARITH_OVERFLOW) - mpfr_set_inf (mpc_realref (e->value.complex), - mpfr_sgn (mpc_realref (e->value.complex))); - if (rc == ARITH_NAN) - mpfr_set_nan (mpc_realref (e->value.complex)); - - rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind); - if (rc == ARITH_UNDERFLOW) - mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE); - if (rc == ARITH_OVERFLOW) - mpfr_set_inf (mpc_imagref (e->value.complex), - mpfr_sgn (mpc_imagref (e->value.complex))); - if (rc == ARITH_NAN) - mpfr_set_nan (mpc_imagref (e->value.complex)); - - if (rc == ARITH_OK) - rc = rc2; - break; - - default: - gfc_internal_error ("gfc_range_check(): Bad type"); - } - - return rc; -} - - -/* Several of the following routines use the same set of statements to - check the validity of the result. Encapsulate the checking here. */ - -static arith -check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp) -{ - arith val = rc; - - if (val == ARITH_UNDERFLOW) - { - if (warn_underflow) - gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where); - val = ARITH_OK; - } - - if (val == ARITH_ASYMMETRIC) - { - gfc_warning (0, gfc_arith_error (val), &x->where); - val = ARITH_OK; - } - - if (val == ARITH_OK || val == ARITH_OVERFLOW) - *rp = r; - else - gfc_free_expr (r); - - return val; -} - - -/* It may seem silly to have a subroutine that actually computes the - unary plus of a constant, but it prevents us from making exceptions - in the code elsewhere. Used for unary plus and parenthesized - expressions. */ - -static arith -gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp) -{ - *resultp = gfc_copy_expr (op1); - return ARITH_OK; -} - - -static arith -gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) -{ - gfc_expr *result; - arith rc; - - result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); - - switch (op1->ts.type) - { - case BT_INTEGER: - mpz_neg (result->value.integer, op1->value.integer); - break; - - case BT_REAL: - mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_arith_uminus(): Bad basic type"); - } - - rc = gfc_range_check (result); - - return check_result (rc, op1, result, resultp); -} - - -static arith -gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - arith rc; - - result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); - - switch (op1->ts.type) - { - case BT_INTEGER: - mpz_add (result->value.integer, op1->value.integer, op2->value.integer); - break; - - case BT_REAL: - mpfr_add (result->value.real, op1->value.real, op2->value.real, - GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_add (result->value.complex, op1->value.complex, op2->value.complex, - GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_arith_plus(): Bad basic type"); - } - - rc = gfc_range_check (result); - - return check_result (rc, op1, result, resultp); -} - - -static arith -gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - arith rc; - - result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); - - switch (op1->ts.type) - { - case BT_INTEGER: - mpz_sub (result->value.integer, op1->value.integer, op2->value.integer); - break; - - case BT_REAL: - mpfr_sub (result->value.real, op1->value.real, op2->value.real, - GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_sub (result->value.complex, op1->value.complex, - op2->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_arith_minus(): Bad basic type"); - } - - rc = gfc_range_check (result); - - return check_result (rc, op1, result, resultp); -} - - -static arith -gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - arith rc; - - result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); - - switch (op1->ts.type) - { - case BT_INTEGER: - mpz_mul (result->value.integer, op1->value.integer, op2->value.integer); - break; - - case BT_REAL: - mpfr_mul (result->value.real, op1->value.real, op2->value.real, - GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model (mpc_realref (op1->value.complex)); - mpc_mul (result->value.complex, op1->value.complex, op2->value.complex, - GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_arith_times(): Bad basic type"); - } - - rc = gfc_range_check (result); - - return check_result (rc, op1, result, resultp); -} - - -static arith -gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - arith rc; - - rc = ARITH_OK; - - result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); - - switch (op1->ts.type) - { - case BT_INTEGER: - if (mpz_sgn (op2->value.integer) == 0) - { - rc = ARITH_DIV0; - break; - } - - if (warn_integer_division) - { - mpz_t r; - mpz_init (r); - mpz_tdiv_qr (result->value.integer, r, op1->value.integer, - op2->value.integer); - - if (mpz_cmp_si (r, 0) != 0) - { - char *p; - p = mpz_get_str (NULL, 10, result->value.integer); - gfc_warning_now (OPT_Winteger_division, "Integer division " - "truncated to constant %qs at %L", p, - &op1->where); - free (p); - } - mpz_clear (r); - } - else - mpz_tdiv_q (result->value.integer, op1->value.integer, - op2->value.integer); - - break; - - case BT_REAL: - if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1) - { - rc = ARITH_DIV0; - break; - } - - mpfr_div (result->value.real, op1->value.real, op2->value.real, - GFC_RND_MODE); - break; - - case BT_COMPLEX: - if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0 - && flag_range_check == 1) - { - rc = ARITH_DIV0; - break; - } - - gfc_set_model (mpc_realref (op1->value.complex)); - if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0) - { - /* In Fortran, return (NaN + NaN I) for any zero divisor. See - PR 40318. */ - mpfr_set_nan (mpc_realref (result->value.complex)); - mpfr_set_nan (mpc_imagref (result->value.complex)); - } - else - mpc_div (result->value.complex, op1->value.complex, op2->value.complex, - GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_arith_divide(): Bad basic type"); - } - - if (rc == ARITH_OK) - rc = gfc_range_check (result); - - return check_result (rc, op1, result, resultp); -} - -/* Raise a number to a power. */ - -static arith -arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - int power_sign; - gfc_expr *result; - arith rc; - - rc = ARITH_OK; - result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); - - switch (op2->ts.type) - { - case BT_INTEGER: - power_sign = mpz_sgn (op2->value.integer); - - if (power_sign == 0) - { - /* Handle something to the zeroth power. Since we're dealing - with integral exponents, there is no ambiguity in the - limiting procedure used to determine the value of 0**0. */ - switch (op1->ts.type) - { - case BT_INTEGER: - mpz_set_ui (result->value.integer, 1); - break; - - case BT_REAL: - mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("arith_power(): Bad base"); - } - } - else - { - switch (op1->ts.type) - { - case BT_INTEGER: - { - /* First, we simplify the cases of op1 == 1, 0 or -1. */ - if (mpz_cmp_si (op1->value.integer, 1) == 0) - { - /* 1**op2 == 1 */ - mpz_set_si (result->value.integer, 1); - } - else if (mpz_cmp_si (op1->value.integer, 0) == 0) - { - /* 0**op2 == 0, if op2 > 0 - 0**op2 overflow, if op2 < 0 ; in that case, we - set the result to 0 and return ARITH_DIV0. */ - mpz_set_si (result->value.integer, 0); - if (mpz_cmp_si (op2->value.integer, 0) < 0) - rc = ARITH_DIV0; - } - else if (mpz_cmp_si (op1->value.integer, -1) == 0) - { - /* (-1)**op2 == (-1)**(mod(op2,2)) */ - unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2); - if (odd) - mpz_set_si (result->value.integer, -1); - else - mpz_set_si (result->value.integer, 1); - } - /* Then, we take care of op2 < 0. */ - else if (mpz_cmp_si (op2->value.integer, 0) < 0) - { - /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */ - mpz_set_si (result->value.integer, 0); - if (warn_integer_division) - gfc_warning_now (OPT_Winteger_division, "Negative " - "exponent of integer has zero " - "result at %L", &result->where); - } - else - { - /* We have abs(op1) > 1 and op2 > 1. - If op2 > bit_size(op1), we'll have an out-of-range - result. */ - int k, power; - - k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false); - power = gfc_integer_kinds[k].bit_size; - if (mpz_cmp_si (op2->value.integer, power) < 0) - { - gfc_extract_int (op2, &power); - mpz_pow_ui (result->value.integer, op1->value.integer, - power); - rc = gfc_range_check (result); - if (rc == ARITH_OVERFLOW) - gfc_error_now ("Result of exponentiation at %L " - "exceeds the range of %s", &op1->where, - gfc_typename (&(op1->ts))); - } - else - { - /* Provide a nonsense value to propagate up. */ - mpz_set (result->value.integer, - gfc_integer_kinds[k].huge); - mpz_add_ui (result->value.integer, - result->value.integer, 1); - rc = ARITH_OVERFLOW; - } - } - } - break; - - case BT_REAL: - mpfr_pow_z (result->value.real, op1->value.real, - op2->value.integer, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_pow_z (result->value.complex, op1->value.complex, - op2->value.integer, GFC_MPC_RND_MODE); - break; - - default: - break; - } - } - break; - - case BT_REAL: - - if (gfc_init_expr_flag) - { - if (!gfc_notify_std (GFC_STD_F2003, "Noninteger " - "exponent in an initialization " - "expression at %L", &op2->where)) - { - gfc_free_expr (result); - return ARITH_PROHIBIT; - } - } - - if (mpfr_cmp_si (op1->value.real, 0) < 0) - { - gfc_error ("Raising a negative REAL at %L to " - "a REAL power is prohibited", &op1->where); - gfc_free_expr (result); - return ARITH_PROHIBIT; - } - - mpfr_pow (result->value.real, op1->value.real, op2->value.real, - GFC_RND_MODE); - break; - - case BT_COMPLEX: - { - if (gfc_init_expr_flag) - { - if (!gfc_notify_std (GFC_STD_F2003, "Noninteger " - "exponent in an initialization " - "expression at %L", &op2->where)) - { - gfc_free_expr (result); - return ARITH_PROHIBIT; - } - } - - mpc_pow (result->value.complex, op1->value.complex, - op2->value.complex, GFC_MPC_RND_MODE); - } - break; - default: - gfc_internal_error ("arith_power(): unknown type"); - } - - if (rc == ARITH_OK) - rc = gfc_range_check (result); - - return check_result (rc, op1, result, resultp); -} - - -/* Concatenate two string constants. */ - -static arith -gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - size_t len; - - /* By cleverly playing around with constructors, it is possible - to get mismaching types here. */ - if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER - || op1->ts.kind != op2->ts.kind) - return ARITH_WRONGCONCAT; - - result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind, - &op1->where); - - len = op1->value.character.length + op2->value.character.length; - - result->value.character.string = gfc_get_wide_string (len + 1); - result->value.character.length = len; - - memcpy (result->value.character.string, op1->value.character.string, - op1->value.character.length * sizeof (gfc_char_t)); - - memcpy (&result->value.character.string[op1->value.character.length], - op2->value.character.string, - op2->value.character.length * sizeof (gfc_char_t)); - - result->value.character.string[len] = '\0'; - - *resultp = result; - - return ARITH_OK; -} - -/* Comparison between real values; returns 0 if (op1 .op. op2) is true. - This function mimics mpfr_cmp but takes NaN into account. */ - -static int -compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - int rc; - switch (op) - { - case INTRINSIC_EQ: - rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1; - break; - case INTRINSIC_GT: - rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1; - break; - case INTRINSIC_GE: - rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1; - break; - case INTRINSIC_LT: - rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1; - break; - case INTRINSIC_LE: - rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1; - break; - default: - gfc_internal_error ("compare_real(): Bad operator"); - } - - return rc; -} - -/* Comparison operators. Assumes that the two expression nodes - contain two constants of the same type. The op argument is - needed to handle NaN correctly. */ - -int -gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - int rc; - - switch (op1->ts.type) - { - case BT_INTEGER: - rc = mpz_cmp (op1->value.integer, op2->value.integer); - break; - - case BT_REAL: - rc = compare_real (op1, op2, op); - break; - - case BT_CHARACTER: - rc = gfc_compare_string (op1, op2); - break; - - case BT_LOGICAL: - rc = ((!op1->value.logical && op2->value.logical) - || (op1->value.logical && !op2->value.logical)); - break; - - default: - gfc_internal_error ("gfc_compare_expr(): Bad basic type"); - } - - return rc; -} - - -/* Compare a pair of complex numbers. Naturally, this is only for - equality and inequality. */ - -static int -compare_complex (gfc_expr *op1, gfc_expr *op2) -{ - return mpc_cmp (op1->value.complex, op2->value.complex) == 0; -} - - -/* Given two constant strings and the inverse collating sequence, compare the - strings. We return -1 for a < b, 0 for a == b and 1 for a > b. - We use the processor's default collating sequence. */ - -int -gfc_compare_string (gfc_expr *a, gfc_expr *b) -{ - size_t len, alen, blen, i; - gfc_char_t ac, bc; - - alen = a->value.character.length; - blen = b->value.character.length; - - len = MAX(alen, blen); - - for (i = 0; i < len; i++) - { - ac = ((i < alen) ? a->value.character.string[i] : ' '); - bc = ((i < blen) ? b->value.character.string[i] : ' '); - - if (ac < bc) - return -1; - if (ac > bc) - return 1; - } - - /* Strings are equal */ - return 0; -} - - -int -gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive) -{ - size_t len, alen, blen, i; - gfc_char_t ac, bc; - - alen = a->value.character.length; - blen = strlen (b); - - len = MAX(alen, blen); - - for (i = 0; i < len; i++) - { - ac = ((i < alen) ? a->value.character.string[i] : ' '); - bc = ((i < blen) ? b[i] : ' '); - - if (!case_sensitive) - { - ac = TOLOWER (ac); - bc = TOLOWER (bc); - } - - if (ac < bc) - return -1; - if (ac > bc) - return 1; - } - - /* Strings are equal */ - return 0; -} - - -/* Specific comparison subroutines. */ - -static arith -gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); - result->value.logical = (op1->ts.type == BT_COMPLEX) - ? compare_complex (op1, op2) - : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0); - - *resultp = result; - return ARITH_OK; -} - - -static arith -gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); - result->value.logical = (op1->ts.type == BT_COMPLEX) - ? !compare_complex (op1, op2) - : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0); - - *resultp = result; - return ARITH_OK; -} - - -static arith -gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); - result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0); - *resultp = result; - - return ARITH_OK; -} - - -static arith -gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); - result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0); - *resultp = result; - - return ARITH_OK; -} - - -static arith -gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); - result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0); - *resultp = result; - - return ARITH_OK; -} - - -static arith -gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, - &op1->where); - result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0); - *resultp = result; - - return ARITH_OK; -} - - -static arith -reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, - gfc_expr **result) -{ - gfc_constructor_base head; - gfc_constructor *c; - gfc_expr *r; - arith rc; - - if (op->expr_type == EXPR_CONSTANT) - return eval (op, result); - - rc = ARITH_OK; - head = gfc_constructor_copy (op->value.constructor); - for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) - { - rc = reduce_unary (eval, c->expr, &r); - - if (rc != ARITH_OK) - break; - - gfc_replace_expr (c->expr, r); - } - - if (rc != ARITH_OK) - gfc_constructor_free (head); - else - { - gfc_constructor *c = gfc_constructor_first (head); - r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, - &op->where); - r->shape = gfc_copy_shape (op->shape, op->rank); - r->rank = op->rank; - r->value.constructor = head; - *result = r; - } - - return rc; -} - - -static arith -reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), - gfc_expr *op1, gfc_expr *op2, gfc_expr **result) -{ - gfc_constructor_base head; - gfc_constructor *c; - gfc_expr *r; - arith rc = ARITH_OK; - - head = gfc_constructor_copy (op1->value.constructor); - for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) - { - if (c->expr->expr_type == EXPR_CONSTANT) - rc = eval (c->expr, op2, &r); - else - rc = reduce_binary_ac (eval, c->expr, op2, &r); - - if (rc != ARITH_OK) - break; - - gfc_replace_expr (c->expr, r); - } - - if (rc != ARITH_OK) - gfc_constructor_free (head); - else - { - gfc_constructor *c = gfc_constructor_first (head); - r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, - &op1->where); - r->shape = gfc_copy_shape (op1->shape, op1->rank); - r->rank = op1->rank; - r->value.constructor = head; - *result = r; - } - - return rc; -} - - -static arith -reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), - gfc_expr *op1, gfc_expr *op2, gfc_expr **result) -{ - gfc_constructor_base head; - gfc_constructor *c; - gfc_expr *r; - arith rc = ARITH_OK; - - head = gfc_constructor_copy (op2->value.constructor); - for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) - { - if (c->expr->expr_type == EXPR_CONSTANT) - rc = eval (op1, c->expr, &r); - else - rc = reduce_binary_ca (eval, op1, c->expr, &r); - - if (rc != ARITH_OK) - break; - - gfc_replace_expr (c->expr, r); - } - - if (rc != ARITH_OK) - gfc_constructor_free (head); - else - { - gfc_constructor *c = gfc_constructor_first (head); - r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, - &op2->where); - r->shape = gfc_copy_shape (op2->shape, op2->rank); - r->rank = op2->rank; - r->value.constructor = head; - *result = r; - } - - return rc; -} - - -/* We need a forward declaration of reduce_binary. */ -static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), - gfc_expr *op1, gfc_expr *op2, gfc_expr **result); - - -static arith -reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), - gfc_expr *op1, gfc_expr *op2, gfc_expr **result) -{ - gfc_constructor_base head; - gfc_constructor *c, *d; - gfc_expr *r; - arith rc = ARITH_OK; - - if (!gfc_check_conformance (op1, op2, _("elemental binary operation"))) - return ARITH_INCOMMENSURATE; - - head = gfc_constructor_copy (op1->value.constructor); - for (c = gfc_constructor_first (head), - d = gfc_constructor_first (op2->value.constructor); - c && d; - c = gfc_constructor_next (c), d = gfc_constructor_next (d)) - { - rc = reduce_binary (eval, c->expr, d->expr, &r); - if (rc != ARITH_OK) - break; - - gfc_replace_expr (c->expr, r); - } - - if (c || d) - rc = ARITH_INCOMMENSURATE; - - if (rc != ARITH_OK) - gfc_constructor_free (head); - else - { - gfc_constructor *c = gfc_constructor_first (head); - r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, - &op1->where); - r->shape = gfc_copy_shape (op1->shape, op1->rank); - r->rank = op1->rank; - r->value.constructor = head; - *result = r; - } - - return rc; -} - - -static arith -reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), - gfc_expr *op1, gfc_expr *op2, gfc_expr **result) -{ - if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT) - return eval (op1, op2, result); - - if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY) - return reduce_binary_ca (eval, op1, op2, result); - - if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT) - return reduce_binary_ac (eval, op1, op2, result); - - return reduce_binary_aa (eval, op1, op2, result); -} - - -typedef union -{ - arith (*f2)(gfc_expr *, gfc_expr **); - arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **); -} -eval_f; - -/* High level arithmetic subroutines. These subroutines go into - eval_intrinsic(), which can do one of several things to its - operands. If the operands are incompatible with the intrinsic - operation, we return a node pointing to the operands and hope that - an operator interface is found during resolution. - - If the operands are compatible and are constants, then we try doing - the arithmetic. We also handle the cases where either or both - operands are array constructors. */ - -static gfc_expr * -eval_intrinsic (gfc_intrinsic_op op, - eval_f eval, gfc_expr *op1, gfc_expr *op2) -{ - gfc_expr temp, *result; - int unary; - arith rc; - - gfc_clear_ts (&temp.ts); - - switch (op) - { - /* Logical unary */ - case INTRINSIC_NOT: - if (op1->ts.type != BT_LOGICAL) - goto runtime; - - temp.ts.type = BT_LOGICAL; - temp.ts.kind = gfc_default_logical_kind; - unary = 1; - break; - - /* Logical binary operators */ - case INTRINSIC_OR: - case INTRINSIC_AND: - case INTRINSIC_NEQV: - case INTRINSIC_EQV: - if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL) - goto runtime; - - temp.ts.type = BT_LOGICAL; - temp.ts.kind = gfc_default_logical_kind; - unary = 0; - break; - - /* Numeric unary */ - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - if (!gfc_numeric_ts (&op1->ts)) - goto runtime; - - temp.ts = op1->ts; - unary = 1; - break; - - case INTRINSIC_PARENTHESES: - temp.ts = op1->ts; - unary = 1; - break; - - /* Additional restrictions for ordering relations. */ - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) - { - temp.ts.type = BT_LOGICAL; - temp.ts.kind = gfc_default_logical_kind; - goto runtime; - } - - /* Fall through */ - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) - { - unary = 0; - temp.ts.type = BT_LOGICAL; - temp.ts.kind = gfc_default_logical_kind; - - /* If kind mismatch, exit and we'll error out later. */ - if (op1->ts.kind != op2->ts.kind) - goto runtime; - - break; - } - - gcc_fallthrough (); - /* Numeric binary */ - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: - if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts)) - goto runtime; - - /* Insert any necessary type conversions to make the operands - compatible. */ - - temp.expr_type = EXPR_OP; - gfc_clear_ts (&temp.ts); - temp.value.op.op = op; - - temp.value.op.op1 = op1; - temp.value.op.op2 = op2; - - gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra); - - if (op == INTRINSIC_EQ || op == INTRINSIC_NE - || op == INTRINSIC_GE || op == INTRINSIC_GT - || op == INTRINSIC_LE || op == INTRINSIC_LT - || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS - || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS - || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS) - { - temp.ts.type = BT_LOGICAL; - temp.ts.kind = gfc_default_logical_kind; - } - - unary = 0; - break; - - /* Character binary */ - case INTRINSIC_CONCAT: - if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER - || op1->ts.kind != op2->ts.kind) - goto runtime; - - temp.ts.type = BT_CHARACTER; - temp.ts.kind = op1->ts.kind; - unary = 0; - break; - - case INTRINSIC_USER: - goto runtime; - - default: - gfc_internal_error ("eval_intrinsic(): Bad operator"); - } - - if (op1->expr_type != EXPR_CONSTANT - && (op1->expr_type != EXPR_ARRAY - || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1))) - goto runtime; - - if (op2 != NULL - && op2->expr_type != EXPR_CONSTANT - && (op2->expr_type != EXPR_ARRAY - || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2))) - goto runtime; - - if (unary) - rc = reduce_unary (eval.f2, op1, &result); - else - rc = reduce_binary (eval.f3, op1, op2, &result); - - - /* Something went wrong. */ - if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT) - return NULL; - - if (rc != ARITH_OK) - { - gfc_error (gfc_arith_error (rc), &op1->where); - if (rc == ARITH_OVERFLOW) - goto done; - - if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER) - gfc_seen_div0 = true; - - return NULL; - } - -done: - - gfc_free_expr (op1); - gfc_free_expr (op2); - return result; - -runtime: - /* Create a run-time expression. */ - result = gfc_get_operator_expr (&op1->where, op, op1, op2); - result->ts = temp.ts; - - return result; -} - - -/* Modify type of expression for zero size array. */ - -static gfc_expr * -eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op) -{ - if (op == NULL) - gfc_internal_error ("eval_type_intrinsic0(): op NULL"); - - switch (iop) - { - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - op->ts.type = BT_LOGICAL; - op->ts.kind = gfc_default_logical_kind; - break; - - default: - break; - } - - return op; -} - - -/* Return nonzero if the expression is a zero size array. */ - -static int -gfc_zero_size_array (gfc_expr *e) -{ - if (e->expr_type != EXPR_ARRAY) - return 0; - - return e->value.constructor == NULL; -} - - -/* Reduce a binary expression where at least one of the operands - involves a zero-length array. Returns NULL if neither of the - operands is a zero-length array. */ - -static gfc_expr * -reduce_binary0 (gfc_expr *op1, gfc_expr *op2) -{ - if (gfc_zero_size_array (op1)) - { - gfc_free_expr (op2); - return op1; - } - - if (gfc_zero_size_array (op2)) - { - gfc_free_expr (op1); - return op2; - } - - return NULL; -} - - -static gfc_expr * -eval_intrinsic_f2 (gfc_intrinsic_op op, - arith (*eval) (gfc_expr *, gfc_expr **), - gfc_expr *op1, gfc_expr *op2) -{ - gfc_expr *result; - eval_f f; - - if (op2 == NULL) - { - if (gfc_zero_size_array (op1)) - return eval_type_intrinsic0 (op, op1); - } - else - { - result = reduce_binary0 (op1, op2); - if (result != NULL) - return eval_type_intrinsic0 (op, result); - } - - f.f2 = eval; - return eval_intrinsic (op, f, op1, op2); -} - - -static gfc_expr * -eval_intrinsic_f3 (gfc_intrinsic_op op, - arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), - gfc_expr *op1, gfc_expr *op2) -{ - gfc_expr *result; - eval_f f; - - if (!op1 && !op2) - return NULL; - - result = reduce_binary0 (op1, op2); - if (result != NULL) - return eval_type_intrinsic0(op, result); - - f.f3 = eval; - return eval_intrinsic (op, f, op1, op2); -} - - -gfc_expr * -gfc_parentheses (gfc_expr *op) -{ - if (gfc_is_constant_expr (op)) - return op; - - return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity, - op, NULL); -} - -gfc_expr * -gfc_uplus (gfc_expr *op) -{ - return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL); -} - - -gfc_expr * -gfc_uminus (gfc_expr *op) -{ - return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL); -} - - -gfc_expr * -gfc_add (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2); -} - - -gfc_expr * -gfc_subtract (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2); -} - - -gfc_expr * -gfc_multiply (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2); -} - - -gfc_expr * -gfc_divide (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2); -} - - -gfc_expr * -gfc_power (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2); -} - - -gfc_expr * -gfc_concat (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2); -} - - -gfc_expr * -gfc_and (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2); -} - - -gfc_expr * -gfc_or (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2); -} - - -gfc_expr * -gfc_not (gfc_expr *op1) -{ - return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL); -} - - -gfc_expr * -gfc_eqv (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2); -} - - -gfc_expr * -gfc_neqv (gfc_expr *op1, gfc_expr *op2) -{ - return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2); -} - - -gfc_expr * -gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2); -} - - -gfc_expr * -gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2); -} - - -gfc_expr * -gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2); -} - - -gfc_expr * -gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2); -} - - -gfc_expr * -gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2); -} - - -gfc_expr * -gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) -{ - return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2); -} - - -/******* Simplification of intrinsic functions with constant arguments *****/ - - -/* Deal with an arithmetic error. */ - -static void -arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where) -{ - switch (rc) - { - case ARITH_OK: - gfc_error ("Arithmetic OK converting %s to %s at %L", - gfc_typename (from), gfc_typename (to), where); - break; - case ARITH_OVERFLOW: - gfc_error ("Arithmetic overflow converting %s to %s at %L. This check " - "can be disabled with the option %<-fno-range-check%>", - gfc_typename (from), gfc_typename (to), where); - break; - case ARITH_UNDERFLOW: - gfc_error ("Arithmetic underflow converting %s to %s at %L. This check " - "can be disabled with the option %<-fno-range-check%>", - gfc_typename (from), gfc_typename (to), where); - break; - case ARITH_NAN: - gfc_error ("Arithmetic NaN converting %s to %s at %L. This check " - "can be disabled with the option %<-fno-range-check%>", - gfc_typename (from), gfc_typename (to), where); - break; - case ARITH_DIV0: - gfc_error ("Division by zero converting %s to %s at %L", - gfc_typename (from), gfc_typename (to), where); - break; - case ARITH_INCOMMENSURATE: - gfc_error ("Array operands are incommensurate converting %s to %s at %L", - gfc_typename (from), gfc_typename (to), where); - break; - case ARITH_ASYMMETRIC: - gfc_error ("Integer outside symmetric range implied by Standard Fortran" - " converting %s to %s at %L", - gfc_typename (from), gfc_typename (to), where); - break; - default: - gfc_internal_error ("gfc_arith_error(): Bad error code"); - } - - /* TODO: Do something about the error, i.e., throw exception, return - NaN, etc. */ -} - -/* Returns true if significant bits were lost when converting real - constant r from from_kind to to_kind. */ - -static bool -wprecision_real_real (mpfr_t r, int from_kind, int to_kind) -{ - mpfr_t rv, diff; - bool ret; - - gfc_set_model_kind (to_kind); - mpfr_init (rv); - gfc_set_model_kind (from_kind); - mpfr_init (diff); - - mpfr_set (rv, r, GFC_RND_MODE); - mpfr_sub (diff, rv, r, GFC_RND_MODE); - - ret = ! mpfr_zero_p (diff); - mpfr_clear (rv); - mpfr_clear (diff); - return ret; -} - -/* Return true if conversion from an integer to a real loses precision. */ - -static bool -wprecision_int_real (mpz_t n, mpfr_t r) -{ - bool ret; - mpz_t i; - mpz_init (i); - mpfr_get_z (i, r, GFC_RND_MODE); - mpz_sub (i, i, n); - ret = mpz_cmp_si (i, 0) != 0; - mpz_clear (i); - return ret; -} - -/* Convert integers to integers. */ - -gfc_expr * -gfc_int2int (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - - result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); - - mpz_set (result->value.integer, src->value.integer); - - if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) - { - if (rc == ARITH_ASYMMETRIC) - { - gfc_warning (0, gfc_arith_error (rc), &src->where); - } - else - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - } - - /* If we do not trap numeric overflow, we need to convert the number to - signed, throwing away high-order bits if necessary. */ - if (flag_range_check == 0) - { - int k; - - k = gfc_validate_kind (BT_INTEGER, kind, false); - gfc_convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); - - if (warn_conversion && !src->do_not_warn && kind < src->ts.kind) - gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", - gfc_typename (&src->ts), gfc_typename (&result->ts), - &src->where); - } - return result; -} - - -/* Convert integers to reals. */ - -gfc_expr * -gfc_int2real (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - - result = gfc_get_constant_expr (BT_REAL, kind, &src->where); - - mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); - - if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - if (warn_conversion - && wprecision_int_real (src->value.integer, result->value.real)) - gfc_warning (OPT_Wconversion, "Change of value in conversion " - "from %qs to %qs at %L", - gfc_typename (&src->ts), - gfc_typename (&result->ts), - &src->where); - - return result; -} - - -/* Convert default integer to default complex. */ - -gfc_expr * -gfc_int2complex (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - - result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); - - mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); - - if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind)) - != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - if (warn_conversion - && wprecision_int_real (src->value.integer, - mpc_realref (result->value.complex))) - gfc_warning_now (OPT_Wconversion, "Change of value in conversion " - "from %qs to %qs at %L", - gfc_typename (&src->ts), - gfc_typename (&result->ts), - &src->where); - - return result; -} - - -/* Convert default real to default integer. */ - -gfc_expr * -gfc_real2int (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - bool did_warn = false; - - result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); - - gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); - - if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - /* If there was a fractional part, warn about this. */ - - if (warn_conversion) - { - mpfr_t f; - mpfr_init (f); - mpfr_frac (f, src->value.real, GFC_RND_MODE); - if (mpfr_cmp_si (f, 0) != 0) - { - gfc_warning_now (OPT_Wconversion, "Change of value in conversion " - "from %qs to %qs at %L", gfc_typename (&src->ts), - gfc_typename (&result->ts), &src->where); - did_warn = true; - } - } - if (!did_warn && warn_conversion_extra) - { - gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " - "at %L", gfc_typename (&src->ts), - gfc_typename (&result->ts), &src->where); - } - - return result; -} - - -/* Convert real to real. */ - -gfc_expr * -gfc_real2real (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - bool did_warn = false; - - result = gfc_get_constant_expr (BT_REAL, kind, &src->where); - - mpfr_set (result->value.real, src->value.real, GFC_RND_MODE); - - rc = gfc_check_real_range (result->value.real, kind); - - if (rc == ARITH_UNDERFLOW) - { - if (warn_underflow) - gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - } - else if (rc != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - /* As a special bonus, don't warn about REAL values which are not changed by - the conversion if -Wconversion is specified and -Wconversion-extra is - not. */ - - if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) - { - int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; - - /* Calculate the difference between the constant and the rounded - value and check it against zero. */ - - if (wprecision_real_real (src->value.real, src->ts.kind, kind)) - { - gfc_warning_now (w, "Change of value in conversion from " - "%qs to %qs at %L", - gfc_typename (&src->ts), gfc_typename (&result->ts), - &src->where); - /* Make sure the conversion warning is not emitted again. */ - did_warn = true; - } - } - - if (!did_warn && warn_conversion_extra) - gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " - "at %L", gfc_typename(&src->ts), - gfc_typename(&result->ts), &src->where); - - return result; -} - - -/* Convert real to complex. */ - -gfc_expr * -gfc_real2complex (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - bool did_warn = false; - - result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); - - mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE); - - rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); - - if (rc == ARITH_UNDERFLOW) - { - if (warn_underflow) - gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); - mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE); - } - else if (rc != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) - { - int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; - - if (wprecision_real_real (src->value.real, src->ts.kind, kind)) - { - gfc_warning_now (w, "Change of value in conversion from " - "%qs to %qs at %L", - gfc_typename (&src->ts), gfc_typename (&result->ts), - &src->where); - /* Make sure the conversion warning is not emitted again. */ - did_warn = true; - } - } - - if (!did_warn && warn_conversion_extra) - gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " - "at %L", gfc_typename(&src->ts), - gfc_typename(&result->ts), &src->where); - - return result; -} - - -/* Convert complex to integer. */ - -gfc_expr * -gfc_complex2int (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - bool did_warn = false; - - result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); - - gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex), - &src->where); - - if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - if (warn_conversion || warn_conversion_extra) - { - int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; - - /* See if we discarded an imaginary part. */ - if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) - { - gfc_warning_now (w, "Non-zero imaginary part discarded " - "in conversion from %qs to %qs at %L", - gfc_typename(&src->ts), gfc_typename (&result->ts), - &src->where); - did_warn = true; - } - - else { - mpfr_t f; - - mpfr_init (f); - mpfr_frac (f, src->value.real, GFC_RND_MODE); - if (mpfr_cmp_si (f, 0) != 0) - { - gfc_warning_now (w, "Change of value in conversion from " - "%qs to %qs at %L", gfc_typename (&src->ts), - gfc_typename (&result->ts), &src->where); - did_warn = true; - } - mpfr_clear (f); - } - - if (!did_warn && warn_conversion_extra) - { - gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " - "at %L", gfc_typename (&src->ts), - gfc_typename (&result->ts), &src->where); - } - } - - return result; -} - - -/* Convert complex to real. */ - -gfc_expr * -gfc_complex2real (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - bool did_warn = false; - - result = gfc_get_constant_expr (BT_REAL, kind, &src->where); - - mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); - - rc = gfc_check_real_range (result->value.real, kind); - - if (rc == ARITH_UNDERFLOW) - { - if (warn_underflow) - gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - } - if (rc != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - if (warn_conversion || warn_conversion_extra) - { - int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; - - /* See if we discarded an imaginary part. */ - if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) - { - gfc_warning (w, "Non-zero imaginary part discarded " - "in conversion from %qs to %qs at %L", - gfc_typename(&src->ts), gfc_typename (&result->ts), - &src->where); - did_warn = true; - } - - /* Calculate the difference between the real constant and the rounded - value and check it against zero. */ - - if (kind > src->ts.kind - && wprecision_real_real (mpc_realref (src->value.complex), - src->ts.kind, kind)) - { - gfc_warning_now (w, "Change of value in conversion from " - "%qs to %qs at %L", - gfc_typename (&src->ts), gfc_typename (&result->ts), - &src->where); - /* Make sure the conversion warning is not emitted again. */ - did_warn = true; - } - } - - if (!did_warn && warn_conversion_extra) - gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", - gfc_typename(&src->ts), gfc_typename (&result->ts), - &src->where); - - return result; -} - - -/* Convert complex to complex. */ - -gfc_expr * -gfc_complex2complex (gfc_expr *src, int kind) -{ - gfc_expr *result; - arith rc; - bool did_warn = false; - - result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); - - mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); - - rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); - - if (rc == ARITH_UNDERFLOW) - { - if (warn_underflow) - gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); - mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE); - } - else if (rc != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind); - - if (rc == ARITH_UNDERFLOW) - { - if (warn_underflow) - gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); - mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE); - } - else if (rc != ARITH_OK) - { - arith_error (rc, &src->ts, &result->ts, &src->where); - gfc_free_expr (result); - return NULL; - } - - if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind - && (wprecision_real_real (mpc_realref (src->value.complex), - src->ts.kind, kind) - || wprecision_real_real (mpc_imagref (src->value.complex), - src->ts.kind, kind))) - { - int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; - - gfc_warning_now (w, "Change of value in conversion from " - "%qs to %qs at %L", - gfc_typename (&src->ts), gfc_typename (&result->ts), - &src->where); - did_warn = true; - } - - if (!did_warn && warn_conversion_extra && src->ts.kind != kind) - gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " - "at %L", gfc_typename(&src->ts), - gfc_typename (&result->ts), &src->where); - - return result; -} - - -/* Logical kind conversion. */ - -gfc_expr * -gfc_log2log (gfc_expr *src, int kind) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); - result->value.logical = src->value.logical; - - return result; -} - - -/* Convert logical to integer. */ - -gfc_expr * -gfc_log2int (gfc_expr *src, int kind) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); - mpz_set_si (result->value.integer, src->value.logical); - - return result; -} - - -/* Convert integer to logical. */ - -gfc_expr * -gfc_int2log (gfc_expr *src, int kind) -{ - gfc_expr *result; - - result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); - result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); - - return result; -} - -/* Convert character to character. We only use wide strings internally, - so we only set the kind. */ - -gfc_expr * -gfc_character2character (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_copy_expr (src); - result->ts.kind = kind; - - return result; -} - -/* Helper function to set the representation in a Hollerith conversion. - This assumes that the ts.type and ts.kind of the result have already - been set. */ - -static void -hollerith2representation (gfc_expr *result, gfc_expr *src) -{ - size_t src_len, result_len; - - src_len = src->representation.length - src->ts.u.pad; - gfc_target_expr_size (result, &result_len); - - if (src_len > result_len) - { - gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L " - "is truncated in conversion to %qs", &src->where, - gfc_typename(&result->ts)); - } - - result->representation.string = XCNEWVEC (char, result_len + 1); - memcpy (result->representation.string, src->representation.string, - MIN (result_len, src_len)); - - if (src_len < result_len) - memset (&result->representation.string[src_len], ' ', result_len - src_len); - - result->representation.string[result_len] = '\0'; /* For debugger */ - result->representation.length = result_len; -} - - -/* Helper function to set the representation in a character conversion. - This assumes that the ts.type and ts.kind of the result have already - been set. */ - -static void -character2representation (gfc_expr *result, gfc_expr *src) -{ - size_t src_len, result_len, i; - src_len = src->value.character.length; - gfc_target_expr_size (result, &result_len); - - if (src_len > result_len) - gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is " - "truncated in conversion to %s", &src->where, - gfc_typename(&result->ts)); - - result->representation.string = XCNEWVEC (char, result_len + 1); - - for (i = 0; i < MIN (result_len, src_len); i++) - result->representation.string[i] = (char) src->value.character.string[i]; - - if (src_len < result_len) - memset (&result->representation.string[src_len], ' ', - result_len - src_len); - - result->representation.string[result_len] = '\0'; /* For debugger. */ - result->representation.length = result_len; -} - -/* Convert Hollerith to integer. The constant will be padded or truncated. */ - -gfc_expr * -gfc_hollerith2int (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); - - hollerith2representation (result, src); - gfc_interpret_integer (kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.integer); - - return result; -} - -/* Convert character to integer. The constant will be padded or truncated. */ - -gfc_expr * -gfc_character2int (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); - - character2representation (result, src); - gfc_interpret_integer (kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.integer); - return result; -} - -/* Convert Hollerith to real. The constant will be padded or truncated. */ - -gfc_expr * -gfc_hollerith2real (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_REAL, kind, &src->where); - - hollerith2representation (result, src); - gfc_interpret_float (kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.real); - - return result; -} - -/* Convert character to real. The constant will be padded or truncated. */ - -gfc_expr * -gfc_character2real (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_REAL, kind, &src->where); - - character2representation (result, src); - gfc_interpret_float (kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.real); - - return result; -} - - -/* Convert Hollerith to complex. The constant will be padded or truncated. */ - -gfc_expr * -gfc_hollerith2complex (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); - - hollerith2representation (result, src); - gfc_interpret_complex (kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.complex); - - return result; -} - -/* Convert character to complex. The constant will be padded or truncated. */ - -gfc_expr * -gfc_character2complex (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); - - character2representation (result, src); - gfc_interpret_complex (kind, (unsigned char *) result->representation.string, - result->representation.length, result->value.complex); - - return result; -} - - -/* Convert Hollerith to character. */ - -gfc_expr * -gfc_hollerith2character (gfc_expr *src, int kind) -{ - gfc_expr *result; - - result = gfc_copy_expr (src); - result->ts.type = BT_CHARACTER; - result->ts.kind = kind; - result->ts.u.pad = 0; - - result->value.character.length = result->representation.length; - result->value.character.string - = gfc_char_to_widechar (result->representation.string); - - return result; -} - - -/* Convert Hollerith to logical. The constant will be padded or truncated. */ - -gfc_expr * -gfc_hollerith2logical (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); - - hollerith2representation (result, src); - gfc_interpret_logical (kind, (unsigned char *) result->representation.string, - result->representation.length, &result->value.logical); - - return result; -} - -/* Convert character to logical. The constant will be padded or truncated. */ - -gfc_expr * -gfc_character2logical (gfc_expr *src, int kind) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); - - character2representation (result, src); - gfc_interpret_logical (kind, (unsigned char *) result->representation.string, - result->representation.length, &result->value.logical); - - return result; -} diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc new file mode 100644 index 0000000..b3323ec --- /dev/null +++ b/gcc/fortran/arith.cc @@ -0,0 +1,2706 @@ +/* Compiler arithmetic + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +/* Since target arithmetic must be done on the host, there has to + be some way of evaluating arithmetic expressions as the host + would evaluate them. We use the GNU MP library and the MPFR + library to do arithmetic, and this file provides the interface. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "arith.h" +#include "target-memory.h" +#include "constructor.h" + +bool gfc_seen_div0; + +/* MPFR does not have a direct replacement for mpz_set_f() from GMP. + It's easily implemented with a few calls though. */ + +void +gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where) +{ + mpfr_exp_t e; + + if (mpfr_inf_p (x) || mpfr_nan_p (x)) + { + gfc_error ("Conversion of an Infinity or Not-a-Number at %L " + "to INTEGER", where); + mpz_set_ui (z, 0); + return; + } + + e = mpfr_get_z_exp (z, x); + + if (e > 0) + mpz_mul_2exp (z, z, e); + else + mpz_tdiv_q_2exp (z, z, -e); +} + + +/* Set the model number precision by the requested KIND. */ + +void +gfc_set_model_kind (int kind) +{ + int index = gfc_validate_kind (BT_REAL, kind, false); + int base2prec; + + base2prec = gfc_real_kinds[index].digits; + if (gfc_real_kinds[index].radix != 2) + base2prec *= gfc_real_kinds[index].radix / 2; + mpfr_set_default_prec (base2prec); +} + + +/* Set the model number precision from mpfr_t x. */ + +void +gfc_set_model (mpfr_t x) +{ + mpfr_set_default_prec (mpfr_get_prec (x)); +} + + +/* Given an arithmetic error code, return a pointer to a string that + explains the error. */ + +static const char * +gfc_arith_error (arith code) +{ + const char *p; + + switch (code) + { + case ARITH_OK: + p = G_("Arithmetic OK at %L"); + break; + case ARITH_OVERFLOW: + p = G_("Arithmetic overflow at %L"); + break; + case ARITH_UNDERFLOW: + p = G_("Arithmetic underflow at %L"); + break; + case ARITH_NAN: + p = G_("Arithmetic NaN at %L"); + break; + case ARITH_DIV0: + p = G_("Division by zero at %L"); + break; + case ARITH_INCOMMENSURATE: + p = G_("Array operands are incommensurate at %L"); + break; + case ARITH_ASYMMETRIC: + p = G_("Integer outside symmetric range implied by Standard Fortran" + " at %L"); + break; + case ARITH_WRONGCONCAT: + p = G_("Illegal type in character concatenation at %L"); + break; + + default: + gfc_internal_error ("gfc_arith_error(): Bad error code"); + } + + return p; +} + + +/* Get things ready to do math. */ + +void +gfc_arith_init_1 (void) +{ + gfc_integer_info *int_info; + gfc_real_info *real_info; + mpfr_t a, b; + int i; + + mpfr_set_default_prec (128); + mpfr_init (a); + + /* Convert the minimum and maximum values for each kind into their + GNU MP representation. */ + for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++) + { + /* Huge */ + mpz_init (int_info->huge); + mpz_set_ui (int_info->huge, int_info->radix); + mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits); + mpz_sub_ui (int_info->huge, int_info->huge, 1); + + /* These are the numbers that are actually representable by the + target. For bases other than two, this needs to be changed. */ + if (int_info->radix != 2) + gfc_internal_error ("Fix min_int calculation"); + + /* See PRs 13490 and 17912, related to integer ranges. + The pedantic_min_int exists for range checking when a program + is compiled with -pedantic, and reflects the belief that + Standard Fortran requires integers to be symmetrical, i.e. + every negative integer must have a representable positive + absolute value, and vice versa. */ + + mpz_init (int_info->pedantic_min_int); + mpz_neg (int_info->pedantic_min_int, int_info->huge); + + mpz_init (int_info->min_int); + mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1); + + /* Range */ + mpfr_set_z (a, int_info->huge, GFC_RND_MODE); + mpfr_log10 (a, a, GFC_RND_MODE); + mpfr_trunc (a, a); + int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); + } + + mpfr_clear (a); + + for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++) + { + gfc_set_model_kind (real_info->kind); + + mpfr_init (a); + mpfr_init (b); + + /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b */ + /* 1 - b**(-p) */ + mpfr_init (real_info->huge); + mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE); + mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); + mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE); + mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE); + + /* b**(emax-1) */ + mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); + mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE); + + /* (1 - b**(-p)) * b**(emax-1) */ + mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE); + + /* (1 - b**(-p)) * b**(emax-1) * b */ + mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix, + GFC_RND_MODE); + + /* tiny(x) = b**(emin-1) */ + mpfr_init (real_info->tiny); + mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE); + mpfr_pow_si (real_info->tiny, real_info->tiny, + real_info->min_exponent - 1, GFC_RND_MODE); + + /* subnormal (x) = b**(emin - digit) */ + mpfr_init (real_info->subnormal); + mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE); + mpfr_pow_si (real_info->subnormal, real_info->subnormal, + real_info->min_exponent - real_info->digits, GFC_RND_MODE); + + /* epsilon(x) = b**(1-p) */ + mpfr_init (real_info->epsilon); + mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE); + mpfr_pow_si (real_info->epsilon, real_info->epsilon, + 1 - real_info->digits, GFC_RND_MODE); + + /* range(x) = int(min(log10(huge(x)), -log10(tiny)) */ + mpfr_log10 (a, real_info->huge, GFC_RND_MODE); + mpfr_log10 (b, real_info->tiny, GFC_RND_MODE); + mpfr_neg (b, b, GFC_RND_MODE); + + /* a = min(a, b) */ + mpfr_min (a, a, b, GFC_RND_MODE); + mpfr_trunc (a, a); + real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE); + + /* precision(x) = int((p - 1) * log10(b)) + k */ + mpfr_set_ui (a, real_info->radix, GFC_RND_MODE); + mpfr_log10 (a, a, GFC_RND_MODE); + mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE); + mpfr_trunc (a, a); + real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE); + + /* If the radix is an integral power of 10, add one to the precision. */ + for (i = 10; i <= real_info->radix; i *= 10) + if (i == real_info->radix) + real_info->precision++; + + mpfr_clears (a, b, NULL); + } +} + + +/* Clean up, get rid of numeric constants. */ + +void +gfc_arith_done_1 (void) +{ + gfc_integer_info *ip; + gfc_real_info *rp; + + for (ip = gfc_integer_kinds; ip->kind; ip++) + { + mpz_clear (ip->min_int); + mpz_clear (ip->pedantic_min_int); + mpz_clear (ip->huge); + } + + for (rp = gfc_real_kinds; rp->kind; rp++) + mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL); + + mpfr_free_cache (); +} + + +/* Given a wide character value and a character kind, determine whether + the character is representable for that kind. */ +bool +gfc_check_character_range (gfc_char_t c, int kind) +{ + /* As wide characters are stored as 32-bit values, they're all + representable in UCS=4. */ + if (kind == 4) + return true; + + if (kind == 1) + return c <= 255 ? true : false; + + gcc_unreachable (); +} + + +/* Given an integer and a kind, make sure that the integer lies within + the range of the kind. Returns ARITH_OK, ARITH_ASYMMETRIC or + ARITH_OVERFLOW. */ + +arith +gfc_check_integer_range (mpz_t p, int kind) +{ + arith result; + int i; + + i = gfc_validate_kind (BT_INTEGER, kind, false); + result = ARITH_OK; + + if (pedantic) + { + if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0) + result = ARITH_ASYMMETRIC; + } + + + if (flag_range_check == 0) + return result; + + if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0 + || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0) + result = ARITH_OVERFLOW; + + return result; +} + + +/* Given a real and a kind, make sure that the real lies within the + range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or + ARITH_UNDERFLOW. */ + +static arith +gfc_check_real_range (mpfr_t p, int kind) +{ + arith retval; + mpfr_t q; + int i; + + i = gfc_validate_kind (BT_REAL, kind, false); + + gfc_set_model (p); + mpfr_init (q); + mpfr_abs (q, p, GFC_RND_MODE); + + retval = ARITH_OK; + + if (mpfr_inf_p (p)) + { + if (flag_range_check != 0) + retval = ARITH_OVERFLOW; + } + else if (mpfr_nan_p (p)) + { + if (flag_range_check != 0) + retval = ARITH_NAN; + } + else if (mpfr_sgn (q) == 0) + { + mpfr_clear (q); + return retval; + } + else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0) + { + if (flag_range_check == 0) + mpfr_set_inf (p, mpfr_sgn (p)); + else + retval = ARITH_OVERFLOW; + } + else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0) + { + if (flag_range_check == 0) + { + if (mpfr_sgn (p) < 0) + { + mpfr_set_ui (p, 0, GFC_RND_MODE); + mpfr_set_si (q, -1, GFC_RND_MODE); + mpfr_copysign (p, p, q, GFC_RND_MODE); + } + else + mpfr_set_ui (p, 0, GFC_RND_MODE); + } + else + retval = ARITH_UNDERFLOW; + } + else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0) + { + mpfr_exp_t emin, emax; + int en; + + /* Save current values of emin and emax. */ + emin = mpfr_get_emin (); + emax = mpfr_get_emax (); + + /* Set emin and emax for the current model number. */ + en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1; + mpfr_set_emin ((mpfr_exp_t) en); + mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent); + mpfr_check_range (q, 0, GFC_RND_MODE); + mpfr_subnormalize (q, 0, GFC_RND_MODE); + + /* Reset emin and emax. */ + mpfr_set_emin (emin); + mpfr_set_emax (emax); + + /* Copy sign if needed. */ + if (mpfr_sgn (p) < 0) + mpfr_neg (p, q, MPFR_RNDN); + else + mpfr_set (p, q, MPFR_RNDN); + } + + mpfr_clear (q); + + return retval; +} + + +/* Low-level arithmetic functions. All of these subroutines assume + that all operands are of the same type and return an operand of the + same type. The other thing about these subroutines is that they + can fail in various ways -- overflow, underflow, division by zero, + zero raised to the zero, etc. */ + +static arith +gfc_arith_not (gfc_expr *op1, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where); + result->value.logical = !op1->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical && op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical || op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical == op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical != op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +/* Make sure a constant numeric expression is within the range for + its type and kind. Note that there's also a gfc_check_range(), + but that one deals with the intrinsic RANGE function. */ + +arith +gfc_range_check (gfc_expr *e) +{ + arith rc; + arith rc2; + + switch (e->ts.type) + { + case BT_INTEGER: + rc = gfc_check_integer_range (e->value.integer, e->ts.kind); + break; + + case BT_REAL: + rc = gfc_check_real_range (e->value.real, e->ts.kind); + if (rc == ARITH_UNDERFLOW) + mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); + if (rc == ARITH_OVERFLOW) + mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real)); + if (rc == ARITH_NAN) + mpfr_set_nan (e->value.real); + break; + + case BT_COMPLEX: + rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind); + if (rc == ARITH_UNDERFLOW) + mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE); + if (rc == ARITH_OVERFLOW) + mpfr_set_inf (mpc_realref (e->value.complex), + mpfr_sgn (mpc_realref (e->value.complex))); + if (rc == ARITH_NAN) + mpfr_set_nan (mpc_realref (e->value.complex)); + + rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind); + if (rc == ARITH_UNDERFLOW) + mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE); + if (rc == ARITH_OVERFLOW) + mpfr_set_inf (mpc_imagref (e->value.complex), + mpfr_sgn (mpc_imagref (e->value.complex))); + if (rc == ARITH_NAN) + mpfr_set_nan (mpc_imagref (e->value.complex)); + + if (rc == ARITH_OK) + rc = rc2; + break; + + default: + gfc_internal_error ("gfc_range_check(): Bad type"); + } + + return rc; +} + + +/* Several of the following routines use the same set of statements to + check the validity of the result. Encapsulate the checking here. */ + +static arith +check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp) +{ + arith val = rc; + + if (val == ARITH_UNDERFLOW) + { + if (warn_underflow) + gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where); + val = ARITH_OK; + } + + if (val == ARITH_ASYMMETRIC) + { + gfc_warning (0, gfc_arith_error (val), &x->where); + val = ARITH_OK; + } + + if (val == ARITH_OK || val == ARITH_OVERFLOW) + *rp = r; + else + gfc_free_expr (r); + + return val; +} + + +/* It may seem silly to have a subroutine that actually computes the + unary plus of a constant, but it prevents us from making exceptions + in the code elsewhere. Used for unary plus and parenthesized + expressions. */ + +static arith +gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp) +{ + *resultp = gfc_copy_expr (op1); + return ARITH_OK; +} + + +static arith +gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp) +{ + gfc_expr *result; + arith rc; + + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_neg (result->value.integer, op1->value.integer); + break; + + case BT_REAL: + mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_arith_uminus(): Bad basic type"); + } + + rc = gfc_range_check (result); + + return check_result (rc, op1, result, resultp); +} + + +static arith +gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + arith rc; + + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_add (result->value.integer, op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + mpfr_add (result->value.real, op1->value.real, op2->value.real, + GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_add (result->value.complex, op1->value.complex, op2->value.complex, + GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_arith_plus(): Bad basic type"); + } + + rc = gfc_range_check (result); + + return check_result (rc, op1, result, resultp); +} + + +static arith +gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + arith rc; + + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_sub (result->value.integer, op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + mpfr_sub (result->value.real, op1->value.real, op2->value.real, + GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_sub (result->value.complex, op1->value.complex, + op2->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_arith_minus(): Bad basic type"); + } + + rc = gfc_range_check (result); + + return check_result (rc, op1, result, resultp); +} + + +static arith +gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + arith rc; + + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_mul (result->value.integer, op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + mpfr_mul (result->value.real, op1->value.real, op2->value.real, + GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model (mpc_realref (op1->value.complex)); + mpc_mul (result->value.complex, op1->value.complex, op2->value.complex, + GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_arith_times(): Bad basic type"); + } + + rc = gfc_range_check (result); + + return check_result (rc, op1, result, resultp); +} + + +static arith +gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + arith rc; + + rc = ARITH_OK; + + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + if (mpz_sgn (op2->value.integer) == 0) + { + rc = ARITH_DIV0; + break; + } + + if (warn_integer_division) + { + mpz_t r; + mpz_init (r); + mpz_tdiv_qr (result->value.integer, r, op1->value.integer, + op2->value.integer); + + if (mpz_cmp_si (r, 0) != 0) + { + char *p; + p = mpz_get_str (NULL, 10, result->value.integer); + gfc_warning_now (OPT_Winteger_division, "Integer division " + "truncated to constant %qs at %L", p, + &op1->where); + free (p); + } + mpz_clear (r); + } + else + mpz_tdiv_q (result->value.integer, op1->value.integer, + op2->value.integer); + + break; + + case BT_REAL: + if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1) + { + rc = ARITH_DIV0; + break; + } + + mpfr_div (result->value.real, op1->value.real, op2->value.real, + GFC_RND_MODE); + break; + + case BT_COMPLEX: + if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0 + && flag_range_check == 1) + { + rc = ARITH_DIV0; + break; + } + + gfc_set_model (mpc_realref (op1->value.complex)); + if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0) + { + /* In Fortran, return (NaN + NaN I) for any zero divisor. See + PR 40318. */ + mpfr_set_nan (mpc_realref (result->value.complex)); + mpfr_set_nan (mpc_imagref (result->value.complex)); + } + else + mpc_div (result->value.complex, op1->value.complex, op2->value.complex, + GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_arith_divide(): Bad basic type"); + } + + if (rc == ARITH_OK) + rc = gfc_range_check (result); + + return check_result (rc, op1, result, resultp); +} + +/* Raise a number to a power. */ + +static arith +arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + int power_sign; + gfc_expr *result; + arith rc; + + rc = ARITH_OK; + result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op2->ts.type) + { + case BT_INTEGER: + power_sign = mpz_sgn (op2->value.integer); + + if (power_sign == 0) + { + /* Handle something to the zeroth power. Since we're dealing + with integral exponents, there is no ambiguity in the + limiting procedure used to determine the value of 0**0. */ + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_set_ui (result->value.integer, 1); + break; + + case BT_REAL: + mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("arith_power(): Bad base"); + } + } + else + { + switch (op1->ts.type) + { + case BT_INTEGER: + { + /* First, we simplify the cases of op1 == 1, 0 or -1. */ + if (mpz_cmp_si (op1->value.integer, 1) == 0) + { + /* 1**op2 == 1 */ + mpz_set_si (result->value.integer, 1); + } + else if (mpz_cmp_si (op1->value.integer, 0) == 0) + { + /* 0**op2 == 0, if op2 > 0 + 0**op2 overflow, if op2 < 0 ; in that case, we + set the result to 0 and return ARITH_DIV0. */ + mpz_set_si (result->value.integer, 0); + if (mpz_cmp_si (op2->value.integer, 0) < 0) + rc = ARITH_DIV0; + } + else if (mpz_cmp_si (op1->value.integer, -1) == 0) + { + /* (-1)**op2 == (-1)**(mod(op2,2)) */ + unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2); + if (odd) + mpz_set_si (result->value.integer, -1); + else + mpz_set_si (result->value.integer, 1); + } + /* Then, we take care of op2 < 0. */ + else if (mpz_cmp_si (op2->value.integer, 0) < 0) + { + /* if op2 < 0, op1**op2 == 0 because abs(op1) > 1. */ + mpz_set_si (result->value.integer, 0); + if (warn_integer_division) + gfc_warning_now (OPT_Winteger_division, "Negative " + "exponent of integer has zero " + "result at %L", &result->where); + } + else + { + /* We have abs(op1) > 1 and op2 > 1. + If op2 > bit_size(op1), we'll have an out-of-range + result. */ + int k, power; + + k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false); + power = gfc_integer_kinds[k].bit_size; + if (mpz_cmp_si (op2->value.integer, power) < 0) + { + gfc_extract_int (op2, &power); + mpz_pow_ui (result->value.integer, op1->value.integer, + power); + rc = gfc_range_check (result); + if (rc == ARITH_OVERFLOW) + gfc_error_now ("Result of exponentiation at %L " + "exceeds the range of %s", &op1->where, + gfc_typename (&(op1->ts))); + } + else + { + /* Provide a nonsense value to propagate up. */ + mpz_set (result->value.integer, + gfc_integer_kinds[k].huge); + mpz_add_ui (result->value.integer, + result->value.integer, 1); + rc = ARITH_OVERFLOW; + } + } + } + break; + + case BT_REAL: + mpfr_pow_z (result->value.real, op1->value.real, + op2->value.integer, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_pow_z (result->value.complex, op1->value.complex, + op2->value.integer, GFC_MPC_RND_MODE); + break; + + default: + break; + } + } + break; + + case BT_REAL: + + if (gfc_init_expr_flag) + { + if (!gfc_notify_std (GFC_STD_F2003, "Noninteger " + "exponent in an initialization " + "expression at %L", &op2->where)) + { + gfc_free_expr (result); + return ARITH_PROHIBIT; + } + } + + if (mpfr_cmp_si (op1->value.real, 0) < 0) + { + gfc_error ("Raising a negative REAL at %L to " + "a REAL power is prohibited", &op1->where); + gfc_free_expr (result); + return ARITH_PROHIBIT; + } + + mpfr_pow (result->value.real, op1->value.real, op2->value.real, + GFC_RND_MODE); + break; + + case BT_COMPLEX: + { + if (gfc_init_expr_flag) + { + if (!gfc_notify_std (GFC_STD_F2003, "Noninteger " + "exponent in an initialization " + "expression at %L", &op2->where)) + { + gfc_free_expr (result); + return ARITH_PROHIBIT; + } + } + + mpc_pow (result->value.complex, op1->value.complex, + op2->value.complex, GFC_MPC_RND_MODE); + } + break; + default: + gfc_internal_error ("arith_power(): unknown type"); + } + + if (rc == ARITH_OK) + rc = gfc_range_check (result); + + return check_result (rc, op1, result, resultp); +} + + +/* Concatenate two string constants. */ + +static arith +gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + size_t len; + + /* By cleverly playing around with constructors, it is possible + to get mismaching types here. */ + if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER + || op1->ts.kind != op2->ts.kind) + return ARITH_WRONGCONCAT; + + result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind, + &op1->where); + + len = op1->value.character.length + op2->value.character.length; + + result->value.character.string = gfc_get_wide_string (len + 1); + result->value.character.length = len; + + memcpy (result->value.character.string, op1->value.character.string, + op1->value.character.length * sizeof (gfc_char_t)); + + memcpy (&result->value.character.string[op1->value.character.length], + op2->value.character.string, + op2->value.character.length * sizeof (gfc_char_t)); + + result->value.character.string[len] = '\0'; + + *resultp = result; + + return ARITH_OK; +} + +/* Comparison between real values; returns 0 if (op1 .op. op2) is true. + This function mimics mpfr_cmp but takes NaN into account. */ + +static int +compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + int rc; + switch (op) + { + case INTRINSIC_EQ: + rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1; + break; + case INTRINSIC_GT: + rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1; + break; + case INTRINSIC_GE: + rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1; + break; + case INTRINSIC_LT: + rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1; + break; + case INTRINSIC_LE: + rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1; + break; + default: + gfc_internal_error ("compare_real(): Bad operator"); + } + + return rc; +} + +/* Comparison operators. Assumes that the two expression nodes + contain two constants of the same type. The op argument is + needed to handle NaN correctly. */ + +int +gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + int rc; + + switch (op1->ts.type) + { + case BT_INTEGER: + rc = mpz_cmp (op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + rc = compare_real (op1, op2, op); + break; + + case BT_CHARACTER: + rc = gfc_compare_string (op1, op2); + break; + + case BT_LOGICAL: + rc = ((!op1->value.logical && op2->value.logical) + || (op1->value.logical && !op2->value.logical)); + break; + + default: + gfc_internal_error ("gfc_compare_expr(): Bad basic type"); + } + + return rc; +} + + +/* Compare a pair of complex numbers. Naturally, this is only for + equality and inequality. */ + +static int +compare_complex (gfc_expr *op1, gfc_expr *op2) +{ + return mpc_cmp (op1->value.complex, op2->value.complex) == 0; +} + + +/* Given two constant strings and the inverse collating sequence, compare the + strings. We return -1 for a < b, 0 for a == b and 1 for a > b. + We use the processor's default collating sequence. */ + +int +gfc_compare_string (gfc_expr *a, gfc_expr *b) +{ + size_t len, alen, blen, i; + gfc_char_t ac, bc; + + alen = a->value.character.length; + blen = b->value.character.length; + + len = MAX(alen, blen); + + for (i = 0; i < len; i++) + { + ac = ((i < alen) ? a->value.character.string[i] : ' '); + bc = ((i < blen) ? b->value.character.string[i] : ' '); + + if (ac < bc) + return -1; + if (ac > bc) + return 1; + } + + /* Strings are equal */ + return 0; +} + + +int +gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive) +{ + size_t len, alen, blen, i; + gfc_char_t ac, bc; + + alen = a->value.character.length; + blen = strlen (b); + + len = MAX(alen, blen); + + for (i = 0; i < len; i++) + { + ac = ((i < alen) ? a->value.character.string[i] : ' '); + bc = ((i < blen) ? b[i] : ' '); + + if (!case_sensitive) + { + ac = TOLOWER (ac); + bc = TOLOWER (bc); + } + + if (ac < bc) + return -1; + if (ac > bc) + return 1; + } + + /* Strings are equal */ + return 0; +} + + +/* Specific comparison subroutines. */ + +static arith +gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); + result->value.logical = (op1->ts.type == BT_COMPLEX) + ? compare_complex (op1, op2) + : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0); + + *resultp = result; + return ARITH_OK; +} + + +static arith +gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); + result->value.logical = (op1->ts.type == BT_COMPLEX) + ? !compare_complex (op1, op2) + : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0); + + *resultp = result; + return ARITH_OK; +} + + +static arith +gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind, + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op, + gfc_expr **result) +{ + gfc_constructor_base head; + gfc_constructor *c; + gfc_expr *r; + arith rc; + + if (op->expr_type == EXPR_CONSTANT) + return eval (op, result); + + rc = ARITH_OK; + head = gfc_constructor_copy (op->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) + { + rc = reduce_unary (eval, c->expr, &r); + + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (rc != ARITH_OK) + gfc_constructor_free (head); + else + { + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op->where); + r->shape = gfc_copy_shape (op->shape, op->rank); + r->rank = op->rank; + r->value.constructor = head; + *result = r; + } + + return rc; +} + + +static arith +reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr *op1, gfc_expr *op2, gfc_expr **result) +{ + gfc_constructor_base head; + gfc_constructor *c; + gfc_expr *r; + arith rc = ARITH_OK; + + head = gfc_constructor_copy (op1->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) + { + if (c->expr->expr_type == EXPR_CONSTANT) + rc = eval (c->expr, op2, &r); + else + rc = reduce_binary_ac (eval, c->expr, op2, &r); + + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (rc != ARITH_OK) + gfc_constructor_free (head); + else + { + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op1->where); + r->shape = gfc_copy_shape (op1->shape, op1->rank); + r->rank = op1->rank; + r->value.constructor = head; + *result = r; + } + + return rc; +} + + +static arith +reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr *op1, gfc_expr *op2, gfc_expr **result) +{ + gfc_constructor_base head; + gfc_constructor *c; + gfc_expr *r; + arith rc = ARITH_OK; + + head = gfc_constructor_copy (op2->value.constructor); + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) + { + if (c->expr->expr_type == EXPR_CONSTANT) + rc = eval (op1, c->expr, &r); + else + rc = reduce_binary_ca (eval, op1, c->expr, &r); + + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (rc != ARITH_OK) + gfc_constructor_free (head); + else + { + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op2->where); + r->shape = gfc_copy_shape (op2->shape, op2->rank); + r->rank = op2->rank; + r->value.constructor = head; + *result = r; + } + + return rc; +} + + +/* We need a forward declaration of reduce_binary. */ +static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr *op1, gfc_expr *op2, gfc_expr **result); + + +static arith +reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr *op1, gfc_expr *op2, gfc_expr **result) +{ + gfc_constructor_base head; + gfc_constructor *c, *d; + gfc_expr *r; + arith rc = ARITH_OK; + + if (!gfc_check_conformance (op1, op2, _("elemental binary operation"))) + return ARITH_INCOMMENSURATE; + + head = gfc_constructor_copy (op1->value.constructor); + for (c = gfc_constructor_first (head), + d = gfc_constructor_first (op2->value.constructor); + c && d; + c = gfc_constructor_next (c), d = gfc_constructor_next (d)) + { + rc = reduce_binary (eval, c->expr, d->expr, &r); + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (c || d) + rc = ARITH_INCOMMENSURATE; + + if (rc != ARITH_OK) + gfc_constructor_free (head); + else + { + gfc_constructor *c = gfc_constructor_first (head); + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op1->where); + r->shape = gfc_copy_shape (op1->shape, op1->rank); + r->rank = op1->rank; + r->value.constructor = head; + *result = r; + } + + return rc; +} + + +static arith +reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr *op1, gfc_expr *op2, gfc_expr **result) +{ + if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT) + return eval (op1, op2, result); + + if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY) + return reduce_binary_ca (eval, op1, op2, result); + + if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT) + return reduce_binary_ac (eval, op1, op2, result); + + return reduce_binary_aa (eval, op1, op2, result); +} + + +typedef union +{ + arith (*f2)(gfc_expr *, gfc_expr **); + arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **); +} +eval_f; + +/* High level arithmetic subroutines. These subroutines go into + eval_intrinsic(), which can do one of several things to its + operands. If the operands are incompatible with the intrinsic + operation, we return a node pointing to the operands and hope that + an operator interface is found during resolution. + + If the operands are compatible and are constants, then we try doing + the arithmetic. We also handle the cases where either or both + operands are array constructors. */ + +static gfc_expr * +eval_intrinsic (gfc_intrinsic_op op, + eval_f eval, gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr temp, *result; + int unary; + arith rc; + + gfc_clear_ts (&temp.ts); + + switch (op) + { + /* Logical unary */ + case INTRINSIC_NOT: + if (op1->ts.type != BT_LOGICAL) + goto runtime; + + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind; + unary = 1; + break; + + /* Logical binary operators */ + case INTRINSIC_OR: + case INTRINSIC_AND: + case INTRINSIC_NEQV: + case INTRINSIC_EQV: + if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL) + goto runtime; + + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind; + unary = 0; + break; + + /* Numeric unary */ + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + if (!gfc_numeric_ts (&op1->ts)) + goto runtime; + + temp.ts = op1->ts; + unary = 1; + break; + + case INTRINSIC_PARENTHESES: + temp.ts = op1->ts; + unary = 1; + break; + + /* Additional restrictions for ordering relations. */ + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) + { + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind; + goto runtime; + } + + /* Fall through */ + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) + { + unary = 0; + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind; + + /* If kind mismatch, exit and we'll error out later. */ + if (op1->ts.kind != op2->ts.kind) + goto runtime; + + break; + } + + gcc_fallthrough (); + /* Numeric binary */ + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts)) + goto runtime; + + /* Insert any necessary type conversions to make the operands + compatible. */ + + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.value.op.op = op; + + temp.value.op.op1 = op1; + temp.value.op.op2 = op2; + + gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra); + + if (op == INTRINSIC_EQ || op == INTRINSIC_NE + || op == INTRINSIC_GE || op == INTRINSIC_GT + || op == INTRINSIC_LE || op == INTRINSIC_LT + || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS + || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS + || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS) + { + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind; + } + + unary = 0; + break; + + /* Character binary */ + case INTRINSIC_CONCAT: + if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER + || op1->ts.kind != op2->ts.kind) + goto runtime; + + temp.ts.type = BT_CHARACTER; + temp.ts.kind = op1->ts.kind; + unary = 0; + break; + + case INTRINSIC_USER: + goto runtime; + + default: + gfc_internal_error ("eval_intrinsic(): Bad operator"); + } + + if (op1->expr_type != EXPR_CONSTANT + && (op1->expr_type != EXPR_ARRAY + || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1))) + goto runtime; + + if (op2 != NULL + && op2->expr_type != EXPR_CONSTANT + && (op2->expr_type != EXPR_ARRAY + || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2))) + goto runtime; + + if (unary) + rc = reduce_unary (eval.f2, op1, &result); + else + rc = reduce_binary (eval.f3, op1, op2, &result); + + + /* Something went wrong. */ + if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT) + return NULL; + + if (rc != ARITH_OK) + { + gfc_error (gfc_arith_error (rc), &op1->where); + if (rc == ARITH_OVERFLOW) + goto done; + + if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER) + gfc_seen_div0 = true; + + return NULL; + } + +done: + + gfc_free_expr (op1); + gfc_free_expr (op2); + return result; + +runtime: + /* Create a run-time expression. */ + result = gfc_get_operator_expr (&op1->where, op, op1, op2); + result->ts = temp.ts; + + return result; +} + + +/* Modify type of expression for zero size array. */ + +static gfc_expr * +eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op) +{ + if (op == NULL) + gfc_internal_error ("eval_type_intrinsic0(): op NULL"); + + switch (iop) + { + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + op->ts.type = BT_LOGICAL; + op->ts.kind = gfc_default_logical_kind; + break; + + default: + break; + } + + return op; +} + + +/* Return nonzero if the expression is a zero size array. */ + +static int +gfc_zero_size_array (gfc_expr *e) +{ + if (e->expr_type != EXPR_ARRAY) + return 0; + + return e->value.constructor == NULL; +} + + +/* Reduce a binary expression where at least one of the operands + involves a zero-length array. Returns NULL if neither of the + operands is a zero-length array. */ + +static gfc_expr * +reduce_binary0 (gfc_expr *op1, gfc_expr *op2) +{ + if (gfc_zero_size_array (op1)) + { + gfc_free_expr (op2); + return op1; + } + + if (gfc_zero_size_array (op2)) + { + gfc_free_expr (op1); + return op2; + } + + return NULL; +} + + +static gfc_expr * +eval_intrinsic_f2 (gfc_intrinsic_op op, + arith (*eval) (gfc_expr *, gfc_expr **), + gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *result; + eval_f f; + + if (op2 == NULL) + { + if (gfc_zero_size_array (op1)) + return eval_type_intrinsic0 (op, op1); + } + else + { + result = reduce_binary0 (op1, op2); + if (result != NULL) + return eval_type_intrinsic0 (op, result); + } + + f.f2 = eval; + return eval_intrinsic (op, f, op1, op2); +} + + +static gfc_expr * +eval_intrinsic_f3 (gfc_intrinsic_op op, + arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *result; + eval_f f; + + if (!op1 && !op2) + return NULL; + + result = reduce_binary0 (op1, op2); + if (result != NULL) + return eval_type_intrinsic0(op, result); + + f.f3 = eval; + return eval_intrinsic (op, f, op1, op2); +} + + +gfc_expr * +gfc_parentheses (gfc_expr *op) +{ + if (gfc_is_constant_expr (op)) + return op; + + return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity, + op, NULL); +} + +gfc_expr * +gfc_uplus (gfc_expr *op) +{ + return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL); +} + + +gfc_expr * +gfc_uminus (gfc_expr *op) +{ + return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL); +} + + +gfc_expr * +gfc_add (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2); +} + + +gfc_expr * +gfc_subtract (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2); +} + + +gfc_expr * +gfc_multiply (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2); +} + + +gfc_expr * +gfc_divide (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2); +} + + +gfc_expr * +gfc_power (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2); +} + + +gfc_expr * +gfc_concat (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2); +} + + +gfc_expr * +gfc_and (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2); +} + + +gfc_expr * +gfc_or (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2); +} + + +gfc_expr * +gfc_not (gfc_expr *op1) +{ + return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL); +} + + +gfc_expr * +gfc_eqv (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2); +} + + +gfc_expr * +gfc_neqv (gfc_expr *op1, gfc_expr *op2) +{ + return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2); +} + + +gfc_expr * +gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2); +} + + +gfc_expr * +gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2); +} + + +gfc_expr * +gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2); +} + + +gfc_expr * +gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2); +} + + +gfc_expr * +gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2); +} + + +gfc_expr * +gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op) +{ + return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2); +} + + +/******* Simplification of intrinsic functions with constant arguments *****/ + + +/* Deal with an arithmetic error. */ + +static void +arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where) +{ + switch (rc) + { + case ARITH_OK: + gfc_error ("Arithmetic OK converting %s to %s at %L", + gfc_typename (from), gfc_typename (to), where); + break; + case ARITH_OVERFLOW: + gfc_error ("Arithmetic overflow converting %s to %s at %L. This check " + "can be disabled with the option %<-fno-range-check%>", + gfc_typename (from), gfc_typename (to), where); + break; + case ARITH_UNDERFLOW: + gfc_error ("Arithmetic underflow converting %s to %s at %L. This check " + "can be disabled with the option %<-fno-range-check%>", + gfc_typename (from), gfc_typename (to), where); + break; + case ARITH_NAN: + gfc_error ("Arithmetic NaN converting %s to %s at %L. This check " + "can be disabled with the option %<-fno-range-check%>", + gfc_typename (from), gfc_typename (to), where); + break; + case ARITH_DIV0: + gfc_error ("Division by zero converting %s to %s at %L", + gfc_typename (from), gfc_typename (to), where); + break; + case ARITH_INCOMMENSURATE: + gfc_error ("Array operands are incommensurate converting %s to %s at %L", + gfc_typename (from), gfc_typename (to), where); + break; + case ARITH_ASYMMETRIC: + gfc_error ("Integer outside symmetric range implied by Standard Fortran" + " converting %s to %s at %L", + gfc_typename (from), gfc_typename (to), where); + break; + default: + gfc_internal_error ("gfc_arith_error(): Bad error code"); + } + + /* TODO: Do something about the error, i.e., throw exception, return + NaN, etc. */ +} + +/* Returns true if significant bits were lost when converting real + constant r from from_kind to to_kind. */ + +static bool +wprecision_real_real (mpfr_t r, int from_kind, int to_kind) +{ + mpfr_t rv, diff; + bool ret; + + gfc_set_model_kind (to_kind); + mpfr_init (rv); + gfc_set_model_kind (from_kind); + mpfr_init (diff); + + mpfr_set (rv, r, GFC_RND_MODE); + mpfr_sub (diff, rv, r, GFC_RND_MODE); + + ret = ! mpfr_zero_p (diff); + mpfr_clear (rv); + mpfr_clear (diff); + return ret; +} + +/* Return true if conversion from an integer to a real loses precision. */ + +static bool +wprecision_int_real (mpz_t n, mpfr_t r) +{ + bool ret; + mpz_t i; + mpz_init (i); + mpfr_get_z (i, r, GFC_RND_MODE); + mpz_sub (i, i, n); + ret = mpz_cmp_si (i, 0) != 0; + mpz_clear (i); + return ret; +} + +/* Convert integers to integers. */ + +gfc_expr * +gfc_int2int (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); + + mpz_set (result->value.integer, src->value.integer); + + if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) + { + if (rc == ARITH_ASYMMETRIC) + { + gfc_warning (0, gfc_arith_error (rc), &src->where); + } + else + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + } + + /* If we do not trap numeric overflow, we need to convert the number to + signed, throwing away high-order bits if necessary. */ + if (flag_range_check == 0) + { + int k; + + k = gfc_validate_kind (BT_INTEGER, kind, false); + gfc_convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + if (warn_conversion && !src->do_not_warn && kind < src->ts.kind) + gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + } + return result; +} + + +/* Convert integers to reals. */ + +gfc_expr * +gfc_int2real (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); + + mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE); + + if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if (warn_conversion + && wprecision_int_real (src->value.integer, result->value.real)) + gfc_warning (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", + gfc_typename (&src->ts), + gfc_typename (&result->ts), + &src->where); + + return result; +} + + +/* Convert default integer to default complex. */ + +gfc_expr * +gfc_int2complex (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); + + mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE); + + if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind)) + != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if (warn_conversion + && wprecision_int_real (src->value.integer, + mpc_realref (result->value.complex))) + gfc_warning_now (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", + gfc_typename (&src->ts), + gfc_typename (&result->ts), + &src->where); + + return result; +} + + +/* Convert default real to default integer. */ + +gfc_expr * +gfc_real2int (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); + + gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where); + + if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + /* If there was a fractional part, warn about this. */ + + if (warn_conversion) + { + mpfr_t f; + mpfr_init (f); + mpfr_frac (f, src->value.real, GFC_RND_MODE); + if (mpfr_cmp_si (f, 0) != 0) + { + gfc_warning_now (OPT_Wconversion, "Change of value in conversion " + "from %qs to %qs at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + did_warn = true; + } + } + if (!did_warn && warn_conversion_extra) + { + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + } + + return result; +} + + +/* Convert real to real. */ + +gfc_expr * +gfc_real2real (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); + + mpfr_set (result->value.real, src->value.real, GFC_RND_MODE); + + rc = gfc_check_real_range (result->value.real, kind); + + if (rc == ARITH_UNDERFLOW) + { + if (warn_underflow) + gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + } + else if (rc != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + /* As a special bonus, don't warn about REAL values which are not changed by + the conversion if -Wconversion is specified and -Wconversion-extra is + not. */ + + if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + /* Calculate the difference between the constant and the rounded + value and check it against zero. */ + + if (wprecision_real_real (src->value.real, src->ts.kind, kind)) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + /* Make sure the conversion warning is not emitted again. */ + did_warn = true; + } + } + + if (!did_warn && warn_conversion_extra) + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename(&src->ts), + gfc_typename(&result->ts), &src->where); + + return result; +} + + +/* Convert real to complex. */ + +gfc_expr * +gfc_real2complex (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); + + mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE); + + rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); + + if (rc == ARITH_UNDERFLOW) + { + if (warn_underflow) + gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); + mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE); + } + else if (rc != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + if (wprecision_real_real (src->value.real, src->ts.kind, kind)) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + /* Make sure the conversion warning is not emitted again. */ + did_warn = true; + } + } + + if (!did_warn && warn_conversion_extra) + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename(&src->ts), + gfc_typename(&result->ts), &src->where); + + return result; +} + + +/* Convert complex to integer. */ + +gfc_expr * +gfc_complex2int (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); + + gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex), + &src->where); + + if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if (warn_conversion || warn_conversion_extra) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + /* See if we discarded an imaginary part. */ + if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) + { + gfc_warning_now (w, "Non-zero imaginary part discarded " + "in conversion from %qs to %qs at %L", + gfc_typename(&src->ts), gfc_typename (&result->ts), + &src->where); + did_warn = true; + } + + else { + mpfr_t f; + + mpfr_init (f); + mpfr_frac (f, src->value.real, GFC_RND_MODE); + if (mpfr_cmp_si (f, 0) != 0) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + did_warn = true; + } + mpfr_clear (f); + } + + if (!did_warn && warn_conversion_extra) + { + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename (&src->ts), + gfc_typename (&result->ts), &src->where); + } + } + + return result; +} + + +/* Convert complex to real. */ + +gfc_expr * +gfc_complex2real (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); + + mpc_real (result->value.real, src->value.complex, GFC_RND_MODE); + + rc = gfc_check_real_range (result->value.real, kind); + + if (rc == ARITH_UNDERFLOW) + { + if (warn_underflow) + gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + } + if (rc != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if (warn_conversion || warn_conversion_extra) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + /* See if we discarded an imaginary part. */ + if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0) + { + gfc_warning (w, "Non-zero imaginary part discarded " + "in conversion from %qs to %qs at %L", + gfc_typename(&src->ts), gfc_typename (&result->ts), + &src->where); + did_warn = true; + } + + /* Calculate the difference between the real constant and the rounded + value and check it against zero. */ + + if (kind > src->ts.kind + && wprecision_real_real (mpc_realref (src->value.complex), + src->ts.kind, kind)) + { + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + /* Make sure the conversion warning is not emitted again. */ + did_warn = true; + } + } + + if (!did_warn && warn_conversion_extra) + gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L", + gfc_typename(&src->ts), gfc_typename (&result->ts), + &src->where); + + return result; +} + + +/* Convert complex to complex. */ + +gfc_expr * +gfc_complex2complex (gfc_expr *src, int kind) +{ + gfc_expr *result; + arith rc; + bool did_warn = false; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); + + mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE); + + rc = gfc_check_real_range (mpc_realref (result->value.complex), kind); + + if (rc == ARITH_UNDERFLOW) + { + if (warn_underflow) + gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); + mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE); + } + else if (rc != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind); + + if (rc == ARITH_UNDERFLOW) + { + if (warn_underflow) + gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where); + mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE); + } + else if (rc != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind + && (wprecision_real_real (mpc_realref (src->value.complex), + src->ts.kind, kind) + || wprecision_real_real (mpc_imagref (src->value.complex), + src->ts.kind, kind))) + { + int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra; + + gfc_warning_now (w, "Change of value in conversion from " + "%qs to %qs at %L", + gfc_typename (&src->ts), gfc_typename (&result->ts), + &src->where); + did_warn = true; + } + + if (!did_warn && warn_conversion_extra && src->ts.kind != kind) + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs " + "at %L", gfc_typename(&src->ts), + gfc_typename (&result->ts), &src->where); + + return result; +} + + +/* Logical kind conversion. */ + +gfc_expr * +gfc_log2log (gfc_expr *src, int kind) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); + result->value.logical = src->value.logical; + + return result; +} + + +/* Convert logical to integer. */ + +gfc_expr * +gfc_log2int (gfc_expr *src, int kind) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); + mpz_set_si (result->value.integer, src->value.logical); + + return result; +} + + +/* Convert integer to logical. */ + +gfc_expr * +gfc_int2log (gfc_expr *src, int kind) +{ + gfc_expr *result; + + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); + result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0); + + return result; +} + +/* Convert character to character. We only use wide strings internally, + so we only set the kind. */ + +gfc_expr * +gfc_character2character (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_copy_expr (src); + result->ts.kind = kind; + + return result; +} + +/* Helper function to set the representation in a Hollerith conversion. + This assumes that the ts.type and ts.kind of the result have already + been set. */ + +static void +hollerith2representation (gfc_expr *result, gfc_expr *src) +{ + size_t src_len, result_len; + + src_len = src->representation.length - src->ts.u.pad; + gfc_target_expr_size (result, &result_len); + + if (src_len > result_len) + { + gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L " + "is truncated in conversion to %qs", &src->where, + gfc_typename(&result->ts)); + } + + result->representation.string = XCNEWVEC (char, result_len + 1); + memcpy (result->representation.string, src->representation.string, + MIN (result_len, src_len)); + + if (src_len < result_len) + memset (&result->representation.string[src_len], ' ', result_len - src_len); + + result->representation.string[result_len] = '\0'; /* For debugger */ + result->representation.length = result_len; +} + + +/* Helper function to set the representation in a character conversion. + This assumes that the ts.type and ts.kind of the result have already + been set. */ + +static void +character2representation (gfc_expr *result, gfc_expr *src) +{ + size_t src_len, result_len, i; + src_len = src->value.character.length; + gfc_target_expr_size (result, &result_len); + + if (src_len > result_len) + gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is " + "truncated in conversion to %s", &src->where, + gfc_typename(&result->ts)); + + result->representation.string = XCNEWVEC (char, result_len + 1); + + for (i = 0; i < MIN (result_len, src_len); i++) + result->representation.string[i] = (char) src->value.character.string[i]; + + if (src_len < result_len) + memset (&result->representation.string[src_len], ' ', + result_len - src_len); + + result->representation.string[result_len] = '\0'; /* For debugger. */ + result->representation.length = result_len; +} + +/* Convert Hollerith to integer. The constant will be padded or truncated. */ + +gfc_expr * +gfc_hollerith2int (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); + + hollerith2representation (result, src); + gfc_interpret_integer (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.integer); + + return result; +} + +/* Convert character to integer. The constant will be padded or truncated. */ + +gfc_expr * +gfc_character2int (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); + + character2representation (result, src); + gfc_interpret_integer (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.integer); + return result; +} + +/* Convert Hollerith to real. The constant will be padded or truncated. */ + +gfc_expr * +gfc_hollerith2real (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); + + hollerith2representation (result, src); + gfc_interpret_float (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.real); + + return result; +} + +/* Convert character to real. The constant will be padded or truncated. */ + +gfc_expr * +gfc_character2real (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_REAL, kind, &src->where); + + character2representation (result, src); + gfc_interpret_float (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.real); + + return result; +} + + +/* Convert Hollerith to complex. The constant will be padded or truncated. */ + +gfc_expr * +gfc_hollerith2complex (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); + + hollerith2representation (result, src); + gfc_interpret_complex (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.complex); + + return result; +} + +/* Convert character to complex. The constant will be padded or truncated. */ + +gfc_expr * +gfc_character2complex (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); + + character2representation (result, src); + gfc_interpret_complex (kind, (unsigned char *) result->representation.string, + result->representation.length, result->value.complex); + + return result; +} + + +/* Convert Hollerith to character. */ + +gfc_expr * +gfc_hollerith2character (gfc_expr *src, int kind) +{ + gfc_expr *result; + + result = gfc_copy_expr (src); + result->ts.type = BT_CHARACTER; + result->ts.kind = kind; + result->ts.u.pad = 0; + + result->value.character.length = result->representation.length; + result->value.character.string + = gfc_char_to_widechar (result->representation.string); + + return result; +} + + +/* Convert Hollerith to logical. The constant will be padded or truncated. */ + +gfc_expr * +gfc_hollerith2logical (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); + + hollerith2representation (result, src); + gfc_interpret_logical (kind, (unsigned char *) result->representation.string, + result->representation.length, &result->value.logical); + + return result; +} + +/* Convert character to logical. The constant will be padded or truncated. */ + +gfc_expr * +gfc_character2logical (gfc_expr *src, int kind) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); + + character2representation (result, src); + gfc_interpret_logical (kind, (unsigned char *) result->representation.string, + result->representation.length, &result->value.logical); + + return result; +} diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c deleted file mode 100644 index 4723043..0000000 --- a/gcc/fortran/array.c +++ /dev/null @@ -1,2785 +0,0 @@ -/* Array things - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "parse.h" -#include "match.h" -#include "constructor.h" - -/**************** Array reference matching subroutines *****************/ - -/* Copy an array reference structure. */ - -gfc_array_ref * -gfc_copy_array_ref (gfc_array_ref *src) -{ - gfc_array_ref *dest; - int i; - - if (src == NULL) - return NULL; - - dest = gfc_get_array_ref (); - - *dest = *src; - - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) - { - dest->start[i] = gfc_copy_expr (src->start[i]); - dest->end[i] = gfc_copy_expr (src->end[i]); - dest->stride[i] = gfc_copy_expr (src->stride[i]); - } - - return dest; -} - - -/* Match a single dimension of an array reference. This can be a - single element or an array section. Any modifications we've made - to the ar structure are cleaned up by the caller. If the init - is set, we require the subscript to be a valid initialization - expression. */ - -static match -match_subscript (gfc_array_ref *ar, int init, bool match_star) -{ - match m = MATCH_ERROR; - bool star = false; - int i; - bool saw_boz = false; - - i = ar->dimen + ar->codimen; - - gfc_gobble_whitespace (); - ar->c_where[i] = gfc_current_locus; - ar->start[i] = ar->end[i] = ar->stride[i] = NULL; - - /* We can't be sure of the difference between DIMEN_ELEMENT and - DIMEN_VECTOR until we know the type of the element itself at - resolution time. */ - - ar->dimen_type[i] = DIMEN_UNKNOWN; - - if (gfc_match_char (':') == MATCH_YES) - goto end_element; - - /* Get start element. */ - if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) - star = true; - - if (!star && init) - m = gfc_match_init_expr (&ar->start[i]); - else if (!star) - m = gfc_match_expr (&ar->start[i]); - - if (ar->start[i] && ar->start[i]->ts.type == BT_BOZ) - { - gfc_error ("Invalid BOZ literal constant used in subscript at %C"); - saw_boz = true; - } - - if (m == MATCH_NO) - gfc_error ("Expected array subscript at %C"); - if (m != MATCH_YES) - return MATCH_ERROR; - - if (gfc_match_char (':') == MATCH_NO) - goto matched; - - if (star) - { - gfc_error ("Unexpected %<*%> in coarray subscript at %C"); - return MATCH_ERROR; - } - - /* Get an optional end element. Because we've seen the colon, we - definitely have a range along this dimension. */ -end_element: - ar->dimen_type[i] = DIMEN_RANGE; - - if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) - star = true; - else if (init) - m = gfc_match_init_expr (&ar->end[i]); - else - m = gfc_match_expr (&ar->end[i]); - - if (ar->end[i] && ar->end[i]->ts.type == BT_BOZ) - { - gfc_error ("Invalid BOZ literal constant used in subscript at %C"); - saw_boz = true; - } - - if (m == MATCH_ERROR) - return MATCH_ERROR; - - /* See if we have an optional stride. */ - if (gfc_match_char (':') == MATCH_YES) - { - if (star) - { - gfc_error ("Strides not allowed in coarray subscript at %C"); - return MATCH_ERROR; - } - - m = init ? gfc_match_init_expr (&ar->stride[i]) - : gfc_match_expr (&ar->stride[i]); - - if (ar->stride[i] && ar->stride[i]->ts.type == BT_BOZ) - { - gfc_error ("Invalid BOZ literal constant used in subscript at %C"); - saw_boz = true; - } - - if (m == MATCH_NO) - gfc_error ("Expected array subscript stride at %C"); - if (m != MATCH_YES) - return MATCH_ERROR; - } - -matched: - if (star) - ar->dimen_type[i] = DIMEN_STAR; - - return (saw_boz ? MATCH_ERROR : MATCH_YES); -} - - -/* Match an array reference, whether it is the whole array or particular - elements or a section. If init is set, the reference has to consist - of init expressions. */ - -match -gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, - int corank) -{ - match m; - bool matched_bracket = false; - gfc_expr *tmp; - bool stat_just_seen = false; - bool team_just_seen = false; - - memset (ar, '\0', sizeof (*ar)); - - ar->where = gfc_current_locus; - ar->as = as; - ar->type = AR_UNKNOWN; - - if (gfc_match_char ('[') == MATCH_YES) - { - matched_bracket = true; - goto coarray; - } - - if (gfc_match_char ('(') != MATCH_YES) - { - ar->type = AR_FULL; - ar->dimen = 0; - return MATCH_YES; - } - - for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) - { - m = match_subscript (ar, init, false); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match_char (')') == MATCH_YES) - { - ar->dimen++; - goto coarray; - } - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Invalid form of array reference at %C"); - return MATCH_ERROR; - } - } - - if (ar->dimen >= 7 - && !gfc_notify_std (GFC_STD_F2008, - "Array reference at %C has more than 7 dimensions")) - return MATCH_ERROR; - - gfc_error ("Array reference at %C cannot have more than %d dimensions", - GFC_MAX_DIMENSIONS); - return MATCH_ERROR; - -coarray: - if (!matched_bracket && gfc_match_char ('[') != MATCH_YES) - { - if (ar->dimen > 0) - return MATCH_YES; - else - return MATCH_ERROR; - } - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return MATCH_ERROR; - } - - if (corank == 0) - { - gfc_error ("Unexpected coarray designator at %C"); - return MATCH_ERROR; - } - - ar->stat = NULL; - - for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) - { - m = match_subscript (ar, init, true); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - team_just_seen = false; - stat_just_seen = false; - if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL) - { - ar->team = tmp; - team_just_seen = true; - } - - if (ar->team && !team_just_seen) - { - gfc_error ("TEAM= attribute in %C misplaced"); - return MATCH_ERROR; - } - - if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL) - { - ar->stat = tmp; - stat_just_seen = true; - } - - if (ar->stat && !stat_just_seen) - { - gfc_error ("STAT= attribute in %C misplaced"); - return MATCH_ERROR; - } - - if (gfc_match_char (']') == MATCH_YES) - { - ar->codimen++; - if (ar->codimen < corank) - { - gfc_error ("Too few codimensions at %C, expected %d not %d", - corank, ar->codimen); - return MATCH_ERROR; - } - if (ar->codimen > corank) - { - gfc_error ("Too many codimensions at %C, expected %d not %d", - corank, ar->codimen); - return MATCH_ERROR; - } - return MATCH_YES; - } - - if (gfc_match_char (',') != MATCH_YES) - { - if (gfc_match_char ('*') == MATCH_YES) - gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", - ar->codimen + 1, corank); - else - gfc_error ("Invalid form of coarray reference at %C"); - return MATCH_ERROR; - } - else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR) - { - gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", - ar->codimen + 1, corank); - return MATCH_ERROR; - } - - if (ar->codimen >= corank) - { - gfc_error ("Invalid codimension %d at %C, only %d codimensions exist", - ar->codimen + 1, corank); - return MATCH_ERROR; - } - } - - gfc_error ("Array reference at %C cannot have more than %d dimensions", - GFC_MAX_DIMENSIONS); - return MATCH_ERROR; - -} - - -/************** Array specification matching subroutines ***************/ - -/* Free all of the expressions associated with array bounds - specifications. */ - -void -gfc_free_array_spec (gfc_array_spec *as) -{ - int i; - - if (as == NULL) - return; - - if (as->corank == 0) - { - for (i = 0; i < as->rank; i++) - { - gfc_free_expr (as->lower[i]); - gfc_free_expr (as->upper[i]); - } - } - else - { - int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0); - for (i = 0; i < n; i++) - { - gfc_free_expr (as->lower[i]); - gfc_free_expr (as->upper[i]); - } - } - - free (as); -} - - -/* Take an array bound, resolves the expression, that make up the - shape and check associated constraints. */ - -static bool -resolve_array_bound (gfc_expr *e, int check_constant) -{ - if (e == NULL) - return true; - - if (!gfc_resolve_expr (e) - || !gfc_specification_expr (e)) - return false; - - if (check_constant && !gfc_is_constant_expr (e)) - { - if (e->expr_type == EXPR_VARIABLE) - gfc_error ("Variable %qs at %L in this context must be constant", - e->symtree->n.sym->name, &e->where); - else - gfc_error ("Expression at %L in this context must be constant", - &e->where); - return false; - } - - return true; -} - - -/* Takes an array specification, resolves the expressions that make up - the shape and make sure everything is integral. */ - -bool -gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) -{ - gfc_expr *e; - int i; - - if (as == NULL) - return true; - - if (as->resolved) - return true; - - for (i = 0; i < as->rank + as->corank; i++) - { - if (i == GFC_MAX_DIMENSIONS) - return false; - - e = as->lower[i]; - if (!resolve_array_bound (e, check_constant)) - return false; - - e = as->upper[i]; - if (!resolve_array_bound (e, check_constant)) - return false; - - if ((as->lower[i] == NULL) || (as->upper[i] == NULL)) - continue; - - /* If the size is negative in this dimension, set it to zero. */ - if (as->lower[i]->expr_type == EXPR_CONSTANT - && as->upper[i]->expr_type == EXPR_CONSTANT - && mpz_cmp (as->upper[i]->value.integer, - as->lower[i]->value.integer) < 0) - { - gfc_free_expr (as->upper[i]); - as->upper[i] = gfc_copy_expr (as->lower[i]); - mpz_sub_ui (as->upper[i]->value.integer, - as->upper[i]->value.integer, 1); - } - } - - as->resolved = true; - - return true; -} - - -/* Match a single array element specification. The return values as - well as the upper and lower bounds of the array spec are filled - in according to what we see on the input. The caller makes sure - individual specifications make sense as a whole. - - - Parsed Lower Upper Returned - ------------------------------------ - : NULL NULL AS_DEFERRED (*) - x 1 x AS_EXPLICIT - x: x NULL AS_ASSUMED_SHAPE - x:y x y AS_EXPLICIT - x:* x NULL AS_ASSUMED_SIZE - * 1 NULL AS_ASSUMED_SIZE - - (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This - is fixed during the resolution of formal interfaces. - - Anything else AS_UNKNOWN. */ - -static array_type -match_array_element_spec (gfc_array_spec *as) -{ - gfc_expr **upper, **lower; - match m; - int rank; - - rank = as->rank == -1 ? 0 : as->rank; - lower = &as->lower[rank + as->corank - 1]; - upper = &as->upper[rank + as->corank - 1]; - - if (gfc_match_char ('*') == MATCH_YES) - { - *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - return AS_ASSUMED_SIZE; - } - - if (gfc_match_char (':') == MATCH_YES) - return AS_DEFERRED; - - m = gfc_match_expr (upper); - if (m == MATCH_NO) - gfc_error ("Expected expression in array specification at %C"); - if (m != MATCH_YES) - return AS_UNKNOWN; - if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) - return AS_UNKNOWN; - - gfc_try_simplify_expr (*upper, 0); - - if (((*upper)->expr_type == EXPR_CONSTANT - && (*upper)->ts.type != BT_INTEGER) || - ((*upper)->expr_type == EXPR_FUNCTION - && (*upper)->ts.type == BT_UNKNOWN - && (*upper)->symtree - && strcmp ((*upper)->symtree->name, "null") == 0)) - { - gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", - gfc_basic_typename ((*upper)->ts.type)); - return AS_UNKNOWN; - } - - if (gfc_match_char (':') == MATCH_NO) - { - *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - return AS_EXPLICIT; - } - - *lower = *upper; - *upper = NULL; - - if (gfc_match_char ('*') == MATCH_YES) - return AS_ASSUMED_SIZE; - - m = gfc_match_expr (upper); - if (m == MATCH_ERROR) - return AS_UNKNOWN; - if (m == MATCH_NO) - return AS_ASSUMED_SHAPE; - if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) - return AS_UNKNOWN; - - gfc_try_simplify_expr (*upper, 0); - - if (((*upper)->expr_type == EXPR_CONSTANT - && (*upper)->ts.type != BT_INTEGER) || - ((*upper)->expr_type == EXPR_FUNCTION - && (*upper)->ts.type == BT_UNKNOWN - && (*upper)->symtree - && strcmp ((*upper)->symtree->name, "null") == 0)) - { - gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", - gfc_basic_typename ((*upper)->ts.type)); - return AS_UNKNOWN; - } - - return AS_EXPLICIT; -} - - -/* Matches an array specification, incidentally figuring out what sort - it is. Match either a normal array specification, or a coarray spec - or both. Optionally allow [:] for coarrays. */ - -match -gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) -{ - array_type current_type; - gfc_array_spec *as; - int i; - - as = gfc_get_array_spec (); - - if (!match_dim) - goto coarray; - - if (gfc_match_char ('(') != MATCH_YES) - { - if (!match_codim) - goto done; - goto coarray; - } - - if (gfc_match (" .. )") == MATCH_YES) - { - as->type = AS_ASSUMED_RANK; - as->rank = -1; - - if (!gfc_notify_std (GFC_STD_F2018, "Assumed-rank array at %C")) - goto cleanup; - - if (!match_codim) - goto done; - goto coarray; - } - - for (;;) - { - as->rank++; - current_type = match_array_element_spec (as); - - /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size - and implied-shape specifications. If the rank is at least 2, we can - distinguish between them. But for rank 1, we currently return - ASSUMED_SIZE; this gets adjusted later when we know for sure - whether the symbol parsed is a PARAMETER or not. */ - - if (as->rank == 1) - { - if (current_type == AS_UNKNOWN) - goto cleanup; - as->type = current_type; - } - else - switch (as->type) - { /* See how current spec meshes with the existing. */ - case AS_UNKNOWN: - goto cleanup; - - case AS_IMPLIED_SHAPE: - if (current_type != AS_ASSUMED_SIZE) - { - gfc_error ("Bad array specification for implied-shape" - " array at %C"); - goto cleanup; - } - break; - - case AS_EXPLICIT: - if (current_type == AS_ASSUMED_SIZE) - { - as->type = AS_ASSUMED_SIZE; - break; - } - - if (current_type == AS_EXPLICIT) - break; - - gfc_error ("Bad array specification for an explicitly shaped " - "array at %C"); - - goto cleanup; - - case AS_ASSUMED_SHAPE: - if ((current_type == AS_ASSUMED_SHAPE) - || (current_type == AS_DEFERRED)) - break; - - gfc_error ("Bad array specification for assumed shape " - "array at %C"); - goto cleanup; - - case AS_DEFERRED: - if (current_type == AS_DEFERRED) - break; - - if (current_type == AS_ASSUMED_SHAPE) - { - as->type = AS_ASSUMED_SHAPE; - break; - } - - gfc_error ("Bad specification for deferred shape array at %C"); - goto cleanup; - - case AS_ASSUMED_SIZE: - if (as->rank == 2 && current_type == AS_ASSUMED_SIZE) - { - as->type = AS_IMPLIED_SHAPE; - break; - } - - gfc_error ("Bad specification for assumed size array at %C"); - goto cleanup; - - case AS_ASSUMED_RANK: - gcc_unreachable (); - } - - if (gfc_match_char (')') == MATCH_YES) - break; - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expected another dimension in array declaration at %C"); - goto cleanup; - } - - if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) - { - gfc_error ("Array specification at %C has more than %d dimensions", - GFC_MAX_DIMENSIONS); - goto cleanup; - } - - if (as->corank + as->rank >= 7 - && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C " - "with more than 7 dimensions")) - goto cleanup; - } - - if (!match_codim) - goto done; - -coarray: - if (gfc_match_char ('[') != MATCH_YES) - goto done; - - if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C")) - goto cleanup; - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - goto cleanup; - } - - if (as->rank >= GFC_MAX_DIMENSIONS) - { - gfc_error ("Array specification at %C has more than %d " - "dimensions", GFC_MAX_DIMENSIONS); - goto cleanup; - } - - for (;;) - { - as->corank++; - current_type = match_array_element_spec (as); - - if (current_type == AS_UNKNOWN) - goto cleanup; - - if (as->corank == 1) - as->cotype = current_type; - else - switch (as->cotype) - { /* See how current spec meshes with the existing. */ - case AS_IMPLIED_SHAPE: - case AS_UNKNOWN: - goto cleanup; - - case AS_EXPLICIT: - if (current_type == AS_ASSUMED_SIZE) - { - as->cotype = AS_ASSUMED_SIZE; - break; - } - - if (current_type == AS_EXPLICIT) - break; - - gfc_error ("Bad array specification for an explicitly " - "shaped array at %C"); - - goto cleanup; - - case AS_ASSUMED_SHAPE: - if ((current_type == AS_ASSUMED_SHAPE) - || (current_type == AS_DEFERRED)) - break; - - gfc_error ("Bad array specification for assumed shape " - "array at %C"); - goto cleanup; - - case AS_DEFERRED: - if (current_type == AS_DEFERRED) - break; - - if (current_type == AS_ASSUMED_SHAPE) - { - as->cotype = AS_ASSUMED_SHAPE; - break; - } - - gfc_error ("Bad specification for deferred shape array at %C"); - goto cleanup; - - case AS_ASSUMED_SIZE: - gfc_error ("Bad specification for assumed size array at %C"); - goto cleanup; - - case AS_ASSUMED_RANK: - gcc_unreachable (); - } - - if (gfc_match_char (']') == MATCH_YES) - break; - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expected another dimension in array declaration at %C"); - goto cleanup; - } - - if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) - { - gfc_error ("Array specification at %C has more than %d " - "dimensions", GFC_MAX_DIMENSIONS); - goto cleanup; - } - } - - if (current_type == AS_EXPLICIT) - { - gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C"); - goto cleanup; - } - - if (as->cotype == AS_ASSUMED_SIZE) - as->cotype = AS_EXPLICIT; - - if (as->rank == 0) - as->type = as->cotype; - -done: - if (as->rank == 0 && as->corank == 0) - { - *asp = NULL; - gfc_free_array_spec (as); - return MATCH_NO; - } - - /* If a lower bounds of an assumed shape array is blank, put in one. */ - if (as->type == AS_ASSUMED_SHAPE) - { - for (i = 0; i < as->rank + as->corank; i++) - { - if (as->lower[i] == NULL) - as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - } - } - - *asp = as; - - return MATCH_YES; - -cleanup: - /* Something went wrong. */ - gfc_free_array_spec (as); - return MATCH_ERROR; -} - -/* Given a symbol and an array specification, modify the symbol to - have that array specification. The error locus is needed in case - something goes wrong. On failure, the caller must free the spec. */ - -bool -gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) -{ - int i; - symbol_attribute *attr; - - if (as == NULL) - return true; - - /* If the symbol corresponds to a submodule module procedure the array spec is - already set, so do not attempt to set it again here. */ - attr = &sym->attr; - if (gfc_submodule_procedure(attr)) - return true; - - if (as->rank - && !gfc_add_dimension (&sym->attr, sym->name, error_loc)) - return false; - - if (as->corank - && !gfc_add_codimension (&sym->attr, sym->name, error_loc)) - return false; - - if (sym->as == NULL) - { - sym->as = as; - return true; - } - - if ((sym->as->type == AS_ASSUMED_RANK && as->corank) - || (as->type == AS_ASSUMED_RANK && sym->as->corank)) - { - gfc_error ("The assumed-rank array %qs at %L shall not have a " - "codimension", sym->name, error_loc); - return false; - } - - /* Check F2018:C822. */ - if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) - goto too_many; - - if (as->corank) - { - sym->as->cotype = as->cotype; - sym->as->corank = as->corank; - /* Check F2018:C822. */ - if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) - goto too_many; - - for (i = 0; i < as->corank; i++) - { - sym->as->lower[sym->as->rank + i] = as->lower[i]; - sym->as->upper[sym->as->rank + i] = as->upper[i]; - } - } - else - { - /* The "sym" has no rank (checked via gfc_add_dimension). Thus - the dimension is added - but first the codimensions (if existing - need to be shifted to make space for the dimension. */ - gcc_assert (as->corank == 0 && sym->as->rank == 0); - - sym->as->rank = as->rank; - sym->as->type = as->type; - sym->as->cray_pointee = as->cray_pointee; - sym->as->cp_was_assumed = as->cp_was_assumed; - - /* Check F2018:C822. */ - if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) - goto too_many; - - for (i = sym->as->corank - 1; i >= 0; i--) - { - sym->as->lower[as->rank + i] = sym->as->lower[i]; - sym->as->upper[as->rank + i] = sym->as->upper[i]; - } - for (i = 0; i < as->rank; i++) - { - sym->as->lower[i] = as->lower[i]; - sym->as->upper[i] = as->upper[i]; - } - } - - free (as); - return true; - -too_many: - - gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name, - GFC_MAX_DIMENSIONS); - return false; -} - - -/* Copy an array specification. */ - -gfc_array_spec * -gfc_copy_array_spec (gfc_array_spec *src) -{ - gfc_array_spec *dest; - int i; - - if (src == NULL) - return NULL; - - dest = gfc_get_array_spec (); - - *dest = *src; - - for (i = 0; i < dest->rank + dest->corank; i++) - { - dest->lower[i] = gfc_copy_expr (dest->lower[i]); - dest->upper[i] = gfc_copy_expr (dest->upper[i]); - } - - return dest; -} - - -/* Returns nonzero if the two expressions are equal. Only handles integer - constants. */ - -static int -compare_bounds (gfc_expr *bound1, gfc_expr *bound2) -{ - if (bound1 == NULL || bound2 == NULL - || bound1->expr_type != EXPR_CONSTANT - || bound2->expr_type != EXPR_CONSTANT - || bound1->ts.type != BT_INTEGER - || bound2->ts.type != BT_INTEGER) - gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered"); - - if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0) - return 1; - else - return 0; -} - - -/* Compares two array specifications. They must be constant or deferred - shape. */ - -int -gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) -{ - int i; - - if (as1 == NULL && as2 == NULL) - return 1; - - if (as1 == NULL || as2 == NULL) - return 0; - - if (as1->rank != as2->rank) - return 0; - - if (as1->corank != as2->corank) - return 0; - - if (as1->rank == 0) - return 1; - - if (as1->type != as2->type) - return 0; - - if (as1->type == AS_EXPLICIT) - for (i = 0; i < as1->rank + as1->corank; i++) - { - if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) - return 0; - - if (compare_bounds (as1->upper[i], as2->upper[i]) == 0) - return 0; - } - - return 1; -} - - -/****************** Array constructor functions ******************/ - - -/* Given an expression node that might be an array constructor and a - symbol, make sure that no iterators in this or child constructors - use the symbol as an implied-DO iterator. Returns nonzero if a - duplicate was found. */ - -static int -check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) -{ - gfc_constructor *c; - gfc_expr *e; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - e = c->expr; - - if (e->expr_type == EXPR_ARRAY - && check_duplicate_iterator (e->value.constructor, master)) - return 1; - - if (c->iterator == NULL) - continue; - - if (c->iterator->var->symtree->n.sym == master) - { - gfc_error ("DO-iterator %qs at %L is inside iterator of the " - "same name", master->name, &c->where); - - return 1; - } - } - - return 0; -} - - -/* Forward declaration because these functions are mutually recursive. */ -static match match_array_cons_element (gfc_constructor_base *); - -/* Match a list of array elements. */ - -static match -match_array_list (gfc_constructor_base *result) -{ - gfc_constructor_base head; - gfc_constructor *p; - gfc_iterator iter; - locus old_loc; - gfc_expr *e; - match m; - int n; - - old_loc = gfc_current_locus; - - if (gfc_match_char ('(') == MATCH_NO) - return MATCH_NO; - - memset (&iter, '\0', sizeof (gfc_iterator)); - head = NULL; - - m = match_array_cons_element (&head); - if (m != MATCH_YES) - goto cleanup; - - if (gfc_match_char (',') != MATCH_YES) - { - m = MATCH_NO; - goto cleanup; - } - - for (n = 1;; n++) - { - m = gfc_match_iterator (&iter, 0); - if (m == MATCH_YES) - break; - if (m == MATCH_ERROR) - goto cleanup; - - m = match_array_cons_element (&head); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - if (n > 2) - goto syntax; - m = MATCH_NO; - goto cleanup; /* Could be a complex constant */ - } - - if (gfc_match_char (',') != MATCH_YES) - { - if (n > 2) - goto syntax; - m = MATCH_NO; - goto cleanup; - } - } - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - if (check_duplicate_iterator (head, iter.var->symtree->n.sym)) - { - m = MATCH_ERROR; - goto cleanup; - } - - e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); - e->value.constructor = head; - - p = gfc_constructor_append_expr (result, e, &gfc_current_locus); - p->iterator = gfc_get_iterator (); - *p->iterator = iter; - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in array constructor at %C"); - m = MATCH_ERROR; - -cleanup: - gfc_constructor_free (head); - gfc_free_iterator (&iter, 0); - gfc_current_locus = old_loc; - return m; -} - - -/* Match a single element of an array constructor, which can be a - single expression or a list of elements. */ - -static match -match_array_cons_element (gfc_constructor_base *result) -{ - gfc_expr *expr; - match m; - - m = match_array_list (result); - if (m != MATCH_NO) - return m; - - m = gfc_match_expr (&expr); - if (m != MATCH_YES) - return m; - - if (expr->ts.type == BT_BOZ) - { - gfc_error ("BOZ literal constant at %L cannot appear in an " - "array constructor", &expr->where); - goto done; - } - - if (expr->expr_type == EXPR_FUNCTION - && expr->ts.type == BT_UNKNOWN - && strcmp(expr->symtree->name, "null") == 0) - { - gfc_error ("NULL() at %C cannot appear in an array constructor"); - goto done; - } - - gfc_constructor_append_expr (result, expr, &gfc_current_locus); - return MATCH_YES; - -done: - gfc_free_expr (expr); - return MATCH_ERROR; -} - - -/* Convert components of an array constructor to the type in ts. */ - -static match -walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head) -{ - gfc_constructor *c; - gfc_expr *e; - match m; - - for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) - { - e = c->expr; - if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_UNKNOWN - && !e->ref && e->value.constructor) - { - m = walk_array_constructor (ts, e->value.constructor); - if (m == MATCH_ERROR) - return m; - } - else if (!gfc_convert_type_warn (e, ts, 1, 1, true) - && e->ts.type != BT_UNKNOWN) - return MATCH_ERROR; - } - return MATCH_YES; -} - -/* Match an array constructor. */ - -match -gfc_match_array_constructor (gfc_expr **result) -{ - gfc_constructor *c; - gfc_constructor_base head; - gfc_expr *expr; - gfc_typespec ts; - locus where; - match m; - const char *end_delim; - bool seen_ts; - - head = NULL; - seen_ts = false; - - if (gfc_match (" (/") == MATCH_NO) - { - if (gfc_match (" [") == MATCH_NO) - return MATCH_NO; - else - { - if (!gfc_notify_std (GFC_STD_F2003, "[...] " - "style array constructors at %C")) - return MATCH_ERROR; - end_delim = " ]"; - } - } - else - end_delim = " /)"; - - where = gfc_current_locus; - - /* Try to match an optional "type-spec ::" */ - gfc_clear_ts (&ts); - m = gfc_match_type_spec (&ts); - if (m == MATCH_YES) - { - seen_ts = (gfc_match (" ::") == MATCH_YES); - - if (seen_ts) - { - if (!gfc_notify_std (GFC_STD_F2003, "Array constructor " - "including type specification at %C")) - goto cleanup; - - if (ts.deferred) - { - gfc_error ("Type-spec at %L cannot contain a deferred " - "type parameter", &where); - goto cleanup; - } - - if (ts.type == BT_CHARACTER - && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec) - { - gfc_error ("Type-spec at %L cannot contain an asterisk for a " - "type parameter", &where); - goto cleanup; - } - } - } - else if (m == MATCH_ERROR) - goto cleanup; - - if (!seen_ts) - gfc_current_locus = where; - - if (gfc_match (end_delim) == MATCH_YES) - { - if (seen_ts) - goto done; - else - { - gfc_error ("Empty array constructor at %C is not allowed"); - goto cleanup; - } - } - - for (;;) - { - m = match_array_cons_element (&head); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (gfc_match_char (',') == MATCH_NO) - break; - } - - if (gfc_match (end_delim) == MATCH_NO) - goto syntax; - -done: - /* Size must be calculated at resolution time. */ - if (seen_ts) - { - expr = gfc_get_array_expr (ts.type, ts.kind, &where); - expr->ts = ts; - - /* If the typespec is CHARACTER, check that array elements can - be converted. See PR fortran/67803. */ - if (ts.type == BT_CHARACTER) - { - c = gfc_constructor_first (head); - for (; c; c = gfc_constructor_next (c)) - { - if (gfc_numeric_ts (&c->expr->ts) - || c->expr->ts.type == BT_LOGICAL) - { - gfc_error ("Incompatible typespec for array element at %L", - &c->expr->where); - return MATCH_ERROR; - } - - /* Special case null(). */ - if (c->expr->expr_type == EXPR_FUNCTION - && c->expr->ts.type == BT_UNKNOWN - && strcmp (c->expr->symtree->name, "null") == 0) - { - gfc_error ("Incompatible typespec for array element at %L", - &c->expr->where); - return MATCH_ERROR; - } - } - } - - /* Walk the constructor, and if possible, do type conversion for - numeric types. */ - if (gfc_numeric_ts (&ts)) - { - m = walk_array_constructor (&ts, head); - if (m == MATCH_ERROR) - return m; - } - } - else - expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); - - expr->value.constructor = head; - if (expr->ts.u.cl) - expr->ts.u.cl->length_from_typespec = seen_ts; - - *result = expr; - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in array constructor at %C"); - -cleanup: - gfc_constructor_free (head); - return MATCH_ERROR; -} - - - -/************** Check array constructors for correctness **************/ - -/* Given an expression, compare it's type with the type of the current - constructor. Returns nonzero if an error was issued. The - cons_state variable keeps track of whether the type of the - constructor being read or resolved is known to be good, bad or just - starting out. */ - -static gfc_typespec constructor_ts; -static enum -{ CONS_START, CONS_GOOD, CONS_BAD } -cons_state; - -static int -check_element_type (gfc_expr *expr, bool convert) -{ - if (cons_state == CONS_BAD) - return 0; /* Suppress further errors */ - - if (cons_state == CONS_START) - { - if (expr->ts.type == BT_UNKNOWN) - cons_state = CONS_BAD; - else - { - cons_state = CONS_GOOD; - constructor_ts = expr->ts; - } - - return 0; - } - - if (gfc_compare_types (&constructor_ts, &expr->ts)) - return 0; - - if (convert) - return gfc_convert_type_warn (expr, &constructor_ts, 1, 1, true) ? 0 : 1; - - gfc_error ("Element in %s array constructor at %L is %s", - gfc_typename (&constructor_ts), &expr->where, - gfc_typename (expr)); - - cons_state = CONS_BAD; - return 1; -} - - -/* Recursive work function for gfc_check_constructor_type(). */ - -static bool -check_constructor_type (gfc_constructor_base base, bool convert) -{ - gfc_constructor *c; - gfc_expr *e; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - e = c->expr; - - if (e->expr_type == EXPR_ARRAY) - { - if (!check_constructor_type (e->value.constructor, convert)) - return false; - - continue; - } - - if (check_element_type (e, convert)) - return false; - } - - return true; -} - - -/* Check that all elements of an array constructor are the same type. - On false, an error has been generated. */ - -bool -gfc_check_constructor_type (gfc_expr *e) -{ - bool t; - - if (e->ts.type != BT_UNKNOWN) - { - cons_state = CONS_GOOD; - constructor_ts = e->ts; - } - else - { - cons_state = CONS_START; - gfc_clear_ts (&constructor_ts); - } - - /* If e->ts.type != BT_UNKNOWN, the array constructor included a - typespec, and we will now convert the values on the fly. */ - t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN); - if (t && e->ts.type == BT_UNKNOWN) - e->ts = constructor_ts; - - return t; -} - - - -typedef struct cons_stack -{ - gfc_iterator *iterator; - struct cons_stack *previous; -} -cons_stack; - -static cons_stack *base; - -static bool check_constructor (gfc_constructor_base, bool (*) (gfc_expr *)); - -/* Check an EXPR_VARIABLE expression in a constructor to make sure - that that variable is an iteration variable. */ - -bool -gfc_check_iter_variable (gfc_expr *expr) -{ - gfc_symbol *sym; - cons_stack *c; - - sym = expr->symtree->n.sym; - - for (c = base; c && c->iterator; c = c->previous) - if (sym == c->iterator->var->symtree->n.sym) - return true; - - return false; -} - - -/* Recursive work function for gfc_check_constructor(). This amounts - to calling the check function for each expression in the - constructor, giving variables with the names of iterators a pass. */ - -static bool -check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *)) -{ - cons_stack element; - gfc_expr *e; - bool t; - gfc_constructor *c; - - for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) - { - e = c->expr; - - if (!e) - continue; - - if (e->expr_type != EXPR_ARRAY) - { - if (!(*check_function)(e)) - return false; - continue; - } - - element.previous = base; - element.iterator = c->iterator; - - base = &element; - t = check_constructor (e->value.constructor, check_function); - base = element.previous; - - if (!t) - return false; - } - - /* Nothing went wrong, so all OK. */ - return true; -} - - -/* Checks a constructor to see if it is a particular kind of - expression -- specification, restricted, or initialization as - determined by the check_function. */ - -bool -gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *)) -{ - cons_stack *base_save; - bool t; - - base_save = base; - base = NULL; - - t = check_constructor (expr->value.constructor, check_function); - base = base_save; - - return t; -} - - - -/**************** Simplification of array constructors ****************/ - -iterator_stack *iter_stack; - -typedef struct -{ - gfc_constructor_base base; - int extract_count, extract_n; - gfc_expr *extracted; - mpz_t *count; - - mpz_t *offset; - gfc_component *component; - mpz_t *repeat; - - bool (*expand_work_function) (gfc_expr *); -} -expand_info; - -static expand_info current_expand; - -static bool expand_constructor (gfc_constructor_base); - - -/* Work function that counts the number of elements present in a - constructor. */ - -static bool -count_elements (gfc_expr *e) -{ - mpz_t result; - - if (e->rank == 0) - mpz_add_ui (*current_expand.count, *current_expand.count, 1); - else - { - if (!gfc_array_size (e, &result)) - { - gfc_free_expr (e); - return false; - } - - mpz_add (*current_expand.count, *current_expand.count, result); - mpz_clear (result); - } - - gfc_free_expr (e); - return true; -} - - -/* Work function that extracts a particular element from an array - constructor, freeing the rest. */ - -static bool -extract_element (gfc_expr *e) -{ - if (e->rank != 0) - { /* Something unextractable */ - gfc_free_expr (e); - return false; - } - - if (current_expand.extract_count == current_expand.extract_n) - current_expand.extracted = e; - else - gfc_free_expr (e); - - current_expand.extract_count++; - - return true; -} - - -/* Work function that constructs a new constructor out of the old one, - stringing new elements together. */ - -static bool -expand (gfc_expr *e) -{ - gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base, - e, &e->where); - - c->n.component = current_expand.component; - return true; -} - - -/* Given an initialization expression that is a variable reference, - substitute the current value of the iteration variable. */ - -void -gfc_simplify_iterator_var (gfc_expr *e) -{ - iterator_stack *p; - - for (p = iter_stack; p; p = p->prev) - if (e->symtree == p->variable) - break; - - if (p == NULL) - return; /* Variable not found */ - - gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); - - mpz_set (e->value.integer, p->value); - - return; -} - - -/* Expand an expression with that is inside of a constructor, - recursing into other constructors if present. */ - -static bool -expand_expr (gfc_expr *e) -{ - if (e->expr_type == EXPR_ARRAY) - return expand_constructor (e->value.constructor); - - e = gfc_copy_expr (e); - - if (!gfc_simplify_expr (e, 1)) - { - gfc_free_expr (e); - return false; - } - - return current_expand.expand_work_function (e); -} - - -static bool -expand_iterator (gfc_constructor *c) -{ - gfc_expr *start, *end, *step; - iterator_stack frame; - mpz_t trip; - bool t; - - end = step = NULL; - - t = false; - - mpz_init (trip); - mpz_init (frame.value); - frame.prev = NULL; - - start = gfc_copy_expr (c->iterator->start); - if (!gfc_simplify_expr (start, 1)) - goto cleanup; - - if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER) - goto cleanup; - - end = gfc_copy_expr (c->iterator->end); - if (!gfc_simplify_expr (end, 1)) - goto cleanup; - - if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER) - goto cleanup; - - step = gfc_copy_expr (c->iterator->step); - if (!gfc_simplify_expr (step, 1)) - goto cleanup; - - if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER) - goto cleanup; - - if (mpz_sgn (step->value.integer) == 0) - { - gfc_error ("Iterator step at %L cannot be zero", &step->where); - goto cleanup; - } - - /* Calculate the trip count of the loop. */ - mpz_sub (trip, end->value.integer, start->value.integer); - mpz_add (trip, trip, step->value.integer); - mpz_tdiv_q (trip, trip, step->value.integer); - - mpz_set (frame.value, start->value.integer); - - frame.prev = iter_stack; - frame.variable = c->iterator->var->symtree; - iter_stack = &frame; - - while (mpz_sgn (trip) > 0) - { - if (!expand_expr (c->expr)) - goto cleanup; - - mpz_add (frame.value, frame.value, step->value.integer); - mpz_sub_ui (trip, trip, 1); - } - - t = true; - -cleanup: - gfc_free_expr (start); - gfc_free_expr (end); - gfc_free_expr (step); - - mpz_clear (trip); - mpz_clear (frame.value); - - iter_stack = frame.prev; - - return t; -} - -/* Variables for noticing if all constructors are empty, and - if any of them had a type. */ - -static bool empty_constructor; -static gfc_typespec empty_ts; - -/* Expand a constructor into constant constructors without any - iterators, calling the work function for each of the expanded - expressions. The work function needs to either save or free the - passed expression. */ - -static bool -expand_constructor (gfc_constructor_base base) -{ - gfc_constructor *c; - gfc_expr *e; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) - { - if (c->iterator != NULL) - { - if (!expand_iterator (c)) - return false; - continue; - } - - e = c->expr; - - if (e == NULL) - return false; - - if (empty_constructor) - empty_ts = e->ts; - - /* Simplify constant array expression/section within constructor. */ - if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref - && e->symtree && e->symtree->n.sym - && e->symtree->n.sym->attr.flavor == FL_PARAMETER) - gfc_simplify_expr (e, 0); - - if (e->expr_type == EXPR_ARRAY) - { - if (!expand_constructor (e->value.constructor)) - return false; - - continue; - } - - empty_constructor = false; - e = gfc_copy_expr (e); - if (!gfc_simplify_expr (e, 1)) - { - gfc_free_expr (e); - return false; - } - e->from_constructor = 1; - current_expand.offset = &c->offset; - current_expand.repeat = &c->repeat; - current_expand.component = c->n.component; - if (!current_expand.expand_work_function(e)) - return false; - } - return true; -} - - -/* Given an array expression and an element number (starting at zero), - return a pointer to the array element. NULL is returned if the - size of the array has been exceeded. The expression node returned - remains a part of the array and should not be freed. Access is not - efficient at all, but this is another place where things do not - have to be particularly fast. */ - -static gfc_expr * -gfc_get_array_element (gfc_expr *array, int element) -{ - expand_info expand_save; - gfc_expr *e; - bool rc; - - expand_save = current_expand; - current_expand.extract_n = element; - current_expand.expand_work_function = extract_element; - current_expand.extracted = NULL; - current_expand.extract_count = 0; - - iter_stack = NULL; - - rc = expand_constructor (array->value.constructor); - e = current_expand.extracted; - current_expand = expand_save; - - if (!rc) - return NULL; - - return e; -} - - -/* Top level subroutine for expanding constructors. We only expand - constructor if they are small enough. */ - -bool -gfc_expand_constructor (gfc_expr *e, bool fatal) -{ - expand_info expand_save; - gfc_expr *f; - bool rc; - - /* If we can successfully get an array element at the max array size then - the array is too big to expand, so we just return. */ - f = gfc_get_array_element (e, flag_max_array_constructor); - if (f != NULL) - { - gfc_free_expr (f); - if (fatal) - { - gfc_error ("The number of elements in the array constructor " - "at %L requires an increase of the allowed %d " - "upper limit. See %<-fmax-array-constructor%> " - "option", &e->where, flag_max_array_constructor); - return false; - } - return true; - } - - /* We now know the array is not too big so go ahead and try to expand it. */ - expand_save = current_expand; - current_expand.base = NULL; - - iter_stack = NULL; - - empty_constructor = true; - gfc_clear_ts (&empty_ts); - current_expand.expand_work_function = expand; - - if (!expand_constructor (e->value.constructor)) - { - gfc_constructor_free (current_expand.base); - rc = false; - goto done; - } - - /* If we don't have an explicit constructor type, and there - were only empty constructors, then take the type from - them. */ - - if (constructor_ts.type == BT_UNKNOWN && empty_constructor) - e->ts = empty_ts; - - gfc_constructor_free (e->value.constructor); - e->value.constructor = current_expand.base; - - rc = true; - -done: - current_expand = expand_save; - - return rc; -} - - -/* Work function for checking that an element of a constructor is a - constant, after removal of any iteration variables. We return - false if not so. */ - -static bool -is_constant_element (gfc_expr *e) -{ - int rv; - - rv = gfc_is_constant_expr (e); - gfc_free_expr (e); - - return rv ? true : false; -} - - -/* Given an array constructor, determine if the constructor is - constant or not by expanding it and making sure that all elements - are constants. This is a bit of a hack since something like (/ (i, - i=1,100000000) /) will take a while as* opposed to a more clever - function that traverses the expression tree. FIXME. */ - -int -gfc_constant_ac (gfc_expr *e) -{ - expand_info expand_save; - bool rc; - - iter_stack = NULL; - expand_save = current_expand; - current_expand.expand_work_function = is_constant_element; - - rc = expand_constructor (e->value.constructor); - - current_expand = expand_save; - if (!rc) - return 0; - - return 1; -} - - -/* Returns nonzero if an array constructor has been completely - expanded (no iterators) and zero if iterators are present. */ - -int -gfc_expanded_ac (gfc_expr *e) -{ - gfc_constructor *c; - - if (e->expr_type == EXPR_ARRAY) - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - if (c->iterator != NULL || !gfc_expanded_ac (c->expr)) - return 0; - - return 1; -} - - -/*************** Type resolution of array constructors ***************/ - - -/* The symbol expr_is_sought_symbol_ref will try to find. */ -static const gfc_symbol *sought_symbol = NULL; - - -/* Tells whether the expression E is a variable reference to the symbol - in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE - accordingly. - To be used with gfc_expr_walker: if a reference is found we don't need - to look further so we return 1 to skip any further walk. */ - -static int -expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *where) -{ - gfc_expr *expr = *e; - locus *sym_loc = (locus *)where; - - if (expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym == sought_symbol) - { - *sym_loc = expr->where; - return 1; - } - - return 0; -} - - -/* Tells whether the expression EXPR contains a reference to the symbol - SYM and in that case sets the position SYM_LOC where the reference is. */ - -static bool -find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc) -{ - int ret; - - sought_symbol = sym; - ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc); - sought_symbol = NULL; - return ret; -} - - -/* Recursive array list resolution function. All of the elements must - be of the same type. */ - -static bool -resolve_array_list (gfc_constructor_base base) -{ - bool t; - gfc_constructor *c; - gfc_iterator *iter; - - t = true; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - iter = c->iterator; - if (iter != NULL) - { - gfc_symbol *iter_var; - locus iter_var_loc; - - if (!gfc_resolve_iterator (iter, false, true)) - t = false; - - /* Check for bounds referencing the iterator variable. */ - gcc_assert (iter->var->expr_type == EXPR_VARIABLE); - iter_var = iter->var->symtree->n.sym; - if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc)) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial " - "expression references control variable " - "at %L", &iter_var_loc)) - t = false; - } - if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc)) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final " - "expression references control variable " - "at %L", &iter_var_loc)) - t = false; - } - if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc)) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step " - "expression references control variable " - "at %L", &iter_var_loc)) - t = false; - } - } - - if (!gfc_resolve_expr (c->expr)) - t = false; - - if (UNLIMITED_POLY (c->expr)) - { - gfc_error ("Array constructor value at %L shall not be unlimited " - "polymorphic [F2008: C4106]", &c->expr->where); - t = false; - } - } - - return t; -} - -/* Resolve character array constructor. If it has a specified constant character - length, pad/truncate the elements here; if the length is not specified and - all elements are of compile-time known length, emit an error as this is - invalid. */ - -bool -gfc_resolve_character_array_constructor (gfc_expr *expr) -{ - gfc_constructor *p; - HOST_WIDE_INT found_length; - - gcc_assert (expr->expr_type == EXPR_ARRAY); - gcc_assert (expr->ts.type == BT_CHARACTER); - - if (expr->ts.u.cl == NULL) - { - for (p = gfc_constructor_first (expr->value.constructor); - p; p = gfc_constructor_next (p)) - if (p->expr->ts.u.cl != NULL) - { - /* Ensure that if there is a char_len around that it is - used; otherwise the middle-end confuses them! */ - expr->ts.u.cl = p->expr->ts.u.cl; - goto got_charlen; - } - - expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - } - -got_charlen: - - /* Early exit for zero size arrays. */ - if (expr->shape) - { - mpz_t size; - HOST_WIDE_INT arraysize; - - gfc_array_size (expr, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - if (arraysize == 0) - return true; - } - - found_length = -1; - - if (expr->ts.u.cl->length == NULL) - { - /* Check that all constant string elements have the same length until - we reach the end or find a variable-length one. */ - - for (p = gfc_constructor_first (expr->value.constructor); - p; p = gfc_constructor_next (p)) - { - HOST_WIDE_INT current_length = -1; - gfc_ref *ref; - for (ref = p->expr->ref; ref; ref = ref->next) - if (ref->type == REF_SUBSTRING - && ref->u.ss.start - && ref->u.ss.start->expr_type == EXPR_CONSTANT - && ref->u.ss.end - && ref->u.ss.end->expr_type == EXPR_CONSTANT) - break; - - if (p->expr->expr_type == EXPR_CONSTANT) - current_length = p->expr->value.character.length; - else if (ref) - current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer) - - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1; - else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length - && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) - current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer); - else - return true; - - if (current_length < 0) - current_length = 0; - - if (found_length == -1) - found_length = current_length; - else if (found_length != current_length) - { - gfc_error ("Different CHARACTER lengths (%ld/%ld) in array" - " constructor at %L", (long) found_length, - (long) current_length, &p->expr->where); - return false; - } - - gcc_assert (found_length == current_length); - } - - gcc_assert (found_length != -1); - - /* Update the character length of the array constructor. */ - expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, found_length); - } - else - { - /* We've got a character length specified. It should be an integer, - otherwise an error is signalled elsewhere. */ - gcc_assert (expr->ts.u.cl->length); - - /* If we've got a constant character length, pad according to this. - gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets - max_length only if they pass. */ - gfc_extract_hwi (expr->ts.u.cl->length, &found_length); - - /* Now pad/truncate the elements accordingly to the specified character - length. This is ok inside this conditional, as in the case above - (without typespec) all elements are verified to have the same length - anyway. */ - if (found_length != -1) - for (p = gfc_constructor_first (expr->value.constructor); - p; p = gfc_constructor_next (p)) - if (p->expr->expr_type == EXPR_CONSTANT) - { - gfc_expr *cl = NULL; - HOST_WIDE_INT current_length = -1; - bool has_ts; - - if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) - { - cl = p->expr->ts.u.cl->length; - gfc_extract_hwi (cl, ¤t_length); - } - - /* If gfc_extract_int above set current_length, we implicitly - know the type is BT_INTEGER and it's EXPR_CONSTANT. */ - - has_ts = expr->ts.u.cl->length_from_typespec; - - if (! cl - || (current_length != -1 && current_length != found_length)) - gfc_set_constant_character_len (found_length, p->expr, - has_ts ? -1 : found_length); - } - } - - return true; -} - - -/* Resolve all of the expressions in an array list. */ - -bool -gfc_resolve_array_constructor (gfc_expr *expr) -{ - bool t; - - t = resolve_array_list (expr->value.constructor); - if (t) - t = gfc_check_constructor_type (expr); - - /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after - the call to this function, so we don't need to call it here; if it was - called twice, an error message there would be duplicated. */ - - return t; -} - - -/* Copy an iterator structure. */ - -gfc_iterator * -gfc_copy_iterator (gfc_iterator *src) -{ - gfc_iterator *dest; - - if (src == NULL) - return NULL; - - dest = gfc_get_iterator (); - - dest->var = gfc_copy_expr (src->var); - dest->start = gfc_copy_expr (src->start); - dest->end = gfc_copy_expr (src->end); - dest->step = gfc_copy_expr (src->step); - dest->unroll = src->unroll; - dest->ivdep = src->ivdep; - dest->vector = src->vector; - dest->novector = src->novector; - - return dest; -} - - -/********* Subroutines for determining the size of an array *********/ - -/* These are needed just to accommodate RESHAPE(). There are no - diagnostics here, we just return false if something goes wrong. */ - - -/* Get the size of single dimension of an array specification. The - array is guaranteed to be one dimensional. */ - -bool -spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) -{ - if (as == NULL) - return false; - - if (dimen < 0 || dimen > as->rank - 1) - gfc_internal_error ("spec_dimen_size(): Bad dimension"); - - if (as->type != AS_EXPLICIT - || !as->lower[dimen] - || !as->upper[dimen]) - return false; - - if (as->lower[dimen]->expr_type != EXPR_CONSTANT - || as->upper[dimen]->expr_type != EXPR_CONSTANT - || as->lower[dimen]->ts.type != BT_INTEGER - || as->upper[dimen]->ts.type != BT_INTEGER) - return false; - - mpz_init (*result); - - mpz_sub (*result, as->upper[dimen]->value.integer, - as->lower[dimen]->value.integer); - - mpz_add_ui (*result, *result, 1); - - if (mpz_cmp_si (*result, 0) < 0) - mpz_set_si (*result, 0); - - return true; -} - - -bool -spec_size (gfc_array_spec *as, mpz_t *result) -{ - mpz_t size; - int d; - - if (!as || as->type == AS_ASSUMED_RANK) - return false; - - mpz_init_set_ui (*result, 1); - - for (d = 0; d < as->rank; d++) - { - if (!spec_dimen_size (as, d, &size)) - { - mpz_clear (*result); - return false; - } - - mpz_mul (*result, *result, size); - mpz_clear (size); - } - - return true; -} - - -/* Get the number of elements in an array section. Optionally, also supply - the end value. */ - -bool -gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end) -{ - mpz_t upper, lower, stride; - mpz_t diff; - bool t; - gfc_expr *stride_expr = NULL; - - if (dimen < 0 || ar == NULL) - gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension"); - - if (dimen > ar->dimen - 1) - { - gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]); - return false; - } - - switch (ar->dimen_type[dimen]) - { - case DIMEN_ELEMENT: - mpz_init (*result); - mpz_set_ui (*result, 1); - t = true; - break; - - case DIMEN_VECTOR: - t = gfc_array_size (ar->start[dimen], result); /* Recurse! */ - break; - - case DIMEN_RANGE: - - mpz_init (stride); - - if (ar->stride[dimen] == NULL) - mpz_set_ui (stride, 1); - else - { - stride_expr = gfc_copy_expr(ar->stride[dimen]); - - if (!gfc_simplify_expr (stride_expr, 1) - || stride_expr->expr_type != EXPR_CONSTANT - || mpz_cmp_ui (stride_expr->value.integer, 0) == 0) - { - gfc_free_expr (stride_expr); - mpz_clear (stride); - return false; - } - mpz_set (stride, stride_expr->value.integer); - gfc_free_expr(stride_expr); - } - - /* Calculate the number of elements via gfc_dep_differce, but only if - start and end are both supplied in the reference or the array spec. - This is to guard against strange but valid code like - - subroutine foo(a,n) - real a(1:n) - n = 3 - print *,size(a(n-1:)) - - where the user changes the value of a variable. If we have to - determine end as well, we cannot do this using gfc_dep_difference. - Fall back to the constants-only code then. */ - - if (end == NULL) - { - bool use_dep; - - use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen], - &diff); - if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL) - use_dep = gfc_dep_difference (ar->as->upper[dimen], - ar->as->lower[dimen], &diff); - - if (use_dep) - { - mpz_init (*result); - mpz_add (*result, diff, stride); - mpz_div (*result, *result, stride); - if (mpz_cmp_ui (*result, 0) < 0) - mpz_set_ui (*result, 0); - - mpz_clear (stride); - mpz_clear (diff); - return true; - } - - } - - /* Constant-only code here, which covers more cases - like a(:4) etc. */ - mpz_init (upper); - mpz_init (lower); - t = false; - - if (ar->start[dimen] == NULL) - { - if (ar->as->lower[dimen] == NULL - || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT - || ar->as->lower[dimen]->ts.type != BT_INTEGER) - goto cleanup; - mpz_set (lower, ar->as->lower[dimen]->value.integer); - } - else - { - if (ar->start[dimen]->expr_type != EXPR_CONSTANT) - goto cleanup; - mpz_set (lower, ar->start[dimen]->value.integer); - } - - if (ar->end[dimen] == NULL) - { - if (ar->as->upper[dimen] == NULL - || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT - || ar->as->upper[dimen]->ts.type != BT_INTEGER) - goto cleanup; - mpz_set (upper, ar->as->upper[dimen]->value.integer); - } - else - { - if (ar->end[dimen]->expr_type != EXPR_CONSTANT) - goto cleanup; - mpz_set (upper, ar->end[dimen]->value.integer); - } - - mpz_init (*result); - mpz_sub (*result, upper, lower); - mpz_add (*result, *result, stride); - mpz_div (*result, *result, stride); - - /* Zero stride caught earlier. */ - if (mpz_cmp_ui (*result, 0) < 0) - mpz_set_ui (*result, 0); - t = true; - - if (end) - { - mpz_init (*end); - - mpz_sub_ui (*end, *result, 1UL); - mpz_mul (*end, *end, stride); - mpz_add (*end, *end, lower); - } - - cleanup: - mpz_clear (upper); - mpz_clear (lower); - mpz_clear (stride); - return t; - - default: - gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type"); - } - - return t; -} - - -static bool -ref_size (gfc_array_ref *ar, mpz_t *result) -{ - mpz_t size; - int d; - - mpz_init_set_ui (*result, 1); - - for (d = 0; d < ar->dimen; d++) - { - if (!gfc_ref_dimen_size (ar, d, &size, NULL)) - { - mpz_clear (*result); - return false; - } - - mpz_mul (*result, *result, size); - mpz_clear (size); - } - - return true; -} - - -/* Given an array expression and a dimension, figure out how many - elements it has along that dimension. Returns true if we were - able to return a result in the 'result' variable, false - otherwise. */ - -bool -gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) -{ - gfc_ref *ref; - int i; - - gcc_assert (array != NULL); - - if (array->ts.type == BT_CLASS) - return false; - - if (array->rank == -1) - return false; - - if (dimen < 0 || dimen > array->rank - 1) - gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); - - switch (array->expr_type) - { - case EXPR_VARIABLE: - case EXPR_FUNCTION: - for (ref = array->ref; ref; ref = ref->next) - { - if (ref->type != REF_ARRAY) - continue; - - if (ref->u.ar.type == AR_FULL) - return spec_dimen_size (ref->u.ar.as, dimen, result); - - if (ref->u.ar.type == AR_SECTION) - { - for (i = 0; dimen >= 0; i++) - if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) - dimen--; - - return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL); - } - } - - if (array->shape) - { - mpz_init_set (*result, array->shape[dimen]); - return true; - } - - if (array->symtree->n.sym->attr.generic - && array->value.function.esym != NULL) - { - if (!spec_dimen_size (array->value.function.esym->as, dimen, result)) - return false; - } - else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result)) - return false; - - break; - - case EXPR_ARRAY: - if (array->shape == NULL) { - /* Expressions with rank > 1 should have "shape" properly set */ - if ( array->rank != 1 ) - gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr"); - return gfc_array_size(array, result); - } - - /* Fall through */ - default: - if (array->shape == NULL) - return false; - - mpz_init_set (*result, array->shape[dimen]); - - break; - } - - return true; -} - - -/* Given an array expression, figure out how many elements are in the - array. Returns true if this is possible, and sets the 'result' - variable. Otherwise returns false. */ - -bool -gfc_array_size (gfc_expr *array, mpz_t *result) -{ - expand_info expand_save; - gfc_ref *ref; - int i; - bool t; - - if (array->ts.type == BT_CLASS) - return false; - - switch (array->expr_type) - { - case EXPR_ARRAY: - gfc_push_suppress_errors (); - - expand_save = current_expand; - - current_expand.count = result; - mpz_init_set_ui (*result, 0); - - current_expand.expand_work_function = count_elements; - iter_stack = NULL; - - t = expand_constructor (array->value.constructor); - - gfc_pop_suppress_errors (); - - if (!t) - mpz_clear (*result); - current_expand = expand_save; - return t; - - case EXPR_VARIABLE: - for (ref = array->ref; ref; ref = ref->next) - { - if (ref->type != REF_ARRAY) - continue; - - if (ref->u.ar.type == AR_FULL) - return spec_size (ref->u.ar.as, result); - - if (ref->u.ar.type == AR_SECTION) - return ref_size (&ref->u.ar, result); - } - - return spec_size (array->symtree->n.sym->as, result); - - - default: - if (array->rank == 0 || array->shape == NULL) - return false; - - mpz_init_set_ui (*result, 1); - - for (i = 0; i < array->rank; i++) - mpz_mul (*result, *result, array->shape[i]); - - break; - } - - return true; -} - - -/* Given an array reference, return the shape of the reference in an - array of mpz_t integers. */ - -bool -gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) -{ - int d; - int i; - - d = 0; - - switch (ar->type) - { - case AR_FULL: - for (; d < ar->as->rank; d++) - if (!spec_dimen_size (ar->as, d, &shape[d])) - goto cleanup; - - return true; - - case AR_SECTION: - for (i = 0; i < ar->dimen; i++) - { - if (ar->dimen_type[i] != DIMEN_ELEMENT) - { - if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL)) - goto cleanup; - d++; - } - } - - return true; - - default: - break; - } - -cleanup: - gfc_clear_shape (shape, d); - return false; -} - - -/* Given an array expression, find the array reference structure that - characterizes the reference. */ - -gfc_array_ref * -gfc_find_array_ref (gfc_expr *e, bool allow_null) -{ - gfc_ref *ref; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY - && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) - break; - - if (ref == NULL) - { - if (allow_null) - return NULL; - else - gfc_internal_error ("gfc_find_array_ref(): No ref found"); - } - - return &ref->u.ar; -} - - -/* Find out if an array shape is known at compile time. */ - -bool -gfc_is_compile_time_shape (gfc_array_spec *as) -{ - if (as->type != AS_EXPLICIT) - return false; - - for (int i = 0; i < as->rank; i++) - if (!gfc_is_constant_expr (as->lower[i]) - || !gfc_is_constant_expr (as->upper[i])) - return false; - - return true; -} diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc new file mode 100644 index 0000000..4723043 --- /dev/null +++ b/gcc/fortran/array.cc @@ -0,0 +1,2785 @@ +/* Array things + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "parse.h" +#include "match.h" +#include "constructor.h" + +/**************** Array reference matching subroutines *****************/ + +/* Copy an array reference structure. */ + +gfc_array_ref * +gfc_copy_array_ref (gfc_array_ref *src) +{ + gfc_array_ref *dest; + int i; + + if (src == NULL) + return NULL; + + dest = gfc_get_array_ref (); + + *dest = *src; + + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + dest->start[i] = gfc_copy_expr (src->start[i]); + dest->end[i] = gfc_copy_expr (src->end[i]); + dest->stride[i] = gfc_copy_expr (src->stride[i]); + } + + return dest; +} + + +/* Match a single dimension of an array reference. This can be a + single element or an array section. Any modifications we've made + to the ar structure are cleaned up by the caller. If the init + is set, we require the subscript to be a valid initialization + expression. */ + +static match +match_subscript (gfc_array_ref *ar, int init, bool match_star) +{ + match m = MATCH_ERROR; + bool star = false; + int i; + bool saw_boz = false; + + i = ar->dimen + ar->codimen; + + gfc_gobble_whitespace (); + ar->c_where[i] = gfc_current_locus; + ar->start[i] = ar->end[i] = ar->stride[i] = NULL; + + /* We can't be sure of the difference between DIMEN_ELEMENT and + DIMEN_VECTOR until we know the type of the element itself at + resolution time. */ + + ar->dimen_type[i] = DIMEN_UNKNOWN; + + if (gfc_match_char (':') == MATCH_YES) + goto end_element; + + /* Get start element. */ + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + + if (!star && init) + m = gfc_match_init_expr (&ar->start[i]); + else if (!star) + m = gfc_match_expr (&ar->start[i]); + + if (ar->start[i] && ar->start[i]->ts.type == BT_BOZ) + { + gfc_error ("Invalid BOZ literal constant used in subscript at %C"); + saw_boz = true; + } + + if (m == MATCH_NO) + gfc_error ("Expected array subscript at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_char (':') == MATCH_NO) + goto matched; + + if (star) + { + gfc_error ("Unexpected %<*%> in coarray subscript at %C"); + return MATCH_ERROR; + } + + /* Get an optional end element. Because we've seen the colon, we + definitely have a range along this dimension. */ +end_element: + ar->dimen_type[i] = DIMEN_RANGE; + + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + else if (init) + m = gfc_match_init_expr (&ar->end[i]); + else + m = gfc_match_expr (&ar->end[i]); + + if (ar->end[i] && ar->end[i]->ts.type == BT_BOZ) + { + gfc_error ("Invalid BOZ literal constant used in subscript at %C"); + saw_boz = true; + } + + if (m == MATCH_ERROR) + return MATCH_ERROR; + + /* See if we have an optional stride. */ + if (gfc_match_char (':') == MATCH_YES) + { + if (star) + { + gfc_error ("Strides not allowed in coarray subscript at %C"); + return MATCH_ERROR; + } + + m = init ? gfc_match_init_expr (&ar->stride[i]) + : gfc_match_expr (&ar->stride[i]); + + if (ar->stride[i] && ar->stride[i]->ts.type == BT_BOZ) + { + gfc_error ("Invalid BOZ literal constant used in subscript at %C"); + saw_boz = true; + } + + if (m == MATCH_NO) + gfc_error ("Expected array subscript stride at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + } + +matched: + if (star) + ar->dimen_type[i] = DIMEN_STAR; + + return (saw_boz ? MATCH_ERROR : MATCH_YES); +} + + +/* Match an array reference, whether it is the whole array or particular + elements or a section. If init is set, the reference has to consist + of init expressions. */ + +match +gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, + int corank) +{ + match m; + bool matched_bracket = false; + gfc_expr *tmp; + bool stat_just_seen = false; + bool team_just_seen = false; + + memset (ar, '\0', sizeof (*ar)); + + ar->where = gfc_current_locus; + ar->as = as; + ar->type = AR_UNKNOWN; + + if (gfc_match_char ('[') == MATCH_YES) + { + matched_bracket = true; + goto coarray; + } + + if (gfc_match_char ('(') != MATCH_YES) + { + ar->type = AR_FULL; + ar->dimen = 0; + return MATCH_YES; + } + + for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) + { + m = match_subscript (ar, init, false); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match_char (')') == MATCH_YES) + { + ar->dimen++; + goto coarray; + } + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Invalid form of array reference at %C"); + return MATCH_ERROR; + } + } + + if (ar->dimen >= 7 + && !gfc_notify_std (GFC_STD_F2008, + "Array reference at %C has more than 7 dimensions")) + return MATCH_ERROR; + + gfc_error ("Array reference at %C cannot have more than %d dimensions", + GFC_MAX_DIMENSIONS); + return MATCH_ERROR; + +coarray: + if (!matched_bracket && gfc_match_char ('[') != MATCH_YES) + { + if (ar->dimen > 0) + return MATCH_YES; + else + return MATCH_ERROR; + } + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return MATCH_ERROR; + } + + if (corank == 0) + { + gfc_error ("Unexpected coarray designator at %C"); + return MATCH_ERROR; + } + + ar->stat = NULL; + + for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) + { + m = match_subscript (ar, init, true); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + team_just_seen = false; + stat_just_seen = false; + if (gfc_match (" , team = %e", &tmp) == MATCH_YES && ar->team == NULL) + { + ar->team = tmp; + team_just_seen = true; + } + + if (ar->team && !team_just_seen) + { + gfc_error ("TEAM= attribute in %C misplaced"); + return MATCH_ERROR; + } + + if (gfc_match (" , stat = %e",&tmp) == MATCH_YES && ar->stat == NULL) + { + ar->stat = tmp; + stat_just_seen = true; + } + + if (ar->stat && !stat_just_seen) + { + gfc_error ("STAT= attribute in %C misplaced"); + return MATCH_ERROR; + } + + if (gfc_match_char (']') == MATCH_YES) + { + ar->codimen++; + if (ar->codimen < corank) + { + gfc_error ("Too few codimensions at %C, expected %d not %d", + corank, ar->codimen); + return MATCH_ERROR; + } + if (ar->codimen > corank) + { + gfc_error ("Too many codimensions at %C, expected %d not %d", + corank, ar->codimen); + return MATCH_ERROR; + } + return MATCH_YES; + } + + if (gfc_match_char (',') != MATCH_YES) + { + if (gfc_match_char ('*') == MATCH_YES) + gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", + ar->codimen + 1, corank); + else + gfc_error ("Invalid form of coarray reference at %C"); + return MATCH_ERROR; + } + else if (ar->dimen_type[ar->codimen + ar->dimen] == DIMEN_STAR) + { + gfc_error ("Unexpected %<*%> for codimension %d of %d at %C", + ar->codimen + 1, corank); + return MATCH_ERROR; + } + + if (ar->codimen >= corank) + { + gfc_error ("Invalid codimension %d at %C, only %d codimensions exist", + ar->codimen + 1, corank); + return MATCH_ERROR; + } + } + + gfc_error ("Array reference at %C cannot have more than %d dimensions", + GFC_MAX_DIMENSIONS); + return MATCH_ERROR; + +} + + +/************** Array specification matching subroutines ***************/ + +/* Free all of the expressions associated with array bounds + specifications. */ + +void +gfc_free_array_spec (gfc_array_spec *as) +{ + int i; + + if (as == NULL) + return; + + if (as->corank == 0) + { + for (i = 0; i < as->rank; i++) + { + gfc_free_expr (as->lower[i]); + gfc_free_expr (as->upper[i]); + } + } + else + { + int n = as->rank + as->corank - (as->cotype == AS_EXPLICIT ? 1 : 0); + for (i = 0; i < n; i++) + { + gfc_free_expr (as->lower[i]); + gfc_free_expr (as->upper[i]); + } + } + + free (as); +} + + +/* Take an array bound, resolves the expression, that make up the + shape and check associated constraints. */ + +static bool +resolve_array_bound (gfc_expr *e, int check_constant) +{ + if (e == NULL) + return true; + + if (!gfc_resolve_expr (e) + || !gfc_specification_expr (e)) + return false; + + if (check_constant && !gfc_is_constant_expr (e)) + { + if (e->expr_type == EXPR_VARIABLE) + gfc_error ("Variable %qs at %L in this context must be constant", + e->symtree->n.sym->name, &e->where); + else + gfc_error ("Expression at %L in this context must be constant", + &e->where); + return false; + } + + return true; +} + + +/* Takes an array specification, resolves the expressions that make up + the shape and make sure everything is integral. */ + +bool +gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) +{ + gfc_expr *e; + int i; + + if (as == NULL) + return true; + + if (as->resolved) + return true; + + for (i = 0; i < as->rank + as->corank; i++) + { + if (i == GFC_MAX_DIMENSIONS) + return false; + + e = as->lower[i]; + if (!resolve_array_bound (e, check_constant)) + return false; + + e = as->upper[i]; + if (!resolve_array_bound (e, check_constant)) + return false; + + if ((as->lower[i] == NULL) || (as->upper[i] == NULL)) + continue; + + /* If the size is negative in this dimension, set it to zero. */ + if (as->lower[i]->expr_type == EXPR_CONSTANT + && as->upper[i]->expr_type == EXPR_CONSTANT + && mpz_cmp (as->upper[i]->value.integer, + as->lower[i]->value.integer) < 0) + { + gfc_free_expr (as->upper[i]); + as->upper[i] = gfc_copy_expr (as->lower[i]); + mpz_sub_ui (as->upper[i]->value.integer, + as->upper[i]->value.integer, 1); + } + } + + as->resolved = true; + + return true; +} + + +/* Match a single array element specification. The return values as + well as the upper and lower bounds of the array spec are filled + in according to what we see on the input. The caller makes sure + individual specifications make sense as a whole. + + + Parsed Lower Upper Returned + ------------------------------------ + : NULL NULL AS_DEFERRED (*) + x 1 x AS_EXPLICIT + x: x NULL AS_ASSUMED_SHAPE + x:y x y AS_EXPLICIT + x:* x NULL AS_ASSUMED_SIZE + * 1 NULL AS_ASSUMED_SIZE + + (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This + is fixed during the resolution of formal interfaces. + + Anything else AS_UNKNOWN. */ + +static array_type +match_array_element_spec (gfc_array_spec *as) +{ + gfc_expr **upper, **lower; + match m; + int rank; + + rank = as->rank == -1 ? 0 : as->rank; + lower = &as->lower[rank + as->corank - 1]; + upper = &as->upper[rank + as->corank - 1]; + + if (gfc_match_char ('*') == MATCH_YES) + { + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + return AS_ASSUMED_SIZE; + } + + if (gfc_match_char (':') == MATCH_YES) + return AS_DEFERRED; + + m = gfc_match_expr (upper); + if (m == MATCH_NO) + gfc_error ("Expected expression in array specification at %C"); + if (m != MATCH_YES) + return AS_UNKNOWN; + if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) + return AS_UNKNOWN; + + gfc_try_simplify_expr (*upper, 0); + + if (((*upper)->expr_type == EXPR_CONSTANT + && (*upper)->ts.type != BT_INTEGER) || + ((*upper)->expr_type == EXPR_FUNCTION + && (*upper)->ts.type == BT_UNKNOWN + && (*upper)->symtree + && strcmp ((*upper)->symtree->name, "null") == 0)) + { + gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", + gfc_basic_typename ((*upper)->ts.type)); + return AS_UNKNOWN; + } + + if (gfc_match_char (':') == MATCH_NO) + { + *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + return AS_EXPLICIT; + } + + *lower = *upper; + *upper = NULL; + + if (gfc_match_char ('*') == MATCH_YES) + return AS_ASSUMED_SIZE; + + m = gfc_match_expr (upper); + if (m == MATCH_ERROR) + return AS_UNKNOWN; + if (m == MATCH_NO) + return AS_ASSUMED_SHAPE; + if (!gfc_expr_check_typed (*upper, gfc_current_ns, false)) + return AS_UNKNOWN; + + gfc_try_simplify_expr (*upper, 0); + + if (((*upper)->expr_type == EXPR_CONSTANT + && (*upper)->ts.type != BT_INTEGER) || + ((*upper)->expr_type == EXPR_FUNCTION + && (*upper)->ts.type == BT_UNKNOWN + && (*upper)->symtree + && strcmp ((*upper)->symtree->name, "null") == 0)) + { + gfc_error ("Expecting a scalar INTEGER expression at %C, found %s", + gfc_basic_typename ((*upper)->ts.type)); + return AS_UNKNOWN; + } + + return AS_EXPLICIT; +} + + +/* Matches an array specification, incidentally figuring out what sort + it is. Match either a normal array specification, or a coarray spec + or both. Optionally allow [:] for coarrays. */ + +match +gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) +{ + array_type current_type; + gfc_array_spec *as; + int i; + + as = gfc_get_array_spec (); + + if (!match_dim) + goto coarray; + + if (gfc_match_char ('(') != MATCH_YES) + { + if (!match_codim) + goto done; + goto coarray; + } + + if (gfc_match (" .. )") == MATCH_YES) + { + as->type = AS_ASSUMED_RANK; + as->rank = -1; + + if (!gfc_notify_std (GFC_STD_F2018, "Assumed-rank array at %C")) + goto cleanup; + + if (!match_codim) + goto done; + goto coarray; + } + + for (;;) + { + as->rank++; + current_type = match_array_element_spec (as); + + /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size + and implied-shape specifications. If the rank is at least 2, we can + distinguish between them. But for rank 1, we currently return + ASSUMED_SIZE; this gets adjusted later when we know for sure + whether the symbol parsed is a PARAMETER or not. */ + + if (as->rank == 1) + { + if (current_type == AS_UNKNOWN) + goto cleanup; + as->type = current_type; + } + else + switch (as->type) + { /* See how current spec meshes with the existing. */ + case AS_UNKNOWN: + goto cleanup; + + case AS_IMPLIED_SHAPE: + if (current_type != AS_ASSUMED_SIZE) + { + gfc_error ("Bad array specification for implied-shape" + " array at %C"); + goto cleanup; + } + break; + + case AS_EXPLICIT: + if (current_type == AS_ASSUMED_SIZE) + { + as->type = AS_ASSUMED_SIZE; + break; + } + + if (current_type == AS_EXPLICIT) + break; + + gfc_error ("Bad array specification for an explicitly shaped " + "array at %C"); + + goto cleanup; + + case AS_ASSUMED_SHAPE: + if ((current_type == AS_ASSUMED_SHAPE) + || (current_type == AS_DEFERRED)) + break; + + gfc_error ("Bad array specification for assumed shape " + "array at %C"); + goto cleanup; + + case AS_DEFERRED: + if (current_type == AS_DEFERRED) + break; + + if (current_type == AS_ASSUMED_SHAPE) + { + as->type = AS_ASSUMED_SHAPE; + break; + } + + gfc_error ("Bad specification for deferred shape array at %C"); + goto cleanup; + + case AS_ASSUMED_SIZE: + if (as->rank == 2 && current_type == AS_ASSUMED_SIZE) + { + as->type = AS_IMPLIED_SHAPE; + break; + } + + gfc_error ("Bad specification for assumed size array at %C"); + goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); + } + + if (gfc_match_char (')') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected another dimension in array declaration at %C"); + goto cleanup; + } + + if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d dimensions", + GFC_MAX_DIMENSIONS); + goto cleanup; + } + + if (as->corank + as->rank >= 7 + && !gfc_notify_std (GFC_STD_F2008, "Array specification at %C " + "with more than 7 dimensions")) + goto cleanup; + } + + if (!match_codim) + goto done; + +coarray: + if (gfc_match_char ('[') != MATCH_YES) + goto done; + + if (!gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C")) + goto cleanup; + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + goto cleanup; + } + + if (as->rank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d " + "dimensions", GFC_MAX_DIMENSIONS); + goto cleanup; + } + + for (;;) + { + as->corank++; + current_type = match_array_element_spec (as); + + if (current_type == AS_UNKNOWN) + goto cleanup; + + if (as->corank == 1) + as->cotype = current_type; + else + switch (as->cotype) + { /* See how current spec meshes with the existing. */ + case AS_IMPLIED_SHAPE: + case AS_UNKNOWN: + goto cleanup; + + case AS_EXPLICIT: + if (current_type == AS_ASSUMED_SIZE) + { + as->cotype = AS_ASSUMED_SIZE; + break; + } + + if (current_type == AS_EXPLICIT) + break; + + gfc_error ("Bad array specification for an explicitly " + "shaped array at %C"); + + goto cleanup; + + case AS_ASSUMED_SHAPE: + if ((current_type == AS_ASSUMED_SHAPE) + || (current_type == AS_DEFERRED)) + break; + + gfc_error ("Bad array specification for assumed shape " + "array at %C"); + goto cleanup; + + case AS_DEFERRED: + if (current_type == AS_DEFERRED) + break; + + if (current_type == AS_ASSUMED_SHAPE) + { + as->cotype = AS_ASSUMED_SHAPE; + break; + } + + gfc_error ("Bad specification for deferred shape array at %C"); + goto cleanup; + + case AS_ASSUMED_SIZE: + gfc_error ("Bad specification for assumed size array at %C"); + goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); + } + + if (gfc_match_char (']') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected another dimension in array declaration at %C"); + goto cleanup; + } + + if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d " + "dimensions", GFC_MAX_DIMENSIONS); + goto cleanup; + } + } + + if (current_type == AS_EXPLICIT) + { + gfc_error ("Upper bound of last coarray dimension must be %<*%> at %C"); + goto cleanup; + } + + if (as->cotype == AS_ASSUMED_SIZE) + as->cotype = AS_EXPLICIT; + + if (as->rank == 0) + as->type = as->cotype; + +done: + if (as->rank == 0 && as->corank == 0) + { + *asp = NULL; + gfc_free_array_spec (as); + return MATCH_NO; + } + + /* If a lower bounds of an assumed shape array is blank, put in one. */ + if (as->type == AS_ASSUMED_SHAPE) + { + for (i = 0; i < as->rank + as->corank; i++) + { + if (as->lower[i] == NULL) + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + } + } + + *asp = as; + + return MATCH_YES; + +cleanup: + /* Something went wrong. */ + gfc_free_array_spec (as); + return MATCH_ERROR; +} + +/* Given a symbol and an array specification, modify the symbol to + have that array specification. The error locus is needed in case + something goes wrong. On failure, the caller must free the spec. */ + +bool +gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) +{ + int i; + symbol_attribute *attr; + + if (as == NULL) + return true; + + /* If the symbol corresponds to a submodule module procedure the array spec is + already set, so do not attempt to set it again here. */ + attr = &sym->attr; + if (gfc_submodule_procedure(attr)) + return true; + + if (as->rank + && !gfc_add_dimension (&sym->attr, sym->name, error_loc)) + return false; + + if (as->corank + && !gfc_add_codimension (&sym->attr, sym->name, error_loc)) + return false; + + if (sym->as == NULL) + { + sym->as = as; + return true; + } + + if ((sym->as->type == AS_ASSUMED_RANK && as->corank) + || (as->type == AS_ASSUMED_RANK && sym->as->corank)) + { + gfc_error ("The assumed-rank array %qs at %L shall not have a " + "codimension", sym->name, error_loc); + return false; + } + + /* Check F2018:C822. */ + if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) + goto too_many; + + if (as->corank) + { + sym->as->cotype = as->cotype; + sym->as->corank = as->corank; + /* Check F2018:C822. */ + if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) + goto too_many; + + for (i = 0; i < as->corank; i++) + { + sym->as->lower[sym->as->rank + i] = as->lower[i]; + sym->as->upper[sym->as->rank + i] = as->upper[i]; + } + } + else + { + /* The "sym" has no rank (checked via gfc_add_dimension). Thus + the dimension is added - but first the codimensions (if existing + need to be shifted to make space for the dimension. */ + gcc_assert (as->corank == 0 && sym->as->rank == 0); + + sym->as->rank = as->rank; + sym->as->type = as->type; + sym->as->cray_pointee = as->cray_pointee; + sym->as->cp_was_assumed = as->cp_was_assumed; + + /* Check F2018:C822. */ + if (sym->as->rank + sym->as->corank > GFC_MAX_DIMENSIONS) + goto too_many; + + for (i = sym->as->corank - 1; i >= 0; i--) + { + sym->as->lower[as->rank + i] = sym->as->lower[i]; + sym->as->upper[as->rank + i] = sym->as->upper[i]; + } + for (i = 0; i < as->rank; i++) + { + sym->as->lower[i] = as->lower[i]; + sym->as->upper[i] = as->upper[i]; + } + } + + free (as); + return true; + +too_many: + + gfc_error ("rank + corank of %qs exceeds %d at %C", sym->name, + GFC_MAX_DIMENSIONS); + return false; +} + + +/* Copy an array specification. */ + +gfc_array_spec * +gfc_copy_array_spec (gfc_array_spec *src) +{ + gfc_array_spec *dest; + int i; + + if (src == NULL) + return NULL; + + dest = gfc_get_array_spec (); + + *dest = *src; + + for (i = 0; i < dest->rank + dest->corank; i++) + { + dest->lower[i] = gfc_copy_expr (dest->lower[i]); + dest->upper[i] = gfc_copy_expr (dest->upper[i]); + } + + return dest; +} + + +/* Returns nonzero if the two expressions are equal. Only handles integer + constants. */ + +static int +compare_bounds (gfc_expr *bound1, gfc_expr *bound2) +{ + if (bound1 == NULL || bound2 == NULL + || bound1->expr_type != EXPR_CONSTANT + || bound2->expr_type != EXPR_CONSTANT + || bound1->ts.type != BT_INTEGER + || bound2->ts.type != BT_INTEGER) + gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered"); + + if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0) + return 1; + else + return 0; +} + + +/* Compares two array specifications. They must be constant or deferred + shape. */ + +int +gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) +{ + int i; + + if (as1 == NULL && as2 == NULL) + return 1; + + if (as1 == NULL || as2 == NULL) + return 0; + + if (as1->rank != as2->rank) + return 0; + + if (as1->corank != as2->corank) + return 0; + + if (as1->rank == 0) + return 1; + + if (as1->type != as2->type) + return 0; + + if (as1->type == AS_EXPLICIT) + for (i = 0; i < as1->rank + as1->corank; i++) + { + if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) + return 0; + + if (compare_bounds (as1->upper[i], as2->upper[i]) == 0) + return 0; + } + + return 1; +} + + +/****************** Array constructor functions ******************/ + + +/* Given an expression node that might be an array constructor and a + symbol, make sure that no iterators in this or child constructors + use the symbol as an implied-DO iterator. Returns nonzero if a + duplicate was found. */ + +static int +check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) +{ + gfc_constructor *c; + gfc_expr *e; + + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + e = c->expr; + + if (e->expr_type == EXPR_ARRAY + && check_duplicate_iterator (e->value.constructor, master)) + return 1; + + if (c->iterator == NULL) + continue; + + if (c->iterator->var->symtree->n.sym == master) + { + gfc_error ("DO-iterator %qs at %L is inside iterator of the " + "same name", master->name, &c->where); + + return 1; + } + } + + return 0; +} + + +/* Forward declaration because these functions are mutually recursive. */ +static match match_array_cons_element (gfc_constructor_base *); + +/* Match a list of array elements. */ + +static match +match_array_list (gfc_constructor_base *result) +{ + gfc_constructor_base head; + gfc_constructor *p; + gfc_iterator iter; + locus old_loc; + gfc_expr *e; + match m; + int n; + + old_loc = gfc_current_locus; + + if (gfc_match_char ('(') == MATCH_NO) + return MATCH_NO; + + memset (&iter, '\0', sizeof (gfc_iterator)); + head = NULL; + + m = match_array_cons_element (&head); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char (',') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + for (n = 1;; n++) + { + m = gfc_match_iterator (&iter, 0); + if (m == MATCH_YES) + break; + if (m == MATCH_ERROR) + goto cleanup; + + m = match_array_cons_element (&head); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + if (n > 2) + goto syntax; + m = MATCH_NO; + goto cleanup; /* Could be a complex constant */ + } + + if (gfc_match_char (',') != MATCH_YES) + { + if (n > 2) + goto syntax; + m = MATCH_NO; + goto cleanup; + } + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + if (check_duplicate_iterator (head, iter.var->symtree->n.sym)) + { + m = MATCH_ERROR; + goto cleanup; + } + + e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc); + e->value.constructor = head; + + p = gfc_constructor_append_expr (result, e, &gfc_current_locus); + p->iterator = gfc_get_iterator (); + *p->iterator = iter; + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in array constructor at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_constructor_free (head); + gfc_free_iterator (&iter, 0); + gfc_current_locus = old_loc; + return m; +} + + +/* Match a single element of an array constructor, which can be a + single expression or a list of elements. */ + +static match +match_array_cons_element (gfc_constructor_base *result) +{ + gfc_expr *expr; + match m; + + m = match_array_list (result); + if (m != MATCH_NO) + return m; + + m = gfc_match_expr (&expr); + if (m != MATCH_YES) + return m; + + if (expr->ts.type == BT_BOZ) + { + gfc_error ("BOZ literal constant at %L cannot appear in an " + "array constructor", &expr->where); + goto done; + } + + if (expr->expr_type == EXPR_FUNCTION + && expr->ts.type == BT_UNKNOWN + && strcmp(expr->symtree->name, "null") == 0) + { + gfc_error ("NULL() at %C cannot appear in an array constructor"); + goto done; + } + + gfc_constructor_append_expr (result, expr, &gfc_current_locus); + return MATCH_YES; + +done: + gfc_free_expr (expr); + return MATCH_ERROR; +} + + +/* Convert components of an array constructor to the type in ts. */ + +static match +walk_array_constructor (gfc_typespec *ts, gfc_constructor_base head) +{ + gfc_constructor *c; + gfc_expr *e; + match m; + + for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) + { + e = c->expr; + if (e->expr_type == EXPR_ARRAY && e->ts.type == BT_UNKNOWN + && !e->ref && e->value.constructor) + { + m = walk_array_constructor (ts, e->value.constructor); + if (m == MATCH_ERROR) + return m; + } + else if (!gfc_convert_type_warn (e, ts, 1, 1, true) + && e->ts.type != BT_UNKNOWN) + return MATCH_ERROR; + } + return MATCH_YES; +} + +/* Match an array constructor. */ + +match +gfc_match_array_constructor (gfc_expr **result) +{ + gfc_constructor *c; + gfc_constructor_base head; + gfc_expr *expr; + gfc_typespec ts; + locus where; + match m; + const char *end_delim; + bool seen_ts; + + head = NULL; + seen_ts = false; + + if (gfc_match (" (/") == MATCH_NO) + { + if (gfc_match (" [") == MATCH_NO) + return MATCH_NO; + else + { + if (!gfc_notify_std (GFC_STD_F2003, "[...] " + "style array constructors at %C")) + return MATCH_ERROR; + end_delim = " ]"; + } + } + else + end_delim = " /)"; + + where = gfc_current_locus; + + /* Try to match an optional "type-spec ::" */ + gfc_clear_ts (&ts); + m = gfc_match_type_spec (&ts); + if (m == MATCH_YES) + { + seen_ts = (gfc_match (" ::") == MATCH_YES); + + if (seen_ts) + { + if (!gfc_notify_std (GFC_STD_F2003, "Array constructor " + "including type specification at %C")) + goto cleanup; + + if (ts.deferred) + { + gfc_error ("Type-spec at %L cannot contain a deferred " + "type parameter", &where); + goto cleanup; + } + + if (ts.type == BT_CHARACTER + && ts.u.cl && !ts.u.cl->length && !ts.u.cl->length_from_typespec) + { + gfc_error ("Type-spec at %L cannot contain an asterisk for a " + "type parameter", &where); + goto cleanup; + } + } + } + else if (m == MATCH_ERROR) + goto cleanup; + + if (!seen_ts) + gfc_current_locus = where; + + if (gfc_match (end_delim) == MATCH_YES) + { + if (seen_ts) + goto done; + else + { + gfc_error ("Empty array constructor at %C is not allowed"); + goto cleanup; + } + } + + for (;;) + { + m = match_array_cons_element (&head); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match_char (',') == MATCH_NO) + break; + } + + if (gfc_match (end_delim) == MATCH_NO) + goto syntax; + +done: + /* Size must be calculated at resolution time. */ + if (seen_ts) + { + expr = gfc_get_array_expr (ts.type, ts.kind, &where); + expr->ts = ts; + + /* If the typespec is CHARACTER, check that array elements can + be converted. See PR fortran/67803. */ + if (ts.type == BT_CHARACTER) + { + c = gfc_constructor_first (head); + for (; c; c = gfc_constructor_next (c)) + { + if (gfc_numeric_ts (&c->expr->ts) + || c->expr->ts.type == BT_LOGICAL) + { + gfc_error ("Incompatible typespec for array element at %L", + &c->expr->where); + return MATCH_ERROR; + } + + /* Special case null(). */ + if (c->expr->expr_type == EXPR_FUNCTION + && c->expr->ts.type == BT_UNKNOWN + && strcmp (c->expr->symtree->name, "null") == 0) + { + gfc_error ("Incompatible typespec for array element at %L", + &c->expr->where); + return MATCH_ERROR; + } + } + } + + /* Walk the constructor, and if possible, do type conversion for + numeric types. */ + if (gfc_numeric_ts (&ts)) + { + m = walk_array_constructor (&ts, head); + if (m == MATCH_ERROR) + return m; + } + } + else + expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where); + + expr->value.constructor = head; + if (expr->ts.u.cl) + expr->ts.u.cl->length_from_typespec = seen_ts; + + *result = expr; + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in array constructor at %C"); + +cleanup: + gfc_constructor_free (head); + return MATCH_ERROR; +} + + + +/************** Check array constructors for correctness **************/ + +/* Given an expression, compare it's type with the type of the current + constructor. Returns nonzero if an error was issued. The + cons_state variable keeps track of whether the type of the + constructor being read or resolved is known to be good, bad or just + starting out. */ + +static gfc_typespec constructor_ts; +static enum +{ CONS_START, CONS_GOOD, CONS_BAD } +cons_state; + +static int +check_element_type (gfc_expr *expr, bool convert) +{ + if (cons_state == CONS_BAD) + return 0; /* Suppress further errors */ + + if (cons_state == CONS_START) + { + if (expr->ts.type == BT_UNKNOWN) + cons_state = CONS_BAD; + else + { + cons_state = CONS_GOOD; + constructor_ts = expr->ts; + } + + return 0; + } + + if (gfc_compare_types (&constructor_ts, &expr->ts)) + return 0; + + if (convert) + return gfc_convert_type_warn (expr, &constructor_ts, 1, 1, true) ? 0 : 1; + + gfc_error ("Element in %s array constructor at %L is %s", + gfc_typename (&constructor_ts), &expr->where, + gfc_typename (expr)); + + cons_state = CONS_BAD; + return 1; +} + + +/* Recursive work function for gfc_check_constructor_type(). */ + +static bool +check_constructor_type (gfc_constructor_base base, bool convert) +{ + gfc_constructor *c; + gfc_expr *e; + + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + e = c->expr; + + if (e->expr_type == EXPR_ARRAY) + { + if (!check_constructor_type (e->value.constructor, convert)) + return false; + + continue; + } + + if (check_element_type (e, convert)) + return false; + } + + return true; +} + + +/* Check that all elements of an array constructor are the same type. + On false, an error has been generated. */ + +bool +gfc_check_constructor_type (gfc_expr *e) +{ + bool t; + + if (e->ts.type != BT_UNKNOWN) + { + cons_state = CONS_GOOD; + constructor_ts = e->ts; + } + else + { + cons_state = CONS_START; + gfc_clear_ts (&constructor_ts); + } + + /* If e->ts.type != BT_UNKNOWN, the array constructor included a + typespec, and we will now convert the values on the fly. */ + t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN); + if (t && e->ts.type == BT_UNKNOWN) + e->ts = constructor_ts; + + return t; +} + + + +typedef struct cons_stack +{ + gfc_iterator *iterator; + struct cons_stack *previous; +} +cons_stack; + +static cons_stack *base; + +static bool check_constructor (gfc_constructor_base, bool (*) (gfc_expr *)); + +/* Check an EXPR_VARIABLE expression in a constructor to make sure + that that variable is an iteration variable. */ + +bool +gfc_check_iter_variable (gfc_expr *expr) +{ + gfc_symbol *sym; + cons_stack *c; + + sym = expr->symtree->n.sym; + + for (c = base; c && c->iterator; c = c->previous) + if (sym == c->iterator->var->symtree->n.sym) + return true; + + return false; +} + + +/* Recursive work function for gfc_check_constructor(). This amounts + to calling the check function for each expression in the + constructor, giving variables with the names of iterators a pass. */ + +static bool +check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr *)) +{ + cons_stack element; + gfc_expr *e; + bool t; + gfc_constructor *c; + + for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c)) + { + e = c->expr; + + if (!e) + continue; + + if (e->expr_type != EXPR_ARRAY) + { + if (!(*check_function)(e)) + return false; + continue; + } + + element.previous = base; + element.iterator = c->iterator; + + base = &element; + t = check_constructor (e->value.constructor, check_function); + base = element.previous; + + if (!t) + return false; + } + + /* Nothing went wrong, so all OK. */ + return true; +} + + +/* Checks a constructor to see if it is a particular kind of + expression -- specification, restricted, or initialization as + determined by the check_function. */ + +bool +gfc_check_constructor (gfc_expr *expr, bool (*check_function) (gfc_expr *)) +{ + cons_stack *base_save; + bool t; + + base_save = base; + base = NULL; + + t = check_constructor (expr->value.constructor, check_function); + base = base_save; + + return t; +} + + + +/**************** Simplification of array constructors ****************/ + +iterator_stack *iter_stack; + +typedef struct +{ + gfc_constructor_base base; + int extract_count, extract_n; + gfc_expr *extracted; + mpz_t *count; + + mpz_t *offset; + gfc_component *component; + mpz_t *repeat; + + bool (*expand_work_function) (gfc_expr *); +} +expand_info; + +static expand_info current_expand; + +static bool expand_constructor (gfc_constructor_base); + + +/* Work function that counts the number of elements present in a + constructor. */ + +static bool +count_elements (gfc_expr *e) +{ + mpz_t result; + + if (e->rank == 0) + mpz_add_ui (*current_expand.count, *current_expand.count, 1); + else + { + if (!gfc_array_size (e, &result)) + { + gfc_free_expr (e); + return false; + } + + mpz_add (*current_expand.count, *current_expand.count, result); + mpz_clear (result); + } + + gfc_free_expr (e); + return true; +} + + +/* Work function that extracts a particular element from an array + constructor, freeing the rest. */ + +static bool +extract_element (gfc_expr *e) +{ + if (e->rank != 0) + { /* Something unextractable */ + gfc_free_expr (e); + return false; + } + + if (current_expand.extract_count == current_expand.extract_n) + current_expand.extracted = e; + else + gfc_free_expr (e); + + current_expand.extract_count++; + + return true; +} + + +/* Work function that constructs a new constructor out of the old one, + stringing new elements together. */ + +static bool +expand (gfc_expr *e) +{ + gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base, + e, &e->where); + + c->n.component = current_expand.component; + return true; +} + + +/* Given an initialization expression that is a variable reference, + substitute the current value of the iteration variable. */ + +void +gfc_simplify_iterator_var (gfc_expr *e) +{ + iterator_stack *p; + + for (p = iter_stack; p; p = p->prev) + if (e->symtree == p->variable) + break; + + if (p == NULL) + return; /* Variable not found */ + + gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0)); + + mpz_set (e->value.integer, p->value); + + return; +} + + +/* Expand an expression with that is inside of a constructor, + recursing into other constructors if present. */ + +static bool +expand_expr (gfc_expr *e) +{ + if (e->expr_type == EXPR_ARRAY) + return expand_constructor (e->value.constructor); + + e = gfc_copy_expr (e); + + if (!gfc_simplify_expr (e, 1)) + { + gfc_free_expr (e); + return false; + } + + return current_expand.expand_work_function (e); +} + + +static bool +expand_iterator (gfc_constructor *c) +{ + gfc_expr *start, *end, *step; + iterator_stack frame; + mpz_t trip; + bool t; + + end = step = NULL; + + t = false; + + mpz_init (trip); + mpz_init (frame.value); + frame.prev = NULL; + + start = gfc_copy_expr (c->iterator->start); + if (!gfc_simplify_expr (start, 1)) + goto cleanup; + + if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER) + goto cleanup; + + end = gfc_copy_expr (c->iterator->end); + if (!gfc_simplify_expr (end, 1)) + goto cleanup; + + if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER) + goto cleanup; + + step = gfc_copy_expr (c->iterator->step); + if (!gfc_simplify_expr (step, 1)) + goto cleanup; + + if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER) + goto cleanup; + + if (mpz_sgn (step->value.integer) == 0) + { + gfc_error ("Iterator step at %L cannot be zero", &step->where); + goto cleanup; + } + + /* Calculate the trip count of the loop. */ + mpz_sub (trip, end->value.integer, start->value.integer); + mpz_add (trip, trip, step->value.integer); + mpz_tdiv_q (trip, trip, step->value.integer); + + mpz_set (frame.value, start->value.integer); + + frame.prev = iter_stack; + frame.variable = c->iterator->var->symtree; + iter_stack = &frame; + + while (mpz_sgn (trip) > 0) + { + if (!expand_expr (c->expr)) + goto cleanup; + + mpz_add (frame.value, frame.value, step->value.integer); + mpz_sub_ui (trip, trip, 1); + } + + t = true; + +cleanup: + gfc_free_expr (start); + gfc_free_expr (end); + gfc_free_expr (step); + + mpz_clear (trip); + mpz_clear (frame.value); + + iter_stack = frame.prev; + + return t; +} + +/* Variables for noticing if all constructors are empty, and + if any of them had a type. */ + +static bool empty_constructor; +static gfc_typespec empty_ts; + +/* Expand a constructor into constant constructors without any + iterators, calling the work function for each of the expanded + expressions. The work function needs to either save or free the + passed expression. */ + +static bool +expand_constructor (gfc_constructor_base base) +{ + gfc_constructor *c; + gfc_expr *e; + + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c)) + { + if (c->iterator != NULL) + { + if (!expand_iterator (c)) + return false; + continue; + } + + e = c->expr; + + if (e == NULL) + return false; + + if (empty_constructor) + empty_ts = e->ts; + + /* Simplify constant array expression/section within constructor. */ + if (e->expr_type == EXPR_VARIABLE && e->rank > 0 && e->ref + && e->symtree && e->symtree->n.sym + && e->symtree->n.sym->attr.flavor == FL_PARAMETER) + gfc_simplify_expr (e, 0); + + if (e->expr_type == EXPR_ARRAY) + { + if (!expand_constructor (e->value.constructor)) + return false; + + continue; + } + + empty_constructor = false; + e = gfc_copy_expr (e); + if (!gfc_simplify_expr (e, 1)) + { + gfc_free_expr (e); + return false; + } + e->from_constructor = 1; + current_expand.offset = &c->offset; + current_expand.repeat = &c->repeat; + current_expand.component = c->n.component; + if (!current_expand.expand_work_function(e)) + return false; + } + return true; +} + + +/* Given an array expression and an element number (starting at zero), + return a pointer to the array element. NULL is returned if the + size of the array has been exceeded. The expression node returned + remains a part of the array and should not be freed. Access is not + efficient at all, but this is another place where things do not + have to be particularly fast. */ + +static gfc_expr * +gfc_get_array_element (gfc_expr *array, int element) +{ + expand_info expand_save; + gfc_expr *e; + bool rc; + + expand_save = current_expand; + current_expand.extract_n = element; + current_expand.expand_work_function = extract_element; + current_expand.extracted = NULL; + current_expand.extract_count = 0; + + iter_stack = NULL; + + rc = expand_constructor (array->value.constructor); + e = current_expand.extracted; + current_expand = expand_save; + + if (!rc) + return NULL; + + return e; +} + + +/* Top level subroutine for expanding constructors. We only expand + constructor if they are small enough. */ + +bool +gfc_expand_constructor (gfc_expr *e, bool fatal) +{ + expand_info expand_save; + gfc_expr *f; + bool rc; + + /* If we can successfully get an array element at the max array size then + the array is too big to expand, so we just return. */ + f = gfc_get_array_element (e, flag_max_array_constructor); + if (f != NULL) + { + gfc_free_expr (f); + if (fatal) + { + gfc_error ("The number of elements in the array constructor " + "at %L requires an increase of the allowed %d " + "upper limit. See %<-fmax-array-constructor%> " + "option", &e->where, flag_max_array_constructor); + return false; + } + return true; + } + + /* We now know the array is not too big so go ahead and try to expand it. */ + expand_save = current_expand; + current_expand.base = NULL; + + iter_stack = NULL; + + empty_constructor = true; + gfc_clear_ts (&empty_ts); + current_expand.expand_work_function = expand; + + if (!expand_constructor (e->value.constructor)) + { + gfc_constructor_free (current_expand.base); + rc = false; + goto done; + } + + /* If we don't have an explicit constructor type, and there + were only empty constructors, then take the type from + them. */ + + if (constructor_ts.type == BT_UNKNOWN && empty_constructor) + e->ts = empty_ts; + + gfc_constructor_free (e->value.constructor); + e->value.constructor = current_expand.base; + + rc = true; + +done: + current_expand = expand_save; + + return rc; +} + + +/* Work function for checking that an element of a constructor is a + constant, after removal of any iteration variables. We return + false if not so. */ + +static bool +is_constant_element (gfc_expr *e) +{ + int rv; + + rv = gfc_is_constant_expr (e); + gfc_free_expr (e); + + return rv ? true : false; +} + + +/* Given an array constructor, determine if the constructor is + constant or not by expanding it and making sure that all elements + are constants. This is a bit of a hack since something like (/ (i, + i=1,100000000) /) will take a while as* opposed to a more clever + function that traverses the expression tree. FIXME. */ + +int +gfc_constant_ac (gfc_expr *e) +{ + expand_info expand_save; + bool rc; + + iter_stack = NULL; + expand_save = current_expand; + current_expand.expand_work_function = is_constant_element; + + rc = expand_constructor (e->value.constructor); + + current_expand = expand_save; + if (!rc) + return 0; + + return 1; +} + + +/* Returns nonzero if an array constructor has been completely + expanded (no iterators) and zero if iterators are present. */ + +int +gfc_expanded_ac (gfc_expr *e) +{ + gfc_constructor *c; + + if (e->expr_type == EXPR_ARRAY) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->iterator != NULL || !gfc_expanded_ac (c->expr)) + return 0; + + return 1; +} + + +/*************** Type resolution of array constructors ***************/ + + +/* The symbol expr_is_sought_symbol_ref will try to find. */ +static const gfc_symbol *sought_symbol = NULL; + + +/* Tells whether the expression E is a variable reference to the symbol + in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE + accordingly. + To be used with gfc_expr_walker: if a reference is found we don't need + to look further so we return 1 to skip any further walk. */ + +static int +expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *where) +{ + gfc_expr *expr = *e; + locus *sym_loc = (locus *)where; + + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym == sought_symbol) + { + *sym_loc = expr->where; + return 1; + } + + return 0; +} + + +/* Tells whether the expression EXPR contains a reference to the symbol + SYM and in that case sets the position SYM_LOC where the reference is. */ + +static bool +find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc) +{ + int ret; + + sought_symbol = sym; + ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc); + sought_symbol = NULL; + return ret; +} + + +/* Recursive array list resolution function. All of the elements must + be of the same type. */ + +static bool +resolve_array_list (gfc_constructor_base base) +{ + bool t; + gfc_constructor *c; + gfc_iterator *iter; + + t = true; + + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + iter = c->iterator; + if (iter != NULL) + { + gfc_symbol *iter_var; + locus iter_var_loc; + + if (!gfc_resolve_iterator (iter, false, true)) + t = false; + + /* Check for bounds referencing the iterator variable. */ + gcc_assert (iter->var->expr_type == EXPR_VARIABLE); + iter_var = iter->var->symtree->n.sym; + if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc)) + { + if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial " + "expression references control variable " + "at %L", &iter_var_loc)) + t = false; + } + if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc)) + { + if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final " + "expression references control variable " + "at %L", &iter_var_loc)) + t = false; + } + if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc)) + { + if (!gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step " + "expression references control variable " + "at %L", &iter_var_loc)) + t = false; + } + } + + if (!gfc_resolve_expr (c->expr)) + t = false; + + if (UNLIMITED_POLY (c->expr)) + { + gfc_error ("Array constructor value at %L shall not be unlimited " + "polymorphic [F2008: C4106]", &c->expr->where); + t = false; + } + } + + return t; +} + +/* Resolve character array constructor. If it has a specified constant character + length, pad/truncate the elements here; if the length is not specified and + all elements are of compile-time known length, emit an error as this is + invalid. */ + +bool +gfc_resolve_character_array_constructor (gfc_expr *expr) +{ + gfc_constructor *p; + HOST_WIDE_INT found_length; + + gcc_assert (expr->expr_type == EXPR_ARRAY); + gcc_assert (expr->ts.type == BT_CHARACTER); + + if (expr->ts.u.cl == NULL) + { + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) + if (p->expr->ts.u.cl != NULL) + { + /* Ensure that if there is a char_len around that it is + used; otherwise the middle-end confuses them! */ + expr->ts.u.cl = p->expr->ts.u.cl; + goto got_charlen; + } + + expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + } + +got_charlen: + + /* Early exit for zero size arrays. */ + if (expr->shape) + { + mpz_t size; + HOST_WIDE_INT arraysize; + + gfc_array_size (expr, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + if (arraysize == 0) + return true; + } + + found_length = -1; + + if (expr->ts.u.cl->length == NULL) + { + /* Check that all constant string elements have the same length until + we reach the end or find a variable-length one. */ + + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) + { + HOST_WIDE_INT current_length = -1; + gfc_ref *ref; + for (ref = p->expr->ref; ref; ref = ref->next) + if (ref->type == REF_SUBSTRING + && ref->u.ss.start + && ref->u.ss.start->expr_type == EXPR_CONSTANT + && ref->u.ss.end + && ref->u.ss.end->expr_type == EXPR_CONSTANT) + break; + + if (p->expr->expr_type == EXPR_CONSTANT) + current_length = p->expr->value.character.length; + else if (ref) + current_length = gfc_mpz_get_hwi (ref->u.ss.end->value.integer) + - gfc_mpz_get_hwi (ref->u.ss.start->value.integer) + 1; + else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length + && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) + current_length = gfc_mpz_get_hwi (p->expr->ts.u.cl->length->value.integer); + else + return true; + + if (current_length < 0) + current_length = 0; + + if (found_length == -1) + found_length = current_length; + else if (found_length != current_length) + { + gfc_error ("Different CHARACTER lengths (%ld/%ld) in array" + " constructor at %L", (long) found_length, + (long) current_length, &p->expr->where); + return false; + } + + gcc_assert (found_length == current_length); + } + + gcc_assert (found_length != -1); + + /* Update the character length of the array constructor. */ + expr->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, found_length); + } + else + { + /* We've got a character length specified. It should be an integer, + otherwise an error is signalled elsewhere. */ + gcc_assert (expr->ts.u.cl->length); + + /* If we've got a constant character length, pad according to this. + gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets + max_length only if they pass. */ + gfc_extract_hwi (expr->ts.u.cl->length, &found_length); + + /* Now pad/truncate the elements accordingly to the specified character + length. This is ok inside this conditional, as in the case above + (without typespec) all elements are verified to have the same length + anyway. */ + if (found_length != -1) + for (p = gfc_constructor_first (expr->value.constructor); + p; p = gfc_constructor_next (p)) + if (p->expr->expr_type == EXPR_CONSTANT) + { + gfc_expr *cl = NULL; + HOST_WIDE_INT current_length = -1; + bool has_ts; + + if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + { + cl = p->expr->ts.u.cl->length; + gfc_extract_hwi (cl, ¤t_length); + } + + /* If gfc_extract_int above set current_length, we implicitly + know the type is BT_INTEGER and it's EXPR_CONSTANT. */ + + has_ts = expr->ts.u.cl->length_from_typespec; + + if (! cl + || (current_length != -1 && current_length != found_length)) + gfc_set_constant_character_len (found_length, p->expr, + has_ts ? -1 : found_length); + } + } + + return true; +} + + +/* Resolve all of the expressions in an array list. */ + +bool +gfc_resolve_array_constructor (gfc_expr *expr) +{ + bool t; + + t = resolve_array_list (expr->value.constructor); + if (t) + t = gfc_check_constructor_type (expr); + + /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after + the call to this function, so we don't need to call it here; if it was + called twice, an error message there would be duplicated. */ + + return t; +} + + +/* Copy an iterator structure. */ + +gfc_iterator * +gfc_copy_iterator (gfc_iterator *src) +{ + gfc_iterator *dest; + + if (src == NULL) + return NULL; + + dest = gfc_get_iterator (); + + dest->var = gfc_copy_expr (src->var); + dest->start = gfc_copy_expr (src->start); + dest->end = gfc_copy_expr (src->end); + dest->step = gfc_copy_expr (src->step); + dest->unroll = src->unroll; + dest->ivdep = src->ivdep; + dest->vector = src->vector; + dest->novector = src->novector; + + return dest; +} + + +/********* Subroutines for determining the size of an array *********/ + +/* These are needed just to accommodate RESHAPE(). There are no + diagnostics here, we just return false if something goes wrong. */ + + +/* Get the size of single dimension of an array specification. The + array is guaranteed to be one dimensional. */ + +bool +spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) +{ + if (as == NULL) + return false; + + if (dimen < 0 || dimen > as->rank - 1) + gfc_internal_error ("spec_dimen_size(): Bad dimension"); + + if (as->type != AS_EXPLICIT + || !as->lower[dimen] + || !as->upper[dimen]) + return false; + + if (as->lower[dimen]->expr_type != EXPR_CONSTANT + || as->upper[dimen]->expr_type != EXPR_CONSTANT + || as->lower[dimen]->ts.type != BT_INTEGER + || as->upper[dimen]->ts.type != BT_INTEGER) + return false; + + mpz_init (*result); + + mpz_sub (*result, as->upper[dimen]->value.integer, + as->lower[dimen]->value.integer); + + mpz_add_ui (*result, *result, 1); + + if (mpz_cmp_si (*result, 0) < 0) + mpz_set_si (*result, 0); + + return true; +} + + +bool +spec_size (gfc_array_spec *as, mpz_t *result) +{ + mpz_t size; + int d; + + if (!as || as->type == AS_ASSUMED_RANK) + return false; + + mpz_init_set_ui (*result, 1); + + for (d = 0; d < as->rank; d++) + { + if (!spec_dimen_size (as, d, &size)) + { + mpz_clear (*result); + return false; + } + + mpz_mul (*result, *result, size); + mpz_clear (size); + } + + return true; +} + + +/* Get the number of elements in an array section. Optionally, also supply + the end value. */ + +bool +gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end) +{ + mpz_t upper, lower, stride; + mpz_t diff; + bool t; + gfc_expr *stride_expr = NULL; + + if (dimen < 0 || ar == NULL) + gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension"); + + if (dimen > ar->dimen - 1) + { + gfc_error ("Bad array dimension at %L", &ar->c_where[dimen]); + return false; + } + + switch (ar->dimen_type[dimen]) + { + case DIMEN_ELEMENT: + mpz_init (*result); + mpz_set_ui (*result, 1); + t = true; + break; + + case DIMEN_VECTOR: + t = gfc_array_size (ar->start[dimen], result); /* Recurse! */ + break; + + case DIMEN_RANGE: + + mpz_init (stride); + + if (ar->stride[dimen] == NULL) + mpz_set_ui (stride, 1); + else + { + stride_expr = gfc_copy_expr(ar->stride[dimen]); + + if (!gfc_simplify_expr (stride_expr, 1) + || stride_expr->expr_type != EXPR_CONSTANT + || mpz_cmp_ui (stride_expr->value.integer, 0) == 0) + { + gfc_free_expr (stride_expr); + mpz_clear (stride); + return false; + } + mpz_set (stride, stride_expr->value.integer); + gfc_free_expr(stride_expr); + } + + /* Calculate the number of elements via gfc_dep_differce, but only if + start and end are both supplied in the reference or the array spec. + This is to guard against strange but valid code like + + subroutine foo(a,n) + real a(1:n) + n = 3 + print *,size(a(n-1:)) + + where the user changes the value of a variable. If we have to + determine end as well, we cannot do this using gfc_dep_difference. + Fall back to the constants-only code then. */ + + if (end == NULL) + { + bool use_dep; + + use_dep = gfc_dep_difference (ar->end[dimen], ar->start[dimen], + &diff); + if (!use_dep && ar->end[dimen] == NULL && ar->start[dimen] == NULL) + use_dep = gfc_dep_difference (ar->as->upper[dimen], + ar->as->lower[dimen], &diff); + + if (use_dep) + { + mpz_init (*result); + mpz_add (*result, diff, stride); + mpz_div (*result, *result, stride); + if (mpz_cmp_ui (*result, 0) < 0) + mpz_set_ui (*result, 0); + + mpz_clear (stride); + mpz_clear (diff); + return true; + } + + } + + /* Constant-only code here, which covers more cases + like a(:4) etc. */ + mpz_init (upper); + mpz_init (lower); + t = false; + + if (ar->start[dimen] == NULL) + { + if (ar->as->lower[dimen] == NULL + || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT + || ar->as->lower[dimen]->ts.type != BT_INTEGER) + goto cleanup; + mpz_set (lower, ar->as->lower[dimen]->value.integer); + } + else + { + if (ar->start[dimen]->expr_type != EXPR_CONSTANT) + goto cleanup; + mpz_set (lower, ar->start[dimen]->value.integer); + } + + if (ar->end[dimen] == NULL) + { + if (ar->as->upper[dimen] == NULL + || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT + || ar->as->upper[dimen]->ts.type != BT_INTEGER) + goto cleanup; + mpz_set (upper, ar->as->upper[dimen]->value.integer); + } + else + { + if (ar->end[dimen]->expr_type != EXPR_CONSTANT) + goto cleanup; + mpz_set (upper, ar->end[dimen]->value.integer); + } + + mpz_init (*result); + mpz_sub (*result, upper, lower); + mpz_add (*result, *result, stride); + mpz_div (*result, *result, stride); + + /* Zero stride caught earlier. */ + if (mpz_cmp_ui (*result, 0) < 0) + mpz_set_ui (*result, 0); + t = true; + + if (end) + { + mpz_init (*end); + + mpz_sub_ui (*end, *result, 1UL); + mpz_mul (*end, *end, stride); + mpz_add (*end, *end, lower); + } + + cleanup: + mpz_clear (upper); + mpz_clear (lower); + mpz_clear (stride); + return t; + + default: + gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type"); + } + + return t; +} + + +static bool +ref_size (gfc_array_ref *ar, mpz_t *result) +{ + mpz_t size; + int d; + + mpz_init_set_ui (*result, 1); + + for (d = 0; d < ar->dimen; d++) + { + if (!gfc_ref_dimen_size (ar, d, &size, NULL)) + { + mpz_clear (*result); + return false; + } + + mpz_mul (*result, *result, size); + mpz_clear (size); + } + + return true; +} + + +/* Given an array expression and a dimension, figure out how many + elements it has along that dimension. Returns true if we were + able to return a result in the 'result' variable, false + otherwise. */ + +bool +gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) +{ + gfc_ref *ref; + int i; + + gcc_assert (array != NULL); + + if (array->ts.type == BT_CLASS) + return false; + + if (array->rank == -1) + return false; + + if (dimen < 0 || dimen > array->rank - 1) + gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); + + switch (array->expr_type) + { + case EXPR_VARIABLE: + case EXPR_FUNCTION: + for (ref = array->ref; ref; ref = ref->next) + { + if (ref->type != REF_ARRAY) + continue; + + if (ref->u.ar.type == AR_FULL) + return spec_dimen_size (ref->u.ar.as, dimen, result); + + if (ref->u.ar.type == AR_SECTION) + { + for (i = 0; dimen >= 0; i++) + if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) + dimen--; + + return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL); + } + } + + if (array->shape) + { + mpz_init_set (*result, array->shape[dimen]); + return true; + } + + if (array->symtree->n.sym->attr.generic + && array->value.function.esym != NULL) + { + if (!spec_dimen_size (array->value.function.esym->as, dimen, result)) + return false; + } + else if (!spec_dimen_size (array->symtree->n.sym->as, dimen, result)) + return false; + + break; + + case EXPR_ARRAY: + if (array->shape == NULL) { + /* Expressions with rank > 1 should have "shape" properly set */ + if ( array->rank != 1 ) + gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr"); + return gfc_array_size(array, result); + } + + /* Fall through */ + default: + if (array->shape == NULL) + return false; + + mpz_init_set (*result, array->shape[dimen]); + + break; + } + + return true; +} + + +/* Given an array expression, figure out how many elements are in the + array. Returns true if this is possible, and sets the 'result' + variable. Otherwise returns false. */ + +bool +gfc_array_size (gfc_expr *array, mpz_t *result) +{ + expand_info expand_save; + gfc_ref *ref; + int i; + bool t; + + if (array->ts.type == BT_CLASS) + return false; + + switch (array->expr_type) + { + case EXPR_ARRAY: + gfc_push_suppress_errors (); + + expand_save = current_expand; + + current_expand.count = result; + mpz_init_set_ui (*result, 0); + + current_expand.expand_work_function = count_elements; + iter_stack = NULL; + + t = expand_constructor (array->value.constructor); + + gfc_pop_suppress_errors (); + + if (!t) + mpz_clear (*result); + current_expand = expand_save; + return t; + + case EXPR_VARIABLE: + for (ref = array->ref; ref; ref = ref->next) + { + if (ref->type != REF_ARRAY) + continue; + + if (ref->u.ar.type == AR_FULL) + return spec_size (ref->u.ar.as, result); + + if (ref->u.ar.type == AR_SECTION) + return ref_size (&ref->u.ar, result); + } + + return spec_size (array->symtree->n.sym->as, result); + + + default: + if (array->rank == 0 || array->shape == NULL) + return false; + + mpz_init_set_ui (*result, 1); + + for (i = 0; i < array->rank; i++) + mpz_mul (*result, *result, array->shape[i]); + + break; + } + + return true; +} + + +/* Given an array reference, return the shape of the reference in an + array of mpz_t integers. */ + +bool +gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape) +{ + int d; + int i; + + d = 0; + + switch (ar->type) + { + case AR_FULL: + for (; d < ar->as->rank; d++) + if (!spec_dimen_size (ar->as, d, &shape[d])) + goto cleanup; + + return true; + + case AR_SECTION: + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT) + { + if (!gfc_ref_dimen_size (ar, i, &shape[d], NULL)) + goto cleanup; + d++; + } + } + + return true; + + default: + break; + } + +cleanup: + gfc_clear_shape (shape, d); + return false; +} + + +/* Given an array expression, find the array reference structure that + characterizes the reference. */ + +gfc_array_ref * +gfc_find_array_ref (gfc_expr *e, bool allow_null) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION)) + break; + + if (ref == NULL) + { + if (allow_null) + return NULL; + else + gfc_internal_error ("gfc_find_array_ref(): No ref found"); + } + + return &ref->u.ar; +} + + +/* Find out if an array shape is known at compile time. */ + +bool +gfc_is_compile_time_shape (gfc_array_spec *as) +{ + if (as->type != AS_EXPLICIT) + return false; + + for (int i = 0; i < as->rank; i++) + if (!gfc_is_constant_expr (as->lower[i]) + || !gfc_is_constant_expr (as->upper[i])) + return false; + + return true; +} diff --git a/gcc/fortran/bbt.c b/gcc/fortran/bbt.c deleted file mode 100644 index 8b65471..0000000 --- a/gcc/fortran/bbt.c +++ /dev/null @@ -1,198 +0,0 @@ -/* Balanced binary trees using treaps. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -/* The idea is to balance the tree using pseudorandom numbers. The - main constraint on this implementation is that we have several - distinct structures that have to be arranged in a binary tree. - These structures all contain a BBT_HEADER() in front that gives the - treap-related information. The key and value are assumed to reside - in the rest of the structure. - - When calling, we are also passed a comparison function that - compares two nodes. We don't implement a separate 'find' function - here, but rather use separate functions for each variety of tree. - We are also restricted to not copy treap structures, which most - implementations find convenient, because we otherwise would need to - know how long the structure is. - - This implementation is based on Stefan Nilsson's article in the - July 1997 Doctor Dobb's Journal, "Treaps in Java". */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" - -typedef struct gfc_treap -{ - BBT_HEADER (gfc_treap); -} -gfc_bbt; - -/* Simple linear congruential pseudorandom number generator. The - period of this generator is 44071, which is plenty for our - purposes. */ - -static int -pseudo_random (void) -{ - static int x0 = 5341; - - x0 = (22611 * x0 + 10) % 44071; - return x0; -} - - -/* Rotate the treap left. */ - -static gfc_bbt * -rotate_left (gfc_bbt *t) -{ - gfc_bbt *temp; - - temp = t->right; - t->right = t->right->left; - temp->left = t; - - return temp; -} - - -/* Rotate the treap right. */ - -static gfc_bbt * -rotate_right (gfc_bbt *t) -{ - gfc_bbt *temp; - - temp = t->left; - t->left = t->left->right; - temp->right = t; - - return temp; -} - - -/* Recursive insertion function. Returns the updated treap, or - aborts if we find a duplicate key. */ - -static gfc_bbt * -insert (gfc_bbt *new_bbt, gfc_bbt *t, compare_fn compare) -{ - int c; - - if (t == NULL) - return new_bbt; - - c = (*compare) (new_bbt, t); - - if (c < 0) - { - t->left = insert (new_bbt, t->left, compare); - if (t->priority < t->left->priority) - t = rotate_right (t); - } - else if (c > 0) - { - t->right = insert (new_bbt, t->right, compare); - if (t->priority < t->right->priority) - t = rotate_left (t); - } - else /* if (c == 0) */ - gfc_internal_error("insert_bbt(): Duplicate key found"); - - return t; -} - - -/* Given root pointer, a new node and a comparison function, insert - the new node into the treap. It is an error to insert a key that - already exists. */ - -void -gfc_insert_bbt (void *root, void *new_node, compare_fn compare) -{ - gfc_bbt **r, *n; - - r = (gfc_bbt **) root; - n = (gfc_bbt *) new_node; - n->priority = pseudo_random (); - *r = insert (n, *r, compare); -} - -static gfc_bbt * -delete_root (gfc_bbt *t) -{ - gfc_bbt *temp; - - if (t->left == NULL) - return t->right; - if (t->right == NULL) - return t->left; - - if (t->left->priority > t->right->priority) - { - temp = rotate_right (t); - temp->right = delete_root (t); - } - else - { - temp = rotate_left (t); - temp->left = delete_root (t); - } - - return temp; -} - - -/* Delete an element from a tree. The 'old' value does not - necessarily have to point to the element to be deleted, it must - just point to a treap structure with the key to be deleted. - Returns the new root node of the tree. */ - -static gfc_bbt * -delete_treap (gfc_bbt *old, gfc_bbt *t, compare_fn compare) -{ - int c; - - if (t == NULL) - return NULL; - - c = (*compare) (old, t); - - if (c < 0) - t->left = delete_treap (old, t->left, compare); - if (c > 0) - t->right = delete_treap (old, t->right, compare); - if (c == 0) - t = delete_root (t); - - return t; -} - - -void -gfc_delete_bbt (void *root, void *old, compare_fn compare) -{ - gfc_bbt **t; - - t = (gfc_bbt **) root; - *t = delete_treap ((gfc_bbt *) old, *t, compare); -} diff --git a/gcc/fortran/bbt.cc b/gcc/fortran/bbt.cc new file mode 100644 index 0000000..8b65471 --- /dev/null +++ b/gcc/fortran/bbt.cc @@ -0,0 +1,198 @@ +/* Balanced binary trees using treaps. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +/* The idea is to balance the tree using pseudorandom numbers. The + main constraint on this implementation is that we have several + distinct structures that have to be arranged in a binary tree. + These structures all contain a BBT_HEADER() in front that gives the + treap-related information. The key and value are assumed to reside + in the rest of the structure. + + When calling, we are also passed a comparison function that + compares two nodes. We don't implement a separate 'find' function + here, but rather use separate functions for each variety of tree. + We are also restricted to not copy treap structures, which most + implementations find convenient, because we otherwise would need to + know how long the structure is. + + This implementation is based on Stefan Nilsson's article in the + July 1997 Doctor Dobb's Journal, "Treaps in Java". */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" + +typedef struct gfc_treap +{ + BBT_HEADER (gfc_treap); +} +gfc_bbt; + +/* Simple linear congruential pseudorandom number generator. The + period of this generator is 44071, which is plenty for our + purposes. */ + +static int +pseudo_random (void) +{ + static int x0 = 5341; + + x0 = (22611 * x0 + 10) % 44071; + return x0; +} + + +/* Rotate the treap left. */ + +static gfc_bbt * +rotate_left (gfc_bbt *t) +{ + gfc_bbt *temp; + + temp = t->right; + t->right = t->right->left; + temp->left = t; + + return temp; +} + + +/* Rotate the treap right. */ + +static gfc_bbt * +rotate_right (gfc_bbt *t) +{ + gfc_bbt *temp; + + temp = t->left; + t->left = t->left->right; + temp->right = t; + + return temp; +} + + +/* Recursive insertion function. Returns the updated treap, or + aborts if we find a duplicate key. */ + +static gfc_bbt * +insert (gfc_bbt *new_bbt, gfc_bbt *t, compare_fn compare) +{ + int c; + + if (t == NULL) + return new_bbt; + + c = (*compare) (new_bbt, t); + + if (c < 0) + { + t->left = insert (new_bbt, t->left, compare); + if (t->priority < t->left->priority) + t = rotate_right (t); + } + else if (c > 0) + { + t->right = insert (new_bbt, t->right, compare); + if (t->priority < t->right->priority) + t = rotate_left (t); + } + else /* if (c == 0) */ + gfc_internal_error("insert_bbt(): Duplicate key found"); + + return t; +} + + +/* Given root pointer, a new node and a comparison function, insert + the new node into the treap. It is an error to insert a key that + already exists. */ + +void +gfc_insert_bbt (void *root, void *new_node, compare_fn compare) +{ + gfc_bbt **r, *n; + + r = (gfc_bbt **) root; + n = (gfc_bbt *) new_node; + n->priority = pseudo_random (); + *r = insert (n, *r, compare); +} + +static gfc_bbt * +delete_root (gfc_bbt *t) +{ + gfc_bbt *temp; + + if (t->left == NULL) + return t->right; + if (t->right == NULL) + return t->left; + + if (t->left->priority > t->right->priority) + { + temp = rotate_right (t); + temp->right = delete_root (t); + } + else + { + temp = rotate_left (t); + temp->left = delete_root (t); + } + + return temp; +} + + +/* Delete an element from a tree. The 'old' value does not + necessarily have to point to the element to be deleted, it must + just point to a treap structure with the key to be deleted. + Returns the new root node of the tree. */ + +static gfc_bbt * +delete_treap (gfc_bbt *old, gfc_bbt *t, compare_fn compare) +{ + int c; + + if (t == NULL) + return NULL; + + c = (*compare) (old, t); + + if (c < 0) + t->left = delete_treap (old, t->left, compare); + if (c > 0) + t->right = delete_treap (old, t->right, compare); + if (c == 0) + t = delete_root (t); + + return t; +} + + +void +gfc_delete_bbt (void *root, void *old, compare_fn compare) +{ + gfc_bbt **t; + + t = (gfc_bbt **) root; + *t = delete_treap ((gfc_bbt *) old, *t, compare); +} diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c deleted file mode 100644 index 053f856..0000000 --- a/gcc/fortran/check.c +++ /dev/null @@ -1,7523 +0,0 @@ -/* Check functions - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught & Katherine Holcomb - -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 -. */ - - -/* These functions check to see if an argument list is compatible with - a particular intrinsic function or subroutine. Presence of - required arguments has already been established, the argument list - has been sorted into the right order and has NULL arguments in the - correct places for missing optional arguments. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "intrinsic.h" -#include "constructor.h" -#include "target-memory.h" - - -/* Reset a BOZ to a zero value. This is used to prevent run-on errors - from resolve.c(resolve_function). */ - -static void -reset_boz (gfc_expr *x) -{ - /* Clear boz info. */ - x->boz.rdx = 0; - x->boz.len = 0; - free (x->boz.str); - - x->ts.type = BT_INTEGER; - x->ts.kind = gfc_default_integer_kind; - mpz_init (x->value.integer); - mpz_set_ui (x->value.integer, 0); -} - -/* A BOZ literal constant can appear in a limited number of contexts. - gfc_invalid_boz() is a helper function to simplify error/warning - generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran - allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz - is used, then issue a warning; otherwise issue an error. */ - -bool -gfc_invalid_boz (const char *msg, locus *loc) -{ - if (flag_allow_invalid_boz) - { - gfc_warning (0, msg, loc); - return false; - } - - const char *hint = _(" [see %<-fno-allow-invalid-boz%>]"); - size_t len = strlen (msg) + strlen (hint) + 1; - char *msg2 = (char *) alloca (len); - strcpy (msg2, msg); - strcat (msg2, hint); - gfc_error (msg2, loc); - return true; -} - - -/* Issue an error for an illegal BOZ argument. */ - -static bool -illegal_boz_arg (gfc_expr *x) -{ - if (x->ts.type == BT_BOZ) - { - gfc_error ("BOZ literal constant at %L cannot be an actual argument " - "to %qs", &x->where, gfc_current_intrinsic); - reset_boz (x); - return true; - } - - return false; -} - -/* Some precedures take two arguments such that both cannot be BOZ. */ - -static bool -boz_args_check(gfc_expr *i, gfc_expr *j) -{ - if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ) - { - gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ " - "literal constants", gfc_current_intrinsic, &i->where, - &j->where); - reset_boz (i); - reset_boz (j); - return false; - - } - - return true; -} - - -/* Check that a BOZ is a constant. */ - -static bool -is_boz_constant (gfc_expr *a) -{ - if (a->expr_type != EXPR_CONSTANT) - { - gfc_error ("Invalid use of BOZ literal constant at %L", &a->where); - return false; - } - - return true; -} - - -/* Convert a octal string into a binary string. This is used in the - fallback conversion of an octal string to a REAL. */ - -static char * -oct2bin(int nbits, char *oct) -{ - const char bits[8][5] = { - "000", "001", "010", "011", "100", "101", "110", "111"}; - - char *buf, *bufp; - int i, j, n; - - j = nbits + 1; - if (nbits == 64) j++; - - bufp = buf = XCNEWVEC (char, j + 1); - memset (bufp, 0, j + 1); - - n = strlen (oct); - for (i = 0; i < n; i++, oct++) - { - j = *oct - 48; - strcpy (bufp, &bits[j][0]); - bufp += 3; - } - - bufp = XCNEWVEC (char, nbits + 1); - if (nbits == 64) - strcpy (bufp, buf + 2); - else - strcpy (bufp, buf + 1); - - free (buf); - - return bufp; -} - - -/* Convert a hexidecimal string into a binary string. This is used in the - fallback conversion of a hexidecimal string to a REAL. */ - -static char * -hex2bin(int nbits, char *hex) -{ - const char bits[16][5] = { - "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111", - "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"}; - - char *buf, *bufp; - int i, j, n; - - bufp = buf = XCNEWVEC (char, nbits + 1); - memset (bufp, 0, nbits + 1); - - n = strlen (hex); - for (i = 0; i < n; i++, hex++) - { - j = *hex; - if (j > 47 && j < 58) - j -= 48; - else if (j > 64 && j < 71) - j -= 55; - else if (j > 96 && j < 103) - j -= 87; - else - gcc_unreachable (); - - strcpy (bufp, &bits[j][0]); - bufp += 4; - } - - return buf; -} - - -/* Fallback conversion of a BOZ string to REAL. */ - -static void -bin2real (gfc_expr *x, int kind) -{ - char buf[114], *sp; - int b, i, ie, t, w; - bool sgn; - mpz_t em; - - i = gfc_validate_kind (BT_REAL, kind, false); - t = gfc_real_kinds[i].digits - 1; - - /* Number of bits in the exponent. */ - if (gfc_real_kinds[i].max_exponent == 16384) - w = 15; - else if (gfc_real_kinds[i].max_exponent == 1024) - w = 11; - else - w = 8; - - if (x->boz.rdx == 16) - sp = hex2bin (gfc_real_kinds[i].mode_precision, x->boz.str); - else if (x->boz.rdx == 8) - sp = oct2bin (gfc_real_kinds[i].mode_precision, x->boz.str); - else - sp = x->boz.str; - - /* Extract sign bit. */ - sgn = *sp != '0'; - - /* Extract biased exponent. */ - memset (buf, 0, 114); - strncpy (buf, ++sp, w); - mpz_init (em); - mpz_set_str (em, buf, 2); - ie = mpz_get_si (em); - - mpfr_init2 (x->value.real, t + 1); - x->ts.type = BT_REAL; - x->ts.kind = kind; - - sp += w; /* Set to first digit in significand. */ - b = (1 << w) - 1; - if ((i == 0 && ie == b) || (i == 1 && ie == b) - || ((i == 2 || i == 3) && ie == b)) - { - bool zeros = true; - if (i == 2) sp++; - for (; *sp; sp++) - { - if (*sp != '0') - { - zeros = false; - break; - } - } - - if (zeros) - mpfr_set_inf (x->value.real, 1); - else - mpfr_set_nan (x->value.real); - } - else - { - if (i == 2) - strncpy (buf, sp, t + 1); - else - { - /* Significand with hidden bit. */ - buf[0] = '1'; - strncpy (&buf[1], sp, t); - } - - /* Convert to significand to integer. */ - mpz_set_str (em, buf, 2); - ie -= ((1 << (w - 1)) - 1); /* Unbiased exponent. */ - mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODE); - } - - if (sgn) mpfr_neg (x->value.real, x->value.real, GFC_RND_MODE); - - mpz_clear (em); -} - - -/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real () - converts the string into a REAL of the appropriate kind. The treatment - of the sign bit is processor dependent. */ - -bool -gfc_boz2real (gfc_expr *x, int kind) -{ - extern int gfc_max_integer_kind; - gfc_typespec ts; - int len; - char *buf, *str; - - if (!is_boz_constant (x)) - return false; - - /* Determine the length of the required string. */ - len = 8 * kind; - if (x->boz.rdx == 16) len /= 4; - if (x->boz.rdx == 8) len = len / 3 + 1; - buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */ - - if (x->boz.len >= len) /* Truncate if necessary. */ - { - str = x->boz.str + (x->boz.len - len); - strcpy(buf, str); - } - else /* Copy and pad. */ - { - memset (buf, 48, len); - str = buf + (len - x->boz.len); - strcpy (str, x->boz.str); - } - - /* Need to adjust leading bits in an octal string. */ - if (x->boz.rdx == 8) - { - /* Clear first bit. */ - if (kind == 4 || kind == 10 || kind == 16) - { - if (buf[0] == '4') - buf[0] = '0'; - else if (buf[0] == '5') - buf[0] = '1'; - else if (buf[0] == '6') - buf[0] = '2'; - else if (buf[0] == '7') - buf[0] = '3'; - } - /* Clear first two bits. */ - else - { - if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6') - buf[0] = '0'; - else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7') - buf[0] = '1'; - } - } - - /* Reset BOZ string to the truncated or padded version. */ - free (x->boz.str); - x->boz.len = len; - x->boz.str = XCNEWVEC (char, len + 1); - strncpy (x->boz.str, buf, len); - - /* For some targets, the largest INTEGER in terms of bits is smaller than - the bits needed to hold the REAL. Fortunately, the kind type parameter - indicates the number of bytes required to an INTEGER and a REAL. */ - if (gfc_max_integer_kind < kind) - { - bin2real (x, kind); - } - else - { - /* Convert to widest possible integer. */ - gfc_boz2int (x, gfc_max_integer_kind); - ts.type = BT_REAL; - ts.kind = kind; - if (!gfc_convert_boz (x, &ts)) - { - gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where); - return false; - } - } - - return true; -} - - -/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int () - converts the string into an INTEGER of the appropriate kind. The - treatment of the sign bit is processor dependent. If the converted - value exceeds the range of the type, then wrap-around semantics are - applied. */ - -bool -gfc_boz2int (gfc_expr *x, int kind) -{ - int i, len; - char *buf, *str; - mpz_t tmp1; - - if (!is_boz_constant (x)) - return false; - - i = gfc_validate_kind (BT_INTEGER, kind, false); - len = gfc_integer_kinds[i].bit_size; - if (x->boz.rdx == 16) len /= 4; - if (x->boz.rdx == 8) len = len / 3 + 1; - buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */ - - if (x->boz.len >= len) /* Truncate if necessary. */ - { - str = x->boz.str + (x->boz.len - len); - strcpy(buf, str); - } - else /* Copy and pad. */ - { - memset (buf, 48, len); - str = buf + (len - x->boz.len); - strcpy (str, x->boz.str); - } - - /* Need to adjust leading bits in an octal string. */ - if (x->boz.rdx == 8) - { - /* Clear first bit. */ - if (kind == 1 || kind == 4 || kind == 16) - { - if (buf[0] == '4') - buf[0] = '0'; - else if (buf[0] == '5') - buf[0] = '1'; - else if (buf[0] == '6') - buf[0] = '2'; - else if (buf[0] == '7') - buf[0] = '3'; - } - /* Clear first two bits. */ - else - { - if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6') - buf[0] = '0'; - else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7') - buf[0] = '1'; - } - } - - /* Convert as-if unsigned integer. */ - mpz_init (tmp1); - mpz_set_str (tmp1, buf, x->boz.rdx); - - /* Check for wrap-around. */ - if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0) - { - mpz_t tmp2; - mpz_init (tmp2); - mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1); - mpz_mod (tmp1, tmp1, tmp2); - mpz_sub (tmp1, tmp1, tmp2); - mpz_clear (tmp2); - } - - /* Clear boz info. */ - x->boz.rdx = 0; - x->boz.len = 0; - free (x->boz.str); - - mpz_init (x->value.integer); - mpz_set (x->value.integer, tmp1); - x->ts.type = BT_INTEGER; - x->ts.kind = kind; - mpz_clear (tmp1); - - return true; -} - - -/* Make sure an expression is a scalar. */ - -static bool -scalar_check (gfc_expr *e, int n) -{ - if (e->rank == 0) - return true; - - gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where); - - return false; -} - - -/* Check the type of an expression. */ - -static bool -type_check (gfc_expr *e, int n, bt type) -{ - if (e->ts.type == type) - return true; - - gfc_error ("%qs argument of %qs intrinsic at %L must be %s", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where, gfc_basic_typename (type)); - - return false; -} - - -/* Check that the expression is a numeric type. */ - -static bool -numeric_check (gfc_expr *e, int n) -{ - /* Users sometime use a subroutine designator as an actual argument to - an intrinsic subprogram that expects an argument with a numeric type. */ - if (e->symtree && e->symtree->n.sym->attr.subroutine) - goto error; - - if (gfc_numeric_ts (&e->ts)) - return true; - - /* If the expression has not got a type, check if its namespace can - offer a default type. */ - if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) - && e->symtree->n.sym->ts.type == BT_UNKNOWN - && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns) - && gfc_numeric_ts (&e->symtree->n.sym->ts)) - { - e->ts = e->symtree->n.sym->ts; - return true; - } - -error: - - gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where); - - return false; -} - - -/* Check that an expression is integer or real. */ - -static bool -int_or_real_check (gfc_expr *e, int n) -{ - if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - return false; - } - - return true; -} - -/* Check that an expression is integer or real; allow character for - F2003 or later. */ - -static bool -int_or_real_or_char_check_f2003 (gfc_expr *e, int n) -{ - if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) - { - if (e->ts.type == BT_CHARACTER) - return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for " - "%qs argument of %qs intrinsic at %L", - gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - else - { - if (gfc_option.allow_std & GFC_STD_F2003) - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " - "or REAL or CHARACTER", - gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - else - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " - "or REAL", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - } - return false; - } - - return true; -} - -/* Check that an expression is an intrinsic type. */ -static bool -intrinsic_type_check (gfc_expr *e, int n) -{ - if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL - && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER - && e->ts.type != BT_LOGICAL) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type", - gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - return false; - } - return true; -} - -/* Check that an expression is real or complex. */ - -static bool -real_or_complex_check (gfc_expr *e, int n) -{ - if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be REAL " - "or COMPLEX", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - return false; - } - - return true; -} - - -/* Check that an expression is INTEGER or PROCEDURE. */ - -static bool -int_or_proc_check (gfc_expr *e, int n) -{ - if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " - "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - return false; - } - - return true; -} - - -/* Check that the expression is an optional constant integer - and that it specifies a valid kind for that type. */ - -static bool -kind_check (gfc_expr *k, int n, bt type) -{ - int kind; - - if (k == NULL) - return true; - - if (!type_check (k, n, BT_INTEGER)) - return false; - - if (!scalar_check (k, n)) - return false; - - if (!gfc_check_init_expr (k)) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &k->where); - return false; - } - - if (gfc_extract_int (k, &kind) - || gfc_validate_kind (type, kind, true) < 0) - { - gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), - &k->where); - return false; - } - - return true; -} - - -/* Make sure the expression is a double precision real. */ - -static bool -double_check (gfc_expr *d, int n) -{ - if (!type_check (d, n, BT_REAL)) - return false; - - if (d->ts.kind != gfc_default_double_kind) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be double " - "precision", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &d->where); - return false; - } - - return true; -} - - -static bool -coarray_check (gfc_expr *e, int n) -{ - if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok - && CLASS_DATA (e)->attr.codimension - && CLASS_DATA (e)->as->corank) - { - gfc_add_class_array_ref (e); - return true; - } - - if (!gfc_is_coarray (e)) - { - gfc_error ("Expected coarray variable as %qs argument to the %s " - "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - return false; - } - - return true; -} - - -/* Make sure the expression is a logical array. */ - -static bool -logical_array_check (gfc_expr *array, int n) -{ - if (array->ts.type != BT_LOGICAL || array->rank == 0) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a logical " - "array", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &array->where); - return false; - } - - return true; -} - - -/* Make sure an expression is an array. */ - -static bool -array_check (gfc_expr *e, int n) -{ - if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok - && CLASS_DATA (e)->attr.dimension - && CLASS_DATA (e)->as->rank) - { - gfc_add_class_array_ref (e); - } - - if (e->rank != 0 && e->ts.type != BT_PROCEDURE) - return true; - - gfc_error ("%qs argument of %qs intrinsic at %L must be an array", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where); - - return false; -} - - -/* If expr is a constant, then check to ensure that it is greater than - of equal to zero. */ - -static bool -nonnegative_check (const char *arg, gfc_expr *expr) -{ - int i; - - if (expr->expr_type == EXPR_CONSTANT) - { - gfc_extract_int (expr, &i); - if (i < 0) - { - gfc_error ("%qs at %L must be nonnegative", arg, &expr->where); - return false; - } - } - - return true; -} - - -/* If expr is a constant, then check to ensure that it is greater than zero. */ - -static bool -positive_check (int n, gfc_expr *expr) -{ - int i; - - if (expr->expr_type == EXPR_CONSTANT) - { - gfc_extract_int (expr, &i); - if (i <= 0) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be positive", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &expr->where); - return false; - } - } - - return true; -} - - -/* If expr2 is constant, then check that the value is less than - (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ - -static bool -less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, - gfc_expr *expr2, bool or_equal) -{ - int i2, i3; - - if (expr2->expr_type == EXPR_CONSTANT) - { - gfc_extract_int (expr2, &i2); - i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); - - /* For ISHFT[C], check that |shift| <= bit_size(i). */ - if (arg2 == NULL) - { - if (i2 < 0) - i2 = -i2; - - if (i2 > gfc_integer_kinds[i3].bit_size) - { - gfc_error ("The absolute value of SHIFT at %L must be less " - "than or equal to BIT_SIZE(%qs)", - &expr2->where, arg1); - return false; - } - } - - if (or_equal) - { - if (i2 > gfc_integer_kinds[i3].bit_size) - { - gfc_error ("%qs at %L must be less than " - "or equal to BIT_SIZE(%qs)", - arg2, &expr2->where, arg1); - return false; - } - } - else - { - if (i2 >= gfc_integer_kinds[i3].bit_size) - { - gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)", - arg2, &expr2->where, arg1); - return false; - } - } - } - - return true; -} - - -/* If expr is constant, then check that the value is less than or equal - to the bit_size of the kind k. */ - -static bool -less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) -{ - int i, val; - - if (expr->expr_type != EXPR_CONSTANT) - return true; - - i = gfc_validate_kind (BT_INTEGER, k, false); - gfc_extract_int (expr, &val); - - if (val > gfc_integer_kinds[i].bit_size) - { - gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " - "INTEGER(KIND=%d)", arg, &expr->where, k); - return false; - } - - return true; -} - - -/* If expr2 and expr3 are constants, then check that the value is less than - or equal to bit_size(expr1). */ - -static bool -less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, - gfc_expr *expr2, const char *arg3, gfc_expr *expr3) -{ - int i2, i3; - - if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) - { - gfc_extract_int (expr2, &i2); - gfc_extract_int (expr3, &i3); - i2 += i3; - i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); - if (i2 > gfc_integer_kinds[i3].bit_size) - { - gfc_error ("%<%s + %s%> at %L must be less than or equal " - "to BIT_SIZE(%qs)", - arg2, arg3, &expr2->where, arg1); - return false; - } - } - - return true; -} - -/* Make sure two expressions have the same type. */ - -static bool -same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false) -{ - gfc_typespec *ets = &e->ts; - gfc_typespec *fts = &f->ts; - - if (assoc) - { - /* Procedure pointer component expressions have the type of the interface - procedure. If they are being tested for association with a procedure - pointer (ie. not a component), the type of the procedure must be - determined. */ - if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) - ets = &e->symtree->n.sym->ts; - if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) - fts = &f->symtree->n.sym->ts; - } - - if (gfc_compare_types (ets, fts)) - return true; - - gfc_error ("%qs argument of %qs intrinsic at %L must be the same type " - "and kind as %qs", gfc_current_intrinsic_arg[m]->name, - gfc_current_intrinsic, &f->where, - gfc_current_intrinsic_arg[n]->name); - - return false; -} - - -/* Make sure that an expression has a certain (nonzero) rank. */ - -static bool -rank_check (gfc_expr *e, int n, int rank) -{ - if (e->rank == rank) - return true; - - gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where, rank); - - return false; -} - - -/* Make sure a variable expression is not an optional dummy argument. */ - -static bool -nonoptional_check (gfc_expr *e, int n) -{ - if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) - { - gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where); - } - - /* TODO: Recursive check on nonoptional variables? */ - - return true; -} - - -/* Check for ALLOCATABLE attribute. */ - -static bool -allocatable_check (gfc_expr *e, int n) -{ - symbol_attribute attr; - - attr = gfc_variable_attr (e, NULL); - if (!attr.allocatable - || (attr.associate_var && !attr.select_rank_temporary)) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where); - return false; - } - - return true; -} - - -/* Check that an expression has a particular kind. */ - -static bool -kind_value_check (gfc_expr *e, int n, int k) -{ - if (e->ts.kind == k) - return true; - - gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, - &e->where, k); - - return false; -} - - -/* Make sure an expression is a variable. */ - -static bool -variable_check (gfc_expr *e, int n, bool allow_proc) -{ - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.intent == INTENT_IN - && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT - || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT) - && !gfc_check_vardef_context (e, false, true, false, NULL)) - { - gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)", - gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &e->where); - return false; - } - - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.flavor != FL_PARAMETER - && (allow_proc || !e->symtree->n.sym->attr.function)) - return true; - - if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function - && e->symtree->n.sym == e->symtree->n.sym->result) - { - gfc_namespace *ns; - for (ns = gfc_current_ns; ns; ns = ns->parent) - if (ns->proc_name == e->symtree->n.sym) - return true; - } - - /* F2018:R902: function reference having a data pointer result. */ - if (e->expr_type == EXPR_FUNCTION - && e->symtree->n.sym->attr.flavor == FL_PROCEDURE - && e->symtree->n.sym->attr.function - && e->symtree->n.sym->attr.pointer) - return true; - - gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", - gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); - - return false; -} - - -/* Check the common DIM parameter for correctness. */ - -static bool -dim_check (gfc_expr *dim, int n, bool optional) -{ - if (dim == NULL) - return true; - - if (!type_check (dim, n, BT_INTEGER)) - return false; - - if (!scalar_check (dim, n)) - return false; - - if (!optional && !nonoptional_check (dim, n)) - return false; - - return true; -} - - -/* If a coarray DIM parameter is a constant, make sure that it is greater than - zero and less than or equal to the corank of the given array. */ - -static bool -dim_corank_check (gfc_expr *dim, gfc_expr *array) -{ - int corank; - - gcc_assert (array->expr_type == EXPR_VARIABLE); - - if (dim->expr_type != EXPR_CONSTANT) - return true; - - if (array->ts.type == BT_CLASS) - return true; - - corank = gfc_get_corank (array); - - if (mpz_cmp_ui (dim->value.integer, 1) < 0 - || mpz_cmp_ui (dim->value.integer, corank) > 0) - { - gfc_error ("% argument of %qs intrinsic at %L is not a valid " - "codimension index", gfc_current_intrinsic, &dim->where); - - return false; - } - - return true; -} - - -/* If a DIM parameter is a constant, make sure that it is greater than - zero and less than or equal to the rank of the given array. If - allow_assumed is zero then dim must be less than the rank of the array - for assumed size arrays. */ - -static bool -dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) -{ - gfc_array_ref *ar; - int rank; - - if (dim == NULL) - return true; - - if (dim->expr_type != EXPR_CONSTANT) - return true; - - if (array->expr_type == EXPR_FUNCTION && array->value.function.isym - && array->value.function.isym->id == GFC_ISYM_SPREAD) - rank = array->rank + 1; - else - rank = array->rank; - - /* Assumed-rank array. */ - if (rank == -1) - rank = GFC_MAX_DIMENSIONS; - - if (array->expr_type == EXPR_VARIABLE) - { - ar = gfc_find_array_ref (array, true); - if (!ar) - return false; - if (ar->as->type == AS_ASSUMED_SIZE - && !allow_assumed - && ar->type != AR_ELEMENT - && ar->type != AR_SECTION) - rank--; - } - - if (mpz_cmp_ui (dim->value.integer, 1) < 0 - || mpz_cmp_ui (dim->value.integer, rank) > 0) - { - gfc_error ("% argument of %qs intrinsic at %L is not a valid " - "dimension index", gfc_current_intrinsic, &dim->where); - - return false; - } - - return true; -} - - -/* Compare the size of a along dimension ai with the size of b along - dimension bi, returning 0 if they are known not to be identical, - and 1 if they are identical, or if this cannot be determined. */ - -static int -identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) -{ - mpz_t a_size, b_size; - int ret; - - gcc_assert (a->rank > ai); - gcc_assert (b->rank > bi); - - ret = 1; - - if (gfc_array_dimen_size (a, ai, &a_size)) - { - if (gfc_array_dimen_size (b, bi, &b_size)) - { - if (mpz_cmp (a_size, b_size) != 0) - ret = 0; - - mpz_clear (b_size); - } - mpz_clear (a_size); - } - return ret; -} - -/* Calculate the length of a character variable, including substrings. - Strip away parentheses if necessary. Return -1 if no length could - be determined. */ - -static long -gfc_var_strlen (const gfc_expr *a) -{ - gfc_ref *ra; - - while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES) - a = a->value.op.op1; - - for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next) - ; - - if (ra) - { - long start_a, end_a; - - if (!ra->u.ss.end) - return -1; - - if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT) - && ra->u.ss.end->expr_type == EXPR_CONSTANT) - { - start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer) - : 1; - end_a = mpz_get_si (ra->u.ss.end->value.integer); - return (end_a < start_a) ? 0 : end_a - start_a + 1; - } - else if (ra->u.ss.start - && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0) - return 1; - else - return -1; - } - - if (a->ts.u.cl && a->ts.u.cl->length - && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) - return mpz_get_si (a->ts.u.cl->length->value.integer); - else if (a->expr_type == EXPR_CONSTANT - && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) - return a->value.character.length; - else - return -1; - -} - -/* Check whether two character expressions have the same length; - returns true if they have or if the length cannot be determined, - otherwise return false and raise a gfc_error. */ - -bool -gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) -{ - long len_a, len_b; - - len_a = gfc_var_strlen(a); - len_b = gfc_var_strlen(b); - - if (len_a == -1 || len_b == -1 || len_a == len_b) - return true; - else - { - gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", - len_a, len_b, name, &a->where); - return false; - } -} - - -/***** Check functions *****/ - -/* Check subroutine suitable for intrinsics taking a real argument and - a kind argument for the result. */ - -static bool -check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) -{ - if (!type_check (a, 0, BT_REAL)) - return false; - if (!kind_check (kind, 1, type)) - return false; - - return true; -} - - -/* Check subroutine suitable for ceiling, floor and nint. */ - -bool -gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) -{ - return check_a_kind (a, kind, BT_INTEGER); -} - - -/* Check subroutine suitable for aint, anint. */ - -bool -gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) -{ - return check_a_kind (a, kind, BT_REAL); -} - - -bool -gfc_check_abs (gfc_expr *a) -{ - if (!numeric_check (a, 0)) - return false; - - return true; -} - - -bool -gfc_check_achar (gfc_expr *a, gfc_expr *kind) -{ - if (a->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " - "ACHAR intrinsic subprogram"), &a->where)) - return false; - - if (!gfc_boz2int (a, gfc_default_integer_kind)) - return false; - } - - if (!type_check (a, 0, BT_INTEGER)) - return false; - - if (!kind_check (kind, 1, BT_CHARACTER)) - return false; - - return true; -} - - -bool -gfc_check_access_func (gfc_expr *name, gfc_expr *mode) -{ - if (!type_check (name, 0, BT_CHARACTER) - || !scalar_check (name, 0)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!type_check (mode, 1, BT_CHARACTER) - || !scalar_check (mode, 1)) - return false; - if (!kind_value_check (mode, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) -{ - if (!logical_array_check (mask, 0)) - return false; - - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_rank_check (dim, mask, 0)) - return false; - - return true; -} - - -/* Limited checking for ALLOCATED intrinsic. Additional checking - is performed in intrinsic.c(sort_actual), because ALLOCATED - has two mutually exclusive non-optional arguments. */ - -bool -gfc_check_allocated (gfc_expr *array) -{ - /* Tests on allocated components of coarrays need to detour the check to - argument of the _caf_get. */ - if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION - && array->value.function.isym - && array->value.function.isym->id == GFC_ISYM_CAF_GET) - { - array = array->value.function.actual->expr; - if (!array->ref) - return false; - } - - if (!variable_check (array, 0, false)) - return false; - if (!allocatable_check (array, 0)) - return false; - - return true; -} - - -/* Common check function where the first argument must be real or - integer and the second argument must be the same as the first. */ - -bool -gfc_check_a_p (gfc_expr *a, gfc_expr *p) -{ - if (!int_or_real_check (a, 0)) - return false; - - if (a->ts.type != p->ts.type) - { - gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " - "have the same type", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &p->where); - return false; - } - - if (a->ts.kind != p->ts.kind) - { - if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", - &p->where)) - return false; - } - - return true; -} - - -bool -gfc_check_x_yd (gfc_expr *x, gfc_expr *y) -{ - if (!double_check (x, 0) || !double_check (y, 1)) - return false; - - return true; -} - -bool -gfc_invalid_null_arg (gfc_expr *x) -{ - if (x->expr_type == EXPR_NULL) - { - gfc_error ("NULL at %L is not permitted as actual argument " - "to %qs intrinsic function", &x->where, - gfc_current_intrinsic); - return true; - } - return false; -} - -bool -gfc_check_associated (gfc_expr *pointer, gfc_expr *target) -{ - symbol_attribute attr1, attr2; - int i; - bool t; - - if (gfc_invalid_null_arg (pointer)) - return false; - - attr1 = gfc_expr_attr (pointer); - - if (!attr1.pointer && !attr1.proc_pointer) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &pointer->where); - return false; - } - - /* F2008, C1242. */ - if (attr1.pointer && gfc_is_coindexed (pointer)) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be " - "coindexed", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &pointer->where); - return false; - } - - /* Target argument is optional. */ - if (target == NULL) - return true; - - if (gfc_invalid_null_arg (target)) - return false; - - if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) - attr2 = gfc_expr_attr (target); - else - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer " - "or target VARIABLE or FUNCTION", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &target->where); - return false; - } - - if (attr1.pointer && !attr2.pointer && !attr2.target) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER " - "or a TARGET", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &target->where); - return false; - } - - /* F2008, C1242. */ - if (attr1.pointer && gfc_is_coindexed (target)) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be " - "coindexed", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &target->where); - return false; - } - - t = true; - if (!same_type_check (pointer, 0, target, 1, true)) - t = false; - /* F2018 C838 explicitly allows an assumed-rank variable as the first - argument of intrinsic inquiry functions. */ - if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank)) - t = false; - if (target->rank > 0) - { - for (i = 0; i < target->rank; i++) - if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR) - { - gfc_error ("Array section with a vector subscript at %L shall not " - "be the target of a pointer", - &target->where); - t = false; - break; - } - } - return t; -} - - -bool -gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) -{ - /* gfc_notify_std would be a waste of time as the return value - is seemingly used only for the generic resolution. The error - will be: Too many arguments. */ - if ((gfc_option.allow_std & GFC_STD_F2008) == 0) - return false; - - return gfc_check_atan2 (y, x); -} - - -bool -gfc_check_atan2 (gfc_expr *y, gfc_expr *x) -{ - if (!type_check (y, 0, BT_REAL)) - return false; - if (!same_type_check (y, 0, x, 1)) - return false; - - return true; -} - - -static bool -gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, - gfc_expr *stat, int stat_no) -{ - if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no)) - return false; - - if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind) - && !(atom->ts.type == BT_LOGICAL - && atom->ts.kind == gfc_atomic_logical_kind)) - { - gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " - "integer of ATOMIC_INT_KIND or a logical of " - "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic); - return false; - } - - if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom)) - { - gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a " - "coarray or coindexed", &atom->where, gfc_current_intrinsic); - return false; - } - - if (atom->ts.type != value->ts.type) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall have the same " - "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name, - gfc_current_intrinsic, &value->where, - gfc_current_intrinsic_arg[atom_no]->name, &atom->where); - return false; - } - - if (stat != NULL) - { - if (!type_check (stat, stat_no, BT_INTEGER)) - return false; - if (!scalar_check (stat, stat_no)) - return false; - if (!variable_check (stat, stat_no, false)) - return false; - if (!kind_value_check (stat, stat_no, gfc_default_integer_kind)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", - gfc_current_intrinsic, &stat->where)) - return false; - } - - return true; -} - - -bool -gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) -{ - if (atom->expr_type == EXPR_FUNCTION - && atom->value.function.isym - && atom->value.function.isym->id == GFC_ISYM_CAF_GET) - atom = atom->value.function.actual->expr; - - if (!gfc_check_vardef_context (atom, false, false, false, NULL)) - { - gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " - "definable", gfc_current_intrinsic, &atom->where); - return false; - } - - return gfc_check_atomic (atom, 0, value, 1, stat, 2); -} - - -bool -gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) -{ - if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) - { - gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " - "integer of ATOMIC_INT_KIND", &atom->where, - gfc_current_intrinsic); - return false; - } - - return gfc_check_atomic_def (atom, value, stat); -} - - -bool -gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) -{ - if (atom->expr_type == EXPR_FUNCTION - && atom->value.function.isym - && atom->value.function.isym->id == GFC_ISYM_CAF_GET) - atom = atom->value.function.actual->expr; - - if (!gfc_check_vardef_context (value, false, false, false, NULL)) - { - gfc_error ("VALUE argument of the %s intrinsic function at %L shall be " - "definable", gfc_current_intrinsic, &value->where); - return false; - } - - return gfc_check_atomic (atom, 1, value, 0, stat, 2); -} - - -bool -gfc_check_image_status (gfc_expr *image, gfc_expr *team) -{ - /* IMAGE has to be a positive, scalar integer. */ - if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0) - || !positive_check (0, image)) - return false; - - if (team) - { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &team->where); - return false; - } - return true; -} - - -bool -gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) -{ - if (team) - { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &team->where); - return false; - } - - if (kind) - { - int k; - - if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1) - || !positive_check (1, kind)) - return false; - - /* Get the kind, reporting error on non-constant or overflow. */ - gfc_current_locus = kind->where; - if (gfc_extract_int (kind, &k, 1)) - return false; - if (gfc_validate_kind (BT_INTEGER, k, true) == -1) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall specify a " - "valid integer kind", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &kind->where); - return false; - } - } - return true; -} - - -bool -gfc_check_get_team (gfc_expr *level) -{ - if (level) - { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &level->where); - return false; - } - return true; -} - - -bool -gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare, - gfc_expr *new_val, gfc_expr *stat) -{ - if (atom->expr_type == EXPR_FUNCTION - && atom->value.function.isym - && atom->value.function.isym->id == GFC_ISYM_CAF_GET) - atom = atom->value.function.actual->expr; - - if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4)) - return false; - - if (!scalar_check (old, 1) || !scalar_check (compare, 2)) - return false; - - if (!same_type_check (atom, 0, old, 1)) - return false; - - if (!same_type_check (atom, 0, compare, 2)) - return false; - - if (!gfc_check_vardef_context (atom, false, false, false, NULL)) - { - gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " - "definable", gfc_current_intrinsic, &atom->where); - return false; - } - - if (!gfc_check_vardef_context (old, false, false, false, NULL)) - { - gfc_error ("OLD argument of the %s intrinsic function at %L shall be " - "definable", gfc_current_intrinsic, &old->where); - return false; - } - - return true; -} - -bool -gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat) -{ - if (event->ts.type != BT_DERIVED - || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE) - { - gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY " - "shall be of type EVENT_TYPE", &event->where); - return false; - } - - if (!scalar_check (event, 0)) - return false; - - if (!gfc_check_vardef_context (count, false, false, false, NULL)) - { - gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " - "shall be definable", &count->where); - return false; - } - - if (!type_check (count, 1, BT_INTEGER)) - return false; - - int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false); - int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); - - if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range) - { - gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " - "shall have at least the range of the default integer", - &count->where); - return false; - } - - if (stat != NULL) - { - if (!type_check (stat, 2, BT_INTEGER)) - return false; - if (!scalar_check (stat, 2)) - return false; - if (!variable_check (stat, 2, false)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", - gfc_current_intrinsic, &stat->where)) - return false; - } - - return true; -} - - -bool -gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old, - gfc_expr *stat) -{ - if (atom->expr_type == EXPR_FUNCTION - && atom->value.function.isym - && atom->value.function.isym->id == GFC_ISYM_CAF_GET) - atom = atom->value.function.actual->expr; - - if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) - { - gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " - "integer of ATOMIC_INT_KIND", &atom->where, - gfc_current_intrinsic); - return false; - } - - if (!gfc_check_atomic (atom, 0, value, 1, stat, 3)) - return false; - - if (!scalar_check (old, 2)) - return false; - - if (!same_type_check (atom, 0, old, 2)) - return false; - - if (!gfc_check_vardef_context (atom, false, false, false, NULL)) - { - gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " - "definable", gfc_current_intrinsic, &atom->where); - return false; - } - - if (!gfc_check_vardef_context (old, false, false, false, NULL)) - { - gfc_error ("OLD argument of the %s intrinsic function at %L shall be " - "definable", gfc_current_intrinsic, &old->where); - return false; - } - - return true; -} - - -/* BESJN and BESYN functions. */ - -bool -gfc_check_besn (gfc_expr *n, gfc_expr *x) -{ - if (!type_check (n, 0, BT_INTEGER)) - return false; - if (n->expr_type == EXPR_CONSTANT) - { - int i; - gfc_extract_int (n, &i); - if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument " - "N at %L", &n->where)) - return false; - } - - if (!type_check (x, 1, BT_REAL)) - return false; - - return true; -} - - -/* Transformational version of the Bessel JN and YN functions. */ - -bool -gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) -{ - if (!type_check (n1, 0, BT_INTEGER)) - return false; - if (!scalar_check (n1, 0)) - return false; - if (!nonnegative_check ("N1", n1)) - return false; - - if (!type_check (n2, 1, BT_INTEGER)) - return false; - if (!scalar_check (n2, 1)) - return false; - if (!nonnegative_check ("N2", n2)) - return false; - - if (!type_check (x, 2, BT_REAL)) - return false; - if (!scalar_check (x, 2)) - return false; - - return true; -} - - -bool -gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) -{ - extern int gfc_max_integer_kind; - - /* If i and j are both BOZ, convert to widest INTEGER. */ - if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ) - { - if (!gfc_boz2int (i, gfc_max_integer_kind)) - return false; - if (!gfc_boz2int (j, gfc_max_integer_kind)) - return false; - } - - /* If i is BOZ and j is integer, convert i to type of j. */ - if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER - && !gfc_boz2int (i, j->ts.kind)) - return false; - - /* If j is BOZ and i is integer, convert j to type of i. */ - if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER - && !gfc_boz2int (j, i->ts.kind)) - return false; - - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (j, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) -{ - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (pos, 1, BT_INTEGER)) - return false; - - if (!nonnegative_check ("pos", pos)) - return false; - - if (!less_than_bitsize1 ("i", i, "pos", pos, false)) - return false; - - return true; -} - - -bool -gfc_check_char (gfc_expr *i, gfc_expr *kind) -{ - if (i->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " - "CHAR intrinsic subprogram"), &i->where)) - return false; - - if (!gfc_boz2int (i, gfc_default_integer_kind)) - return false; - } - - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!kind_check (kind, 1, BT_CHARACTER)) - return false; - - return true; -} - - -bool -gfc_check_chdir (gfc_expr *dir) -{ - if (!type_check (dir, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (dir, 0, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) -{ - if (!type_check (dir, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (dir, 0, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 1, BT_INTEGER)) - return false; - if (!scalar_check (status, 1)) - return false; - - return true; -} - - -bool -gfc_check_chmod (gfc_expr *name, gfc_expr *mode) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!type_check (mode, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (mode, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!type_check (mode, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (mode, 1, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER)) - return false; - - if (!scalar_check (status, 2)) - return false; - - return true; -} - - -bool -gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) -{ - int k; - - /* Check kind first, because it may be needed in conversion of a BOZ. */ - if (kind) - { - if (!kind_check (kind, 2, BT_COMPLEX)) - return false; - gfc_extract_int (kind, &k); - } - else - k = gfc_default_complex_kind; - - if (x->ts.type == BT_BOZ && !gfc_boz2real (x, k)) - return false; - - if (!numeric_check (x, 0)) - return false; - - if (y != NULL) - { - if (y->ts.type == BT_BOZ && !gfc_boz2real (y, k)) - return false; - - if (!numeric_check (y, 1)) - return false; - - if (x->ts.type == BT_COMPLEX) - { - gfc_error ("%qs argument of %qs intrinsic at %L must not be " - "present if % is COMPLEX", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &y->where); - return false; - } - - if (y->ts.type == BT_COMPLEX) - { - gfc_error ("%qs argument of %qs intrinsic at %L must have a type " - "of either REAL or INTEGER", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &y->where); - return false; - } - } - - if (!kind && warn_conversion - && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind) - gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " - "COMPLEX(%d) at %L might lose precision, consider using " - "the KIND argument", gfc_typename (&x->ts), - gfc_default_real_kind, &x->where); - else if (y && !kind && warn_conversion - && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind) - gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " - "COMPLEX(%d) at %L might lose precision, consider using " - "the KIND argument", gfc_typename (&y->ts), - gfc_default_real_kind, &y->where); - return true; -} - - -static bool -check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat, - gfc_expr *errmsg, bool co_reduce) -{ - if (!variable_check (a, 0, false)) - return false; - - if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with " - "INTENT(INOUT)")) - return false; - - /* Fortran 2008, 12.5.2.4, paragraph 18. */ - if (gfc_has_vector_subscript (a)) - { - gfc_error ("Argument % with INTENT(INOUT) at %L of the intrinsic " - "subroutine %s shall not have a vector subscript", - &a->where, gfc_current_intrinsic); - return false; - } - - if (gfc_is_coindexed (a)) - { - gfc_error ("The A argument at %L to the intrinsic %s shall not be " - "coindexed", &a->where, gfc_current_intrinsic); - return false; - } - - if (image_idx != NULL) - { - if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER)) - return false; - if (!scalar_check (image_idx, co_reduce ? 2 : 1)) - return false; - } - - if (stat != NULL) - { - if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER)) - return false; - if (!scalar_check (stat, co_reduce ? 3 : 2)) - return false; - if (!variable_check (stat, co_reduce ? 3 : 2, false)) - return false; - if (stat->ts.kind != 4) - { - gfc_error ("The stat= argument at %L must be a kind=4 integer " - "variable", &stat->where); - return false; - } - } - - if (errmsg != NULL) - { - if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER)) - return false; - if (!scalar_check (errmsg, co_reduce ? 4 : 3)) - return false; - if (!variable_check (errmsg, co_reduce ? 4 : 3, false)) - return false; - if (errmsg->ts.kind != 1) - { - gfc_error ("The errmsg= argument at %L must be a default-kind " - "character variable", &errmsg->where); - return false; - } - } - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", - &a->where); - return false; - } - - return true; -} - - -bool -gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat, - gfc_expr *errmsg) -{ - if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp) - { - gfc_error ("Support for the A argument at %L which is polymorphic A " - "argument or has allocatable components is not yet " - "implemented", &a->where); - return false; - } - return check_co_collective (a, source_image, stat, errmsg, false); -} - - -bool -gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, - gfc_expr *stat, gfc_expr *errmsg) -{ - symbol_attribute attr; - gfc_formal_arglist *formal; - gfc_symbol *sym; - - if (a->ts.type == BT_CLASS) - { - gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", - &a->where); - return false; - } - - if (gfc_expr_attr (a).alloc_comp) - { - gfc_error ("Support for the A argument at %L with allocatable components" - " is not yet implemented", &a->where); - return false; - } - - if (!check_co_collective (a, result_image, stat, errmsg, true)) - return false; - - if (!gfc_resolve_expr (op)) - return false; - - attr = gfc_expr_attr (op); - if (!attr.pure || !attr.function) - { - gfc_error ("OPERATION argument at %L must be a PURE function", - &op->where); - return false; - } - - if (attr.intrinsic) - { - /* None of the intrinsics fulfills the criteria of taking two arguments, - returning the same type and kind as the arguments and being permitted - as actual argument. */ - gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE", - op->symtree->n.sym->name, &op->where); - return false; - } - - if (gfc_is_proc_ptr_comp (op)) - { - gfc_component *comp = gfc_get_proc_ptr_comp (op); - sym = comp->ts.interface; - } - else - sym = op->symtree->n.sym; - - formal = sym->formal; - - if (!formal || !formal->next || formal->next->next) - { - gfc_error ("The function passed as OPERATION at %L shall have two " - "arguments", &op->where); - return false; - } - - if (sym->result->ts.type == BT_UNKNOWN) - gfc_set_default_type (sym->result, 0, NULL); - - if (!gfc_compare_types (&a->ts, &sym->result->ts)) - { - gfc_error ("The A argument at %L has type %s but the function passed as " - "OPERATION at %L returns %s", - &a->where, gfc_typename (a), &op->where, - gfc_typename (&sym->result->ts)); - return false; - } - if (!gfc_compare_types (&a->ts, &formal->sym->ts) - || !gfc_compare_types (&a->ts, &formal->next->sym->ts)) - { - gfc_error ("The function passed as OPERATION at %L has arguments of type " - "%s and %s but shall have type %s", &op->where, - gfc_typename (&formal->sym->ts), - gfc_typename (&formal->next->sym->ts), gfc_typename (a)); - return false; - } - if (op->rank || attr.allocatable || attr.pointer || formal->sym->as - || formal->next->sym->as || formal->sym->attr.allocatable - || formal->next->sym->attr.allocatable || formal->sym->attr.pointer - || formal->next->sym->attr.pointer) - { - gfc_error ("The function passed as OPERATION at %L shall have scalar " - "nonallocatable nonpointer arguments and return a " - "nonallocatable nonpointer scalar", &op->where); - return false; - } - - if (formal->sym->attr.value != formal->next->sym->attr.value) - { - gfc_error ("The function passed as OPERATION at %L shall have the VALUE " - "attribute either for none or both arguments", &op->where); - return false; - } - - if (formal->sym->attr.target != formal->next->sym->attr.target) - { - gfc_error ("The function passed as OPERATION at %L shall have the TARGET " - "attribute either for none or both arguments", &op->where); - return false; - } - - if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous) - { - gfc_error ("The function passed as OPERATION at %L shall have the " - "ASYNCHRONOUS attribute either for none or both arguments", - &op->where); - return false; - } - - if (formal->sym->attr.optional || formal->next->sym->attr.optional) - { - gfc_error ("The function passed as OPERATION at %L shall not have the " - "OPTIONAL attribute for either of the arguments", &op->where); - return false; - } - - if (a->ts.type == BT_CHARACTER) - { - gfc_charlen *cl; - unsigned long actual_size, formal_size1, formal_size2, result_size; - - cl = a->ts.u.cl; - actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; - - cl = formal->sym->ts.u.cl; - formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; - - cl = formal->next->sym->ts.u.cl; - formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; - - cl = sym->ts.u.cl; - result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT - ? mpz_get_ui (cl->length->value.integer) : 0; - - if (actual_size - && ((formal_size1 && actual_size != formal_size1) - || (formal_size2 && actual_size != formal_size2))) - { - gfc_error ("The character length of the A argument at %L and of the " - "arguments of the OPERATION at %L shall be the same", - &a->where, &op->where); - return false; - } - if (actual_size && result_size && actual_size != result_size) - { - gfc_error ("The character length of the A argument at %L and of the " - "function result of the OPERATION at %L shall be the same", - &a->where, &op->where); - return false; - } - } - - return true; -} - - -bool -gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, - gfc_expr *errmsg) -{ - if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL - && a->ts.type != BT_CHARACTER) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " - "integer, real or character", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); - return false; - } - return check_co_collective (a, result_image, stat, errmsg, false); -} - - -bool -gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, - gfc_expr *errmsg) -{ - if (!numeric_check (a, 0)) - return false; - return check_co_collective (a, result_image, stat, errmsg, false); -} - - -bool -gfc_check_complex (gfc_expr *x, gfc_expr *y) -{ - if (!boz_args_check (x, y)) - return false; - - if (x->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" - " intrinsic subprogram"), &x->where)) - { - reset_boz (x); - return false; - } - if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind)) - return false; - if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind)) - return false; - } - - if (y->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" - " intrinsic subprogram"), &y->where)) - { - reset_boz (y); - return false; - } - if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind)) - return false; - if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind)) - return false; - } - - if (!int_or_real_check (x, 0)) - return false; - if (!scalar_check (x, 0)) - return false; - - if (!int_or_real_check (y, 1)) - return false; - if (!scalar_check (y, 1)) - return false; - - return true; -} - - -bool -gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) -{ - if (!logical_array_check (mask, 0)) - return false; - if (!dim_check (dim, 1, false)) - return false; - if (!dim_rank_check (dim, mask, 0)) - return false; - if (!kind_check (kind, 2, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - return true; -} - - -bool -gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) -{ - if (!array_check (array, 0)) - return false; - - if (!type_check (shift, 1, BT_INTEGER)) - return false; - - if (!dim_check (dim, 2, true)) - return false; - - if (!dim_rank_check (dim, array, false)) - return false; - - if (array->rank == 1 || shift->rank == 0) - { - if (!scalar_check (shift, 1)) - return false; - } - else if (shift->rank == array->rank - 1) - { - int d; - if (!dim) - d = 1; - else if (dim->expr_type == EXPR_CONSTANT) - gfc_extract_int (dim, &d); - else - d = -1; - - if (d > 0) - { - int i, j; - for (i = 0, j = 0; i < array->rank; i++) - if (i != d - 1) - { - if (!identical_dimen_shape (array, i, shift, j)) - { - gfc_error ("%qs argument of %qs intrinsic at %L has " - "invalid shape in dimension %d (%ld/%ld)", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &shift->where, i + 1, - mpz_get_si (array->shape[i]), - mpz_get_si (shift->shape[j])); - return false; - } - - j += 1; - } - } - } - else - { - gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " - "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &shift->where, array->rank - 1); - return false; - } - - return true; -} - - -bool -gfc_check_ctime (gfc_expr *time) -{ - if (!scalar_check (time, 0)) - return false; - - if (!type_check (time, 0, BT_INTEGER)) - return false; - - return true; -} - - -bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x) -{ - if (!double_check (y, 0) || !double_check (x, 1)) - return false; - - return true; -} - -bool -gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) -{ - if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind)) - return false; - - if (!numeric_check (x, 0)) - return false; - - if (y != NULL) - { - if (y->ts.type == BT_BOZ && !gfc_boz2real (y, gfc_default_double_kind)) - return false; - - if (!numeric_check (y, 1)) - return false; - - if (x->ts.type == BT_COMPLEX) - { - gfc_error ("%qs argument of %qs intrinsic at %L must not be " - "present if % is COMPLEX", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &y->where); - return false; - } - - if (y->ts.type == BT_COMPLEX) - { - gfc_error ("%qs argument of %qs intrinsic at %L must have a type " - "of either REAL or INTEGER", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &y->where); - return false; - } - } - - return true; -} - - -bool -gfc_check_dble (gfc_expr *x) -{ - if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind)) - return false; - - if (!numeric_check (x, 0)) - return false; - - return true; -} - - -bool -gfc_check_digits (gfc_expr *x) -{ - if (!int_or_real_check (x, 0)) - return false; - - return true; -} - - -bool -gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) -{ - switch (vector_a->ts.type) - { - case BT_LOGICAL: - if (!type_check (vector_b, 1, BT_LOGICAL)) - return false; - break; - - case BT_INTEGER: - case BT_REAL: - case BT_COMPLEX: - if (!numeric_check (vector_b, 1)) - return false; - break; - - default: - gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &vector_a->where); - return false; - } - - if (!rank_check (vector_a, 0, 1)) - return false; - - if (!rank_check (vector_b, 1, 1)) - return false; - - if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) - { - gfc_error ("Different shape for arguments %qs and %qs at %L for " - "intrinsic %", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[1]->name, &vector_a->where); - return false; - } - - return true; -} - - -bool -gfc_check_dprod (gfc_expr *x, gfc_expr *y) -{ - if (!type_check (x, 0, BT_REAL) - || !type_check (y, 1, BT_REAL)) - return false; - - if (x->ts.kind != gfc_default_real_kind) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be default " - "real", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &x->where); - return false; - } - - if (y->ts.kind != gfc_default_real_kind) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be default " - "real", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &y->where); - return false; - } - - return true; -} - -bool -gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) -{ - /* i and j cannot both be BOZ literal constants. */ - if (!boz_args_check (i, j)) - return false; - - /* If i is BOZ and j is integer, convert i to type of j. If j is not - an integer, clear the BOZ; otherwise, check that i is an integer. */ - if (i->ts.type == BT_BOZ) - { - if (j->ts.type != BT_INTEGER) - reset_boz (i); - else if (!gfc_boz2int (i, j->ts.kind)) - return false; - } - else if (!type_check (i, 0, BT_INTEGER)) - { - if (j->ts.type == BT_BOZ) - reset_boz (j); - return false; - } - - /* If j is BOZ and i is integer, convert j to type of i. If i is not - an integer, clear the BOZ; otherwise, check that i is an integer. */ - if (j->ts.type == BT_BOZ) - { - if (i->ts.type != BT_INTEGER) - reset_boz (j); - else if (!gfc_boz2int (j, i->ts.kind)) - return false; - } - else if (!type_check (j, 1, BT_INTEGER)) - return false; - - if (!same_type_check (i, 0, j, 1)) - return false; - - if (!type_check (shift, 2, BT_INTEGER)) - return false; - - if (!nonnegative_check ("SHIFT", shift)) - return false; - - if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) - return false; - - return true; -} - - -bool -gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, - gfc_expr *dim) -{ - int d; - - if (!array_check (array, 0)) - return false; - - if (!type_check (shift, 1, BT_INTEGER)) - return false; - - if (!dim_check (dim, 3, true)) - return false; - - if (!dim_rank_check (dim, array, false)) - return false; - - if (!dim) - d = 1; - else if (dim->expr_type == EXPR_CONSTANT) - gfc_extract_int (dim, &d); - else - d = -1; - - if (array->rank == 1 || shift->rank == 0) - { - if (!scalar_check (shift, 1)) - return false; - } - else if (shift->rank == array->rank - 1) - { - if (d > 0) - { - int i, j; - for (i = 0, j = 0; i < array->rank; i++) - if (i != d - 1) - { - if (!identical_dimen_shape (array, i, shift, j)) - { - gfc_error ("%qs argument of %qs intrinsic at %L has " - "invalid shape in dimension %d (%ld/%ld)", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &shift->where, i + 1, - mpz_get_si (array->shape[i]), - mpz_get_si (shift->shape[j])); - return false; - } - - j += 1; - } - } - } - else - { - gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " - "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &shift->where, array->rank - 1); - return false; - } - - if (boundary != NULL) - { - if (!same_type_check (array, 0, boundary, 2)) - return false; - - /* Reject unequal string lengths and emit a better error message than - gfc_check_same_strlen would. */ - if (array->ts.type == BT_CHARACTER) - { - ssize_t len_a, len_b; - - len_a = gfc_var_strlen (array); - len_b = gfc_var_strlen (boundary); - if (len_a != -1 && len_b != -1 && len_a != len_b) - { - gfc_error ("%qs must be of same type and kind as %qs at %L in %qs", - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic_arg[0]->name, - &boundary->where, gfc_current_intrinsic); - return false; - } - } - - if (array->rank == 1 || boundary->rank == 0) - { - if (!scalar_check (boundary, 2)) - return false; - } - else if (boundary->rank == array->rank - 1) - { - if (d > 0) - { - int i,j; - for (i = 0, j = 0; i < array->rank; i++) - { - if (i != d - 1) - { - if (!identical_dimen_shape (array, i, boundary, j)) - { - gfc_error ("%qs argument of %qs intrinsic at %L has " - "invalid shape in dimension %d (%ld/%ld)", - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic, &shift->where, i+1, - mpz_get_si (array->shape[i]), - mpz_get_si (boundary->shape[j])); - return false; - } - j += 1; - } - } - } - } - else - { - gfc_error ("%qs argument of intrinsic %qs at %L of must have " - "rank %d or be a scalar", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &shift->where, array->rank - 1); - return false; - } - } - else - { - switch (array->ts.type) - { - case BT_INTEGER: - case BT_LOGICAL: - case BT_REAL: - case BT_COMPLEX: - case BT_CHARACTER: - break; - - default: - gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs " - "of type %qs", gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic, &array->where, - gfc_current_intrinsic_arg[0]->name, - gfc_typename (array)); - return false; - } - } - - return true; -} - - -bool -gfc_check_float (gfc_expr *a) -{ - if (a->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the" - " FLOAT intrinsic subprogram"), &a->where)) - { - reset_boz (a); - return false; - } - if (!gfc_boz2int (a, gfc_default_integer_kind)) - return false; - } - - if (!type_check (a, 0, BT_INTEGER)) - return false; - - if ((a->ts.kind != gfc_default_integer_kind) - && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER " - "kind argument to %s intrinsic at %L", - gfc_current_intrinsic, &a->where)) - return false; - - return true; -} - -/* A single complex argument. */ - -bool -gfc_check_fn_c (gfc_expr *a) -{ - if (!type_check (a, 0, BT_COMPLEX)) - return false; - - return true; -} - - -/* A single real argument. */ - -bool -gfc_check_fn_r (gfc_expr *a) -{ - if (!type_check (a, 0, BT_REAL)) - return false; - - return true; -} - -/* A single double argument. */ - -bool -gfc_check_fn_d (gfc_expr *a) -{ - if (!double_check (a, 0)) - return false; - - return true; -} - -/* A single real or complex argument. */ - -bool -gfc_check_fn_rc (gfc_expr *a) -{ - if (!real_or_complex_check (a, 0)) - return false; - - return true; -} - - -bool -gfc_check_fn_rc2008 (gfc_expr *a) -{ - if (!real_or_complex_check (a, 0)) - return false; - - if (a->ts.type == BT_COMPLEX - && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs " - "of %qs intrinsic at %L", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where)) - return false; - - return true; -} - - -bool -gfc_check_fnum (gfc_expr *unit) -{ - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - return true; -} - - -bool -gfc_check_huge (gfc_expr *x) -{ - if (!int_or_real_check (x, 0)) - return false; - - return true; -} - - -bool -gfc_check_hypot (gfc_expr *x, gfc_expr *y) -{ - if (!type_check (x, 0, BT_REAL)) - return false; - if (!same_type_check (x, 0, y, 1)) - return false; - - return true; -} - - -/* Check that the single argument is an integer. */ - -bool -gfc_check_i (gfc_expr *i) -{ - if (!type_check (i, 0, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) -{ - /* i and j cannot both be BOZ literal constants. */ - if (!boz_args_check (i, j)) - return false; - - /* If i is BOZ and j is integer, convert i to type of j. */ - if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER - && !gfc_boz2int (i, j->ts.kind)) - return false; - - /* If j is BOZ and i is integer, convert j to type of i. */ - if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER - && !gfc_boz2int (j, i->ts.kind)) - return false; - - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (j, 1, BT_INTEGER)) - return false; - - if (i->ts.kind != j->ts.kind) - { - gfc_error ("Arguments of %qs have different kind type parameters " - "at %L", gfc_current_intrinsic, &i->where); - return false; - } - - return true; -} - - -bool -gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) -{ - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (pos, 1, BT_INTEGER)) - return false; - - if (!type_check (len, 2, BT_INTEGER)) - return false; - - if (!nonnegative_check ("pos", pos)) - return false; - - if (!nonnegative_check ("len", len)) - return false; - - if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len)) - return false; - - return true; -} - - -bool -gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) -{ - int i; - - if (!type_check (c, 0, BT_CHARACTER)) - return false; - - if (!kind_check (kind, 1, BT_INTEGER)) - return false; - - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING) - { - gfc_expr *start; - gfc_expr *end; - gfc_ref *ref; - - /* Substring references don't have the charlength set. */ - ref = c->ref; - while (ref && ref->type != REF_SUBSTRING) - ref = ref->next; - - gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); - - if (!ref) - { - /* Check that the argument is length one. Non-constant lengths - can't be checked here, so assume they are ok. */ - if (c->ts.u.cl && c->ts.u.cl->length) - { - /* If we already have a length for this expression then use it. */ - if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return true; - i = mpz_get_si (c->ts.u.cl->length->value.integer); - } - else - return true; - } - else - { - start = ref->u.ss.start; - end = ref->u.ss.end; - - gcc_assert (start); - if (end == NULL || end->expr_type != EXPR_CONSTANT - || start->expr_type != EXPR_CONSTANT) - return true; - - i = mpz_get_si (end->value.integer) + 1 - - mpz_get_si (start->value.integer); - } - } - else - return true; - - if (i != 1) - { - gfc_error ("Argument of %s at %L must be of length one", - gfc_current_intrinsic, &c->where); - return false; - } - - return true; -} - - -bool -gfc_check_idnint (gfc_expr *a) -{ - if (!double_check (a, 0)) - return false; - - return true; -} - - -bool -gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, - gfc_expr *kind) -{ - if (!type_check (string, 0, BT_CHARACTER) - || !type_check (substring, 1, BT_CHARACTER)) - return false; - - if (back != NULL && !type_check (back, 2, BT_LOGICAL)) - return false; - - if (!kind_check (kind, 3, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - if (string->ts.kind != substring->ts.kind) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be the same " - "kind as %qs", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &substring->where, - gfc_current_intrinsic_arg[0]->name); - return false; - } - - return true; -} - - -bool -gfc_check_int (gfc_expr *x, gfc_expr *kind) -{ - /* BOZ is dealt within simplify_int*. */ - if (x->ts.type == BT_BOZ) - return true; - - if (!numeric_check (x, 0)) - return false; - - if (!kind_check (kind, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_intconv (gfc_expr *x) -{ - if (strcmp (gfc_current_intrinsic, "short") == 0 - || strcmp (gfc_current_intrinsic, "long") == 0) - { - gfc_error ("%qs intrinsic subprogram at %L has been removed. " - "Use INT intrinsic subprogram.", gfc_current_intrinsic, - &x->where); - return false; - } - - /* BOZ is dealt within simplify_int*. */ - if (x->ts.type == BT_BOZ) - return true; - - if (!numeric_check (x, 0)) - return false; - - return true; -} - -bool -gfc_check_ishft (gfc_expr *i, gfc_expr *shift) -{ - if (!type_check (i, 0, BT_INTEGER) - || !type_check (shift, 1, BT_INTEGER)) - return false; - - if (!less_than_bitsize1 ("I", i, NULL, shift, true)) - return false; - - return true; -} - - -bool -gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) -{ - if (!type_check (i, 0, BT_INTEGER) - || !type_check (shift, 1, BT_INTEGER)) - return false; - - if (size != NULL) - { - int i2, i3; - - if (!type_check (size, 2, BT_INTEGER)) - return false; - - if (!less_than_bitsize1 ("I", i, "SIZE", size, true)) - return false; - - if (size->expr_type == EXPR_CONSTANT) - { - gfc_extract_int (size, &i3); - if (i3 <= 0) - { - gfc_error ("SIZE at %L must be positive", &size->where); - return false; - } - - if (shift->expr_type == EXPR_CONSTANT) - { - gfc_extract_int (shift, &i2); - if (i2 < 0) - i2 = -i2; - - if (i2 > i3) - { - gfc_error ("The absolute value of SHIFT at %L must be less " - "than or equal to SIZE at %L", &shift->where, - &size->where); - return false; - } - } - } - } - else if (!less_than_bitsize1 ("I", i, NULL, shift, true)) - return false; - - return true; -} - - -bool -gfc_check_kill (gfc_expr *pid, gfc_expr *sig) -{ - if (!type_check (pid, 0, BT_INTEGER)) - return false; - - if (!scalar_check (pid, 0)) - return false; - - if (!type_check (sig, 1, BT_INTEGER)) - return false; - - if (!scalar_check (sig, 1)) - return false; - - return true; -} - - -bool -gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) -{ - if (!type_check (pid, 0, BT_INTEGER)) - return false; - - if (!scalar_check (pid, 0)) - return false; - - if (!type_check (sig, 1, BT_INTEGER)) - return false; - - if (!scalar_check (sig, 1)) - return false; - - if (status) - { - if (!type_check (status, 2, BT_INTEGER)) - return false; - - if (!scalar_check (status, 2)) - return false; - - if (status->expr_type != EXPR_VARIABLE) - { - gfc_error ("STATUS at %L shall be an INTENT(OUT) variable", - &status->where); - return false; - } - - if (status->expr_type == EXPR_VARIABLE - && status->symtree && status->symtree->n.sym - && status->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("%qs at %L shall be an INTENT(OUT) variable", - status->symtree->name, &status->where); - return false; - } - } - - return true; -} - - -bool -gfc_check_kind (gfc_expr *x) -{ - if (gfc_invalid_null_arg (x)) - return false; - - if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be of " - "intrinsic type", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &x->where); - return false; - } - if (x->ts.type == BT_PROCEDURE) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &x->where); - return false; - } - - return true; -} - - -bool -gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - if (!array_check (array, 0)) - return false; - - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_rank_check (dim, array, 1)) - return false; - - if (!kind_check (kind, 2, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - return true; -} - - -bool -gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return false; - } - - if (!coarray_check (coarray, 0)) - return false; - - if (dim != NULL) - { - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_corank_check (dim, coarray)) - return false; - } - - if (!kind_check (kind, 2, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) -{ - if (!type_check (s, 0, BT_CHARACTER)) - return false; - - if (gfc_invalid_null_arg (s)) - return false; - - if (!kind_check (kind, 1, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - return true; -} - - -bool -gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) -{ - if (!type_check (a, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (a, 0, gfc_default_character_kind)) - return false; - - if (!type_check (b, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (b, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_link (gfc_expr *path1, gfc_expr *path2) -{ - if (!type_check (path1, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (path1, 0, gfc_default_character_kind)) - return false; - - if (!type_check (path2, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (path2, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) -{ - if (!type_check (path1, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (path1, 0, gfc_default_character_kind)) - return false; - - if (!type_check (path2, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (path2, 0, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER)) - return false; - - if (!scalar_check (status, 2)) - return false; - - return true; -} - - -bool -gfc_check_loc (gfc_expr *expr) -{ - return variable_check (expr, 0, true); -} - - -bool -gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) -{ - if (!type_check (path1, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (path1, 0, gfc_default_character_kind)) - return false; - - if (!type_check (path2, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (path2, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) -{ - if (!type_check (path1, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (path1, 0, gfc_default_character_kind)) - return false; - - if (!type_check (path2, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (path2, 1, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER)) - return false; - - if (!scalar_check (status, 2)) - return false; - - return true; -} - - -bool -gfc_check_logical (gfc_expr *a, gfc_expr *kind) -{ - if (!type_check (a, 0, BT_LOGICAL)) - return false; - if (!kind_check (kind, 1, BT_LOGICAL)) - return false; - - return true; -} - - -/* Min/max family. */ - -static bool -min_max_args (gfc_actual_arglist *args) -{ - gfc_actual_arglist *arg; - int i, j, nargs, *nlabels, nlabelless; - bool a1 = false, a2 = false; - - if (args == NULL || args->next == NULL) - { - gfc_error ("Intrinsic %qs at %L must have at least two arguments", - gfc_current_intrinsic, gfc_current_intrinsic_where); - return false; - } - - if (!args->name) - a1 = true; - - if (!args->next->name) - a2 = true; - - nargs = 0; - for (arg = args; arg; arg = arg->next) - if (arg->name) - nargs++; - - if (nargs == 0) - return true; - - /* Note: Having a keywordless argument after an "arg=" is checked before. */ - nlabelless = 0; - nlabels = XALLOCAVEC (int, nargs); - for (arg = args, i = 0; arg; arg = arg->next, i++) - if (arg->name) - { - int n; - char *endp; - - if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9') - goto unknown; - n = strtol (&arg->name[1], &endp, 10); - if (endp[0] != '\0') - goto unknown; - if (n <= 0) - goto unknown; - if (n <= nlabelless) - goto duplicate; - nlabels[i] = n; - if (n == 1) - a1 = true; - if (n == 2) - a2 = true; - } - else - nlabelless++; - - if (!a1 || !a2) - { - gfc_error ("Missing %qs argument to the %s intrinsic at %L", - !a1 ? "a1" : "a2", gfc_current_intrinsic, - gfc_current_intrinsic_where); - return false; - } - - /* Check for duplicates. */ - for (i = 0; i < nargs; i++) - for (j = i + 1; j < nargs; j++) - if (nlabels[i] == nlabels[j]) - goto duplicate; - - return true; - -duplicate: - gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name, - &arg->expr->where, gfc_current_intrinsic); - return false; - -unknown: - gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name, - &arg->expr->where, gfc_current_intrinsic); - return false; -} - - -static bool -check_rest (bt type, int kind, gfc_actual_arglist *arglist) -{ - gfc_actual_arglist *arg, *tmp; - gfc_expr *x; - int m, n; - - if (!min_max_args (arglist)) - return false; - - for (arg = arglist, n=1; arg; arg = arg->next, n++) - { - x = arg->expr; - if (x->ts.type != type || x->ts.kind != kind) - { - if (x->ts.type == type) - { - if (x->ts.type == BT_CHARACTER) - { - gfc_error ("Different character kinds at %L", &x->where); - return false; - } - if (!gfc_notify_std (GFC_STD_GNU, "Different type " - "kinds at %L", &x->where)) - return false; - } - else - { - gfc_error ("% argument of %qs intrinsic at %L must be " - "%s(%d)", n, gfc_current_intrinsic, &x->where, - gfc_basic_typename (type), kind); - return false; - } - } - - for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) - if (!gfc_check_conformance (tmp->expr, x, - _("arguments 'a%d' and 'a%d' for " - "intrinsic '%s'"), m, n, - gfc_current_intrinsic)) - return false; - } - - return true; -} - - -bool -gfc_check_min_max (gfc_actual_arglist *arg) -{ - gfc_expr *x; - - if (!min_max_args (arg)) - return false; - - x = arg->expr; - - if (x->ts.type == BT_CHARACTER) - { - if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with CHARACTER argument at %L", - gfc_current_intrinsic, &x->where)) - return false; - } - else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) - { - gfc_error ("% argument of %qs intrinsic at %L must be INTEGER, " - "REAL or CHARACTER", gfc_current_intrinsic, &x->where); - return false; - } - - return check_rest (x->ts.type, x->ts.kind, arg); -} - - -bool -gfc_check_min_max_integer (gfc_actual_arglist *arg) -{ - return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); -} - - -bool -gfc_check_min_max_real (gfc_actual_arglist *arg) -{ - return check_rest (BT_REAL, gfc_default_real_kind, arg); -} - - -bool -gfc_check_min_max_double (gfc_actual_arglist *arg) -{ - return check_rest (BT_REAL, gfc_default_double_kind, arg); -} - - -/* End of min/max family. */ - -bool -gfc_check_malloc (gfc_expr *size) -{ - if (!type_check (size, 0, BT_INTEGER)) - return false; - - if (!scalar_check (size, 0)) - return false; - - return true; -} - - -bool -gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) -{ - if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &matrix_a->where); - return false; - } - - if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " - "or LOGICAL", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &matrix_b->where); - return false; - } - - if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) - || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)) - { - gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)", - gfc_current_intrinsic, &matrix_a->where, - gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); - return false; - } - - switch (matrix_a->rank) - { - case 1: - if (!rank_check (matrix_b, 1, 2)) - return false; - /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ - if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) - { - gfc_error ("Different shape on dimension 1 for arguments %qs " - "and %qs at %L for intrinsic matmul", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[1]->name, &matrix_a->where); - return false; - } - break; - - case 2: - if (matrix_b->rank != 2) - { - if (!rank_check (matrix_b, 1, 1)) - return false; - } - /* matrix_b has rank 1 or 2 here. Common check for the cases - - matrix_a has shape (n,m) and matrix_b has shape (m, k) - - matrix_a has shape (n,m) and matrix_b has shape (m). */ - if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0)) - { - gfc_error ("Different shape on dimension 2 for argument %qs and " - "dimension 1 for argument %qs at %L for intrinsic " - "matmul", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[1]->name, &matrix_a->where); - return false; - } - break; - - default: - gfc_error ("%qs argument of %qs intrinsic at %L must be of rank " - "1 or 2", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &matrix_a->where); - return false; - } - - return true; -} - - -/* Whoever came up with this interface was probably on something. - The possibilities for the occupation of the second and third - parameters are: - - Arg #2 Arg #3 - NULL NULL - DIM NULL - MASK NULL - NULL MASK minloc(array, mask=m) - DIM MASK - - I.e. in the case of minloc(array,mask), mask will be in the second - position of the argument list and we'll have to fix that up. Also, - add the BACK argument if that isn't present. */ - -bool -gfc_check_minloc_maxloc (gfc_actual_arglist *ap) -{ - gfc_expr *a, *m, *d, *k, *b; - - a = ap->expr; - if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0)) - return false; - - d = ap->next->expr; - m = ap->next->next->expr; - k = ap->next->next->next->expr; - b = ap->next->next->next->next->expr; - - if (b) - { - if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4)) - return false; - } - else - { - b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); - ap->next->next->next->next->expr = b; - } - - if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL - && ap->next->name == NULL) - { - m = d; - d = NULL; - ap->next->expr = NULL; - ap->next->next->expr = m; - } - - if (!dim_check (d, 1, false)) - return false; - - if (!dim_rank_check (d, a, 0)) - return false; - - if (m != NULL && !type_check (m, 2, BT_LOGICAL)) - return false; - - if (m != NULL - && !gfc_check_conformance (a, m, - _("arguments '%s' and '%s' for intrinsic %s"), - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic)) - return false; - - if (!kind_check (k, 1, BT_INTEGER)) - return false; - - return true; -} - -/* Check function for findloc. Mostly like gfc_check_minloc_maxloc - above, with the additional "value" argument. */ - -bool -gfc_check_findloc (gfc_actual_arglist *ap) -{ - gfc_expr *a, *v, *m, *d, *k, *b; - bool a1, v1; - - a = ap->expr; - if (!intrinsic_type_check (a, 0) || !array_check (a, 0)) - return false; - - v = ap->next->expr; - if (!intrinsic_type_check (v, 1) || !scalar_check (v,1)) - return false; - - /* Check if the type are both logical. */ - a1 = a->ts.type == BT_LOGICAL; - v1 = v->ts.type == BT_LOGICAL; - if ((a1 && !v1) || (!a1 && v1)) - goto incompat; - - /* Check if the type are both character. */ - a1 = a->ts.type == BT_CHARACTER; - v1 = v->ts.type == BT_CHARACTER; - if ((a1 && !v1) || (!a1 && v1)) - goto incompat; - - /* Check the kind of the characters argument match. */ - if (a1 && v1 && a->ts.kind != v->ts.kind) - goto incompat; - - d = ap->next->next->expr; - m = ap->next->next->next->expr; - k = ap->next->next->next->next->expr; - b = ap->next->next->next->next->next->expr; - - if (b) - { - if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4)) - return false; - } - else - { - b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); - ap->next->next->next->next->next->expr = b; - } - - if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL - && ap->next->name == NULL) - { - m = d; - d = NULL; - ap->next->next->expr = NULL; - ap->next->next->next->expr = m; - } - - if (!dim_check (d, 2, false)) - return false; - - if (!dim_rank_check (d, a, 0)) - return false; - - if (m != NULL && !type_check (m, 3, BT_LOGICAL)) - return false; - - if (m != NULL - && !gfc_check_conformance (a, m, - _("arguments '%s' and '%s' for intrinsic %s"), - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[3]->name, - gfc_current_intrinsic)) - return false; - - if (!kind_check (k, 1, BT_INTEGER)) - return false; - - return true; - -incompat: - gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " - "conformance to argument %qs at %L", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where, - gfc_current_intrinsic_arg[1]->name, &v->where); - return false; -} - - -/* Similar to minloc/maxloc, the argument list might need to be - reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The - difference is that MINLOC/MAXLOC take an additional KIND argument. - The possibilities are: - - Arg #2 Arg #3 - NULL NULL - DIM NULL - MASK NULL - NULL MASK minval(array, mask=m) - DIM MASK - - I.e. in the case of minval(array,mask), mask will be in the second - position of the argument list and we'll have to fix that up. */ - -static bool -check_reduction (gfc_actual_arglist *ap) -{ - gfc_expr *a, *m, *d; - - a = ap->expr; - d = ap->next->expr; - m = ap->next->next->expr; - - if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL - && ap->next->name == NULL) - { - m = d; - d = NULL; - ap->next->expr = NULL; - ap->next->next->expr = m; - } - - if (!dim_check (d, 1, false)) - return false; - - if (!dim_rank_check (d, a, 0)) - return false; - - if (m != NULL && !type_check (m, 2, BT_LOGICAL)) - return false; - - if (m != NULL - && !gfc_check_conformance (a, m, - _("arguments '%s' and '%s' for intrinsic %s"), - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic)) - return false; - - return true; -} - - -bool -gfc_check_minval_maxval (gfc_actual_arglist *ap) -{ - if (!int_or_real_or_char_check_f2003 (ap->expr, 0) - || !array_check (ap->expr, 0)) - return false; - - return check_reduction (ap); -} - - -bool -gfc_check_product_sum (gfc_actual_arglist *ap) -{ - if (!numeric_check (ap->expr, 0) - || !array_check (ap->expr, 0)) - return false; - - return check_reduction (ap); -} - - -/* For IANY, IALL and IPARITY. */ - -bool -gfc_check_mask (gfc_expr *i, gfc_expr *kind) -{ - int k; - - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!nonnegative_check ("I", i)) - return false; - - if (!kind_check (kind, 1, BT_INTEGER)) - return false; - - if (kind) - gfc_extract_int (kind, &k); - else - k = gfc_default_integer_kind; - - if (!less_than_bitsizekind ("I", i, k)) - return false; - - return true; -} - - -bool -gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) -{ - if (ap->expr->ts.type != BT_INTEGER) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &ap->expr->where); - return false; - } - - if (!array_check (ap->expr, 0)) - return false; - - return check_reduction (ap); -} - - -bool -gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) -{ - if (gfc_invalid_null_arg (tsource)) - return false; - - if (gfc_invalid_null_arg (fsource)) - return false; - - if (!same_type_check (tsource, 0, fsource, 1)) - return false; - - if (!type_check (mask, 2, BT_LOGICAL)) - return false; - - if (tsource->ts.type == BT_CHARACTER) - return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic"); - - return true; -} - - -bool -gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) -{ - /* i and j cannot both be BOZ literal constants. */ - if (!boz_args_check (i, j)) - return false; - - /* If i is BOZ and j is integer, convert i to type of j. */ - if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER - && !gfc_boz2int (i, j->ts.kind)) - return false; - - /* If j is BOZ and i is integer, convert j to type of i. */ - if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER - && !gfc_boz2int (j, i->ts.kind)) - return false; - - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (j, 1, BT_INTEGER)) - return false; - - if (!same_type_check (i, 0, j, 1)) - return false; - - if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind)) - return false; - - if (!type_check (mask, 2, BT_INTEGER)) - return false; - - if (!same_type_check (i, 0, mask, 2)) - return false; - - return true; -} - - -bool -gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) -{ - if (!variable_check (from, 0, false)) - return false; - if (!allocatable_check (from, 0)) - return false; - if (gfc_is_coindexed (from)) - { - gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be " - "coindexed", &from->where); - return false; - } - - if (!variable_check (to, 1, false)) - return false; - if (!allocatable_check (to, 1)) - return false; - if (gfc_is_coindexed (to)) - { - gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be " - "coindexed", &to->where); - return false; - } - - if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) - { - gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " - "polymorphic if FROM is polymorphic", - &to->where); - return false; - } - - if (!same_type_check (to, 1, from, 0)) - return false; - - if (to->rank != from->rank) - { - gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " - "must have the same rank %d/%d", &to->where, from->rank, - to->rank); - return false; - } - - /* IR F08/0040; cf. 12-006A. */ - if (gfc_get_corank (to) != gfc_get_corank (from)) - { - gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " - "must have the same corank %d/%d", &to->where, - gfc_get_corank (from), gfc_get_corank (to)); - return false; - } - - /* This is based losely on F2003 12.4.1.7. It is intended to prevent - the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1 - and cmp2 are allocatable. After the allocation is transferred, - the 'to' chain is broken by the nullification of the 'from'. A bit - of reflection reveals that this can only occur for derived types - with recursive allocatable components. */ - if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE - && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name)) - { - gfc_ref *to_ref, *from_ref; - to_ref = to->ref; - from_ref = from->ref; - bool aliasing = true; - - for (; from_ref && to_ref; - from_ref = from_ref->next, to_ref = to_ref->next) - { - if (to_ref->type != from->ref->type) - aliasing = false; - else if (to_ref->type == REF_ARRAY - && to_ref->u.ar.type != AR_FULL - && from_ref->u.ar.type != AR_FULL) - /* Play safe; assume sections and elements are different. */ - aliasing = false; - else if (to_ref->type == REF_COMPONENT - && to_ref->u.c.component != from_ref->u.c.component) - aliasing = false; - - if (!aliasing) - break; - } - - if (aliasing) - { - gfc_error ("The FROM and TO arguments at %L violate aliasing " - "restrictions (F2003 12.4.1.7)", &to->where); - return false; - } - } - - /* CLASS arguments: Make sure the vtab of from is present. */ - if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from)) - gfc_find_vtab (&from->ts); - - return true; -} - - -bool -gfc_check_nearest (gfc_expr *x, gfc_expr *s) -{ - if (!type_check (x, 0, BT_REAL)) - return false; - - if (!type_check (s, 1, BT_REAL)) - return false; - - if (s->expr_type == EXPR_CONSTANT) - { - if (mpfr_sgn (s->value.real) == 0) - { - gfc_error ("Argument % of NEAREST at %L shall not be zero", - &s->where); - return false; - } - } - - return true; -} - - -bool -gfc_check_new_line (gfc_expr *a) -{ - if (!type_check (a, 0, BT_CHARACTER)) - return false; - - return true; -} - - -bool -gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) -{ - if (!type_check (array, 0, BT_REAL)) - return false; - - if (!array_check (array, 0)) - return false; - - if (!dim_rank_check (dim, array, false)) - return false; - - return true; -} - -bool -gfc_check_null (gfc_expr *mold) -{ - symbol_attribute attr; - - if (mold == NULL) - return true; - - if (!variable_check (mold, 0, true)) - return false; - - attr = gfc_variable_attr (mold, NULL); - - if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, " - "ALLOCATABLE or procedure pointer", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &mold->where); - return false; - } - - if (attr.allocatable - && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " - "allocatable MOLD at %L", &mold->where)) - return false; - - /* F2008, C1242. */ - if (gfc_is_coindexed (mold)) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be " - "coindexed", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &mold->where); - return false; - } - - return true; -} - - -bool -gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) -{ - if (!array_check (array, 0)) - return false; - - if (!type_check (mask, 1, BT_LOGICAL)) - return false; - - if (!gfc_check_conformance (array, mask, - _("arguments '%s' and '%s' for intrinsic '%s'"), - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic)) - return false; - - if (vector != NULL) - { - mpz_t array_size, vector_size; - bool have_array_size, have_vector_size; - - if (!same_type_check (array, 0, vector, 2)) - return false; - - if (!rank_check (vector, 2, 1)) - return false; - - /* VECTOR requires at least as many elements as MASK - has .TRUE. values. */ - have_array_size = gfc_array_size(array, &array_size); - have_vector_size = gfc_array_size(vector, &vector_size); - - if (have_vector_size - && (mask->expr_type == EXPR_ARRAY - || (mask->expr_type == EXPR_CONSTANT - && have_array_size))) - { - int mask_true_values = 0; - - if (mask->expr_type == EXPR_ARRAY) - { - gfc_constructor *mask_ctor; - mask_ctor = gfc_constructor_first (mask->value.constructor); - while (mask_ctor) - { - if (mask_ctor->expr->expr_type != EXPR_CONSTANT) - { - mask_true_values = 0; - break; - } - - if (mask_ctor->expr->value.logical) - mask_true_values++; - - mask_ctor = gfc_constructor_next (mask_ctor); - } - } - else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) - mask_true_values = mpz_get_si (array_size); - - if (mpz_get_si (vector_size) < mask_true_values) - { - gfc_error ("%qs argument of %qs intrinsic at %L must " - "provide at least as many elements as there " - "are .TRUE. values in %qs (%ld/%d)", - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic, &vector->where, - gfc_current_intrinsic_arg[1]->name, - mpz_get_si (vector_size), mask_true_values); - return false; - } - } - - if (have_array_size) - mpz_clear (array_size); - if (have_vector_size) - mpz_clear (vector_size); - } - - return true; -} - - -bool -gfc_check_parity (gfc_expr *mask, gfc_expr *dim) -{ - if (!type_check (mask, 0, BT_LOGICAL)) - return false; - - if (!array_check (mask, 0)) - return false; - - if (!dim_rank_check (dim, mask, false)) - return false; - - return true; -} - - -bool -gfc_check_precision (gfc_expr *x) -{ - if (!real_or_complex_check (x, 0)) - return false; - - return true; -} - - -bool -gfc_check_present (gfc_expr *a) -{ - gfc_symbol *sym; - - if (!variable_check (a, 0, true)) - return false; - - sym = a->symtree->n.sym; - if (!sym->attr.dummy) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be of a " - "dummy variable", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where); - return false; - } - - /* For CLASS, the optional attribute might be set at either location. */ - if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional) - && !sym->attr.optional) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be of " - "an OPTIONAL dummy variable", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); - return false; - } - - /* 13.14.82 PRESENT(A) - ...... - Argument. A shall be the name of an optional dummy argument that is - accessible in the subprogram in which the PRESENT function reference - appears... */ - - if (a->ref != NULL - && !(a->ref->next == NULL && a->ref->type == REF_ARRAY - && (a->ref->u.ar.type == AR_FULL - || (a->ref->u.ar.type == AR_ELEMENT - && a->ref->u.ar.as->rank == 0)))) - { - gfc_error ("%qs argument of %qs intrinsic at %L must not be a " - "subobject of %qs", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where, sym->name); - return false; - } - - return true; -} - - -bool -gfc_check_radix (gfc_expr *x) -{ - if (!int_or_real_check (x, 0)) - return false; - - return true; -} - - -bool -gfc_check_range (gfc_expr *x) -{ - if (!numeric_check (x, 0)) - return false; - - return true; -} - - -bool -gfc_check_rank (gfc_expr *a) -{ - /* Any data object is allowed; a "data object" is a "constant (4.1.3), - variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */ - - bool is_variable = true; - - /* Functions returning pointers are regarded as variable, cf. F2008, R602. */ - if (a->expr_type == EXPR_FUNCTION) - is_variable = a->value.function.esym - ? a->value.function.esym->result->attr.pointer - : a->symtree->n.sym->result->attr.pointer; - - if (a->expr_type == EXPR_OP - || a->expr_type == EXPR_NULL - || a->expr_type == EXPR_COMPCALL - || a->expr_type == EXPR_PPC - || a->ts.type == BT_PROCEDURE - || !is_variable) - { - gfc_error ("The argument of the RANK intrinsic at %L must be a data " - "object", &a->where); - return false; - } - - return true; -} - - -bool -gfc_check_real (gfc_expr *a, gfc_expr *kind) -{ - if (!kind_check (kind, 1, BT_REAL)) - return false; - - /* BOZ is dealt with in gfc_simplify_real. */ - if (a->ts.type == BT_BOZ) - return true; - - if (!numeric_check (a, 0)) - return false; - - return true; -} - - -bool -gfc_check_rename (gfc_expr *path1, gfc_expr *path2) -{ - if (!type_check (path1, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (path1, 0, gfc_default_character_kind)) - return false; - - if (!type_check (path2, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (path2, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) -{ - if (!type_check (path1, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (path1, 0, gfc_default_character_kind)) - return false; - - if (!type_check (path2, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (path2, 1, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER)) - return false; - - if (!scalar_check (status, 2)) - return false; - - return true; -} - - -bool -gfc_check_repeat (gfc_expr *x, gfc_expr *y) -{ - if (!type_check (x, 0, BT_CHARACTER)) - return false; - - if (!scalar_check (x, 0)) - return false; - - if (!type_check (y, 0, BT_INTEGER)) - return false; - - if (!scalar_check (y, 1)) - return false; - - return true; -} - - -bool -gfc_check_reshape (gfc_expr *source, gfc_expr *shape, - gfc_expr *pad, gfc_expr *order) -{ - mpz_t size; - mpz_t nelems; - int shape_size; - bool shape_is_const; - - if (!array_check (source, 0)) - return false; - - if (!rank_check (shape, 1, 1)) - return false; - - if (!type_check (shape, 1, BT_INTEGER)) - return false; - - if (!gfc_array_size (shape, &size)) - { - gfc_error ("% argument of % intrinsic at %L must be an " - "array of constant size", &shape->where); - return false; - } - - shape_size = mpz_get_ui (size); - mpz_clear (size); - - if (shape_size <= 0) - { - gfc_error ("%qs argument of %qs intrinsic at %L is empty", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &shape->where); - return false; - } - else if (shape_size > GFC_MAX_DIMENSIONS) - { - gfc_error ("% argument of % intrinsic at %L has more " - "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); - return false; - } - - gfc_simplify_expr (shape, 0); - shape_is_const = gfc_is_constant_expr (shape); - - if (shape->expr_type == EXPR_ARRAY && shape_is_const) - { - gfc_expr *e; - int i, extent; - for (i = 0; i < shape_size; ++i) - { - e = gfc_constructor_lookup_expr (shape->value.constructor, i); - if (e->expr_type != EXPR_CONSTANT) - continue; - - gfc_extract_int (e, &extent); - if (extent < 0) - { - gfc_error ("%qs argument of %qs intrinsic at %L has " - "negative element (%d)", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &shape->where, extent); - return false; - } - } - } - - if (pad != NULL) - { - if (!same_type_check (source, 0, pad, 2)) - return false; - - if (!array_check (pad, 2)) - return false; - } - - if (order != NULL) - { - if (!array_check (order, 3)) - return false; - - if (!type_check (order, 3, BT_INTEGER)) - return false; - - if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order)) - { - int i, order_size, dim, perm[GFC_MAX_DIMENSIONS]; - gfc_expr *e; - - for (i = 0; i < GFC_MAX_DIMENSIONS; ++i) - perm[i] = 0; - - gfc_array_size (order, &size); - order_size = mpz_get_ui (size); - mpz_clear (size); - - if (order_size != shape_size) - { - gfc_error ("%qs argument of %qs intrinsic at %L " - "has wrong number of elements (%d/%d)", - gfc_current_intrinsic_arg[3]->name, - gfc_current_intrinsic, &order->where, - order_size, shape_size); - return false; - } - - for (i = 1; i <= order_size; ++i) - { - e = gfc_constructor_lookup_expr (order->value.constructor, i-1); - if (e->expr_type != EXPR_CONSTANT) - continue; - - gfc_extract_int (e, &dim); - - if (dim < 1 || dim > order_size) - { - gfc_error ("%qs argument of %qs intrinsic at %L " - "has out-of-range dimension (%d)", - gfc_current_intrinsic_arg[3]->name, - gfc_current_intrinsic, &e->where, dim); - return false; - } - - if (perm[dim-1] != 0) - { - gfc_error ("%qs argument of %qs intrinsic at %L has " - "invalid permutation of dimensions (dimension " - "%qd duplicated)", - gfc_current_intrinsic_arg[3]->name, - gfc_current_intrinsic, &e->where, dim); - return false; - } - - perm[dim-1] = 1; - } - } - } - - if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const - && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as - && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE)) - { - /* Check the match in size between source and destination. */ - if (gfc_array_size (source, &nelems)) - { - gfc_constructor *c; - bool test; - - - mpz_init_set_ui (size, 1); - for (c = gfc_constructor_first (shape->value.constructor); - c; c = gfc_constructor_next (c)) - mpz_mul (size, size, c->expr->value.integer); - - test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0; - mpz_clear (nelems); - mpz_clear (size); - - if (test) - { - gfc_error ("Without padding, there are not enough elements " - "in the intrinsic RESHAPE source at %L to match " - "the shape", &source->where); - return false; - } - } - } - - return true; -} - - -bool -gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) -{ - if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) - { - gfc_error ("%qs argument of %qs intrinsic at %L " - "cannot be of type %s", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, - &a->where, gfc_typename (a)); - return false; - } - - if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) - { - gfc_error ("%qs argument of %qs intrinsic at %L " - "must be of an extensible type", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); - return false; - } - - if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) - { - gfc_error ("%qs argument of %qs intrinsic at %L " - "cannot be of type %s", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, - &b->where, gfc_typename (b)); - return false; - } - - if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) - { - gfc_error ("%qs argument of %qs intrinsic at %L " - "must be of an extensible type", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &b->where); - return false; - } - - return true; -} - - -bool -gfc_check_scale (gfc_expr *x, gfc_expr *i) -{ - if (!type_check (x, 0, BT_REAL)) - return false; - - if (!type_check (i, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) -{ - if (!type_check (x, 0, BT_CHARACTER)) - return false; - - if (!type_check (y, 1, BT_CHARACTER)) - return false; - - if (z != NULL && !type_check (z, 2, BT_LOGICAL)) - return false; - - if (!kind_check (kind, 3, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - if (!same_type_check (x, 0, y, 1)) - return false; - - return true; -} - - -bool -gfc_check_secnds (gfc_expr *r) -{ - if (!type_check (r, 0, BT_REAL)) - return false; - - if (!kind_value_check (r, 0, 4)) - return false; - - if (!scalar_check (r, 0)) - return false; - - return true; -} - - -bool -gfc_check_selected_char_kind (gfc_expr *name) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!scalar_check (name, 0)) - return false; - - return true; -} - - -bool -gfc_check_selected_int_kind (gfc_expr *r) -{ - if (!type_check (r, 0, BT_INTEGER)) - return false; - - if (!scalar_check (r, 0)) - return false; - - return true; -} - - -bool -gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) -{ - if (p == NULL && r == NULL - && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" - " neither % nor % argument at %L", - gfc_current_intrinsic_where)) - return false; - - if (p) - { - if (!type_check (p, 0, BT_INTEGER)) - return false; - - if (!scalar_check (p, 0)) - return false; - } - - if (r) - { - if (!type_check (r, 1, BT_INTEGER)) - return false; - - if (!scalar_check (r, 1)) - return false; - } - - if (radix) - { - if (!type_check (radix, 1, BT_INTEGER)) - return false; - - if (!scalar_check (radix, 1)) - return false; - - if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with " - "RADIX argument at %L", gfc_current_intrinsic, - &radix->where)) - return false; - } - - return true; -} - - -bool -gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) -{ - if (!type_check (x, 0, BT_REAL)) - return false; - - if (!type_check (i, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_shape (gfc_expr *source, gfc_expr *kind) -{ - gfc_array_ref *ar; - - if (gfc_invalid_null_arg (source)) - return false; - - if (!kind_check (kind, 1, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) - return true; - - if (source->ref == NULL) - return false; - - ar = gfc_find_array_ref (source); - - if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL) - { - gfc_error ("% argument of % intrinsic at %L must not be " - "an assumed size array", &source->where); - return false; - } - - return true; -} - - -bool -gfc_check_shift (gfc_expr *i, gfc_expr *shift) -{ - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!type_check (shift, 0, BT_INTEGER)) - return false; - - if (!nonnegative_check ("SHIFT", shift)) - return false; - - if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) - return false; - - return true; -} - - -bool -gfc_check_sign (gfc_expr *a, gfc_expr *b) -{ - if (!int_or_real_check (a, 0)) - return false; - - if (!same_type_check (a, 0, b, 1)) - return false; - - return true; -} - - -bool -gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - if (!array_check (array, 0)) - return false; - - if (!dim_check (dim, 1, true)) - return false; - - if (!dim_rank_check (dim, array, 0)) - return false; - - if (!kind_check (kind, 2, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - - return true; -} - - -bool -gfc_check_sizeof (gfc_expr *arg) -{ - if (gfc_invalid_null_arg (arg)) - return false; - - if (arg->ts.type == BT_PROCEDURE) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &arg->where); - return false; - } - - if (illegal_boz_arg (arg)) - return false; - - /* TYPE(*) is acceptable if and only if it uses an array descriptor. */ - if (arg->ts.type == BT_ASSUMED - && (arg->symtree->n.sym->as == NULL - || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE - && arg->symtree->n.sym->as->type != AS_DEFERRED - && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK))) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &arg->where); - return false; - } - - if (arg->rank && arg->expr_type == EXPR_VARIABLE - && arg->symtree->n.sym->as != NULL - && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref - && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " - "assumed-size array", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &arg->where); - return false; - } - - return true; -} - - -/* Check whether an expression is interoperable. When returning false, - msg is set to a string telling why the expression is not interoperable, - otherwise, it is set to NULL. The msg string can be used in diagnostics. - If c_loc is true, character with len > 1 are allowed (cf. Fortran - 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape - arrays are permitted. And if c_f_ptr is true, deferred-shape arrays - are permitted. */ - -static bool -is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr) -{ - *msg = NULL; - - if (expr->expr_type == EXPR_NULL) - { - *msg = "NULL() is not interoperable"; - return false; - } - - if (expr->ts.type == BT_BOZ) - { - *msg = "BOZ literal constant"; - return false; - } - - if (expr->ts.type == BT_CLASS) - { - *msg = "Expression is polymorphic"; - return false; - } - - if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c - && !expr->ts.u.derived->ts.is_iso_c) - { - *msg = "Expression is a noninteroperable derived type"; - return false; - } - - if (expr->ts.type == BT_PROCEDURE) - { - *msg = "Procedure unexpected as argument"; - return false; - } - - if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL) - { - int i; - for (i = 0; gfc_logical_kinds[i].kind; i++) - if (gfc_logical_kinds[i].kind == expr->ts.kind) - return true; - *msg = "Extension to use a non-C_Bool-kind LOGICAL"; - return false; - } - - if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER - && expr->ts.kind != 1) - { - *msg = "Extension to use a non-C_CHAR-kind CHARACTER"; - return false; - } - - if (expr->ts.type == BT_CHARACTER) { - if (expr->ts.deferred) - { - /* TS 29113 allows deferred-length strings as dummy arguments, - but it is not an interoperable type. */ - *msg = "Expression shall not be a deferred-length string"; - return false; - } - - if (expr->ts.u.cl && expr->ts.u.cl->length - && !gfc_simplify_expr (expr->ts.u.cl->length, 0)) - gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed"); - - if (!c_loc && expr->ts.u.cl - && (!expr->ts.u.cl->length - || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)) - { - *msg = "Type shall have a character length of 1"; - return false; - } - } - - /* Note: The following checks are about interoperatable variables, Fortran - 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more - is allowed, e.g. assumed-shape arrays with TS 29113. */ - - if (gfc_is_coarray (expr)) - { - *msg = "Coarrays are not interoperable"; - return false; - } - - if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY) - { - gfc_array_ref *ar = gfc_find_array_ref (expr); - if (ar->type != AR_FULL) - { - *msg = "Only whole-arrays are interoperable"; - return false; - } - if (!c_f_ptr && ar->as->type != AS_EXPLICIT - && ar->as->type != AS_ASSUMED_SIZE) - { - *msg = "Only explicit-size and assumed-size arrays are interoperable"; - return false; - } - } - - return true; -} - - -bool -gfc_check_c_sizeof (gfc_expr *arg) -{ - const char *msg; - - if (!is_c_interoperable (arg, &msg, false, false)) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be an " - "interoperable data entity: %s", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &arg->where, msg); - return false; - } - - if (arg->ts.type == BT_ASSUMED) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be " - "TYPE(*)", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &arg->where); - return false; - } - - if (arg->rank && arg->expr_type == EXPR_VARIABLE - && arg->symtree->n.sym->as != NULL - && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref - && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " - "assumed-size array", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &arg->where); - return false; - } - - return true; -} - - -bool -gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) -{ - if (c_ptr_1->ts.type != BT_DERIVED - || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING - || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR - && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)) - { - gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " - "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); - return false; - } - - if (!scalar_check (c_ptr_1, 0)) - return false; - - if (c_ptr_2 - && (c_ptr_2->ts.type != BT_DERIVED - || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING - || (c_ptr_1->ts.u.derived->intmod_sym_id - != c_ptr_2->ts.u.derived->intmod_sym_id))) - { - gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " - "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where, - gfc_typename (&c_ptr_1->ts), - gfc_typename (&c_ptr_2->ts)); - return false; - } - - if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) - return false; - - return true; -} - - -bool -gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) -{ - symbol_attribute attr; - const char *msg; - - if (cptr->ts.type != BT_DERIVED - || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING - || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR) - { - gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the " - "type TYPE(C_PTR)", &cptr->where); - return false; - } - - if (!scalar_check (cptr, 0)) - return false; - - attr = gfc_expr_attr (fptr); - - if (!attr.pointer) - { - gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer", - &fptr->where); - return false; - } - - if (fptr->ts.type == BT_CLASS) - { - gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic", - &fptr->where); - return false; - } - - if (gfc_is_coindexed (fptr)) - { - gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be " - "coindexed", &fptr->where); - return false; - } - - if (fptr->rank == 0 && shape) - { - gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar " - "FPTR", &fptr->where); - return false; - } - else if (fptr->rank && !shape) - { - gfc_error ("Expected SHAPE argument to C_F_POINTER with array " - "FPTR at %L", &fptr->where); - return false; - } - - if (shape && !rank_check (shape, 2, 1)) - return false; - - if (shape && !type_check (shape, 2, BT_INTEGER)) - return false; - - if (shape) - { - mpz_t size; - if (gfc_array_size (shape, &size)) - { - if (mpz_cmp_ui (size, fptr->rank) != 0) - { - mpz_clear (size); - gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same " - "size as the RANK of FPTR", &shape->where); - return false; - } - mpz_clear (size); - } - } - - if (fptr->ts.type == BT_CLASS) - { - gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where); - return false; - } - - if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true)) - return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR " - "at %L to C_F_POINTER: %s", &fptr->where, msg); - - return true; -} - - -bool -gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr) -{ - symbol_attribute attr; - - if (cptr->ts.type != BT_DERIVED - || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING - || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR) - { - gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the " - "type TYPE(C_FUNPTR)", &cptr->where); - return false; - } - - if (!scalar_check (cptr, 0)) - return false; - - attr = gfc_expr_attr (fptr); - - if (!attr.proc_pointer) - { - gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure " - "pointer", &fptr->where); - return false; - } - - if (gfc_is_coindexed (fptr)) - { - gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be " - "coindexed", &fptr->where); - return false; - } - - if (!attr.is_bind_c) - return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " - "pointer at %L to C_F_PROCPOINTER", &fptr->where); - - return true; -} - - -bool -gfc_check_c_funloc (gfc_expr *x) -{ - symbol_attribute attr; - - if (gfc_is_coindexed (x)) - { - gfc_error ("Argument X at %L to C_FUNLOC shall not be " - "coindexed", &x->where); - return false; - } - - attr = gfc_expr_attr (x); - - if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE - && x->symtree->n.sym == x->symtree->n.sym->result) - for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent) - if (x->symtree->n.sym == ns->proc_name) - { - gfc_error ("Function result %qs at %L is invalid as X argument " - "to C_FUNLOC", x->symtree->n.sym->name, &x->where); - return false; - } - - if (attr.flavor != FL_PROCEDURE) - { - gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure " - "or a procedure pointer", &x->where); - return false; - } - - if (!attr.is_bind_c) - return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " - "at %L to C_FUNLOC", &x->where); - return true; -} - - -bool -gfc_check_c_loc (gfc_expr *x) -{ - symbol_attribute attr; - const char *msg; - - if (gfc_is_coindexed (x)) - { - gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where); - return false; - } - - if (x->ts.type == BT_CLASS) - { - gfc_error ("X argument at %L to C_LOC shall not be polymorphic", - &x->where); - return false; - } - - attr = gfc_expr_attr (x); - - if (!attr.pointer - && (x->expr_type != EXPR_VARIABLE || !attr.target - || attr.flavor == FL_PARAMETER)) - { - gfc_error ("Argument X at %L to C_LOC shall have either " - "the POINTER or the TARGET attribute", &x->where); - return false; - } - - if (x->ts.type == BT_CHARACTER - && gfc_var_strlen (x) == 0) - { - gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized " - "string", &x->where); - return false; - } - - if (!is_c_interoperable (x, &msg, true, false)) - { - if (x->ts.type == BT_CLASS) - { - gfc_error ("Argument at %L to C_LOC shall not be polymorphic", - &x->where); - return false; - } - - if (x->rank - && !gfc_notify_std (GFC_STD_F2018, - "Noninteroperable array at %L as" - " argument to C_LOC: %s", &x->where, msg)) - return false; - } - else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008)) - { - gfc_array_ref *ar = gfc_find_array_ref (x); - - if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE - && !attr.allocatable - && !gfc_notify_std (GFC_STD_F2008, - "Array of interoperable type at %L " - "to C_LOC which is nonallocatable and neither " - "assumed size nor explicit size", &x->where)) - return false; - else if (ar->type != AR_FULL - && !gfc_notify_std (GFC_STD_F2008, "Array section at %L " - "to C_LOC", &x->where)) - return false; - } - - return true; -} - - -bool -gfc_check_sleep_sub (gfc_expr *seconds) -{ - if (!type_check (seconds, 0, BT_INTEGER)) - return false; - - if (!scalar_check (seconds, 0)) - return false; - - return true; -} - -bool -gfc_check_sngl (gfc_expr *a) -{ - if (!type_check (a, 0, BT_REAL)) - return false; - - if ((a->ts.kind != gfc_default_double_kind) - && !gfc_notify_std (GFC_STD_GNU, "non double precision " - "REAL argument to %s intrinsic at %L", - gfc_current_intrinsic, &a->where)) - return false; - - return true; -} - -bool -gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) -{ - if (gfc_invalid_null_arg (source)) - return false; - - if (source->rank >= GFC_MAX_DIMENSIONS) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be less " - "than rank %d", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); - - return false; - } - - if (dim == NULL) - return false; - - if (!dim_check (dim, 1, false)) - return false; - - /* dim_rank_check() does not apply here. */ - if (dim - && dim->expr_type == EXPR_CONSTANT - && (mpz_cmp_ui (dim->value.integer, 1) < 0 - || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) - { - gfc_error ("%qs argument of %qs intrinsic at %L is not a valid " - "dimension index", gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &dim->where); - return false; - } - - if (!type_check (ncopies, 2, BT_INTEGER)) - return false; - - if (!scalar_check (ncopies, 2)) - return false; - - return true; -} - - -/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and - functions). */ - -bool -arg_strlen_is_zero (gfc_expr *c, int n) -{ - if (gfc_var_strlen (c) == 0) - { - gfc_error ("%qs argument of %qs intrinsic at %L must have " - "length at least 1", gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic, &c->where); - return true; - } - return false; -} - -bool -gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) -{ - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (c, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (c, 1, gfc_default_character_kind)) - return false; - if (strcmp (gfc_current_intrinsic, "fgetc") == 0 - && !variable_check (c, 1, false)) - return false; - if (arg_strlen_is_zero (c, 1)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER) - || !kind_value_check (status, 2, gfc_default_integer_kind) - || !scalar_check (status, 2) - || !variable_check (status, 2, false)) - return false; - - return true; -} - - -bool -gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) -{ - return gfc_check_fgetputc_sub (unit, c, NULL); -} - - -bool -gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) -{ - if (!type_check (c, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (c, 0, gfc_default_character_kind)) - return false; - if (strcmp (gfc_current_intrinsic, "fget") == 0 - && !variable_check (c, 0, false)) - return false; - if (arg_strlen_is_zero (c, 0)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 1, BT_INTEGER) - || !kind_value_check (status, 1, gfc_default_integer_kind) - || !scalar_check (status, 1) - || !variable_check (status, 1, false)) - return false; - - return true; -} - - -bool -gfc_check_fgetput (gfc_expr *c) -{ - return gfc_check_fgetput_sub (c, NULL); -} - - -bool -gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) -{ - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (offset, 1, BT_INTEGER)) - return false; - - if (!scalar_check (offset, 1)) - return false; - - if (!type_check (whence, 2, BT_INTEGER)) - return false; - - if (!scalar_check (whence, 2)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 3, BT_INTEGER)) - return false; - - if (!kind_value_check (status, 3, 4)) - return false; - - if (!scalar_check (status, 3)) - return false; - - return true; -} - - - -bool -gfc_check_fstat (gfc_expr *unit, gfc_expr *array) -{ - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (unit, 0, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) - return false; - - return true; -} - - -bool -gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) -{ - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER) - || !kind_value_check (status, 2, gfc_default_integer_kind)) - return false; - - if (!scalar_check (status, 2)) - return false; - - return true; -} - - -bool -gfc_check_ftell (gfc_expr *unit) -{ - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - return true; -} - - -bool -gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) -{ - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (offset, 1, BT_INTEGER)) - return false; - - if (!scalar_check (offset, 1)) - return false; - - return true; -} - - -bool -gfc_check_stat (gfc_expr *name, gfc_expr *array) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) - return false; - - return true; -} - - -bool -gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!scalar_check (status, 2)) - return false; - - return true; -} - - -bool -gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) -{ - mpz_t nelems; - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return false; - } - - if (!coarray_check (coarray, 0)) - return false; - - if (sub->rank != 1) - { - gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", - gfc_current_intrinsic_arg[1]->name, &sub->where); - return false; - } - - if (sub->ts.type != BT_INTEGER) - { - gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER", - gfc_current_intrinsic_arg[1]->name, &sub->where); - return false; - } - - if (gfc_array_size (sub, &nelems)) - { - int corank = gfc_get_corank (coarray); - - if (mpz_cmp_ui (nelems, corank) != 0) - { - gfc_error ("The number of array elements of the SUB argument to " - "IMAGE_INDEX at %L shall be %d (corank) not %d", - &sub->where, corank, (int) mpz_get_si (nelems)); - mpz_clear (nelems); - return false; - } - mpz_clear (nelems); - } - - return true; -} - - -bool -gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return false; - } - - if (distance) - { - if (!type_check (distance, 0, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 0)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "NUM_IMAGES at %L", &distance->where)) - return false; - } - - if (failed) - { - if (!type_check (failed, 1, BT_LOGICAL)) - return false; - - if (!scalar_check (failed, 1)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to " - "NUM_IMAGES at %L", &failed->where)) - return false; - } - - return true; -} - - -bool -gfc_check_team_number (gfc_expr *team) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return false; - } - - if (team) - { - if (team->ts.type != BT_DERIVED - || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) - { - gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER " - "shall be of type TEAM_TYPE", &team->where); - return false; - } - } - else - return true; - - return true; -} - - -bool -gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return false; - } - - if (coarray == NULL && dim == NULL && distance == NULL) - return true; - - if (dim != NULL && coarray == NULL) - { - gfc_error ("DIM argument without COARRAY argument not allowed for " - "THIS_IMAGE intrinsic at %L", &dim->where); - return false; - } - - if (distance && (coarray || dim)) - { - gfc_error ("The DISTANCE argument may not be specified together with the " - "COARRAY or DIM argument in intrinsic at %L", - &distance->where); - return false; - } - - /* Assume that we have "this_image (distance)". */ - if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER) - { - if (dim) - { - gfc_error ("Unexpected DIM argument with noncoarray argument at %L", - &coarray->where); - return false; - } - distance = coarray; - } - - if (distance) - { - if (!type_check (distance, 2, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 2)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "THIS_IMAGE at %L", &distance->where)) - return false; - - return true; - } - - if (!coarray_check (coarray, 0)) - return false; - - if (dim != NULL) - { - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_corank_check (dim, coarray)) - return false; - } - - return true; -} - -/* Calculate the sizes for transfer, used by gfc_check_transfer and also - by gfc_simplify_transfer. Return false if we cannot do so. */ - -bool -gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, - size_t *source_size, size_t *result_size, - size_t *result_length_p) -{ - size_t result_elt_size; - - if (source->expr_type == EXPR_FUNCTION) - return false; - - if (size && size->expr_type != EXPR_CONSTANT) - return false; - - /* Calculate the size of the source. */ - if (!gfc_target_expr_size (source, source_size)) - return false; - - /* Determine the size of the element. */ - if (!gfc_element_size (mold, &result_elt_size)) - return false; - - /* If the storage size of SOURCE is greater than zero and MOLD is an array, - * a scalar with the type and type parameters of MOLD shall not have a - * storage size equal to zero. - * If MOLD is a scalar and SIZE is absent, the result is a scalar. - * If MOLD is an array and SIZE is absent, the result is an array and of - * rank one. Its size is as small as possible such that its physical - * representation is not shorter than that of SOURCE. - * If SIZE is present, the result is an array of rank one and size SIZE. - */ - if (result_elt_size == 0 && *source_size > 0 && !size - && mold->expr_type == EXPR_ARRAY) - { - gfc_error ("% argument of % intrinsic at %L is an " - "array and shall not have storage size 0 when % " - "argument has size greater than 0", &mold->where); - return false; - } - - if (result_elt_size == 0 && *source_size == 0 && !size) - { - *result_size = 0; - if (result_length_p) - *result_length_p = 0; - return true; - } - - if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank)) - || size) - { - int result_length; - - if (size) - result_length = (size_t)mpz_get_ui (size->value.integer); - else - { - result_length = *source_size / result_elt_size; - if (result_length * result_elt_size < *source_size) - result_length += 1; - } - - *result_size = result_length * result_elt_size; - if (result_length_p) - *result_length_p = result_length; - } - else - *result_size = result_elt_size; - - return true; -} - - -bool -gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) -{ - size_t source_size; - size_t result_size; - - if (gfc_invalid_null_arg (source)) - return false; - - /* SOURCE shall be a scalar or array of any type. */ - if (source->ts.type == BT_PROCEDURE - && source->symtree->n.sym->attr.subroutine == 1) - { - gfc_error ("% argument of % intrinsic at %L " - "must not be a %s", &source->where, - gfc_basic_typename (source->ts.type)); - return false; - } - - if (source->ts.type == BT_BOZ && illegal_boz_arg (source)) - return false; - - if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold)) - return false; - - if (gfc_invalid_null_arg (mold)) - return false; - - /* MOLD shall be a scalar or array of any type. */ - if (mold->ts.type == BT_PROCEDURE - && mold->symtree->n.sym->attr.subroutine == 1) - { - gfc_error ("% argument of % intrinsic at %L " - "must not be a %s", &mold->where, - gfc_basic_typename (mold->ts.type)); - return false; - } - - if (mold->ts.type == BT_HOLLERITH) - { - gfc_error ("% argument of % intrinsic at %L must not be" - " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH)); - return false; - } - - /* SIZE (optional) shall be an integer scalar. The corresponding actual - argument shall not be an optional dummy argument. */ - if (size != NULL) - { - if (!type_check (size, 2, BT_INTEGER)) - { - if (size->ts.type == BT_BOZ) - reset_boz (size); - return false; - } - - if (!scalar_check (size, 2)) - return false; - - if (!nonoptional_check (size, 2)) - return false; - } - - if (!warn_surprising) - return true; - - /* If we can't calculate the sizes, we cannot check any more. - Return true for that case. */ - - if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, - &result_size, NULL)) - return true; - - if (source_size < result_size) - gfc_warning (OPT_Wsurprising, - "Intrinsic TRANSFER at %L has partly undefined result: " - "source size %ld < result size %ld", &source->where, - (long) source_size, (long) result_size); - - return true; -} - - -bool -gfc_check_transpose (gfc_expr *matrix) -{ - if (!rank_check (matrix, 0, 2)) - return false; - - return true; -} - - -bool -gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - if (!array_check (array, 0)) - return false; - - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_rank_check (dim, array, 0)) - return false; - - if (!kind_check (kind, 2, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - return true; -} - - -bool -gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return false; - } - - if (!coarray_check (coarray, 0)) - return false; - - if (dim != NULL) - { - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_corank_check (dim, coarray)) - return false; - } - - if (!kind_check (kind, 2, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) -{ - mpz_t vector_size; - - if (!rank_check (vector, 0, 1)) - return false; - - if (!array_check (mask, 1)) - return false; - - if (!type_check (mask, 1, BT_LOGICAL)) - return false; - - if (!same_type_check (vector, 0, field, 2)) - return false; - - if (mask->expr_type == EXPR_ARRAY - && gfc_array_size (vector, &vector_size)) - { - int mask_true_count = 0; - gfc_constructor *mask_ctor; - mask_ctor = gfc_constructor_first (mask->value.constructor); - while (mask_ctor) - { - if (mask_ctor->expr->expr_type != EXPR_CONSTANT) - { - mask_true_count = 0; - break; - } - - if (mask_ctor->expr->value.logical) - mask_true_count++; - - mask_ctor = gfc_constructor_next (mask_ctor); - } - - if (mpz_get_si (vector_size) < mask_true_count) - { - gfc_error ("%qs argument of %qs intrinsic at %L must " - "provide at least as many elements as there " - "are .TRUE. values in %qs (%ld/%d)", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &vector->where, gfc_current_intrinsic_arg[1]->name, - mpz_get_si (vector_size), mask_true_count); - return false; - } - - mpz_clear (vector_size); - } - - if (mask->rank != field->rank && field->rank != 0) - { - gfc_error ("%qs argument of %qs intrinsic at %L must have " - "the same rank as %qs or be a scalar", - gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, - &field->where, gfc_current_intrinsic_arg[1]->name); - return false; - } - - if (mask->rank == field->rank) - { - int i; - for (i = 0; i < field->rank; i++) - if (! identical_dimen_shape (mask, i, field, i)) - { - gfc_error ("%qs and %qs arguments of %qs intrinsic at %L " - "must have identical shape.", - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &field->where); - } - } - - return true; -} - - -bool -gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) -{ - if (!type_check (x, 0, BT_CHARACTER)) - return false; - - if (!same_type_check (x, 0, y, 1)) - return false; - - if (z != NULL && !type_check (z, 2, BT_LOGICAL)) - return false; - - if (!kind_check (kind, 3, BT_INTEGER)) - return false; - if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " - "with KIND argument at %L", - gfc_current_intrinsic, &kind->where)) - return false; - - return true; -} - - -bool -gfc_check_trim (gfc_expr *x) -{ - if (!type_check (x, 0, BT_CHARACTER)) - return false; - - if (gfc_invalid_null_arg (x)) - return false; - - if (!scalar_check (x, 0)) - return false; - - return true; -} - - -bool -gfc_check_ttynam (gfc_expr *unit) -{ - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - return true; -} - - -/************* Check functions for intrinsic subroutines *************/ - -bool -gfc_check_cpu_time (gfc_expr *time) -{ - if (!scalar_check (time, 0)) - return false; - - if (!type_check (time, 0, BT_REAL)) - return false; - - if (!variable_check (time, 0, false)) - return false; - - return true; -} - - -bool -gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, - gfc_expr *zone, gfc_expr *values) -{ - if (date != NULL) - { - if (!type_check (date, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (date, 0, gfc_default_character_kind)) - return false; - if (!scalar_check (date, 0)) - return false; - if (!variable_check (date, 0, false)) - return false; - } - - if (time != NULL) - { - if (!type_check (time, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (time, 1, gfc_default_character_kind)) - return false; - if (!scalar_check (time, 1)) - return false; - if (!variable_check (time, 1, false)) - return false; - } - - if (zone != NULL) - { - if (!type_check (zone, 2, BT_CHARACTER)) - return false; - if (!kind_value_check (zone, 2, gfc_default_character_kind)) - return false; - if (!scalar_check (zone, 2)) - return false; - if (!variable_check (zone, 2, false)) - return false; - } - - if (values != NULL) - { - if (!type_check (values, 3, BT_INTEGER)) - return false; - if (!array_check (values, 3)) - return false; - if (!rank_check (values, 3, 1)) - return false; - if (!variable_check (values, 3, false)) - return false; - } - - return true; -} - - -bool -gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, - gfc_expr *to, gfc_expr *topos) -{ - if (!type_check (from, 0, BT_INTEGER)) - return false; - - if (!type_check (frompos, 1, BT_INTEGER)) - return false; - - if (!type_check (len, 2, BT_INTEGER)) - return false; - - if (!same_type_check (from, 0, to, 3)) - return false; - - if (!variable_check (to, 3, false)) - return false; - - if (!type_check (topos, 4, BT_INTEGER)) - return false; - - if (!nonnegative_check ("frompos", frompos)) - return false; - - if (!nonnegative_check ("topos", topos)) - return false; - - if (!nonnegative_check ("len", len)) - return false; - - if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)) - return false; - - if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len)) - return false; - - return true; -} - - -/* Check the arguments for RANDOM_INIT. */ - -bool -gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct) -{ - if (!type_check (repeatable, 0, BT_LOGICAL)) - return false; - - if (!scalar_check (repeatable, 0)) - return false; - - if (!type_check (image_distinct, 1, BT_LOGICAL)) - return false; - - if (!scalar_check (image_distinct, 1)) - return false; - - return true; -} - - -bool -gfc_check_random_number (gfc_expr *harvest) -{ - if (!type_check (harvest, 0, BT_REAL)) - return false; - - if (!variable_check (harvest, 0, false)) - return false; - - return true; -} - - -bool -gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) -{ - unsigned int nargs = 0, seed_size; - locus *where = NULL; - mpz_t put_size, get_size; - - /* Keep the number of bytes in sync with master_state in - libgfortran/intrinsics/random.c. */ - seed_size = 32 / gfc_default_integer_kind; - - if (size != NULL) - { - if (size->expr_type != EXPR_VARIABLE - || !size->symtree->n.sym->attr.optional) - nargs++; - - if (!scalar_check (size, 0)) - return false; - - if (!type_check (size, 0, BT_INTEGER)) - return false; - - if (!variable_check (size, 0, false)) - return false; - - if (!kind_value_check (size, 0, gfc_default_integer_kind)) - return false; - } - - if (put != NULL) - { - if (put->expr_type != EXPR_VARIABLE - || !put->symtree->n.sym->attr.optional) - { - nargs++; - where = &put->where; - } - - if (!array_check (put, 1)) - return false; - - if (!rank_check (put, 1, 1)) - return false; - - if (!type_check (put, 1, BT_INTEGER)) - return false; - - if (!kind_value_check (put, 1, gfc_default_integer_kind)) - return false; - - if (gfc_array_size (put, &put_size) - && mpz_get_ui (put_size) < seed_size) - gfc_error ("Size of %qs argument of %qs intrinsic at %L " - "too small (%i/%i)", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &put->where, (int) mpz_get_ui (put_size), seed_size); - } - - if (get != NULL) - { - if (get->expr_type != EXPR_VARIABLE - || !get->symtree->n.sym->attr.optional) - { - nargs++; - where = &get->where; - } - - if (!array_check (get, 2)) - return false; - - if (!rank_check (get, 2, 1)) - return false; - - if (!type_check (get, 2, BT_INTEGER)) - return false; - - if (!variable_check (get, 2, false)) - return false; - - if (!kind_value_check (get, 2, gfc_default_integer_kind)) - return false; - - if (gfc_array_size (get, &get_size) - && mpz_get_ui (get_size) < seed_size) - gfc_error ("Size of %qs argument of %qs intrinsic at %L " - "too small (%i/%i)", - gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, - &get->where, (int) mpz_get_ui (get_size), seed_size); - } - - /* RANDOM_SEED may not have more than one non-optional argument. */ - if (nargs > 1) - gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where); - - return true; -} - -bool -gfc_check_fe_runtime_error (gfc_actual_arglist *a) -{ - gfc_expr *e; - size_t len, i; - int num_percent, nargs; - - e = a->expr; - if (e->expr_type != EXPR_CONSTANT) - return true; - - len = e->value.character.length; - if (e->value.character.string[len-1] != '\0') - gfc_internal_error ("fe_runtime_error string must be null terminated"); - - num_percent = 0; - for (i=0; ivalue.character.string[i] == '%') - num_percent ++; - - nargs = 0; - for (; a; a = a->next) - nargs ++; - - if (nargs -1 != num_percent) - gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)", - nargs, num_percent++); - - return true; -} - -bool -gfc_check_second_sub (gfc_expr *time) -{ - if (!scalar_check (time, 0)) - return false; - - if (!type_check (time, 0, BT_REAL)) - return false; - - if (!kind_value_check (time, 0, 4)) - return false; - - return true; -} - - -/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer - variables in Fortran 95. In Fortran 2003 and later, they can be of any - kind, and COUNT_RATE can be of type real. Note, count, count_rate, and - count_max are all optional arguments */ - -bool -gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, - gfc_expr *count_max) -{ - if (count != NULL) - { - if (!scalar_check (count, 0)) - return false; - - if (!type_check (count, 0, BT_INTEGER)) - return false; - - if (count->ts.kind != gfc_default_integer_kind - && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to " - "SYSTEM_CLOCK at %L has non-default kind", - &count->where)) - return false; - - if (!variable_check (count, 0, false)) - return false; - } - - if (count_rate != NULL) - { - if (!scalar_check (count_rate, 1)) - return false; - - if (!variable_check (count_rate, 1, false)) - return false; - - if (count_rate->ts.type == BT_REAL) - { - if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to " - "SYSTEM_CLOCK at %L", &count_rate->where)) - return false; - } - else - { - if (!type_check (count_rate, 1, BT_INTEGER)) - return false; - - if (count_rate->ts.kind != gfc_default_integer_kind - && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to " - "SYSTEM_CLOCK at %L has non-default kind", - &count_rate->where)) - return false; - } - - } - - if (count_max != NULL) - { - if (!scalar_check (count_max, 2)) - return false; - - if (!type_check (count_max, 2, BT_INTEGER)) - return false; - - if (count_max->ts.kind != gfc_default_integer_kind - && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to " - "SYSTEM_CLOCK at %L has non-default kind", - &count_max->where)) - return false; - - if (!variable_check (count_max, 2, false)) - return false; - } - - return true; -} - - -bool -gfc_check_irand (gfc_expr *x) -{ - if (x == NULL) - return true; - - if (!scalar_check (x, 0)) - return false; - - if (!type_check (x, 0, BT_INTEGER)) - return false; - - if (!kind_value_check (x, 0, 4)) - return false; - - return true; -} - - -bool -gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) -{ - if (!scalar_check (seconds, 0)) - return false; - if (!type_check (seconds, 0, BT_INTEGER)) - return false; - - if (!int_or_proc_check (handler, 1)) - return false; - if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) - return false; - - if (status == NULL) - return true; - - if (!scalar_check (status, 2)) - return false; - if (!type_check (status, 2, BT_INTEGER)) - return false; - if (!kind_value_check (status, 2, gfc_default_integer_kind)) - return false; - - return true; -} - - -bool -gfc_check_rand (gfc_expr *x) -{ - if (x == NULL) - return true; - - if (!scalar_check (x, 0)) - return false; - - if (!type_check (x, 0, BT_INTEGER)) - return false; - - if (!kind_value_check (x, 0, 4)) - return false; - - return true; -} - - -bool -gfc_check_srand (gfc_expr *x) -{ - if (!scalar_check (x, 0)) - return false; - - if (!type_check (x, 0, BT_INTEGER)) - return false; - - if (!kind_value_check (x, 0, 4)) - return false; - - return true; -} - - -bool -gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) -{ - if (!scalar_check (time, 0)) - return false; - if (!type_check (time, 0, BT_INTEGER)) - return false; - - if (!type_check (result, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (result, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_dtime_etime (gfc_expr *x) -{ - if (!array_check (x, 0)) - return false; - - if (!rank_check (x, 0, 1)) - return false; - - if (!variable_check (x, 0, false)) - return false; - - if (!type_check (x, 0, BT_REAL)) - return false; - - if (!kind_value_check (x, 0, 4)) - return false; - - return true; -} - - -bool -gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) -{ - if (!array_check (values, 0)) - return false; - - if (!rank_check (values, 0, 1)) - return false; - - if (!variable_check (values, 0, false)) - return false; - - if (!type_check (values, 0, BT_REAL)) - return false; - - if (!kind_value_check (values, 0, 4)) - return false; - - if (!scalar_check (time, 1)) - return false; - - if (!type_check (time, 1, BT_REAL)) - return false; - - if (!kind_value_check (time, 1, 4)) - return false; - - return true; -} - - -bool -gfc_check_fdate_sub (gfc_expr *date) -{ - if (!type_check (date, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (date, 0, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_gerror (gfc_expr *msg) -{ - if (!type_check (msg, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (msg, 0, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) -{ - if (!type_check (cwd, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (cwd, 0, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!scalar_check (status, 1)) - return false; - - if (!type_check (status, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_getarg (gfc_expr *pos, gfc_expr *value) -{ - if (!type_check (pos, 0, BT_INTEGER)) - return false; - - if (pos->ts.kind > gfc_default_integer_kind) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind " - "not wider than the default kind (%d)", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &pos->where, gfc_default_integer_kind); - return false; - } - - if (!type_check (value, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (value, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_getlog (gfc_expr *msg) -{ - if (!type_check (msg, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (msg, 0, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_exit (gfc_expr *status) -{ - if (status == NULL) - return true; - - if (!type_check (status, 0, BT_INTEGER)) - return false; - - if (!scalar_check (status, 0)) - return false; - - return true; -} - - -bool -gfc_check_flush (gfc_expr *unit) -{ - if (unit == NULL) - return true; - - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - return true; -} - - -bool -gfc_check_free (gfc_expr *i) -{ - if (!type_check (i, 0, BT_INTEGER)) - return false; - - if (!scalar_check (i, 0)) - return false; - - return true; -} - - -bool -gfc_check_hostnm (gfc_expr *name) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!scalar_check (status, 1)) - return false; - - if (!type_check (status, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_itime_idate (gfc_expr *values) -{ - if (!array_check (values, 0)) - return false; - - if (!rank_check (values, 0, 1)) - return false; - - if (!variable_check (values, 0, false)) - return false; - - if (!type_check (values, 0, BT_INTEGER)) - return false; - - if (!kind_value_check (values, 0, gfc_default_integer_kind)) - return false; - - return true; -} - - -bool -gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) -{ - if (!type_check (time, 0, BT_INTEGER)) - return false; - - if (!kind_value_check (time, 0, gfc_default_integer_kind)) - return false; - - if (!scalar_check (time, 0)) - return false; - - if (!array_check (values, 1)) - return false; - - if (!rank_check (values, 1, 1)) - return false; - - if (!variable_check (values, 1, false)) - return false; - - if (!type_check (values, 1, BT_INTEGER)) - return false; - - if (!kind_value_check (values, 1, gfc_default_integer_kind)) - return false; - - return true; -} - - -bool -gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) -{ - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!type_check (name, 1, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 1, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_is_contiguous (gfc_expr *array) -{ - if (array->expr_type == EXPR_NULL) - { - gfc_error ("Actual argument at %L of %qs intrinsic shall be an " - "associated pointer", &array->where, gfc_current_intrinsic); - return false; - } - - if (!array_check (array, 0)) - return false; - - return true; -} - - -bool -gfc_check_isatty (gfc_expr *unit) -{ - if (unit == NULL) - return false; - - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - return true; -} - - -bool -gfc_check_isnan (gfc_expr *x) -{ - if (!type_check (x, 0, BT_REAL)) - return false; - - return true; -} - - -bool -gfc_check_perror (gfc_expr *string) -{ - if (!type_check (string, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (string, 0, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_umask (gfc_expr *mask) -{ - if (!type_check (mask, 0, BT_INTEGER)) - return false; - - if (!scalar_check (mask, 0)) - return false; - - return true; -} - - -bool -gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) -{ - if (!type_check (mask, 0, BT_INTEGER)) - return false; - - if (!scalar_check (mask, 0)) - return false; - - if (old == NULL) - return true; - - if (!scalar_check (old, 1)) - return false; - - if (!type_check (old, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_unlink (gfc_expr *name) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - return true; -} - - -bool -gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) -{ - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (status == NULL) - return true; - - if (!scalar_check (status, 1)) - return false; - - if (!type_check (status, 1, BT_INTEGER)) - return false; - - return true; -} - - -bool -gfc_check_signal (gfc_expr *number, gfc_expr *handler) -{ - if (!scalar_check (number, 0)) - return false; - if (!type_check (number, 0, BT_INTEGER)) - return false; - - if (!int_or_proc_check (handler, 1)) - return false; - if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) - return false; - - return true; -} - - -bool -gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) -{ - if (!scalar_check (number, 0)) - return false; - if (!type_check (number, 0, BT_INTEGER)) - return false; - - if (!int_or_proc_check (handler, 1)) - return false; - if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) - return false; - - if (status == NULL) - return true; - - if (!type_check (status, 2, BT_INTEGER)) - return false; - if (!scalar_check (status, 2)) - return false; - - return true; -} - - -bool -gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) -{ - if (!type_check (cmd, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (cmd, 0, gfc_default_character_kind)) - return false; - - if (!scalar_check (status, 1)) - return false; - - if (!type_check (status, 1, BT_INTEGER)) - return false; - - if (!kind_value_check (status, 1, gfc_default_integer_kind)) - return false; - - return true; -} - - -/* This is used for the GNU intrinsics AND, OR and XOR. */ -bool -gfc_check_and (gfc_expr *i, gfc_expr *j) -{ - if (i->ts.type != BT_INTEGER - && i->ts.type != BT_LOGICAL - && i->ts.type != BT_BOZ) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " - "LOGICAL, or a BOZ literal constant", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &i->where); - return false; - } - - if (j->ts.type != BT_INTEGER - && j->ts.type != BT_LOGICAL - && j->ts.type != BT_BOZ) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " - "LOGICAL, or a BOZ literal constant", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &j->where); - return false; - } - - /* i and j cannot both be BOZ literal constants. */ - if (!boz_args_check (i, j)) - return false; - - /* If i is BOZ and j is integer, convert i to type of j. */ - if (i->ts.type == BT_BOZ) - { - if (j->ts.type != BT_INTEGER) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic, &j->where); - reset_boz (i); - return false; - } - if (!gfc_boz2int (i, j->ts.kind)) - return false; - } - - /* If j is BOZ and i is integer, convert j to type of i. */ - if (j->ts.type == BT_BOZ) - { - if (i->ts.type != BT_INTEGER) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &j->where); - reset_boz (j); - return false; - } - if (!gfc_boz2int (j, i->ts.kind)) - return false; - } - - if (!same_type_check (i, 0, j, 1, false)) - return false; - - if (!scalar_check (i, 0)) - return false; - - if (!scalar_check (j, 1)) - return false; - - return true; -} - - -bool -gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) -{ - - if (a->expr_type == EXPR_NULL) - { - gfc_error ("Intrinsic function NULL at %L cannot be an actual " - "argument to STORAGE_SIZE, because it returns a " - "disassociated pointer", &a->where); - return false; - } - - if (a->ts.type == BT_ASSUMED) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &a->where); - return false; - } - - if (a->ts.type == BT_PROCEDURE) - { - gfc_error ("%qs argument of %qs intrinsic at %L shall not be a " - "procedure", gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic, &a->where); - return false; - } - - if (a->ts.type == BT_BOZ && illegal_boz_arg (a)) - return false; - - if (kind == NULL) - return true; - - if (!type_check (kind, 1, BT_INTEGER)) - return false; - - if (!scalar_check (kind, 1)) - return false; - - if (kind->expr_type != EXPR_CONSTANT) - { - gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &kind->where); - return false; - } - - return true; -} diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc new file mode 100644 index 0000000..053f856 --- /dev/null +++ b/gcc/fortran/check.cc @@ -0,0 +1,7523 @@ +/* Check functions + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +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 +. */ + + +/* These functions check to see if an argument list is compatible with + a particular intrinsic function or subroutine. Presence of + required arguments has already been established, the argument list + has been sorted into the right order and has NULL arguments in the + correct places for missing optional arguments. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "intrinsic.h" +#include "constructor.h" +#include "target-memory.h" + + +/* Reset a BOZ to a zero value. This is used to prevent run-on errors + from resolve.c(resolve_function). */ + +static void +reset_boz (gfc_expr *x) +{ + /* Clear boz info. */ + x->boz.rdx = 0; + x->boz.len = 0; + free (x->boz.str); + + x->ts.type = BT_INTEGER; + x->ts.kind = gfc_default_integer_kind; + mpz_init (x->value.integer); + mpz_set_ui (x->value.integer, 0); +} + +/* A BOZ literal constant can appear in a limited number of contexts. + gfc_invalid_boz() is a helper function to simplify error/warning + generation. gfortran accepts the nonstandard 'X' for 'Z', and gfortran + allows the BOZ indicator to appear as a suffix. If -fallow-invalid-boz + is used, then issue a warning; otherwise issue an error. */ + +bool +gfc_invalid_boz (const char *msg, locus *loc) +{ + if (flag_allow_invalid_boz) + { + gfc_warning (0, msg, loc); + return false; + } + + const char *hint = _(" [see %<-fno-allow-invalid-boz%>]"); + size_t len = strlen (msg) + strlen (hint) + 1; + char *msg2 = (char *) alloca (len); + strcpy (msg2, msg); + strcat (msg2, hint); + gfc_error (msg2, loc); + return true; +} + + +/* Issue an error for an illegal BOZ argument. */ + +static bool +illegal_boz_arg (gfc_expr *x) +{ + if (x->ts.type == BT_BOZ) + { + gfc_error ("BOZ literal constant at %L cannot be an actual argument " + "to %qs", &x->where, gfc_current_intrinsic); + reset_boz (x); + return true; + } + + return false; +} + +/* Some precedures take two arguments such that both cannot be BOZ. */ + +static bool +boz_args_check(gfc_expr *i, gfc_expr *j) +{ + if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ) + { + gfc_error ("Arguments of %qs at %L and %L cannot both be BOZ " + "literal constants", gfc_current_intrinsic, &i->where, + &j->where); + reset_boz (i); + reset_boz (j); + return false; + + } + + return true; +} + + +/* Check that a BOZ is a constant. */ + +static bool +is_boz_constant (gfc_expr *a) +{ + if (a->expr_type != EXPR_CONSTANT) + { + gfc_error ("Invalid use of BOZ literal constant at %L", &a->where); + return false; + } + + return true; +} + + +/* Convert a octal string into a binary string. This is used in the + fallback conversion of an octal string to a REAL. */ + +static char * +oct2bin(int nbits, char *oct) +{ + const char bits[8][5] = { + "000", "001", "010", "011", "100", "101", "110", "111"}; + + char *buf, *bufp; + int i, j, n; + + j = nbits + 1; + if (nbits == 64) j++; + + bufp = buf = XCNEWVEC (char, j + 1); + memset (bufp, 0, j + 1); + + n = strlen (oct); + for (i = 0; i < n; i++, oct++) + { + j = *oct - 48; + strcpy (bufp, &bits[j][0]); + bufp += 3; + } + + bufp = XCNEWVEC (char, nbits + 1); + if (nbits == 64) + strcpy (bufp, buf + 2); + else + strcpy (bufp, buf + 1); + + free (buf); + + return bufp; +} + + +/* Convert a hexidecimal string into a binary string. This is used in the + fallback conversion of a hexidecimal string to a REAL. */ + +static char * +hex2bin(int nbits, char *hex) +{ + const char bits[16][5] = { + "0000", "0001", "0010", "0011", "0100", "0101", "0110", "0111", + "1000", "1001", "1010", "1011", "1100", "1101", "1110", "1111"}; + + char *buf, *bufp; + int i, j, n; + + bufp = buf = XCNEWVEC (char, nbits + 1); + memset (bufp, 0, nbits + 1); + + n = strlen (hex); + for (i = 0; i < n; i++, hex++) + { + j = *hex; + if (j > 47 && j < 58) + j -= 48; + else if (j > 64 && j < 71) + j -= 55; + else if (j > 96 && j < 103) + j -= 87; + else + gcc_unreachable (); + + strcpy (bufp, &bits[j][0]); + bufp += 4; + } + + return buf; +} + + +/* Fallback conversion of a BOZ string to REAL. */ + +static void +bin2real (gfc_expr *x, int kind) +{ + char buf[114], *sp; + int b, i, ie, t, w; + bool sgn; + mpz_t em; + + i = gfc_validate_kind (BT_REAL, kind, false); + t = gfc_real_kinds[i].digits - 1; + + /* Number of bits in the exponent. */ + if (gfc_real_kinds[i].max_exponent == 16384) + w = 15; + else if (gfc_real_kinds[i].max_exponent == 1024) + w = 11; + else + w = 8; + + if (x->boz.rdx == 16) + sp = hex2bin (gfc_real_kinds[i].mode_precision, x->boz.str); + else if (x->boz.rdx == 8) + sp = oct2bin (gfc_real_kinds[i].mode_precision, x->boz.str); + else + sp = x->boz.str; + + /* Extract sign bit. */ + sgn = *sp != '0'; + + /* Extract biased exponent. */ + memset (buf, 0, 114); + strncpy (buf, ++sp, w); + mpz_init (em); + mpz_set_str (em, buf, 2); + ie = mpz_get_si (em); + + mpfr_init2 (x->value.real, t + 1); + x->ts.type = BT_REAL; + x->ts.kind = kind; + + sp += w; /* Set to first digit in significand. */ + b = (1 << w) - 1; + if ((i == 0 && ie == b) || (i == 1 && ie == b) + || ((i == 2 || i == 3) && ie == b)) + { + bool zeros = true; + if (i == 2) sp++; + for (; *sp; sp++) + { + if (*sp != '0') + { + zeros = false; + break; + } + } + + if (zeros) + mpfr_set_inf (x->value.real, 1); + else + mpfr_set_nan (x->value.real); + } + else + { + if (i == 2) + strncpy (buf, sp, t + 1); + else + { + /* Significand with hidden bit. */ + buf[0] = '1'; + strncpy (&buf[1], sp, t); + } + + /* Convert to significand to integer. */ + mpz_set_str (em, buf, 2); + ie -= ((1 << (w - 1)) - 1); /* Unbiased exponent. */ + mpfr_set_z_2exp (x->value.real, em, ie - t, GFC_RND_MODE); + } + + if (sgn) mpfr_neg (x->value.real, x->value.real, GFC_RND_MODE); + + mpz_clear (em); +} + + +/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2real () + converts the string into a REAL of the appropriate kind. The treatment + of the sign bit is processor dependent. */ + +bool +gfc_boz2real (gfc_expr *x, int kind) +{ + extern int gfc_max_integer_kind; + gfc_typespec ts; + int len; + char *buf, *str; + + if (!is_boz_constant (x)) + return false; + + /* Determine the length of the required string. */ + len = 8 * kind; + if (x->boz.rdx == 16) len /= 4; + if (x->boz.rdx == 8) len = len / 3 + 1; + buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */ + + if (x->boz.len >= len) /* Truncate if necessary. */ + { + str = x->boz.str + (x->boz.len - len); + strcpy(buf, str); + } + else /* Copy and pad. */ + { + memset (buf, 48, len); + str = buf + (len - x->boz.len); + strcpy (str, x->boz.str); + } + + /* Need to adjust leading bits in an octal string. */ + if (x->boz.rdx == 8) + { + /* Clear first bit. */ + if (kind == 4 || kind == 10 || kind == 16) + { + if (buf[0] == '4') + buf[0] = '0'; + else if (buf[0] == '5') + buf[0] = '1'; + else if (buf[0] == '6') + buf[0] = '2'; + else if (buf[0] == '7') + buf[0] = '3'; + } + /* Clear first two bits. */ + else + { + if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6') + buf[0] = '0'; + else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7') + buf[0] = '1'; + } + } + + /* Reset BOZ string to the truncated or padded version. */ + free (x->boz.str); + x->boz.len = len; + x->boz.str = XCNEWVEC (char, len + 1); + strncpy (x->boz.str, buf, len); + + /* For some targets, the largest INTEGER in terms of bits is smaller than + the bits needed to hold the REAL. Fortunately, the kind type parameter + indicates the number of bytes required to an INTEGER and a REAL. */ + if (gfc_max_integer_kind < kind) + { + bin2real (x, kind); + } + else + { + /* Convert to widest possible integer. */ + gfc_boz2int (x, gfc_max_integer_kind); + ts.type = BT_REAL; + ts.kind = kind; + if (!gfc_convert_boz (x, &ts)) + { + gfc_error ("Failure in conversion of BOZ to REAL at %L", &x->where); + return false; + } + } + + return true; +} + + +/* Fortran 2018 treats a BOZ as simply a string of bits. gfc_boz2int () + converts the string into an INTEGER of the appropriate kind. The + treatment of the sign bit is processor dependent. If the converted + value exceeds the range of the type, then wrap-around semantics are + applied. */ + +bool +gfc_boz2int (gfc_expr *x, int kind) +{ + int i, len; + char *buf, *str; + mpz_t tmp1; + + if (!is_boz_constant (x)) + return false; + + i = gfc_validate_kind (BT_INTEGER, kind, false); + len = gfc_integer_kinds[i].bit_size; + if (x->boz.rdx == 16) len /= 4; + if (x->boz.rdx == 8) len = len / 3 + 1; + buf = (char *) alloca (len + 1); /* +1 for NULL terminator. */ + + if (x->boz.len >= len) /* Truncate if necessary. */ + { + str = x->boz.str + (x->boz.len - len); + strcpy(buf, str); + } + else /* Copy and pad. */ + { + memset (buf, 48, len); + str = buf + (len - x->boz.len); + strcpy (str, x->boz.str); + } + + /* Need to adjust leading bits in an octal string. */ + if (x->boz.rdx == 8) + { + /* Clear first bit. */ + if (kind == 1 || kind == 4 || kind == 16) + { + if (buf[0] == '4') + buf[0] = '0'; + else if (buf[0] == '5') + buf[0] = '1'; + else if (buf[0] == '6') + buf[0] = '2'; + else if (buf[0] == '7') + buf[0] = '3'; + } + /* Clear first two bits. */ + else + { + if (buf[0] == '2' || buf[0] == '4' || buf[0] == '6') + buf[0] = '0'; + else if (buf[0] == '3' || buf[0] == '5' || buf[0] == '7') + buf[0] = '1'; + } + } + + /* Convert as-if unsigned integer. */ + mpz_init (tmp1); + mpz_set_str (tmp1, buf, x->boz.rdx); + + /* Check for wrap-around. */ + if (mpz_cmp (tmp1, gfc_integer_kinds[i].huge) > 0) + { + mpz_t tmp2; + mpz_init (tmp2); + mpz_add_ui (tmp2, gfc_integer_kinds[i].huge, 1); + mpz_mod (tmp1, tmp1, tmp2); + mpz_sub (tmp1, tmp1, tmp2); + mpz_clear (tmp2); + } + + /* Clear boz info. */ + x->boz.rdx = 0; + x->boz.len = 0; + free (x->boz.str); + + mpz_init (x->value.integer); + mpz_set (x->value.integer, tmp1); + x->ts.type = BT_INTEGER; + x->ts.kind = kind; + mpz_clear (tmp1); + + return true; +} + + +/* Make sure an expression is a scalar. */ + +static bool +scalar_check (gfc_expr *e, int n) +{ + if (e->rank == 0) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be a scalar", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + + return false; +} + + +/* Check the type of an expression. */ + +static bool +type_check (gfc_expr *e, int n, bt type) +{ + if (e->ts.type == type) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be %s", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where, gfc_basic_typename (type)); + + return false; +} + + +/* Check that the expression is a numeric type. */ + +static bool +numeric_check (gfc_expr *e, int n) +{ + /* Users sometime use a subroutine designator as an actual argument to + an intrinsic subprogram that expects an argument with a numeric type. */ + if (e->symtree && e->symtree->n.sym->attr.subroutine) + goto error; + + if (gfc_numeric_ts (&e->ts)) + return true; + + /* If the expression has not got a type, check if its namespace can + offer a default type. */ + if ((e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION) + && e->symtree->n.sym->ts.type == BT_UNKNOWN + && gfc_set_default_type (e->symtree->n.sym, 0, e->symtree->n.sym->ns) + && gfc_numeric_ts (&e->symtree->n.sym->ts)) + { + e->ts = e->symtree->n.sym->ts; + return true; + } + +error: + + gfc_error ("%qs argument of %qs intrinsic at %L must have a numeric type", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + + return false; +} + + +/* Check that an expression is integer or real. */ + +static bool +int_or_real_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " + "or REAL", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; + } + + return true; +} + +/* Check that an expression is integer or real; allow character for + F2003 or later. */ + +static bool +int_or_real_or_char_check_f2003 (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) + { + if (e->ts.type == BT_CHARACTER) + return gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Character for " + "%qs argument of %qs intrinsic at %L", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + else + { + if (gfc_option.allow_std & GFC_STD_F2003) + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " + "or REAL or CHARACTER", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + else + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " + "or REAL", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + } + return false; + } + + return true; +} + +/* Check that an expression is an intrinsic type. */ +static bool +intrinsic_type_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL + && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER + && e->ts.type != BT_LOGICAL) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; + } + return true; +} + +/* Check that an expression is real or complex. */ + +static bool +real_or_complex_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be REAL " + "or COMPLEX", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; + } + + return true; +} + + +/* Check that an expression is INTEGER or PROCEDURE. */ + +static bool +int_or_proc_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_INTEGER && e->ts.type != BT_PROCEDURE) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER " + "or PROCEDURE", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; + } + + return true; +} + + +/* Check that the expression is an optional constant integer + and that it specifies a valid kind for that type. */ + +static bool +kind_check (gfc_expr *k, int n, bt type) +{ + int kind; + + if (k == NULL) + return true; + + if (!type_check (k, n, BT_INTEGER)) + return false; + + if (!scalar_check (k, n)) + return false; + + if (!gfc_check_init_expr (k)) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &k->where); + return false; + } + + if (gfc_extract_int (k, &kind) + || gfc_validate_kind (type, kind, true) < 0) + { + gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), + &k->where); + return false; + } + + return true; +} + + +/* Make sure the expression is a double precision real. */ + +static bool +double_check (gfc_expr *d, int n) +{ + if (!type_check (d, n, BT_REAL)) + return false; + + if (d->ts.kind != gfc_default_double_kind) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be double " + "precision", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &d->where); + return false; + } + + return true; +} + + +static bool +coarray_check (gfc_expr *e, int n) +{ + if (e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok + && CLASS_DATA (e)->attr.codimension + && CLASS_DATA (e)->as->corank) + { + gfc_add_class_array_ref (e); + return true; + } + + if (!gfc_is_coarray (e)) + { + gfc_error ("Expected coarray variable as %qs argument to the %s " + "intrinsic at %L", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; + } + + return true; +} + + +/* Make sure the expression is a logical array. */ + +static bool +logical_array_check (gfc_expr *array, int n) +{ + if (array->ts.type != BT_LOGICAL || array->rank == 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a logical " + "array", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &array->where); + return false; + } + + return true; +} + + +/* Make sure an expression is an array. */ + +static bool +array_check (gfc_expr *e, int n) +{ + if (e->rank != 0 && e->ts.type == BT_CLASS && gfc_expr_attr (e).class_ok + && CLASS_DATA (e)->attr.dimension + && CLASS_DATA (e)->as->rank) + { + gfc_add_class_array_ref (e); + } + + if (e->rank != 0 && e->ts.type != BT_PROCEDURE) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be an array", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + + return false; +} + + +/* If expr is a constant, then check to ensure that it is greater than + of equal to zero. */ + +static bool +nonnegative_check (const char *arg, gfc_expr *expr) +{ + int i; + + if (expr->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr, &i); + if (i < 0) + { + gfc_error ("%qs at %L must be nonnegative", arg, &expr->where); + return false; + } + } + + return true; +} + + +/* If expr is a constant, then check to ensure that it is greater than zero. */ + +static bool +positive_check (int n, gfc_expr *expr) +{ + int i; + + if (expr->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr, &i); + if (i <= 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be positive", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &expr->where); + return false; + } + } + + return true; +} + + +/* If expr2 is constant, then check that the value is less than + (less than or equal to, if 'or_equal' is true) bit_size(expr1). */ + +static bool +less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2, bool or_equal) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + + /* For ISHFT[C], check that |shift| <= bit_size(i). */ + if (arg2 == NULL) + { + if (i2 < 0) + i2 = -i2; + + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("The absolute value of SHIFT at %L must be less " + "than or equal to BIT_SIZE(%qs)", + &expr2->where, arg1); + return false; + } + } + + if (or_equal) + { + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("%qs at %L must be less than " + "or equal to BIT_SIZE(%qs)", + arg2, &expr2->where, arg1); + return false; + } + } + else + { + if (i2 >= gfc_integer_kinds[i3].bit_size) + { + gfc_error ("%qs at %L must be less than BIT_SIZE(%qs)", + arg2, &expr2->where, arg1); + return false; + } + } + } + + return true; +} + + +/* If expr is constant, then check that the value is less than or equal + to the bit_size of the kind k. */ + +static bool +less_than_bitsizekind (const char *arg, gfc_expr *expr, int k) +{ + int i, val; + + if (expr->expr_type != EXPR_CONSTANT) + return true; + + i = gfc_validate_kind (BT_INTEGER, k, false); + gfc_extract_int (expr, &val); + + if (val > gfc_integer_kinds[i].bit_size) + { + gfc_error ("%qs at %L must be less than or equal to the BIT_SIZE of " + "INTEGER(KIND=%d)", arg, &expr->where, k); + return false; + } + + return true; +} + + +/* If expr2 and expr3 are constants, then check that the value is less than + or equal to bit_size(expr1). */ + +static bool +less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2, const char *arg3, gfc_expr *expr3) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + gfc_extract_int (expr3, &i3); + i2 += i3; + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("%<%s + %s%> at %L must be less than or equal " + "to BIT_SIZE(%qs)", + arg2, arg3, &expr2->where, arg1); + return false; + } + } + + return true; +} + +/* Make sure two expressions have the same type. */ + +static bool +same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false) +{ + gfc_typespec *ets = &e->ts; + gfc_typespec *fts = &f->ts; + + if (assoc) + { + /* Procedure pointer component expressions have the type of the interface + procedure. If they are being tested for association with a procedure + pointer (ie. not a component), the type of the procedure must be + determined. */ + if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) + ets = &e->symtree->n.sym->ts; + if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) + fts = &f->symtree->n.sym->ts; + } + + if (gfc_compare_types (ets, fts)) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be the same type " + "and kind as %qs", gfc_current_intrinsic_arg[m]->name, + gfc_current_intrinsic, &f->where, + gfc_current_intrinsic_arg[n]->name); + + return false; +} + + +/* Make sure that an expression has a certain (nonzero) rank. */ + +static bool +rank_check (gfc_expr *e, int n, int rank) +{ + if (e->rank == rank) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be of rank %d", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where, rank); + + return false; +} + + +/* Make sure a variable expression is not an optional dummy argument. */ + +static bool +nonoptional_check (gfc_expr *e, int n) +{ + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) + { + gfc_error ("%qs argument of %qs intrinsic at %L must not be OPTIONAL", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + } + + /* TODO: Recursive check on nonoptional variables? */ + + return true; +} + + +/* Check for ALLOCATABLE attribute. */ + +static bool +allocatable_check (gfc_expr *e, int n) +{ + symbol_attribute attr; + + attr = gfc_variable_attr (e, NULL); + if (!attr.allocatable + || (attr.associate_var && !attr.select_rank_temporary)) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be ALLOCATABLE", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + return false; + } + + return true; +} + + +/* Check that an expression has a particular kind. */ + +static bool +kind_value_check (gfc_expr *e, int n, int k) +{ + if (e->ts.kind == k) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be of kind %d", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where, k); + + return false; +} + + +/* Make sure an expression is a variable. */ + +static bool +variable_check (gfc_expr *e, int n, bool allow_proc) +{ + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.intent == INTENT_IN + && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT + || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT) + && !gfc_check_vardef_context (e, false, true, false, NULL)) + { + gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; + } + + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor != FL_PARAMETER + && (allow_proc || !e->symtree->n.sym->attr.function)) + return true; + + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.function + && e->symtree->n.sym == e->symtree->n.sym->result) + { + gfc_namespace *ns; + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (ns->proc_name == e->symtree->n.sym) + return true; + } + + /* F2018:R902: function reference having a data pointer result. */ + if (e->expr_type == EXPR_FUNCTION + && e->symtree->n.sym->attr.flavor == FL_PROCEDURE + && e->symtree->n.sym->attr.function + && e->symtree->n.sym->attr.pointer) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must be a variable", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, &e->where); + + return false; +} + + +/* Check the common DIM parameter for correctness. */ + +static bool +dim_check (gfc_expr *dim, int n, bool optional) +{ + if (dim == NULL) + return true; + + if (!type_check (dim, n, BT_INTEGER)) + return false; + + if (!scalar_check (dim, n)) + return false; + + if (!optional && !nonoptional_check (dim, n)) + return false; + + return true; +} + + +/* If a coarray DIM parameter is a constant, make sure that it is greater than + zero and less than or equal to the corank of the given array. */ + +static bool +dim_corank_check (gfc_expr *dim, gfc_expr *array) +{ + int corank; + + gcc_assert (array->expr_type == EXPR_VARIABLE); + + if (dim->expr_type != EXPR_CONSTANT) + return true; + + if (array->ts.type == BT_CLASS) + return true; + + corank = gfc_get_corank (array); + + if (mpz_cmp_ui (dim->value.integer, 1) < 0 + || mpz_cmp_ui (dim->value.integer, corank) > 0) + { + gfc_error ("% argument of %qs intrinsic at %L is not a valid " + "codimension index", gfc_current_intrinsic, &dim->where); + + return false; + } + + return true; +} + + +/* If a DIM parameter is a constant, make sure that it is greater than + zero and less than or equal to the rank of the given array. If + allow_assumed is zero then dim must be less than the rank of the array + for assumed size arrays. */ + +static bool +dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) +{ + gfc_array_ref *ar; + int rank; + + if (dim == NULL) + return true; + + if (dim->expr_type != EXPR_CONSTANT) + return true; + + if (array->expr_type == EXPR_FUNCTION && array->value.function.isym + && array->value.function.isym->id == GFC_ISYM_SPREAD) + rank = array->rank + 1; + else + rank = array->rank; + + /* Assumed-rank array. */ + if (rank == -1) + rank = GFC_MAX_DIMENSIONS; + + if (array->expr_type == EXPR_VARIABLE) + { + ar = gfc_find_array_ref (array, true); + if (!ar) + return false; + if (ar->as->type == AS_ASSUMED_SIZE + && !allow_assumed + && ar->type != AR_ELEMENT + && ar->type != AR_SECTION) + rank--; + } + + if (mpz_cmp_ui (dim->value.integer, 1) < 0 + || mpz_cmp_ui (dim->value.integer, rank) > 0) + { + gfc_error ("% argument of %qs intrinsic at %L is not a valid " + "dimension index", gfc_current_intrinsic, &dim->where); + + return false; + } + + return true; +} + + +/* Compare the size of a along dimension ai with the size of b along + dimension bi, returning 0 if they are known not to be identical, + and 1 if they are identical, or if this cannot be determined. */ + +static int +identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) +{ + mpz_t a_size, b_size; + int ret; + + gcc_assert (a->rank > ai); + gcc_assert (b->rank > bi); + + ret = 1; + + if (gfc_array_dimen_size (a, ai, &a_size)) + { + if (gfc_array_dimen_size (b, bi, &b_size)) + { + if (mpz_cmp (a_size, b_size) != 0) + ret = 0; + + mpz_clear (b_size); + } + mpz_clear (a_size); + } + return ret; +} + +/* Calculate the length of a character variable, including substrings. + Strip away parentheses if necessary. Return -1 if no length could + be determined. */ + +static long +gfc_var_strlen (const gfc_expr *a) +{ + gfc_ref *ra; + + while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES) + a = a->value.op.op1; + + for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next) + ; + + if (ra) + { + long start_a, end_a; + + if (!ra->u.ss.end) + return -1; + + if ((!ra->u.ss.start || ra->u.ss.start->expr_type == EXPR_CONSTANT) + && ra->u.ss.end->expr_type == EXPR_CONSTANT) + { + start_a = ra->u.ss.start ? mpz_get_si (ra->u.ss.start->value.integer) + : 1; + end_a = mpz_get_si (ra->u.ss.end->value.integer); + return (end_a < start_a) ? 0 : end_a - start_a + 1; + } + else if (ra->u.ss.start + && gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0) + return 1; + else + return -1; + } + + if (a->ts.u.cl && a->ts.u.cl->length + && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) + return mpz_get_si (a->ts.u.cl->length->value.integer); + else if (a->expr_type == EXPR_CONSTANT + && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) + return a->value.character.length; + else + return -1; + +} + +/* Check whether two character expressions have the same length; + returns true if they have or if the length cannot be determined, + otherwise return false and raise a gfc_error. */ + +bool +gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) +{ + long len_a, len_b; + + len_a = gfc_var_strlen(a); + len_b = gfc_var_strlen(b); + + if (len_a == -1 || len_b == -1 || len_a == len_b) + return true; + else + { + gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L", + len_a, len_b, name, &a->where); + return false; + } +} + + +/***** Check functions *****/ + +/* Check subroutine suitable for intrinsics taking a real argument and + a kind argument for the result. */ + +static bool +check_a_kind (gfc_expr *a, gfc_expr *kind, bt type) +{ + if (!type_check (a, 0, BT_REAL)) + return false; + if (!kind_check (kind, 1, type)) + return false; + + return true; +} + + +/* Check subroutine suitable for ceiling, floor and nint. */ + +bool +gfc_check_a_ikind (gfc_expr *a, gfc_expr *kind) +{ + return check_a_kind (a, kind, BT_INTEGER); +} + + +/* Check subroutine suitable for aint, anint. */ + +bool +gfc_check_a_xkind (gfc_expr *a, gfc_expr *kind) +{ + return check_a_kind (a, kind, BT_REAL); +} + + +bool +gfc_check_abs (gfc_expr *a) +{ + if (!numeric_check (a, 0)) + return false; + + return true; +} + + +bool +gfc_check_achar (gfc_expr *a, gfc_expr *kind) +{ + if (a->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " + "ACHAR intrinsic subprogram"), &a->where)) + return false; + + if (!gfc_boz2int (a, gfc_default_integer_kind)) + return false; + } + + if (!type_check (a, 0, BT_INTEGER)) + return false; + + if (!kind_check (kind, 1, BT_CHARACTER)) + return false; + + return true; +} + + +bool +gfc_check_access_func (gfc_expr *name, gfc_expr *mode) +{ + if (!type_check (name, 0, BT_CHARACTER) + || !scalar_check (name, 0)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (!type_check (mode, 1, BT_CHARACTER) + || !scalar_check (mode, 1)) + return false; + if (!kind_value_check (mode, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_all_any (gfc_expr *mask, gfc_expr *dim) +{ + if (!logical_array_check (mask, 0)) + return false; + + if (!dim_check (dim, 1, false)) + return false; + + if (!dim_rank_check (dim, mask, 0)) + return false; + + return true; +} + + +/* Limited checking for ALLOCATED intrinsic. Additional checking + is performed in intrinsic.c(sort_actual), because ALLOCATED + has two mutually exclusive non-optional arguments. */ + +bool +gfc_check_allocated (gfc_expr *array) +{ + /* Tests on allocated components of coarrays need to detour the check to + argument of the _caf_get. */ + if (flag_coarray == GFC_FCOARRAY_LIB && array->expr_type == EXPR_FUNCTION + && array->value.function.isym + && array->value.function.isym->id == GFC_ISYM_CAF_GET) + { + array = array->value.function.actual->expr; + if (!array->ref) + return false; + } + + if (!variable_check (array, 0, false)) + return false; + if (!allocatable_check (array, 0)) + return false; + + return true; +} + + +/* Common check function where the first argument must be real or + integer and the second argument must be the same as the first. */ + +bool +gfc_check_a_p (gfc_expr *a, gfc_expr *p) +{ + if (!int_or_real_check (a, 0)) + return false; + + if (a->ts.type != p->ts.type) + { + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L must " + "have the same type", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &p->where); + return false; + } + + if (a->ts.kind != p->ts.kind) + { + if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", + &p->where)) + return false; + } + + return true; +} + + +bool +gfc_check_x_yd (gfc_expr *x, gfc_expr *y) +{ + if (!double_check (x, 0) || !double_check (y, 1)) + return false; + + return true; +} + +bool +gfc_invalid_null_arg (gfc_expr *x) +{ + if (x->expr_type == EXPR_NULL) + { + gfc_error ("NULL at %L is not permitted as actual argument " + "to %qs intrinsic function", &x->where, + gfc_current_intrinsic); + return true; + } + return false; +} + +bool +gfc_check_associated (gfc_expr *pointer, gfc_expr *target) +{ + symbol_attribute attr1, attr2; + int i; + bool t; + + if (gfc_invalid_null_arg (pointer)) + return false; + + attr1 = gfc_expr_attr (pointer); + + if (!attr1.pointer && !attr1.proc_pointer) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &pointer->where); + return false; + } + + /* F2008, C1242. */ + if (attr1.pointer && gfc_is_coindexed (pointer)) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " + "coindexed", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &pointer->where); + return false; + } + + /* Target argument is optional. */ + if (target == NULL) + return true; + + if (gfc_invalid_null_arg (target)) + return false; + + if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) + attr2 = gfc_expr_attr (target); + else + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a pointer " + "or target VARIABLE or FUNCTION", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &target->where); + return false; + } + + if (attr1.pointer && !attr2.pointer && !attr2.target) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER " + "or a TARGET", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &target->where); + return false; + } + + /* F2008, C1242. */ + if (attr1.pointer && gfc_is_coindexed (target)) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " + "coindexed", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &target->where); + return false; + } + + t = true; + if (!same_type_check (pointer, 0, target, 1, true)) + t = false; + /* F2018 C838 explicitly allows an assumed-rank variable as the first + argument of intrinsic inquiry functions. */ + if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank)) + t = false; + if (target->rank > 0) + { + for (i = 0; i < target->rank; i++) + if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + { + gfc_error ("Array section with a vector subscript at %L shall not " + "be the target of a pointer", + &target->where); + t = false; + break; + } + } + return t; +} + + +bool +gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) +{ + /* gfc_notify_std would be a waste of time as the return value + is seemingly used only for the generic resolution. The error + will be: Too many arguments. */ + if ((gfc_option.allow_std & GFC_STD_F2008) == 0) + return false; + + return gfc_check_atan2 (y, x); +} + + +bool +gfc_check_atan2 (gfc_expr *y, gfc_expr *x) +{ + if (!type_check (y, 0, BT_REAL)) + return false; + if (!same_type_check (y, 0, x, 1)) + return false; + + return true; +} + + +static bool +gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, + gfc_expr *stat, int stat_no) +{ + if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no)) + return false; + + if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind) + && !(atom->ts.type == BT_LOGICAL + && atom->ts.kind == gfc_atomic_logical_kind)) + { + gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " + "integer of ATOMIC_INT_KIND or a logical of " + "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic); + return false; + } + + if (!gfc_is_coarray (atom) && !gfc_is_coindexed (atom)) + { + gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a " + "coarray or coindexed", &atom->where, gfc_current_intrinsic); + return false; + } + + if (atom->ts.type != value->ts.type) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall have the same " + "type as %qs at %L", gfc_current_intrinsic_arg[val_no]->name, + gfc_current_intrinsic, &value->where, + gfc_current_intrinsic_arg[atom_no]->name, &atom->where); + return false; + } + + if (stat != NULL) + { + if (!type_check (stat, stat_no, BT_INTEGER)) + return false; + if (!scalar_check (stat, stat_no)) + return false; + if (!variable_check (stat, stat_no, false)) + return false; + if (!kind_value_check (stat, stat_no, gfc_default_integer_kind)) + return false; + + if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", + gfc_current_intrinsic, &stat->where)) + return false; + } + + return true; +} + + +bool +gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) +{ + if (atom->expr_type == EXPR_FUNCTION + && atom->value.function.isym + && atom->value.function.isym->id == GFC_ISYM_CAF_GET) + atom = atom->value.function.actual->expr; + + if (!gfc_check_vardef_context (atom, false, false, false, NULL)) + { + gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &atom->where); + return false; + } + + return gfc_check_atomic (atom, 0, value, 1, stat, 2); +} + + +bool +gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) +{ + if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) + { + gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " + "integer of ATOMIC_INT_KIND", &atom->where, + gfc_current_intrinsic); + return false; + } + + return gfc_check_atomic_def (atom, value, stat); +} + + +bool +gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) +{ + if (atom->expr_type == EXPR_FUNCTION + && atom->value.function.isym + && atom->value.function.isym->id == GFC_ISYM_CAF_GET) + atom = atom->value.function.actual->expr; + + if (!gfc_check_vardef_context (value, false, false, false, NULL)) + { + gfc_error ("VALUE argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &value->where); + return false; + } + + return gfc_check_atomic (atom, 1, value, 0, stat, 2); +} + + +bool +gfc_check_image_status (gfc_expr *image, gfc_expr *team) +{ + /* IMAGE has to be a positive, scalar integer. */ + if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0) + || !positive_check (0, image)) + return false; + + if (team) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &team->where); + return false; + } + return true; +} + + +bool +gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) +{ + if (team) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &team->where); + return false; + } + + if (kind) + { + int k; + + if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1) + || !positive_check (1, kind)) + return false; + + /* Get the kind, reporting error on non-constant or overflow. */ + gfc_current_locus = kind->where; + if (gfc_extract_int (kind, &k, 1)) + return false; + if (gfc_validate_kind (BT_INTEGER, k, true) == -1) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall specify a " + "valid integer kind", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &kind->where); + return false; + } + } + return true; +} + + +bool +gfc_check_get_team (gfc_expr *level) +{ + if (level) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &level->where); + return false; + } + return true; +} + + +bool +gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare, + gfc_expr *new_val, gfc_expr *stat) +{ + if (atom->expr_type == EXPR_FUNCTION + && atom->value.function.isym + && atom->value.function.isym->id == GFC_ISYM_CAF_GET) + atom = atom->value.function.actual->expr; + + if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4)) + return false; + + if (!scalar_check (old, 1) || !scalar_check (compare, 2)) + return false; + + if (!same_type_check (atom, 0, old, 1)) + return false; + + if (!same_type_check (atom, 0, compare, 2)) + return false; + + if (!gfc_check_vardef_context (atom, false, false, false, NULL)) + { + gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &atom->where); + return false; + } + + if (!gfc_check_vardef_context (old, false, false, false, NULL)) + { + gfc_error ("OLD argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &old->where); + return false; + } + + return true; +} + +bool +gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat) +{ + if (event->ts.type != BT_DERIVED + || event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE) + { + gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY " + "shall be of type EVENT_TYPE", &event->where); + return false; + } + + if (!scalar_check (event, 0)) + return false; + + if (!gfc_check_vardef_context (count, false, false, false, NULL)) + { + gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " + "shall be definable", &count->where); + return false; + } + + if (!type_check (count, 1, BT_INTEGER)) + return false; + + int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false); + int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); + + if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range) + { + gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L " + "shall have at least the range of the default integer", + &count->where); + return false; + } + + if (stat != NULL) + { + if (!type_check (stat, 2, BT_INTEGER)) + return false; + if (!scalar_check (stat, 2)) + return false; + if (!variable_check (stat, 2, false)) + return false; + + if (!gfc_notify_std (GFC_STD_F2018, "STAT= argument to %s at %L", + gfc_current_intrinsic, &stat->where)) + return false; + } + + return true; +} + + +bool +gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old, + gfc_expr *stat) +{ + if (atom->expr_type == EXPR_FUNCTION + && atom->value.function.isym + && atom->value.function.isym->id == GFC_ISYM_CAF_GET) + atom = atom->value.function.actual->expr; + + if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) + { + gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " + "integer of ATOMIC_INT_KIND", &atom->where, + gfc_current_intrinsic); + return false; + } + + if (!gfc_check_atomic (atom, 0, value, 1, stat, 3)) + return false; + + if (!scalar_check (old, 2)) + return false; + + if (!same_type_check (atom, 0, old, 2)) + return false; + + if (!gfc_check_vardef_context (atom, false, false, false, NULL)) + { + gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &atom->where); + return false; + } + + if (!gfc_check_vardef_context (old, false, false, false, NULL)) + { + gfc_error ("OLD argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &old->where); + return false; + } + + return true; +} + + +/* BESJN and BESYN functions. */ + +bool +gfc_check_besn (gfc_expr *n, gfc_expr *x) +{ + if (!type_check (n, 0, BT_INTEGER)) + return false; + if (n->expr_type == EXPR_CONSTANT) + { + int i; + gfc_extract_int (n, &i); + if (i < 0 && !gfc_notify_std (GFC_STD_GNU, "Negative argument " + "N at %L", &n->where)) + return false; + } + + if (!type_check (x, 1, BT_REAL)) + return false; + + return true; +} + + +/* Transformational version of the Bessel JN and YN functions. */ + +bool +gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x) +{ + if (!type_check (n1, 0, BT_INTEGER)) + return false; + if (!scalar_check (n1, 0)) + return false; + if (!nonnegative_check ("N1", n1)) + return false; + + if (!type_check (n2, 1, BT_INTEGER)) + return false; + if (!scalar_check (n2, 1)) + return false; + if (!nonnegative_check ("N2", n2)) + return false; + + if (!type_check (x, 2, BT_REAL)) + return false; + if (!scalar_check (x, 2)) + return false; + + return true; +} + + +bool +gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j) +{ + extern int gfc_max_integer_kind; + + /* If i and j are both BOZ, convert to widest INTEGER. */ + if (i->ts.type == BT_BOZ && j->ts.type == BT_BOZ) + { + if (!gfc_boz2int (i, gfc_max_integer_kind)) + return false; + if (!gfc_boz2int (j, gfc_max_integer_kind)) + return false; + } + + /* If i is BOZ and j is integer, convert i to type of j. */ + if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER + && !gfc_boz2int (i, j->ts.kind)) + return false; + + /* If j is BOZ and i is integer, convert j to type of i. */ + if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER + && !gfc_boz2int (j, i->ts.kind)) + return false; + + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (j, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) +{ + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (pos, 1, BT_INTEGER)) + return false; + + if (!nonnegative_check ("pos", pos)) + return false; + + if (!less_than_bitsize1 ("i", i, "pos", pos, false)) + return false; + + return true; +} + + +bool +gfc_check_char (gfc_expr *i, gfc_expr *kind) +{ + if (i->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " + "CHAR intrinsic subprogram"), &i->where)) + return false; + + if (!gfc_boz2int (i, gfc_default_integer_kind)) + return false; + } + + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!kind_check (kind, 1, BT_CHARACTER)) + return false; + + return true; +} + + +bool +gfc_check_chdir (gfc_expr *dir) +{ + if (!type_check (dir, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (dir, 0, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_chdir_sub (gfc_expr *dir, gfc_expr *status) +{ + if (!type_check (dir, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (dir, 0, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 1, BT_INTEGER)) + return false; + if (!scalar_check (status, 1)) + return false; + + return true; +} + + +bool +gfc_check_chmod (gfc_expr *name, gfc_expr *mode) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (!type_check (mode, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (mode, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_chmod_sub (gfc_expr *name, gfc_expr *mode, gfc_expr *status) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (!type_check (mode, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (mode, 1, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER)) + return false; + + if (!scalar_check (status, 2)) + return false; + + return true; +} + + +bool +gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) +{ + int k; + + /* Check kind first, because it may be needed in conversion of a BOZ. */ + if (kind) + { + if (!kind_check (kind, 2, BT_COMPLEX)) + return false; + gfc_extract_int (kind, &k); + } + else + k = gfc_default_complex_kind; + + if (x->ts.type == BT_BOZ && !gfc_boz2real (x, k)) + return false; + + if (!numeric_check (x, 0)) + return false; + + if (y != NULL) + { + if (y->ts.type == BT_BOZ && !gfc_boz2real (y, k)) + return false; + + if (!numeric_check (y, 1)) + return false; + + if (x->ts.type == BT_COMPLEX) + { + gfc_error ("%qs argument of %qs intrinsic at %L must not be " + "present if % is COMPLEX", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); + return false; + } + + if (y->ts.type == BT_COMPLEX) + { + gfc_error ("%qs argument of %qs intrinsic at %L must have a type " + "of either REAL or INTEGER", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); + return false; + } + } + + if (!kind && warn_conversion + && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind) + gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " + "COMPLEX(%d) at %L might lose precision, consider using " + "the KIND argument", gfc_typename (&x->ts), + gfc_default_real_kind, &x->where); + else if (y && !kind && warn_conversion + && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind) + gfc_warning_now (OPT_Wconversion, "Conversion from %s to default-kind " + "COMPLEX(%d) at %L might lose precision, consider using " + "the KIND argument", gfc_typename (&y->ts), + gfc_default_real_kind, &y->where); + return true; +} + + +static bool +check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat, + gfc_expr *errmsg, bool co_reduce) +{ + if (!variable_check (a, 0, false)) + return false; + + if (!gfc_check_vardef_context (a, false, false, false, "argument 'A' with " + "INTENT(INOUT)")) + return false; + + /* Fortran 2008, 12.5.2.4, paragraph 18. */ + if (gfc_has_vector_subscript (a)) + { + gfc_error ("Argument % with INTENT(INOUT) at %L of the intrinsic " + "subroutine %s shall not have a vector subscript", + &a->where, gfc_current_intrinsic); + return false; + } + + if (gfc_is_coindexed (a)) + { + gfc_error ("The A argument at %L to the intrinsic %s shall not be " + "coindexed", &a->where, gfc_current_intrinsic); + return false; + } + + if (image_idx != NULL) + { + if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER)) + return false; + if (!scalar_check (image_idx, co_reduce ? 2 : 1)) + return false; + } + + if (stat != NULL) + { + if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER)) + return false; + if (!scalar_check (stat, co_reduce ? 3 : 2)) + return false; + if (!variable_check (stat, co_reduce ? 3 : 2, false)) + return false; + if (stat->ts.kind != 4) + { + gfc_error ("The stat= argument at %L must be a kind=4 integer " + "variable", &stat->where); + return false; + } + } + + if (errmsg != NULL) + { + if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER)) + return false; + if (!scalar_check (errmsg, co_reduce ? 4 : 3)) + return false; + if (!variable_check (errmsg, co_reduce ? 4 : 3, false)) + return false; + if (errmsg->ts.kind != 1) + { + gfc_error ("The errmsg= argument at %L must be a default-kind " + "character variable", &errmsg->where); + return false; + } + } + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %L, use %<-fcoarray=%> to enable", + &a->where); + return false; + } + + return true; +} + + +bool +gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat, + gfc_expr *errmsg) +{ + if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp) + { + gfc_error ("Support for the A argument at %L which is polymorphic A " + "argument or has allocatable components is not yet " + "implemented", &a->where); + return false; + } + return check_co_collective (a, source_image, stat, errmsg, false); +} + + +bool +gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, + gfc_expr *stat, gfc_expr *errmsg) +{ + symbol_attribute attr; + gfc_formal_arglist *formal; + gfc_symbol *sym; + + if (a->ts.type == BT_CLASS) + { + gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", + &a->where); + return false; + } + + if (gfc_expr_attr (a).alloc_comp) + { + gfc_error ("Support for the A argument at %L with allocatable components" + " is not yet implemented", &a->where); + return false; + } + + if (!check_co_collective (a, result_image, stat, errmsg, true)) + return false; + + if (!gfc_resolve_expr (op)) + return false; + + attr = gfc_expr_attr (op); + if (!attr.pure || !attr.function) + { + gfc_error ("OPERATION argument at %L must be a PURE function", + &op->where); + return false; + } + + if (attr.intrinsic) + { + /* None of the intrinsics fulfills the criteria of taking two arguments, + returning the same type and kind as the arguments and being permitted + as actual argument. */ + gfc_error ("Intrinsic function %s at %L is not permitted for CO_REDUCE", + op->symtree->n.sym->name, &op->where); + return false; + } + + if (gfc_is_proc_ptr_comp (op)) + { + gfc_component *comp = gfc_get_proc_ptr_comp (op); + sym = comp->ts.interface; + } + else + sym = op->symtree->n.sym; + + formal = sym->formal; + + if (!formal || !formal->next || formal->next->next) + { + gfc_error ("The function passed as OPERATION at %L shall have two " + "arguments", &op->where); + return false; + } + + if (sym->result->ts.type == BT_UNKNOWN) + gfc_set_default_type (sym->result, 0, NULL); + + if (!gfc_compare_types (&a->ts, &sym->result->ts)) + { + gfc_error ("The A argument at %L has type %s but the function passed as " + "OPERATION at %L returns %s", + &a->where, gfc_typename (a), &op->where, + gfc_typename (&sym->result->ts)); + return false; + } + if (!gfc_compare_types (&a->ts, &formal->sym->ts) + || !gfc_compare_types (&a->ts, &formal->next->sym->ts)) + { + gfc_error ("The function passed as OPERATION at %L has arguments of type " + "%s and %s but shall have type %s", &op->where, + gfc_typename (&formal->sym->ts), + gfc_typename (&formal->next->sym->ts), gfc_typename (a)); + return false; + } + if (op->rank || attr.allocatable || attr.pointer || formal->sym->as + || formal->next->sym->as || formal->sym->attr.allocatable + || formal->next->sym->attr.allocatable || formal->sym->attr.pointer + || formal->next->sym->attr.pointer) + { + gfc_error ("The function passed as OPERATION at %L shall have scalar " + "nonallocatable nonpointer arguments and return a " + "nonallocatable nonpointer scalar", &op->where); + return false; + } + + if (formal->sym->attr.value != formal->next->sym->attr.value) + { + gfc_error ("The function passed as OPERATION at %L shall have the VALUE " + "attribute either for none or both arguments", &op->where); + return false; + } + + if (formal->sym->attr.target != formal->next->sym->attr.target) + { + gfc_error ("The function passed as OPERATION at %L shall have the TARGET " + "attribute either for none or both arguments", &op->where); + return false; + } + + if (formal->sym->attr.asynchronous != formal->next->sym->attr.asynchronous) + { + gfc_error ("The function passed as OPERATION at %L shall have the " + "ASYNCHRONOUS attribute either for none or both arguments", + &op->where); + return false; + } + + if (formal->sym->attr.optional || formal->next->sym->attr.optional) + { + gfc_error ("The function passed as OPERATION at %L shall not have the " + "OPTIONAL attribute for either of the arguments", &op->where); + return false; + } + + if (a->ts.type == BT_CHARACTER) + { + gfc_charlen *cl; + unsigned long actual_size, formal_size1, formal_size2, result_size; + + cl = a->ts.u.cl; + actual_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT + ? mpz_get_ui (cl->length->value.integer) : 0; + + cl = formal->sym->ts.u.cl; + formal_size1 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT + ? mpz_get_ui (cl->length->value.integer) : 0; + + cl = formal->next->sym->ts.u.cl; + formal_size2 = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT + ? mpz_get_ui (cl->length->value.integer) : 0; + + cl = sym->ts.u.cl; + result_size = cl && cl->length && cl->length->expr_type == EXPR_CONSTANT + ? mpz_get_ui (cl->length->value.integer) : 0; + + if (actual_size + && ((formal_size1 && actual_size != formal_size1) + || (formal_size2 && actual_size != formal_size2))) + { + gfc_error ("The character length of the A argument at %L and of the " + "arguments of the OPERATION at %L shall be the same", + &a->where, &op->where); + return false; + } + if (actual_size && result_size && actual_size != result_size) + { + gfc_error ("The character length of the A argument at %L and of the " + "function result of the OPERATION at %L shall be the same", + &a->where, &op->where); + return false; + } + } + + return true; +} + + +bool +gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, + gfc_expr *errmsg) +{ + if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL + && a->ts.type != BT_CHARACTER) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " + "integer, real or character", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); + return false; + } + return check_co_collective (a, result_image, stat, errmsg, false); +} + + +bool +gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, + gfc_expr *errmsg) +{ + if (!numeric_check (a, 0)) + return false; + return check_co_collective (a, result_image, stat, errmsg, false); +} + + +bool +gfc_check_complex (gfc_expr *x, gfc_expr *y) +{ + if (!boz_args_check (x, y)) + return false; + + if (x->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" + " intrinsic subprogram"), &x->where)) + { + reset_boz (x); + return false; + } + if (y->ts.type == BT_INTEGER && !gfc_boz2int (x, y->ts.kind)) + return false; + if (y->ts.type == BT_REAL && !gfc_boz2real (x, y->ts.kind)) + return false; + } + + if (y->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" + " intrinsic subprogram"), &y->where)) + { + reset_boz (y); + return false; + } + if (x->ts.type == BT_INTEGER && !gfc_boz2int (y, x->ts.kind)) + return false; + if (x->ts.type == BT_REAL && !gfc_boz2real (y, x->ts.kind)) + return false; + } + + if (!int_or_real_check (x, 0)) + return false; + if (!scalar_check (x, 0)) + return false; + + if (!int_or_real_check (y, 1)) + return false; + if (!scalar_check (y, 1)) + return false; + + return true; +} + + +bool +gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) +{ + if (!logical_array_check (mask, 0)) + return false; + if (!dim_check (dim, 1, false)) + return false; + if (!dim_rank_check (dim, mask, 0)) + return false; + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + return true; +} + + +bool +gfc_check_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) +{ + if (!array_check (array, 0)) + return false; + + if (!type_check (shift, 1, BT_INTEGER)) + return false; + + if (!dim_check (dim, 2, true)) + return false; + + if (!dim_rank_check (dim, array, false)) + return false; + + if (array->rank == 1 || shift->rank == 0) + { + if (!scalar_check (shift, 1)) + return false; + } + else if (shift->rank == array->rank - 1) + { + int d; + if (!dim) + d = 1; + else if (dim->expr_type == EXPR_CONSTANT) + gfc_extract_int (dim, &d); + else + d = -1; + + if (d > 0) + { + int i, j; + for (i = 0, j = 0; i < array->rank; i++) + if (i != d - 1) + { + if (!identical_dimen_shape (array, i, shift, j)) + { + gfc_error ("%qs argument of %qs intrinsic at %L has " + "invalid shape in dimension %d (%ld/%ld)", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &shift->where, i + 1, + mpz_get_si (array->shape[i]), + mpz_get_si (shift->shape[j])); + return false; + } + + j += 1; + } + } + } + else + { + gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " + "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &shift->where, array->rank - 1); + return false; + } + + return true; +} + + +bool +gfc_check_ctime (gfc_expr *time) +{ + if (!scalar_check (time, 0)) + return false; + + if (!type_check (time, 0, BT_INTEGER)) + return false; + + return true; +} + + +bool gfc_check_datan2 (gfc_expr *y, gfc_expr *x) +{ + if (!double_check (y, 0) || !double_check (x, 1)) + return false; + + return true; +} + +bool +gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) +{ + if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind)) + return false; + + if (!numeric_check (x, 0)) + return false; + + if (y != NULL) + { + if (y->ts.type == BT_BOZ && !gfc_boz2real (y, gfc_default_double_kind)) + return false; + + if (!numeric_check (y, 1)) + return false; + + if (x->ts.type == BT_COMPLEX) + { + gfc_error ("%qs argument of %qs intrinsic at %L must not be " + "present if % is COMPLEX", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); + return false; + } + + if (y->ts.type == BT_COMPLEX) + { + gfc_error ("%qs argument of %qs intrinsic at %L must have a type " + "of either REAL or INTEGER", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &y->where); + return false; + } + } + + return true; +} + + +bool +gfc_check_dble (gfc_expr *x) +{ + if (x->ts.type == BT_BOZ && !gfc_boz2real (x, gfc_default_double_kind)) + return false; + + if (!numeric_check (x, 0)) + return false; + + return true; +} + + +bool +gfc_check_digits (gfc_expr *x) +{ + if (!int_or_real_check (x, 0)) + return false; + + return true; +} + + +bool +gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) +{ + switch (vector_a->ts.type) + { + case BT_LOGICAL: + if (!type_check (vector_b, 1, BT_LOGICAL)) + return false; + break; + + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + if (!numeric_check (vector_b, 1)) + return false; + break; + + default: + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &vector_a->where); + return false; + } + + if (!rank_check (vector_a, 0, 1)) + return false; + + if (!rank_check (vector_b, 1, 1)) + return false; + + if (! identical_dimen_shape (vector_a, 0, vector_b, 0)) + { + gfc_error ("Different shape for arguments %qs and %qs at %L for " + "intrinsic %", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &vector_a->where); + return false; + } + + return true; +} + + +bool +gfc_check_dprod (gfc_expr *x, gfc_expr *y) +{ + if (!type_check (x, 0, BT_REAL) + || !type_check (y, 1, BT_REAL)) + return false; + + if (x->ts.kind != gfc_default_real_kind) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be default " + "real", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &x->where); + return false; + } + + if (y->ts.kind != gfc_default_real_kind) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be default " + "real", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &y->where); + return false; + } + + return true; +} + +bool +gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) +{ + /* i and j cannot both be BOZ literal constants. */ + if (!boz_args_check (i, j)) + return false; + + /* If i is BOZ and j is integer, convert i to type of j. If j is not + an integer, clear the BOZ; otherwise, check that i is an integer. */ + if (i->ts.type == BT_BOZ) + { + if (j->ts.type != BT_INTEGER) + reset_boz (i); + else if (!gfc_boz2int (i, j->ts.kind)) + return false; + } + else if (!type_check (i, 0, BT_INTEGER)) + { + if (j->ts.type == BT_BOZ) + reset_boz (j); + return false; + } + + /* If j is BOZ and i is integer, convert j to type of i. If i is not + an integer, clear the BOZ; otherwise, check that i is an integer. */ + if (j->ts.type == BT_BOZ) + { + if (i->ts.type != BT_INTEGER) + reset_boz (j); + else if (!gfc_boz2int (j, i->ts.kind)) + return false; + } + else if (!type_check (j, 1, BT_INTEGER)) + return false; + + if (!same_type_check (i, 0, j, 1)) + return false; + + if (!type_check (shift, 2, BT_INTEGER)) + return false; + + if (!nonnegative_check ("SHIFT", shift)) + return false; + + if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) + return false; + + return true; +} + + +bool +gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, + gfc_expr *dim) +{ + int d; + + if (!array_check (array, 0)) + return false; + + if (!type_check (shift, 1, BT_INTEGER)) + return false; + + if (!dim_check (dim, 3, true)) + return false; + + if (!dim_rank_check (dim, array, false)) + return false; + + if (!dim) + d = 1; + else if (dim->expr_type == EXPR_CONSTANT) + gfc_extract_int (dim, &d); + else + d = -1; + + if (array->rank == 1 || shift->rank == 0) + { + if (!scalar_check (shift, 1)) + return false; + } + else if (shift->rank == array->rank - 1) + { + if (d > 0) + { + int i, j; + for (i = 0, j = 0; i < array->rank; i++) + if (i != d - 1) + { + if (!identical_dimen_shape (array, i, shift, j)) + { + gfc_error ("%qs argument of %qs intrinsic at %L has " + "invalid shape in dimension %d (%ld/%ld)", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &shift->where, i + 1, + mpz_get_si (array->shape[i]), + mpz_get_si (shift->shape[j])); + return false; + } + + j += 1; + } + } + } + else + { + gfc_error ("%qs argument of intrinsic %qs at %L of must have rank " + "%d or be a scalar", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &shift->where, array->rank - 1); + return false; + } + + if (boundary != NULL) + { + if (!same_type_check (array, 0, boundary, 2)) + return false; + + /* Reject unequal string lengths and emit a better error message than + gfc_check_same_strlen would. */ + if (array->ts.type == BT_CHARACTER) + { + ssize_t len_a, len_b; + + len_a = gfc_var_strlen (array); + len_b = gfc_var_strlen (boundary); + if (len_a != -1 && len_b != -1 && len_a != len_b) + { + gfc_error ("%qs must be of same type and kind as %qs at %L in %qs", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic_arg[0]->name, + &boundary->where, gfc_current_intrinsic); + return false; + } + } + + if (array->rank == 1 || boundary->rank == 0) + { + if (!scalar_check (boundary, 2)) + return false; + } + else if (boundary->rank == array->rank - 1) + { + if (d > 0) + { + int i,j; + for (i = 0, j = 0; i < array->rank; i++) + { + if (i != d - 1) + { + if (!identical_dimen_shape (array, i, boundary, j)) + { + gfc_error ("%qs argument of %qs intrinsic at %L has " + "invalid shape in dimension %d (%ld/%ld)", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic, &shift->where, i+1, + mpz_get_si (array->shape[i]), + mpz_get_si (boundary->shape[j])); + return false; + } + j += 1; + } + } + } + } + else + { + gfc_error ("%qs argument of intrinsic %qs at %L of must have " + "rank %d or be a scalar", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &shift->where, array->rank - 1); + return false; + } + } + else + { + switch (array->ts.type) + { + case BT_INTEGER: + case BT_LOGICAL: + case BT_REAL: + case BT_COMPLEX: + case BT_CHARACTER: + break; + + default: + gfc_error ("Missing %qs argument to %qs intrinsic at %L for %qs " + "of type %qs", gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic, &array->where, + gfc_current_intrinsic_arg[0]->name, + gfc_typename (array)); + return false; + } + } + + return true; +} + + +bool +gfc_check_float (gfc_expr *a) +{ + if (a->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the" + " FLOAT intrinsic subprogram"), &a->where)) + { + reset_boz (a); + return false; + } + if (!gfc_boz2int (a, gfc_default_integer_kind)) + return false; + } + + if (!type_check (a, 0, BT_INTEGER)) + return false; + + if ((a->ts.kind != gfc_default_integer_kind) + && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER " + "kind argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where)) + return false; + + return true; +} + +/* A single complex argument. */ + +bool +gfc_check_fn_c (gfc_expr *a) +{ + if (!type_check (a, 0, BT_COMPLEX)) + return false; + + return true; +} + + +/* A single real argument. */ + +bool +gfc_check_fn_r (gfc_expr *a) +{ + if (!type_check (a, 0, BT_REAL)) + return false; + + return true; +} + +/* A single double argument. */ + +bool +gfc_check_fn_d (gfc_expr *a) +{ + if (!double_check (a, 0)) + return false; + + return true; +} + +/* A single real or complex argument. */ + +bool +gfc_check_fn_rc (gfc_expr *a) +{ + if (!real_or_complex_check (a, 0)) + return false; + + return true; +} + + +bool +gfc_check_fn_rc2008 (gfc_expr *a) +{ + if (!real_or_complex_check (a, 0)) + return false; + + if (a->ts.type == BT_COMPLEX + && !gfc_notify_std (GFC_STD_F2008, "COMPLEX argument %qs " + "of %qs intrinsic at %L", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where)) + return false; + + return true; +} + + +bool +gfc_check_fnum (gfc_expr *unit) +{ + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + return true; +} + + +bool +gfc_check_huge (gfc_expr *x) +{ + if (!int_or_real_check (x, 0)) + return false; + + return true; +} + + +bool +gfc_check_hypot (gfc_expr *x, gfc_expr *y) +{ + if (!type_check (x, 0, BT_REAL)) + return false; + if (!same_type_check (x, 0, y, 1)) + return false; + + return true; +} + + +/* Check that the single argument is an integer. */ + +bool +gfc_check_i (gfc_expr *i) +{ + if (!type_check (i, 0, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_iand_ieor_ior (gfc_expr *i, gfc_expr *j) +{ + /* i and j cannot both be BOZ literal constants. */ + if (!boz_args_check (i, j)) + return false; + + /* If i is BOZ and j is integer, convert i to type of j. */ + if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER + && !gfc_boz2int (i, j->ts.kind)) + return false; + + /* If j is BOZ and i is integer, convert j to type of i. */ + if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER + && !gfc_boz2int (j, i->ts.kind)) + return false; + + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (j, 1, BT_INTEGER)) + return false; + + if (i->ts.kind != j->ts.kind) + { + gfc_error ("Arguments of %qs have different kind type parameters " + "at %L", gfc_current_intrinsic, &i->where); + return false; + } + + return true; +} + + +bool +gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) +{ + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (pos, 1, BT_INTEGER)) + return false; + + if (!type_check (len, 2, BT_INTEGER)) + return false; + + if (!nonnegative_check ("pos", pos)) + return false; + + if (!nonnegative_check ("len", len)) + return false; + + if (!less_than_bitsize2 ("i", i, "pos", pos, "len", len)) + return false; + + return true; +} + + +bool +gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) +{ + int i; + + if (!type_check (c, 0, BT_CHARACTER)) + return false; + + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING) + { + gfc_expr *start; + gfc_expr *end; + gfc_ref *ref; + + /* Substring references don't have the charlength set. */ + ref = c->ref; + while (ref && ref->type != REF_SUBSTRING) + ref = ref->next; + + gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); + + if (!ref) + { + /* Check that the argument is length one. Non-constant lengths + can't be checked here, so assume they are ok. */ + if (c->ts.u.cl && c->ts.u.cl->length) + { + /* If we already have a length for this expression then use it. */ + if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT) + return true; + i = mpz_get_si (c->ts.u.cl->length->value.integer); + } + else + return true; + } + else + { + start = ref->u.ss.start; + end = ref->u.ss.end; + + gcc_assert (start); + if (end == NULL || end->expr_type != EXPR_CONSTANT + || start->expr_type != EXPR_CONSTANT) + return true; + + i = mpz_get_si (end->value.integer) + 1 + - mpz_get_si (start->value.integer); + } + } + else + return true; + + if (i != 1) + { + gfc_error ("Argument of %s at %L must be of length one", + gfc_current_intrinsic, &c->where); + return false; + } + + return true; +} + + +bool +gfc_check_idnint (gfc_expr *a) +{ + if (!double_check (a, 0)) + return false; + + return true; +} + + +bool +gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, + gfc_expr *kind) +{ + if (!type_check (string, 0, BT_CHARACTER) + || !type_check (substring, 1, BT_CHARACTER)) + return false; + + if (back != NULL && !type_check (back, 2, BT_LOGICAL)) + return false; + + if (!kind_check (kind, 3, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + if (string->ts.kind != substring->ts.kind) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be the same " + "kind as %qs", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &substring->where, + gfc_current_intrinsic_arg[0]->name); + return false; + } + + return true; +} + + +bool +gfc_check_int (gfc_expr *x, gfc_expr *kind) +{ + /* BOZ is dealt within simplify_int*. */ + if (x->ts.type == BT_BOZ) + return true; + + if (!numeric_check (x, 0)) + return false; + + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_intconv (gfc_expr *x) +{ + if (strcmp (gfc_current_intrinsic, "short") == 0 + || strcmp (gfc_current_intrinsic, "long") == 0) + { + gfc_error ("%qs intrinsic subprogram at %L has been removed. " + "Use INT intrinsic subprogram.", gfc_current_intrinsic, + &x->where); + return false; + } + + /* BOZ is dealt within simplify_int*. */ + if (x->ts.type == BT_BOZ) + return true; + + if (!numeric_check (x, 0)) + return false; + + return true; +} + +bool +gfc_check_ishft (gfc_expr *i, gfc_expr *shift) +{ + if (!type_check (i, 0, BT_INTEGER) + || !type_check (shift, 1, BT_INTEGER)) + return false; + + if (!less_than_bitsize1 ("I", i, NULL, shift, true)) + return false; + + return true; +} + + +bool +gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size) +{ + if (!type_check (i, 0, BT_INTEGER) + || !type_check (shift, 1, BT_INTEGER)) + return false; + + if (size != NULL) + { + int i2, i3; + + if (!type_check (size, 2, BT_INTEGER)) + return false; + + if (!less_than_bitsize1 ("I", i, "SIZE", size, true)) + return false; + + if (size->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (size, &i3); + if (i3 <= 0) + { + gfc_error ("SIZE at %L must be positive", &size->where); + return false; + } + + if (shift->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (shift, &i2); + if (i2 < 0) + i2 = -i2; + + if (i2 > i3) + { + gfc_error ("The absolute value of SHIFT at %L must be less " + "than or equal to SIZE at %L", &shift->where, + &size->where); + return false; + } + } + } + } + else if (!less_than_bitsize1 ("I", i, NULL, shift, true)) + return false; + + return true; +} + + +bool +gfc_check_kill (gfc_expr *pid, gfc_expr *sig) +{ + if (!type_check (pid, 0, BT_INTEGER)) + return false; + + if (!scalar_check (pid, 0)) + return false; + + if (!type_check (sig, 1, BT_INTEGER)) + return false; + + if (!scalar_check (sig, 1)) + return false; + + return true; +} + + +bool +gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) +{ + if (!type_check (pid, 0, BT_INTEGER)) + return false; + + if (!scalar_check (pid, 0)) + return false; + + if (!type_check (sig, 1, BT_INTEGER)) + return false; + + if (!scalar_check (sig, 1)) + return false; + + if (status) + { + if (!type_check (status, 2, BT_INTEGER)) + return false; + + if (!scalar_check (status, 2)) + return false; + + if (status->expr_type != EXPR_VARIABLE) + { + gfc_error ("STATUS at %L shall be an INTENT(OUT) variable", + &status->where); + return false; + } + + if (status->expr_type == EXPR_VARIABLE + && status->symtree && status->symtree->n.sym + && status->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("%qs at %L shall be an INTENT(OUT) variable", + status->symtree->name, &status->where); + return false; + } + } + + return true; +} + + +bool +gfc_check_kind (gfc_expr *x) +{ + if (gfc_invalid_null_arg (x)) + return false; + + if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be of " + "intrinsic type", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &x->where); + return false; + } + if (x->ts.type == BT_PROCEDURE) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a data entity", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &x->where); + return false; + } + + return true; +} + + +bool +gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + if (!array_check (array, 0)) + return false; + + if (!dim_check (dim, 1, false)) + return false; + + if (!dim_rank_check (dim, array, 1)) + return false; + + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + return true; +} + + +bool +gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return false; + } + + if (!coarray_check (coarray, 0)) + return false; + + if (dim != NULL) + { + if (!dim_check (dim, 1, false)) + return false; + + if (!dim_corank_check (dim, coarray)) + return false; + } + + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) +{ + if (!type_check (s, 0, BT_CHARACTER)) + return false; + + if (gfc_invalid_null_arg (s)) + return false; + + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + return true; +} + + +bool +gfc_check_lge_lgt_lle_llt (gfc_expr *a, gfc_expr *b) +{ + if (!type_check (a, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (a, 0, gfc_default_character_kind)) + return false; + + if (!type_check (b, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (b, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_link (gfc_expr *path1, gfc_expr *path2) +{ + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; + + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_link_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) +{ + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; + + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 0, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER)) + return false; + + if (!scalar_check (status, 2)) + return false; + + return true; +} + + +bool +gfc_check_loc (gfc_expr *expr) +{ + return variable_check (expr, 0, true); +} + + +bool +gfc_check_symlnk (gfc_expr *path1, gfc_expr *path2) +{ + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; + + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_symlnk_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) +{ + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; + + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER)) + return false; + + if (!scalar_check (status, 2)) + return false; + + return true; +} + + +bool +gfc_check_logical (gfc_expr *a, gfc_expr *kind) +{ + if (!type_check (a, 0, BT_LOGICAL)) + return false; + if (!kind_check (kind, 1, BT_LOGICAL)) + return false; + + return true; +} + + +/* Min/max family. */ + +static bool +min_max_args (gfc_actual_arglist *args) +{ + gfc_actual_arglist *arg; + int i, j, nargs, *nlabels, nlabelless; + bool a1 = false, a2 = false; + + if (args == NULL || args->next == NULL) + { + gfc_error ("Intrinsic %qs at %L must have at least two arguments", + gfc_current_intrinsic, gfc_current_intrinsic_where); + return false; + } + + if (!args->name) + a1 = true; + + if (!args->next->name) + a2 = true; + + nargs = 0; + for (arg = args; arg; arg = arg->next) + if (arg->name) + nargs++; + + if (nargs == 0) + return true; + + /* Note: Having a keywordless argument after an "arg=" is checked before. */ + nlabelless = 0; + nlabels = XALLOCAVEC (int, nargs); + for (arg = args, i = 0; arg; arg = arg->next, i++) + if (arg->name) + { + int n; + char *endp; + + if (arg->name[0] != 'a' || arg->name[1] < '1' || arg->name[1] > '9') + goto unknown; + n = strtol (&arg->name[1], &endp, 10); + if (endp[0] != '\0') + goto unknown; + if (n <= 0) + goto unknown; + if (n <= nlabelless) + goto duplicate; + nlabels[i] = n; + if (n == 1) + a1 = true; + if (n == 2) + a2 = true; + } + else + nlabelless++; + + if (!a1 || !a2) + { + gfc_error ("Missing %qs argument to the %s intrinsic at %L", + !a1 ? "a1" : "a2", gfc_current_intrinsic, + gfc_current_intrinsic_where); + return false; + } + + /* Check for duplicates. */ + for (i = 0; i < nargs; i++) + for (j = i + 1; j < nargs; j++) + if (nlabels[i] == nlabels[j]) + goto duplicate; + + return true; + +duplicate: + gfc_error ("Duplicate argument %qs at %L to intrinsic %s", arg->name, + &arg->expr->where, gfc_current_intrinsic); + return false; + +unknown: + gfc_error ("Unknown argument %qs at %L to intrinsic %s", arg->name, + &arg->expr->where, gfc_current_intrinsic); + return false; +} + + +static bool +check_rest (bt type, int kind, gfc_actual_arglist *arglist) +{ + gfc_actual_arglist *arg, *tmp; + gfc_expr *x; + int m, n; + + if (!min_max_args (arglist)) + return false; + + for (arg = arglist, n=1; arg; arg = arg->next, n++) + { + x = arg->expr; + if (x->ts.type != type || x->ts.kind != kind) + { + if (x->ts.type == type) + { + if (x->ts.type == BT_CHARACTER) + { + gfc_error ("Different character kinds at %L", &x->where); + return false; + } + if (!gfc_notify_std (GFC_STD_GNU, "Different type " + "kinds at %L", &x->where)) + return false; + } + else + { + gfc_error ("% argument of %qs intrinsic at %L must be " + "%s(%d)", n, gfc_current_intrinsic, &x->where, + gfc_basic_typename (type), kind); + return false; + } + } + + for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) + if (!gfc_check_conformance (tmp->expr, x, + _("arguments 'a%d' and 'a%d' for " + "intrinsic '%s'"), m, n, + gfc_current_intrinsic)) + return false; + } + + return true; +} + + +bool +gfc_check_min_max (gfc_actual_arglist *arg) +{ + gfc_expr *x; + + if (!min_max_args (arg)) + return false; + + x = arg->expr; + + if (x->ts.type == BT_CHARACTER) + { + if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with CHARACTER argument at %L", + gfc_current_intrinsic, &x->where)) + return false; + } + else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) + { + gfc_error ("% argument of %qs intrinsic at %L must be INTEGER, " + "REAL or CHARACTER", gfc_current_intrinsic, &x->where); + return false; + } + + return check_rest (x->ts.type, x->ts.kind, arg); +} + + +bool +gfc_check_min_max_integer (gfc_actual_arglist *arg) +{ + return check_rest (BT_INTEGER, gfc_default_integer_kind, arg); +} + + +bool +gfc_check_min_max_real (gfc_actual_arglist *arg) +{ + return check_rest (BT_REAL, gfc_default_real_kind, arg); +} + + +bool +gfc_check_min_max_double (gfc_actual_arglist *arg) +{ + return check_rest (BT_REAL, gfc_default_double_kind, arg); +} + + +/* End of min/max family. */ + +bool +gfc_check_malloc (gfc_expr *size) +{ + if (!type_check (size, 0, BT_INTEGER)) + return false; + + if (!scalar_check (size, 0)) + return false; + + return true; +} + + +bool +gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) +{ + if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " + "or LOGICAL", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &matrix_a->where); + return false; + } + + if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be numeric " + "or LOGICAL", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &matrix_b->where); + return false; + } + + if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts)) + || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)) + { + gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)", + gfc_current_intrinsic, &matrix_a->where, + gfc_typename(&matrix_a->ts), gfc_typename(&matrix_b->ts)); + return false; + } + + switch (matrix_a->rank) + { + case 1: + if (!rank_check (matrix_b, 1, 2)) + return false; + /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */ + if (!identical_dimen_shape (matrix_a, 0, matrix_b, 0)) + { + gfc_error ("Different shape on dimension 1 for arguments %qs " + "and %qs at %L for intrinsic matmul", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &matrix_a->where); + return false; + } + break; + + case 2: + if (matrix_b->rank != 2) + { + if (!rank_check (matrix_b, 1, 1)) + return false; + } + /* matrix_b has rank 1 or 2 here. Common check for the cases + - matrix_a has shape (n,m) and matrix_b has shape (m, k) + - matrix_a has shape (n,m) and matrix_b has shape (m). */ + if (!identical_dimen_shape (matrix_a, 1, matrix_b, 0)) + { + gfc_error ("Different shape on dimension 2 for argument %qs and " + "dimension 1 for argument %qs at %L for intrinsic " + "matmul", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, &matrix_a->where); + return false; + } + break; + + default: + gfc_error ("%qs argument of %qs intrinsic at %L must be of rank " + "1 or 2", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &matrix_a->where); + return false; + } + + return true; +} + + +/* Whoever came up with this interface was probably on something. + The possibilities for the occupation of the second and third + parameters are: + + Arg #2 Arg #3 + NULL NULL + DIM NULL + MASK NULL + NULL MASK minloc(array, mask=m) + DIM MASK + + I.e. in the case of minloc(array,mask), mask will be in the second + position of the argument list and we'll have to fix that up. Also, + add the BACK argument if that isn't present. */ + +bool +gfc_check_minloc_maxloc (gfc_actual_arglist *ap) +{ + gfc_expr *a, *m, *d, *k, *b; + + a = ap->expr; + if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0)) + return false; + + d = ap->next->expr; + m = ap->next->next->expr; + k = ap->next->next->next->expr; + b = ap->next->next->next->next->expr; + + if (b) + { + if (!type_check (b, 4, BT_LOGICAL) || !scalar_check (b,4)) + return false; + } + else + { + b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); + ap->next->next->next->next->expr = b; + } + + if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL + && ap->next->name == NULL) + { + m = d; + d = NULL; + ap->next->expr = NULL; + ap->next->next->expr = m; + } + + if (!dim_check (d, 1, false)) + return false; + + if (!dim_rank_check (d, a, 0)) + return false; + + if (m != NULL && !type_check (m, 2, BT_LOGICAL)) + return false; + + if (m != NULL + && !gfc_check_conformance (a, m, + _("arguments '%s' and '%s' for intrinsic %s"), + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic)) + return false; + + if (!kind_check (k, 1, BT_INTEGER)) + return false; + + return true; +} + +/* Check function for findloc. Mostly like gfc_check_minloc_maxloc + above, with the additional "value" argument. */ + +bool +gfc_check_findloc (gfc_actual_arglist *ap) +{ + gfc_expr *a, *v, *m, *d, *k, *b; + bool a1, v1; + + a = ap->expr; + if (!intrinsic_type_check (a, 0) || !array_check (a, 0)) + return false; + + v = ap->next->expr; + if (!intrinsic_type_check (v, 1) || !scalar_check (v,1)) + return false; + + /* Check if the type are both logical. */ + a1 = a->ts.type == BT_LOGICAL; + v1 = v->ts.type == BT_LOGICAL; + if ((a1 && !v1) || (!a1 && v1)) + goto incompat; + + /* Check if the type are both character. */ + a1 = a->ts.type == BT_CHARACTER; + v1 = v->ts.type == BT_CHARACTER; + if ((a1 && !v1) || (!a1 && v1)) + goto incompat; + + /* Check the kind of the characters argument match. */ + if (a1 && v1 && a->ts.kind != v->ts.kind) + goto incompat; + + d = ap->next->next->expr; + m = ap->next->next->next->expr; + k = ap->next->next->next->next->expr; + b = ap->next->next->next->next->next->expr; + + if (b) + { + if (!type_check (b, 5, BT_LOGICAL) || !scalar_check (b,4)) + return false; + } + else + { + b = gfc_get_logical_expr (gfc_logical_4_kind, NULL, 0); + ap->next->next->next->next->next->expr = b; + } + + if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL + && ap->next->name == NULL) + { + m = d; + d = NULL; + ap->next->next->expr = NULL; + ap->next->next->next->expr = m; + } + + if (!dim_check (d, 2, false)) + return false; + + if (!dim_rank_check (d, a, 0)) + return false; + + if (m != NULL && !type_check (m, 3, BT_LOGICAL)) + return false; + + if (m != NULL + && !gfc_check_conformance (a, m, + _("arguments '%s' and '%s' for intrinsic %s"), + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[3]->name, + gfc_current_intrinsic)) + return false; + + if (!kind_check (k, 1, BT_INTEGER)) + return false; + + return true; + +incompat: + gfc_error ("Argument %qs of %qs intrinsic at %L must be in type " + "conformance to argument %qs at %L", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where, + gfc_current_intrinsic_arg[1]->name, &v->where); + return false; +} + + +/* Similar to minloc/maxloc, the argument list might need to be + reordered for the MINVAL, MAXVAL, PRODUCT, and SUM intrinsics. The + difference is that MINLOC/MAXLOC take an additional KIND argument. + The possibilities are: + + Arg #2 Arg #3 + NULL NULL + DIM NULL + MASK NULL + NULL MASK minval(array, mask=m) + DIM MASK + + I.e. in the case of minval(array,mask), mask will be in the second + position of the argument list and we'll have to fix that up. */ + +static bool +check_reduction (gfc_actual_arglist *ap) +{ + gfc_expr *a, *m, *d; + + a = ap->expr; + d = ap->next->expr; + m = ap->next->next->expr; + + if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL + && ap->next->name == NULL) + { + m = d; + d = NULL; + ap->next->expr = NULL; + ap->next->next->expr = m; + } + + if (!dim_check (d, 1, false)) + return false; + + if (!dim_rank_check (d, a, 0)) + return false; + + if (m != NULL && !type_check (m, 2, BT_LOGICAL)) + return false; + + if (m != NULL + && !gfc_check_conformance (a, m, + _("arguments '%s' and '%s' for intrinsic %s"), + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic)) + return false; + + return true; +} + + +bool +gfc_check_minval_maxval (gfc_actual_arglist *ap) +{ + if (!int_or_real_or_char_check_f2003 (ap->expr, 0) + || !array_check (ap->expr, 0)) + return false; + + return check_reduction (ap); +} + + +bool +gfc_check_product_sum (gfc_actual_arglist *ap) +{ + if (!numeric_check (ap->expr, 0) + || !array_check (ap->expr, 0)) + return false; + + return check_reduction (ap); +} + + +/* For IANY, IALL and IPARITY. */ + +bool +gfc_check_mask (gfc_expr *i, gfc_expr *kind) +{ + int k; + + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!nonnegative_check ("I", i)) + return false; + + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + + if (kind) + gfc_extract_int (kind, &k); + else + k = gfc_default_integer_kind; + + if (!less_than_bitsizekind ("I", i, k)) + return false; + + return true; +} + + +bool +gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) +{ + if (ap->expr->ts.type != BT_INTEGER) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &ap->expr->where); + return false; + } + + if (!array_check (ap->expr, 0)) + return false; + + return check_reduction (ap); +} + + +bool +gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) +{ + if (gfc_invalid_null_arg (tsource)) + return false; + + if (gfc_invalid_null_arg (fsource)) + return false; + + if (!same_type_check (tsource, 0, fsource, 1)) + return false; + + if (!type_check (mask, 2, BT_LOGICAL)) + return false; + + if (tsource->ts.type == BT_CHARACTER) + return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic"); + + return true; +} + + +bool +gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) +{ + /* i and j cannot both be BOZ literal constants. */ + if (!boz_args_check (i, j)) + return false; + + /* If i is BOZ and j is integer, convert i to type of j. */ + if (i->ts.type == BT_BOZ && j->ts.type == BT_INTEGER + && !gfc_boz2int (i, j->ts.kind)) + return false; + + /* If j is BOZ and i is integer, convert j to type of i. */ + if (j->ts.type == BT_BOZ && i->ts.type == BT_INTEGER + && !gfc_boz2int (j, i->ts.kind)) + return false; + + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (j, 1, BT_INTEGER)) + return false; + + if (!same_type_check (i, 0, j, 1)) + return false; + + if (mask->ts.type == BT_BOZ && !gfc_boz2int(mask, i->ts.kind)) + return false; + + if (!type_check (mask, 2, BT_INTEGER)) + return false; + + if (!same_type_check (i, 0, mask, 2)) + return false; + + return true; +} + + +bool +gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +{ + if (!variable_check (from, 0, false)) + return false; + if (!allocatable_check (from, 0)) + return false; + if (gfc_is_coindexed (from)) + { + gfc_error ("The FROM argument to MOVE_ALLOC at %L shall not be " + "coindexed", &from->where); + return false; + } + + if (!variable_check (to, 1, false)) + return false; + if (!allocatable_check (to, 1)) + return false; + if (gfc_is_coindexed (to)) + { + gfc_error ("The TO argument to MOVE_ALLOC at %L shall not be " + "coindexed", &to->where); + return false; + } + + if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) + { + gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " + "polymorphic if FROM is polymorphic", + &to->where); + return false; + } + + if (!same_type_check (to, 1, from, 0)) + return false; + + if (to->rank != from->rank) + { + gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " + "must have the same rank %d/%d", &to->where, from->rank, + to->rank); + return false; + } + + /* IR F08/0040; cf. 12-006A. */ + if (gfc_get_corank (to) != gfc_get_corank (from)) + { + gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L " + "must have the same corank %d/%d", &to->where, + gfc_get_corank (from), gfc_get_corank (to)); + return false; + } + + /* This is based losely on F2003 12.4.1.7. It is intended to prevent + the likes of to = sym->cmp1->cmp2 and from = sym->cmp1, where cmp1 + and cmp2 are allocatable. After the allocation is transferred, + the 'to' chain is broken by the nullification of the 'from'. A bit + of reflection reveals that this can only occur for derived types + with recursive allocatable components. */ + if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE + && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name)) + { + gfc_ref *to_ref, *from_ref; + to_ref = to->ref; + from_ref = from->ref; + bool aliasing = true; + + for (; from_ref && to_ref; + from_ref = from_ref->next, to_ref = to_ref->next) + { + if (to_ref->type != from->ref->type) + aliasing = false; + else if (to_ref->type == REF_ARRAY + && to_ref->u.ar.type != AR_FULL + && from_ref->u.ar.type != AR_FULL) + /* Play safe; assume sections and elements are different. */ + aliasing = false; + else if (to_ref->type == REF_COMPONENT + && to_ref->u.c.component != from_ref->u.c.component) + aliasing = false; + + if (!aliasing) + break; + } + + if (aliasing) + { + gfc_error ("The FROM and TO arguments at %L violate aliasing " + "restrictions (F2003 12.4.1.7)", &to->where); + return false; + } + } + + /* CLASS arguments: Make sure the vtab of from is present. */ + if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from)) + gfc_find_vtab (&from->ts); + + return true; +} + + +bool +gfc_check_nearest (gfc_expr *x, gfc_expr *s) +{ + if (!type_check (x, 0, BT_REAL)) + return false; + + if (!type_check (s, 1, BT_REAL)) + return false; + + if (s->expr_type == EXPR_CONSTANT) + { + if (mpfr_sgn (s->value.real) == 0) + { + gfc_error ("Argument % of NEAREST at %L shall not be zero", + &s->where); + return false; + } + } + + return true; +} + + +bool +gfc_check_new_line (gfc_expr *a) +{ + if (!type_check (a, 0, BT_CHARACTER)) + return false; + + return true; +} + + +bool +gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) +{ + if (!type_check (array, 0, BT_REAL)) + return false; + + if (!array_check (array, 0)) + return false; + + if (!dim_rank_check (dim, array, false)) + return false; + + return true; +} + +bool +gfc_check_null (gfc_expr *mold) +{ + symbol_attribute attr; + + if (mold == NULL) + return true; + + if (!variable_check (mold, 0, true)) + return false; + + attr = gfc_variable_attr (mold, NULL); + + if (!attr.pointer && !attr.proc_pointer && !attr.allocatable) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a POINTER, " + "ALLOCATABLE or procedure pointer", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &mold->where); + return false; + } + + if (attr.allocatable + && !gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " + "allocatable MOLD at %L", &mold->where)) + return false; + + /* F2008, C1242. */ + if (gfc_is_coindexed (mold)) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " + "coindexed", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &mold->where); + return false; + } + + return true; +} + + +bool +gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) +{ + if (!array_check (array, 0)) + return false; + + if (!type_check (mask, 1, BT_LOGICAL)) + return false; + + if (!gfc_check_conformance (array, mask, + _("arguments '%s' and '%s' for intrinsic '%s'"), + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic)) + return false; + + if (vector != NULL) + { + mpz_t array_size, vector_size; + bool have_array_size, have_vector_size; + + if (!same_type_check (array, 0, vector, 2)) + return false; + + if (!rank_check (vector, 2, 1)) + return false; + + /* VECTOR requires at least as many elements as MASK + has .TRUE. values. */ + have_array_size = gfc_array_size(array, &array_size); + have_vector_size = gfc_array_size(vector, &vector_size); + + if (have_vector_size + && (mask->expr_type == EXPR_ARRAY + || (mask->expr_type == EXPR_CONSTANT + && have_array_size))) + { + int mask_true_values = 0; + + if (mask->expr_type == EXPR_ARRAY) + { + gfc_constructor *mask_ctor; + mask_ctor = gfc_constructor_first (mask->value.constructor); + while (mask_ctor) + { + if (mask_ctor->expr->expr_type != EXPR_CONSTANT) + { + mask_true_values = 0; + break; + } + + if (mask_ctor->expr->value.logical) + mask_true_values++; + + mask_ctor = gfc_constructor_next (mask_ctor); + } + } + else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical) + mask_true_values = mpz_get_si (array_size); + + if (mpz_get_si (vector_size) < mask_true_values) + { + gfc_error ("%qs argument of %qs intrinsic at %L must " + "provide at least as many elements as there " + "are .TRUE. values in %qs (%ld/%d)", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic, &vector->where, + gfc_current_intrinsic_arg[1]->name, + mpz_get_si (vector_size), mask_true_values); + return false; + } + } + + if (have_array_size) + mpz_clear (array_size); + if (have_vector_size) + mpz_clear (vector_size); + } + + return true; +} + + +bool +gfc_check_parity (gfc_expr *mask, gfc_expr *dim) +{ + if (!type_check (mask, 0, BT_LOGICAL)) + return false; + + if (!array_check (mask, 0)) + return false; + + if (!dim_rank_check (dim, mask, false)) + return false; + + return true; +} + + +bool +gfc_check_precision (gfc_expr *x) +{ + if (!real_or_complex_check (x, 0)) + return false; + + return true; +} + + +bool +gfc_check_present (gfc_expr *a) +{ + gfc_symbol *sym; + + if (!variable_check (a, 0, true)) + return false; + + sym = a->symtree->n.sym; + if (!sym->attr.dummy) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be of a " + "dummy variable", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where); + return false; + } + + /* For CLASS, the optional attribute might be set at either location. */ + if ((sym->ts.type != BT_CLASS || !CLASS_DATA (sym)->attr.optional) + && !sym->attr.optional) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be of " + "an OPTIONAL dummy variable", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); + return false; + } + + /* 13.14.82 PRESENT(A) + ...... + Argument. A shall be the name of an optional dummy argument that is + accessible in the subprogram in which the PRESENT function reference + appears... */ + + if (a->ref != NULL + && !(a->ref->next == NULL && a->ref->type == REF_ARRAY + && (a->ref->u.ar.type == AR_FULL + || (a->ref->u.ar.type == AR_ELEMENT + && a->ref->u.ar.as->rank == 0)))) + { + gfc_error ("%qs argument of %qs intrinsic at %L must not be a " + "subobject of %qs", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where, sym->name); + return false; + } + + return true; +} + + +bool +gfc_check_radix (gfc_expr *x) +{ + if (!int_or_real_check (x, 0)) + return false; + + return true; +} + + +bool +gfc_check_range (gfc_expr *x) +{ + if (!numeric_check (x, 0)) + return false; + + return true; +} + + +bool +gfc_check_rank (gfc_expr *a) +{ + /* Any data object is allowed; a "data object" is a "constant (4.1.3), + variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */ + + bool is_variable = true; + + /* Functions returning pointers are regarded as variable, cf. F2008, R602. */ + if (a->expr_type == EXPR_FUNCTION) + is_variable = a->value.function.esym + ? a->value.function.esym->result->attr.pointer + : a->symtree->n.sym->result->attr.pointer; + + if (a->expr_type == EXPR_OP + || a->expr_type == EXPR_NULL + || a->expr_type == EXPR_COMPCALL + || a->expr_type == EXPR_PPC + || a->ts.type == BT_PROCEDURE + || !is_variable) + { + gfc_error ("The argument of the RANK intrinsic at %L must be a data " + "object", &a->where); + return false; + } + + return true; +} + + +bool +gfc_check_real (gfc_expr *a, gfc_expr *kind) +{ + if (!kind_check (kind, 1, BT_REAL)) + return false; + + /* BOZ is dealt with in gfc_simplify_real. */ + if (a->ts.type == BT_BOZ) + return true; + + if (!numeric_check (a, 0)) + return false; + + return true; +} + + +bool +gfc_check_rename (gfc_expr *path1, gfc_expr *path2) +{ + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; + + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_rename_sub (gfc_expr *path1, gfc_expr *path2, gfc_expr *status) +{ + if (!type_check (path1, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (path1, 0, gfc_default_character_kind)) + return false; + + if (!type_check (path2, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (path2, 1, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER)) + return false; + + if (!scalar_check (status, 2)) + return false; + + return true; +} + + +bool +gfc_check_repeat (gfc_expr *x, gfc_expr *y) +{ + if (!type_check (x, 0, BT_CHARACTER)) + return false; + + if (!scalar_check (x, 0)) + return false; + + if (!type_check (y, 0, BT_INTEGER)) + return false; + + if (!scalar_check (y, 1)) + return false; + + return true; +} + + +bool +gfc_check_reshape (gfc_expr *source, gfc_expr *shape, + gfc_expr *pad, gfc_expr *order) +{ + mpz_t size; + mpz_t nelems; + int shape_size; + bool shape_is_const; + + if (!array_check (source, 0)) + return false; + + if (!rank_check (shape, 1, 1)) + return false; + + if (!type_check (shape, 1, BT_INTEGER)) + return false; + + if (!gfc_array_size (shape, &size)) + { + gfc_error ("% argument of % intrinsic at %L must be an " + "array of constant size", &shape->where); + return false; + } + + shape_size = mpz_get_ui (size); + mpz_clear (size); + + if (shape_size <= 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L is empty", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &shape->where); + return false; + } + else if (shape_size > GFC_MAX_DIMENSIONS) + { + gfc_error ("% argument of % intrinsic at %L has more " + "than %d elements", &shape->where, GFC_MAX_DIMENSIONS); + return false; + } + + gfc_simplify_expr (shape, 0); + shape_is_const = gfc_is_constant_expr (shape); + + if (shape->expr_type == EXPR_ARRAY && shape_is_const) + { + gfc_expr *e; + int i, extent; + for (i = 0; i < shape_size; ++i) + { + e = gfc_constructor_lookup_expr (shape->value.constructor, i); + if (e->expr_type != EXPR_CONSTANT) + continue; + + gfc_extract_int (e, &extent); + if (extent < 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L has " + "negative element (%d)", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &shape->where, extent); + return false; + } + } + } + + if (pad != NULL) + { + if (!same_type_check (source, 0, pad, 2)) + return false; + + if (!array_check (pad, 2)) + return false; + } + + if (order != NULL) + { + if (!array_check (order, 3)) + return false; + + if (!type_check (order, 3, BT_INTEGER)) + return false; + + if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order)) + { + int i, order_size, dim, perm[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + + for (i = 0; i < GFC_MAX_DIMENSIONS; ++i) + perm[i] = 0; + + gfc_array_size (order, &size); + order_size = mpz_get_ui (size); + mpz_clear (size); + + if (order_size != shape_size) + { + gfc_error ("%qs argument of %qs intrinsic at %L " + "has wrong number of elements (%d/%d)", + gfc_current_intrinsic_arg[3]->name, + gfc_current_intrinsic, &order->where, + order_size, shape_size); + return false; + } + + for (i = 1; i <= order_size; ++i) + { + e = gfc_constructor_lookup_expr (order->value.constructor, i-1); + if (e->expr_type != EXPR_CONSTANT) + continue; + + gfc_extract_int (e, &dim); + + if (dim < 1 || dim > order_size) + { + gfc_error ("%qs argument of %qs intrinsic at %L " + "has out-of-range dimension (%d)", + gfc_current_intrinsic_arg[3]->name, + gfc_current_intrinsic, &e->where, dim); + return false; + } + + if (perm[dim-1] != 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L has " + "invalid permutation of dimensions (dimension " + "%qd duplicated)", + gfc_current_intrinsic_arg[3]->name, + gfc_current_intrinsic, &e->where, dim); + return false; + } + + perm[dim-1] = 1; + } + } + } + + if (pad == NULL && shape->expr_type == EXPR_ARRAY && shape_is_const + && !(source->expr_type == EXPR_VARIABLE && source->symtree->n.sym->as + && source->symtree->n.sym->as->type == AS_ASSUMED_SIZE)) + { + /* Check the match in size between source and destination. */ + if (gfc_array_size (source, &nelems)) + { + gfc_constructor *c; + bool test; + + + mpz_init_set_ui (size, 1); + for (c = gfc_constructor_first (shape->value.constructor); + c; c = gfc_constructor_next (c)) + mpz_mul (size, size, c->expr->value.integer); + + test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0; + mpz_clear (nelems); + mpz_clear (size); + + if (test) + { + gfc_error ("Without padding, there are not enough elements " + "in the intrinsic RESHAPE source at %L to match " + "the shape", &source->where); + return false; + } + } + } + + return true; +} + + +bool +gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) +{ + if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) + { + gfc_error ("%qs argument of %qs intrinsic at %L " + "cannot be of type %s", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, + &a->where, gfc_typename (a)); + return false; + } + + if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a))) + { + gfc_error ("%qs argument of %qs intrinsic at %L " + "must be of an extensible type", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); + return false; + } + + if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) + { + gfc_error ("%qs argument of %qs intrinsic at %L " + "cannot be of type %s", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, + &b->where, gfc_typename (b)); + return false; + } + + if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b))) + { + gfc_error ("%qs argument of %qs intrinsic at %L " + "must be of an extensible type", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &b->where); + return false; + } + + return true; +} + + +bool +gfc_check_scale (gfc_expr *x, gfc_expr *i) +{ + if (!type_check (x, 0, BT_REAL)) + return false; + + if (!type_check (i, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) +{ + if (!type_check (x, 0, BT_CHARACTER)) + return false; + + if (!type_check (y, 1, BT_CHARACTER)) + return false; + + if (z != NULL && !type_check (z, 2, BT_LOGICAL)) + return false; + + if (!kind_check (kind, 3, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + if (!same_type_check (x, 0, y, 1)) + return false; + + return true; +} + + +bool +gfc_check_secnds (gfc_expr *r) +{ + if (!type_check (r, 0, BT_REAL)) + return false; + + if (!kind_value_check (r, 0, 4)) + return false; + + if (!scalar_check (r, 0)) + return false; + + return true; +} + + +bool +gfc_check_selected_char_kind (gfc_expr *name) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (!scalar_check (name, 0)) + return false; + + return true; +} + + +bool +gfc_check_selected_int_kind (gfc_expr *r) +{ + if (!type_check (r, 0, BT_INTEGER)) + return false; + + if (!scalar_check (r, 0)) + return false; + + return true; +} + + +bool +gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) +{ + if (p == NULL && r == NULL + && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" + " neither % nor % argument at %L", + gfc_current_intrinsic_where)) + return false; + + if (p) + { + if (!type_check (p, 0, BT_INTEGER)) + return false; + + if (!scalar_check (p, 0)) + return false; + } + + if (r) + { + if (!type_check (r, 1, BT_INTEGER)) + return false; + + if (!scalar_check (r, 1)) + return false; + } + + if (radix) + { + if (!type_check (radix, 1, BT_INTEGER)) + return false; + + if (!scalar_check (radix, 1)) + return false; + + if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with " + "RADIX argument at %L", gfc_current_intrinsic, + &radix->where)) + return false; + } + + return true; +} + + +bool +gfc_check_set_exponent (gfc_expr *x, gfc_expr *i) +{ + if (!type_check (x, 0, BT_REAL)) + return false; + + if (!type_check (i, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_shape (gfc_expr *source, gfc_expr *kind) +{ + gfc_array_ref *ar; + + if (gfc_invalid_null_arg (source)) + return false; + + if (!kind_check (kind, 1, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) + return true; + + if (source->ref == NULL) + return false; + + ar = gfc_find_array_ref (source); + + if (ar->as && ar->as->type == AS_ASSUMED_SIZE && ar->type == AR_FULL) + { + gfc_error ("% argument of % intrinsic at %L must not be " + "an assumed size array", &source->where); + return false; + } + + return true; +} + + +bool +gfc_check_shift (gfc_expr *i, gfc_expr *shift) +{ + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!type_check (shift, 0, BT_INTEGER)) + return false; + + if (!nonnegative_check ("SHIFT", shift)) + return false; + + if (!less_than_bitsize1 ("I", i, "SHIFT", shift, true)) + return false; + + return true; +} + + +bool +gfc_check_sign (gfc_expr *a, gfc_expr *b) +{ + if (!int_or_real_check (a, 0)) + return false; + + if (!same_type_check (a, 0, b, 1)) + return false; + + return true; +} + + +bool +gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + if (!array_check (array, 0)) + return false; + + if (!dim_check (dim, 1, true)) + return false; + + if (!dim_rank_check (dim, array, 0)) + return false; + + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + + return true; +} + + +bool +gfc_check_sizeof (gfc_expr *arg) +{ + if (gfc_invalid_null_arg (arg)) + return false; + + if (arg->ts.type == BT_PROCEDURE) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); + return false; + } + + if (illegal_boz_arg (arg)) + return false; + + /* TYPE(*) is acceptable if and only if it uses an array descriptor. */ + if (arg->ts.type == BT_ASSUMED + && (arg->symtree->n.sym->as == NULL + || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE + && arg->symtree->n.sym->as->type != AS_DEFERRED + && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK))) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); + return false; + } + + if (arg->rank && arg->expr_type == EXPR_VARIABLE + && arg->symtree->n.sym->as != NULL + && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref + && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " + "assumed-size array", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &arg->where); + return false; + } + + return true; +} + + +/* Check whether an expression is interoperable. When returning false, + msg is set to a string telling why the expression is not interoperable, + otherwise, it is set to NULL. The msg string can be used in diagnostics. + If c_loc is true, character with len > 1 are allowed (cf. Fortran + 2003corr5); additionally, assumed-shape/assumed-rank/deferred-shape + arrays are permitted. And if c_f_ptr is true, deferred-shape arrays + are permitted. */ + +static bool +is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr) +{ + *msg = NULL; + + if (expr->expr_type == EXPR_NULL) + { + *msg = "NULL() is not interoperable"; + return false; + } + + if (expr->ts.type == BT_BOZ) + { + *msg = "BOZ literal constant"; + return false; + } + + if (expr->ts.type == BT_CLASS) + { + *msg = "Expression is polymorphic"; + return false; + } + + if (expr->ts.type == BT_DERIVED && !expr->ts.u.derived->attr.is_bind_c + && !expr->ts.u.derived->ts.is_iso_c) + { + *msg = "Expression is a noninteroperable derived type"; + return false; + } + + if (expr->ts.type == BT_PROCEDURE) + { + *msg = "Procedure unexpected as argument"; + return false; + } + + if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_LOGICAL) + { + int i; + for (i = 0; gfc_logical_kinds[i].kind; i++) + if (gfc_logical_kinds[i].kind == expr->ts.kind) + return true; + *msg = "Extension to use a non-C_Bool-kind LOGICAL"; + return false; + } + + if (gfc_notification_std (GFC_STD_GNU) && expr->ts.type == BT_CHARACTER + && expr->ts.kind != 1) + { + *msg = "Extension to use a non-C_CHAR-kind CHARACTER"; + return false; + } + + if (expr->ts.type == BT_CHARACTER) { + if (expr->ts.deferred) + { + /* TS 29113 allows deferred-length strings as dummy arguments, + but it is not an interoperable type. */ + *msg = "Expression shall not be a deferred-length string"; + return false; + } + + if (expr->ts.u.cl && expr->ts.u.cl->length + && !gfc_simplify_expr (expr->ts.u.cl->length, 0)) + gfc_internal_error ("is_c_interoperable(): gfc_simplify_expr failed"); + + if (!c_loc && expr->ts.u.cl + && (!expr->ts.u.cl->length + || expr->ts.u.cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)) + { + *msg = "Type shall have a character length of 1"; + return false; + } + } + + /* Note: The following checks are about interoperatable variables, Fortran + 15.3.5/15.3.6. In intrinsics like C_LOC or in procedure interface, more + is allowed, e.g. assumed-shape arrays with TS 29113. */ + + if (gfc_is_coarray (expr)) + { + *msg = "Coarrays are not interoperable"; + return false; + } + + if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY) + { + gfc_array_ref *ar = gfc_find_array_ref (expr); + if (ar->type != AR_FULL) + { + *msg = "Only whole-arrays are interoperable"; + return false; + } + if (!c_f_ptr && ar->as->type != AS_EXPLICIT + && ar->as->type != AS_ASSUMED_SIZE) + { + *msg = "Only explicit-size and assumed-size arrays are interoperable"; + return false; + } + } + + return true; +} + + +bool +gfc_check_c_sizeof (gfc_expr *arg) +{ + const char *msg; + + if (!is_c_interoperable (arg, &msg, false, false)) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be an " + "interoperable data entity: %s", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where, msg); + return false; + } + + if (arg->ts.type == BT_ASSUMED) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be " + "TYPE(*)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &arg->where); + return false; + } + + if (arg->rank && arg->expr_type == EXPR_VARIABLE + && arg->symtree->n.sym->as != NULL + && arg->symtree->n.sym->as->type == AS_ASSUMED_SIZE && arg->ref + && arg->ref->type == REF_ARRAY && arg->ref->u.ar.type == AR_FULL) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be an " + "assumed-size array", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &arg->where); + return false; + } + + return true; +} + + +bool +gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) +{ + if (c_ptr_1->ts.type != BT_DERIVED + || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING + || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR + && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)) + { + gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " + "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); + return false; + } + + if (!scalar_check (c_ptr_1, 0)) + return false; + + if (c_ptr_2 + && (c_ptr_2->ts.type != BT_DERIVED + || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING + || (c_ptr_1->ts.u.derived->intmod_sym_id + != c_ptr_2->ts.u.derived->intmod_sym_id))) + { + gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " + "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where, + gfc_typename (&c_ptr_1->ts), + gfc_typename (&c_ptr_2->ts)); + return false; + } + + if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) + return false; + + return true; +} + + +bool +gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) +{ + symbol_attribute attr; + const char *msg; + + if (cptr->ts.type != BT_DERIVED + || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING + || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR) + { + gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the " + "type TYPE(C_PTR)", &cptr->where); + return false; + } + + if (!scalar_check (cptr, 0)) + return false; + + attr = gfc_expr_attr (fptr); + + if (!attr.pointer) + { + gfc_error ("Argument FPTR at %L to C_F_POINTER must be a pointer", + &fptr->where); + return false; + } + + if (fptr->ts.type == BT_CLASS) + { + gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic", + &fptr->where); + return false; + } + + if (gfc_is_coindexed (fptr)) + { + gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be " + "coindexed", &fptr->where); + return false; + } + + if (fptr->rank == 0 && shape) + { + gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar " + "FPTR", &fptr->where); + return false; + } + else if (fptr->rank && !shape) + { + gfc_error ("Expected SHAPE argument to C_F_POINTER with array " + "FPTR at %L", &fptr->where); + return false; + } + + if (shape && !rank_check (shape, 2, 1)) + return false; + + if (shape && !type_check (shape, 2, BT_INTEGER)) + return false; + + if (shape) + { + mpz_t size; + if (gfc_array_size (shape, &size)) + { + if (mpz_cmp_ui (size, fptr->rank) != 0) + { + mpz_clear (size); + gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same " + "size as the RANK of FPTR", &shape->where); + return false; + } + mpz_clear (size); + } + } + + if (fptr->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where); + return false; + } + + if (fptr->rank > 0 && !is_c_interoperable (fptr, &msg, false, true)) + return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR " + "at %L to C_F_POINTER: %s", &fptr->where, msg); + + return true; +} + + +bool +gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr) +{ + symbol_attribute attr; + + if (cptr->ts.type != BT_DERIVED + || cptr->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING + || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR) + { + gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the " + "type TYPE(C_FUNPTR)", &cptr->where); + return false; + } + + if (!scalar_check (cptr, 0)) + return false; + + attr = gfc_expr_attr (fptr); + + if (!attr.proc_pointer) + { + gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure " + "pointer", &fptr->where); + return false; + } + + if (gfc_is_coindexed (fptr)) + { + gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be " + "coindexed", &fptr->where); + return false; + } + + if (!attr.is_bind_c) + return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " + "pointer at %L to C_F_PROCPOINTER", &fptr->where); + + return true; +} + + +bool +gfc_check_c_funloc (gfc_expr *x) +{ + symbol_attribute attr; + + if (gfc_is_coindexed (x)) + { + gfc_error ("Argument X at %L to C_FUNLOC shall not be " + "coindexed", &x->where); + return false; + } + + attr = gfc_expr_attr (x); + + if (attr.function && !attr.proc_pointer && x->expr_type == EXPR_VARIABLE + && x->symtree->n.sym == x->symtree->n.sym->result) + for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent) + if (x->symtree->n.sym == ns->proc_name) + { + gfc_error ("Function result %qs at %L is invalid as X argument " + "to C_FUNLOC", x->symtree->n.sym->name, &x->where); + return false; + } + + if (attr.flavor != FL_PROCEDURE) + { + gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure " + "or a procedure pointer", &x->where); + return false; + } + + if (!attr.is_bind_c) + return gfc_notify_std (GFC_STD_F2018, "Noninteroperable procedure " + "at %L to C_FUNLOC", &x->where); + return true; +} + + +bool +gfc_check_c_loc (gfc_expr *x) +{ + symbol_attribute attr; + const char *msg; + + if (gfc_is_coindexed (x)) + { + gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where); + return false; + } + + if (x->ts.type == BT_CLASS) + { + gfc_error ("X argument at %L to C_LOC shall not be polymorphic", + &x->where); + return false; + } + + attr = gfc_expr_attr (x); + + if (!attr.pointer + && (x->expr_type != EXPR_VARIABLE || !attr.target + || attr.flavor == FL_PARAMETER)) + { + gfc_error ("Argument X at %L to C_LOC shall have either " + "the POINTER or the TARGET attribute", &x->where); + return false; + } + + if (x->ts.type == BT_CHARACTER + && gfc_var_strlen (x) == 0) + { + gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized " + "string", &x->where); + return false; + } + + if (!is_c_interoperable (x, &msg, true, false)) + { + if (x->ts.type == BT_CLASS) + { + gfc_error ("Argument at %L to C_LOC shall not be polymorphic", + &x->where); + return false; + } + + if (x->rank + && !gfc_notify_std (GFC_STD_F2018, + "Noninteroperable array at %L as" + " argument to C_LOC: %s", &x->where, msg)) + return false; + } + else if (x->rank > 0 && gfc_notification_std (GFC_STD_F2008)) + { + gfc_array_ref *ar = gfc_find_array_ref (x); + + if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE + && !attr.allocatable + && !gfc_notify_std (GFC_STD_F2008, + "Array of interoperable type at %L " + "to C_LOC which is nonallocatable and neither " + "assumed size nor explicit size", &x->where)) + return false; + else if (ar->type != AR_FULL + && !gfc_notify_std (GFC_STD_F2008, "Array section at %L " + "to C_LOC", &x->where)) + return false; + } + + return true; +} + + +bool +gfc_check_sleep_sub (gfc_expr *seconds) +{ + if (!type_check (seconds, 0, BT_INTEGER)) + return false; + + if (!scalar_check (seconds, 0)) + return false; + + return true; +} + +bool +gfc_check_sngl (gfc_expr *a) +{ + if (!type_check (a, 0, BT_REAL)) + return false; + + if ((a->ts.kind != gfc_default_double_kind) + && !gfc_notify_std (GFC_STD_GNU, "non double precision " + "REAL argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where)) + return false; + + return true; +} + +bool +gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) +{ + if (gfc_invalid_null_arg (source)) + return false; + + if (source->rank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be less " + "than rank %d", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &source->where, GFC_MAX_DIMENSIONS); + + return false; + } + + if (dim == NULL) + return false; + + if (!dim_check (dim, 1, false)) + return false; + + /* dim_rank_check() does not apply here. */ + if (dim + && dim->expr_type == EXPR_CONSTANT + && (mpz_cmp_ui (dim->value.integer, 1) < 0 + || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0)) + { + gfc_error ("%qs argument of %qs intrinsic at %L is not a valid " + "dimension index", gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &dim->where); + return false; + } + + if (!type_check (ncopies, 2, BT_INTEGER)) + return false; + + if (!scalar_check (ncopies, 2)) + return false; + + return true; +} + + +/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and + functions). */ + +bool +arg_strlen_is_zero (gfc_expr *c, int n) +{ + if (gfc_var_strlen (c) == 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L must have " + "length at least 1", gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &c->where); + return true; + } + return false; +} + +bool +gfc_check_fgetputc_sub (gfc_expr *unit, gfc_expr *c, gfc_expr *status) +{ + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + if (!type_check (c, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (c, 1, gfc_default_character_kind)) + return false; + if (strcmp (gfc_current_intrinsic, "fgetc") == 0 + && !variable_check (c, 1, false)) + return false; + if (arg_strlen_is_zero (c, 1)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER) + || !kind_value_check (status, 2, gfc_default_integer_kind) + || !scalar_check (status, 2) + || !variable_check (status, 2, false)) + return false; + + return true; +} + + +bool +gfc_check_fgetputc (gfc_expr *unit, gfc_expr *c) +{ + return gfc_check_fgetputc_sub (unit, c, NULL); +} + + +bool +gfc_check_fgetput_sub (gfc_expr *c, gfc_expr *status) +{ + if (!type_check (c, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (c, 0, gfc_default_character_kind)) + return false; + if (strcmp (gfc_current_intrinsic, "fget") == 0 + && !variable_check (c, 0, false)) + return false; + if (arg_strlen_is_zero (c, 0)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 1, BT_INTEGER) + || !kind_value_check (status, 1, gfc_default_integer_kind) + || !scalar_check (status, 1) + || !variable_check (status, 1, false)) + return false; + + return true; +} + + +bool +gfc_check_fgetput (gfc_expr *c) +{ + return gfc_check_fgetput_sub (c, NULL); +} + + +bool +gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_expr *status) +{ + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + if (!type_check (offset, 1, BT_INTEGER)) + return false; + + if (!scalar_check (offset, 1)) + return false; + + if (!type_check (whence, 2, BT_INTEGER)) + return false; + + if (!scalar_check (whence, 2)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 3, BT_INTEGER)) + return false; + + if (!kind_value_check (status, 3, 4)) + return false; + + if (!scalar_check (status, 3)) + return false; + + return true; +} + + + +bool +gfc_check_fstat (gfc_expr *unit, gfc_expr *array) +{ + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (unit, 0, gfc_default_integer_kind)) + return false; + + if (!array_check (array, 1)) + return false; + + return true; +} + + +bool +gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) +{ + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; + + if (!array_check (array, 1)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER) + || !kind_value_check (status, 2, gfc_default_integer_kind)) + return false; + + if (!scalar_check (status, 2)) + return false; + + return true; +} + + +bool +gfc_check_ftell (gfc_expr *unit) +{ + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + return true; +} + + +bool +gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) +{ + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + if (!type_check (offset, 1, BT_INTEGER)) + return false; + + if (!scalar_check (offset, 1)) + return false; + + return true; +} + + +bool +gfc_check_stat (gfc_expr *name, gfc_expr *array) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; + + if (!array_check (array, 1)) + return false; + + return true; +} + + +bool +gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (!type_check (array, 1, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; + + if (!array_check (array, 1)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER) + || !kind_value_check (array, 1, gfc_default_integer_kind)) + return false; + + if (!scalar_check (status, 2)) + return false; + + return true; +} + + +bool +gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + mpz_t nelems; + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return false; + } + + if (!coarray_check (coarray, 0)) + return false; + + if (sub->rank != 1) + { + gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", + gfc_current_intrinsic_arg[1]->name, &sub->where); + return false; + } + + if (sub->ts.type != BT_INTEGER) + { + gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER", + gfc_current_intrinsic_arg[1]->name, &sub->where); + return false; + } + + if (gfc_array_size (sub, &nelems)) + { + int corank = gfc_get_corank (coarray); + + if (mpz_cmp_ui (nelems, corank) != 0) + { + gfc_error ("The number of array elements of the SUB argument to " + "IMAGE_INDEX at %L shall be %d (corank) not %d", + &sub->where, corank, (int) mpz_get_si (nelems)); + mpz_clear (nelems); + return false; + } + mpz_clear (nelems); + } + + return true; +} + + +bool +gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return false; + } + + if (distance) + { + if (!type_check (distance, 0, BT_INTEGER)) + return false; + + if (!nonnegative_check ("DISTANCE", distance)) + return false; + + if (!scalar_check (distance, 0)) + return false; + + if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " + "NUM_IMAGES at %L", &distance->where)) + return false; + } + + if (failed) + { + if (!type_check (failed, 1, BT_LOGICAL)) + return false; + + if (!scalar_check (failed, 1)) + return false; + + if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to " + "NUM_IMAGES at %L", &failed->where)) + return false; + } + + return true; +} + + +bool +gfc_check_team_number (gfc_expr *team) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return false; + } + + if (team) + { + if (team->ts.type != BT_DERIVED + || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER " + "shall be of type TEAM_TYPE", &team->where); + return false; + } + } + else + return true; + + return true; +} + + +bool +gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return false; + } + + if (coarray == NULL && dim == NULL && distance == NULL) + return true; + + if (dim != NULL && coarray == NULL) + { + gfc_error ("DIM argument without COARRAY argument not allowed for " + "THIS_IMAGE intrinsic at %L", &dim->where); + return false; + } + + if (distance && (coarray || dim)) + { + gfc_error ("The DISTANCE argument may not be specified together with the " + "COARRAY or DIM argument in intrinsic at %L", + &distance->where); + return false; + } + + /* Assume that we have "this_image (distance)". */ + if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER) + { + if (dim) + { + gfc_error ("Unexpected DIM argument with noncoarray argument at %L", + &coarray->where); + return false; + } + distance = coarray; + } + + if (distance) + { + if (!type_check (distance, 2, BT_INTEGER)) + return false; + + if (!nonnegative_check ("DISTANCE", distance)) + return false; + + if (!scalar_check (distance, 2)) + return false; + + if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " + "THIS_IMAGE at %L", &distance->where)) + return false; + + return true; + } + + if (!coarray_check (coarray, 0)) + return false; + + if (dim != NULL) + { + if (!dim_check (dim, 1, false)) + return false; + + if (!dim_corank_check (dim, coarray)) + return false; + } + + return true; +} + +/* Calculate the sizes for transfer, used by gfc_check_transfer and also + by gfc_simplify_transfer. Return false if we cannot do so. */ + +bool +gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, + size_t *source_size, size_t *result_size, + size_t *result_length_p) +{ + size_t result_elt_size; + + if (source->expr_type == EXPR_FUNCTION) + return false; + + if (size && size->expr_type != EXPR_CONSTANT) + return false; + + /* Calculate the size of the source. */ + if (!gfc_target_expr_size (source, source_size)) + return false; + + /* Determine the size of the element. */ + if (!gfc_element_size (mold, &result_elt_size)) + return false; + + /* If the storage size of SOURCE is greater than zero and MOLD is an array, + * a scalar with the type and type parameters of MOLD shall not have a + * storage size equal to zero. + * If MOLD is a scalar and SIZE is absent, the result is a scalar. + * If MOLD is an array and SIZE is absent, the result is an array and of + * rank one. Its size is as small as possible such that its physical + * representation is not shorter than that of SOURCE. + * If SIZE is present, the result is an array of rank one and size SIZE. + */ + if (result_elt_size == 0 && *source_size > 0 && !size + && mold->expr_type == EXPR_ARRAY) + { + gfc_error ("% argument of % intrinsic at %L is an " + "array and shall not have storage size 0 when % " + "argument has size greater than 0", &mold->where); + return false; + } + + if (result_elt_size == 0 && *source_size == 0 && !size) + { + *result_size = 0; + if (result_length_p) + *result_length_p = 0; + return true; + } + + if ((result_elt_size > 0 && (mold->expr_type == EXPR_ARRAY || mold->rank)) + || size) + { + int result_length; + + if (size) + result_length = (size_t)mpz_get_ui (size->value.integer); + else + { + result_length = *source_size / result_elt_size; + if (result_length * result_elt_size < *source_size) + result_length += 1; + } + + *result_size = result_length * result_elt_size; + if (result_length_p) + *result_length_p = result_length; + } + else + *result_size = result_elt_size; + + return true; +} + + +bool +gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) +{ + size_t source_size; + size_t result_size; + + if (gfc_invalid_null_arg (source)) + return false; + + /* SOURCE shall be a scalar or array of any type. */ + if (source->ts.type == BT_PROCEDURE + && source->symtree->n.sym->attr.subroutine == 1) + { + gfc_error ("% argument of % intrinsic at %L " + "must not be a %s", &source->where, + gfc_basic_typename (source->ts.type)); + return false; + } + + if (source->ts.type == BT_BOZ && illegal_boz_arg (source)) + return false; + + if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold)) + return false; + + if (gfc_invalid_null_arg (mold)) + return false; + + /* MOLD shall be a scalar or array of any type. */ + if (mold->ts.type == BT_PROCEDURE + && mold->symtree->n.sym->attr.subroutine == 1) + { + gfc_error ("% argument of % intrinsic at %L " + "must not be a %s", &mold->where, + gfc_basic_typename (mold->ts.type)); + return false; + } + + if (mold->ts.type == BT_HOLLERITH) + { + gfc_error ("% argument of % intrinsic at %L must not be" + " %s", &mold->where, gfc_basic_typename (BT_HOLLERITH)); + return false; + } + + /* SIZE (optional) shall be an integer scalar. The corresponding actual + argument shall not be an optional dummy argument. */ + if (size != NULL) + { + if (!type_check (size, 2, BT_INTEGER)) + { + if (size->ts.type == BT_BOZ) + reset_boz (size); + return false; + } + + if (!scalar_check (size, 2)) + return false; + + if (!nonoptional_check (size, 2)) + return false; + } + + if (!warn_surprising) + return true; + + /* If we can't calculate the sizes, we cannot check any more. + Return true for that case. */ + + if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, + &result_size, NULL)) + return true; + + if (source_size < result_size) + gfc_warning (OPT_Wsurprising, + "Intrinsic TRANSFER at %L has partly undefined result: " + "source size %ld < result size %ld", &source->where, + (long) source_size, (long) result_size); + + return true; +} + + +bool +gfc_check_transpose (gfc_expr *matrix) +{ + if (!rank_check (matrix, 0, 2)) + return false; + + return true; +} + + +bool +gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + if (!array_check (array, 0)) + return false; + + if (!dim_check (dim, 1, false)) + return false; + + if (!dim_rank_check (dim, array, 0)) + return false; + + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + return true; +} + + +bool +gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return false; + } + + if (!coarray_check (coarray, 0)) + return false; + + if (dim != NULL) + { + if (!dim_check (dim, 1, false)) + return false; + + if (!dim_corank_check (dim, coarray)) + return false; + } + + if (!kind_check (kind, 2, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) +{ + mpz_t vector_size; + + if (!rank_check (vector, 0, 1)) + return false; + + if (!array_check (mask, 1)) + return false; + + if (!type_check (mask, 1, BT_LOGICAL)) + return false; + + if (!same_type_check (vector, 0, field, 2)) + return false; + + if (mask->expr_type == EXPR_ARRAY + && gfc_array_size (vector, &vector_size)) + { + int mask_true_count = 0; + gfc_constructor *mask_ctor; + mask_ctor = gfc_constructor_first (mask->value.constructor); + while (mask_ctor) + { + if (mask_ctor->expr->expr_type != EXPR_CONSTANT) + { + mask_true_count = 0; + break; + } + + if (mask_ctor->expr->value.logical) + mask_true_count++; + + mask_ctor = gfc_constructor_next (mask_ctor); + } + + if (mpz_get_si (vector_size) < mask_true_count) + { + gfc_error ("%qs argument of %qs intrinsic at %L must " + "provide at least as many elements as there " + "are .TRUE. values in %qs (%ld/%d)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &vector->where, gfc_current_intrinsic_arg[1]->name, + mpz_get_si (vector_size), mask_true_count); + return false; + } + + mpz_clear (vector_size); + } + + if (mask->rank != field->rank && field->rank != 0) + { + gfc_error ("%qs argument of %qs intrinsic at %L must have " + "the same rank as %qs or be a scalar", + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, + &field->where, gfc_current_intrinsic_arg[1]->name); + return false; + } + + if (mask->rank == field->rank) + { + int i; + for (i = 0; i < field->rank; i++) + if (! identical_dimen_shape (mask, i, field, i)) + { + gfc_error ("%qs and %qs arguments of %qs intrinsic at %L " + "must have identical shape.", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &field->where); + } + } + + return true; +} + + +bool +gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) +{ + if (!type_check (x, 0, BT_CHARACTER)) + return false; + + if (!same_type_check (x, 0, y, 1)) + return false; + + if (z != NULL && !type_check (z, 2, BT_LOGICAL)) + return false; + + if (!kind_check (kind, 3, BT_INTEGER)) + return false; + if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " + "with KIND argument at %L", + gfc_current_intrinsic, &kind->where)) + return false; + + return true; +} + + +bool +gfc_check_trim (gfc_expr *x) +{ + if (!type_check (x, 0, BT_CHARACTER)) + return false; + + if (gfc_invalid_null_arg (x)) + return false; + + if (!scalar_check (x, 0)) + return false; + + return true; +} + + +bool +gfc_check_ttynam (gfc_expr *unit) +{ + if (!scalar_check (unit, 0)) + return false; + + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + return true; +} + + +/************* Check functions for intrinsic subroutines *************/ + +bool +gfc_check_cpu_time (gfc_expr *time) +{ + if (!scalar_check (time, 0)) + return false; + + if (!type_check (time, 0, BT_REAL)) + return false; + + if (!variable_check (time, 0, false)) + return false; + + return true; +} + + +bool +gfc_check_date_and_time (gfc_expr *date, gfc_expr *time, + gfc_expr *zone, gfc_expr *values) +{ + if (date != NULL) + { + if (!type_check (date, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (date, 0, gfc_default_character_kind)) + return false; + if (!scalar_check (date, 0)) + return false; + if (!variable_check (date, 0, false)) + return false; + } + + if (time != NULL) + { + if (!type_check (time, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (time, 1, gfc_default_character_kind)) + return false; + if (!scalar_check (time, 1)) + return false; + if (!variable_check (time, 1, false)) + return false; + } + + if (zone != NULL) + { + if (!type_check (zone, 2, BT_CHARACTER)) + return false; + if (!kind_value_check (zone, 2, gfc_default_character_kind)) + return false; + if (!scalar_check (zone, 2)) + return false; + if (!variable_check (zone, 2, false)) + return false; + } + + if (values != NULL) + { + if (!type_check (values, 3, BT_INTEGER)) + return false; + if (!array_check (values, 3)) + return false; + if (!rank_check (values, 3, 1)) + return false; + if (!variable_check (values, 3, false)) + return false; + } + + return true; +} + + +bool +gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, + gfc_expr *to, gfc_expr *topos) +{ + if (!type_check (from, 0, BT_INTEGER)) + return false; + + if (!type_check (frompos, 1, BT_INTEGER)) + return false; + + if (!type_check (len, 2, BT_INTEGER)) + return false; + + if (!same_type_check (from, 0, to, 3)) + return false; + + if (!variable_check (to, 3, false)) + return false; + + if (!type_check (topos, 4, BT_INTEGER)) + return false; + + if (!nonnegative_check ("frompos", frompos)) + return false; + + if (!nonnegative_check ("topos", topos)) + return false; + + if (!nonnegative_check ("len", len)) + return false; + + if (!less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)) + return false; + + if (!less_than_bitsize2 ("to", to, "topos", topos, "len", len)) + return false; + + return true; +} + + +/* Check the arguments for RANDOM_INIT. */ + +bool +gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct) +{ + if (!type_check (repeatable, 0, BT_LOGICAL)) + return false; + + if (!scalar_check (repeatable, 0)) + return false; + + if (!type_check (image_distinct, 1, BT_LOGICAL)) + return false; + + if (!scalar_check (image_distinct, 1)) + return false; + + return true; +} + + +bool +gfc_check_random_number (gfc_expr *harvest) +{ + if (!type_check (harvest, 0, BT_REAL)) + return false; + + if (!variable_check (harvest, 0, false)) + return false; + + return true; +} + + +bool +gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) +{ + unsigned int nargs = 0, seed_size; + locus *where = NULL; + mpz_t put_size, get_size; + + /* Keep the number of bytes in sync with master_state in + libgfortran/intrinsics/random.c. */ + seed_size = 32 / gfc_default_integer_kind; + + if (size != NULL) + { + if (size->expr_type != EXPR_VARIABLE + || !size->symtree->n.sym->attr.optional) + nargs++; + + if (!scalar_check (size, 0)) + return false; + + if (!type_check (size, 0, BT_INTEGER)) + return false; + + if (!variable_check (size, 0, false)) + return false; + + if (!kind_value_check (size, 0, gfc_default_integer_kind)) + return false; + } + + if (put != NULL) + { + if (put->expr_type != EXPR_VARIABLE + || !put->symtree->n.sym->attr.optional) + { + nargs++; + where = &put->where; + } + + if (!array_check (put, 1)) + return false; + + if (!rank_check (put, 1, 1)) + return false; + + if (!type_check (put, 1, BT_INTEGER)) + return false; + + if (!kind_value_check (put, 1, gfc_default_integer_kind)) + return false; + + if (gfc_array_size (put, &put_size) + && mpz_get_ui (put_size) < seed_size) + gfc_error ("Size of %qs argument of %qs intrinsic at %L " + "too small (%i/%i)", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &put->where, (int) mpz_get_ui (put_size), seed_size); + } + + if (get != NULL) + { + if (get->expr_type != EXPR_VARIABLE + || !get->symtree->n.sym->attr.optional) + { + nargs++; + where = &get->where; + } + + if (!array_check (get, 2)) + return false; + + if (!rank_check (get, 2, 1)) + return false; + + if (!type_check (get, 2, BT_INTEGER)) + return false; + + if (!variable_check (get, 2, false)) + return false; + + if (!kind_value_check (get, 2, gfc_default_integer_kind)) + return false; + + if (gfc_array_size (get, &get_size) + && mpz_get_ui (get_size) < seed_size) + gfc_error ("Size of %qs argument of %qs intrinsic at %L " + "too small (%i/%i)", + gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, + &get->where, (int) mpz_get_ui (get_size), seed_size); + } + + /* RANDOM_SEED may not have more than one non-optional argument. */ + if (nargs > 1) + gfc_error ("Too many arguments to %s at %L", gfc_current_intrinsic, where); + + return true; +} + +bool +gfc_check_fe_runtime_error (gfc_actual_arglist *a) +{ + gfc_expr *e; + size_t len, i; + int num_percent, nargs; + + e = a->expr; + if (e->expr_type != EXPR_CONSTANT) + return true; + + len = e->value.character.length; + if (e->value.character.string[len-1] != '\0') + gfc_internal_error ("fe_runtime_error string must be null terminated"); + + num_percent = 0; + for (i=0; ivalue.character.string[i] == '%') + num_percent ++; + + nargs = 0; + for (; a; a = a->next) + nargs ++; + + if (nargs -1 != num_percent) + gfc_internal_error ("fe_runtime_error: Wrong number of arguments (%d instead of %d)", + nargs, num_percent++); + + return true; +} + +bool +gfc_check_second_sub (gfc_expr *time) +{ + if (!scalar_check (time, 0)) + return false; + + if (!type_check (time, 0, BT_REAL)) + return false; + + if (!kind_value_check (time, 0, 4)) + return false; + + return true; +} + + +/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer + variables in Fortran 95. In Fortran 2003 and later, they can be of any + kind, and COUNT_RATE can be of type real. Note, count, count_rate, and + count_max are all optional arguments */ + +bool +gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate, + gfc_expr *count_max) +{ + if (count != NULL) + { + if (!scalar_check (count, 0)) + return false; + + if (!type_check (count, 0, BT_INTEGER)) + return false; + + if (count->ts.kind != gfc_default_integer_kind + && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to " + "SYSTEM_CLOCK at %L has non-default kind", + &count->where)) + return false; + + if (!variable_check (count, 0, false)) + return false; + } + + if (count_rate != NULL) + { + if (!scalar_check (count_rate, 1)) + return false; + + if (!variable_check (count_rate, 1, false)) + return false; + + if (count_rate->ts.type == BT_REAL) + { + if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to " + "SYSTEM_CLOCK at %L", &count_rate->where)) + return false; + } + else + { + if (!type_check (count_rate, 1, BT_INTEGER)) + return false; + + if (count_rate->ts.kind != gfc_default_integer_kind + && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to " + "SYSTEM_CLOCK at %L has non-default kind", + &count_rate->where)) + return false; + } + + } + + if (count_max != NULL) + { + if (!scalar_check (count_max, 2)) + return false; + + if (!type_check (count_max, 2, BT_INTEGER)) + return false; + + if (count_max->ts.kind != gfc_default_integer_kind + && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to " + "SYSTEM_CLOCK at %L has non-default kind", + &count_max->where)) + return false; + + if (!variable_check (count_max, 2, false)) + return false; + } + + return true; +} + + +bool +gfc_check_irand (gfc_expr *x) +{ + if (x == NULL) + return true; + + if (!scalar_check (x, 0)) + return false; + + if (!type_check (x, 0, BT_INTEGER)) + return false; + + if (!kind_value_check (x, 0, 4)) + return false; + + return true; +} + + +bool +gfc_check_alarm_sub (gfc_expr *seconds, gfc_expr *handler, gfc_expr *status) +{ + if (!scalar_check (seconds, 0)) + return false; + if (!type_check (seconds, 0, BT_INTEGER)) + return false; + + if (!int_or_proc_check (handler, 1)) + return false; + if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) + return false; + + if (status == NULL) + return true; + + if (!scalar_check (status, 2)) + return false; + if (!type_check (status, 2, BT_INTEGER)) + return false; + if (!kind_value_check (status, 2, gfc_default_integer_kind)) + return false; + + return true; +} + + +bool +gfc_check_rand (gfc_expr *x) +{ + if (x == NULL) + return true; + + if (!scalar_check (x, 0)) + return false; + + if (!type_check (x, 0, BT_INTEGER)) + return false; + + if (!kind_value_check (x, 0, 4)) + return false; + + return true; +} + + +bool +gfc_check_srand (gfc_expr *x) +{ + if (!scalar_check (x, 0)) + return false; + + if (!type_check (x, 0, BT_INTEGER)) + return false; + + if (!kind_value_check (x, 0, 4)) + return false; + + return true; +} + + +bool +gfc_check_ctime_sub (gfc_expr *time, gfc_expr *result) +{ + if (!scalar_check (time, 0)) + return false; + if (!type_check (time, 0, BT_INTEGER)) + return false; + + if (!type_check (result, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (result, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_dtime_etime (gfc_expr *x) +{ + if (!array_check (x, 0)) + return false; + + if (!rank_check (x, 0, 1)) + return false; + + if (!variable_check (x, 0, false)) + return false; + + if (!type_check (x, 0, BT_REAL)) + return false; + + if (!kind_value_check (x, 0, 4)) + return false; + + return true; +} + + +bool +gfc_check_dtime_etime_sub (gfc_expr *values, gfc_expr *time) +{ + if (!array_check (values, 0)) + return false; + + if (!rank_check (values, 0, 1)) + return false; + + if (!variable_check (values, 0, false)) + return false; + + if (!type_check (values, 0, BT_REAL)) + return false; + + if (!kind_value_check (values, 0, 4)) + return false; + + if (!scalar_check (time, 1)) + return false; + + if (!type_check (time, 1, BT_REAL)) + return false; + + if (!kind_value_check (time, 1, 4)) + return false; + + return true; +} + + +bool +gfc_check_fdate_sub (gfc_expr *date) +{ + if (!type_check (date, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (date, 0, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_gerror (gfc_expr *msg) +{ + if (!type_check (msg, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (msg, 0, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_getcwd_sub (gfc_expr *cwd, gfc_expr *status) +{ + if (!type_check (cwd, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (cwd, 0, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!scalar_check (status, 1)) + return false; + + if (!type_check (status, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_getarg (gfc_expr *pos, gfc_expr *value) +{ + if (!type_check (pos, 0, BT_INTEGER)) + return false; + + if (pos->ts.kind > gfc_default_integer_kind) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be of a kind " + "not wider than the default kind (%d)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &pos->where, gfc_default_integer_kind); + return false; + } + + if (!type_check (value, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (value, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_getlog (gfc_expr *msg) +{ + if (!type_check (msg, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (msg, 0, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_exit (gfc_expr *status) +{ + if (status == NULL) + return true; + + if (!type_check (status, 0, BT_INTEGER)) + return false; + + if (!scalar_check (status, 0)) + return false; + + return true; +} + + +bool +gfc_check_flush (gfc_expr *unit) +{ + if (unit == NULL) + return true; + + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + return true; +} + + +bool +gfc_check_free (gfc_expr *i) +{ + if (!type_check (i, 0, BT_INTEGER)) + return false; + + if (!scalar_check (i, 0)) + return false; + + return true; +} + + +bool +gfc_check_hostnm (gfc_expr *name) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_hostnm_sub (gfc_expr *name, gfc_expr *status) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!scalar_check (status, 1)) + return false; + + if (!type_check (status, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_itime_idate (gfc_expr *values) +{ + if (!array_check (values, 0)) + return false; + + if (!rank_check (values, 0, 1)) + return false; + + if (!variable_check (values, 0, false)) + return false; + + if (!type_check (values, 0, BT_INTEGER)) + return false; + + if (!kind_value_check (values, 0, gfc_default_integer_kind)) + return false; + + return true; +} + + +bool +gfc_check_ltime_gmtime (gfc_expr *time, gfc_expr *values) +{ + if (!type_check (time, 0, BT_INTEGER)) + return false; + + if (!kind_value_check (time, 0, gfc_default_integer_kind)) + return false; + + if (!scalar_check (time, 0)) + return false; + + if (!array_check (values, 1)) + return false; + + if (!rank_check (values, 1, 1)) + return false; + + if (!variable_check (values, 1, false)) + return false; + + if (!type_check (values, 1, BT_INTEGER)) + return false; + + if (!kind_value_check (values, 1, gfc_default_integer_kind)) + return false; + + return true; +} + + +bool +gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) +{ + if (!scalar_check (unit, 0)) + return false; + + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!type_check (name, 1, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 1, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_is_contiguous (gfc_expr *array) +{ + if (array->expr_type == EXPR_NULL) + { + gfc_error ("Actual argument at %L of %qs intrinsic shall be an " + "associated pointer", &array->where, gfc_current_intrinsic); + return false; + } + + if (!array_check (array, 0)) + return false; + + return true; +} + + +bool +gfc_check_isatty (gfc_expr *unit) +{ + if (unit == NULL) + return false; + + if (!type_check (unit, 0, BT_INTEGER)) + return false; + + if (!scalar_check (unit, 0)) + return false; + + return true; +} + + +bool +gfc_check_isnan (gfc_expr *x) +{ + if (!type_check (x, 0, BT_REAL)) + return false; + + return true; +} + + +bool +gfc_check_perror (gfc_expr *string) +{ + if (!type_check (string, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (string, 0, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_umask (gfc_expr *mask) +{ + if (!type_check (mask, 0, BT_INTEGER)) + return false; + + if (!scalar_check (mask, 0)) + return false; + + return true; +} + + +bool +gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old) +{ + if (!type_check (mask, 0, BT_INTEGER)) + return false; + + if (!scalar_check (mask, 0)) + return false; + + if (old == NULL) + return true; + + if (!scalar_check (old, 1)) + return false; + + if (!type_check (old, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_unlink (gfc_expr *name) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + return true; +} + + +bool +gfc_check_unlink_sub (gfc_expr *name, gfc_expr *status) +{ + if (!type_check (name, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (name, 0, gfc_default_character_kind)) + return false; + + if (status == NULL) + return true; + + if (!scalar_check (status, 1)) + return false; + + if (!type_check (status, 1, BT_INTEGER)) + return false; + + return true; +} + + +bool +gfc_check_signal (gfc_expr *number, gfc_expr *handler) +{ + if (!scalar_check (number, 0)) + return false; + if (!type_check (number, 0, BT_INTEGER)) + return false; + + if (!int_or_proc_check (handler, 1)) + return false; + if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) + return false; + + return true; +} + + +bool +gfc_check_signal_sub (gfc_expr *number, gfc_expr *handler, gfc_expr *status) +{ + if (!scalar_check (number, 0)) + return false; + if (!type_check (number, 0, BT_INTEGER)) + return false; + + if (!int_or_proc_check (handler, 1)) + return false; + if (handler->ts.type == BT_INTEGER && !scalar_check (handler, 1)) + return false; + + if (status == NULL) + return true; + + if (!type_check (status, 2, BT_INTEGER)) + return false; + if (!scalar_check (status, 2)) + return false; + + return true; +} + + +bool +gfc_check_system_sub (gfc_expr *cmd, gfc_expr *status) +{ + if (!type_check (cmd, 0, BT_CHARACTER)) + return false; + if (!kind_value_check (cmd, 0, gfc_default_character_kind)) + return false; + + if (!scalar_check (status, 1)) + return false; + + if (!type_check (status, 1, BT_INTEGER)) + return false; + + if (!kind_value_check (status, 1, gfc_default_integer_kind)) + return false; + + return true; +} + + +/* This is used for the GNU intrinsics AND, OR and XOR. */ +bool +gfc_check_and (gfc_expr *i, gfc_expr *j) +{ + if (i->ts.type != BT_INTEGER + && i->ts.type != BT_LOGICAL + && i->ts.type != BT_BOZ) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " + "LOGICAL, or a BOZ literal constant", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &i->where); + return false; + } + + if (j->ts.type != BT_INTEGER + && j->ts.type != BT_LOGICAL + && j->ts.type != BT_BOZ) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER, " + "LOGICAL, or a BOZ literal constant", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &j->where); + return false; + } + + /* i and j cannot both be BOZ literal constants. */ + if (!boz_args_check (i, j)) + return false; + + /* If i is BOZ and j is integer, convert i to type of j. */ + if (i->ts.type == BT_BOZ) + { + if (j->ts.type != BT_INTEGER) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", + gfc_current_intrinsic_arg[1]->name, + gfc_current_intrinsic, &j->where); + reset_boz (i); + return false; + } + if (!gfc_boz2int (i, j->ts.kind)) + return false; + } + + /* If j is BOZ and i is integer, convert j to type of i. */ + if (j->ts.type == BT_BOZ) + { + if (i->ts.type != BT_INTEGER) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER", + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &j->where); + reset_boz (j); + return false; + } + if (!gfc_boz2int (j, i->ts.kind)) + return false; + } + + if (!same_type_check (i, 0, j, 1, false)) + return false; + + if (!scalar_check (i, 0)) + return false; + + if (!scalar_check (j, 1)) + return false; + + return true; +} + + +bool +gfc_check_storage_size (gfc_expr *a, gfc_expr *kind) +{ + + if (a->expr_type == EXPR_NULL) + { + gfc_error ("Intrinsic function NULL at %L cannot be an actual " + "argument to STORAGE_SIZE, because it returns a " + "disassociated pointer", &a->where); + return false; + } + + if (a->ts.type == BT_ASSUMED) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be TYPE(*)", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &a->where); + return false; + } + + if (a->ts.type == BT_PROCEDURE) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall not be a " + "procedure", gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic, &a->where); + return false; + } + + if (a->ts.type == BT_BOZ && illegal_boz_arg (a)) + return false; + + if (kind == NULL) + return true; + + if (!type_check (kind, 1, BT_INTEGER)) + return false; + + if (!scalar_check (kind, 1)) + return false; + + if (kind->expr_type != EXPR_CONSTANT) + { + gfc_error ("%qs argument of %qs intrinsic at %L must be a constant", + gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, + &kind->where); + return false; + } + + return true; +} diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c deleted file mode 100644 index 2cb0c65..0000000 --- a/gcc/fortran/class.c +++ /dev/null @@ -1,3073 +0,0 @@ -/* Implementation of Fortran 2003 Polymorphism. - Copyright (C) 2009-2022 Free Software Foundation, Inc. - Contributed by Paul Richard Thomas - and Janus Weil - -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 -. */ - - -/* class.c -- This file contains the front end functions needed to service - the implementation of Fortran 2003 polymorphism and other - object-oriented features. */ - - -/* Outline of the internal representation: - - Each CLASS variable is encapsulated by a class container, which is a - structure with two fields: - * _data: A pointer to the actual data of the variable. This field has the - declared type of the class variable and its attributes - (pointer/allocatable/dimension/...). - * _vptr: A pointer to the vtable entry (see below) of the dynamic type. - - Only for unlimited polymorphic classes: - * _len: An integer(C_SIZE_T) to store the string length when the unlimited - polymorphic pointer is used to point to a char array. The '_len' - component will be zero when no character array is stored in - '_data'. - - For each derived type we set up a "vtable" entry, i.e. a structure with the - following fields: - * _hash: A hash value serving as a unique identifier for this type. - * _size: The size in bytes of the derived type. - * _extends: A pointer to the vtable entry of the parent derived type. - * _def_init: A pointer to a default initialized variable of this type. - * _copy: A procedure pointer to a copying procedure. - * _final: A procedure pointer to a wrapper function, which frees - allocatable components and calls FINAL subroutines. - * _deallocate: A procedure pointer to a deallocation procedure; nonnull - only for a recursive derived type. - - After these follow procedure pointer components for the specific - type-bound procedures. */ - - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "constructor.h" -#include "target-memory.h" - -/* Inserts a derived type component reference in a data reference chain. - TS: base type of the ref chain so far, in which we will pick the component - REF: the address of the GFC_REF pointer to update - NAME: name of the component to insert - Note that component insertion makes sense only if we are at the end of - the chain (*REF == NULL) or if we are adding a missing "_data" component - to access the actual contents of a class object. */ - -static void -insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name) -{ - gfc_ref *new_ref; - int wcnt, ecnt; - - gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS); - - gfc_find_component (ts->u.derived, name, true, true, &new_ref); - - gfc_get_errors (&wcnt, &ecnt); - if (ecnt > 0 && !new_ref) - return; - gcc_assert (new_ref->u.c.component); - - while (new_ref->next) - new_ref = new_ref->next; - new_ref->next = *ref; - - if (new_ref->next) - { - gfc_ref *next = NULL; - - /* We need to update the base type in the trailing reference chain to - that of the new component. */ - - gcc_assert (strcmp (name, "_data") == 0); - - if (new_ref->next->type == REF_COMPONENT) - next = new_ref->next; - else if (new_ref->next->type == REF_ARRAY - && new_ref->next->next - && new_ref->next->next->type == REF_COMPONENT) - next = new_ref->next->next; - - if (next != NULL) - { - gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS - || new_ref->u.c.component->ts.type == BT_DERIVED); - next->u.c.sym = new_ref->u.c.component->ts.u.derived; - } - } - - *ref = new_ref; -} - - -/* Tells whether we need to add a "_data" reference to access REF subobject - from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base - object accessed by REF is a variable; in other words it is a full object, - not a subobject. */ - -static bool -class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain) -{ - /* Only class containers may need the "_data" reference. */ - if (ts->type != BT_CLASS) - return false; - - /* Accessing a class container with an array reference is certainly wrong. */ - if (ref->type != REF_COMPONENT) - return true; - - /* Accessing the class container's fields is fine. */ - if (ref->u.c.component->name[0] == '_') - return false; - - /* At this point we have a class container with a non class container's field - component reference. We don't want to add the "_data" component if we are - at the first reference and the symbol's type is an extended derived type. - In that case, conv_parent_component_references will do the right thing so - it is not absolutely necessary. Omitting it prevents a regression (see - class_41.f03) in the interface mapping mechanism. When evaluating string - lengths depending on dummy arguments, we create a fake symbol with a type - equal to that of the dummy type. However, because of type extension, - the backend type (corresponding to the actual argument) can have a - different (extended) type. Adding the "_data" component explicitly, using - the base type, confuses the gfc_conv_component_ref code which deals with - the extended type. */ - if (first_ref_in_chain && ts->u.derived->attr.extension) - return false; - - /* We have a class container with a non class container's field component - reference that doesn't fall into the above. */ - return true; -} - - -/* Browse through a data reference chain and add the missing "_data" references - when a subobject of a class object is accessed without it. - Note that it doesn't add the "_data" reference when the class container - is the last element in the reference chain. */ - -void -gfc_fix_class_refs (gfc_expr *e) -{ - gfc_typespec *ts; - gfc_ref **ref; - - if ((e->expr_type != EXPR_VARIABLE - && e->expr_type != EXPR_FUNCTION) - || (e->expr_type == EXPR_FUNCTION - && e->value.function.isym != NULL)) - return; - - if (e->expr_type == EXPR_VARIABLE) - ts = &e->symtree->n.sym->ts; - else - { - gfc_symbol *func; - - gcc_assert (e->expr_type == EXPR_FUNCTION); - if (e->value.function.esym != NULL) - func = e->value.function.esym; - else - func = e->symtree->n.sym; - - if (func->result != NULL) - ts = &func->result->ts; - else - ts = &func->ts; - } - - for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next) - { - if (class_data_ref_missing (ts, *ref, ref == &e->ref)) - insert_component_ref (ts, ref, "_data"); - - if ((*ref)->type == REF_COMPONENT) - ts = &(*ref)->u.c.component->ts; - } -} - - -/* Insert a reference to the component of the given name. - Only to be used with CLASS containers and vtables. */ - -void -gfc_add_component_ref (gfc_expr *e, const char *name) -{ - gfc_component *c; - gfc_ref **tail = &(e->ref); - gfc_ref *ref, *next = NULL; - gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; - while (*tail != NULL) - { - if ((*tail)->type == REF_COMPONENT) - { - if (strcmp ((*tail)->u.c.component->name, "_data") == 0 - && (*tail)->next - && (*tail)->next->type == REF_ARRAY - && (*tail)->next->next == NULL) - return; - derived = (*tail)->u.c.component->ts.u.derived; - } - if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) - break; - tail = &((*tail)->next); - } - if (derived && derived->components && derived->components->next && - derived->components->next->ts.type == BT_DERIVED && - derived->components->next->ts.u.derived == NULL) - { - /* Fix up missing vtype. */ - gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); - gcc_assert (vtab); - derived->components->next->ts.u.derived = vtab->ts.u.derived; - } - if (*tail != NULL && strcmp (name, "_data") == 0) - next = *tail; - else - /* Avoid losing memory. */ - gfc_free_ref_list (*tail); - c = gfc_find_component (derived, name, true, true, tail); - - if (c) { - for (ref = *tail; ref->next; ref = ref->next) - ; - ref->next = next; - if (!next) - e->ts = c->ts; - } -} - - -/* This is used to add both the _data component reference and an array - reference to class expressions. Used in translation of intrinsic - array inquiry functions. */ - -void -gfc_add_class_array_ref (gfc_expr *e) -{ - int rank = CLASS_DATA (e)->as->rank; - gfc_array_spec *as = CLASS_DATA (e)->as; - gfc_ref *ref = NULL; - gfc_add_data_component (e); - e->rank = rank; - for (ref = e->ref; ref; ref = ref->next) - if (!ref->next) - break; - if (ref->type != REF_ARRAY) - { - ref->next = gfc_get_ref (); - ref = ref->next; - ref->type = REF_ARRAY; - ref->u.ar.type = AR_FULL; - ref->u.ar.as = as; - } -} - - -/* Unfortunately, class array expressions can appear in various conditions; - with and without both _data component and an arrayspec. This function - deals with that variability. The previous reference to 'ref' is to a - class array. */ - -static bool -class_array_ref_detected (gfc_ref *ref, bool *full_array) -{ - bool no_data = false; - bool with_data = false; - - /* An array reference with no _data component. */ - if (ref && ref->type == REF_ARRAY - && !ref->next - && ref->u.ar.type != AR_ELEMENT) - { - if (full_array) - *full_array = ref->u.ar.type == AR_FULL; - no_data = true; - } - - /* Cover cases where _data appears, with or without an array ref. */ - if (ref && ref->type == REF_COMPONENT - && strcmp (ref->u.c.component->name, "_data") == 0) - { - if (!ref->next) - { - with_data = true; - if (full_array) - *full_array = true; - } - else if (ref->next && ref->next->type == REF_ARRAY - && ref->type == REF_COMPONENT - && ref->next->u.ar.type != AR_ELEMENT) - { - with_data = true; - if (full_array) - *full_array = ref->next->u.ar.type == AR_FULL; - } - } - - return no_data || with_data; -} - - -/* Returns true if the expression contains a reference to a class - array. Notice that class array elements return false. */ - -bool -gfc_is_class_array_ref (gfc_expr *e, bool *full_array) -{ - gfc_ref *ref; - - if (!e->rank) - return false; - - if (full_array) - *full_array= false; - - /* Is this a class array object? ie. Is the symbol of type class? */ - if (e->symtree - && e->symtree->n.sym->ts.type == BT_CLASS - && CLASS_DATA (e->symtree->n.sym) - && CLASS_DATA (e->symtree->n.sym)->attr.dimension - && class_array_ref_detected (e->ref, full_array)) - return true; - - /* Or is this a class array component reference? */ - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS - && CLASS_DATA (ref->u.c.component)->attr.dimension - && class_array_ref_detected (ref->next, full_array)) - return true; - } - - return false; -} - - -/* Returns true if the expression is a reference to a class - scalar. This function is necessary because such expressions - can be dressed with a reference to the _data component and so - have a type other than BT_CLASS. */ - -bool -gfc_is_class_scalar_expr (gfc_expr *e) -{ - gfc_ref *ref; - - if (e->rank) - return false; - - /* Is this a class object? */ - if (e->symtree - && e->symtree->n.sym->ts.type == BT_CLASS - && CLASS_DATA (e->symtree->n.sym) - && !CLASS_DATA (e->symtree->n.sym)->attr.dimension - && (e->ref == NULL - || (e->ref->type == REF_COMPONENT - && strcmp (e->ref->u.c.component->name, "_data") == 0 - && e->ref->next == NULL))) - return true; - - /* Or is the final reference BT_CLASS or _data? */ - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS - && CLASS_DATA (ref->u.c.component) - && !CLASS_DATA (ref->u.c.component)->attr.dimension - && (ref->next == NULL - || (ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0 - && ref->next->next == NULL))) - return true; - } - - return false; -} - - -/* Tells whether the expression E is a reference to a (scalar) class container. - Scalar because array class containers usually have an array reference after - them, and gfc_fix_class_refs will add the missing "_data" component reference - in that case. */ - -bool -gfc_is_class_container_ref (gfc_expr *e) -{ - gfc_ref *ref; - bool result; - - if (e->expr_type != EXPR_VARIABLE) - return e->ts.type == BT_CLASS; - - if (e->symtree->n.sym->ts.type == BT_CLASS) - result = true; - else - result = false; - - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type != REF_COMPONENT) - result = false; - else if (ref->u.c.component->ts.type == BT_CLASS) - result = true; - else - result = false; - } - - return result; -} - - -/* Build an initializer for CLASS pointers, - initializing the _data component to the init_expr (or NULL) and the _vptr - component to the corresponding type (or the declared type, given by ts). */ - -gfc_expr * -gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr) -{ - gfc_expr *init; - gfc_component *comp; - gfc_symbol *vtab = NULL; - - if (init_expr && init_expr->expr_type != EXPR_NULL) - vtab = gfc_find_vtab (&init_expr->ts); - else - vtab = gfc_find_vtab (ts); - - init = gfc_get_structure_constructor_expr (ts->type, ts->kind, - &ts->u.derived->declared_at); - init->ts = *ts; - - for (comp = ts->u.derived->components; comp; comp = comp->next) - { - gfc_constructor *ctor = gfc_constructor_get(); - if (strcmp (comp->name, "_vptr") == 0 && vtab) - ctor->expr = gfc_lval_expr_from_sym (vtab); - else if (init_expr && init_expr->expr_type != EXPR_NULL) - ctor->expr = gfc_copy_expr (init_expr); - else - ctor->expr = gfc_get_null_expr (NULL); - gfc_constructor_append (&init->value.constructor, ctor); - } - - return init; -} - - -/* Create a unique string identifier for a derived type, composed of its name - and module name. This is used to construct unique names for the class - containers and vtab symbols. */ - -static char * -get_unique_type_string (gfc_symbol *derived) -{ - const char *dt_name; - char *string; - size_t len; - if (derived->attr.unlimited_polymorphic) - dt_name = "STAR"; - else - dt_name = gfc_dt_upper_string (derived->name); - len = strlen (dt_name) + 2; - if (derived->attr.unlimited_polymorphic) - { - string = XNEWVEC (char, len); - sprintf (string, "_%s", dt_name); - } - else if (derived->module) - { - string = XNEWVEC (char, strlen (derived->module) + len); - sprintf (string, "%s_%s", derived->module, dt_name); - } - else if (derived->ns->proc_name) - { - string = XNEWVEC (char, strlen (derived->ns->proc_name->name) + len); - sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); - } - else - { - string = XNEWVEC (char, len); - sprintf (string, "_%s", dt_name); - } - return string; -} - - -/* A relative of 'get_unique_type_string' which makes sure the generated - string will not be too long (replacing it by a hash string if needed). */ - -static void -get_unique_hashed_string (char *string, gfc_symbol *derived) -{ - /* Provide sufficient space to hold "symbol.symbol_symbol". */ - char *tmp; - tmp = get_unique_type_string (derived); - /* If string is too long, use hash value in hex representation (allow for - extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). - We need space to for 15 characters "__class_" + symbol name + "_%d_%da", - where %d is the (co)rank which can be up to n = 15. */ - if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) - { - int h = gfc_hash_value (derived); - sprintf (string, "%X", h); - } - else - strcpy (string, tmp); - free (tmp); -} - - -/* Assign a hash value for a derived type. The algorithm is that of SDBM. */ - -unsigned int -gfc_hash_value (gfc_symbol *sym) -{ - unsigned int hash = 0; - /* Provide sufficient space to hold "symbol.symbol_symbol". */ - char *c; - int i, len; - - c = get_unique_type_string (sym); - len = strlen (c); - - for (i = 0; i < len; i++) - hash = (hash << 6) + (hash << 16) - hash + c[i]; - - free (c); - /* Return the hash but take the modulus for the sake of module read, - even though this slightly increases the chance of collision. */ - return (hash % 100000000); -} - - -/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */ - -unsigned int -gfc_intrinsic_hash_value (gfc_typespec *ts) -{ - unsigned int hash = 0; - const char *c = gfc_typename (ts, true); - int i, len; - - len = strlen (c); - - for (i = 0; i < len; i++) - hash = (hash << 6) + (hash << 16) - hash + c[i]; - - /* Return the hash but take the modulus for the sake of module read, - even though this slightly increases the chance of collision. */ - return (hash % 100000000); -} - - -/* Get the _len component from a class/derived object storing a string. - For unlimited polymorphic entities a ref to the _data component is available - while a ref to the _len component is needed. This routine traverese the - ref-chain and strips the last ref to a _data from it replacing it with a - ref to the _len component. */ - -gfc_expr * -gfc_get_len_component (gfc_expr *e, int k) -{ - gfc_expr *ptr; - gfc_ref *ref, **last; - - ptr = gfc_copy_expr (e); - - /* We need to remove the last _data component ref from ptr. */ - last = &(ptr->ref); - ref = ptr->ref; - while (ref) - { - if (!ref->next - && ref->type == REF_COMPONENT - && strcmp ("_data", ref->u.c.component->name)== 0) - { - gfc_free_ref_list (ref); - *last = NULL; - break; - } - last = &(ref->next); - ref = ref->next; - } - /* And replace if with a ref to the _len component. */ - gfc_add_len_component (ptr); - if (k != ptr->ts.kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = k; - gfc_convert_type_warn (ptr, &ts, 2, 0); - } - return ptr; -} - - -/* Build a polymorphic CLASS entity, using the symbol that comes from - build_sym. A CLASS entity is represented by an encapsulating type, - which contains the declared type as '_data' component, plus a pointer - component '_vptr' which determines the dynamic type. When this CLASS - entity is unlimited polymorphic, then also add a component '_len' to - store the length of string when that is stored in it. */ -static int ctr = 0; - -bool -gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, - gfc_array_spec **as) -{ - char tname[GFC_MAX_SYMBOL_LEN+1]; - char *name; - gfc_symbol *fclass; - gfc_symbol *vtab; - gfc_component *c; - gfc_namespace *ns; - int rank; - - gcc_assert (as); - - if (attr->class_ok) - /* Class container has already been built. */ - return true; - - attr->class_ok = attr->dummy || attr->pointer || attr->allocatable - || attr->select_type_temporary || attr->associate_var; - - if (!attr->class_ok) - /* We cannot build the class container yet. */ - return true; - - /* Determine the name of the encapsulating type. */ - rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; - - if (!ts->u.derived) - return false; - - get_unique_hashed_string (tname, ts->u.derived); - if ((*as) && attr->allocatable) - name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank); - else if ((*as) && attr->pointer) - name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank); - else if ((*as)) - name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank); - else if (attr->pointer) - name = xasprintf ("__class_%s_p", tname); - else if (attr->allocatable) - name = xasprintf ("__class_%s_a", tname); - else - name = xasprintf ("__class_%s_t", tname); - - if (ts->u.derived->attr.unlimited_polymorphic) - { - /* Find the top-level namespace. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - if (!ns->parent) - break; - } - else - ns = ts->u.derived->ns; - - /* Although this might seem to be counterintuitive, we can build separate - class types with different array specs because the TKR interface checks - work on the declared type. All array type other than deferred shape or - assumed rank are added to the function namespace to ensure that they - are properly distinguished. */ - if (attr->dummy && !attr->codimension && (*as) - && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK)) - { - char *sname; - ns = gfc_current_ns; - gfc_find_symbol (name, ns, 0, &fclass); - /* If a local class type with this name already exists, update the - name with an index. */ - if (fclass) - { - fclass = NULL; - sname = xasprintf ("%s_%d", name, ++ctr); - free (name); - name = sname; - } - } - else - gfc_find_symbol (name, ns, 0, &fclass); - - if (fclass == NULL) - { - gfc_symtree *st; - /* If not there, create a new symbol. */ - fclass = gfc_new_symbol (name, ns); - st = gfc_new_symtree (&ns->sym_root, name); - st->n.sym = fclass; - gfc_set_sym_referenced (fclass); - fclass->refs++; - fclass->ts.type = BT_UNKNOWN; - if (!ts->u.derived->attr.unlimited_polymorphic) - fclass->attr.abstract = ts->u.derived->attr.abstract; - fclass->f2k_derived = gfc_get_namespace (NULL, 0); - if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL, - &gfc_current_locus)) - return false; - - /* Add component '_data'. */ - if (!gfc_add_component (fclass, "_data", &c)) - return false; - c->ts = *ts; - c->ts.type = BT_DERIVED; - c->attr.access = ACCESS_PRIVATE; - c->ts.u.derived = ts->u.derived; - c->attr.class_pointer = attr->pointer; - c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable) - || attr->select_type_temporary; - c->attr.allocatable = attr->allocatable; - c->attr.dimension = attr->dimension; - c->attr.codimension = attr->codimension; - c->attr.abstract = fclass->attr.abstract; - c->as = (*as); - c->initializer = NULL; - - /* Add component '_vptr'. */ - if (!gfc_add_component (fclass, "_vptr", &c)) - return false; - c->ts.type = BT_DERIVED; - c->attr.access = ACCESS_PRIVATE; - c->attr.pointer = 1; - - if (ts->u.derived->attr.unlimited_polymorphic) - { - vtab = gfc_find_derived_vtab (ts->u.derived); - gcc_assert (vtab); - c->ts.u.derived = vtab->ts.u.derived; - - /* Add component '_len'. Only unlimited polymorphic pointers may - have a string assigned to them, i.e., only those need the _len - component. */ - if (!gfc_add_component (fclass, "_len", &c)) - return false; - c->ts.type = BT_INTEGER; - c->ts.kind = gfc_charlen_int_kind; - c->attr.access = ACCESS_PRIVATE; - c->attr.artificial = 1; - } - else - /* Build vtab later. */ - c->ts.u.derived = NULL; - } - - if (!ts->u.derived->attr.unlimited_polymorphic) - { - /* Since the extension field is 8 bit wide, we can only have - up to 255 extension levels. */ - if (ts->u.derived->attr.extension == 255) - { - gfc_error ("Maximum extension level reached with type %qs at %L", - ts->u.derived->name, &ts->u.derived->declared_at); - return false; - } - - fclass->attr.extension = ts->u.derived->attr.extension + 1; - fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp; - fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp; - } - - fclass->attr.is_class = 1; - ts->u.derived = fclass; - attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; - (*as) = NULL; - free (name); - return true; -} - - -/* Add a procedure pointer component to the vtype - to represent a specific type-bound procedure. */ - -static void -add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) -{ - gfc_component *c; - - if (tb->non_overridable && !tb->overridden) - return; - - c = gfc_find_component (vtype, name, true, true, NULL); - - if (c == NULL) - { - /* Add procedure component. */ - if (!gfc_add_component (vtype, name, &c)) - return; - - if (!c->tb) - c->tb = XCNEW (gfc_typebound_proc); - *c->tb = *tb; - c->tb->ppc = 1; - c->attr.procedure = 1; - c->attr.proc_pointer = 1; - c->attr.flavor = FL_PROCEDURE; - c->attr.access = ACCESS_PRIVATE; - c->attr.external = 1; - c->attr.untyped = 1; - c->attr.if_source = IFSRC_IFBODY; - } - else if (c->attr.proc_pointer && c->tb) - { - *c->tb = *tb; - c->tb->ppc = 1; - } - - if (tb->u.specific) - { - gfc_symbol *ifc = tb->u.specific->n.sym; - c->ts.interface = ifc; - if (!tb->deferred) - c->initializer = gfc_get_variable_expr (tb->u.specific); - c->attr.pure = ifc->attr.pure; - } -} - - -/* Add all specific type-bound procedures in the symtree 'st' to a vtype. */ - -static void -add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) -{ - if (!st) - return; - - if (st->left) - add_procs_to_declared_vtab1 (st->left, vtype); - - if (st->right) - add_procs_to_declared_vtab1 (st->right, vtype); - - if (st->n.tb && !st->n.tb->error - && !st->n.tb->is_generic && st->n.tb->u.specific) - add_proc_comp (vtype, st->name, st->n.tb); -} - - -/* Copy procedure pointers components from the parent type. */ - -static void -copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) -{ - gfc_component *cmp; - gfc_symbol *vtab; - - vtab = gfc_find_derived_vtab (declared); - - for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) - { - if (gfc_find_component (vtype, cmp->name, true, true, NULL)) - continue; - - add_proc_comp (vtype, cmp->name, cmp->tb); - } -} - - -/* Returns true if any of its nonpointer nonallocatable components or - their nonpointer nonallocatable subcomponents has a finalization - subroutine. */ - -static bool -has_finalizer_component (gfc_symbol *derived) -{ - gfc_component *c; - - for (c = derived->components; c; c = c->next) - if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable) - { - if (c->ts.u.derived->f2k_derived - && c->ts.u.derived->f2k_derived->finalizers) - return true; - - /* Stop infinite recursion through this function by inhibiting - calls when the derived type and that of the component are - the same. */ - if (!gfc_compare_derived_types (derived, c->ts.u.derived) - && has_finalizer_component (c->ts.u.derived)) - return true; - } - return false; -} - - -static bool -comp_is_finalizable (gfc_component *comp) -{ - if (comp->attr.proc_pointer) - return false; - else if (comp->attr.allocatable && comp->ts.type != BT_CLASS) - return true; - else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer - && (comp->ts.u.derived->attr.alloc_comp - || has_finalizer_component (comp->ts.u.derived) - || (comp->ts.u.derived->f2k_derived - && comp->ts.u.derived->f2k_derived->finalizers))) - return true; - else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.allocatable) - return true; - else - return false; -} - - -/* Call DEALLOCATE for the passed component if it is allocatable, if it is - neither allocatable nor a pointer but has a finalizer, call it. If it - is a nonpointer component with allocatable components or has finalizers, walk - them. Either of them is required; other nonallocatables and pointers aren't - handled gracefully. - Note: If the component is allocatable, the DEALLOCATE handling takes care - of calling the appropriate finalizers, coarray deregistering, and - deallocation of allocatable subcomponents. */ - -static void -finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, - gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code, - gfc_namespace *sub_ns) -{ - gfc_expr *e; - gfc_ref *ref; - gfc_was_finalized *f; - - if (!comp_is_finalizable (comp)) - return; - - /* If this expression with this component has been finalized - already in this namespace, there is nothing to do. */ - for (f = sub_ns->was_finalized; f; f = f->next) - { - if (f->e == expr && f->c == comp) - return; - } - - e = gfc_copy_expr (expr); - if (!e->ref) - e->ref = ref = gfc_get_ref (); - else - { - for (ref = e->ref; ref->next; ref = ref->next) - ; - ref->next = gfc_get_ref (); - ref = ref->next; - } - ref->type = REF_COMPONENT; - ref->u.c.sym = derived; - ref->u.c.component = comp; - e->ts = comp->ts; - - if (comp->attr.dimension || comp->attr.codimension - || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && (CLASS_DATA (comp)->attr.dimension - || CLASS_DATA (comp)->attr.codimension))) - { - ref->next = gfc_get_ref (); - ref->next->type = REF_ARRAY; - ref->next->u.ar.dimen = 0; - ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as - : comp->as; - e->rank = ref->next->u.ar.as->rank; - ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT; - } - - /* Call DEALLOCATE (comp, stat=ignore). */ - if (comp->attr.allocatable - || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.allocatable)) - { - gfc_code *dealloc, *block = NULL; - - /* Add IF (fini_coarray). */ - if (comp->attr.codimension - || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.codimension)) - { - block = gfc_get_code (EXEC_IF); - if (*code) - { - (*code)->next = block; - (*code) = (*code)->next; - } - else - (*code) = block; - - block->block = gfc_get_code (EXEC_IF); - block = block->block; - block->expr1 = gfc_lval_expr_from_sym (fini_coarray); - } - - dealloc = gfc_get_code (EXEC_DEALLOCATE); - - dealloc->ext.alloc.list = gfc_get_alloc (); - dealloc->ext.alloc.list->expr = e; - dealloc->expr1 = gfc_lval_expr_from_sym (stat); - - gfc_code *cond = gfc_get_code (EXEC_IF); - cond->block = gfc_get_code (EXEC_IF); - cond->block->expr1 = gfc_get_expr (); - cond->block->expr1->expr_type = EXPR_FUNCTION; - cond->block->expr1->where = gfc_current_locus; - gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false); - cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE; - cond->block->expr1->symtree->n.sym->attr.intrinsic = 1; - cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym; - gfc_commit_symbol (cond->block->expr1->symtree->n.sym); - cond->block->expr1->ts.type = BT_LOGICAL; - cond->block->expr1->ts.kind = gfc_default_logical_kind; - cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED); - cond->block->expr1->value.function.actual = gfc_get_actual_arglist (); - cond->block->expr1->value.function.actual->expr = gfc_copy_expr (expr); - cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist (); - cond->block->next = dealloc; - - if (block) - block->next = cond; - else if (*code) - { - (*code)->next = cond; - (*code) = (*code)->next; - } - else - (*code) = cond; - - } - else if (comp->ts.type == BT_DERIVED - && comp->ts.u.derived->f2k_derived - && comp->ts.u.derived->f2k_derived->finalizers) - { - /* Call FINAL_WRAPPER (comp); */ - gfc_code *final_wrap; - gfc_symbol *vtab; - gfc_component *c; - - vtab = gfc_find_derived_vtab (comp->ts.u.derived); - for (c = vtab->ts.u.derived->components; c; c = c->next) - if (strcmp (c->name, "_final") == 0) - break; - - gcc_assert (c); - final_wrap = gfc_get_code (EXEC_CALL); - final_wrap->symtree = c->initializer->symtree; - final_wrap->resolved_sym = c->initializer->symtree->n.sym; - final_wrap->ext.actual = gfc_get_actual_arglist (); - final_wrap->ext.actual->expr = e; - - if (*code) - { - (*code)->next = final_wrap; - (*code) = (*code)->next; - } - else - (*code) = final_wrap; - } - else - { - gfc_component *c; - - for (c = comp->ts.u.derived->components; c; c = c->next) - finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code, - sub_ns); - gfc_free_expr (e); - } - - /* Record that this was finalized already in this namespace. */ - f = sub_ns->was_finalized; - sub_ns->was_finalized = XCNEW (gfc_was_finalized); - sub_ns->was_finalized->e = expr; - sub_ns->was_finalized->c = comp; - sub_ns->was_finalized->next = f; -} - - -/* Generate code equivalent to - CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + offset, c_ptr), ptr). */ - -static gfc_code * -finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, - gfc_expr *offset, gfc_namespace *sub_ns) -{ - gfc_code *block; - gfc_expr *expr, *expr2; - - /* C_F_POINTER(). */ - block = gfc_get_code (EXEC_CALL); - gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true); - block->resolved_sym = block->symtree->n.sym; - block->resolved_sym->attr.flavor = FL_PROCEDURE; - block->resolved_sym->attr.intrinsic = 1; - block->resolved_sym->attr.subroutine = 1; - block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING; - block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER; - block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER); - gfc_commit_symbol (block->resolved_sym); - - /* C_F_POINTER's first argument: TRANSFER ( , c_intptr_t). */ - block->ext.actual = gfc_get_actual_arglist (); - block->ext.actual->next = gfc_get_actual_arglist (); - block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind, - NULL, 0); - block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */ - - /* The part: TRANSFER (C_LOC (array), c_intptr_t). */ - - /* TRANSFER's first argument: C_LOC (array). */ - expr = gfc_get_expr (); - expr->expr_type = EXPR_FUNCTION; - gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false); - expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; - expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC; - expr->symtree->n.sym->attr.intrinsic = 1; - expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING; - expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC); - expr->value.function.actual = gfc_get_actual_arglist (); - expr->value.function.actual->expr - = gfc_lval_expr_from_sym (array); - expr->symtree->n.sym->result = expr->symtree->n.sym; - gfc_commit_symbol (expr->symtree->n.sym); - expr->ts.type = BT_INTEGER; - expr->ts.kind = gfc_index_integer_kind; - expr->where = gfc_current_locus; - - /* TRANSFER. */ - expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer", - gfc_current_locus, 3, expr, - gfc_get_int_expr (gfc_index_integer_kind, - NULL, 0), NULL); - expr2->ts.type = BT_INTEGER; - expr2->ts.kind = gfc_index_integer_kind; - - /* + . */ - block->ext.actual->expr = gfc_get_expr (); - block->ext.actual->expr->expr_type = EXPR_OP; - block->ext.actual->expr->value.op.op = INTRINSIC_PLUS; - block->ext.actual->expr->value.op.op1 = expr2; - block->ext.actual->expr->value.op.op2 = offset; - block->ext.actual->expr->ts = expr->ts; - block->ext.actual->expr->where = gfc_current_locus; - - /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ - block->ext.actual->next = gfc_get_actual_arglist (); - block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr); - block->ext.actual->next->next = gfc_get_actual_arglist (); - - return block; -} - - -/* Calculates the offset to the (idx+1)th element of an array, taking the - stride into account. It generates the code: - offset = 0 - do idx2 = 1, rank - offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2) - end do - offset = offset * byte_stride. */ - -static gfc_code* -finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, - gfc_symbol *strides, gfc_symbol *sizes, - gfc_symbol *byte_stride, gfc_expr *rank, - gfc_code *block, gfc_namespace *sub_ns) -{ - gfc_iterator *iter; - gfc_expr *expr, *expr2; - - /* offset = 0. */ - block->next = gfc_get_code (EXEC_ASSIGN); - block = block->next; - block->expr1 = gfc_lval_expr_from_sym (offset); - block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - - /* Create loop. */ - iter = gfc_get_iterator (); - iter->var = gfc_lval_expr_from_sym (idx2); - iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - iter->end = gfc_copy_expr (rank); - iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - block->next = gfc_get_code (EXEC_DO); - block = block->next; - block->ext.iterator = iter; - block->block = gfc_get_code (EXEC_DO); - - /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) - * strides(idx2). */ - - /* mod (idx, sizes(idx2)). */ - expr = gfc_lval_expr_from_sym (sizes); - expr->ref = gfc_get_ref (); - expr->ref->type = REF_ARRAY; - expr->ref->u.ar.as = sizes->as; - expr->ref->u.ar.type = AR_ELEMENT; - expr->ref->u.ar.dimen = 1; - expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); - expr->where = sizes->declared_at; - - expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod", - gfc_current_locus, 2, - gfc_lval_expr_from_sym (idx), expr); - expr->ts = idx->ts; - - /* (...) / sizes(idx2-1). */ - expr2 = gfc_get_expr (); - expr2->expr_type = EXPR_OP; - expr2->value.op.op = INTRINSIC_DIVIDE; - expr2->value.op.op1 = expr; - expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes); - expr2->value.op.op2->ref = gfc_get_ref (); - expr2->value.op.op2->ref->type = REF_ARRAY; - expr2->value.op.op2->ref->u.ar.as = sizes->as; - expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT; - expr2->value.op.op2->ref->u.ar.dimen = 1; - expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); - expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; - expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus; - expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; - expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1 - = gfc_lval_expr_from_sym (idx2); - expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2 - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - expr2->value.op.op2->ref->u.ar.start[0]->ts - = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; - expr2->ts = idx->ts; - expr2->where = gfc_current_locus; - - /* ... * strides(idx2). */ - expr = gfc_get_expr (); - expr->expr_type = EXPR_OP; - expr->value.op.op = INTRINSIC_TIMES; - expr->value.op.op1 = expr2; - expr->value.op.op2 = gfc_lval_expr_from_sym (strides); - expr->value.op.op2->ref = gfc_get_ref (); - expr->value.op.op2->ref->type = REF_ARRAY; - expr->value.op.op2->ref->u.ar.type = AR_ELEMENT; - expr->value.op.op2->ref->u.ar.dimen = 1; - expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); - expr->value.op.op2->ref->u.ar.as = strides->as; - expr->ts = idx->ts; - expr->where = gfc_current_locus; - - /* offset = offset + ... */ - block->block->next = gfc_get_code (EXEC_ASSIGN); - block->block->next->expr1 = gfc_lval_expr_from_sym (offset); - block->block->next->expr2 = gfc_get_expr (); - block->block->next->expr2->expr_type = EXPR_OP; - block->block->next->expr2->value.op.op = INTRINSIC_PLUS; - block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); - block->block->next->expr2->value.op.op2 = expr; - block->block->next->expr2->ts = idx->ts; - block->block->next->expr2->where = gfc_current_locus; - - /* After the loop: offset = offset * byte_stride. */ - block->next = gfc_get_code (EXEC_ASSIGN); - block = block->next; - block->expr1 = gfc_lval_expr_from_sym (offset); - block->expr2 = gfc_get_expr (); - block->expr2->expr_type = EXPR_OP; - block->expr2->value.op.op = INTRINSIC_TIMES; - block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); - block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride); - block->expr2->ts = block->expr2->value.op.op1->ts; - block->expr2->where = gfc_current_locus; - return block; -} - - -/* Insert code of the following form: - - block - integer(c_intptr_t) :: i - - if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE - && (is_contiguous || !final_rank3->attr.contiguous - || final_rank3->as->type != AS_ASSUMED_SHAPE)) - || 0 == STORAGE_SIZE (array)) then - call final_rank3 (array) - else - block - integer(c_intptr_t) :: offset, j - type(t) :: tmp(shape (array)) - - do i = 0, size (array)-1 - offset = obtain_offset(i, strides, sizes, byte_stride) - addr = transfer (c_loc (array), addr) + offset - call c_f_pointer (transfer (addr, cptr), ptr) - - addr = transfer (c_loc (tmp), addr) - + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE - call c_f_pointer (transfer (addr, cptr), ptr2) - ptr2 = ptr - end do - call final_rank3 (tmp) - end block - end if - block */ - -static void -finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, - gfc_symbol *array, gfc_symbol *byte_stride, - gfc_symbol *idx, gfc_symbol *ptr, - gfc_symbol *nelem, - gfc_symbol *strides, gfc_symbol *sizes, - gfc_symbol *idx2, gfc_symbol *offset, - gfc_symbol *is_contiguous, gfc_expr *rank, - gfc_namespace *sub_ns) -{ - gfc_symbol *tmp_array, *ptr2; - gfc_expr *size_expr, *offset2, *expr; - gfc_namespace *ns; - gfc_iterator *iter; - gfc_code *block2; - int i; - - block->next = gfc_get_code (EXEC_IF); - block = block->next; - - block->block = gfc_get_code (EXEC_IF); - block = block->block; - - /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ - size_expr = gfc_get_expr (); - size_expr->where = gfc_current_locus; - size_expr->expr_type = EXPR_OP; - size_expr->value.op.op = INTRINSIC_DIVIDE; - - /* STORAGE_SIZE (array,kind=c_intptr_t). */ - size_expr->value.op.op1 - = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE, - "storage_size", gfc_current_locus, 2, - gfc_lval_expr_from_sym (array), - gfc_get_int_expr (gfc_index_integer_kind, - NULL, 0)); - - /* NUMERIC_STORAGE_SIZE. */ - size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, - gfc_character_storage_size); - size_expr->value.op.op1->ts = size_expr->value.op.op2->ts; - size_expr->ts = size_expr->value.op.op1->ts; - - /* IF condition: (stride == size_expr - && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous) - || is_contiguous) - || 0 == size_expr. */ - block->expr1 = gfc_get_expr (); - block->expr1->ts.type = BT_LOGICAL; - block->expr1->ts.kind = gfc_default_logical_kind; - block->expr1->expr_type = EXPR_OP; - block->expr1->where = gfc_current_locus; - - block->expr1->value.op.op = INTRINSIC_OR; - - /* byte_stride == size_expr */ - expr = gfc_get_expr (); - expr->ts.type = BT_LOGICAL; - expr->ts.kind = gfc_default_logical_kind; - expr->expr_type = EXPR_OP; - expr->where = gfc_current_locus; - expr->value.op.op = INTRINSIC_EQ; - expr->value.op.op1 - = gfc_lval_expr_from_sym (byte_stride); - expr->value.op.op2 = size_expr; - - /* If strides aren't allowed (not assumed shape or CONTIGUOUS), - add is_contiguous check. */ - - if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE - || fini->proc_tree->n.sym->formal->sym->attr.contiguous) - { - gfc_expr *expr2; - expr2 = gfc_get_expr (); - expr2->ts.type = BT_LOGICAL; - expr2->ts.kind = gfc_default_logical_kind; - expr2->expr_type = EXPR_OP; - expr2->where = gfc_current_locus; - expr2->value.op.op = INTRINSIC_AND; - expr2->value.op.op1 = expr; - expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous); - expr = expr2; - } - - block->expr1->value.op.op1 = expr; - - /* 0 == size_expr */ - block->expr1->value.op.op2 = gfc_get_expr (); - block->expr1->value.op.op2->ts.type = BT_LOGICAL; - block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind; - block->expr1->value.op.op2->expr_type = EXPR_OP; - block->expr1->value.op.op2->where = gfc_current_locus; - block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ; - block->expr1->value.op.op2->value.op.op1 = - gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr); - - /* IF body: call final subroutine. */ - block->next = gfc_get_code (EXEC_CALL); - block->next->symtree = fini->proc_tree; - block->next->resolved_sym = fini->proc_tree->n.sym; - block->next->ext.actual = gfc_get_actual_arglist (); - block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); - block->next->ext.actual->next = gfc_get_actual_arglist (); - block->next->ext.actual->next->expr = gfc_copy_expr (size_expr); - - /* ELSE. */ - - block->block = gfc_get_code (EXEC_IF); - block = block->block; - - /* BLOCK ... END BLOCK. */ - block->next = gfc_get_code (EXEC_BLOCK); - block = block->next; - - ns = gfc_build_block_ns (sub_ns); - block->ext.block.ns = ns; - block->ext.block.assoc = NULL; - - gfc_get_symbol ("ptr2", ns, &ptr2); - ptr2->ts.type = BT_DERIVED; - ptr2->ts.u.derived = array->ts.u.derived; - ptr2->attr.flavor = FL_VARIABLE; - ptr2->attr.pointer = 1; - ptr2->attr.artificial = 1; - gfc_set_sym_referenced (ptr2); - gfc_commit_symbol (ptr2); - - gfc_get_symbol ("tmp_array", ns, &tmp_array); - tmp_array->ts.type = BT_DERIVED; - tmp_array->ts.u.derived = array->ts.u.derived; - tmp_array->attr.flavor = FL_VARIABLE; - tmp_array->attr.dimension = 1; - tmp_array->attr.artificial = 1; - tmp_array->as = gfc_get_array_spec(); - tmp_array->attr.intent = INTENT_INOUT; - tmp_array->as->type = AS_EXPLICIT; - tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank; - - for (i = 0; i < tmp_array->as->rank; i++) - { - gfc_expr *shape_expr; - tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, 1); - /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */ - shape_expr - = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size", - gfc_current_locus, 3, - gfc_lval_expr_from_sym (array), - gfc_get_int_expr (gfc_default_integer_kind, - NULL, i+1), - gfc_get_int_expr (gfc_default_integer_kind, - NULL, - gfc_index_integer_kind)); - shape_expr->ts.kind = gfc_index_integer_kind; - tmp_array->as->upper[i] = shape_expr; - } - gfc_set_sym_referenced (tmp_array); - gfc_commit_symbol (tmp_array); - - /* Create loop. */ - iter = gfc_get_iterator (); - iter->var = gfc_lval_expr_from_sym (idx); - iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - iter->end = gfc_lval_expr_from_sym (nelem); - iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - - block = gfc_get_code (EXEC_DO); - ns->code = block; - block->ext.iterator = iter; - block->block = gfc_get_code (EXEC_DO); - - /* Offset calculation for the new array: idx * size of type (in bytes). */ - offset2 = gfc_get_expr (); - offset2->expr_type = EXPR_OP; - offset2->where = gfc_current_locus; - offset2->value.op.op = INTRINSIC_TIMES; - offset2->value.op.op1 = gfc_lval_expr_from_sym (idx); - offset2->value.op.op2 = gfc_copy_expr (size_expr); - offset2->ts = byte_stride->ts; - - /* Offset calculation of "array". */ - block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, - byte_stride, rank, block->block, sub_ns); - - /* Create code for - CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * stride, c_ptr), ptr). */ - block2->next = finalization_scalarizer (array, ptr, - gfc_lval_expr_from_sym (offset), - sub_ns); - block2 = block2->next; - block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); - block2 = block2->next; - - /* ptr2 = ptr. */ - block2->next = gfc_get_code (EXEC_ASSIGN); - block2 = block2->next; - block2->expr1 = gfc_lval_expr_from_sym (ptr2); - block2->expr2 = gfc_lval_expr_from_sym (ptr); - - /* Call now the user's final subroutine. */ - block->next = gfc_get_code (EXEC_CALL); - block = block->next; - block->symtree = fini->proc_tree; - block->resolved_sym = fini->proc_tree->n.sym; - block->ext.actual = gfc_get_actual_arglist (); - block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array); - - if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN) - return; - - /* Copy back. */ - - /* Loop. */ - iter = gfc_get_iterator (); - iter->var = gfc_lval_expr_from_sym (idx); - iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - iter->end = gfc_lval_expr_from_sym (nelem); - iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - - block->next = gfc_get_code (EXEC_DO); - block = block->next; - block->ext.iterator = iter; - block->block = gfc_get_code (EXEC_DO); - - /* Offset calculation of "array". */ - block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, - byte_stride, rank, block->block, sub_ns); - - /* Create code for - CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + offset, c_ptr), ptr). */ - block2->next = finalization_scalarizer (array, ptr, - gfc_lval_expr_from_sym (offset), - sub_ns); - block2 = block2->next; - block2->next = finalization_scalarizer (tmp_array, ptr2, - gfc_copy_expr (offset2), sub_ns); - block2 = block2->next; - - /* ptr = ptr2. */ - block2->next = gfc_get_code (EXEC_ASSIGN); - block2->next->expr1 = gfc_lval_expr_from_sym (ptr); - block2->next->expr2 = gfc_lval_expr_from_sym (ptr2); -} - - -/* Generate the finalization/polymorphic freeing wrapper subroutine for the - derived type "derived". The function first calls the approriate FINAL - subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable - components (but not the inherited ones). Last, it calls the wrapper - subroutine of the parent. The generated wrapper procedure takes as argument - an assumed-rank array. - If neither allocatable components nor FINAL subroutines exists, the vtab - will contain a NULL pointer. - The generated function has the form - _final(assumed-rank array, stride, skip_corarray) - where the array has to be contiguous (except of the lowest dimension). The - stride (in bytes) is used to allow different sizes for ancestor types by - skipping over the additionally added components in the scalarizer. If - "fini_coarray" is false, coarray components are not finalized to allow for - the correct semantic with intrinsic assignment. */ - -static void -generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, - const char *tname, gfc_component *vtab_final) -{ - gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; - gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; - gfc_component *comp; - gfc_namespace *sub_ns; - gfc_code *last_code, *block; - char *name; - bool finalizable_comp = false; - gfc_expr *ancestor_wrapper = NULL, *rank; - gfc_iterator *iter; - - if (derived->attr.unlimited_polymorphic) - { - vtab_final->initializer = gfc_get_null_expr (NULL); - return; - } - - /* Search for the ancestor's finalizers. */ - if (derived->attr.extension && derived->components - && (!derived->components->ts.u.derived->attr.abstract - || has_finalizer_component (derived))) - { - gfc_symbol *vtab; - gfc_component *comp; - - vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); - for (comp = vtab->ts.u.derived->components; comp; comp = comp->next) - if (comp->name[0] == '_' && comp->name[1] == 'f') - { - ancestor_wrapper = comp->initializer; - break; - } - } - - /* No wrapper of the ancestor and no own FINAL subroutines and allocatable - components: Return a NULL() expression; we defer this a bit to have - an interface declaration. */ - if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL) - && !derived->attr.alloc_comp - && (!derived->f2k_derived || !derived->f2k_derived->finalizers) - && !has_finalizer_component (derived)) - { - vtab_final->initializer = gfc_get_null_expr (NULL); - gcc_assert (vtab_final->ts.interface == NULL); - return; - } - else - /* Check whether there are new allocatable components. */ - for (comp = derived->components; comp; comp = comp->next) - { - if (comp == derived->components && derived->attr.extension - && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) - continue; - - finalizable_comp |= comp_is_finalizable (comp); - } - - /* If there is no new finalizer and no new allocatable, return with - an expr to the ancestor's one. */ - if (!finalizable_comp - && (!derived->f2k_derived || !derived->f2k_derived->finalizers)) - { - gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL - && ancestor_wrapper->expr_type == EXPR_VARIABLE); - vtab_final->initializer = gfc_copy_expr (ancestor_wrapper); - vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym; - return; - } - - /* We now create a wrapper, which does the following: - 1. Call the suitable finalization subroutine for this type - 2. Loop over all noninherited allocatable components and noninherited - components with allocatable components and DEALLOCATE those; this will - take care of finalizers, coarray deregistering and allocatable - nested components. - 3. Call the ancestor's finalizer. */ - - /* Declare the wrapper function; it takes an assumed-rank array - and a VALUE logical as arguments. */ - - /* Set up the namespace. */ - sub_ns = gfc_get_namespace (ns, 0); - sub_ns->sibling = ns->contained; - ns->contained = sub_ns; - sub_ns->resolved = 1; - - /* Set up the procedure symbol. */ - name = xasprintf ("__final_%s", tname); - gfc_get_symbol (name, sub_ns, &final); - sub_ns->proc_name = final; - final->attr.flavor = FL_PROCEDURE; - final->attr.function = 1; - final->attr.pure = 0; - final->attr.recursive = 1; - final->result = final; - final->ts.type = BT_INTEGER; - final->ts.kind = 4; - final->attr.artificial = 1; - final->attr.always_explicit = 1; - final->attr.if_source = IFSRC_DECL; - if (ns->proc_name->attr.flavor == FL_MODULE) - final->module = ns->proc_name->name; - gfc_set_sym_referenced (final); - gfc_commit_symbol (final); - - /* Set up formal argument. */ - gfc_get_symbol ("array", sub_ns, &array); - array->ts.type = BT_DERIVED; - array->ts.u.derived = derived; - array->attr.flavor = FL_VARIABLE; - array->attr.dummy = 1; - array->attr.contiguous = 1; - array->attr.dimension = 1; - array->attr.artificial = 1; - array->as = gfc_get_array_spec(); - array->as->type = AS_ASSUMED_RANK; - array->as->rank = -1; - array->attr.intent = INTENT_INOUT; - gfc_set_sym_referenced (array); - final->formal = gfc_get_formal_arglist (); - final->formal->sym = array; - gfc_commit_symbol (array); - - /* Set up formal argument. */ - gfc_get_symbol ("byte_stride", sub_ns, &byte_stride); - byte_stride->ts.type = BT_INTEGER; - byte_stride->ts.kind = gfc_index_integer_kind; - byte_stride->attr.flavor = FL_VARIABLE; - byte_stride->attr.dummy = 1; - byte_stride->attr.value = 1; - byte_stride->attr.artificial = 1; - gfc_set_sym_referenced (byte_stride); - final->formal->next = gfc_get_formal_arglist (); - final->formal->next->sym = byte_stride; - gfc_commit_symbol (byte_stride); - - /* Set up formal argument. */ - gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray); - fini_coarray->ts.type = BT_LOGICAL; - fini_coarray->ts.kind = 1; - fini_coarray->attr.flavor = FL_VARIABLE; - fini_coarray->attr.dummy = 1; - fini_coarray->attr.value = 1; - fini_coarray->attr.artificial = 1; - gfc_set_sym_referenced (fini_coarray); - final->formal->next->next = gfc_get_formal_arglist (); - final->formal->next->next->sym = fini_coarray; - gfc_commit_symbol (fini_coarray); - - /* Local variables. */ - - gfc_get_symbol ("idx", sub_ns, &idx); - idx->ts.type = BT_INTEGER; - idx->ts.kind = gfc_index_integer_kind; - idx->attr.flavor = FL_VARIABLE; - idx->attr.artificial = 1; - gfc_set_sym_referenced (idx); - gfc_commit_symbol (idx); - - gfc_get_symbol ("idx2", sub_ns, &idx2); - idx2->ts.type = BT_INTEGER; - idx2->ts.kind = gfc_index_integer_kind; - idx2->attr.flavor = FL_VARIABLE; - idx2->attr.artificial = 1; - gfc_set_sym_referenced (idx2); - gfc_commit_symbol (idx2); - - gfc_get_symbol ("offset", sub_ns, &offset); - offset->ts.type = BT_INTEGER; - offset->ts.kind = gfc_index_integer_kind; - offset->attr.flavor = FL_VARIABLE; - offset->attr.artificial = 1; - gfc_set_sym_referenced (offset); - gfc_commit_symbol (offset); - - /* Create RANK expression. */ - rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank", - gfc_current_locus, 1, - gfc_lval_expr_from_sym (array)); - if (rank->ts.kind != idx->ts.kind) - gfc_convert_type_warn (rank, &idx->ts, 2, 0); - - /* Create is_contiguous variable. */ - gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous); - is_contiguous->ts.type = BT_LOGICAL; - is_contiguous->ts.kind = gfc_default_logical_kind; - is_contiguous->attr.flavor = FL_VARIABLE; - is_contiguous->attr.artificial = 1; - gfc_set_sym_referenced (is_contiguous); - gfc_commit_symbol (is_contiguous); - - /* Create "sizes(0..rank)" variable, which contains the multiplied - up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1), - sizes(2) = sizes(1) * extent(dim=2) etc. */ - gfc_get_symbol ("sizes", sub_ns, &sizes); - sizes->ts.type = BT_INTEGER; - sizes->ts.kind = gfc_index_integer_kind; - sizes->attr.flavor = FL_VARIABLE; - sizes->attr.dimension = 1; - sizes->attr.artificial = 1; - sizes->as = gfc_get_array_spec(); - sizes->attr.intent = INTENT_INOUT; - sizes->as->type = AS_EXPLICIT; - sizes->as->rank = 1; - sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - sizes->as->upper[0] = gfc_copy_expr (rank); - gfc_set_sym_referenced (sizes); - gfc_commit_symbol (sizes); - - /* Create "strides(1..rank)" variable, which contains the strides per - dimension. */ - gfc_get_symbol ("strides", sub_ns, &strides); - strides->ts.type = BT_INTEGER; - strides->ts.kind = gfc_index_integer_kind; - strides->attr.flavor = FL_VARIABLE; - strides->attr.dimension = 1; - strides->attr.artificial = 1; - strides->as = gfc_get_array_spec(); - strides->attr.intent = INTENT_INOUT; - strides->as->type = AS_EXPLICIT; - strides->as->rank = 1; - strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - strides->as->upper[0] = gfc_copy_expr (rank); - gfc_set_sym_referenced (strides); - gfc_commit_symbol (strides); - - - /* Set return value to 0. */ - last_code = gfc_get_code (EXEC_ASSIGN); - last_code->expr1 = gfc_lval_expr_from_sym (final); - last_code->expr2 = gfc_get_int_expr (4, NULL, 0); - sub_ns->code = last_code; - - /* Set: is_contiguous = .true. */ - last_code->next = gfc_get_code (EXEC_ASSIGN); - last_code = last_code->next; - last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous); - last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, - &gfc_current_locus, true); - - /* Set: sizes(0) = 1. */ - last_code->next = gfc_get_code (EXEC_ASSIGN); - last_code = last_code->next; - last_code->expr1 = gfc_lval_expr_from_sym (sizes); - last_code->expr1->ref = gfc_get_ref (); - last_code->expr1->ref->type = REF_ARRAY; - last_code->expr1->ref->u.ar.type = AR_ELEMENT; - last_code->expr1->ref->u.ar.dimen = 1; - last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - last_code->expr1->ref->u.ar.start[0] - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - last_code->expr1->ref->u.ar.as = sizes->as; - last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - - /* Create: - DO idx = 1, rank - strides(idx) = _F._stride (array, dim=idx) - sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind) - if (strides (idx) /= sizes(i-1)) is_contiguous = .false. - END DO. */ - - /* Create loop. */ - iter = gfc_get_iterator (); - iter->var = gfc_lval_expr_from_sym (idx); - iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - iter->end = gfc_copy_expr (rank); - iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - last_code->next = gfc_get_code (EXEC_DO); - last_code = last_code->next; - last_code->ext.iterator = iter; - last_code->block = gfc_get_code (EXEC_DO); - - /* strides(idx) = _F._stride(array,dim=idx). */ - last_code->block->next = gfc_get_code (EXEC_ASSIGN); - block = last_code->block->next; - - block->expr1 = gfc_lval_expr_from_sym (strides); - block->expr1->ref = gfc_get_ref (); - block->expr1->ref->type = REF_ARRAY; - block->expr1->ref->u.ar.type = AR_ELEMENT; - block->expr1->ref->u.ar.dimen = 1; - block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); - block->expr1->ref->u.ar.as = strides->as; - - block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride", - gfc_current_locus, 2, - gfc_lval_expr_from_sym (array), - gfc_lval_expr_from_sym (idx)); - - /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */ - block->next = gfc_get_code (EXEC_ASSIGN); - block = block->next; - - /* sizes(idx) = ... */ - block->expr1 = gfc_lval_expr_from_sym (sizes); - block->expr1->ref = gfc_get_ref (); - block->expr1->ref->type = REF_ARRAY; - block->expr1->ref->u.ar.type = AR_ELEMENT; - block->expr1->ref->u.ar.dimen = 1; - block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); - block->expr1->ref->u.ar.as = sizes->as; - - block->expr2 = gfc_get_expr (); - block->expr2->expr_type = EXPR_OP; - block->expr2->value.op.op = INTRINSIC_TIMES; - block->expr2->where = gfc_current_locus; - - /* sizes(idx-1). */ - block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); - block->expr2->value.op.op1->ref = gfc_get_ref (); - block->expr2->value.op.op1->ref->type = REF_ARRAY; - block->expr2->value.op.op1->ref->u.ar.as = sizes->as; - block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; - block->expr2->value.op.op1->ref->u.ar.dimen = 1; - block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr (); - block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP; - block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus; - block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; - block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1 - = gfc_lval_expr_from_sym (idx); - block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2 - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - block->expr2->value.op.op1->ref->u.ar.start[0]->ts - = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts; - - /* size(array, dim=idx, kind=index_kind). */ - block->expr2->value.op.op2 - = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size", - gfc_current_locus, 3, - gfc_lval_expr_from_sym (array), - gfc_lval_expr_from_sym (idx), - gfc_get_int_expr (gfc_index_integer_kind, - NULL, - gfc_index_integer_kind)); - block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind; - block->expr2->ts = idx->ts; - - /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */ - block->next = gfc_get_code (EXEC_IF); - block = block->next; - - block->block = gfc_get_code (EXEC_IF); - block = block->block; - - /* if condition: strides(idx) /= sizes(idx-1). */ - block->expr1 = gfc_get_expr (); - block->expr1->ts.type = BT_LOGICAL; - block->expr1->ts.kind = gfc_default_logical_kind; - block->expr1->expr_type = EXPR_OP; - block->expr1->where = gfc_current_locus; - block->expr1->value.op.op = INTRINSIC_NE; - - block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides); - block->expr1->value.op.op1->ref = gfc_get_ref (); - block->expr1->value.op.op1->ref->type = REF_ARRAY; - block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT; - block->expr1->value.op.op1->ref->u.ar.dimen = 1; - block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); - block->expr1->value.op.op1->ref->u.ar.as = strides->as; - - block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes); - block->expr1->value.op.op2->ref = gfc_get_ref (); - block->expr1->value.op.op2->ref->type = REF_ARRAY; - block->expr1->value.op.op2->ref->u.ar.as = sizes->as; - block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT; - block->expr1->value.op.op2->ref->u.ar.dimen = 1; - block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); - block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; - block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus; - block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; - block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1 - = gfc_lval_expr_from_sym (idx); - block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2 - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - block->expr1->value.op.op2->ref->u.ar.start[0]->ts - = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; - - /* if body: is_contiguous = .false. */ - block->next = gfc_get_code (EXEC_ASSIGN); - block = block->next; - block->expr1 = gfc_lval_expr_from_sym (is_contiguous); - block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, - &gfc_current_locus, false); - - /* Obtain the size (number of elements) of "array" MINUS ONE, - which is used in the scalarization. */ - gfc_get_symbol ("nelem", sub_ns, &nelem); - nelem->ts.type = BT_INTEGER; - nelem->ts.kind = gfc_index_integer_kind; - nelem->attr.flavor = FL_VARIABLE; - nelem->attr.artificial = 1; - gfc_set_sym_referenced (nelem); - gfc_commit_symbol (nelem); - - /* nelem = sizes (rank) - 1. */ - last_code->next = gfc_get_code (EXEC_ASSIGN); - last_code = last_code->next; - - last_code->expr1 = gfc_lval_expr_from_sym (nelem); - - last_code->expr2 = gfc_get_expr (); - last_code->expr2->expr_type = EXPR_OP; - last_code->expr2->value.op.op = INTRINSIC_MINUS; - last_code->expr2->value.op.op2 - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - last_code->expr2->ts = last_code->expr2->value.op.op2->ts; - last_code->expr2->where = gfc_current_locus; - - last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); - last_code->expr2->value.op.op1->ref = gfc_get_ref (); - last_code->expr2->value.op.op1->ref->type = REF_ARRAY; - last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; - last_code->expr2->value.op.op1->ref->u.ar.dimen = 1; - last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; - last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank); - last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as; - - /* Call final subroutines. We now generate code like: - use iso_c_binding - integer, pointer :: ptr - type(c_ptr) :: cptr - integer(c_intptr_t) :: i, addr - - select case (rank (array)) - case (3) - ! If needed, the array is packed - call final_rank3 (array) - case default: - do i = 0, size (array)-1 - addr = transfer (c_loc (array), addr) + i * stride - call c_f_pointer (transfer (addr, cptr), ptr) - call elemental_final (ptr) - end do - end select */ - - if (derived->f2k_derived && derived->f2k_derived->finalizers) - { - gfc_finalizer *fini, *fini_elem = NULL; - - gfc_get_symbol ("ptr1", sub_ns, &ptr); - ptr->ts.type = BT_DERIVED; - ptr->ts.u.derived = derived; - ptr->attr.flavor = FL_VARIABLE; - ptr->attr.pointer = 1; - ptr->attr.artificial = 1; - gfc_set_sym_referenced (ptr); - gfc_commit_symbol (ptr); - - /* SELECT CASE (RANK (array)). */ - last_code->next = gfc_get_code (EXEC_SELECT); - last_code = last_code->next; - last_code->expr1 = gfc_copy_expr (rank); - block = NULL; - - for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next) - { - gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */ - if (fini->proc_tree->n.sym->attr.elemental) - { - fini_elem = fini; - continue; - } - - /* CASE (fini_rank). */ - if (block) - { - block->block = gfc_get_code (EXEC_SELECT); - block = block->block; - } - else - { - block = gfc_get_code (EXEC_SELECT); - last_code->block = block; - } - block->ext.block.case_list = gfc_get_case (); - block->ext.block.case_list->where = gfc_current_locus; - if (fini->proc_tree->n.sym->formal->sym->attr.dimension) - block->ext.block.case_list->low - = gfc_get_int_expr (gfc_default_integer_kind, NULL, - fini->proc_tree->n.sym->formal->sym->as->rank); - else - block->ext.block.case_list->low - = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - block->ext.block.case_list->high - = gfc_copy_expr (block->ext.block.case_list->low); - - /* CALL fini_rank (array) - possibly with packing. */ - if (fini->proc_tree->n.sym->formal->sym->attr.dimension) - finalizer_insert_packed_call (block, fini, array, byte_stride, - idx, ptr, nelem, strides, - sizes, idx2, offset, is_contiguous, - rank, sub_ns); - else - { - block->next = gfc_get_code (EXEC_CALL); - block->next->symtree = fini->proc_tree; - block->next->resolved_sym = fini->proc_tree->n.sym; - block->next->ext.actual = gfc_get_actual_arglist (); - block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); - } - } - - /* Elemental call - scalarized. */ - if (fini_elem) - { - /* CASE DEFAULT. */ - if (block) - { - block->block = gfc_get_code (EXEC_SELECT); - block = block->block; - } - else - { - block = gfc_get_code (EXEC_SELECT); - last_code->block = block; - } - block->ext.block.case_list = gfc_get_case (); - - /* Create loop. */ - iter = gfc_get_iterator (); - iter->var = gfc_lval_expr_from_sym (idx); - iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - iter->end = gfc_lval_expr_from_sym (nelem); - iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - block->next = gfc_get_code (EXEC_DO); - block = block->next; - block->ext.iterator = iter; - block->block = gfc_get_code (EXEC_DO); - - /* Offset calculation. */ - block = finalization_get_offset (idx, idx2, offset, strides, sizes, - byte_stride, rank, block->block, - sub_ns); - - /* Create code for - CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + offset, c_ptr), ptr). */ - block->next - = finalization_scalarizer (array, ptr, - gfc_lval_expr_from_sym (offset), - sub_ns); - block = block->next; - - /* CALL final_elemental (array). */ - block->next = gfc_get_code (EXEC_CALL); - block = block->next; - block->symtree = fini_elem->proc_tree; - block->resolved_sym = fini_elem->proc_sym; - block->ext.actual = gfc_get_actual_arglist (); - block->ext.actual->expr = gfc_lval_expr_from_sym (ptr); - } - } - - /* Finalize and deallocate allocatable components. The same manual - scalarization is used as above. */ - - if (finalizable_comp) - { - gfc_symbol *stat; - gfc_code *block = NULL; - - if (!ptr) - { - gfc_get_symbol ("ptr2", sub_ns, &ptr); - ptr->ts.type = BT_DERIVED; - ptr->ts.u.derived = derived; - ptr->attr.flavor = FL_VARIABLE; - ptr->attr.pointer = 1; - ptr->attr.artificial = 1; - gfc_set_sym_referenced (ptr); - gfc_commit_symbol (ptr); - } - - gfc_get_symbol ("ignore", sub_ns, &stat); - stat->attr.flavor = FL_VARIABLE; - stat->attr.artificial = 1; - stat->ts.type = BT_INTEGER; - stat->ts.kind = gfc_default_integer_kind; - gfc_set_sym_referenced (stat); - gfc_commit_symbol (stat); - - /* Create loop. */ - iter = gfc_get_iterator (); - iter->var = gfc_lval_expr_from_sym (idx); - iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - iter->end = gfc_lval_expr_from_sym (nelem); - iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - last_code->next = gfc_get_code (EXEC_DO); - last_code = last_code->next; - last_code->ext.iterator = iter; - last_code->block = gfc_get_code (EXEC_DO); - - /* Offset calculation. */ - block = finalization_get_offset (idx, idx2, offset, strides, sizes, - byte_stride, rank, last_code->block, - sub_ns); - - /* Create code for - CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * stride, c_ptr), ptr). */ - block->next = finalization_scalarizer (array, ptr, - gfc_lval_expr_from_sym(offset), - sub_ns); - block = block->next; - - for (comp = derived->components; comp; comp = comp->next) - { - if (comp == derived->components && derived->attr.extension - && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) - continue; - - finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp, - stat, fini_coarray, &block, sub_ns); - if (!last_code->block->next) - last_code->block->next = block; - } - - } - - /* Call the finalizer of the ancestor. */ - if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) - { - last_code->next = gfc_get_code (EXEC_CALL); - last_code = last_code->next; - last_code->symtree = ancestor_wrapper->symtree; - last_code->resolved_sym = ancestor_wrapper->symtree->n.sym; - - last_code->ext.actual = gfc_get_actual_arglist (); - last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); - last_code->ext.actual->next = gfc_get_actual_arglist (); - last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride); - last_code->ext.actual->next->next = gfc_get_actual_arglist (); - last_code->ext.actual->next->next->expr - = gfc_lval_expr_from_sym (fini_coarray); - } - - gfc_free_expr (rank); - vtab_final->initializer = gfc_lval_expr_from_sym (final); - vtab_final->ts.interface = final; - free (name); -} - - -/* Add procedure pointers for all type-bound procedures to a vtab. */ - -static void -add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) -{ - gfc_symbol* super_type; - - super_type = gfc_get_derived_super_type (derived); - - if (super_type && (super_type != derived)) - { - /* Make sure that the PPCs appear in the same order as in the parent. */ - copy_vtab_proc_comps (super_type, vtype); - /* Only needed to get the PPC initializers right. */ - add_procs_to_declared_vtab (super_type, vtype); - } - - if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) - add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); - - if (derived->f2k_derived && derived->f2k_derived->tb_uop_root) - add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype); -} - - -/* Find or generate the symbol for a derived type's vtab. */ - -gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived) -{ - gfc_namespace *ns; - gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; - gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; - gfc_gsymbol *gsym = NULL; - gfc_symbol *dealloc = NULL, *arg = NULL; - - if (derived->attr.pdt_template) - return NULL; - - /* Find the top-level namespace. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - if (!ns->parent) - break; - - /* If the type is a class container, use the underlying derived type. */ - if (!derived->attr.unlimited_polymorphic && derived->attr.is_class) - derived = gfc_get_derived_super_type (derived); - - if (!derived) - return NULL; - - if (!derived->name) - return NULL; - - /* Find the gsymbol for the module of use associated derived types. */ - if ((derived->attr.use_assoc || derived->attr.used_in_submodule) - && !derived->attr.vtype && !derived->attr.is_class) - gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module); - else - gsym = NULL; - - /* Work in the gsymbol namespace if the top-level namespace is a module. - This ensures that the vtable is unique, which is required since we use - its address in SELECT TYPE. */ - if (gsym && gsym->ns && ns && ns->proc_name - && ns->proc_name->attr.flavor == FL_MODULE) - ns = gsym->ns; - - if (ns) - { - char tname[GFC_MAX_SYMBOL_LEN+1]; - char *name; - - get_unique_hashed_string (tname, derived); - name = xasprintf ("__vtab_%s", tname); - - /* Look for the vtab symbol in various namespaces. */ - if (gsym && gsym->ns) - { - gfc_find_symbol (name, gsym->ns, 0, &vtab); - if (vtab) - ns = gsym->ns; - } - if (vtab == NULL) - gfc_find_symbol (name, gfc_current_ns, 0, &vtab); - if (vtab == NULL) - gfc_find_symbol (name, ns, 0, &vtab); - if (vtab == NULL) - gfc_find_symbol (name, derived->ns, 0, &vtab); - - if (vtab == NULL) - { - gfc_get_symbol (name, ns, &vtab); - vtab->ts.type = BT_DERIVED; - if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, - &gfc_current_locus)) - goto cleanup; - vtab->attr.target = 1; - vtab->attr.save = SAVE_IMPLICIT; - vtab->attr.vtab = 1; - vtab->attr.access = ACCESS_PUBLIC; - gfc_set_sym_referenced (vtab); - name = xasprintf ("__vtype_%s", tname); - - gfc_find_symbol (name, ns, 0, &vtype); - if (vtype == NULL) - { - gfc_component *c; - gfc_symbol *parent = NULL, *parent_vtab = NULL; - bool rdt = false; - - /* Is this a derived type with recursive allocatable - components? */ - c = (derived->attr.unlimited_polymorphic - || derived->attr.abstract) ? - NULL : derived->components; - for (; c; c= c->next) - if (c->ts.type == BT_DERIVED - && c->ts.u.derived == derived) - { - rdt = true; - break; - } - - gfc_get_symbol (name, ns, &vtype); - if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, - &gfc_current_locus)) - goto cleanup; - vtype->attr.access = ACCESS_PUBLIC; - vtype->attr.vtype = 1; - gfc_set_sym_referenced (vtype); - - /* Add component '_hash'. */ - if (!gfc_add_component (vtype, "_hash", &c)) - goto cleanup; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - c->initializer = gfc_get_int_expr (gfc_default_integer_kind, - NULL, derived->hash_value); - - /* Add component '_size'. */ - if (!gfc_add_component (vtype, "_size", &c)) - goto cleanup; - c->ts.type = BT_INTEGER; - c->ts.kind = gfc_size_kind; - c->attr.access = ACCESS_PRIVATE; - /* Remember the derived type in ts.u.derived, - so that the correct initializer can be set later on - (in gfc_conv_structure). */ - c->ts.u.derived = derived; - c->initializer = gfc_get_int_expr (gfc_size_kind, - NULL, 0); - - /* Add component _extends. */ - if (!gfc_add_component (vtype, "_extends", &c)) - goto cleanup; - c->attr.pointer = 1; - c->attr.access = ACCESS_PRIVATE; - if (!derived->attr.unlimited_polymorphic) - parent = gfc_get_derived_super_type (derived); - else - parent = NULL; - - if (parent) - { - parent_vtab = gfc_find_derived_vtab (parent); - c->ts.type = BT_DERIVED; - c->ts.u.derived = parent_vtab->ts.u.derived; - c->initializer = gfc_get_expr (); - c->initializer->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, - 0, &c->initializer->symtree); - } - else - { - c->ts.type = BT_DERIVED; - c->ts.u.derived = vtype; - c->initializer = gfc_get_null_expr (NULL); - } - - if (!derived->attr.unlimited_polymorphic - && derived->components == NULL - && !derived->attr.zero_comp) - { - /* At this point an error must have occurred. - Prevent further errors on the vtype components. */ - found_sym = vtab; - goto have_vtype; - } - - /* Add component _def_init. */ - if (!gfc_add_component (vtype, "_def_init", &c)) - goto cleanup; - c->attr.pointer = 1; - c->attr.artificial = 1; - c->attr.access = ACCESS_PRIVATE; - c->ts.type = BT_DERIVED; - c->ts.u.derived = derived; - if (derived->attr.unlimited_polymorphic - || derived->attr.abstract) - c->initializer = gfc_get_null_expr (NULL); - else - { - /* Construct default initialization variable. */ - name = xasprintf ("__def_init_%s", tname); - gfc_get_symbol (name, ns, &def_init); - def_init->attr.target = 1; - def_init->attr.artificial = 1; - def_init->attr.save = SAVE_IMPLICIT; - def_init->attr.access = ACCESS_PUBLIC; - def_init->attr.flavor = FL_VARIABLE; - gfc_set_sym_referenced (def_init); - def_init->ts.type = BT_DERIVED; - def_init->ts.u.derived = derived; - def_init->value = gfc_default_initializer (&def_init->ts); - - c->initializer = gfc_lval_expr_from_sym (def_init); - } - - /* Add component _copy. */ - if (!gfc_add_component (vtype, "_copy", &c)) - goto cleanup; - c->attr.proc_pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->tb = XCNEW (gfc_typebound_proc); - c->tb->ppc = 1; - if (derived->attr.unlimited_polymorphic - || derived->attr.abstract) - c->initializer = gfc_get_null_expr (NULL); - else - { - /* Set up namespace. */ - gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); - sub_ns->sibling = ns->contained; - ns->contained = sub_ns; - sub_ns->resolved = 1; - /* Set up procedure symbol. */ - name = xasprintf ("__copy_%s", tname); - gfc_get_symbol (name, sub_ns, ©); - sub_ns->proc_name = copy; - copy->attr.flavor = FL_PROCEDURE; - copy->attr.subroutine = 1; - copy->attr.pure = 1; - copy->attr.artificial = 1; - copy->attr.if_source = IFSRC_DECL; - /* This is elemental so that arrays are automatically - treated correctly by the scalarizer. */ - copy->attr.elemental = 1; - if (ns->proc_name->attr.flavor == FL_MODULE) - copy->module = ns->proc_name->name; - gfc_set_sym_referenced (copy); - /* Set up formal arguments. */ - gfc_get_symbol ("src", sub_ns, &src); - src->ts.type = BT_DERIVED; - src->ts.u.derived = derived; - src->attr.flavor = FL_VARIABLE; - src->attr.dummy = 1; - src->attr.artificial = 1; - src->attr.intent = INTENT_IN; - gfc_set_sym_referenced (src); - copy->formal = gfc_get_formal_arglist (); - copy->formal->sym = src; - gfc_get_symbol ("dst", sub_ns, &dst); - dst->ts.type = BT_DERIVED; - dst->ts.u.derived = derived; - dst->attr.flavor = FL_VARIABLE; - dst->attr.dummy = 1; - dst->attr.artificial = 1; - dst->attr.intent = INTENT_INOUT; - gfc_set_sym_referenced (dst); - copy->formal->next = gfc_get_formal_arglist (); - copy->formal->next->sym = dst; - /* Set up code. */ - sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN); - sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); - sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); - /* Set initializer. */ - c->initializer = gfc_lval_expr_from_sym (copy); - c->ts.interface = copy; - } - - /* Add component _final, which contains a procedure pointer to - a wrapper which handles both the freeing of allocatable - components and the calls to finalization subroutines. - Note: The actual wrapper function can only be generated - at resolution time. */ - if (!gfc_add_component (vtype, "_final", &c)) - goto cleanup; - c->attr.proc_pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->attr.artificial = 1; - c->tb = XCNEW (gfc_typebound_proc); - c->tb->ppc = 1; - generate_finalization_wrapper (derived, ns, tname, c); - - /* Add component _deallocate. */ - if (!gfc_add_component (vtype, "_deallocate", &c)) - goto cleanup; - c->attr.proc_pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->tb = XCNEW (gfc_typebound_proc); - c->tb->ppc = 1; - if (derived->attr.unlimited_polymorphic - || derived->attr.abstract - || !rdt) - c->initializer = gfc_get_null_expr (NULL); - else - { - /* Set up namespace. */ - gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); - - sub_ns->sibling = ns->contained; - ns->contained = sub_ns; - sub_ns->resolved = 1; - /* Set up procedure symbol. */ - name = xasprintf ("__deallocate_%s", tname); - gfc_get_symbol (name, sub_ns, &dealloc); - sub_ns->proc_name = dealloc; - dealloc->attr.flavor = FL_PROCEDURE; - dealloc->attr.subroutine = 1; - dealloc->attr.pure = 1; - dealloc->attr.artificial = 1; - dealloc->attr.if_source = IFSRC_DECL; - - if (ns->proc_name->attr.flavor == FL_MODULE) - dealloc->module = ns->proc_name->name; - gfc_set_sym_referenced (dealloc); - /* Set up formal argument. */ - gfc_get_symbol ("arg", sub_ns, &arg); - arg->ts.type = BT_DERIVED; - arg->ts.u.derived = derived; - arg->attr.flavor = FL_VARIABLE; - arg->attr.dummy = 1; - arg->attr.artificial = 1; - arg->attr.intent = INTENT_INOUT; - arg->attr.dimension = 1; - arg->attr.allocatable = 1; - arg->as = gfc_get_array_spec(); - arg->as->type = AS_ASSUMED_SHAPE; - arg->as->rank = 1; - arg->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, 1); - gfc_set_sym_referenced (arg); - dealloc->formal = gfc_get_formal_arglist (); - dealloc->formal->sym = arg; - /* Set up code. */ - sub_ns->code = gfc_get_code (EXEC_DEALLOCATE); - sub_ns->code->ext.alloc.list = gfc_get_alloc (); - sub_ns->code->ext.alloc.list->expr - = gfc_lval_expr_from_sym (arg); - /* Set initializer. */ - c->initializer = gfc_lval_expr_from_sym (dealloc); - c->ts.interface = dealloc; - } - - /* Add procedure pointers for type-bound procedures. */ - if (!derived->attr.unlimited_polymorphic) - add_procs_to_declared_vtab (derived, vtype); - } - -have_vtype: - vtab->ts.u.derived = vtype; - vtab->value = gfc_default_initializer (&vtab->ts); - } - free (name); - } - - found_sym = vtab; - -cleanup: - /* It is unexpected to have some symbols added at resolution or code - generation time. We commit the changes in order to keep a clean state. */ - if (found_sym) - { - gfc_commit_symbol (vtab); - if (vtype) - gfc_commit_symbol (vtype); - if (def_init) - gfc_commit_symbol (def_init); - if (copy) - gfc_commit_symbol (copy); - if (src) - gfc_commit_symbol (src); - if (dst) - gfc_commit_symbol (dst); - if (dealloc) - gfc_commit_symbol (dealloc); - if (arg) - gfc_commit_symbol (arg); - } - else - gfc_undo_symbols (); - - return found_sym; -} - - -/* Check if a derived type is finalizable. That is the case if it - (1) has a FINAL subroutine or - (2) has a nonpointer nonallocatable component of finalizable type. - If it is finalizable, return an expression containing the - finalization wrapper. */ - -bool -gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr) -{ - gfc_symbol *vtab; - gfc_component *c; - - /* (1) Check for FINAL subroutines. */ - if (derived->f2k_derived && derived->f2k_derived->finalizers) - goto yes; - - /* (2) Check for components of finalizable type. */ - for (c = derived->components; c; c = c->next) - if (c->ts.type == BT_DERIVED - && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable - && gfc_is_finalizable (c->ts.u.derived, NULL)) - goto yes; - - return false; - -yes: - /* Make sure vtab is generated. */ - vtab = gfc_find_derived_vtab (derived); - if (final_expr) - { - /* Return finalizer expression. */ - gfc_component *final; - final = vtab->ts.u.derived->components->next->next->next->next->next; - gcc_assert (strcmp (final->name, "_final") == 0); - gcc_assert (final->initializer - && final->initializer->expr_type != EXPR_NULL); - *final_expr = final->initializer; - } - return true; -} - - -/* Find (or generate) the symbol for an intrinsic type's vtab. This is - needed to support unlimited polymorphism. */ - -static gfc_symbol * -find_intrinsic_vtab (gfc_typespec *ts) -{ - gfc_namespace *ns; - gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL; - gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; - - /* Find the top-level namespace. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - if (!ns->parent) - break; - - if (ns) - { - char tname[GFC_MAX_SYMBOL_LEN+1]; - char *name; - - /* Encode all types as TYPENAME_KIND_ including especially character - arrays, whose length is now consistently stored in the _len component - of the class-variable. */ - sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); - name = xasprintf ("__vtab_%s", tname); - - /* Look for the vtab symbol in the top-level namespace only. */ - gfc_find_symbol (name, ns, 0, &vtab); - - if (vtab == NULL) - { - gfc_get_symbol (name, ns, &vtab); - vtab->ts.type = BT_DERIVED; - if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, - &gfc_current_locus)) - goto cleanup; - vtab->attr.target = 1; - vtab->attr.save = SAVE_IMPLICIT; - vtab->attr.vtab = 1; - vtab->attr.access = ACCESS_PUBLIC; - gfc_set_sym_referenced (vtab); - name = xasprintf ("__vtype_%s", tname); - - gfc_find_symbol (name, ns, 0, &vtype); - if (vtype == NULL) - { - gfc_component *c; - int hash; - gfc_namespace *sub_ns; - gfc_namespace *contained; - gfc_expr *e; - size_t e_size; - - gfc_get_symbol (name, ns, &vtype); - if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, - &gfc_current_locus)) - goto cleanup; - vtype->attr.access = ACCESS_PUBLIC; - vtype->attr.vtype = 1; - gfc_set_sym_referenced (vtype); - - /* Add component '_hash'. */ - if (!gfc_add_component (vtype, "_hash", &c)) - goto cleanup; - c->ts.type = BT_INTEGER; - c->ts.kind = 4; - c->attr.access = ACCESS_PRIVATE; - hash = gfc_intrinsic_hash_value (ts); - c->initializer = gfc_get_int_expr (gfc_default_integer_kind, - NULL, hash); - - /* Add component '_size'. */ - if (!gfc_add_component (vtype, "_size", &c)) - goto cleanup; - c->ts.type = BT_INTEGER; - c->ts.kind = gfc_size_kind; - c->attr.access = ACCESS_PRIVATE; - - /* Build a minimal expression to make use of - target-memory.c/gfc_element_size for 'size'. Special handling - for character arrays, that are not constant sized: to support - len (str) * kind, only the kind information is stored in the - vtab. */ - e = gfc_get_expr (); - e->ts = *ts; - e->expr_type = EXPR_VARIABLE; - if (ts->type == BT_CHARACTER) - e_size = ts->kind; - else - gfc_element_size (e, &e_size); - c->initializer = gfc_get_int_expr (gfc_size_kind, - NULL, - e_size); - gfc_free_expr (e); - - /* Add component _extends. */ - if (!gfc_add_component (vtype, "_extends", &c)) - goto cleanup; - c->attr.pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->ts.type = BT_VOID; - c->initializer = gfc_get_null_expr (NULL); - - /* Add component _def_init. */ - if (!gfc_add_component (vtype, "_def_init", &c)) - goto cleanup; - c->attr.pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->ts.type = BT_VOID; - c->initializer = gfc_get_null_expr (NULL); - - /* Add component _copy. */ - if (!gfc_add_component (vtype, "_copy", &c)) - goto cleanup; - c->attr.proc_pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->tb = XCNEW (gfc_typebound_proc); - c->tb->ppc = 1; - - if (ts->type != BT_CHARACTER) - name = xasprintf ("__copy_%s", tname); - else - { - /* __copy is always the same for characters. - Check to see if copy function already exists. */ - name = xasprintf ("__copy_character_%d", ts->kind); - contained = ns->contained; - for (; contained; contained = contained->sibling) - if (contained->proc_name - && strcmp (name, contained->proc_name->name) == 0) - { - copy = contained->proc_name; - goto got_char_copy; - } - } - - /* Set up namespace. */ - sub_ns = gfc_get_namespace (ns, 0); - sub_ns->sibling = ns->contained; - ns->contained = sub_ns; - sub_ns->resolved = 1; - /* Set up procedure symbol. */ - gfc_get_symbol (name, sub_ns, ©); - sub_ns->proc_name = copy; - copy->attr.flavor = FL_PROCEDURE; - copy->attr.subroutine = 1; - copy->attr.pure = 1; - copy->attr.if_source = IFSRC_DECL; - /* This is elemental so that arrays are automatically - treated correctly by the scalarizer. */ - copy->attr.elemental = 1; - if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE) - copy->module = ns->proc_name->name; - gfc_set_sym_referenced (copy); - /* Set up formal arguments. */ - gfc_get_symbol ("src", sub_ns, &src); - src->ts.type = ts->type; - src->ts.kind = ts->kind; - src->attr.flavor = FL_VARIABLE; - src->attr.dummy = 1; - src->attr.intent = INTENT_IN; - gfc_set_sym_referenced (src); - copy->formal = gfc_get_formal_arglist (); - copy->formal->sym = src; - gfc_get_symbol ("dst", sub_ns, &dst); - dst->ts.type = ts->type; - dst->ts.kind = ts->kind; - dst->attr.flavor = FL_VARIABLE; - dst->attr.dummy = 1; - dst->attr.intent = INTENT_INOUT; - gfc_set_sym_referenced (dst); - copy->formal->next = gfc_get_formal_arglist (); - copy->formal->next->sym = dst; - /* Set up code. */ - sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN); - sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); - sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); - got_char_copy: - /* Set initializer. */ - c->initializer = gfc_lval_expr_from_sym (copy); - c->ts.interface = copy; - - /* Add component _final. */ - if (!gfc_add_component (vtype, "_final", &c)) - goto cleanup; - c->attr.proc_pointer = 1; - c->attr.access = ACCESS_PRIVATE; - c->attr.artificial = 1; - c->tb = XCNEW (gfc_typebound_proc); - c->tb->ppc = 1; - c->initializer = gfc_get_null_expr (NULL); - } - vtab->ts.u.derived = vtype; - vtab->value = gfc_default_initializer (&vtab->ts); - } - free (name); - } - - found_sym = vtab; - -cleanup: - /* It is unexpected to have some symbols added at resolution or code - generation time. We commit the changes in order to keep a clean state. */ - if (found_sym) - { - gfc_commit_symbol (vtab); - if (vtype) - gfc_commit_symbol (vtype); - if (copy) - gfc_commit_symbol (copy); - if (src) - gfc_commit_symbol (src); - if (dst) - gfc_commit_symbol (dst); - } - else - gfc_undo_symbols (); - - return found_sym; -} - - -/* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */ - -gfc_symbol * -gfc_find_vtab (gfc_typespec *ts) -{ - switch (ts->type) - { - case BT_UNKNOWN: - return NULL; - case BT_DERIVED: - return gfc_find_derived_vtab (ts->u.derived); - case BT_CLASS: - if (ts->u.derived->attr.is_class - && ts->u.derived->components - && ts->u.derived->components->ts.u.derived) - return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived); - else - return NULL; - default: - return find_intrinsic_vtab (ts); - } -} - - -/* General worker function to find either a type-bound procedure or a - type-bound user operator. */ - -static gfc_symtree* -find_typebound_proc_uop (gfc_symbol* derived, bool* t, - const char* name, bool noaccess, bool uop, - locus* where) -{ - gfc_symtree* res; - gfc_symtree* root; - - /* Set default to failure. */ - if (t) - *t = false; - - if (derived->f2k_derived) - /* Set correct symbol-root. */ - root = (uop ? derived->f2k_derived->tb_uop_root - : derived->f2k_derived->tb_sym_root); - else - return NULL; - - /* Try to find it in the current type's namespace. */ - res = gfc_find_symtree (root, name); - if (res && res->n.tb && !res->n.tb->error) - { - /* We found one. */ - if (t) - *t = true; - - if (!noaccess && derived->attr.use_assoc - && res->n.tb->access == ACCESS_PRIVATE) - { - if (where) - gfc_error ("%qs of %qs is PRIVATE at %L", - name, derived->name, where); - if (t) - *t = false; - } - - return res; - } - - /* Otherwise, recurse on parent type if derived is an extension. */ - if (derived->attr.extension) - { - gfc_symbol* super_type; - super_type = gfc_get_derived_super_type (derived); - gcc_assert (super_type); - - return find_typebound_proc_uop (super_type, t, name, - noaccess, uop, where); - } - - /* Nothing found. */ - return NULL; -} - - -/* Find a type-bound procedure or user operator by name for a derived-type - (looking recursively through the super-types). */ - -gfc_symtree* -gfc_find_typebound_proc (gfc_symbol* derived, bool* t, - const char* name, bool noaccess, locus* where) -{ - return find_typebound_proc_uop (derived, t, name, noaccess, false, where); -} - -gfc_symtree* -gfc_find_typebound_user_op (gfc_symbol* derived, bool* t, - const char* name, bool noaccess, locus* where) -{ - return find_typebound_proc_uop (derived, t, name, noaccess, true, where); -} - - -/* Find a type-bound intrinsic operator looking recursively through the - super-type hierarchy. */ - -gfc_typebound_proc* -gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t, - gfc_intrinsic_op op, bool noaccess, - locus* where) -{ - gfc_typebound_proc* res; - - /* Set default to failure. */ - if (t) - *t = false; - - /* Try to find it in the current type's namespace. */ - if (derived->f2k_derived) - res = derived->f2k_derived->tb_op[op]; - else - res = NULL; - - /* Check access. */ - if (res && !res->error) - { - /* We found one. */ - if (t) - *t = true; - - if (!noaccess && derived->attr.use_assoc - && res->access == ACCESS_PRIVATE) - { - if (where) - gfc_error ("%qs of %qs is PRIVATE at %L", - gfc_op2string (op), derived->name, where); - if (t) - *t = false; - } - - return res; - } - - /* Otherwise, recurse on parent type if derived is an extension. */ - if (derived->attr.extension) - { - gfc_symbol* super_type; - super_type = gfc_get_derived_super_type (derived); - gcc_assert (super_type); - - return gfc_find_typebound_intrinsic_op (super_type, t, op, - noaccess, where); - } - - /* Nothing found. */ - return NULL; -} - - -/* Get a typebound-procedure symtree or create and insert it if not yet - present. This is like a very simplified version of gfc_get_sym_tree for - tbp-symtrees rather than regular ones. */ - -gfc_symtree* -gfc_get_tbp_symtree (gfc_symtree **root, const char *name) -{ - gfc_symtree *result = gfc_find_symtree (*root, name); - return result ? result : gfc_new_symtree (root, name); -} diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc new file mode 100644 index 0000000..2cb0c65 --- /dev/null +++ b/gcc/fortran/class.cc @@ -0,0 +1,3073 @@ +/* Implementation of Fortran 2003 Polymorphism. + Copyright (C) 2009-2022 Free Software Foundation, Inc. + Contributed by Paul Richard Thomas + and Janus Weil + +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 +. */ + + +/* class.c -- This file contains the front end functions needed to service + the implementation of Fortran 2003 polymorphism and other + object-oriented features. */ + + +/* Outline of the internal representation: + + Each CLASS variable is encapsulated by a class container, which is a + structure with two fields: + * _data: A pointer to the actual data of the variable. This field has the + declared type of the class variable and its attributes + (pointer/allocatable/dimension/...). + * _vptr: A pointer to the vtable entry (see below) of the dynamic type. + + Only for unlimited polymorphic classes: + * _len: An integer(C_SIZE_T) to store the string length when the unlimited + polymorphic pointer is used to point to a char array. The '_len' + component will be zero when no character array is stored in + '_data'. + + For each derived type we set up a "vtable" entry, i.e. a structure with the + following fields: + * _hash: A hash value serving as a unique identifier for this type. + * _size: The size in bytes of the derived type. + * _extends: A pointer to the vtable entry of the parent derived type. + * _def_init: A pointer to a default initialized variable of this type. + * _copy: A procedure pointer to a copying procedure. + * _final: A procedure pointer to a wrapper function, which frees + allocatable components and calls FINAL subroutines. + * _deallocate: A procedure pointer to a deallocation procedure; nonnull + only for a recursive derived type. + + After these follow procedure pointer components for the specific + type-bound procedures. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "constructor.h" +#include "target-memory.h" + +/* Inserts a derived type component reference in a data reference chain. + TS: base type of the ref chain so far, in which we will pick the component + REF: the address of the GFC_REF pointer to update + NAME: name of the component to insert + Note that component insertion makes sense only if we are at the end of + the chain (*REF == NULL) or if we are adding a missing "_data" component + to access the actual contents of a class object. */ + +static void +insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name) +{ + gfc_ref *new_ref; + int wcnt, ecnt; + + gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS); + + gfc_find_component (ts->u.derived, name, true, true, &new_ref); + + gfc_get_errors (&wcnt, &ecnt); + if (ecnt > 0 && !new_ref) + return; + gcc_assert (new_ref->u.c.component); + + while (new_ref->next) + new_ref = new_ref->next; + new_ref->next = *ref; + + if (new_ref->next) + { + gfc_ref *next = NULL; + + /* We need to update the base type in the trailing reference chain to + that of the new component. */ + + gcc_assert (strcmp (name, "_data") == 0); + + if (new_ref->next->type == REF_COMPONENT) + next = new_ref->next; + else if (new_ref->next->type == REF_ARRAY + && new_ref->next->next + && new_ref->next->next->type == REF_COMPONENT) + next = new_ref->next->next; + + if (next != NULL) + { + gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS + || new_ref->u.c.component->ts.type == BT_DERIVED); + next->u.c.sym = new_ref->u.c.component->ts.u.derived; + } + } + + *ref = new_ref; +} + + +/* Tells whether we need to add a "_data" reference to access REF subobject + from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base + object accessed by REF is a variable; in other words it is a full object, + not a subobject. */ + +static bool +class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain) +{ + /* Only class containers may need the "_data" reference. */ + if (ts->type != BT_CLASS) + return false; + + /* Accessing a class container with an array reference is certainly wrong. */ + if (ref->type != REF_COMPONENT) + return true; + + /* Accessing the class container's fields is fine. */ + if (ref->u.c.component->name[0] == '_') + return false; + + /* At this point we have a class container with a non class container's field + component reference. We don't want to add the "_data" component if we are + at the first reference and the symbol's type is an extended derived type. + In that case, conv_parent_component_references will do the right thing so + it is not absolutely necessary. Omitting it prevents a regression (see + class_41.f03) in the interface mapping mechanism. When evaluating string + lengths depending on dummy arguments, we create a fake symbol with a type + equal to that of the dummy type. However, because of type extension, + the backend type (corresponding to the actual argument) can have a + different (extended) type. Adding the "_data" component explicitly, using + the base type, confuses the gfc_conv_component_ref code which deals with + the extended type. */ + if (first_ref_in_chain && ts->u.derived->attr.extension) + return false; + + /* We have a class container with a non class container's field component + reference that doesn't fall into the above. */ + return true; +} + + +/* Browse through a data reference chain and add the missing "_data" references + when a subobject of a class object is accessed without it. + Note that it doesn't add the "_data" reference when the class container + is the last element in the reference chain. */ + +void +gfc_fix_class_refs (gfc_expr *e) +{ + gfc_typespec *ts; + gfc_ref **ref; + + if ((e->expr_type != EXPR_VARIABLE + && e->expr_type != EXPR_FUNCTION) + || (e->expr_type == EXPR_FUNCTION + && e->value.function.isym != NULL)) + return; + + if (e->expr_type == EXPR_VARIABLE) + ts = &e->symtree->n.sym->ts; + else + { + gfc_symbol *func; + + gcc_assert (e->expr_type == EXPR_FUNCTION); + if (e->value.function.esym != NULL) + func = e->value.function.esym; + else + func = e->symtree->n.sym; + + if (func->result != NULL) + ts = &func->result->ts; + else + ts = &func->ts; + } + + for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next) + { + if (class_data_ref_missing (ts, *ref, ref == &e->ref)) + insert_component_ref (ts, ref, "_data"); + + if ((*ref)->type == REF_COMPONENT) + ts = &(*ref)->u.c.component->ts; + } +} + + +/* Insert a reference to the component of the given name. + Only to be used with CLASS containers and vtables. */ + +void +gfc_add_component_ref (gfc_expr *e, const char *name) +{ + gfc_component *c; + gfc_ref **tail = &(e->ref); + gfc_ref *ref, *next = NULL; + gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; + while (*tail != NULL) + { + if ((*tail)->type == REF_COMPONENT) + { + if (strcmp ((*tail)->u.c.component->name, "_data") == 0 + && (*tail)->next + && (*tail)->next->type == REF_ARRAY + && (*tail)->next->next == NULL) + return; + derived = (*tail)->u.c.component->ts.u.derived; + } + if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) + break; + tail = &((*tail)->next); + } + if (derived && derived->components && derived->components->next && + derived->components->next->ts.type == BT_DERIVED && + derived->components->next->ts.u.derived == NULL) + { + /* Fix up missing vtype. */ + gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); + gcc_assert (vtab); + derived->components->next->ts.u.derived = vtab->ts.u.derived; + } + if (*tail != NULL && strcmp (name, "_data") == 0) + next = *tail; + else + /* Avoid losing memory. */ + gfc_free_ref_list (*tail); + c = gfc_find_component (derived, name, true, true, tail); + + if (c) { + for (ref = *tail; ref->next; ref = ref->next) + ; + ref->next = next; + if (!next) + e->ts = c->ts; + } +} + + +/* This is used to add both the _data component reference and an array + reference to class expressions. Used in translation of intrinsic + array inquiry functions. */ + +void +gfc_add_class_array_ref (gfc_expr *e) +{ + int rank = CLASS_DATA (e)->as->rank; + gfc_array_spec *as = CLASS_DATA (e)->as; + gfc_ref *ref = NULL; + gfc_add_data_component (e); + e->rank = rank; + for (ref = e->ref; ref; ref = ref->next) + if (!ref->next) + break; + if (ref->type != REF_ARRAY) + { + ref->next = gfc_get_ref (); + ref = ref->next; + ref->type = REF_ARRAY; + ref->u.ar.type = AR_FULL; + ref->u.ar.as = as; + } +} + + +/* Unfortunately, class array expressions can appear in various conditions; + with and without both _data component and an arrayspec. This function + deals with that variability. The previous reference to 'ref' is to a + class array. */ + +static bool +class_array_ref_detected (gfc_ref *ref, bool *full_array) +{ + bool no_data = false; + bool with_data = false; + + /* An array reference with no _data component. */ + if (ref && ref->type == REF_ARRAY + && !ref->next + && ref->u.ar.type != AR_ELEMENT) + { + if (full_array) + *full_array = ref->u.ar.type == AR_FULL; + no_data = true; + } + + /* Cover cases where _data appears, with or without an array ref. */ + if (ref && ref->type == REF_COMPONENT + && strcmp (ref->u.c.component->name, "_data") == 0) + { + if (!ref->next) + { + with_data = true; + if (full_array) + *full_array = true; + } + else if (ref->next && ref->next->type == REF_ARRAY + && ref->type == REF_COMPONENT + && ref->next->u.ar.type != AR_ELEMENT) + { + with_data = true; + if (full_array) + *full_array = ref->next->u.ar.type == AR_FULL; + } + } + + return no_data || with_data; +} + + +/* Returns true if the expression contains a reference to a class + array. Notice that class array elements return false. */ + +bool +gfc_is_class_array_ref (gfc_expr *e, bool *full_array) +{ + gfc_ref *ref; + + if (!e->rank) + return false; + + if (full_array) + *full_array= false; + + /* Is this a class array object? ie. Is the symbol of type class? */ + if (e->symtree + && e->symtree->n.sym->ts.type == BT_CLASS + && CLASS_DATA (e->symtree->n.sym) + && CLASS_DATA (e->symtree->n.sym)->attr.dimension + && class_array_ref_detected (e->ref, full_array)) + return true; + + /* Or is this a class array component reference? */ + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.dimension + && class_array_ref_detected (ref->next, full_array)) + return true; + } + + return false; +} + + +/* Returns true if the expression is a reference to a class + scalar. This function is necessary because such expressions + can be dressed with a reference to the _data component and so + have a type other than BT_CLASS. */ + +bool +gfc_is_class_scalar_expr (gfc_expr *e) +{ + gfc_ref *ref; + + if (e->rank) + return false; + + /* Is this a class object? */ + if (e->symtree + && e->symtree->n.sym->ts.type == BT_CLASS + && CLASS_DATA (e->symtree->n.sym) + && !CLASS_DATA (e->symtree->n.sym)->attr.dimension + && (e->ref == NULL + || (e->ref->type == REF_COMPONENT + && strcmp (e->ref->u.c.component->name, "_data") == 0 + && e->ref->next == NULL))) + return true; + + /* Or is the final reference BT_CLASS or _data? */ + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component) + && !CLASS_DATA (ref->u.c.component)->attr.dimension + && (ref->next == NULL + || (ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0 + && ref->next->next == NULL))) + return true; + } + + return false; +} + + +/* Tells whether the expression E is a reference to a (scalar) class container. + Scalar because array class containers usually have an array reference after + them, and gfc_fix_class_refs will add the missing "_data" component reference + in that case. */ + +bool +gfc_is_class_container_ref (gfc_expr *e) +{ + gfc_ref *ref; + bool result; + + if (e->expr_type != EXPR_VARIABLE) + return e->ts.type == BT_CLASS; + + if (e->symtree->n.sym->ts.type == BT_CLASS) + result = true; + else + result = false; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + result = false; + else if (ref->u.c.component->ts.type == BT_CLASS) + result = true; + else + result = false; + } + + return result; +} + + +/* Build an initializer for CLASS pointers, + initializing the _data component to the init_expr (or NULL) and the _vptr + component to the corresponding type (or the declared type, given by ts). */ + +gfc_expr * +gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr) +{ + gfc_expr *init; + gfc_component *comp; + gfc_symbol *vtab = NULL; + + if (init_expr && init_expr->expr_type != EXPR_NULL) + vtab = gfc_find_vtab (&init_expr->ts); + else + vtab = gfc_find_vtab (ts); + + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); + init->ts = *ts; + + for (comp = ts->u.derived->components; comp; comp = comp->next) + { + gfc_constructor *ctor = gfc_constructor_get(); + if (strcmp (comp->name, "_vptr") == 0 && vtab) + ctor->expr = gfc_lval_expr_from_sym (vtab); + else if (init_expr && init_expr->expr_type != EXPR_NULL) + ctor->expr = gfc_copy_expr (init_expr); + else + ctor->expr = gfc_get_null_expr (NULL); + gfc_constructor_append (&init->value.constructor, ctor); + } + + return init; +} + + +/* Create a unique string identifier for a derived type, composed of its name + and module name. This is used to construct unique names for the class + containers and vtab symbols. */ + +static char * +get_unique_type_string (gfc_symbol *derived) +{ + const char *dt_name; + char *string; + size_t len; + if (derived->attr.unlimited_polymorphic) + dt_name = "STAR"; + else + dt_name = gfc_dt_upper_string (derived->name); + len = strlen (dt_name) + 2; + if (derived->attr.unlimited_polymorphic) + { + string = XNEWVEC (char, len); + sprintf (string, "_%s", dt_name); + } + else if (derived->module) + { + string = XNEWVEC (char, strlen (derived->module) + len); + sprintf (string, "%s_%s", derived->module, dt_name); + } + else if (derived->ns->proc_name) + { + string = XNEWVEC (char, strlen (derived->ns->proc_name->name) + len); + sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); + } + else + { + string = XNEWVEC (char, len); + sprintf (string, "_%s", dt_name); + } + return string; +} + + +/* A relative of 'get_unique_type_string' which makes sure the generated + string will not be too long (replacing it by a hash string if needed). */ + +static void +get_unique_hashed_string (char *string, gfc_symbol *derived) +{ + /* Provide sufficient space to hold "symbol.symbol_symbol". */ + char *tmp; + tmp = get_unique_type_string (derived); + /* If string is too long, use hash value in hex representation (allow for + extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). + We need space to for 15 characters "__class_" + symbol name + "_%d_%da", + where %d is the (co)rank which can be up to n = 15. */ + if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) + { + int h = gfc_hash_value (derived); + sprintf (string, "%X", h); + } + else + strcpy (string, tmp); + free (tmp); +} + + +/* Assign a hash value for a derived type. The algorithm is that of SDBM. */ + +unsigned int +gfc_hash_value (gfc_symbol *sym) +{ + unsigned int hash = 0; + /* Provide sufficient space to hold "symbol.symbol_symbol". */ + char *c; + int i, len; + + c = get_unique_type_string (sym); + len = strlen (c); + + for (i = 0; i < len; i++) + hash = (hash << 6) + (hash << 16) - hash + c[i]; + + free (c); + /* Return the hash but take the modulus for the sake of module read, + even though this slightly increases the chance of collision. */ + return (hash % 100000000); +} + + +/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */ + +unsigned int +gfc_intrinsic_hash_value (gfc_typespec *ts) +{ + unsigned int hash = 0; + const char *c = gfc_typename (ts, true); + int i, len; + + len = strlen (c); + + for (i = 0; i < len; i++) + hash = (hash << 6) + (hash << 16) - hash + c[i]; + + /* Return the hash but take the modulus for the sake of module read, + even though this slightly increases the chance of collision. */ + return (hash % 100000000); +} + + +/* Get the _len component from a class/derived object storing a string. + For unlimited polymorphic entities a ref to the _data component is available + while a ref to the _len component is needed. This routine traverese the + ref-chain and strips the last ref to a _data from it replacing it with a + ref to the _len component. */ + +gfc_expr * +gfc_get_len_component (gfc_expr *e, int k) +{ + gfc_expr *ptr; + gfc_ref *ref, **last; + + ptr = gfc_copy_expr (e); + + /* We need to remove the last _data component ref from ptr. */ + last = &(ptr->ref); + ref = ptr->ref; + while (ref) + { + if (!ref->next + && ref->type == REF_COMPONENT + && strcmp ("_data", ref->u.c.component->name)== 0) + { + gfc_free_ref_list (ref); + *last = NULL; + break; + } + last = &(ref->next); + ref = ref->next; + } + /* And replace if with a ref to the _len component. */ + gfc_add_len_component (ptr); + if (k != ptr->ts.kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = k; + gfc_convert_type_warn (ptr, &ts, 2, 0); + } + return ptr; +} + + +/* Build a polymorphic CLASS entity, using the symbol that comes from + build_sym. A CLASS entity is represented by an encapsulating type, + which contains the declared type as '_data' component, plus a pointer + component '_vptr' which determines the dynamic type. When this CLASS + entity is unlimited polymorphic, then also add a component '_len' to + store the length of string when that is stored in it. */ +static int ctr = 0; + +bool +gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, + gfc_array_spec **as) +{ + char tname[GFC_MAX_SYMBOL_LEN+1]; + char *name; + gfc_symbol *fclass; + gfc_symbol *vtab; + gfc_component *c; + gfc_namespace *ns; + int rank; + + gcc_assert (as); + + if (attr->class_ok) + /* Class container has already been built. */ + return true; + + attr->class_ok = attr->dummy || attr->pointer || attr->allocatable + || attr->select_type_temporary || attr->associate_var; + + if (!attr->class_ok) + /* We cannot build the class container yet. */ + return true; + + /* Determine the name of the encapsulating type. */ + rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; + + if (!ts->u.derived) + return false; + + get_unique_hashed_string (tname, ts->u.derived); + if ((*as) && attr->allocatable) + name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank); + else if ((*as) && attr->pointer) + name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank); + else if ((*as)) + name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank); + else if (attr->pointer) + name = xasprintf ("__class_%s_p", tname); + else if (attr->allocatable) + name = xasprintf ("__class_%s_a", tname); + else + name = xasprintf ("__class_%s_t", tname); + + if (ts->u.derived->attr.unlimited_polymorphic) + { + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + } + else + ns = ts->u.derived->ns; + + /* Although this might seem to be counterintuitive, we can build separate + class types with different array specs because the TKR interface checks + work on the declared type. All array type other than deferred shape or + assumed rank are added to the function namespace to ensure that they + are properly distinguished. */ + if (attr->dummy && !attr->codimension && (*as) + && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK)) + { + char *sname; + ns = gfc_current_ns; + gfc_find_symbol (name, ns, 0, &fclass); + /* If a local class type with this name already exists, update the + name with an index. */ + if (fclass) + { + fclass = NULL; + sname = xasprintf ("%s_%d", name, ++ctr); + free (name); + name = sname; + } + } + else + gfc_find_symbol (name, ns, 0, &fclass); + + if (fclass == NULL) + { + gfc_symtree *st; + /* If not there, create a new symbol. */ + fclass = gfc_new_symbol (name, ns); + st = gfc_new_symtree (&ns->sym_root, name); + st->n.sym = fclass; + gfc_set_sym_referenced (fclass); + fclass->refs++; + fclass->ts.type = BT_UNKNOWN; + if (!ts->u.derived->attr.unlimited_polymorphic) + fclass->attr.abstract = ts->u.derived->attr.abstract; + fclass->f2k_derived = gfc_get_namespace (NULL, 0); + if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL, + &gfc_current_locus)) + return false; + + /* Add component '_data'. */ + if (!gfc_add_component (fclass, "_data", &c)) + return false; + c->ts = *ts; + c->ts.type = BT_DERIVED; + c->attr.access = ACCESS_PRIVATE; + c->ts.u.derived = ts->u.derived; + c->attr.class_pointer = attr->pointer; + c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable) + || attr->select_type_temporary; + c->attr.allocatable = attr->allocatable; + c->attr.dimension = attr->dimension; + c->attr.codimension = attr->codimension; + c->attr.abstract = fclass->attr.abstract; + c->as = (*as); + c->initializer = NULL; + + /* Add component '_vptr'. */ + if (!gfc_add_component (fclass, "_vptr", &c)) + return false; + c->ts.type = BT_DERIVED; + c->attr.access = ACCESS_PRIVATE; + c->attr.pointer = 1; + + if (ts->u.derived->attr.unlimited_polymorphic) + { + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + c->ts.u.derived = vtab->ts.u.derived; + + /* Add component '_len'. Only unlimited polymorphic pointers may + have a string assigned to them, i.e., only those need the _len + component. */ + if (!gfc_add_component (fclass, "_len", &c)) + return false; + c->ts.type = BT_INTEGER; + c->ts.kind = gfc_charlen_int_kind; + c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; + } + else + /* Build vtab later. */ + c->ts.u.derived = NULL; + } + + if (!ts->u.derived->attr.unlimited_polymorphic) + { + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + if (ts->u.derived->attr.extension == 255) + { + gfc_error ("Maximum extension level reached with type %qs at %L", + ts->u.derived->name, &ts->u.derived->declared_at); + return false; + } + + fclass->attr.extension = ts->u.derived->attr.extension + 1; + fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp; + fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp; + } + + fclass->attr.is_class = 1; + ts->u.derived = fclass; + attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; + (*as) = NULL; + free (name); + return true; +} + + +/* Add a procedure pointer component to the vtype + to represent a specific type-bound procedure. */ + +static void +add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) +{ + gfc_component *c; + + if (tb->non_overridable && !tb->overridden) + return; + + c = gfc_find_component (vtype, name, true, true, NULL); + + if (c == NULL) + { + /* Add procedure component. */ + if (!gfc_add_component (vtype, name, &c)) + return; + + if (!c->tb) + c->tb = XCNEW (gfc_typebound_proc); + *c->tb = *tb; + c->tb->ppc = 1; + c->attr.procedure = 1; + c->attr.proc_pointer = 1; + c->attr.flavor = FL_PROCEDURE; + c->attr.access = ACCESS_PRIVATE; + c->attr.external = 1; + c->attr.untyped = 1; + c->attr.if_source = IFSRC_IFBODY; + } + else if (c->attr.proc_pointer && c->tb) + { + *c->tb = *tb; + c->tb->ppc = 1; + } + + if (tb->u.specific) + { + gfc_symbol *ifc = tb->u.specific->n.sym; + c->ts.interface = ifc; + if (!tb->deferred) + c->initializer = gfc_get_variable_expr (tb->u.specific); + c->attr.pure = ifc->attr.pure; + } +} + + +/* Add all specific type-bound procedures in the symtree 'st' to a vtype. */ + +static void +add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) +{ + if (!st) + return; + + if (st->left) + add_procs_to_declared_vtab1 (st->left, vtype); + + if (st->right) + add_procs_to_declared_vtab1 (st->right, vtype); + + if (st->n.tb && !st->n.tb->error + && !st->n.tb->is_generic && st->n.tb->u.specific) + add_proc_comp (vtype, st->name, st->n.tb); +} + + +/* Copy procedure pointers components from the parent type. */ + +static void +copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) +{ + gfc_component *cmp; + gfc_symbol *vtab; + + vtab = gfc_find_derived_vtab (declared); + + for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) + { + if (gfc_find_component (vtype, cmp->name, true, true, NULL)) + continue; + + add_proc_comp (vtype, cmp->name, cmp->tb); + } +} + + +/* Returns true if any of its nonpointer nonallocatable components or + their nonpointer nonallocatable subcomponents has a finalization + subroutine. */ + +static bool +has_finalizer_component (gfc_symbol *derived) +{ + gfc_component *c; + + for (c = derived->components; c; c = c->next) + if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable) + { + if (c->ts.u.derived->f2k_derived + && c->ts.u.derived->f2k_derived->finalizers) + return true; + + /* Stop infinite recursion through this function by inhibiting + calls when the derived type and that of the component are + the same. */ + if (!gfc_compare_derived_types (derived, c->ts.u.derived) + && has_finalizer_component (c->ts.u.derived)) + return true; + } + return false; +} + + +static bool +comp_is_finalizable (gfc_component *comp) +{ + if (comp->attr.proc_pointer) + return false; + else if (comp->attr.allocatable && comp->ts.type != BT_CLASS) + return true; + else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer + && (comp->ts.u.derived->attr.alloc_comp + || has_finalizer_component (comp->ts.u.derived) + || (comp->ts.u.derived->f2k_derived + && comp->ts.u.derived->f2k_derived->finalizers))) + return true; + else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable) + return true; + else + return false; +} + + +/* Call DEALLOCATE for the passed component if it is allocatable, if it is + neither allocatable nor a pointer but has a finalizer, call it. If it + is a nonpointer component with allocatable components or has finalizers, walk + them. Either of them is required; other nonallocatables and pointers aren't + handled gracefully. + Note: If the component is allocatable, the DEALLOCATE handling takes care + of calling the appropriate finalizers, coarray deregistering, and + deallocation of allocatable subcomponents. */ + +static void +finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, + gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code, + gfc_namespace *sub_ns) +{ + gfc_expr *e; + gfc_ref *ref; + gfc_was_finalized *f; + + if (!comp_is_finalizable (comp)) + return; + + /* If this expression with this component has been finalized + already in this namespace, there is nothing to do. */ + for (f = sub_ns->was_finalized; f; f = f->next) + { + if (f->e == expr && f->c == comp) + return; + } + + e = gfc_copy_expr (expr); + if (!e->ref) + e->ref = ref = gfc_get_ref (); + else + { + for (ref = e->ref; ref->next; ref = ref->next) + ; + ref->next = gfc_get_ref (); + ref = ref->next; + } + ref->type = REF_COMPONENT; + ref->u.c.sym = derived; + ref->u.c.component = comp; + e->ts = comp->ts; + + if (comp->attr.dimension || comp->attr.codimension + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && (CLASS_DATA (comp)->attr.dimension + || CLASS_DATA (comp)->attr.codimension))) + { + ref->next = gfc_get_ref (); + ref->next->type = REF_ARRAY; + ref->next->u.ar.dimen = 0; + ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as + : comp->as; + e->rank = ref->next->u.ar.as->rank; + ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT; + } + + /* Call DEALLOCATE (comp, stat=ignore). */ + if (comp->attr.allocatable + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable)) + { + gfc_code *dealloc, *block = NULL; + + /* Add IF (fini_coarray). */ + if (comp->attr.codimension + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.codimension)) + { + block = gfc_get_code (EXEC_IF); + if (*code) + { + (*code)->next = block; + (*code) = (*code)->next; + } + else + (*code) = block; + + block->block = gfc_get_code (EXEC_IF); + block = block->block; + block->expr1 = gfc_lval_expr_from_sym (fini_coarray); + } + + dealloc = gfc_get_code (EXEC_DEALLOCATE); + + dealloc->ext.alloc.list = gfc_get_alloc (); + dealloc->ext.alloc.list->expr = e; + dealloc->expr1 = gfc_lval_expr_from_sym (stat); + + gfc_code *cond = gfc_get_code (EXEC_IF); + cond->block = gfc_get_code (EXEC_IF); + cond->block->expr1 = gfc_get_expr (); + cond->block->expr1->expr_type = EXPR_FUNCTION; + cond->block->expr1->where = gfc_current_locus; + gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false); + cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE; + cond->block->expr1->symtree->n.sym->attr.intrinsic = 1; + cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym; + gfc_commit_symbol (cond->block->expr1->symtree->n.sym); + cond->block->expr1->ts.type = BT_LOGICAL; + cond->block->expr1->ts.kind = gfc_default_logical_kind; + cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED); + cond->block->expr1->value.function.actual = gfc_get_actual_arglist (); + cond->block->expr1->value.function.actual->expr = gfc_copy_expr (expr); + cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist (); + cond->block->next = dealloc; + + if (block) + block->next = cond; + else if (*code) + { + (*code)->next = cond; + (*code) = (*code)->next; + } + else + (*code) = cond; + + } + else if (comp->ts.type == BT_DERIVED + && comp->ts.u.derived->f2k_derived + && comp->ts.u.derived->f2k_derived->finalizers) + { + /* Call FINAL_WRAPPER (comp); */ + gfc_code *final_wrap; + gfc_symbol *vtab; + gfc_component *c; + + vtab = gfc_find_derived_vtab (comp->ts.u.derived); + for (c = vtab->ts.u.derived->components; c; c = c->next) + if (strcmp (c->name, "_final") == 0) + break; + + gcc_assert (c); + final_wrap = gfc_get_code (EXEC_CALL); + final_wrap->symtree = c->initializer->symtree; + final_wrap->resolved_sym = c->initializer->symtree->n.sym; + final_wrap->ext.actual = gfc_get_actual_arglist (); + final_wrap->ext.actual->expr = e; + + if (*code) + { + (*code)->next = final_wrap; + (*code) = (*code)->next; + } + else + (*code) = final_wrap; + } + else + { + gfc_component *c; + + for (c = comp->ts.u.derived->components; c; c = c->next) + finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code, + sub_ns); + gfc_free_expr (e); + } + + /* Record that this was finalized already in this namespace. */ + f = sub_ns->was_finalized; + sub_ns->was_finalized = XCNEW (gfc_was_finalized); + sub_ns->was_finalized->e = expr; + sub_ns->was_finalized->c = comp; + sub_ns->was_finalized->next = f; +} + + +/* Generate code equivalent to + CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + + offset, c_ptr), ptr). */ + +static gfc_code * +finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, + gfc_expr *offset, gfc_namespace *sub_ns) +{ + gfc_code *block; + gfc_expr *expr, *expr2; + + /* C_F_POINTER(). */ + block = gfc_get_code (EXEC_CALL); + gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true); + block->resolved_sym = block->symtree->n.sym; + block->resolved_sym->attr.flavor = FL_PROCEDURE; + block->resolved_sym->attr.intrinsic = 1; + block->resolved_sym->attr.subroutine = 1; + block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING; + block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER; + block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER); + gfc_commit_symbol (block->resolved_sym); + + /* C_F_POINTER's first argument: TRANSFER ( , c_intptr_t). */ + block->ext.actual = gfc_get_actual_arglist (); + block->ext.actual->next = gfc_get_actual_arglist (); + block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind, + NULL, 0); + block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */ + + /* The part: TRANSFER (C_LOC (array), c_intptr_t). */ + + /* TRANSFER's first argument: C_LOC (array). */ + expr = gfc_get_expr (); + expr->expr_type = EXPR_FUNCTION; + gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false); + expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; + expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC; + expr->symtree->n.sym->attr.intrinsic = 1; + expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING; + expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC); + expr->value.function.actual = gfc_get_actual_arglist (); + expr->value.function.actual->expr + = gfc_lval_expr_from_sym (array); + expr->symtree->n.sym->result = expr->symtree->n.sym; + gfc_commit_symbol (expr->symtree->n.sym); + expr->ts.type = BT_INTEGER; + expr->ts.kind = gfc_index_integer_kind; + expr->where = gfc_current_locus; + + /* TRANSFER. */ + expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer", + gfc_current_locus, 3, expr, + gfc_get_int_expr (gfc_index_integer_kind, + NULL, 0), NULL); + expr2->ts.type = BT_INTEGER; + expr2->ts.kind = gfc_index_integer_kind; + + /* + . */ + block->ext.actual->expr = gfc_get_expr (); + block->ext.actual->expr->expr_type = EXPR_OP; + block->ext.actual->expr->value.op.op = INTRINSIC_PLUS; + block->ext.actual->expr->value.op.op1 = expr2; + block->ext.actual->expr->value.op.op2 = offset; + block->ext.actual->expr->ts = expr->ts; + block->ext.actual->expr->where = gfc_current_locus; + + /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ + block->ext.actual->next = gfc_get_actual_arglist (); + block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr); + block->ext.actual->next->next = gfc_get_actual_arglist (); + + return block; +} + + +/* Calculates the offset to the (idx+1)th element of an array, taking the + stride into account. It generates the code: + offset = 0 + do idx2 = 1, rank + offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2) + end do + offset = offset * byte_stride. */ + +static gfc_code* +finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, + gfc_symbol *strides, gfc_symbol *sizes, + gfc_symbol *byte_stride, gfc_expr *rank, + gfc_code *block, gfc_namespace *sub_ns) +{ + gfc_iterator *iter; + gfc_expr *expr, *expr2; + + /* offset = 0. */ + block->next = gfc_get_code (EXEC_ASSIGN); + block = block->next; + block->expr1 = gfc_lval_expr_from_sym (offset); + block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx2); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + iter->end = gfc_copy_expr (rank); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + block->next = gfc_get_code (EXEC_DO); + block = block->next; + block->ext.iterator = iter; + block->block = gfc_get_code (EXEC_DO); + + /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) + * strides(idx2). */ + + /* mod (idx, sizes(idx2)). */ + expr = gfc_lval_expr_from_sym (sizes); + expr->ref = gfc_get_ref (); + expr->ref->type = REF_ARRAY; + expr->ref->u.ar.as = sizes->as; + expr->ref->u.ar.type = AR_ELEMENT; + expr->ref->u.ar.dimen = 1; + expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); + expr->where = sizes->declared_at; + + expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod", + gfc_current_locus, 2, + gfc_lval_expr_from_sym (idx), expr); + expr->ts = idx->ts; + + /* (...) / sizes(idx2-1). */ + expr2 = gfc_get_expr (); + expr2->expr_type = EXPR_OP; + expr2->value.op.op = INTRINSIC_DIVIDE; + expr2->value.op.op1 = expr; + expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes); + expr2->value.op.op2->ref = gfc_get_ref (); + expr2->value.op.op2->ref->type = REF_ARRAY; + expr2->value.op.op2->ref->u.ar.as = sizes->as; + expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT; + expr2->value.op.op2->ref->u.ar.dimen = 1; + expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); + expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; + expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus; + expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; + expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1 + = gfc_lval_expr_from_sym (idx2); + expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2 + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + expr2->value.op.op2->ref->u.ar.start[0]->ts + = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; + expr2->ts = idx->ts; + expr2->where = gfc_current_locus; + + /* ... * strides(idx2). */ + expr = gfc_get_expr (); + expr->expr_type = EXPR_OP; + expr->value.op.op = INTRINSIC_TIMES; + expr->value.op.op1 = expr2; + expr->value.op.op2 = gfc_lval_expr_from_sym (strides); + expr->value.op.op2->ref = gfc_get_ref (); + expr->value.op.op2->ref->type = REF_ARRAY; + expr->value.op.op2->ref->u.ar.type = AR_ELEMENT; + expr->value.op.op2->ref->u.ar.dimen = 1; + expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); + expr->value.op.op2->ref->u.ar.as = strides->as; + expr->ts = idx->ts; + expr->where = gfc_current_locus; + + /* offset = offset + ... */ + block->block->next = gfc_get_code (EXEC_ASSIGN); + block->block->next->expr1 = gfc_lval_expr_from_sym (offset); + block->block->next->expr2 = gfc_get_expr (); + block->block->next->expr2->expr_type = EXPR_OP; + block->block->next->expr2->value.op.op = INTRINSIC_PLUS; + block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); + block->block->next->expr2->value.op.op2 = expr; + block->block->next->expr2->ts = idx->ts; + block->block->next->expr2->where = gfc_current_locus; + + /* After the loop: offset = offset * byte_stride. */ + block->next = gfc_get_code (EXEC_ASSIGN); + block = block->next; + block->expr1 = gfc_lval_expr_from_sym (offset); + block->expr2 = gfc_get_expr (); + block->expr2->expr_type = EXPR_OP; + block->expr2->value.op.op = INTRINSIC_TIMES; + block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); + block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride); + block->expr2->ts = block->expr2->value.op.op1->ts; + block->expr2->where = gfc_current_locus; + return block; +} + + +/* Insert code of the following form: + + block + integer(c_intptr_t) :: i + + if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE + && (is_contiguous || !final_rank3->attr.contiguous + || final_rank3->as->type != AS_ASSUMED_SHAPE)) + || 0 == STORAGE_SIZE (array)) then + call final_rank3 (array) + else + block + integer(c_intptr_t) :: offset, j + type(t) :: tmp(shape (array)) + + do i = 0, size (array)-1 + offset = obtain_offset(i, strides, sizes, byte_stride) + addr = transfer (c_loc (array), addr) + offset + call c_f_pointer (transfer (addr, cptr), ptr) + + addr = transfer (c_loc (tmp), addr) + + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE + call c_f_pointer (transfer (addr, cptr), ptr2) + ptr2 = ptr + end do + call final_rank3 (tmp) + end block + end if + block */ + +static void +finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, + gfc_symbol *array, gfc_symbol *byte_stride, + gfc_symbol *idx, gfc_symbol *ptr, + gfc_symbol *nelem, + gfc_symbol *strides, gfc_symbol *sizes, + gfc_symbol *idx2, gfc_symbol *offset, + gfc_symbol *is_contiguous, gfc_expr *rank, + gfc_namespace *sub_ns) +{ + gfc_symbol *tmp_array, *ptr2; + gfc_expr *size_expr, *offset2, *expr; + gfc_namespace *ns; + gfc_iterator *iter; + gfc_code *block2; + int i; + + block->next = gfc_get_code (EXEC_IF); + block = block->next; + + block->block = gfc_get_code (EXEC_IF); + block = block->block; + + /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ + size_expr = gfc_get_expr (); + size_expr->where = gfc_current_locus; + size_expr->expr_type = EXPR_OP; + size_expr->value.op.op = INTRINSIC_DIVIDE; + + /* STORAGE_SIZE (array,kind=c_intptr_t). */ + size_expr->value.op.op1 + = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE, + "storage_size", gfc_current_locus, 2, + gfc_lval_expr_from_sym (array), + gfc_get_int_expr (gfc_index_integer_kind, + NULL, 0)); + + /* NUMERIC_STORAGE_SIZE. */ + size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, + gfc_character_storage_size); + size_expr->value.op.op1->ts = size_expr->value.op.op2->ts; + size_expr->ts = size_expr->value.op.op1->ts; + + /* IF condition: (stride == size_expr + && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous) + || is_contiguous) + || 0 == size_expr. */ + block->expr1 = gfc_get_expr (); + block->expr1->ts.type = BT_LOGICAL; + block->expr1->ts.kind = gfc_default_logical_kind; + block->expr1->expr_type = EXPR_OP; + block->expr1->where = gfc_current_locus; + + block->expr1->value.op.op = INTRINSIC_OR; + + /* byte_stride == size_expr */ + expr = gfc_get_expr (); + expr->ts.type = BT_LOGICAL; + expr->ts.kind = gfc_default_logical_kind; + expr->expr_type = EXPR_OP; + expr->where = gfc_current_locus; + expr->value.op.op = INTRINSIC_EQ; + expr->value.op.op1 + = gfc_lval_expr_from_sym (byte_stride); + expr->value.op.op2 = size_expr; + + /* If strides aren't allowed (not assumed shape or CONTIGUOUS), + add is_contiguous check. */ + + if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE + || fini->proc_tree->n.sym->formal->sym->attr.contiguous) + { + gfc_expr *expr2; + expr2 = gfc_get_expr (); + expr2->ts.type = BT_LOGICAL; + expr2->ts.kind = gfc_default_logical_kind; + expr2->expr_type = EXPR_OP; + expr2->where = gfc_current_locus; + expr2->value.op.op = INTRINSIC_AND; + expr2->value.op.op1 = expr; + expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous); + expr = expr2; + } + + block->expr1->value.op.op1 = expr; + + /* 0 == size_expr */ + block->expr1->value.op.op2 = gfc_get_expr (); + block->expr1->value.op.op2->ts.type = BT_LOGICAL; + block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind; + block->expr1->value.op.op2->expr_type = EXPR_OP; + block->expr1->value.op.op2->where = gfc_current_locus; + block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ; + block->expr1->value.op.op2->value.op.op1 = + gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr); + + /* IF body: call final subroutine. */ + block->next = gfc_get_code (EXEC_CALL); + block->next->symtree = fini->proc_tree; + block->next->resolved_sym = fini->proc_tree->n.sym; + block->next->ext.actual = gfc_get_actual_arglist (); + block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); + block->next->ext.actual->next = gfc_get_actual_arglist (); + block->next->ext.actual->next->expr = gfc_copy_expr (size_expr); + + /* ELSE. */ + + block->block = gfc_get_code (EXEC_IF); + block = block->block; + + /* BLOCK ... END BLOCK. */ + block->next = gfc_get_code (EXEC_BLOCK); + block = block->next; + + ns = gfc_build_block_ns (sub_ns); + block->ext.block.ns = ns; + block->ext.block.assoc = NULL; + + gfc_get_symbol ("ptr2", ns, &ptr2); + ptr2->ts.type = BT_DERIVED; + ptr2->ts.u.derived = array->ts.u.derived; + ptr2->attr.flavor = FL_VARIABLE; + ptr2->attr.pointer = 1; + ptr2->attr.artificial = 1; + gfc_set_sym_referenced (ptr2); + gfc_commit_symbol (ptr2); + + gfc_get_symbol ("tmp_array", ns, &tmp_array); + tmp_array->ts.type = BT_DERIVED; + tmp_array->ts.u.derived = array->ts.u.derived; + tmp_array->attr.flavor = FL_VARIABLE; + tmp_array->attr.dimension = 1; + tmp_array->attr.artificial = 1; + tmp_array->as = gfc_get_array_spec(); + tmp_array->attr.intent = INTENT_INOUT; + tmp_array->as->type = AS_EXPLICIT; + tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank; + + for (i = 0; i < tmp_array->as->rank; i++) + { + gfc_expr *shape_expr; + tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); + /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */ + shape_expr + = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size", + gfc_current_locus, 3, + gfc_lval_expr_from_sym (array), + gfc_get_int_expr (gfc_default_integer_kind, + NULL, i+1), + gfc_get_int_expr (gfc_default_integer_kind, + NULL, + gfc_index_integer_kind)); + shape_expr->ts.kind = gfc_index_integer_kind; + tmp_array->as->upper[i] = shape_expr; + } + gfc_set_sym_referenced (tmp_array); + gfc_commit_symbol (tmp_array); + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + iter->end = gfc_lval_expr_from_sym (nelem); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + + block = gfc_get_code (EXEC_DO); + ns->code = block; + block->ext.iterator = iter; + block->block = gfc_get_code (EXEC_DO); + + /* Offset calculation for the new array: idx * size of type (in bytes). */ + offset2 = gfc_get_expr (); + offset2->expr_type = EXPR_OP; + offset2->where = gfc_current_locus; + offset2->value.op.op = INTRINSIC_TIMES; + offset2->value.op.op1 = gfc_lval_expr_from_sym (idx); + offset2->value.op.op2 = gfc_copy_expr (size_expr); + offset2->ts = byte_stride->ts; + + /* Offset calculation of "array". */ + block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, block->block, sub_ns); + + /* Create code for + CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + + idx * stride, c_ptr), ptr). */ + block2->next = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym (offset), + sub_ns); + block2 = block2->next; + block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); + block2 = block2->next; + + /* ptr2 = ptr. */ + block2->next = gfc_get_code (EXEC_ASSIGN); + block2 = block2->next; + block2->expr1 = gfc_lval_expr_from_sym (ptr2); + block2->expr2 = gfc_lval_expr_from_sym (ptr); + + /* Call now the user's final subroutine. */ + block->next = gfc_get_code (EXEC_CALL); + block = block->next; + block->symtree = fini->proc_tree; + block->resolved_sym = fini->proc_tree->n.sym; + block->ext.actual = gfc_get_actual_arglist (); + block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array); + + if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN) + return; + + /* Copy back. */ + + /* Loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + iter->end = gfc_lval_expr_from_sym (nelem); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + + block->next = gfc_get_code (EXEC_DO); + block = block->next; + block->ext.iterator = iter; + block->block = gfc_get_code (EXEC_DO); + + /* Offset calculation of "array". */ + block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, block->block, sub_ns); + + /* Create code for + CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + + offset, c_ptr), ptr). */ + block2->next = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym (offset), + sub_ns); + block2 = block2->next; + block2->next = finalization_scalarizer (tmp_array, ptr2, + gfc_copy_expr (offset2), sub_ns); + block2 = block2->next; + + /* ptr = ptr2. */ + block2->next = gfc_get_code (EXEC_ASSIGN); + block2->next->expr1 = gfc_lval_expr_from_sym (ptr); + block2->next->expr2 = gfc_lval_expr_from_sym (ptr2); +} + + +/* Generate the finalization/polymorphic freeing wrapper subroutine for the + derived type "derived". The function first calls the approriate FINAL + subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable + components (but not the inherited ones). Last, it calls the wrapper + subroutine of the parent. The generated wrapper procedure takes as argument + an assumed-rank array. + If neither allocatable components nor FINAL subroutines exists, the vtab + will contain a NULL pointer. + The generated function has the form + _final(assumed-rank array, stride, skip_corarray) + where the array has to be contiguous (except of the lowest dimension). The + stride (in bytes) is used to allow different sizes for ancestor types by + skipping over the additionally added components in the scalarizer. If + "fini_coarray" is false, coarray components are not finalized to allow for + the correct semantic with intrinsic assignment. */ + +static void +generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, + const char *tname, gfc_component *vtab_final) +{ + gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; + gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; + gfc_component *comp; + gfc_namespace *sub_ns; + gfc_code *last_code, *block; + char *name; + bool finalizable_comp = false; + gfc_expr *ancestor_wrapper = NULL, *rank; + gfc_iterator *iter; + + if (derived->attr.unlimited_polymorphic) + { + vtab_final->initializer = gfc_get_null_expr (NULL); + return; + } + + /* Search for the ancestor's finalizers. */ + if (derived->attr.extension && derived->components + && (!derived->components->ts.u.derived->attr.abstract + || has_finalizer_component (derived))) + { + gfc_symbol *vtab; + gfc_component *comp; + + vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); + for (comp = vtab->ts.u.derived->components; comp; comp = comp->next) + if (comp->name[0] == '_' && comp->name[1] == 'f') + { + ancestor_wrapper = comp->initializer; + break; + } + } + + /* No wrapper of the ancestor and no own FINAL subroutines and allocatable + components: Return a NULL() expression; we defer this a bit to have + an interface declaration. */ + if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL) + && !derived->attr.alloc_comp + && (!derived->f2k_derived || !derived->f2k_derived->finalizers) + && !has_finalizer_component (derived)) + { + vtab_final->initializer = gfc_get_null_expr (NULL); + gcc_assert (vtab_final->ts.interface == NULL); + return; + } + else + /* Check whether there are new allocatable components. */ + for (comp = derived->components; comp; comp = comp->next) + { + if (comp == derived->components && derived->attr.extension + && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) + continue; + + finalizable_comp |= comp_is_finalizable (comp); + } + + /* If there is no new finalizer and no new allocatable, return with + an expr to the ancestor's one. */ + if (!finalizable_comp + && (!derived->f2k_derived || !derived->f2k_derived->finalizers)) + { + gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL + && ancestor_wrapper->expr_type == EXPR_VARIABLE); + vtab_final->initializer = gfc_copy_expr (ancestor_wrapper); + vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym; + return; + } + + /* We now create a wrapper, which does the following: + 1. Call the suitable finalization subroutine for this type + 2. Loop over all noninherited allocatable components and noninherited + components with allocatable components and DEALLOCATE those; this will + take care of finalizers, coarray deregistering and allocatable + nested components. + 3. Call the ancestor's finalizer. */ + + /* Declare the wrapper function; it takes an assumed-rank array + and a VALUE logical as arguments. */ + + /* Set up the namespace. */ + sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + + /* Set up the procedure symbol. */ + name = xasprintf ("__final_%s", tname); + gfc_get_symbol (name, sub_ns, &final); + sub_ns->proc_name = final; + final->attr.flavor = FL_PROCEDURE; + final->attr.function = 1; + final->attr.pure = 0; + final->attr.recursive = 1; + final->result = final; + final->ts.type = BT_INTEGER; + final->ts.kind = 4; + final->attr.artificial = 1; + final->attr.always_explicit = 1; + final->attr.if_source = IFSRC_DECL; + if (ns->proc_name->attr.flavor == FL_MODULE) + final->module = ns->proc_name->name; + gfc_set_sym_referenced (final); + gfc_commit_symbol (final); + + /* Set up formal argument. */ + gfc_get_symbol ("array", sub_ns, &array); + array->ts.type = BT_DERIVED; + array->ts.u.derived = derived; + array->attr.flavor = FL_VARIABLE; + array->attr.dummy = 1; + array->attr.contiguous = 1; + array->attr.dimension = 1; + array->attr.artificial = 1; + array->as = gfc_get_array_spec(); + array->as->type = AS_ASSUMED_RANK; + array->as->rank = -1; + array->attr.intent = INTENT_INOUT; + gfc_set_sym_referenced (array); + final->formal = gfc_get_formal_arglist (); + final->formal->sym = array; + gfc_commit_symbol (array); + + /* Set up formal argument. */ + gfc_get_symbol ("byte_stride", sub_ns, &byte_stride); + byte_stride->ts.type = BT_INTEGER; + byte_stride->ts.kind = gfc_index_integer_kind; + byte_stride->attr.flavor = FL_VARIABLE; + byte_stride->attr.dummy = 1; + byte_stride->attr.value = 1; + byte_stride->attr.artificial = 1; + gfc_set_sym_referenced (byte_stride); + final->formal->next = gfc_get_formal_arglist (); + final->formal->next->sym = byte_stride; + gfc_commit_symbol (byte_stride); + + /* Set up formal argument. */ + gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray); + fini_coarray->ts.type = BT_LOGICAL; + fini_coarray->ts.kind = 1; + fini_coarray->attr.flavor = FL_VARIABLE; + fini_coarray->attr.dummy = 1; + fini_coarray->attr.value = 1; + fini_coarray->attr.artificial = 1; + gfc_set_sym_referenced (fini_coarray); + final->formal->next->next = gfc_get_formal_arglist (); + final->formal->next->next->sym = fini_coarray; + gfc_commit_symbol (fini_coarray); + + /* Local variables. */ + + gfc_get_symbol ("idx", sub_ns, &idx); + idx->ts.type = BT_INTEGER; + idx->ts.kind = gfc_index_integer_kind; + idx->attr.flavor = FL_VARIABLE; + idx->attr.artificial = 1; + gfc_set_sym_referenced (idx); + gfc_commit_symbol (idx); + + gfc_get_symbol ("idx2", sub_ns, &idx2); + idx2->ts.type = BT_INTEGER; + idx2->ts.kind = gfc_index_integer_kind; + idx2->attr.flavor = FL_VARIABLE; + idx2->attr.artificial = 1; + gfc_set_sym_referenced (idx2); + gfc_commit_symbol (idx2); + + gfc_get_symbol ("offset", sub_ns, &offset); + offset->ts.type = BT_INTEGER; + offset->ts.kind = gfc_index_integer_kind; + offset->attr.flavor = FL_VARIABLE; + offset->attr.artificial = 1; + gfc_set_sym_referenced (offset); + gfc_commit_symbol (offset); + + /* Create RANK expression. */ + rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank", + gfc_current_locus, 1, + gfc_lval_expr_from_sym (array)); + if (rank->ts.kind != idx->ts.kind) + gfc_convert_type_warn (rank, &idx->ts, 2, 0); + + /* Create is_contiguous variable. */ + gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous); + is_contiguous->ts.type = BT_LOGICAL; + is_contiguous->ts.kind = gfc_default_logical_kind; + is_contiguous->attr.flavor = FL_VARIABLE; + is_contiguous->attr.artificial = 1; + gfc_set_sym_referenced (is_contiguous); + gfc_commit_symbol (is_contiguous); + + /* Create "sizes(0..rank)" variable, which contains the multiplied + up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1), + sizes(2) = sizes(1) * extent(dim=2) etc. */ + gfc_get_symbol ("sizes", sub_ns, &sizes); + sizes->ts.type = BT_INTEGER; + sizes->ts.kind = gfc_index_integer_kind; + sizes->attr.flavor = FL_VARIABLE; + sizes->attr.dimension = 1; + sizes->attr.artificial = 1; + sizes->as = gfc_get_array_spec(); + sizes->attr.intent = INTENT_INOUT; + sizes->as->type = AS_EXPLICIT; + sizes->as->rank = 1; + sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + sizes->as->upper[0] = gfc_copy_expr (rank); + gfc_set_sym_referenced (sizes); + gfc_commit_symbol (sizes); + + /* Create "strides(1..rank)" variable, which contains the strides per + dimension. */ + gfc_get_symbol ("strides", sub_ns, &strides); + strides->ts.type = BT_INTEGER; + strides->ts.kind = gfc_index_integer_kind; + strides->attr.flavor = FL_VARIABLE; + strides->attr.dimension = 1; + strides->attr.artificial = 1; + strides->as = gfc_get_array_spec(); + strides->attr.intent = INTENT_INOUT; + strides->as->type = AS_EXPLICIT; + strides->as->rank = 1; + strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + strides->as->upper[0] = gfc_copy_expr (rank); + gfc_set_sym_referenced (strides); + gfc_commit_symbol (strides); + + + /* Set return value to 0. */ + last_code = gfc_get_code (EXEC_ASSIGN); + last_code->expr1 = gfc_lval_expr_from_sym (final); + last_code->expr2 = gfc_get_int_expr (4, NULL, 0); + sub_ns->code = last_code; + + /* Set: is_contiguous = .true. */ + last_code->next = gfc_get_code (EXEC_ASSIGN); + last_code = last_code->next; + last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous); + last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, + &gfc_current_locus, true); + + /* Set: sizes(0) = 1. */ + last_code->next = gfc_get_code (EXEC_ASSIGN); + last_code = last_code->next; + last_code->expr1 = gfc_lval_expr_from_sym (sizes); + last_code->expr1->ref = gfc_get_ref (); + last_code->expr1->ref->type = REF_ARRAY; + last_code->expr1->ref->u.ar.type = AR_ELEMENT; + last_code->expr1->ref->u.ar.dimen = 1; + last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + last_code->expr1->ref->u.ar.start[0] + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + last_code->expr1->ref->u.ar.as = sizes->as; + last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + + /* Create: + DO idx = 1, rank + strides(idx) = _F._stride (array, dim=idx) + sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind) + if (strides (idx) /= sizes(i-1)) is_contiguous = .false. + END DO. */ + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + iter->end = gfc_copy_expr (rank); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + last_code->next = gfc_get_code (EXEC_DO); + last_code = last_code->next; + last_code->ext.iterator = iter; + last_code->block = gfc_get_code (EXEC_DO); + + /* strides(idx) = _F._stride(array,dim=idx). */ + last_code->block->next = gfc_get_code (EXEC_ASSIGN); + block = last_code->block->next; + + block->expr1 = gfc_lval_expr_from_sym (strides); + block->expr1->ref = gfc_get_ref (); + block->expr1->ref->type = REF_ARRAY; + block->expr1->ref->u.ar.type = AR_ELEMENT; + block->expr1->ref->u.ar.dimen = 1; + block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); + block->expr1->ref->u.ar.as = strides->as; + + block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride", + gfc_current_locus, 2, + gfc_lval_expr_from_sym (array), + gfc_lval_expr_from_sym (idx)); + + /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */ + block->next = gfc_get_code (EXEC_ASSIGN); + block = block->next; + + /* sizes(idx) = ... */ + block->expr1 = gfc_lval_expr_from_sym (sizes); + block->expr1->ref = gfc_get_ref (); + block->expr1->ref->type = REF_ARRAY; + block->expr1->ref->u.ar.type = AR_ELEMENT; + block->expr1->ref->u.ar.dimen = 1; + block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); + block->expr1->ref->u.ar.as = sizes->as; + + block->expr2 = gfc_get_expr (); + block->expr2->expr_type = EXPR_OP; + block->expr2->value.op.op = INTRINSIC_TIMES; + block->expr2->where = gfc_current_locus; + + /* sizes(idx-1). */ + block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); + block->expr2->value.op.op1->ref = gfc_get_ref (); + block->expr2->value.op.op1->ref->type = REF_ARRAY; + block->expr2->value.op.op1->ref->u.ar.as = sizes->as; + block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; + block->expr2->value.op.op1->ref->u.ar.dimen = 1; + block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr (); + block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP; + block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus; + block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; + block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1 + = gfc_lval_expr_from_sym (idx); + block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2 + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + block->expr2->value.op.op1->ref->u.ar.start[0]->ts + = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts; + + /* size(array, dim=idx, kind=index_kind). */ + block->expr2->value.op.op2 + = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size", + gfc_current_locus, 3, + gfc_lval_expr_from_sym (array), + gfc_lval_expr_from_sym (idx), + gfc_get_int_expr (gfc_index_integer_kind, + NULL, + gfc_index_integer_kind)); + block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind; + block->expr2->ts = idx->ts; + + /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */ + block->next = gfc_get_code (EXEC_IF); + block = block->next; + + block->block = gfc_get_code (EXEC_IF); + block = block->block; + + /* if condition: strides(idx) /= sizes(idx-1). */ + block->expr1 = gfc_get_expr (); + block->expr1->ts.type = BT_LOGICAL; + block->expr1->ts.kind = gfc_default_logical_kind; + block->expr1->expr_type = EXPR_OP; + block->expr1->where = gfc_current_locus; + block->expr1->value.op.op = INTRINSIC_NE; + + block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides); + block->expr1->value.op.op1->ref = gfc_get_ref (); + block->expr1->value.op.op1->ref->type = REF_ARRAY; + block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT; + block->expr1->value.op.op1->ref->u.ar.dimen = 1; + block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); + block->expr1->value.op.op1->ref->u.ar.as = strides->as; + + block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes); + block->expr1->value.op.op2->ref = gfc_get_ref (); + block->expr1->value.op.op2->ref->type = REF_ARRAY; + block->expr1->value.op.op2->ref->u.ar.as = sizes->as; + block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT; + block->expr1->value.op.op2->ref->u.ar.dimen = 1; + block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); + block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; + block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus; + block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; + block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1 + = gfc_lval_expr_from_sym (idx); + block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2 + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + block->expr1->value.op.op2->ref->u.ar.start[0]->ts + = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; + + /* if body: is_contiguous = .false. */ + block->next = gfc_get_code (EXEC_ASSIGN); + block = block->next; + block->expr1 = gfc_lval_expr_from_sym (is_contiguous); + block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, + &gfc_current_locus, false); + + /* Obtain the size (number of elements) of "array" MINUS ONE, + which is used in the scalarization. */ + gfc_get_symbol ("nelem", sub_ns, &nelem); + nelem->ts.type = BT_INTEGER; + nelem->ts.kind = gfc_index_integer_kind; + nelem->attr.flavor = FL_VARIABLE; + nelem->attr.artificial = 1; + gfc_set_sym_referenced (nelem); + gfc_commit_symbol (nelem); + + /* nelem = sizes (rank) - 1. */ + last_code->next = gfc_get_code (EXEC_ASSIGN); + last_code = last_code->next; + + last_code->expr1 = gfc_lval_expr_from_sym (nelem); + + last_code->expr2 = gfc_get_expr (); + last_code->expr2->expr_type = EXPR_OP; + last_code->expr2->value.op.op = INTRINSIC_MINUS; + last_code->expr2->value.op.op2 + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + last_code->expr2->ts = last_code->expr2->value.op.op2->ts; + last_code->expr2->where = gfc_current_locus; + + last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); + last_code->expr2->value.op.op1->ref = gfc_get_ref (); + last_code->expr2->value.op.op1->ref->type = REF_ARRAY; + last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; + last_code->expr2->value.op.op1->ref->u.ar.dimen = 1; + last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank); + last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as; + + /* Call final subroutines. We now generate code like: + use iso_c_binding + integer, pointer :: ptr + type(c_ptr) :: cptr + integer(c_intptr_t) :: i, addr + + select case (rank (array)) + case (3) + ! If needed, the array is packed + call final_rank3 (array) + case default: + do i = 0, size (array)-1 + addr = transfer (c_loc (array), addr) + i * stride + call c_f_pointer (transfer (addr, cptr), ptr) + call elemental_final (ptr) + end do + end select */ + + if (derived->f2k_derived && derived->f2k_derived->finalizers) + { + gfc_finalizer *fini, *fini_elem = NULL; + + gfc_get_symbol ("ptr1", sub_ns, &ptr); + ptr->ts.type = BT_DERIVED; + ptr->ts.u.derived = derived; + ptr->attr.flavor = FL_VARIABLE; + ptr->attr.pointer = 1; + ptr->attr.artificial = 1; + gfc_set_sym_referenced (ptr); + gfc_commit_symbol (ptr); + + /* SELECT CASE (RANK (array)). */ + last_code->next = gfc_get_code (EXEC_SELECT); + last_code = last_code->next; + last_code->expr1 = gfc_copy_expr (rank); + block = NULL; + + for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next) + { + gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */ + if (fini->proc_tree->n.sym->attr.elemental) + { + fini_elem = fini; + continue; + } + + /* CASE (fini_rank). */ + if (block) + { + block->block = gfc_get_code (EXEC_SELECT); + block = block->block; + } + else + { + block = gfc_get_code (EXEC_SELECT); + last_code->block = block; + } + block->ext.block.case_list = gfc_get_case (); + block->ext.block.case_list->where = gfc_current_locus; + if (fini->proc_tree->n.sym->formal->sym->attr.dimension) + block->ext.block.case_list->low + = gfc_get_int_expr (gfc_default_integer_kind, NULL, + fini->proc_tree->n.sym->formal->sym->as->rank); + else + block->ext.block.case_list->low + = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + block->ext.block.case_list->high + = gfc_copy_expr (block->ext.block.case_list->low); + + /* CALL fini_rank (array) - possibly with packing. */ + if (fini->proc_tree->n.sym->formal->sym->attr.dimension) + finalizer_insert_packed_call (block, fini, array, byte_stride, + idx, ptr, nelem, strides, + sizes, idx2, offset, is_contiguous, + rank, sub_ns); + else + { + block->next = gfc_get_code (EXEC_CALL); + block->next->symtree = fini->proc_tree; + block->next->resolved_sym = fini->proc_tree->n.sym; + block->next->ext.actual = gfc_get_actual_arglist (); + block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); + } + } + + /* Elemental call - scalarized. */ + if (fini_elem) + { + /* CASE DEFAULT. */ + if (block) + { + block->block = gfc_get_code (EXEC_SELECT); + block = block->block; + } + else + { + block = gfc_get_code (EXEC_SELECT); + last_code->block = block; + } + block->ext.block.case_list = gfc_get_case (); + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + iter->end = gfc_lval_expr_from_sym (nelem); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + block->next = gfc_get_code (EXEC_DO); + block = block->next; + block->ext.iterator = iter; + block->block = gfc_get_code (EXEC_DO); + + /* Offset calculation. */ + block = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, block->block, + sub_ns); + + /* Create code for + CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + + offset, c_ptr), ptr). */ + block->next + = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym (offset), + sub_ns); + block = block->next; + + /* CALL final_elemental (array). */ + block->next = gfc_get_code (EXEC_CALL); + block = block->next; + block->symtree = fini_elem->proc_tree; + block->resolved_sym = fini_elem->proc_sym; + block->ext.actual = gfc_get_actual_arglist (); + block->ext.actual->expr = gfc_lval_expr_from_sym (ptr); + } + } + + /* Finalize and deallocate allocatable components. The same manual + scalarization is used as above. */ + + if (finalizable_comp) + { + gfc_symbol *stat; + gfc_code *block = NULL; + + if (!ptr) + { + gfc_get_symbol ("ptr2", sub_ns, &ptr); + ptr->ts.type = BT_DERIVED; + ptr->ts.u.derived = derived; + ptr->attr.flavor = FL_VARIABLE; + ptr->attr.pointer = 1; + ptr->attr.artificial = 1; + gfc_set_sym_referenced (ptr); + gfc_commit_symbol (ptr); + } + + gfc_get_symbol ("ignore", sub_ns, &stat); + stat->attr.flavor = FL_VARIABLE; + stat->attr.artificial = 1; + stat->ts.type = BT_INTEGER; + stat->ts.kind = gfc_default_integer_kind; + gfc_set_sym_referenced (stat); + gfc_commit_symbol (stat); + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + iter->end = gfc_lval_expr_from_sym (nelem); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + last_code->next = gfc_get_code (EXEC_DO); + last_code = last_code->next; + last_code->ext.iterator = iter; + last_code->block = gfc_get_code (EXEC_DO); + + /* Offset calculation. */ + block = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, last_code->block, + sub_ns); + + /* Create code for + CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + + idx * stride, c_ptr), ptr). */ + block->next = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym(offset), + sub_ns); + block = block->next; + + for (comp = derived->components; comp; comp = comp->next) + { + if (comp == derived->components && derived->attr.extension + && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) + continue; + + finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp, + stat, fini_coarray, &block, sub_ns); + if (!last_code->block->next) + last_code->block->next = block; + } + + } + + /* Call the finalizer of the ancestor. */ + if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) + { + last_code->next = gfc_get_code (EXEC_CALL); + last_code = last_code->next; + last_code->symtree = ancestor_wrapper->symtree; + last_code->resolved_sym = ancestor_wrapper->symtree->n.sym; + + last_code->ext.actual = gfc_get_actual_arglist (); + last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); + last_code->ext.actual->next = gfc_get_actual_arglist (); + last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride); + last_code->ext.actual->next->next = gfc_get_actual_arglist (); + last_code->ext.actual->next->next->expr + = gfc_lval_expr_from_sym (fini_coarray); + } + + gfc_free_expr (rank); + vtab_final->initializer = gfc_lval_expr_from_sym (final); + vtab_final->ts.interface = final; + free (name); +} + + +/* Add procedure pointers for all type-bound procedures to a vtab. */ + +static void +add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) +{ + gfc_symbol* super_type; + + super_type = gfc_get_derived_super_type (derived); + + if (super_type && (super_type != derived)) + { + /* Make sure that the PPCs appear in the same order as in the parent. */ + copy_vtab_proc_comps (super_type, vtype); + /* Only needed to get the PPC initializers right. */ + add_procs_to_declared_vtab (super_type, vtype); + } + + if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) + add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); + + if (derived->f2k_derived && derived->f2k_derived->tb_uop_root) + add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype); +} + + +/* Find or generate the symbol for a derived type's vtab. */ + +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + gfc_namespace *ns; + gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; + gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; + gfc_gsymbol *gsym = NULL; + gfc_symbol *dealloc = NULL, *arg = NULL; + + if (derived->attr.pdt_template) + return NULL; + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + /* If the type is a class container, use the underlying derived type. */ + if (!derived->attr.unlimited_polymorphic && derived->attr.is_class) + derived = gfc_get_derived_super_type (derived); + + if (!derived) + return NULL; + + if (!derived->name) + return NULL; + + /* Find the gsymbol for the module of use associated derived types. */ + if ((derived->attr.use_assoc || derived->attr.used_in_submodule) + && !derived->attr.vtype && !derived->attr.is_class) + gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module); + else + gsym = NULL; + + /* Work in the gsymbol namespace if the top-level namespace is a module. + This ensures that the vtable is unique, which is required since we use + its address in SELECT TYPE. */ + if (gsym && gsym->ns && ns && ns->proc_name + && ns->proc_name->attr.flavor == FL_MODULE) + ns = gsym->ns; + + if (ns) + { + char tname[GFC_MAX_SYMBOL_LEN+1]; + char *name; + + get_unique_hashed_string (tname, derived); + name = xasprintf ("__vtab_%s", tname); + + /* Look for the vtab symbol in various namespaces. */ + if (gsym && gsym->ns) + { + gfc_find_symbol (name, gsym->ns, 0, &vtab); + if (vtab) + ns = gsym->ns; + } + if (vtab == NULL) + gfc_find_symbol (name, gfc_current_ns, 0, &vtab); + if (vtab == NULL) + gfc_find_symbol (name, ns, 0, &vtab); + if (vtab == NULL) + gfc_find_symbol (name, derived->ns, 0, &vtab); + + if (vtab == NULL) + { + gfc_get_symbol (name, ns, &vtab); + vtab->ts.type = BT_DERIVED; + if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, + &gfc_current_locus)) + goto cleanup; + vtab->attr.target = 1; + vtab->attr.save = SAVE_IMPLICIT; + vtab->attr.vtab = 1; + vtab->attr.access = ACCESS_PUBLIC; + gfc_set_sym_referenced (vtab); + name = xasprintf ("__vtype_%s", tname); + + gfc_find_symbol (name, ns, 0, &vtype); + if (vtype == NULL) + { + gfc_component *c; + gfc_symbol *parent = NULL, *parent_vtab = NULL; + bool rdt = false; + + /* Is this a derived type with recursive allocatable + components? */ + c = (derived->attr.unlimited_polymorphic + || derived->attr.abstract) ? + NULL : derived->components; + for (; c; c= c->next) + if (c->ts.type == BT_DERIVED + && c->ts.u.derived == derived) + { + rdt = true; + break; + } + + gfc_get_symbol (name, ns, &vtype); + if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, + &gfc_current_locus)) + goto cleanup; + vtype->attr.access = ACCESS_PUBLIC; + vtype->attr.vtype = 1; + gfc_set_sym_referenced (vtype); + + /* Add component '_hash'. */ + if (!gfc_add_component (vtype, "_hash", &c)) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, derived->hash_value); + + /* Add component '_size'. */ + if (!gfc_add_component (vtype, "_size", &c)) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = gfc_size_kind; + c->attr.access = ACCESS_PRIVATE; + /* Remember the derived type in ts.u.derived, + so that the correct initializer can be set later on + (in gfc_conv_structure). */ + c->ts.u.derived = derived; + c->initializer = gfc_get_int_expr (gfc_size_kind, + NULL, 0); + + /* Add component _extends. */ + if (!gfc_add_component (vtype, "_extends", &c)) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + if (!derived->attr.unlimited_polymorphic) + parent = gfc_get_derived_super_type (derived); + else + parent = NULL; + + if (parent) + { + parent_vtab = gfc_find_derived_vtab (parent); + c->ts.type = BT_DERIVED; + c->ts.u.derived = parent_vtab->ts.u.derived; + c->initializer = gfc_get_expr (); + c->initializer->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, + 0, &c->initializer->symtree); + } + else + { + c->ts.type = BT_DERIVED; + c->ts.u.derived = vtype; + c->initializer = gfc_get_null_expr (NULL); + } + + if (!derived->attr.unlimited_polymorphic + && derived->components == NULL + && !derived->attr.zero_comp) + { + /* At this point an error must have occurred. + Prevent further errors on the vtype components. */ + found_sym = vtab; + goto have_vtype; + } + + /* Add component _def_init. */ + if (!gfc_add_component (vtype, "_def_init", &c)) + goto cleanup; + c->attr.pointer = 1; + c->attr.artificial = 1; + c->attr.access = ACCESS_PRIVATE; + c->ts.type = BT_DERIVED; + c->ts.u.derived = derived; + if (derived->attr.unlimited_polymorphic + || derived->attr.abstract) + c->initializer = gfc_get_null_expr (NULL); + else + { + /* Construct default initialization variable. */ + name = xasprintf ("__def_init_%s", tname); + gfc_get_symbol (name, ns, &def_init); + def_init->attr.target = 1; + def_init->attr.artificial = 1; + def_init->attr.save = SAVE_IMPLICIT; + def_init->attr.access = ACCESS_PUBLIC; + def_init->attr.flavor = FL_VARIABLE; + gfc_set_sym_referenced (def_init); + def_init->ts.type = BT_DERIVED; + def_init->ts.u.derived = derived; + def_init->value = gfc_default_initializer (&def_init->ts); + + c->initializer = gfc_lval_expr_from_sym (def_init); + } + + /* Add component _copy. */ + if (!gfc_add_component (vtype, "_copy", &c)) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + if (derived->attr.unlimited_polymorphic + || derived->attr.abstract) + c->initializer = gfc_get_null_expr (NULL); + else + { + /* Set up namespace. */ + gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + name = xasprintf ("__copy_%s", tname); + gfc_get_symbol (name, sub_ns, ©); + sub_ns->proc_name = copy; + copy->attr.flavor = FL_PROCEDURE; + copy->attr.subroutine = 1; + copy->attr.pure = 1; + copy->attr.artificial = 1; + copy->attr.if_source = IFSRC_DECL; + /* This is elemental so that arrays are automatically + treated correctly by the scalarizer. */ + copy->attr.elemental = 1; + if (ns->proc_name->attr.flavor == FL_MODULE) + copy->module = ns->proc_name->name; + gfc_set_sym_referenced (copy); + /* Set up formal arguments. */ + gfc_get_symbol ("src", sub_ns, &src); + src->ts.type = BT_DERIVED; + src->ts.u.derived = derived; + src->attr.flavor = FL_VARIABLE; + src->attr.dummy = 1; + src->attr.artificial = 1; + src->attr.intent = INTENT_IN; + gfc_set_sym_referenced (src); + copy->formal = gfc_get_formal_arglist (); + copy->formal->sym = src; + gfc_get_symbol ("dst", sub_ns, &dst); + dst->ts.type = BT_DERIVED; + dst->ts.u.derived = derived; + dst->attr.flavor = FL_VARIABLE; + dst->attr.dummy = 1; + dst->attr.artificial = 1; + dst->attr.intent = INTENT_INOUT; + gfc_set_sym_referenced (dst); + copy->formal->next = gfc_get_formal_arglist (); + copy->formal->next->sym = dst; + /* Set up code. */ + sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN); + sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); + sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); + /* Set initializer. */ + c->initializer = gfc_lval_expr_from_sym (copy); + c->ts.interface = copy; + } + + /* Add component _final, which contains a procedure pointer to + a wrapper which handles both the freeing of allocatable + components and the calls to finalization subroutines. + Note: The actual wrapper function can only be generated + at resolution time. */ + if (!gfc_add_component (vtype, "_final", &c)) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + generate_finalization_wrapper (derived, ns, tname, c); + + /* Add component _deallocate. */ + if (!gfc_add_component (vtype, "_deallocate", &c)) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + if (derived->attr.unlimited_polymorphic + || derived->attr.abstract + || !rdt) + c->initializer = gfc_get_null_expr (NULL); + else + { + /* Set up namespace. */ + gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); + + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + name = xasprintf ("__deallocate_%s", tname); + gfc_get_symbol (name, sub_ns, &dealloc); + sub_ns->proc_name = dealloc; + dealloc->attr.flavor = FL_PROCEDURE; + dealloc->attr.subroutine = 1; + dealloc->attr.pure = 1; + dealloc->attr.artificial = 1; + dealloc->attr.if_source = IFSRC_DECL; + + if (ns->proc_name->attr.flavor == FL_MODULE) + dealloc->module = ns->proc_name->name; + gfc_set_sym_referenced (dealloc); + /* Set up formal argument. */ + gfc_get_symbol ("arg", sub_ns, &arg); + arg->ts.type = BT_DERIVED; + arg->ts.u.derived = derived; + arg->attr.flavor = FL_VARIABLE; + arg->attr.dummy = 1; + arg->attr.artificial = 1; + arg->attr.intent = INTENT_INOUT; + arg->attr.dimension = 1; + arg->attr.allocatable = 1; + arg->as = gfc_get_array_spec(); + arg->as->type = AS_ASSUMED_SHAPE; + arg->as->rank = 1; + arg->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); + gfc_set_sym_referenced (arg); + dealloc->formal = gfc_get_formal_arglist (); + dealloc->formal->sym = arg; + /* Set up code. */ + sub_ns->code = gfc_get_code (EXEC_DEALLOCATE); + sub_ns->code->ext.alloc.list = gfc_get_alloc (); + sub_ns->code->ext.alloc.list->expr + = gfc_lval_expr_from_sym (arg); + /* Set initializer. */ + c->initializer = gfc_lval_expr_from_sym (dealloc); + c->ts.interface = dealloc; + } + + /* Add procedure pointers for type-bound procedures. */ + if (!derived->attr.unlimited_polymorphic) + add_procs_to_declared_vtab (derived, vtype); + } + +have_vtype: + vtab->ts.u.derived = vtype; + vtab->value = gfc_default_initializer (&vtab->ts); + } + free (name); + } + + found_sym = vtab; + +cleanup: + /* It is unexpected to have some symbols added at resolution or code + generation time. We commit the changes in order to keep a clean state. */ + if (found_sym) + { + gfc_commit_symbol (vtab); + if (vtype) + gfc_commit_symbol (vtype); + if (def_init) + gfc_commit_symbol (def_init); + if (copy) + gfc_commit_symbol (copy); + if (src) + gfc_commit_symbol (src); + if (dst) + gfc_commit_symbol (dst); + if (dealloc) + gfc_commit_symbol (dealloc); + if (arg) + gfc_commit_symbol (arg); + } + else + gfc_undo_symbols (); + + return found_sym; +} + + +/* Check if a derived type is finalizable. That is the case if it + (1) has a FINAL subroutine or + (2) has a nonpointer nonallocatable component of finalizable type. + If it is finalizable, return an expression containing the + finalization wrapper. */ + +bool +gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr) +{ + gfc_symbol *vtab; + gfc_component *c; + + /* (1) Check for FINAL subroutines. */ + if (derived->f2k_derived && derived->f2k_derived->finalizers) + goto yes; + + /* (2) Check for components of finalizable type. */ + for (c = derived->components; c; c = c->next) + if (c->ts.type == BT_DERIVED + && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable + && gfc_is_finalizable (c->ts.u.derived, NULL)) + goto yes; + + return false; + +yes: + /* Make sure vtab is generated. */ + vtab = gfc_find_derived_vtab (derived); + if (final_expr) + { + /* Return finalizer expression. */ + gfc_component *final; + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + gcc_assert (final->initializer + && final->initializer->expr_type != EXPR_NULL); + *final_expr = final->initializer; + } + return true; +} + + +/* Find (or generate) the symbol for an intrinsic type's vtab. This is + needed to support unlimited polymorphism. */ + +static gfc_symbol * +find_intrinsic_vtab (gfc_typespec *ts) +{ + gfc_namespace *ns; + gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL; + gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (ns) + { + char tname[GFC_MAX_SYMBOL_LEN+1]; + char *name; + + /* Encode all types as TYPENAME_KIND_ including especially character + arrays, whose length is now consistently stored in the _len component + of the class-variable. */ + sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); + name = xasprintf ("__vtab_%s", tname); + + /* Look for the vtab symbol in the top-level namespace only. */ + gfc_find_symbol (name, ns, 0, &vtab); + + if (vtab == NULL) + { + gfc_get_symbol (name, ns, &vtab); + vtab->ts.type = BT_DERIVED; + if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, + &gfc_current_locus)) + goto cleanup; + vtab->attr.target = 1; + vtab->attr.save = SAVE_IMPLICIT; + vtab->attr.vtab = 1; + vtab->attr.access = ACCESS_PUBLIC; + gfc_set_sym_referenced (vtab); + name = xasprintf ("__vtype_%s", tname); + + gfc_find_symbol (name, ns, 0, &vtype); + if (vtype == NULL) + { + gfc_component *c; + int hash; + gfc_namespace *sub_ns; + gfc_namespace *contained; + gfc_expr *e; + size_t e_size; + + gfc_get_symbol (name, ns, &vtype); + if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, + &gfc_current_locus)) + goto cleanup; + vtype->attr.access = ACCESS_PUBLIC; + vtype->attr.vtype = 1; + gfc_set_sym_referenced (vtype); + + /* Add component '_hash'. */ + if (!gfc_add_component (vtype, "_hash", &c)) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = 4; + c->attr.access = ACCESS_PRIVATE; + hash = gfc_intrinsic_hash_value (ts); + c->initializer = gfc_get_int_expr (gfc_default_integer_kind, + NULL, hash); + + /* Add component '_size'. */ + if (!gfc_add_component (vtype, "_size", &c)) + goto cleanup; + c->ts.type = BT_INTEGER; + c->ts.kind = gfc_size_kind; + c->attr.access = ACCESS_PRIVATE; + + /* Build a minimal expression to make use of + target-memory.c/gfc_element_size for 'size'. Special handling + for character arrays, that are not constant sized: to support + len (str) * kind, only the kind information is stored in the + vtab. */ + e = gfc_get_expr (); + e->ts = *ts; + e->expr_type = EXPR_VARIABLE; + if (ts->type == BT_CHARACTER) + e_size = ts->kind; + else + gfc_element_size (e, &e_size); + c->initializer = gfc_get_int_expr (gfc_size_kind, + NULL, + e_size); + gfc_free_expr (e); + + /* Add component _extends. */ + if (!gfc_add_component (vtype, "_extends", &c)) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->ts.type = BT_VOID; + c->initializer = gfc_get_null_expr (NULL); + + /* Add component _def_init. */ + if (!gfc_add_component (vtype, "_def_init", &c)) + goto cleanup; + c->attr.pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->ts.type = BT_VOID; + c->initializer = gfc_get_null_expr (NULL); + + /* Add component _copy. */ + if (!gfc_add_component (vtype, "_copy", &c)) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + + if (ts->type != BT_CHARACTER) + name = xasprintf ("__copy_%s", tname); + else + { + /* __copy is always the same for characters. + Check to see if copy function already exists. */ + name = xasprintf ("__copy_character_%d", ts->kind); + contained = ns->contained; + for (; contained; contained = contained->sibling) + if (contained->proc_name + && strcmp (name, contained->proc_name->name) == 0) + { + copy = contained->proc_name; + goto got_char_copy; + } + } + + /* Set up namespace. */ + sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + gfc_get_symbol (name, sub_ns, ©); + sub_ns->proc_name = copy; + copy->attr.flavor = FL_PROCEDURE; + copy->attr.subroutine = 1; + copy->attr.pure = 1; + copy->attr.if_source = IFSRC_DECL; + /* This is elemental so that arrays are automatically + treated correctly by the scalarizer. */ + copy->attr.elemental = 1; + if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE) + copy->module = ns->proc_name->name; + gfc_set_sym_referenced (copy); + /* Set up formal arguments. */ + gfc_get_symbol ("src", sub_ns, &src); + src->ts.type = ts->type; + src->ts.kind = ts->kind; + src->attr.flavor = FL_VARIABLE; + src->attr.dummy = 1; + src->attr.intent = INTENT_IN; + gfc_set_sym_referenced (src); + copy->formal = gfc_get_formal_arglist (); + copy->formal->sym = src; + gfc_get_symbol ("dst", sub_ns, &dst); + dst->ts.type = ts->type; + dst->ts.kind = ts->kind; + dst->attr.flavor = FL_VARIABLE; + dst->attr.dummy = 1; + dst->attr.intent = INTENT_INOUT; + gfc_set_sym_referenced (dst); + copy->formal->next = gfc_get_formal_arglist (); + copy->formal->next->sym = dst; + /* Set up code. */ + sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN); + sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); + sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); + got_char_copy: + /* Set initializer. */ + c->initializer = gfc_lval_expr_from_sym (copy); + c->ts.interface = copy; + + /* Add component _final. */ + if (!gfc_add_component (vtype, "_final", &c)) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + c->initializer = gfc_get_null_expr (NULL); + } + vtab->ts.u.derived = vtype; + vtab->value = gfc_default_initializer (&vtab->ts); + } + free (name); + } + + found_sym = vtab; + +cleanup: + /* It is unexpected to have some symbols added at resolution or code + generation time. We commit the changes in order to keep a clean state. */ + if (found_sym) + { + gfc_commit_symbol (vtab); + if (vtype) + gfc_commit_symbol (vtype); + if (copy) + gfc_commit_symbol (copy); + if (src) + gfc_commit_symbol (src); + if (dst) + gfc_commit_symbol (dst); + } + else + gfc_undo_symbols (); + + return found_sym; +} + + +/* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */ + +gfc_symbol * +gfc_find_vtab (gfc_typespec *ts) +{ + switch (ts->type) + { + case BT_UNKNOWN: + return NULL; + case BT_DERIVED: + return gfc_find_derived_vtab (ts->u.derived); + case BT_CLASS: + if (ts->u.derived->attr.is_class + && ts->u.derived->components + && ts->u.derived->components->ts.u.derived) + return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived); + else + return NULL; + default: + return find_intrinsic_vtab (ts); + } +} + + +/* General worker function to find either a type-bound procedure or a + type-bound user operator. */ + +static gfc_symtree* +find_typebound_proc_uop (gfc_symbol* derived, bool* t, + const char* name, bool noaccess, bool uop, + locus* where) +{ + gfc_symtree* res; + gfc_symtree* root; + + /* Set default to failure. */ + if (t) + *t = false; + + if (derived->f2k_derived) + /* Set correct symbol-root. */ + root = (uop ? derived->f2k_derived->tb_uop_root + : derived->f2k_derived->tb_sym_root); + else + return NULL; + + /* Try to find it in the current type's namespace. */ + res = gfc_find_symtree (root, name); + if (res && res->n.tb && !res->n.tb->error) + { + /* We found one. */ + if (t) + *t = true; + + if (!noaccess && derived->attr.use_assoc + && res->n.tb->access == ACCESS_PRIVATE) + { + if (where) + gfc_error ("%qs of %qs is PRIVATE at %L", + name, derived->name, where); + if (t) + *t = false; + } + + return res; + } + + /* Otherwise, recurse on parent type if derived is an extension. */ + if (derived->attr.extension) + { + gfc_symbol* super_type; + super_type = gfc_get_derived_super_type (derived); + gcc_assert (super_type); + + return find_typebound_proc_uop (super_type, t, name, + noaccess, uop, where); + } + + /* Nothing found. */ + return NULL; +} + + +/* Find a type-bound procedure or user operator by name for a derived-type + (looking recursively through the super-types). */ + +gfc_symtree* +gfc_find_typebound_proc (gfc_symbol* derived, bool* t, + const char* name, bool noaccess, locus* where) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, false, where); +} + +gfc_symtree* +gfc_find_typebound_user_op (gfc_symbol* derived, bool* t, + const char* name, bool noaccess, locus* where) +{ + return find_typebound_proc_uop (derived, t, name, noaccess, true, where); +} + + +/* Find a type-bound intrinsic operator looking recursively through the + super-type hierarchy. */ + +gfc_typebound_proc* +gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t, + gfc_intrinsic_op op, bool noaccess, + locus* where) +{ + gfc_typebound_proc* res; + + /* Set default to failure. */ + if (t) + *t = false; + + /* Try to find it in the current type's namespace. */ + if (derived->f2k_derived) + res = derived->f2k_derived->tb_op[op]; + else + res = NULL; + + /* Check access. */ + if (res && !res->error) + { + /* We found one. */ + if (t) + *t = true; + + if (!noaccess && derived->attr.use_assoc + && res->access == ACCESS_PRIVATE) + { + if (where) + gfc_error ("%qs of %qs is PRIVATE at %L", + gfc_op2string (op), derived->name, where); + if (t) + *t = false; + } + + return res; + } + + /* Otherwise, recurse on parent type if derived is an extension. */ + if (derived->attr.extension) + { + gfc_symbol* super_type; + super_type = gfc_get_derived_super_type (derived); + gcc_assert (super_type); + + return gfc_find_typebound_intrinsic_op (super_type, t, op, + noaccess, where); + } + + /* Nothing found. */ + return NULL; +} + + +/* Get a typebound-procedure symtree or create and insert it if not yet + present. This is like a very simplified version of gfc_get_sym_tree for + tbp-symtrees rather than regular ones. */ + +gfc_symtree* +gfc_get_tbp_symtree (gfc_symtree **root, const char *name) +{ + gfc_symtree *result = gfc_find_symtree (*root, name); + return result ? result : gfc_new_symtree (root, name); +} diff --git a/gcc/fortran/constructor.c b/gcc/fortran/constructor.c deleted file mode 100644 index d07dc84..0000000 --- a/gcc/fortran/constructor.c +++ /dev/null @@ -1,261 +0,0 @@ -/* Array and structure constructors - Copyright (C) 2009-2022 Free Software Foundation, Inc. - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "constructor.h" - - -static void -node_free (splay_tree_value value) -{ - gfc_constructor *c = (gfc_constructor*)value; - - if (c->expr) - gfc_free_expr (c->expr); - - if (c->iterator) - gfc_free_iterator (c->iterator, 1); - - mpz_clear (c->offset); - mpz_clear (c->repeat); - - free (c); -} - - -static gfc_constructor * -node_copy (splay_tree_node node, void *base) -{ - gfc_constructor *c, *src = (gfc_constructor*)node->value; - - c = XCNEW (gfc_constructor); - c->base = (gfc_constructor_base)base; - c->expr = gfc_copy_expr (src->expr); - c->iterator = gfc_copy_iterator (src->iterator); - c->where = src->where; - c->n.component = src->n.component; - - mpz_init_set (c->offset, src->offset); - mpz_init_set (c->repeat, src->repeat); - - return c; -} - - -static int -node_copy_and_insert (splay_tree_node node, void *base) -{ - int n = mpz_get_si (((gfc_constructor*)node->value)->offset); - gfc_constructor_insert ((gfc_constructor_base*)base, - node_copy (node, base), n); - return 0; -} - - -gfc_constructor * -gfc_constructor_get (void) -{ - gfc_constructor *c = XCNEW (gfc_constructor); - c->base = NULL; - c->expr = NULL; - c->iterator = NULL; - - mpz_init_set_si (c->offset, 0); - mpz_init_set_si (c->repeat, 1); - - return c; -} - -static gfc_constructor_base -gfc_constructor_get_base (void) -{ - return splay_tree_new (splay_tree_compare_ints, NULL, node_free); -} - - -gfc_constructor_base -gfc_constructor_copy (gfc_constructor_base base) -{ - gfc_constructor_base new_base; - - if (!base) - return NULL; - - new_base = gfc_constructor_get_base (); - splay_tree_foreach (base, node_copy_and_insert, &new_base); - - return new_base; -} - - -void -gfc_constructor_free (gfc_constructor_base base) -{ - if (base) - splay_tree_delete (base); -} - - -gfc_constructor * -gfc_constructor_append (gfc_constructor_base *base, gfc_constructor *c) -{ - int offset = 0; - if (*base) - offset = (int)(splay_tree_max (*base)->key) + 1; - - return gfc_constructor_insert (base, c, offset); -} - - -gfc_constructor * -gfc_constructor_append_expr (gfc_constructor_base *base, - gfc_expr *e, locus *where) -{ - gfc_constructor *c = gfc_constructor_get (); - c->expr = e; - if (where) - c->where = *where; - - return gfc_constructor_append (base, c); -} - - -gfc_constructor * -gfc_constructor_insert (gfc_constructor_base *base, gfc_constructor *c, int n) -{ - splay_tree_node node; - - if (*base == NULL) - *base = splay_tree_new (splay_tree_compare_ints, NULL, node_free); - - c->base = *base; - mpz_set_si (c->offset, n); - - node = splay_tree_insert (*base, (splay_tree_key) n, (splay_tree_value) c); - gcc_assert (node); - - return (gfc_constructor*)node->value; -} - - -gfc_constructor * -gfc_constructor_insert_expr (gfc_constructor_base *base, - gfc_expr *e, locus *where, int n) -{ - gfc_constructor *c = gfc_constructor_get (); - c->expr = e; - if (where) - c->where = *where; - - return gfc_constructor_insert (base, c, n); -} - - -gfc_constructor * -gfc_constructor_lookup (gfc_constructor_base base, int offset) -{ - gfc_constructor *c; - splay_tree_node node; - - if (!base) - return NULL; - - node = splay_tree_lookup (base, (splay_tree_key) offset); - if (node) - return (gfc_constructor *) node->value; - - /* Check if the previous node has a repeat count big enough to - cover the offset looked for. */ - node = splay_tree_predecessor (base, (splay_tree_key) offset); - if (!node) - return NULL; - - c = (gfc_constructor *) node->value; - if (mpz_cmp_si (c->repeat, 1) > 0) - { - if (mpz_get_si (c->offset) + mpz_get_si (c->repeat) <= offset) - c = NULL; - } - else - c = NULL; - - return c; -} - - -gfc_expr * -gfc_constructor_lookup_expr (gfc_constructor_base base, int offset) -{ - gfc_constructor *c = gfc_constructor_lookup (base, offset); - return c ? c->expr : NULL; -} - - -gfc_constructor * -gfc_constructor_first (gfc_constructor_base base) -{ - if (base) - { - splay_tree_node node = splay_tree_min (base); - return node ? (gfc_constructor*) node->value : NULL; - } - else - return NULL; -} - - -gfc_constructor * -gfc_constructor_next (gfc_constructor *ctor) -{ - if (ctor) - { - splay_tree_node node = splay_tree_successor (ctor->base, - mpz_get_si (ctor->offset)); - return node ? (gfc_constructor*) node->value : NULL; - } - else - return NULL; -} - - -void -gfc_constructor_remove (gfc_constructor *ctor) -{ - if (ctor) - splay_tree_remove (ctor->base, mpz_get_si (ctor->offset)); -} - - -gfc_constructor * -gfc_constructor_lookup_next (gfc_constructor_base base, int offset) -{ - splay_tree_node node; - - if (!base) - return NULL; - - node = splay_tree_successor (base, (splay_tree_key) offset); - if (!node) - return NULL; - - return (gfc_constructor *) node->value; -} diff --git a/gcc/fortran/constructor.cc b/gcc/fortran/constructor.cc new file mode 100644 index 0000000..d07dc84 --- /dev/null +++ b/gcc/fortran/constructor.cc @@ -0,0 +1,261 @@ +/* Array and structure constructors + Copyright (C) 2009-2022 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "constructor.h" + + +static void +node_free (splay_tree_value value) +{ + gfc_constructor *c = (gfc_constructor*)value; + + if (c->expr) + gfc_free_expr (c->expr); + + if (c->iterator) + gfc_free_iterator (c->iterator, 1); + + mpz_clear (c->offset); + mpz_clear (c->repeat); + + free (c); +} + + +static gfc_constructor * +node_copy (splay_tree_node node, void *base) +{ + gfc_constructor *c, *src = (gfc_constructor*)node->value; + + c = XCNEW (gfc_constructor); + c->base = (gfc_constructor_base)base; + c->expr = gfc_copy_expr (src->expr); + c->iterator = gfc_copy_iterator (src->iterator); + c->where = src->where; + c->n.component = src->n.component; + + mpz_init_set (c->offset, src->offset); + mpz_init_set (c->repeat, src->repeat); + + return c; +} + + +static int +node_copy_and_insert (splay_tree_node node, void *base) +{ + int n = mpz_get_si (((gfc_constructor*)node->value)->offset); + gfc_constructor_insert ((gfc_constructor_base*)base, + node_copy (node, base), n); + return 0; +} + + +gfc_constructor * +gfc_constructor_get (void) +{ + gfc_constructor *c = XCNEW (gfc_constructor); + c->base = NULL; + c->expr = NULL; + c->iterator = NULL; + + mpz_init_set_si (c->offset, 0); + mpz_init_set_si (c->repeat, 1); + + return c; +} + +static gfc_constructor_base +gfc_constructor_get_base (void) +{ + return splay_tree_new (splay_tree_compare_ints, NULL, node_free); +} + + +gfc_constructor_base +gfc_constructor_copy (gfc_constructor_base base) +{ + gfc_constructor_base new_base; + + if (!base) + return NULL; + + new_base = gfc_constructor_get_base (); + splay_tree_foreach (base, node_copy_and_insert, &new_base); + + return new_base; +} + + +void +gfc_constructor_free (gfc_constructor_base base) +{ + if (base) + splay_tree_delete (base); +} + + +gfc_constructor * +gfc_constructor_append (gfc_constructor_base *base, gfc_constructor *c) +{ + int offset = 0; + if (*base) + offset = (int)(splay_tree_max (*base)->key) + 1; + + return gfc_constructor_insert (base, c, offset); +} + + +gfc_constructor * +gfc_constructor_append_expr (gfc_constructor_base *base, + gfc_expr *e, locus *where) +{ + gfc_constructor *c = gfc_constructor_get (); + c->expr = e; + if (where) + c->where = *where; + + return gfc_constructor_append (base, c); +} + + +gfc_constructor * +gfc_constructor_insert (gfc_constructor_base *base, gfc_constructor *c, int n) +{ + splay_tree_node node; + + if (*base == NULL) + *base = splay_tree_new (splay_tree_compare_ints, NULL, node_free); + + c->base = *base; + mpz_set_si (c->offset, n); + + node = splay_tree_insert (*base, (splay_tree_key) n, (splay_tree_value) c); + gcc_assert (node); + + return (gfc_constructor*)node->value; +} + + +gfc_constructor * +gfc_constructor_insert_expr (gfc_constructor_base *base, + gfc_expr *e, locus *where, int n) +{ + gfc_constructor *c = gfc_constructor_get (); + c->expr = e; + if (where) + c->where = *where; + + return gfc_constructor_insert (base, c, n); +} + + +gfc_constructor * +gfc_constructor_lookup (gfc_constructor_base base, int offset) +{ + gfc_constructor *c; + splay_tree_node node; + + if (!base) + return NULL; + + node = splay_tree_lookup (base, (splay_tree_key) offset); + if (node) + return (gfc_constructor *) node->value; + + /* Check if the previous node has a repeat count big enough to + cover the offset looked for. */ + node = splay_tree_predecessor (base, (splay_tree_key) offset); + if (!node) + return NULL; + + c = (gfc_constructor *) node->value; + if (mpz_cmp_si (c->repeat, 1) > 0) + { + if (mpz_get_si (c->offset) + mpz_get_si (c->repeat) <= offset) + c = NULL; + } + else + c = NULL; + + return c; +} + + +gfc_expr * +gfc_constructor_lookup_expr (gfc_constructor_base base, int offset) +{ + gfc_constructor *c = gfc_constructor_lookup (base, offset); + return c ? c->expr : NULL; +} + + +gfc_constructor * +gfc_constructor_first (gfc_constructor_base base) +{ + if (base) + { + splay_tree_node node = splay_tree_min (base); + return node ? (gfc_constructor*) node->value : NULL; + } + else + return NULL; +} + + +gfc_constructor * +gfc_constructor_next (gfc_constructor *ctor) +{ + if (ctor) + { + splay_tree_node node = splay_tree_successor (ctor->base, + mpz_get_si (ctor->offset)); + return node ? (gfc_constructor*) node->value : NULL; + } + else + return NULL; +} + + +void +gfc_constructor_remove (gfc_constructor *ctor) +{ + if (ctor) + splay_tree_remove (ctor->base, mpz_get_si (ctor->offset)); +} + + +gfc_constructor * +gfc_constructor_lookup_next (gfc_constructor_base base, int offset) +{ + splay_tree_node node; + + if (!base) + return NULL; + + node = splay_tree_successor (base, (splay_tree_key) offset); + if (!node) + return NULL; + + return (gfc_constructor *) node->value; +} diff --git a/gcc/fortran/convert.c b/gcc/fortran/convert.c deleted file mode 100644 index 926a873..0000000 --- a/gcc/fortran/convert.c +++ /dev/null @@ -1,121 +0,0 @@ -/* Data type conversion - Copyright (C) 1987-2022 Free Software Foundation, Inc. - -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 -. */ - - -/* This file contains the functions for converting expressions to - different data types for the translation of the gfortran internal - representation to GIMPLE. The only entry point is `convert'. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "fold-const.h" -#include "convert.h" - -#include "gfortran.h" -#include "trans.h" -#include "trans-types.h" - -/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, - or validate its data type for a GIMPLE `if' or `while' statement. - - The resulting type should always be `logical_type_node'. */ - -static tree -truthvalue_conversion (tree expr) -{ - switch (TREE_CODE (TREE_TYPE (expr))) - { - case BOOLEAN_TYPE: - if (TREE_TYPE (expr) == logical_type_node) - return expr; - else if (COMPARISON_CLASS_P (expr)) - { - TREE_TYPE (expr) = logical_type_node; - return expr; - } - else if (TREE_CODE (expr) == NOP_EXPR) - return fold_build1_loc (input_location, NOP_EXPR, - logical_type_node, - TREE_OPERAND (expr, 0)); - else - return fold_build1_loc (input_location, NOP_EXPR, - logical_type_node, - expr); - - case INTEGER_TYPE: - if (TREE_CODE (expr) == INTEGER_CST) - return integer_zerop (expr) ? logical_false_node - : logical_true_node; - else - return fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - expr, build_int_cst (TREE_TYPE (expr), 0)); - - default: - gcc_unreachable (); - } -} - -/* Create an expression whose value is that of EXPR, - converted to type TYPE. The TREE_TYPE of the value - is always TYPE. This function implements all reasonable - conversions; callers should filter out those that are - not permitted by the language being compiled. */ - -tree -convert (tree type, tree expr) -{ - tree e = expr; - enum tree_code code; - - if (type == TREE_TYPE (expr)) - return expr; - - if (TREE_CODE (type) == ERROR_MARK - || TREE_CODE (expr) == ERROR_MARK - || TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK) - return expr; - - gcc_checking_assert (TREE_CODE (TREE_TYPE (expr)) != VOID_TYPE); - - if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) - return fold_build1_loc (input_location, NOP_EXPR, type, expr); - - code = TREE_CODE (type); - if (code == VOID_TYPE) - return fold_build1_loc (input_location, CONVERT_EXPR, type, e); - if (code == BOOLEAN_TYPE) - return fold_build1_loc (input_location, NOP_EXPR, type, - truthvalue_conversion (e)); - if (code == INTEGER_TYPE) - return fold (convert_to_integer (type, e)); - if (code == POINTER_TYPE || code == REFERENCE_TYPE) - return fold (convert_to_pointer (type, e)); - if (code == REAL_TYPE) - return fold (convert_to_real (type, e)); - if (code == COMPLEX_TYPE) - return fold (convert_to_complex (type, e)); - if (code == VECTOR_TYPE) - return fold (convert_to_vector (type, e)); - - gcc_unreachable (); -} - diff --git a/gcc/fortran/convert.cc b/gcc/fortran/convert.cc new file mode 100644 index 0000000..926a873 --- /dev/null +++ b/gcc/fortran/convert.cc @@ -0,0 +1,121 @@ +/* Data type conversion + Copyright (C) 1987-2022 Free Software Foundation, Inc. + +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 +. */ + + +/* This file contains the functions for converting expressions to + different data types for the translation of the gfortran internal + representation to GIMPLE. The only entry point is `convert'. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "fold-const.h" +#include "convert.h" + +#include "gfortran.h" +#include "trans.h" +#include "trans-types.h" + +/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, + or validate its data type for a GIMPLE `if' or `while' statement. + + The resulting type should always be `logical_type_node'. */ + +static tree +truthvalue_conversion (tree expr) +{ + switch (TREE_CODE (TREE_TYPE (expr))) + { + case BOOLEAN_TYPE: + if (TREE_TYPE (expr) == logical_type_node) + return expr; + else if (COMPARISON_CLASS_P (expr)) + { + TREE_TYPE (expr) = logical_type_node; + return expr; + } + else if (TREE_CODE (expr) == NOP_EXPR) + return fold_build1_loc (input_location, NOP_EXPR, + logical_type_node, + TREE_OPERAND (expr, 0)); + else + return fold_build1_loc (input_location, NOP_EXPR, + logical_type_node, + expr); + + case INTEGER_TYPE: + if (TREE_CODE (expr) == INTEGER_CST) + return integer_zerop (expr) ? logical_false_node + : logical_true_node; + else + return fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + expr, build_int_cst (TREE_TYPE (expr), 0)); + + default: + gcc_unreachable (); + } +} + +/* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. */ + +tree +convert (tree type, tree expr) +{ + tree e = expr; + enum tree_code code; + + if (type == TREE_TYPE (expr)) + return expr; + + if (TREE_CODE (type) == ERROR_MARK + || TREE_CODE (expr) == ERROR_MARK + || TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK) + return expr; + + gcc_checking_assert (TREE_CODE (TREE_TYPE (expr)) != VOID_TYPE); + + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) + return fold_build1_loc (input_location, NOP_EXPR, type, expr); + + code = TREE_CODE (type); + if (code == VOID_TYPE) + return fold_build1_loc (input_location, CONVERT_EXPR, type, e); + if (code == BOOLEAN_TYPE) + return fold_build1_loc (input_location, NOP_EXPR, type, + truthvalue_conversion (e)); + if (code == INTEGER_TYPE) + return fold (convert_to_integer (type, e)); + if (code == POINTER_TYPE || code == REFERENCE_TYPE) + return fold (convert_to_pointer (type, e)); + if (code == REAL_TYPE) + return fold (convert_to_real (type, e)); + if (code == COMPLEX_TYPE) + return fold (convert_to_complex (type, e)); + if (code == VECTOR_TYPE) + return fold (convert_to_vector (type, e)); + + gcc_unreachable (); +} + diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c deleted file mode 100644 index a655686..0000000 --- a/gcc/fortran/cpp.c +++ /dev/null @@ -1,1203 +0,0 @@ -/* Copyright (C) 2008-2022 Free Software Foundation, Inc. - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" - -#define GCC_C_COMMON_C -#include "options.h" /* For cpp_reason_option_codes. */ -#undef GCC_C_COMMON_C - -#include "target.h" -#include "gfortran.h" -#include "diagnostic.h" - -#include "toplev.h" - -#include "../../libcpp/internal.h" -#include "cpp.h" -#include "incpath.h" -#include "cppbuiltin.h" -#include "mkdeps.h" - -#ifndef TARGET_SYSTEM_ROOT -# define TARGET_SYSTEM_ROOT NULL -#endif - -#ifndef TARGET_CPU_CPP_BUILTINS -# define TARGET_CPU_CPP_BUILTINS() -#endif - -#ifndef TARGET_OS_CPP_BUILTINS -# define TARGET_OS_CPP_BUILTINS() -#endif - -#ifndef TARGET_OBJFMT_CPP_BUILTINS -# define TARGET_OBJFMT_CPP_BUILTINS() -#endif - - -/* Holds switches parsed by gfc_cpp_handle_option (), but whose - handling is deferred to gfc_cpp_init (). */ -typedef struct -{ - enum opt_code code; - const char *arg; -} -gfc_cpp_deferred_opt_t; - - -/* Defined and undefined macros being queued for output with -dU at - the next newline. */ -typedef struct gfc_cpp_macro_queue -{ - struct gfc_cpp_macro_queue *next; /* Next macro in the list. */ - char *macro; /* The name of the macro if not - defined, the full definition if - defined. */ -} gfc_cpp_macro_queue; -static gfc_cpp_macro_queue *cpp_define_queue, *cpp_undefine_queue; - -struct gfc_cpp_option_data -{ - /* Argument of -cpp, implied by SPEC; - if NULL, preprocessing disabled. */ - const char *temporary_filename; - - const char *output_filename; /* -o */ - int preprocess_only; /* -E */ - int discard_comments; /* -C */ - int discard_comments_in_macro_exp; /* -CC */ - int print_include_names; /* -H */ - int no_line_commands; /* -P */ - char dump_macros; /* -d[DMNU] */ - int dump_includes; /* -dI */ - int working_directory; /* -fworking-directory */ - int no_predefined; /* -undef */ - int standard_include_paths; /* -nostdinc */ - int verbose; /* -v */ - int deps; /* -M */ - int deps_skip_system; /* -MM */ - const char *deps_filename; /* -M[M]D */ - const char *deps_filename_user; /* -MF */ - int deps_missing_are_generated; /* -MG */ - int deps_phony; /* -MP */ - int warn_date_time; /* -Wdate-time */ - - const char *multilib; /* -imultilib */ - const char *prefix; /* -iprefix */ - const char *sysroot; /* -isysroot */ - - /* Options whose handling needs to be deferred until the - appropriate cpp-objects are created: - -A predicate=answer - -D [=] - -U */ - gfc_cpp_deferred_opt_t *deferred_opt; - int deferred_opt_count; -} -gfc_cpp_option; - -/* Structures used with libcpp: */ -static cpp_options *cpp_option = NULL; -static cpp_reader *cpp_in = NULL; - -/* Encapsulates state used to convert a stream of cpp-tokens into - a text file. */ -static struct -{ - FILE *outf; /* Stream to write to. */ - const cpp_token *prev; /* Previous token. */ - const cpp_token *source; /* Source token for spacing. */ - int src_line; /* Line number currently being written. */ - unsigned char printed; /* Nonzero if something output at line. */ - bool first_time; /* cb_file_change hasn't been called yet. */ -} print; - -/* General output routines. */ -static void scan_translation_unit (cpp_reader *); -static void scan_translation_unit_trad (cpp_reader *); - -/* Callback routines for the parser. Most of these are active only - in specific modes. */ -static void cb_file_change (cpp_reader *, const line_map_ordinary *); -static void cb_line_change (cpp_reader *, const cpp_token *, int); -static void cb_define (cpp_reader *, location_t, cpp_hashnode *); -static void cb_undef (cpp_reader *, location_t, cpp_hashnode *); -static void cb_def_pragma (cpp_reader *, location_t); -static void cb_include (cpp_reader *, location_t, const unsigned char *, - const char *, int, const cpp_token **); -static void cb_ident (cpp_reader *, location_t, const cpp_string *); -static void cb_used_define (cpp_reader *, location_t, cpp_hashnode *); -static void cb_used_undef (cpp_reader *, location_t, cpp_hashnode *); -static bool cb_cpp_diagnostic (cpp_reader *, enum cpp_diagnostic_level, - enum cpp_warning_reason, rich_location *, - const char *, va_list *) - ATTRIBUTE_GCC_DIAG(5,0); -void pp_dir_change (cpp_reader *, const char *); - -static int dump_macro (cpp_reader *, cpp_hashnode *, void *); -static void dump_queued_macros (cpp_reader *); - - -static void -cpp_define_builtins (cpp_reader *pfile) -{ - /* Initialize CPP built-ins; '1' corresponds to 'flag_hosted' - in C, defines __STDC_HOSTED__?! */ - cpp_init_builtins (pfile, 0); - - /* Initialize GFORTRAN specific builtins. - These are documented. */ - define_language_independent_builtin_macros (pfile); - cpp_define (pfile, "__GFORTRAN__=1"); - cpp_define (pfile, "_LANGUAGE_FORTRAN=1"); - - if (flag_openacc) - cpp_define (pfile, "_OPENACC=201711"); - - if (flag_openmp) - cpp_define (pfile, "_OPENMP=201511"); - - /* The defines below are necessary for the TARGET_* macros. - - FIXME: Note that builtin_define_std() actually is a function - in c-cppbuiltin.c which uses flags undefined for Fortran. - Let's skip this for now. If needed, one needs to look into it - once more. */ - -# define builtin_define(TXT) cpp_define (pfile, TXT) -# define builtin_define_std(TXT) -# define builtin_assert(TXT) cpp_assert (pfile, TXT) - - /* FIXME: Pandora's Box - Using the macros below results in multiple breakages: - - mingw will fail to compile this file as dependent macros - assume to be used in c-cppbuiltin.c only. Further, they use - flags only valid/defined in C (same as noted above). - [config/i386/mingw32.h, config/i386/cygming.h] - - other platforms (not as popular) break similarly - [grep for 'builtin_define_with_int_value' in gcc/config/] - - TARGET_CPU_CPP_BUILTINS (); - TARGET_OS_CPP_BUILTINS (); - TARGET_OBJFMT_CPP_BUILTINS (); */ - -#undef builtin_define -#undef builtin_define_std -#undef builtin_assert -} - -bool -gfc_cpp_enabled (void) -{ - return gfc_cpp_option.temporary_filename != NULL; -} - -bool -gfc_cpp_preprocess_only (void) -{ - return gfc_cpp_option.preprocess_only; -} - -bool -gfc_cpp_makedep (void) -{ - return gfc_cpp_option.deps; -} - -void -gfc_cpp_add_dep (const char *name, bool system) -{ - if (!gfc_cpp_option.deps_skip_system || !system) - if (mkdeps *deps = cpp_get_deps (cpp_in)) - deps_add_dep (deps, name); -} - -void -gfc_cpp_add_target (const char *name) -{ - if (mkdeps *deps = cpp_get_deps (cpp_in)) - deps_add_target (deps, name, 0); -} - - -const char * -gfc_cpp_temporary_file (void) -{ - return gfc_cpp_option.temporary_filename; -} - -static void -gfc_cpp_register_include_paths (bool verbose_missing_dir_warn) -{ - int cxx_stdinc = 0; - cpp_get_options (cpp_in)->warn_missing_include_dirs - = (global_options.x_cpp_warn_missing_include_dirs - && verbose_missing_dir_warn); - register_include_chains (cpp_in, gfc_cpp_option.sysroot, - gfc_cpp_option.prefix, gfc_cpp_option.multilib, - gfc_cpp_option.standard_include_paths, cxx_stdinc, - gfc_cpp_option.verbose); -} - -void -gfc_cpp_init_options (unsigned int decoded_options_count, - struct cl_decoded_option *decoded_options ATTRIBUTE_UNUSED) -{ - /* Do not create any objects from libcpp here. If no - preprocessing is requested, this would be wasted - time and effort. - - See gfc_cpp_post_options() instead. */ - - gfc_cpp_option.temporary_filename = NULL; - gfc_cpp_option.output_filename = NULL; - gfc_cpp_option.preprocess_only = 0; - gfc_cpp_option.discard_comments = 1; - gfc_cpp_option.discard_comments_in_macro_exp = 1; - gfc_cpp_option.print_include_names = 0; - gfc_cpp_option.no_line_commands = 0; - gfc_cpp_option.dump_macros = '\0'; - gfc_cpp_option.dump_includes = 0; - gfc_cpp_option.working_directory = -1; - gfc_cpp_option.no_predefined = 0; - gfc_cpp_option.standard_include_paths = 1; - gfc_cpp_option.verbose = 0; - gfc_cpp_option.warn_date_time = 0; - gfc_cpp_option.deps = 0; - gfc_cpp_option.deps_skip_system = 0; - gfc_cpp_option.deps_phony = 0; - gfc_cpp_option.deps_missing_are_generated = 0; - gfc_cpp_option.deps_filename = NULL; - gfc_cpp_option.deps_filename_user = NULL; - - gfc_cpp_option.multilib = NULL; - gfc_cpp_option.prefix = NULL; - gfc_cpp_option.sysroot = TARGET_SYSTEM_ROOT; - - gfc_cpp_option.deferred_opt = XNEWVEC (gfc_cpp_deferred_opt_t, - decoded_options_count); - gfc_cpp_option.deferred_opt_count = 0; -} - -int -gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED) -{ - int result = 1; - enum opt_code code = (enum opt_code) scode; - - switch (code) - { - default: - result = 0; - break; - - case OPT_cpp_: - gfc_cpp_option.temporary_filename = arg; - break; - - case OPT_nocpp: - gfc_cpp_option.temporary_filename = 0L; - break; - - case OPT_d: - for ( ; *arg; ++arg) - switch (*arg) - { - case 'D': - case 'M': - case 'N': - case 'U': - gfc_cpp_option.dump_macros = *arg; - break; - - case 'I': - gfc_cpp_option.dump_includes = 1; - break; - } - break; - - case OPT_fworking_directory: - gfc_cpp_option.working_directory = value; - break; - - case OPT_idirafter: - gfc_cpp_add_include_path_after (xstrdup(arg), true); - break; - - case OPT_imultilib: - gfc_cpp_option.multilib = arg; - break; - - case OPT_iprefix: - gfc_cpp_option.prefix = arg; - break; - - case OPT_isysroot: - gfc_cpp_option.sysroot = arg; - break; - - case OPT_iquote: - case OPT_isystem: - gfc_cpp_add_include_path (xstrdup(arg), true); - break; - - case OPT_nostdinc: - gfc_cpp_option.standard_include_paths = value; - break; - - case OPT_o: - if (!gfc_cpp_option.output_filename) - gfc_cpp_option.output_filename = arg; - else - gfc_fatal_error ("output filename specified twice"); - break; - - case OPT_undef: - gfc_cpp_option.no_predefined = value; - break; - - case OPT_v: - gfc_cpp_option.verbose = value; - break; - - case OPT_Wdate_time: - gfc_cpp_option.warn_date_time = value; - break; - - case OPT_A: - case OPT_D: - case OPT_U: - gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; - gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; - gfc_cpp_option.deferred_opt_count++; - break; - - case OPT_C: - gfc_cpp_option.discard_comments = 0; - break; - - case OPT_CC: - gfc_cpp_option.discard_comments = 0; - gfc_cpp_option.discard_comments_in_macro_exp = 0; - break; - - case OPT_E: - gfc_cpp_option.preprocess_only = 1; - break; - - case OPT_H: - gfc_cpp_option.print_include_names = 1; - break; - - case OPT_MM: - gfc_cpp_option.deps_skip_system = 1; - /* fall through */ - - case OPT_M: - gfc_cpp_option.deps = 1; - break; - - case OPT_MMD: - gfc_cpp_option.deps_skip_system = 1; - /* fall through */ - - case OPT_MD: - gfc_cpp_option.deps = 1; - gfc_cpp_option.deps_filename = arg; - break; - - case OPT_MF: - /* If specified multiple times, last one wins. */ - gfc_cpp_option.deps_filename_user = arg; - break; - - case OPT_MG: - gfc_cpp_option.deps_missing_are_generated = 1; - break; - - case OPT_MP: - gfc_cpp_option.deps_phony = 1; - break; - - case OPT_MQ: - case OPT_MT: - gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; - gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; - gfc_cpp_option.deferred_opt_count++; - break; - - case OPT_P: - gfc_cpp_option.no_line_commands = 1; - break; - } - - return result; -} - -/* This function needs to be called before gfc_cpp_register_include_paths - as the latter may diagnose missing include directories. */ -static void -gfc_cpp_init_cb (void) -{ - struct cpp_callbacks *cb; - - cb = cpp_get_callbacks (cpp_in); - cb->file_change = cb_file_change; - cb->line_change = cb_line_change; - cb->ident = cb_ident; - cb->def_pragma = cb_def_pragma; - cb->diagnostic = cb_cpp_diagnostic; - - if (gfc_cpp_option.dump_includes) - cb->include = cb_include; - - if ((gfc_cpp_option.dump_macros == 'D') - || (gfc_cpp_option.dump_macros == 'N')) - { - cb->define = cb_define; - cb->undef = cb_undef; - } - - if (gfc_cpp_option.dump_macros == 'U') - { - cb->before_define = dump_queued_macros; - cb->used_define = cb_used_define; - cb->used_undef = cb_used_undef; - } -} - -void -gfc_cpp_post_options (bool verbose_missing_dir_warn) -{ - /* Any preprocessing-related option without '-cpp' is considered - an error. */ - if (!gfc_cpp_enabled () - && (gfc_cpp_preprocess_only () - || gfc_cpp_makedep () - || !gfc_cpp_option.discard_comments - || !gfc_cpp_option.discard_comments_in_macro_exp - || gfc_cpp_option.print_include_names - || gfc_cpp_option.no_line_commands - || gfc_cpp_option.dump_macros - || gfc_cpp_option.dump_includes)) - gfc_fatal_error ("To enable preprocessing, use %<-cpp%>"); - - if (!gfc_cpp_enabled ()) - return; - - cpp_in = cpp_create_reader (CLK_GNUC89, NULL, line_table); - gcc_assert (cpp_in); - - /* The cpp_options-structure defines far more flags than those set here. - If any other is implemented, see c-opt.c (sanitize_cpp_opts) for - inter-option dependencies that may need to be enforced. */ - cpp_option = cpp_get_options (cpp_in); - gcc_assert (cpp_option); - - /* TODO: allow non-traditional modes, e.g. by -cpp-std=...? */ - cpp_option->traditional = 1; - cpp_option->cplusplus_comments = 0; - - cpp_option->cpp_pedantic = pedantic; - - cpp_option->dollars_in_ident = flag_dollar_ok; - cpp_option->discard_comments = gfc_cpp_option.discard_comments; - cpp_option->discard_comments_in_macro_exp = gfc_cpp_option.discard_comments_in_macro_exp; - cpp_option->print_include_names = gfc_cpp_option.print_include_names; - cpp_option->preprocessed = gfc_option.flag_preprocessed; - cpp_option->warn_date_time = gfc_cpp_option.warn_date_time; - - if (gfc_cpp_makedep ()) - { - cpp_option->deps.style = DEPS_USER; - cpp_option->deps.phony_targets = gfc_cpp_option.deps_phony; - cpp_option->deps.missing_files = gfc_cpp_option.deps_missing_are_generated; - - /* -MF overrides -M[M]D. */ - if (gfc_cpp_option.deps_filename_user) - gfc_cpp_option.deps_filename = gfc_cpp_option.deps_filename_user; - } - - if (gfc_cpp_option.working_directory == -1) - gfc_cpp_option.working_directory = (debug_info_level != DINFO_LEVEL_NONE); - - cpp_post_options (cpp_in); - - - /* Let diagnostics infrastructure know how to convert input files the same - way libcpp will do it, namely, with no charset conversion but with - skipping of a UTF-8 BOM if present. */ - diagnostic_initialize_input_context (global_dc, nullptr, true); - gfc_cpp_init_cb (); - - gfc_cpp_register_include_paths (verbose_missing_dir_warn); -} - - -void -gfc_cpp_init_0 (void) -{ - /* Initialize the print structure. Setting print.src_line to -1 here is - a trick to guarantee that the first token of the file will cause - a linemarker to be output by maybe_print_line. */ - print.src_line = -1; - print.printed = 0; - print.prev = 0; - print.first_time = 1; - - if (gfc_cpp_preprocess_only ()) - { - if (gfc_cpp_option.output_filename) - { - /* This needs cheating: with "-E -o ", the user wants the - preprocessed output in . However, if nothing is done - about it is also used for assembler output. Hence, it - is necessary to redirect assembler output (actually nothing - as -E implies -fsyntax-only) to another file, otherwise the - output from preprocessing is lost. */ - asm_file_name = gfc_cpp_option.temporary_filename; - - print.outf = fopen (gfc_cpp_option.output_filename, "w"); - if (print.outf == NULL) - gfc_fatal_error ("opening output file %qs: %s", - gfc_cpp_option.output_filename, - xstrerror (errno)); - } - else - print.outf = stdout; - } - else - { - print.outf = fopen (gfc_cpp_option.temporary_filename, "w"); - if (print.outf == NULL) - gfc_fatal_error ("opening output file %qs: %s", - gfc_cpp_option.temporary_filename, xstrerror (errno)); - } - - gcc_assert(cpp_in); - if (!cpp_read_main_file (cpp_in, gfc_source_file)) - errorcount++; -} - -void -gfc_cpp_init (void) -{ - int i; - - if (gfc_option.flag_preprocessed) - return; - - cpp_change_file (cpp_in, LC_RENAME, _("")); - if (!gfc_cpp_option.no_predefined) - { - /* Make sure all of the builtins about to be declared have - BUILTINS_LOCATION has their location_t. */ - cpp_force_token_locations (cpp_in, BUILTINS_LOCATION); - - cpp_define_builtins (cpp_in); - - cpp_stop_forcing_token_locations (cpp_in); - } - - /* Handle deferred options from command-line. */ - cpp_change_file (cpp_in, LC_RENAME, _("")); - - for (i = 0; i < gfc_cpp_option.deferred_opt_count; i++) - { - gfc_cpp_deferred_opt_t *opt = &gfc_cpp_option.deferred_opt[i]; - - if (opt->code == OPT_D) - cpp_define (cpp_in, opt->arg); - else if (opt->code == OPT_U) - cpp_undef (cpp_in, opt->arg); - else if (opt->code == OPT_A) - { - if (opt->arg[0] == '-') - cpp_unassert (cpp_in, opt->arg + 1); - else - cpp_assert (cpp_in, opt->arg); - } - else if (opt->code == OPT_MT || opt->code == OPT_MQ) - if (mkdeps *deps = cpp_get_deps (cpp_in)) - deps_add_target (deps, opt->arg, opt->code == OPT_MQ); - } - - /* Pre-defined macros for non-required INTEGER kind types. */ - for (gfc_integer_info *itype = gfc_integer_kinds; itype->kind != 0; itype++) - { - if (itype->kind == 1) - cpp_define (cpp_in, "__GFC_INT_1__=1"); - if (itype->kind == 2) - cpp_define (cpp_in, "__GFC_INT_2__=1"); - if (itype->kind == 8) - cpp_define (cpp_in, "__GFC_INT_8__=1"); - if (itype->kind == 16) - cpp_define (cpp_in, "__GFC_INT_16__=1"); - } - - /* Pre-defined macros for non-required REAL kind types. */ - for (gfc_real_info *rtype = gfc_real_kinds; rtype->kind != 0; rtype++) - { - if (rtype->kind == 10) - cpp_define (cpp_in, "__GFC_REAL_10__=1"); - if (rtype->kind == 16) - cpp_define (cpp_in, "__GFC_REAL_16__=1"); - } - - if (gfc_cpp_option.working_directory - && gfc_cpp_option.preprocess_only && !gfc_cpp_option.no_line_commands) - pp_dir_change (cpp_in, get_src_pwd ()); -} - -bool -gfc_cpp_preprocess (const char *source_file) -{ - if (!gfc_cpp_enabled ()) - return false; - - cpp_change_file (cpp_in, LC_RENAME, source_file); - - if (cpp_option->traditional) - scan_translation_unit_trad (cpp_in); - else - scan_translation_unit (cpp_in); - - /* -dM command line option. */ - if (gfc_cpp_preprocess_only () && - gfc_cpp_option.dump_macros == 'M') - { - putc ('\n', print.outf); - cpp_forall_identifiers (cpp_in, dump_macro, NULL); - } - - putc ('\n', print.outf); - - if (!gfc_cpp_preprocess_only () - || (gfc_cpp_preprocess_only () && gfc_cpp_option.output_filename)) - fclose (print.outf); - - return true; -} - -void -gfc_cpp_done (void) -{ - if (!gfc_cpp_enabled ()) - return; - - gcc_assert (cpp_in); - - if (gfc_cpp_makedep ()) - { - if (gfc_cpp_option.deps_filename) - { - FILE *f = fopen (gfc_cpp_option.deps_filename, "w"); - if (f) - { - cpp_finish (cpp_in, f); - fclose (f); - } - else - gfc_fatal_error ("opening output file %qs: %s", - gfc_cpp_option.deps_filename, - xstrerror (errno)); - } - else - cpp_finish (cpp_in, stdout); - } - - cpp_undef_all (cpp_in); - cpp_clear_file_cache (cpp_in); -} - -/* PATH must be malloc-ed and NULL-terminated. */ -void -gfc_cpp_add_include_path (char *path, bool user_supplied) -{ - /* CHAIN sets cpp_dir->sysp which differs from 0 if PATH is a system - include path. Fortran does not define any system include paths. */ - int cxx_aware = 0; - - add_path (path, INC_BRACKET, cxx_aware, user_supplied); -} - -void -gfc_cpp_add_include_path_after (char *path, bool user_supplied) -{ - int cxx_aware = 0; - add_path (path, INC_AFTER, cxx_aware, user_supplied); -} - - -static void scan_translation_unit_trad (cpp_reader *); -static void account_for_newlines (const unsigned char *, size_t); -static int dump_macro (cpp_reader *, cpp_hashnode *, void *); - -static void print_line (location_t, const char *); -static void maybe_print_line (location_t); - - -/* Writes out the preprocessed file, handling spacing and paste - avoidance issues. */ -static void -scan_translation_unit (cpp_reader *pfile) -{ - bool avoid_paste = false; - - print.source = NULL; - for (;;) - { - const cpp_token *token = cpp_get_token (pfile); - - if (token->type == CPP_PADDING) - { - avoid_paste = true; - if (print.source == NULL - || (!(print.source->flags & PREV_WHITE) - && token->val.source == NULL)) - print.source = token->val.source; - continue; - } - - if (token->type == CPP_EOF) - break; - - /* Subtle logic to output a space if and only if necessary. */ - if (avoid_paste) - { - if (print.source == NULL) - print.source = token; - if (print.source->flags & PREV_WHITE - || (print.prev - && cpp_avoid_paste (pfile, print.prev, token)) - || (print.prev == NULL && token->type == CPP_HASH)) - putc (' ', print.outf); - } - else if (token->flags & PREV_WHITE) - putc (' ', print.outf); - - avoid_paste = false; - print.source = NULL; - print.prev = token; - cpp_output_token (token, print.outf); - - if (token->type == CPP_COMMENT) - account_for_newlines (token->val.str.text, token->val.str.len); - } -} - -/* Adjust print.src_line for newlines embedded in output. */ -static void -account_for_newlines (const unsigned char *str, size_t len) -{ - while (len--) - if (*str++ == '\n') - print.src_line++; -} - -/* Writes out a traditionally preprocessed file. */ -static void -scan_translation_unit_trad (cpp_reader *pfile) -{ - while (_cpp_read_logical_line_trad (pfile)) - { - size_t len = pfile->out.cur - pfile->out.base; - maybe_print_line (pfile->out.first_line); - fwrite (pfile->out.base, 1, len, print.outf); - print.printed = 1; - if (!CPP_OPTION (pfile, discard_comments)) - account_for_newlines (pfile->out.base, len); - } -} - -/* If the token read on logical line LINE needs to be output on a - different line to the current one, output the required newlines or - a line marker. */ -static void -maybe_print_line (location_t src_loc) -{ - const line_map_ordinary *map - = linemap_check_ordinary (linemap_lookup (line_table, src_loc)); - int src_line = SOURCE_LINE (map, src_loc); - - /* End the previous line of text. */ - if (print.printed) - { - putc ('\n', print.outf); - print.src_line++; - print.printed = 0; - } - - if (src_line >= print.src_line && src_line < print.src_line + 8) - { - while (src_line > print.src_line) - { - putc ('\n', print.outf); - print.src_line++; - } - } - else - print_line (src_loc, ""); -} - -/* Output a line marker for logical line LINE. Special flags are "1" - or "2" indicating entering or leaving a file. */ -static void -print_line (location_t src_loc, const char *special_flags) -{ - /* End any previous line of text. */ - if (print.printed) - putc ('\n', print.outf); - print.printed = 0; - - if (!gfc_cpp_option.no_line_commands) - { - expanded_location loc; - size_t to_file_len; - unsigned char *to_file_quoted; - unsigned char *p; - int sysp; - - loc = expand_location (src_loc); - to_file_len = strlen (loc.file); - to_file_quoted = (unsigned char *) alloca (to_file_len * 4 + 1); - - print.src_line = loc.line; - - /* cpp_quote_string does not nul-terminate, so we have to do it - ourselves. */ - p = cpp_quote_string (to_file_quoted, - (const unsigned char *) loc.file, to_file_len); - *p = '\0'; - fprintf (print.outf, "# %u \"%s\"%s", - print.src_line == 0 ? 1 : print.src_line, - to_file_quoted, special_flags); - - sysp = in_system_header_at (src_loc); - if (sysp == 2) - fputs (" 3 4", print.outf); - else if (sysp == 1) - fputs (" 3", print.outf); - - putc ('\n', print.outf); - } -} - -static void -cb_file_change (cpp_reader * ARG_UNUSED (pfile), const line_map_ordinary *map) -{ - const char *flags = ""; - - if (gfc_cpp_option.no_line_commands) - return; - - if (!map) - return; - - if (print.first_time) - { - /* Avoid printing foo.i when the main file is foo.c. */ - if (!cpp_get_options (cpp_in)->preprocessed) - print_line (map->start_location, flags); - print.first_time = 0; - } - else - { - /* Bring current file to correct line when entering a new file. */ - if (map->reason == LC_ENTER) - maybe_print_line (linemap_included_from (map)); - if (map->reason == LC_ENTER) - flags = " 1"; - else if (map->reason == LC_LEAVE) - flags = " 2"; - print_line (map->start_location, flags); - } - -} - -/* Called when a line of output is started. TOKEN is the first token - of the line, and at end of file will be CPP_EOF. */ -static void -cb_line_change (cpp_reader *pfile, const cpp_token *token, - int parsing_args) -{ - location_t src_loc = token->src_loc; - - if (token->type == CPP_EOF || parsing_args) - return; - - maybe_print_line (src_loc); - print.prev = 0; - print.source = 0; - - /* Supply enough spaces to put this token in its original column, - one space per column greater than 2, since scan_translation_unit - will provide a space if PREV_WHITE. Don't bother trying to - reconstruct tabs; we can't get it right in general, and nothing - ought to care. Some things do care; the fault lies with them. */ - if (!CPP_OPTION (pfile, traditional)) - { - const line_map_ordinary *map - = linemap_check_ordinary (linemap_lookup (line_table, src_loc)); - int spaces = SOURCE_COLUMN (map, src_loc) - 2; - print.printed = 1; - - while (-- spaces >= 0) - putc (' ', print.outf); - } -} - -static void -cb_ident (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, - const cpp_string *str) -{ - maybe_print_line (line); - fprintf (print.outf, "#ident %s\n", str->text); - print.src_line++; -} - -static void -cb_define (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, - cpp_hashnode *node ATTRIBUTE_UNUSED) -{ - maybe_print_line (line); - fputs ("#define ", print.outf); - - /* 'D' is whole definition; 'N' is name only. */ - if (gfc_cpp_option.dump_macros == 'D') - fputs ((const char *) cpp_macro_definition (pfile, node), - print.outf); - else - fputs ((const char *) NODE_NAME (node), print.outf); - - putc ('\n', print.outf); - if (LOCATION_LINE (line) != 0) - print.src_line++; -} - -static void -cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, - cpp_hashnode *node) -{ - maybe_print_line (line); - fprintf (print.outf, "#undef %s\n", NODE_NAME (node)); - print.src_line++; -} - -static void -cb_include (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, - const unsigned char *dir, const char *header, int angle_brackets, - const cpp_token **comments) -{ - maybe_print_line (line); - if (angle_brackets) - fprintf (print.outf, "#%s <%s>", dir, header); - else - fprintf (print.outf, "#%s \"%s\"", dir, header); - - if (comments != NULL) - { - while (*comments != NULL) - { - if ((*comments)->flags & PREV_WHITE) - putc (' ', print.outf); - cpp_output_token (*comments, print.outf); - ++comments; - } - } - - putc ('\n', print.outf); - print.src_line++; -} - -/* Dump out the hash table. */ -static int -dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED) -{ - if (cpp_user_macro_p (node)) - { - fputs ("#define ", print.outf); - fputs ((const char *) cpp_macro_definition (pfile, node), - print.outf); - putc ('\n', print.outf); - print.src_line++; - } - - return 1; -} - -static void -cb_used_define (cpp_reader *pfile, location_t line ATTRIBUTE_UNUSED, - cpp_hashnode *node) -{ - gfc_cpp_macro_queue *q; - q = XNEW (gfc_cpp_macro_queue); - q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node)); - q->next = cpp_define_queue; - cpp_define_queue = q; -} - -/* Return the gcc option code associated with the reason for a cpp - message, or 0 if none. */ - -static int -cb_cpp_diagnostic_cpp_option (enum cpp_warning_reason reason) -{ - const struct cpp_reason_option_codes_t *entry; - - for (entry = cpp_reason_option_codes; entry->reason != CPP_W_NONE; entry++) - if (entry->reason == reason) - return entry->option_code; - return 0; -} - - -/* Callback from cpp_error for PFILE to print diagnostics from the - preprocessor. The diagnostic is of type LEVEL, with REASON set - to the reason code if LEVEL is represents a warning, at location - RICHLOC; MSG is the translated message and AP the arguments. - Returns true if a diagnostic was emitted, false otherwise. */ - -static bool -cb_cpp_diagnostic (cpp_reader *pfile ATTRIBUTE_UNUSED, - enum cpp_diagnostic_level level, - enum cpp_warning_reason reason, - rich_location *richloc, - const char *msg, va_list *ap) -{ - diagnostic_info diagnostic; - diagnostic_t dlevel; - bool save_warn_system_headers = global_dc->dc_warn_system_headers; - bool ret; - - switch (level) - { - case CPP_DL_WARNING_SYSHDR: - global_dc->dc_warn_system_headers = 1; - /* Fall through. */ - case CPP_DL_WARNING: - dlevel = DK_WARNING; - break; - case CPP_DL_PEDWARN: - dlevel = DK_PEDWARN; - break; - case CPP_DL_ERROR: - dlevel = DK_ERROR; - break; - case CPP_DL_ICE: - dlevel = DK_ICE; - break; - case CPP_DL_NOTE: - dlevel = DK_NOTE; - break; - case CPP_DL_FATAL: - dlevel = DK_FATAL; - break; - default: - gcc_unreachable (); - } - diagnostic_set_info_translated (&diagnostic, msg, ap, - richloc, dlevel); - diagnostic_override_option_index (&diagnostic, - cb_cpp_diagnostic_cpp_option (reason)); - ret = diagnostic_report_diagnostic (global_dc, &diagnostic); - if (level == CPP_DL_WARNING_SYSHDR) - global_dc->dc_warn_system_headers = save_warn_system_headers; - return ret; -} - -/* Callback called when -fworking-director and -E to emit working - directory in cpp output file. */ - -void -pp_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir) -{ - size_t to_file_len = strlen (dir); - unsigned char *to_file_quoted = - (unsigned char *) alloca (to_file_len * 4 + 1); - unsigned char *p; - - /* cpp_quote_string does not nul-terminate, so we have to do it ourselves. */ - p = cpp_quote_string (to_file_quoted, (const unsigned char *) dir, to_file_len); - *p = '\0'; - fprintf (print.outf, "# 1 \"%s//\"\n", to_file_quoted); -} - -/* Copy a #pragma directive to the preprocessed output. */ -static void -cb_def_pragma (cpp_reader *pfile, location_t line) -{ - maybe_print_line (line); - fputs ("#pragma ", print.outf); - cpp_output_line (pfile, print.outf); - print.src_line++; -} - -static void -cb_used_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, - location_t line ATTRIBUTE_UNUSED, - cpp_hashnode *node) -{ - gfc_cpp_macro_queue *q; - q = XNEW (gfc_cpp_macro_queue); - q->macro = xstrdup ((const char *) NODE_NAME (node)); - q->next = cpp_undefine_queue; - cpp_undefine_queue = q; -} - -static void -dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED) -{ - gfc_cpp_macro_queue *q; - - /* End the previous line of text. */ - if (print.printed) - { - putc ('\n', print.outf); - print.src_line++; - print.printed = 0; - } - - for (q = cpp_define_queue; q;) - { - gfc_cpp_macro_queue *oq; - fputs ("#define ", print.outf); - fputs (q->macro, print.outf); - putc ('\n', print.outf); - print.src_line++; - oq = q; - q = q->next; - free (oq->macro); - free (oq); - } - cpp_define_queue = NULL; - for (q = cpp_undefine_queue; q;) - { - gfc_cpp_macro_queue *oq; - fprintf (print.outf, "#undef %s\n", q->macro); - print.src_line++; - oq = q; - q = q->next; - free (oq->macro); - free (oq); - } - cpp_undefine_queue = NULL; -} diff --git a/gcc/fortran/cpp.cc b/gcc/fortran/cpp.cc new file mode 100644 index 0000000..a655686 --- /dev/null +++ b/gcc/fortran/cpp.cc @@ -0,0 +1,1203 @@ +/* Copyright (C) 2008-2022 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#define GCC_C_COMMON_C +#include "options.h" /* For cpp_reason_option_codes. */ +#undef GCC_C_COMMON_C + +#include "target.h" +#include "gfortran.h" +#include "diagnostic.h" + +#include "toplev.h" + +#include "../../libcpp/internal.h" +#include "cpp.h" +#include "incpath.h" +#include "cppbuiltin.h" +#include "mkdeps.h" + +#ifndef TARGET_SYSTEM_ROOT +# define TARGET_SYSTEM_ROOT NULL +#endif + +#ifndef TARGET_CPU_CPP_BUILTINS +# define TARGET_CPU_CPP_BUILTINS() +#endif + +#ifndef TARGET_OS_CPP_BUILTINS +# define TARGET_OS_CPP_BUILTINS() +#endif + +#ifndef TARGET_OBJFMT_CPP_BUILTINS +# define TARGET_OBJFMT_CPP_BUILTINS() +#endif + + +/* Holds switches parsed by gfc_cpp_handle_option (), but whose + handling is deferred to gfc_cpp_init (). */ +typedef struct +{ + enum opt_code code; + const char *arg; +} +gfc_cpp_deferred_opt_t; + + +/* Defined and undefined macros being queued for output with -dU at + the next newline. */ +typedef struct gfc_cpp_macro_queue +{ + struct gfc_cpp_macro_queue *next; /* Next macro in the list. */ + char *macro; /* The name of the macro if not + defined, the full definition if + defined. */ +} gfc_cpp_macro_queue; +static gfc_cpp_macro_queue *cpp_define_queue, *cpp_undefine_queue; + +struct gfc_cpp_option_data +{ + /* Argument of -cpp, implied by SPEC; + if NULL, preprocessing disabled. */ + const char *temporary_filename; + + const char *output_filename; /* -o */ + int preprocess_only; /* -E */ + int discard_comments; /* -C */ + int discard_comments_in_macro_exp; /* -CC */ + int print_include_names; /* -H */ + int no_line_commands; /* -P */ + char dump_macros; /* -d[DMNU] */ + int dump_includes; /* -dI */ + int working_directory; /* -fworking-directory */ + int no_predefined; /* -undef */ + int standard_include_paths; /* -nostdinc */ + int verbose; /* -v */ + int deps; /* -M */ + int deps_skip_system; /* -MM */ + const char *deps_filename; /* -M[M]D */ + const char *deps_filename_user; /* -MF */ + int deps_missing_are_generated; /* -MG */ + int deps_phony; /* -MP */ + int warn_date_time; /* -Wdate-time */ + + const char *multilib; /* -imultilib */ + const char *prefix; /* -iprefix */ + const char *sysroot; /* -isysroot */ + + /* Options whose handling needs to be deferred until the + appropriate cpp-objects are created: + -A predicate=answer + -D [=] + -U */ + gfc_cpp_deferred_opt_t *deferred_opt; + int deferred_opt_count; +} +gfc_cpp_option; + +/* Structures used with libcpp: */ +static cpp_options *cpp_option = NULL; +static cpp_reader *cpp_in = NULL; + +/* Encapsulates state used to convert a stream of cpp-tokens into + a text file. */ +static struct +{ + FILE *outf; /* Stream to write to. */ + const cpp_token *prev; /* Previous token. */ + const cpp_token *source; /* Source token for spacing. */ + int src_line; /* Line number currently being written. */ + unsigned char printed; /* Nonzero if something output at line. */ + bool first_time; /* cb_file_change hasn't been called yet. */ +} print; + +/* General output routines. */ +static void scan_translation_unit (cpp_reader *); +static void scan_translation_unit_trad (cpp_reader *); + +/* Callback routines for the parser. Most of these are active only + in specific modes. */ +static void cb_file_change (cpp_reader *, const line_map_ordinary *); +static void cb_line_change (cpp_reader *, const cpp_token *, int); +static void cb_define (cpp_reader *, location_t, cpp_hashnode *); +static void cb_undef (cpp_reader *, location_t, cpp_hashnode *); +static void cb_def_pragma (cpp_reader *, location_t); +static void cb_include (cpp_reader *, location_t, const unsigned char *, + const char *, int, const cpp_token **); +static void cb_ident (cpp_reader *, location_t, const cpp_string *); +static void cb_used_define (cpp_reader *, location_t, cpp_hashnode *); +static void cb_used_undef (cpp_reader *, location_t, cpp_hashnode *); +static bool cb_cpp_diagnostic (cpp_reader *, enum cpp_diagnostic_level, + enum cpp_warning_reason, rich_location *, + const char *, va_list *) + ATTRIBUTE_GCC_DIAG(5,0); +void pp_dir_change (cpp_reader *, const char *); + +static int dump_macro (cpp_reader *, cpp_hashnode *, void *); +static void dump_queued_macros (cpp_reader *); + + +static void +cpp_define_builtins (cpp_reader *pfile) +{ + /* Initialize CPP built-ins; '1' corresponds to 'flag_hosted' + in C, defines __STDC_HOSTED__?! */ + cpp_init_builtins (pfile, 0); + + /* Initialize GFORTRAN specific builtins. + These are documented. */ + define_language_independent_builtin_macros (pfile); + cpp_define (pfile, "__GFORTRAN__=1"); + cpp_define (pfile, "_LANGUAGE_FORTRAN=1"); + + if (flag_openacc) + cpp_define (pfile, "_OPENACC=201711"); + + if (flag_openmp) + cpp_define (pfile, "_OPENMP=201511"); + + /* The defines below are necessary for the TARGET_* macros. + + FIXME: Note that builtin_define_std() actually is a function + in c-cppbuiltin.c which uses flags undefined for Fortran. + Let's skip this for now. If needed, one needs to look into it + once more. */ + +# define builtin_define(TXT) cpp_define (pfile, TXT) +# define builtin_define_std(TXT) +# define builtin_assert(TXT) cpp_assert (pfile, TXT) + + /* FIXME: Pandora's Box + Using the macros below results in multiple breakages: + - mingw will fail to compile this file as dependent macros + assume to be used in c-cppbuiltin.c only. Further, they use + flags only valid/defined in C (same as noted above). + [config/i386/mingw32.h, config/i386/cygming.h] + - other platforms (not as popular) break similarly + [grep for 'builtin_define_with_int_value' in gcc/config/] + + TARGET_CPU_CPP_BUILTINS (); + TARGET_OS_CPP_BUILTINS (); + TARGET_OBJFMT_CPP_BUILTINS (); */ + +#undef builtin_define +#undef builtin_define_std +#undef builtin_assert +} + +bool +gfc_cpp_enabled (void) +{ + return gfc_cpp_option.temporary_filename != NULL; +} + +bool +gfc_cpp_preprocess_only (void) +{ + return gfc_cpp_option.preprocess_only; +} + +bool +gfc_cpp_makedep (void) +{ + return gfc_cpp_option.deps; +} + +void +gfc_cpp_add_dep (const char *name, bool system) +{ + if (!gfc_cpp_option.deps_skip_system || !system) + if (mkdeps *deps = cpp_get_deps (cpp_in)) + deps_add_dep (deps, name); +} + +void +gfc_cpp_add_target (const char *name) +{ + if (mkdeps *deps = cpp_get_deps (cpp_in)) + deps_add_target (deps, name, 0); +} + + +const char * +gfc_cpp_temporary_file (void) +{ + return gfc_cpp_option.temporary_filename; +} + +static void +gfc_cpp_register_include_paths (bool verbose_missing_dir_warn) +{ + int cxx_stdinc = 0; + cpp_get_options (cpp_in)->warn_missing_include_dirs + = (global_options.x_cpp_warn_missing_include_dirs + && verbose_missing_dir_warn); + register_include_chains (cpp_in, gfc_cpp_option.sysroot, + gfc_cpp_option.prefix, gfc_cpp_option.multilib, + gfc_cpp_option.standard_include_paths, cxx_stdinc, + gfc_cpp_option.verbose); +} + +void +gfc_cpp_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options ATTRIBUTE_UNUSED) +{ + /* Do not create any objects from libcpp here. If no + preprocessing is requested, this would be wasted + time and effort. + + See gfc_cpp_post_options() instead. */ + + gfc_cpp_option.temporary_filename = NULL; + gfc_cpp_option.output_filename = NULL; + gfc_cpp_option.preprocess_only = 0; + gfc_cpp_option.discard_comments = 1; + gfc_cpp_option.discard_comments_in_macro_exp = 1; + gfc_cpp_option.print_include_names = 0; + gfc_cpp_option.no_line_commands = 0; + gfc_cpp_option.dump_macros = '\0'; + gfc_cpp_option.dump_includes = 0; + gfc_cpp_option.working_directory = -1; + gfc_cpp_option.no_predefined = 0; + gfc_cpp_option.standard_include_paths = 1; + gfc_cpp_option.verbose = 0; + gfc_cpp_option.warn_date_time = 0; + gfc_cpp_option.deps = 0; + gfc_cpp_option.deps_skip_system = 0; + gfc_cpp_option.deps_phony = 0; + gfc_cpp_option.deps_missing_are_generated = 0; + gfc_cpp_option.deps_filename = NULL; + gfc_cpp_option.deps_filename_user = NULL; + + gfc_cpp_option.multilib = NULL; + gfc_cpp_option.prefix = NULL; + gfc_cpp_option.sysroot = TARGET_SYSTEM_ROOT; + + gfc_cpp_option.deferred_opt = XNEWVEC (gfc_cpp_deferred_opt_t, + decoded_options_count); + gfc_cpp_option.deferred_opt_count = 0; +} + +int +gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED) +{ + int result = 1; + enum opt_code code = (enum opt_code) scode; + + switch (code) + { + default: + result = 0; + break; + + case OPT_cpp_: + gfc_cpp_option.temporary_filename = arg; + break; + + case OPT_nocpp: + gfc_cpp_option.temporary_filename = 0L; + break; + + case OPT_d: + for ( ; *arg; ++arg) + switch (*arg) + { + case 'D': + case 'M': + case 'N': + case 'U': + gfc_cpp_option.dump_macros = *arg; + break; + + case 'I': + gfc_cpp_option.dump_includes = 1; + break; + } + break; + + case OPT_fworking_directory: + gfc_cpp_option.working_directory = value; + break; + + case OPT_idirafter: + gfc_cpp_add_include_path_after (xstrdup(arg), true); + break; + + case OPT_imultilib: + gfc_cpp_option.multilib = arg; + break; + + case OPT_iprefix: + gfc_cpp_option.prefix = arg; + break; + + case OPT_isysroot: + gfc_cpp_option.sysroot = arg; + break; + + case OPT_iquote: + case OPT_isystem: + gfc_cpp_add_include_path (xstrdup(arg), true); + break; + + case OPT_nostdinc: + gfc_cpp_option.standard_include_paths = value; + break; + + case OPT_o: + if (!gfc_cpp_option.output_filename) + gfc_cpp_option.output_filename = arg; + else + gfc_fatal_error ("output filename specified twice"); + break; + + case OPT_undef: + gfc_cpp_option.no_predefined = value; + break; + + case OPT_v: + gfc_cpp_option.verbose = value; + break; + + case OPT_Wdate_time: + gfc_cpp_option.warn_date_time = value; + break; + + case OPT_A: + case OPT_D: + case OPT_U: + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; + gfc_cpp_option.deferred_opt_count++; + break; + + case OPT_C: + gfc_cpp_option.discard_comments = 0; + break; + + case OPT_CC: + gfc_cpp_option.discard_comments = 0; + gfc_cpp_option.discard_comments_in_macro_exp = 0; + break; + + case OPT_E: + gfc_cpp_option.preprocess_only = 1; + break; + + case OPT_H: + gfc_cpp_option.print_include_names = 1; + break; + + case OPT_MM: + gfc_cpp_option.deps_skip_system = 1; + /* fall through */ + + case OPT_M: + gfc_cpp_option.deps = 1; + break; + + case OPT_MMD: + gfc_cpp_option.deps_skip_system = 1; + /* fall through */ + + case OPT_MD: + gfc_cpp_option.deps = 1; + gfc_cpp_option.deps_filename = arg; + break; + + case OPT_MF: + /* If specified multiple times, last one wins. */ + gfc_cpp_option.deps_filename_user = arg; + break; + + case OPT_MG: + gfc_cpp_option.deps_missing_are_generated = 1; + break; + + case OPT_MP: + gfc_cpp_option.deps_phony = 1; + break; + + case OPT_MQ: + case OPT_MT: + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].code = code; + gfc_cpp_option.deferred_opt[gfc_cpp_option.deferred_opt_count].arg = arg; + gfc_cpp_option.deferred_opt_count++; + break; + + case OPT_P: + gfc_cpp_option.no_line_commands = 1; + break; + } + + return result; +} + +/* This function needs to be called before gfc_cpp_register_include_paths + as the latter may diagnose missing include directories. */ +static void +gfc_cpp_init_cb (void) +{ + struct cpp_callbacks *cb; + + cb = cpp_get_callbacks (cpp_in); + cb->file_change = cb_file_change; + cb->line_change = cb_line_change; + cb->ident = cb_ident; + cb->def_pragma = cb_def_pragma; + cb->diagnostic = cb_cpp_diagnostic; + + if (gfc_cpp_option.dump_includes) + cb->include = cb_include; + + if ((gfc_cpp_option.dump_macros == 'D') + || (gfc_cpp_option.dump_macros == 'N')) + { + cb->define = cb_define; + cb->undef = cb_undef; + } + + if (gfc_cpp_option.dump_macros == 'U') + { + cb->before_define = dump_queued_macros; + cb->used_define = cb_used_define; + cb->used_undef = cb_used_undef; + } +} + +void +gfc_cpp_post_options (bool verbose_missing_dir_warn) +{ + /* Any preprocessing-related option without '-cpp' is considered + an error. */ + if (!gfc_cpp_enabled () + && (gfc_cpp_preprocess_only () + || gfc_cpp_makedep () + || !gfc_cpp_option.discard_comments + || !gfc_cpp_option.discard_comments_in_macro_exp + || gfc_cpp_option.print_include_names + || gfc_cpp_option.no_line_commands + || gfc_cpp_option.dump_macros + || gfc_cpp_option.dump_includes)) + gfc_fatal_error ("To enable preprocessing, use %<-cpp%>"); + + if (!gfc_cpp_enabled ()) + return; + + cpp_in = cpp_create_reader (CLK_GNUC89, NULL, line_table); + gcc_assert (cpp_in); + + /* The cpp_options-structure defines far more flags than those set here. + If any other is implemented, see c-opt.c (sanitize_cpp_opts) for + inter-option dependencies that may need to be enforced. */ + cpp_option = cpp_get_options (cpp_in); + gcc_assert (cpp_option); + + /* TODO: allow non-traditional modes, e.g. by -cpp-std=...? */ + cpp_option->traditional = 1; + cpp_option->cplusplus_comments = 0; + + cpp_option->cpp_pedantic = pedantic; + + cpp_option->dollars_in_ident = flag_dollar_ok; + cpp_option->discard_comments = gfc_cpp_option.discard_comments; + cpp_option->discard_comments_in_macro_exp = gfc_cpp_option.discard_comments_in_macro_exp; + cpp_option->print_include_names = gfc_cpp_option.print_include_names; + cpp_option->preprocessed = gfc_option.flag_preprocessed; + cpp_option->warn_date_time = gfc_cpp_option.warn_date_time; + + if (gfc_cpp_makedep ()) + { + cpp_option->deps.style = DEPS_USER; + cpp_option->deps.phony_targets = gfc_cpp_option.deps_phony; + cpp_option->deps.missing_files = gfc_cpp_option.deps_missing_are_generated; + + /* -MF overrides -M[M]D. */ + if (gfc_cpp_option.deps_filename_user) + gfc_cpp_option.deps_filename = gfc_cpp_option.deps_filename_user; + } + + if (gfc_cpp_option.working_directory == -1) + gfc_cpp_option.working_directory = (debug_info_level != DINFO_LEVEL_NONE); + + cpp_post_options (cpp_in); + + + /* Let diagnostics infrastructure know how to convert input files the same + way libcpp will do it, namely, with no charset conversion but with + skipping of a UTF-8 BOM if present. */ + diagnostic_initialize_input_context (global_dc, nullptr, true); + gfc_cpp_init_cb (); + + gfc_cpp_register_include_paths (verbose_missing_dir_warn); +} + + +void +gfc_cpp_init_0 (void) +{ + /* Initialize the print structure. Setting print.src_line to -1 here is + a trick to guarantee that the first token of the file will cause + a linemarker to be output by maybe_print_line. */ + print.src_line = -1; + print.printed = 0; + print.prev = 0; + print.first_time = 1; + + if (gfc_cpp_preprocess_only ()) + { + if (gfc_cpp_option.output_filename) + { + /* This needs cheating: with "-E -o ", the user wants the + preprocessed output in . However, if nothing is done + about it is also used for assembler output. Hence, it + is necessary to redirect assembler output (actually nothing + as -E implies -fsyntax-only) to another file, otherwise the + output from preprocessing is lost. */ + asm_file_name = gfc_cpp_option.temporary_filename; + + print.outf = fopen (gfc_cpp_option.output_filename, "w"); + if (print.outf == NULL) + gfc_fatal_error ("opening output file %qs: %s", + gfc_cpp_option.output_filename, + xstrerror (errno)); + } + else + print.outf = stdout; + } + else + { + print.outf = fopen (gfc_cpp_option.temporary_filename, "w"); + if (print.outf == NULL) + gfc_fatal_error ("opening output file %qs: %s", + gfc_cpp_option.temporary_filename, xstrerror (errno)); + } + + gcc_assert(cpp_in); + if (!cpp_read_main_file (cpp_in, gfc_source_file)) + errorcount++; +} + +void +gfc_cpp_init (void) +{ + int i; + + if (gfc_option.flag_preprocessed) + return; + + cpp_change_file (cpp_in, LC_RENAME, _("")); + if (!gfc_cpp_option.no_predefined) + { + /* Make sure all of the builtins about to be declared have + BUILTINS_LOCATION has their location_t. */ + cpp_force_token_locations (cpp_in, BUILTINS_LOCATION); + + cpp_define_builtins (cpp_in); + + cpp_stop_forcing_token_locations (cpp_in); + } + + /* Handle deferred options from command-line. */ + cpp_change_file (cpp_in, LC_RENAME, _("")); + + for (i = 0; i < gfc_cpp_option.deferred_opt_count; i++) + { + gfc_cpp_deferred_opt_t *opt = &gfc_cpp_option.deferred_opt[i]; + + if (opt->code == OPT_D) + cpp_define (cpp_in, opt->arg); + else if (opt->code == OPT_U) + cpp_undef (cpp_in, opt->arg); + else if (opt->code == OPT_A) + { + if (opt->arg[0] == '-') + cpp_unassert (cpp_in, opt->arg + 1); + else + cpp_assert (cpp_in, opt->arg); + } + else if (opt->code == OPT_MT || opt->code == OPT_MQ) + if (mkdeps *deps = cpp_get_deps (cpp_in)) + deps_add_target (deps, opt->arg, opt->code == OPT_MQ); + } + + /* Pre-defined macros for non-required INTEGER kind types. */ + for (gfc_integer_info *itype = gfc_integer_kinds; itype->kind != 0; itype++) + { + if (itype->kind == 1) + cpp_define (cpp_in, "__GFC_INT_1__=1"); + if (itype->kind == 2) + cpp_define (cpp_in, "__GFC_INT_2__=1"); + if (itype->kind == 8) + cpp_define (cpp_in, "__GFC_INT_8__=1"); + if (itype->kind == 16) + cpp_define (cpp_in, "__GFC_INT_16__=1"); + } + + /* Pre-defined macros for non-required REAL kind types. */ + for (gfc_real_info *rtype = gfc_real_kinds; rtype->kind != 0; rtype++) + { + if (rtype->kind == 10) + cpp_define (cpp_in, "__GFC_REAL_10__=1"); + if (rtype->kind == 16) + cpp_define (cpp_in, "__GFC_REAL_16__=1"); + } + + if (gfc_cpp_option.working_directory + && gfc_cpp_option.preprocess_only && !gfc_cpp_option.no_line_commands) + pp_dir_change (cpp_in, get_src_pwd ()); +} + +bool +gfc_cpp_preprocess (const char *source_file) +{ + if (!gfc_cpp_enabled ()) + return false; + + cpp_change_file (cpp_in, LC_RENAME, source_file); + + if (cpp_option->traditional) + scan_translation_unit_trad (cpp_in); + else + scan_translation_unit (cpp_in); + + /* -dM command line option. */ + if (gfc_cpp_preprocess_only () && + gfc_cpp_option.dump_macros == 'M') + { + putc ('\n', print.outf); + cpp_forall_identifiers (cpp_in, dump_macro, NULL); + } + + putc ('\n', print.outf); + + if (!gfc_cpp_preprocess_only () + || (gfc_cpp_preprocess_only () && gfc_cpp_option.output_filename)) + fclose (print.outf); + + return true; +} + +void +gfc_cpp_done (void) +{ + if (!gfc_cpp_enabled ()) + return; + + gcc_assert (cpp_in); + + if (gfc_cpp_makedep ()) + { + if (gfc_cpp_option.deps_filename) + { + FILE *f = fopen (gfc_cpp_option.deps_filename, "w"); + if (f) + { + cpp_finish (cpp_in, f); + fclose (f); + } + else + gfc_fatal_error ("opening output file %qs: %s", + gfc_cpp_option.deps_filename, + xstrerror (errno)); + } + else + cpp_finish (cpp_in, stdout); + } + + cpp_undef_all (cpp_in); + cpp_clear_file_cache (cpp_in); +} + +/* PATH must be malloc-ed and NULL-terminated. */ +void +gfc_cpp_add_include_path (char *path, bool user_supplied) +{ + /* CHAIN sets cpp_dir->sysp which differs from 0 if PATH is a system + include path. Fortran does not define any system include paths. */ + int cxx_aware = 0; + + add_path (path, INC_BRACKET, cxx_aware, user_supplied); +} + +void +gfc_cpp_add_include_path_after (char *path, bool user_supplied) +{ + int cxx_aware = 0; + add_path (path, INC_AFTER, cxx_aware, user_supplied); +} + + +static void scan_translation_unit_trad (cpp_reader *); +static void account_for_newlines (const unsigned char *, size_t); +static int dump_macro (cpp_reader *, cpp_hashnode *, void *); + +static void print_line (location_t, const char *); +static void maybe_print_line (location_t); + + +/* Writes out the preprocessed file, handling spacing and paste + avoidance issues. */ +static void +scan_translation_unit (cpp_reader *pfile) +{ + bool avoid_paste = false; + + print.source = NULL; + for (;;) + { + const cpp_token *token = cpp_get_token (pfile); + + if (token->type == CPP_PADDING) + { + avoid_paste = true; + if (print.source == NULL + || (!(print.source->flags & PREV_WHITE) + && token->val.source == NULL)) + print.source = token->val.source; + continue; + } + + if (token->type == CPP_EOF) + break; + + /* Subtle logic to output a space if and only if necessary. */ + if (avoid_paste) + { + if (print.source == NULL) + print.source = token; + if (print.source->flags & PREV_WHITE + || (print.prev + && cpp_avoid_paste (pfile, print.prev, token)) + || (print.prev == NULL && token->type == CPP_HASH)) + putc (' ', print.outf); + } + else if (token->flags & PREV_WHITE) + putc (' ', print.outf); + + avoid_paste = false; + print.source = NULL; + print.prev = token; + cpp_output_token (token, print.outf); + + if (token->type == CPP_COMMENT) + account_for_newlines (token->val.str.text, token->val.str.len); + } +} + +/* Adjust print.src_line for newlines embedded in output. */ +static void +account_for_newlines (const unsigned char *str, size_t len) +{ + while (len--) + if (*str++ == '\n') + print.src_line++; +} + +/* Writes out a traditionally preprocessed file. */ +static void +scan_translation_unit_trad (cpp_reader *pfile) +{ + while (_cpp_read_logical_line_trad (pfile)) + { + size_t len = pfile->out.cur - pfile->out.base; + maybe_print_line (pfile->out.first_line); + fwrite (pfile->out.base, 1, len, print.outf); + print.printed = 1; + if (!CPP_OPTION (pfile, discard_comments)) + account_for_newlines (pfile->out.base, len); + } +} + +/* If the token read on logical line LINE needs to be output on a + different line to the current one, output the required newlines or + a line marker. */ +static void +maybe_print_line (location_t src_loc) +{ + const line_map_ordinary *map + = linemap_check_ordinary (linemap_lookup (line_table, src_loc)); + int src_line = SOURCE_LINE (map, src_loc); + + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + if (src_line >= print.src_line && src_line < print.src_line + 8) + { + while (src_line > print.src_line) + { + putc ('\n', print.outf); + print.src_line++; + } + } + else + print_line (src_loc, ""); +} + +/* Output a line marker for logical line LINE. Special flags are "1" + or "2" indicating entering or leaving a file. */ +static void +print_line (location_t src_loc, const char *special_flags) +{ + /* End any previous line of text. */ + if (print.printed) + putc ('\n', print.outf); + print.printed = 0; + + if (!gfc_cpp_option.no_line_commands) + { + expanded_location loc; + size_t to_file_len; + unsigned char *to_file_quoted; + unsigned char *p; + int sysp; + + loc = expand_location (src_loc); + to_file_len = strlen (loc.file); + to_file_quoted = (unsigned char *) alloca (to_file_len * 4 + 1); + + print.src_line = loc.line; + + /* cpp_quote_string does not nul-terminate, so we have to do it + ourselves. */ + p = cpp_quote_string (to_file_quoted, + (const unsigned char *) loc.file, to_file_len); + *p = '\0'; + fprintf (print.outf, "# %u \"%s\"%s", + print.src_line == 0 ? 1 : print.src_line, + to_file_quoted, special_flags); + + sysp = in_system_header_at (src_loc); + if (sysp == 2) + fputs (" 3 4", print.outf); + else if (sysp == 1) + fputs (" 3", print.outf); + + putc ('\n', print.outf); + } +} + +static void +cb_file_change (cpp_reader * ARG_UNUSED (pfile), const line_map_ordinary *map) +{ + const char *flags = ""; + + if (gfc_cpp_option.no_line_commands) + return; + + if (!map) + return; + + if (print.first_time) + { + /* Avoid printing foo.i when the main file is foo.c. */ + if (!cpp_get_options (cpp_in)->preprocessed) + print_line (map->start_location, flags); + print.first_time = 0; + } + else + { + /* Bring current file to correct line when entering a new file. */ + if (map->reason == LC_ENTER) + maybe_print_line (linemap_included_from (map)); + if (map->reason == LC_ENTER) + flags = " 1"; + else if (map->reason == LC_LEAVE) + flags = " 2"; + print_line (map->start_location, flags); + } + +} + +/* Called when a line of output is started. TOKEN is the first token + of the line, and at end of file will be CPP_EOF. */ +static void +cb_line_change (cpp_reader *pfile, const cpp_token *token, + int parsing_args) +{ + location_t src_loc = token->src_loc; + + if (token->type == CPP_EOF || parsing_args) + return; + + maybe_print_line (src_loc); + print.prev = 0; + print.source = 0; + + /* Supply enough spaces to put this token in its original column, + one space per column greater than 2, since scan_translation_unit + will provide a space if PREV_WHITE. Don't bother trying to + reconstruct tabs; we can't get it right in general, and nothing + ought to care. Some things do care; the fault lies with them. */ + if (!CPP_OPTION (pfile, traditional)) + { + const line_map_ordinary *map + = linemap_check_ordinary (linemap_lookup (line_table, src_loc)); + int spaces = SOURCE_COLUMN (map, src_loc) - 2; + print.printed = 1; + + while (-- spaces >= 0) + putc (' ', print.outf); + } +} + +static void +cb_ident (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, + const cpp_string *str) +{ + maybe_print_line (line); + fprintf (print.outf, "#ident %s\n", str->text); + print.src_line++; +} + +static void +cb_define (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, + cpp_hashnode *node ATTRIBUTE_UNUSED) +{ + maybe_print_line (line); + fputs ("#define ", print.outf); + + /* 'D' is whole definition; 'N' is name only. */ + if (gfc_cpp_option.dump_macros == 'D') + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + else + fputs ((const char *) NODE_NAME (node), print.outf); + + putc ('\n', print.outf); + if (LOCATION_LINE (line) != 0) + print.src_line++; +} + +static void +cb_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, + cpp_hashnode *node) +{ + maybe_print_line (line); + fprintf (print.outf, "#undef %s\n", NODE_NAME (node)); + print.src_line++; +} + +static void +cb_include (cpp_reader *pfile ATTRIBUTE_UNUSED, location_t line, + const unsigned char *dir, const char *header, int angle_brackets, + const cpp_token **comments) +{ + maybe_print_line (line); + if (angle_brackets) + fprintf (print.outf, "#%s <%s>", dir, header); + else + fprintf (print.outf, "#%s \"%s\"", dir, header); + + if (comments != NULL) + { + while (*comments != NULL) + { + if ((*comments)->flags & PREV_WHITE) + putc (' ', print.outf); + cpp_output_token (*comments, print.outf); + ++comments; + } + } + + putc ('\n', print.outf); + print.src_line++; +} + +/* Dump out the hash table. */ +static int +dump_macro (cpp_reader *pfile, cpp_hashnode *node, void *v ATTRIBUTE_UNUSED) +{ + if (cpp_user_macro_p (node)) + { + fputs ("#define ", print.outf); + fputs ((const char *) cpp_macro_definition (pfile, node), + print.outf); + putc ('\n', print.outf); + print.src_line++; + } + + return 1; +} + +static void +cb_used_define (cpp_reader *pfile, location_t line ATTRIBUTE_UNUSED, + cpp_hashnode *node) +{ + gfc_cpp_macro_queue *q; + q = XNEW (gfc_cpp_macro_queue); + q->macro = xstrdup ((const char *) cpp_macro_definition (pfile, node)); + q->next = cpp_define_queue; + cpp_define_queue = q; +} + +/* Return the gcc option code associated with the reason for a cpp + message, or 0 if none. */ + +static int +cb_cpp_diagnostic_cpp_option (enum cpp_warning_reason reason) +{ + const struct cpp_reason_option_codes_t *entry; + + for (entry = cpp_reason_option_codes; entry->reason != CPP_W_NONE; entry++) + if (entry->reason == reason) + return entry->option_code; + return 0; +} + + +/* Callback from cpp_error for PFILE to print diagnostics from the + preprocessor. The diagnostic is of type LEVEL, with REASON set + to the reason code if LEVEL is represents a warning, at location + RICHLOC; MSG is the translated message and AP the arguments. + Returns true if a diagnostic was emitted, false otherwise. */ + +static bool +cb_cpp_diagnostic (cpp_reader *pfile ATTRIBUTE_UNUSED, + enum cpp_diagnostic_level level, + enum cpp_warning_reason reason, + rich_location *richloc, + const char *msg, va_list *ap) +{ + diagnostic_info diagnostic; + diagnostic_t dlevel; + bool save_warn_system_headers = global_dc->dc_warn_system_headers; + bool ret; + + switch (level) + { + case CPP_DL_WARNING_SYSHDR: + global_dc->dc_warn_system_headers = 1; + /* Fall through. */ + case CPP_DL_WARNING: + dlevel = DK_WARNING; + break; + case CPP_DL_PEDWARN: + dlevel = DK_PEDWARN; + break; + case CPP_DL_ERROR: + dlevel = DK_ERROR; + break; + case CPP_DL_ICE: + dlevel = DK_ICE; + break; + case CPP_DL_NOTE: + dlevel = DK_NOTE; + break; + case CPP_DL_FATAL: + dlevel = DK_FATAL; + break; + default: + gcc_unreachable (); + } + diagnostic_set_info_translated (&diagnostic, msg, ap, + richloc, dlevel); + diagnostic_override_option_index (&diagnostic, + cb_cpp_diagnostic_cpp_option (reason)); + ret = diagnostic_report_diagnostic (global_dc, &diagnostic); + if (level == CPP_DL_WARNING_SYSHDR) + global_dc->dc_warn_system_headers = save_warn_system_headers; + return ret; +} + +/* Callback called when -fworking-director and -E to emit working + directory in cpp output file. */ + +void +pp_dir_change (cpp_reader *pfile ATTRIBUTE_UNUSED, const char *dir) +{ + size_t to_file_len = strlen (dir); + unsigned char *to_file_quoted = + (unsigned char *) alloca (to_file_len * 4 + 1); + unsigned char *p; + + /* cpp_quote_string does not nul-terminate, so we have to do it ourselves. */ + p = cpp_quote_string (to_file_quoted, (const unsigned char *) dir, to_file_len); + *p = '\0'; + fprintf (print.outf, "# 1 \"%s//\"\n", to_file_quoted); +} + +/* Copy a #pragma directive to the preprocessed output. */ +static void +cb_def_pragma (cpp_reader *pfile, location_t line) +{ + maybe_print_line (line); + fputs ("#pragma ", print.outf); + cpp_output_line (pfile, print.outf); + print.src_line++; +} + +static void +cb_used_undef (cpp_reader *pfile ATTRIBUTE_UNUSED, + location_t line ATTRIBUTE_UNUSED, + cpp_hashnode *node) +{ + gfc_cpp_macro_queue *q; + q = XNEW (gfc_cpp_macro_queue); + q->macro = xstrdup ((const char *) NODE_NAME (node)); + q->next = cpp_undefine_queue; + cpp_undefine_queue = q; +} + +static void +dump_queued_macros (cpp_reader *pfile ATTRIBUTE_UNUSED) +{ + gfc_cpp_macro_queue *q; + + /* End the previous line of text. */ + if (print.printed) + { + putc ('\n', print.outf); + print.src_line++; + print.printed = 0; + } + + for (q = cpp_define_queue; q;) + { + gfc_cpp_macro_queue *oq; + fputs ("#define ", print.outf); + fputs (q->macro, print.outf); + putc ('\n', print.outf); + print.src_line++; + oq = q; + q = q->next; + free (oq->macro); + free (oq); + } + cpp_define_queue = NULL; + for (q = cpp_undefine_queue; q;) + { + gfc_cpp_macro_queue *oq; + fprintf (print.outf, "#undef %s\n", q->macro); + print.src_line++; + oq = q; + q = q->next; + free (oq->macro); + free (oq); + } + cpp_undefine_queue = NULL; +} diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c deleted file mode 100644 index 839e042..0000000 --- a/gcc/fortran/data.c +++ /dev/null @@ -1,848 +0,0 @@ -/* Supporting functions for resolving DATA statement. - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Lifang Zeng - -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 -. */ - - -/* Notes for DATA statement implementation: - - We first assign initial value to each symbol by gfc_assign_data_value - during resolving DATA statement. Refer to check_data_variable and - traverse_data_list in resolve.c. - - The complexity exists in the handling of array section, implied do - and array of struct appeared in DATA statement. - - We call gfc_conv_structure, gfc_con_array_array_initializer, - etc., to convert the initial value. Refer to trans-expr.c and - trans-array.c. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "data.h" -#include "constructor.h" - -static void formalize_init_expr (gfc_expr *); - -/* Calculate the array element offset. */ - -static void -get_array_index (gfc_array_ref *ar, mpz_t *offset) -{ - gfc_expr *e; - int i; - mpz_t delta; - mpz_t tmp; - - mpz_init (tmp); - mpz_set_si (*offset, 0); - mpz_init_set_si (delta, 1); - for (i = 0; i < ar->dimen; i++) - { - e = gfc_copy_expr (ar->start[i]); - gfc_simplify_expr (e, 1); - - if ((gfc_is_constant_expr (ar->as->lower[i]) == 0) - || (gfc_is_constant_expr (ar->as->upper[i]) == 0) - || (gfc_is_constant_expr (e) == 0)) - gfc_error ("non-constant array in DATA statement %L", &ar->where); - - mpz_set (tmp, e->value.integer); - gfc_free_expr (e); - mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); - mpz_mul (tmp, tmp, delta); - mpz_add (*offset, tmp, *offset); - - mpz_sub (tmp, ar->as->upper[i]->value.integer, - ar->as->lower[i]->value.integer); - mpz_add_ui (tmp, tmp, 1); - mpz_mul (delta, tmp, delta); - } - mpz_clear (delta); - mpz_clear (tmp); -} - -/* Find if there is a constructor which component is equal to COM. - TODO: remove this, use symbol.c(gfc_find_component) instead. */ - -static gfc_constructor * -find_con_by_component (gfc_component *com, gfc_constructor_base base) -{ - gfc_constructor *c; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - if (com == c->n.component) - return c; - - return NULL; -} - - -/* Create a character type initialization expression from RVALUE. - TS [and REF] describe [the substring of] the variable being initialized. - INIT is the existing initializer, not NULL. Initialization is performed - according to normal assignment rules. */ - -static gfc_expr * -create_character_initializer (gfc_expr *init, gfc_typespec *ts, - gfc_ref *ref, gfc_expr *rvalue) -{ - HOST_WIDE_INT len, start, end, tlen; - gfc_char_t *dest; - bool alloced_init = false; - - if (init && init->ts.type != BT_CHARACTER) - return NULL; - - gfc_extract_hwi (ts->u.cl->length, &len); - - if (init == NULL) - { - /* Create a new initializer. */ - init = gfc_get_character_expr (ts->kind, NULL, NULL, len); - init->ts = *ts; - alloced_init = true; - } - - dest = init->value.character.string; - - if (ref) - { - gfc_expr *start_expr, *end_expr; - - gcc_assert (ref->type == REF_SUBSTRING); - - /* Only set a substring of the destination. Fortran substring bounds - are one-based [start, end], we want zero based [start, end). */ - start_expr = gfc_copy_expr (ref->u.ss.start); - end_expr = gfc_copy_expr (ref->u.ss.end); - - if ((!gfc_simplify_expr(start_expr, 1)) - || !(gfc_simplify_expr(end_expr, 1))) - { - gfc_error ("failure to simplify substring reference in DATA " - "statement at %L", &ref->u.ss.start->where); - gfc_free_expr (start_expr); - gfc_free_expr (end_expr); - if (alloced_init) - gfc_free_expr (init); - return NULL; - } - - gfc_extract_hwi (start_expr, &start); - gfc_free_expr (start_expr); - start--; - gfc_extract_hwi (end_expr, &end); - gfc_free_expr (end_expr); - } - else - { - /* Set the whole string. */ - start = 0; - end = len; - } - - /* Copy the initial value. */ - if (rvalue->ts.type == BT_HOLLERITH) - len = rvalue->representation.length - rvalue->ts.u.pad; - else - len = rvalue->value.character.length; - - tlen = end - start; - if (len > tlen) - { - if (tlen < 0) - { - gfc_warning_now (0, "Unused initialization string at %L because " - "variable has zero length", &rvalue->where); - len = 0; - } - else - { - gfc_warning_now (0, "Initialization string at %L was truncated to " - "fit the variable (%ld/%ld)", &rvalue->where, - (long) tlen, (long) len); - len = tlen; - } - } - - if (start < 0) - { - gfc_error ("Substring start index at %L is less than one", - &ref->u.ss.start->where); - return NULL; - } - if (end > init->value.character.length) - { - gfc_error ("Substring end index at %L exceeds the string length", - &ref->u.ss.end->where); - return NULL; - } - - if (rvalue->ts.type == BT_HOLLERITH) - { - for (size_t i = 0; i < (size_t) len; i++) - dest[start+i] = rvalue->representation.string[i]; - } - else - memcpy (&dest[start], rvalue->value.character.string, - len * sizeof (gfc_char_t)); - - /* Pad with spaces. Substrings will already be blanked. */ - if (len < tlen && ref == NULL) - gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); - - if (rvalue->ts.type == BT_HOLLERITH) - { - init->representation.length = init->value.character.length; - init->representation.string - = gfc_widechar_to_char (init->value.character.string, - init->value.character.length); - } - - return init; -} - - -/* Assign the initial value RVALUE to LVALUE's symbol->value. If the - LVALUE already has an initialization, we extend this, otherwise we - create a new one. If REPEAT is non-NULL, initialize *REPEAT - consecutive values in LVALUE the same value in RVALUE. In that case, - LVALUE must refer to a full array, not an array section. */ - -bool -gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, - mpz_t *repeat) -{ - gfc_ref *ref; - gfc_expr *init; - gfc_expr *expr = NULL; - gfc_expr *rexpr; - gfc_constructor *con; - gfc_constructor *last_con; - gfc_symbol *symbol; - gfc_typespec *last_ts; - mpz_t offset; - const char *msg = "F18(R841): data-implied-do object at %L is neither an " - "array-element nor a scalar-structure-component"; - - symbol = lvalue->symtree->n.sym; - if (symbol->attr.flavor == FL_PARAMETER) - { - gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %L", - symbol->name, &lvalue->where); - return false; - } - - init = symbol->value; - last_ts = &symbol->ts; - last_con = NULL; - mpz_init_set_si (offset, 0); - - /* Find/create the parent expressions for subobject references. */ - for (ref = lvalue->ref; ref; ref = ref->next) - { - /* Break out of the loop if we find a substring. */ - if (ref->type == REF_SUBSTRING) - { - /* A substring should always be the last subobject reference. */ - gcc_assert (ref->next == NULL); - break; - } - - /* Use the existing initializer expression if it exists. Otherwise - create a new one. */ - if (init == NULL) - expr = gfc_get_expr (); - else - expr = init; - - /* Find or create this element. */ - switch (ref->type) - { - case REF_ARRAY: - if (ref->u.ar.as->rank == 0) - { - gcc_assert (ref->u.ar.as->corank > 0); - if (init == NULL) - free (expr); - continue; - } - - if (init && expr->expr_type != EXPR_ARRAY) - { - gfc_error ("%qs at %L already is initialized at %L", - lvalue->symtree->n.sym->name, &lvalue->where, - &init->where); - goto abort; - } - - if (init == NULL) - { - /* The element typespec will be the same as the array - typespec. */ - expr->ts = *last_ts; - /* Setup the expression to hold the constructor. */ - expr->expr_type = EXPR_ARRAY; - expr->rank = ref->u.ar.as->rank; - } - - if (ref->u.ar.type == AR_ELEMENT) - get_array_index (&ref->u.ar, &offset); - else - mpz_set (offset, index); - - /* Check the bounds. */ - if (mpz_cmp_si (offset, 0) < 0) - { - gfc_error ("Data element below array lower bound at %L", - &lvalue->where); - goto abort; - } - else if (repeat != NULL - && ref->u.ar.type != AR_ELEMENT) - { - mpz_t size, end; - gcc_assert (ref->u.ar.type == AR_FULL - && ref->next == NULL); - mpz_init_set (end, offset); - mpz_add (end, end, *repeat); - if (spec_size (ref->u.ar.as, &size)) - { - if (mpz_cmp (end, size) > 0) - { - mpz_clear (size); - gfc_error ("Data element above array upper bound at %L", - &lvalue->where); - goto abort; - } - mpz_clear (size); - } - - con = gfc_constructor_lookup (expr->value.constructor, - mpz_get_si (offset)); - if (!con) - { - con = gfc_constructor_lookup_next (expr->value.constructor, - mpz_get_si (offset)); - if (con != NULL && mpz_cmp (con->offset, end) >= 0) - con = NULL; - } - - /* Overwriting an existing initializer is non-standard but - usually only provokes a warning from other compilers. */ - if (con != NULL && con->expr != NULL) - { - /* Order in which the expressions arrive here depends on - whether they are from data statements or F95 style - declarations. Therefore, check which is the most - recent. */ - gfc_expr *exprd; - exprd = (LOCATION_LINE (con->expr->where.lb->location) - > LOCATION_LINE (rvalue->where.lb->location)) - ? con->expr : rvalue; - if (gfc_notify_std (GFC_STD_GNU, - "re-initialization of %qs at %L", - symbol->name, &exprd->where) == false) - return false; - } - - while (con != NULL) - { - gfc_constructor *next_con = gfc_constructor_next (con); - - if (mpz_cmp (con->offset, end) >= 0) - break; - if (mpz_cmp (con->offset, offset) < 0) - { - gcc_assert (mpz_cmp_si (con->repeat, 1) > 0); - mpz_sub (con->repeat, offset, con->offset); - } - else if (mpz_cmp_si (con->repeat, 1) > 0 - && mpz_get_si (con->offset) - + mpz_get_si (con->repeat) > mpz_get_si (end)) - { - int endi; - splay_tree_node node - = splay_tree_lookup (con->base, - mpz_get_si (con->offset)); - gcc_assert (node - && con == (gfc_constructor *) node->value - && node->key == (splay_tree_key) - mpz_get_si (con->offset)); - endi = mpz_get_si (con->offset) - + mpz_get_si (con->repeat); - if (endi > mpz_get_si (end) + 1) - mpz_set_si (con->repeat, endi - mpz_get_si (end)); - else - mpz_set_si (con->repeat, 1); - mpz_set (con->offset, end); - node->key = (splay_tree_key) mpz_get_si (end); - break; - } - else - gfc_constructor_remove (con); - con = next_con; - } - - con = gfc_constructor_insert_expr (&expr->value.constructor, - NULL, &rvalue->where, - mpz_get_si (offset)); - mpz_set (con->repeat, *repeat); - repeat = NULL; - mpz_clear (end); - break; - } - else - { - mpz_t size; - if (spec_size (ref->u.ar.as, &size)) - { - if (mpz_cmp (offset, size) >= 0) - { - mpz_clear (size); - gfc_error ("Data element above array upper bound at %L", - &lvalue->where); - goto abort; - } - mpz_clear (size); - } - } - - con = gfc_constructor_lookup (expr->value.constructor, - mpz_get_si (offset)); - if (!con) - { - con = gfc_constructor_insert_expr (&expr->value.constructor, - NULL, &rvalue->where, - mpz_get_si (offset)); - } - else if (mpz_cmp_si (con->repeat, 1) > 0) - { - /* Need to split a range. */ - if (mpz_cmp (con->offset, offset) < 0) - { - gfc_constructor *pred_con = con; - con = gfc_constructor_insert_expr (&expr->value.constructor, - NULL, &con->where, - mpz_get_si (offset)); - con->expr = gfc_copy_expr (pred_con->expr); - mpz_add (con->repeat, pred_con->offset, pred_con->repeat); - mpz_sub (con->repeat, con->repeat, offset); - mpz_sub (pred_con->repeat, offset, pred_con->offset); - } - if (mpz_cmp_si (con->repeat, 1) > 0) - { - gfc_constructor *succ_con; - succ_con - = gfc_constructor_insert_expr (&expr->value.constructor, - NULL, &con->where, - mpz_get_si (offset) + 1); - succ_con->expr = gfc_copy_expr (con->expr); - mpz_sub_ui (succ_con->repeat, con->repeat, 1); - mpz_set_si (con->repeat, 1); - } - } - break; - - case REF_COMPONENT: - if (init == NULL) - { - /* Setup the expression to hold the constructor. */ - expr->expr_type = EXPR_STRUCTURE; - expr->ts.type = BT_DERIVED; - expr->ts.u.derived = ref->u.c.sym; - } - else - gcc_assert (expr->expr_type == EXPR_STRUCTURE); - last_ts = &ref->u.c.component->ts; - - /* Find the same element in the existing constructor. */ - con = find_con_by_component (ref->u.c.component, - expr->value.constructor); - - if (con == NULL) - { - /* Create a new constructor. */ - con = gfc_constructor_append_expr (&expr->value.constructor, - NULL, NULL); - con->n.component = ref->u.c.component; - } - break; - - case REF_INQUIRY: - - /* After some discussion on clf it was determined that the following - violates F18(R841). If the error is removed, the expected result - is obtained. Leaving the code in place ensures a clean error - recovery. */ - gfc_error (msg, &lvalue->where); - - /* This breaks with the other reference types in that the output - constructor has to be of type COMPLEX, whereas the lvalue is - of type REAL. The rvalue is copied to the real or imaginary - part as appropriate. In addition, for all except scalar - complex variables, a complex expression has to provided, where - the constructor does not have it, and the expression modified - with a new value for the real or imaginary part. */ - gcc_assert (ref->next == NULL && last_ts->type == BT_COMPLEX); - rexpr = gfc_copy_expr (rvalue); - if (!gfc_compare_types (&lvalue->ts, &rexpr->ts)) - gfc_convert_type (rexpr, &lvalue->ts, 0); - - /* This is the scalar, complex case, where an initializer exists. */ - if (init && ref == lvalue->ref) - expr = symbol->value; - /* Then all cases, where a complex expression does not exist. */ - else if (!last_con || !last_con->expr) - { - expr = gfc_get_constant_expr (BT_COMPLEX, lvalue->ts.kind, - &lvalue->where); - if (last_con) - last_con->expr = expr; - } - else - /* Finally, and existing constructor expression to be modified. */ - expr = last_con->expr; - - /* Rejection of LEN and KIND inquiry references is handled - elsewhere. The error here is added as backup. The assertion - of F2008 for RE and IM is also done elsewhere. */ - switch (ref->u.i) - { - case INQUIRY_LEN: - case INQUIRY_KIND: - gfc_error ("LEN or KIND inquiry ref in DATA statement at %L", - &lvalue->where); - goto abort; - case INQUIRY_RE: - mpfr_set (mpc_realref (expr->value.complex), - rexpr->value.real, - GFC_RND_MODE); - break; - case INQUIRY_IM: - mpfr_set (mpc_imagref (expr->value.complex), - rexpr->value.real, - GFC_RND_MODE); - break; - } - - /* Only the scalar, complex expression needs to be saved as the - symbol value since the last constructor expression is already - provided as the initializer in the code after the reference - cases. */ - if (ref == lvalue->ref) - symbol->value = expr; - - gfc_free_expr (rexpr); - mpz_clear (offset); - return true; - - default: - gcc_unreachable (); - } - - if (init == NULL) - { - /* Point the container at the new expression. */ - if (last_con == NULL) - symbol->value = expr; - else - last_con->expr = expr; - } - init = con->expr; - last_con = con; - } - - mpz_clear (offset); - gcc_assert (repeat == NULL); - - /* Overwriting an existing initializer is non-standard but usually only - provokes a warning from other compilers. */ - if (init != NULL && init->where.lb && rvalue->where.lb) - { - /* Order in which the expressions arrive here depends on whether - they are from data statements or F95 style declarations. - Therefore, check which is the most recent. */ - expr = (LOCATION_LINE (init->where.lb->location) - > LOCATION_LINE (rvalue->where.lb->location)) - ? init : rvalue; - if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L", - symbol->name, &expr->where) == false) - return false; - } - - if (ref || (last_ts->type == BT_CHARACTER - && rvalue->expr_type == EXPR_CONSTANT)) - { - /* An initializer has to be constant. */ - if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) - return false; - if (lvalue->ts.u.cl->length - && lvalue->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return false; - expr = create_character_initializer (init, last_ts, ref, rvalue); - if (!expr) - return false; - } - else - { - if (lvalue->ts.type == BT_DERIVED - && gfc_has_default_initializer (lvalue->ts.u.derived)) - { - gfc_error ("Nonpointer object %qs with default initialization " - "shall not appear in a DATA statement at %L", - symbol->name, &lvalue->where); - return false; - } - - expr = gfc_copy_expr (rvalue); - if (!gfc_compare_types (&lvalue->ts, &expr->ts)) - gfc_convert_type (expr, &lvalue->ts, 0); - } - - if (last_con == NULL) - symbol->value = expr; - else - last_con->expr = expr; - - return true; - -abort: - if (!init) - gfc_free_expr (expr); - mpz_clear (offset); - return false; -} - - -/* Modify the index of array section and re-calculate the array offset. */ - -void -gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, - mpz_t *offset_ret) -{ - int i; - mpz_t delta; - mpz_t tmp; - bool forwards; - int cmp; - gfc_expr *start, *end, *stride; - - for (i = 0; i < ar->dimen; i++) - { - if (ar->dimen_type[i] != DIMEN_RANGE) - continue; - - if (ar->stride[i]) - { - stride = gfc_copy_expr(ar->stride[i]); - if(!gfc_simplify_expr(stride, 1)) - gfc_internal_error("Simplification error"); - mpz_add (section_index[i], section_index[i], - stride->value.integer); - if (mpz_cmp_si (stride->value.integer, 0) >= 0) - forwards = true; - else - forwards = false; - gfc_free_expr(stride); - } - else - { - mpz_add_ui (section_index[i], section_index[i], 1); - forwards = true; - } - - if (ar->end[i]) - { - end = gfc_copy_expr(ar->end[i]); - if(!gfc_simplify_expr(end, 1)) - gfc_internal_error("Simplification error"); - cmp = mpz_cmp (section_index[i], end->value.integer); - gfc_free_expr(end); - } - else - cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer); - - if ((cmp > 0 && forwards) || (cmp < 0 && !forwards)) - { - /* Reset index to start, then loop to advance the next index. */ - if (ar->start[i]) - { - start = gfc_copy_expr(ar->start[i]); - if(!gfc_simplify_expr(start, 1)) - gfc_internal_error("Simplification error"); - mpz_set (section_index[i], start->value.integer); - gfc_free_expr(start); - } - else - mpz_set (section_index[i], ar->as->lower[i]->value.integer); - } - else - break; - } - - mpz_set_si (*offset_ret, 0); - mpz_init_set_si (delta, 1); - mpz_init (tmp); - for (i = 0; i < ar->dimen; i++) - { - mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer); - mpz_mul (tmp, tmp, delta); - mpz_add (*offset_ret, tmp, *offset_ret); - - mpz_sub (tmp, ar->as->upper[i]->value.integer, - ar->as->lower[i]->value.integer); - mpz_add_ui (tmp, tmp, 1); - mpz_mul (delta, tmp, delta); - } - mpz_clear (tmp); - mpz_clear (delta); -} - - -/* Rearrange a structure constructor so the elements are in the specified - order. Also insert NULL entries if necessary. */ - -static void -formalize_structure_cons (gfc_expr *expr) -{ - gfc_constructor_base base = NULL; - gfc_constructor *cur; - gfc_component *order; - - /* Constructor is already formalized. */ - cur = gfc_constructor_first (expr->value.constructor); - if (!cur || cur->n.component == NULL) - return; - - for (order = expr->ts.u.derived->components; order; order = order->next) - { - cur = find_con_by_component (order, expr->value.constructor); - if (cur) - gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where); - else - gfc_constructor_append_expr (&base, NULL, NULL); - } - - /* For all what it's worth, one would expect - gfc_constructor_free (expr->value.constructor); - here. However, if the constructor is actually free'd, - hell breaks loose in the testsuite?! */ - - expr->value.constructor = base; -} - - -/* Make sure an initialization expression is in normalized form, i.e., all - elements of the constructors are in the correct order. */ - -static void -formalize_init_expr (gfc_expr *expr) -{ - expr_t type; - gfc_constructor *c; - - if (expr == NULL) - return; - - type = expr->expr_type; - switch (type) - { - case EXPR_ARRAY: - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c)) - formalize_init_expr (c->expr); - - break; - - case EXPR_STRUCTURE: - formalize_structure_cons (expr); - break; - - default: - break; - } -} - - -/* Resolve symbol's initial value after all data statement. */ - -void -gfc_formalize_init_value (gfc_symbol *sym) -{ - formalize_init_expr (sym->value); -} - - -/* Get the integer value into RET_AS and SECTION from AS and AR, and return - offset. */ - -void -gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset) -{ - int i; - mpz_t delta; - mpz_t tmp; - gfc_expr *start; - - mpz_set_si (*offset, 0); - mpz_init (tmp); - mpz_init_set_si (delta, 1); - for (i = 0; i < ar->dimen; i++) - { - mpz_init (section_index[i]); - switch (ar->dimen_type[i]) - { - case DIMEN_ELEMENT: - case DIMEN_RANGE: - if (ar->start[i]) - { - start = gfc_copy_expr(ar->start[i]); - if(!gfc_simplify_expr(start, 1)) - gfc_internal_error("Simplification error"); - mpz_sub (tmp, start->value.integer, - ar->as->lower[i]->value.integer); - mpz_mul (tmp, tmp, delta); - mpz_add (*offset, tmp, *offset); - mpz_set (section_index[i], start->value.integer); - gfc_free_expr(start); - } - else - mpz_set (section_index[i], ar->as->lower[i]->value.integer); - break; - - case DIMEN_VECTOR: - gfc_internal_error ("TODO: Vector sections in data statements"); - - default: - gcc_unreachable (); - } - - mpz_sub (tmp, ar->as->upper[i]->value.integer, - ar->as->lower[i]->value.integer); - mpz_add_ui (tmp, tmp, 1); - mpz_mul (delta, tmp, delta); - } - - mpz_clear (tmp); - mpz_clear (delta); -} - diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc new file mode 100644 index 0000000..839e042 --- /dev/null +++ b/gcc/fortran/data.cc @@ -0,0 +1,848 @@ +/* Supporting functions for resolving DATA statement. + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Lifang Zeng + +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 +. */ + + +/* Notes for DATA statement implementation: + + We first assign initial value to each symbol by gfc_assign_data_value + during resolving DATA statement. Refer to check_data_variable and + traverse_data_list in resolve.c. + + The complexity exists in the handling of array section, implied do + and array of struct appeared in DATA statement. + + We call gfc_conv_structure, gfc_con_array_array_initializer, + etc., to convert the initial value. Refer to trans-expr.c and + trans-array.c. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "data.h" +#include "constructor.h" + +static void formalize_init_expr (gfc_expr *); + +/* Calculate the array element offset. */ + +static void +get_array_index (gfc_array_ref *ar, mpz_t *offset) +{ + gfc_expr *e; + int i; + mpz_t delta; + mpz_t tmp; + + mpz_init (tmp); + mpz_set_si (*offset, 0); + mpz_init_set_si (delta, 1); + for (i = 0; i < ar->dimen; i++) + { + e = gfc_copy_expr (ar->start[i]); + gfc_simplify_expr (e, 1); + + if ((gfc_is_constant_expr (ar->as->lower[i]) == 0) + || (gfc_is_constant_expr (ar->as->upper[i]) == 0) + || (gfc_is_constant_expr (e) == 0)) + gfc_error ("non-constant array in DATA statement %L", &ar->where); + + mpz_set (tmp, e->value.integer); + gfc_free_expr (e); + mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); + mpz_mul (tmp, tmp, delta); + mpz_add (*offset, tmp, *offset); + + mpz_sub (tmp, ar->as->upper[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_add_ui (tmp, tmp, 1); + mpz_mul (delta, tmp, delta); + } + mpz_clear (delta); + mpz_clear (tmp); +} + +/* Find if there is a constructor which component is equal to COM. + TODO: remove this, use symbol.c(gfc_find_component) instead. */ + +static gfc_constructor * +find_con_by_component (gfc_component *com, gfc_constructor_base base) +{ + gfc_constructor *c; + + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + if (com == c->n.component) + return c; + + return NULL; +} + + +/* Create a character type initialization expression from RVALUE. + TS [and REF] describe [the substring of] the variable being initialized. + INIT is the existing initializer, not NULL. Initialization is performed + according to normal assignment rules. */ + +static gfc_expr * +create_character_initializer (gfc_expr *init, gfc_typespec *ts, + gfc_ref *ref, gfc_expr *rvalue) +{ + HOST_WIDE_INT len, start, end, tlen; + gfc_char_t *dest; + bool alloced_init = false; + + if (init && init->ts.type != BT_CHARACTER) + return NULL; + + gfc_extract_hwi (ts->u.cl->length, &len); + + if (init == NULL) + { + /* Create a new initializer. */ + init = gfc_get_character_expr (ts->kind, NULL, NULL, len); + init->ts = *ts; + alloced_init = true; + } + + dest = init->value.character.string; + + if (ref) + { + gfc_expr *start_expr, *end_expr; + + gcc_assert (ref->type == REF_SUBSTRING); + + /* Only set a substring of the destination. Fortran substring bounds + are one-based [start, end], we want zero based [start, end). */ + start_expr = gfc_copy_expr (ref->u.ss.start); + end_expr = gfc_copy_expr (ref->u.ss.end); + + if ((!gfc_simplify_expr(start_expr, 1)) + || !(gfc_simplify_expr(end_expr, 1))) + { + gfc_error ("failure to simplify substring reference in DATA " + "statement at %L", &ref->u.ss.start->where); + gfc_free_expr (start_expr); + gfc_free_expr (end_expr); + if (alloced_init) + gfc_free_expr (init); + return NULL; + } + + gfc_extract_hwi (start_expr, &start); + gfc_free_expr (start_expr); + start--; + gfc_extract_hwi (end_expr, &end); + gfc_free_expr (end_expr); + } + else + { + /* Set the whole string. */ + start = 0; + end = len; + } + + /* Copy the initial value. */ + if (rvalue->ts.type == BT_HOLLERITH) + len = rvalue->representation.length - rvalue->ts.u.pad; + else + len = rvalue->value.character.length; + + tlen = end - start; + if (len > tlen) + { + if (tlen < 0) + { + gfc_warning_now (0, "Unused initialization string at %L because " + "variable has zero length", &rvalue->where); + len = 0; + } + else + { + gfc_warning_now (0, "Initialization string at %L was truncated to " + "fit the variable (%ld/%ld)", &rvalue->where, + (long) tlen, (long) len); + len = tlen; + } + } + + if (start < 0) + { + gfc_error ("Substring start index at %L is less than one", + &ref->u.ss.start->where); + return NULL; + } + if (end > init->value.character.length) + { + gfc_error ("Substring end index at %L exceeds the string length", + &ref->u.ss.end->where); + return NULL; + } + + if (rvalue->ts.type == BT_HOLLERITH) + { + for (size_t i = 0; i < (size_t) len; i++) + dest[start+i] = rvalue->representation.string[i]; + } + else + memcpy (&dest[start], rvalue->value.character.string, + len * sizeof (gfc_char_t)); + + /* Pad with spaces. Substrings will already be blanked. */ + if (len < tlen && ref == NULL) + gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); + + if (rvalue->ts.type == BT_HOLLERITH) + { + init->representation.length = init->value.character.length; + init->representation.string + = gfc_widechar_to_char (init->value.character.string, + init->value.character.length); + } + + return init; +} + + +/* Assign the initial value RVALUE to LVALUE's symbol->value. If the + LVALUE already has an initialization, we extend this, otherwise we + create a new one. If REPEAT is non-NULL, initialize *REPEAT + consecutive values in LVALUE the same value in RVALUE. In that case, + LVALUE must refer to a full array, not an array section. */ + +bool +gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, + mpz_t *repeat) +{ + gfc_ref *ref; + gfc_expr *init; + gfc_expr *expr = NULL; + gfc_expr *rexpr; + gfc_constructor *con; + gfc_constructor *last_con; + gfc_symbol *symbol; + gfc_typespec *last_ts; + mpz_t offset; + const char *msg = "F18(R841): data-implied-do object at %L is neither an " + "array-element nor a scalar-structure-component"; + + symbol = lvalue->symtree->n.sym; + if (symbol->attr.flavor == FL_PARAMETER) + { + gfc_error ("PARAMETER %qs shall not appear in a DATA statement at %L", + symbol->name, &lvalue->where); + return false; + } + + init = symbol->value; + last_ts = &symbol->ts; + last_con = NULL; + mpz_init_set_si (offset, 0); + + /* Find/create the parent expressions for subobject references. */ + for (ref = lvalue->ref; ref; ref = ref->next) + { + /* Break out of the loop if we find a substring. */ + if (ref->type == REF_SUBSTRING) + { + /* A substring should always be the last subobject reference. */ + gcc_assert (ref->next == NULL); + break; + } + + /* Use the existing initializer expression if it exists. Otherwise + create a new one. */ + if (init == NULL) + expr = gfc_get_expr (); + else + expr = init; + + /* Find or create this element. */ + switch (ref->type) + { + case REF_ARRAY: + if (ref->u.ar.as->rank == 0) + { + gcc_assert (ref->u.ar.as->corank > 0); + if (init == NULL) + free (expr); + continue; + } + + if (init && expr->expr_type != EXPR_ARRAY) + { + gfc_error ("%qs at %L already is initialized at %L", + lvalue->symtree->n.sym->name, &lvalue->where, + &init->where); + goto abort; + } + + if (init == NULL) + { + /* The element typespec will be the same as the array + typespec. */ + expr->ts = *last_ts; + /* Setup the expression to hold the constructor. */ + expr->expr_type = EXPR_ARRAY; + expr->rank = ref->u.ar.as->rank; + } + + if (ref->u.ar.type == AR_ELEMENT) + get_array_index (&ref->u.ar, &offset); + else + mpz_set (offset, index); + + /* Check the bounds. */ + if (mpz_cmp_si (offset, 0) < 0) + { + gfc_error ("Data element below array lower bound at %L", + &lvalue->where); + goto abort; + } + else if (repeat != NULL + && ref->u.ar.type != AR_ELEMENT) + { + mpz_t size, end; + gcc_assert (ref->u.ar.type == AR_FULL + && ref->next == NULL); + mpz_init_set (end, offset); + mpz_add (end, end, *repeat); + if (spec_size (ref->u.ar.as, &size)) + { + if (mpz_cmp (end, size) > 0) + { + mpz_clear (size); + gfc_error ("Data element above array upper bound at %L", + &lvalue->where); + goto abort; + } + mpz_clear (size); + } + + con = gfc_constructor_lookup (expr->value.constructor, + mpz_get_si (offset)); + if (!con) + { + con = gfc_constructor_lookup_next (expr->value.constructor, + mpz_get_si (offset)); + if (con != NULL && mpz_cmp (con->offset, end) >= 0) + con = NULL; + } + + /* Overwriting an existing initializer is non-standard but + usually only provokes a warning from other compilers. */ + if (con != NULL && con->expr != NULL) + { + /* Order in which the expressions arrive here depends on + whether they are from data statements or F95 style + declarations. Therefore, check which is the most + recent. */ + gfc_expr *exprd; + exprd = (LOCATION_LINE (con->expr->where.lb->location) + > LOCATION_LINE (rvalue->where.lb->location)) + ? con->expr : rvalue; + if (gfc_notify_std (GFC_STD_GNU, + "re-initialization of %qs at %L", + symbol->name, &exprd->where) == false) + return false; + } + + while (con != NULL) + { + gfc_constructor *next_con = gfc_constructor_next (con); + + if (mpz_cmp (con->offset, end) >= 0) + break; + if (mpz_cmp (con->offset, offset) < 0) + { + gcc_assert (mpz_cmp_si (con->repeat, 1) > 0); + mpz_sub (con->repeat, offset, con->offset); + } + else if (mpz_cmp_si (con->repeat, 1) > 0 + && mpz_get_si (con->offset) + + mpz_get_si (con->repeat) > mpz_get_si (end)) + { + int endi; + splay_tree_node node + = splay_tree_lookup (con->base, + mpz_get_si (con->offset)); + gcc_assert (node + && con == (gfc_constructor *) node->value + && node->key == (splay_tree_key) + mpz_get_si (con->offset)); + endi = mpz_get_si (con->offset) + + mpz_get_si (con->repeat); + if (endi > mpz_get_si (end) + 1) + mpz_set_si (con->repeat, endi - mpz_get_si (end)); + else + mpz_set_si (con->repeat, 1); + mpz_set (con->offset, end); + node->key = (splay_tree_key) mpz_get_si (end); + break; + } + else + gfc_constructor_remove (con); + con = next_con; + } + + con = gfc_constructor_insert_expr (&expr->value.constructor, + NULL, &rvalue->where, + mpz_get_si (offset)); + mpz_set (con->repeat, *repeat); + repeat = NULL; + mpz_clear (end); + break; + } + else + { + mpz_t size; + if (spec_size (ref->u.ar.as, &size)) + { + if (mpz_cmp (offset, size) >= 0) + { + mpz_clear (size); + gfc_error ("Data element above array upper bound at %L", + &lvalue->where); + goto abort; + } + mpz_clear (size); + } + } + + con = gfc_constructor_lookup (expr->value.constructor, + mpz_get_si (offset)); + if (!con) + { + con = gfc_constructor_insert_expr (&expr->value.constructor, + NULL, &rvalue->where, + mpz_get_si (offset)); + } + else if (mpz_cmp_si (con->repeat, 1) > 0) + { + /* Need to split a range. */ + if (mpz_cmp (con->offset, offset) < 0) + { + gfc_constructor *pred_con = con; + con = gfc_constructor_insert_expr (&expr->value.constructor, + NULL, &con->where, + mpz_get_si (offset)); + con->expr = gfc_copy_expr (pred_con->expr); + mpz_add (con->repeat, pred_con->offset, pred_con->repeat); + mpz_sub (con->repeat, con->repeat, offset); + mpz_sub (pred_con->repeat, offset, pred_con->offset); + } + if (mpz_cmp_si (con->repeat, 1) > 0) + { + gfc_constructor *succ_con; + succ_con + = gfc_constructor_insert_expr (&expr->value.constructor, + NULL, &con->where, + mpz_get_si (offset) + 1); + succ_con->expr = gfc_copy_expr (con->expr); + mpz_sub_ui (succ_con->repeat, con->repeat, 1); + mpz_set_si (con->repeat, 1); + } + } + break; + + case REF_COMPONENT: + if (init == NULL) + { + /* Setup the expression to hold the constructor. */ + expr->expr_type = EXPR_STRUCTURE; + expr->ts.type = BT_DERIVED; + expr->ts.u.derived = ref->u.c.sym; + } + else + gcc_assert (expr->expr_type == EXPR_STRUCTURE); + last_ts = &ref->u.c.component->ts; + + /* Find the same element in the existing constructor. */ + con = find_con_by_component (ref->u.c.component, + expr->value.constructor); + + if (con == NULL) + { + /* Create a new constructor. */ + con = gfc_constructor_append_expr (&expr->value.constructor, + NULL, NULL); + con->n.component = ref->u.c.component; + } + break; + + case REF_INQUIRY: + + /* After some discussion on clf it was determined that the following + violates F18(R841). If the error is removed, the expected result + is obtained. Leaving the code in place ensures a clean error + recovery. */ + gfc_error (msg, &lvalue->where); + + /* This breaks with the other reference types in that the output + constructor has to be of type COMPLEX, whereas the lvalue is + of type REAL. The rvalue is copied to the real or imaginary + part as appropriate. In addition, for all except scalar + complex variables, a complex expression has to provided, where + the constructor does not have it, and the expression modified + with a new value for the real or imaginary part. */ + gcc_assert (ref->next == NULL && last_ts->type == BT_COMPLEX); + rexpr = gfc_copy_expr (rvalue); + if (!gfc_compare_types (&lvalue->ts, &rexpr->ts)) + gfc_convert_type (rexpr, &lvalue->ts, 0); + + /* This is the scalar, complex case, where an initializer exists. */ + if (init && ref == lvalue->ref) + expr = symbol->value; + /* Then all cases, where a complex expression does not exist. */ + else if (!last_con || !last_con->expr) + { + expr = gfc_get_constant_expr (BT_COMPLEX, lvalue->ts.kind, + &lvalue->where); + if (last_con) + last_con->expr = expr; + } + else + /* Finally, and existing constructor expression to be modified. */ + expr = last_con->expr; + + /* Rejection of LEN and KIND inquiry references is handled + elsewhere. The error here is added as backup. The assertion + of F2008 for RE and IM is also done elsewhere. */ + switch (ref->u.i) + { + case INQUIRY_LEN: + case INQUIRY_KIND: + gfc_error ("LEN or KIND inquiry ref in DATA statement at %L", + &lvalue->where); + goto abort; + case INQUIRY_RE: + mpfr_set (mpc_realref (expr->value.complex), + rexpr->value.real, + GFC_RND_MODE); + break; + case INQUIRY_IM: + mpfr_set (mpc_imagref (expr->value.complex), + rexpr->value.real, + GFC_RND_MODE); + break; + } + + /* Only the scalar, complex expression needs to be saved as the + symbol value since the last constructor expression is already + provided as the initializer in the code after the reference + cases. */ + if (ref == lvalue->ref) + symbol->value = expr; + + gfc_free_expr (rexpr); + mpz_clear (offset); + return true; + + default: + gcc_unreachable (); + } + + if (init == NULL) + { + /* Point the container at the new expression. */ + if (last_con == NULL) + symbol->value = expr; + else + last_con->expr = expr; + } + init = con->expr; + last_con = con; + } + + mpz_clear (offset); + gcc_assert (repeat == NULL); + + /* Overwriting an existing initializer is non-standard but usually only + provokes a warning from other compilers. */ + if (init != NULL && init->where.lb && rvalue->where.lb) + { + /* Order in which the expressions arrive here depends on whether + they are from data statements or F95 style declarations. + Therefore, check which is the most recent. */ + expr = (LOCATION_LINE (init->where.lb->location) + > LOCATION_LINE (rvalue->where.lb->location)) + ? init : rvalue; + if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L", + symbol->name, &expr->where) == false) + return false; + } + + if (ref || (last_ts->type == BT_CHARACTER + && rvalue->expr_type == EXPR_CONSTANT)) + { + /* An initializer has to be constant. */ + if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) + return false; + if (lvalue->ts.u.cl->length + && lvalue->ts.u.cl->length->expr_type != EXPR_CONSTANT) + return false; + expr = create_character_initializer (init, last_ts, ref, rvalue); + if (!expr) + return false; + } + else + { + if (lvalue->ts.type == BT_DERIVED + && gfc_has_default_initializer (lvalue->ts.u.derived)) + { + gfc_error ("Nonpointer object %qs with default initialization " + "shall not appear in a DATA statement at %L", + symbol->name, &lvalue->where); + return false; + } + + expr = gfc_copy_expr (rvalue); + if (!gfc_compare_types (&lvalue->ts, &expr->ts)) + gfc_convert_type (expr, &lvalue->ts, 0); + } + + if (last_con == NULL) + symbol->value = expr; + else + last_con->expr = expr; + + return true; + +abort: + if (!init) + gfc_free_expr (expr); + mpz_clear (offset); + return false; +} + + +/* Modify the index of array section and re-calculate the array offset. */ + +void +gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, + mpz_t *offset_ret) +{ + int i; + mpz_t delta; + mpz_t tmp; + bool forwards; + int cmp; + gfc_expr *start, *end, *stride; + + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] != DIMEN_RANGE) + continue; + + if (ar->stride[i]) + { + stride = gfc_copy_expr(ar->stride[i]); + if(!gfc_simplify_expr(stride, 1)) + gfc_internal_error("Simplification error"); + mpz_add (section_index[i], section_index[i], + stride->value.integer); + if (mpz_cmp_si (stride->value.integer, 0) >= 0) + forwards = true; + else + forwards = false; + gfc_free_expr(stride); + } + else + { + mpz_add_ui (section_index[i], section_index[i], 1); + forwards = true; + } + + if (ar->end[i]) + { + end = gfc_copy_expr(ar->end[i]); + if(!gfc_simplify_expr(end, 1)) + gfc_internal_error("Simplification error"); + cmp = mpz_cmp (section_index[i], end->value.integer); + gfc_free_expr(end); + } + else + cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer); + + if ((cmp > 0 && forwards) || (cmp < 0 && !forwards)) + { + /* Reset index to start, then loop to advance the next index. */ + if (ar->start[i]) + { + start = gfc_copy_expr(ar->start[i]); + if(!gfc_simplify_expr(start, 1)) + gfc_internal_error("Simplification error"); + mpz_set (section_index[i], start->value.integer); + gfc_free_expr(start); + } + else + mpz_set (section_index[i], ar->as->lower[i]->value.integer); + } + else + break; + } + + mpz_set_si (*offset_ret, 0); + mpz_init_set_si (delta, 1); + mpz_init (tmp); + for (i = 0; i < ar->dimen; i++) + { + mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer); + mpz_mul (tmp, tmp, delta); + mpz_add (*offset_ret, tmp, *offset_ret); + + mpz_sub (tmp, ar->as->upper[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_add_ui (tmp, tmp, 1); + mpz_mul (delta, tmp, delta); + } + mpz_clear (tmp); + mpz_clear (delta); +} + + +/* Rearrange a structure constructor so the elements are in the specified + order. Also insert NULL entries if necessary. */ + +static void +formalize_structure_cons (gfc_expr *expr) +{ + gfc_constructor_base base = NULL; + gfc_constructor *cur; + gfc_component *order; + + /* Constructor is already formalized. */ + cur = gfc_constructor_first (expr->value.constructor); + if (!cur || cur->n.component == NULL) + return; + + for (order = expr->ts.u.derived->components; order; order = order->next) + { + cur = find_con_by_component (order, expr->value.constructor); + if (cur) + gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where); + else + gfc_constructor_append_expr (&base, NULL, NULL); + } + + /* For all what it's worth, one would expect + gfc_constructor_free (expr->value.constructor); + here. However, if the constructor is actually free'd, + hell breaks loose in the testsuite?! */ + + expr->value.constructor = base; +} + + +/* Make sure an initialization expression is in normalized form, i.e., all + elements of the constructors are in the correct order. */ + +static void +formalize_init_expr (gfc_expr *expr) +{ + expr_t type; + gfc_constructor *c; + + if (expr == NULL) + return; + + type = expr->expr_type; + switch (type) + { + case EXPR_ARRAY: + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + formalize_init_expr (c->expr); + + break; + + case EXPR_STRUCTURE: + formalize_structure_cons (expr); + break; + + default: + break; + } +} + + +/* Resolve symbol's initial value after all data statement. */ + +void +gfc_formalize_init_value (gfc_symbol *sym) +{ + formalize_init_expr (sym->value); +} + + +/* Get the integer value into RET_AS and SECTION from AS and AR, and return + offset. */ + +void +gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset) +{ + int i; + mpz_t delta; + mpz_t tmp; + gfc_expr *start; + + mpz_set_si (*offset, 0); + mpz_init (tmp); + mpz_init_set_si (delta, 1); + for (i = 0; i < ar->dimen; i++) + { + mpz_init (section_index[i]); + switch (ar->dimen_type[i]) + { + case DIMEN_ELEMENT: + case DIMEN_RANGE: + if (ar->start[i]) + { + start = gfc_copy_expr(ar->start[i]); + if(!gfc_simplify_expr(start, 1)) + gfc_internal_error("Simplification error"); + mpz_sub (tmp, start->value.integer, + ar->as->lower[i]->value.integer); + mpz_mul (tmp, tmp, delta); + mpz_add (*offset, tmp, *offset); + mpz_set (section_index[i], start->value.integer); + gfc_free_expr(start); + } + else + mpz_set (section_index[i], ar->as->lower[i]->value.integer); + break; + + case DIMEN_VECTOR: + gfc_internal_error ("TODO: Vector sections in data statements"); + + default: + gcc_unreachable (); + } + + mpz_sub (tmp, ar->as->upper[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_add_ui (tmp, tmp, 1); + mpz_mul (delta, tmp, delta); + } + + mpz_clear (tmp); + mpz_clear (delta); +} + diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c deleted file mode 100644 index c846923..0000000 --- a/gcc/fortran/decl.c +++ /dev/null @@ -1,11910 +0,0 @@ -/* Declaration statement matcher - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "tree.h" -#include "gfortran.h" -#include "stringpool.h" -#include "match.h" -#include "parse.h" -#include "constructor.h" -#include "target.h" - -/* Macros to access allocate memory for gfc_data_variable, - gfc_data_value and gfc_data. */ -#define gfc_get_data_variable() XCNEW (gfc_data_variable) -#define gfc_get_data_value() XCNEW (gfc_data_value) -#define gfc_get_data() XCNEW (gfc_data) - - -static bool set_binding_label (const char **, const char *, int); - - -/* This flag is set if an old-style length selector is matched - during a type-declaration statement. */ - -static int old_char_selector; - -/* When variables acquire types and attributes from a declaration - statement, they get them from the following static variables. The - first part of a declaration sets these variables and the second - part copies these into symbol structures. */ - -static gfc_typespec current_ts; - -static symbol_attribute current_attr; -static gfc_array_spec *current_as; -static int colon_seen; -static int attr_seen; - -/* The current binding label (if any). */ -static const char* curr_binding_label; -/* Need to know how many identifiers are on the current data declaration - line in case we're given the BIND(C) attribute with a NAME= specifier. */ -static int num_idents_on_line; -/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we - can supply a name if the curr_binding_label is nil and NAME= was not. */ -static int has_name_equals = 0; - -/* Initializer of the previous enumerator. */ - -static gfc_expr *last_initializer; - -/* History of all the enumerators is maintained, so that - kind values of all the enumerators could be updated depending - upon the maximum initialized value. */ - -typedef struct enumerator_history -{ - gfc_symbol *sym; - gfc_expr *initializer; - struct enumerator_history *next; -} -enumerator_history; - -/* Header of enum history chain. */ - -static enumerator_history *enum_history = NULL; - -/* Pointer of enum history node containing largest initializer. */ - -static enumerator_history *max_enum = NULL; - -/* gfc_new_block points to the symbol of a newly matched block. */ - -gfc_symbol *gfc_new_block; - -bool gfc_matching_function; - -/* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */ -int directive_unroll = -1; - -/* Set upon parsing supported !GCC$ pragmas for use in the next loop. */ -bool directive_ivdep = false; -bool directive_vector = false; -bool directive_novector = false; - -/* Map of middle-end built-ins that should be vectorized. */ -hash_map *gfc_vectorized_builtins; - -/* If a kind expression of a component of a parameterized derived type is - parameterized, temporarily store the expression here. */ -static gfc_expr *saved_kind_expr = NULL; - -/* Used to store the parameter list arising in a PDT declaration and - in the typespec of a PDT variable or component. */ -static gfc_actual_arglist *decl_type_param_list; -static gfc_actual_arglist *type_param_spec_list; - -/********************* DATA statement subroutines *********************/ - -static bool in_match_data = false; - -bool -gfc_in_match_data (void) -{ - return in_match_data; -} - -static void -set_in_match_data (bool set_value) -{ - in_match_data = set_value; -} - -/* Free a gfc_data_variable structure and everything beneath it. */ - -static void -free_variable (gfc_data_variable *p) -{ - gfc_data_variable *q; - - for (; p; p = q) - { - q = p->next; - gfc_free_expr (p->expr); - gfc_free_iterator (&p->iter, 0); - free_variable (p->list); - free (p); - } -} - - -/* Free a gfc_data_value structure and everything beneath it. */ - -static void -free_value (gfc_data_value *p) -{ - gfc_data_value *q; - - for (; p; p = q) - { - q = p->next; - mpz_clear (p->repeat); - gfc_free_expr (p->expr); - free (p); - } -} - - -/* Free a list of gfc_data structures. */ - -void -gfc_free_data (gfc_data *p) -{ - gfc_data *q; - - for (; p; p = q) - { - q = p->next; - free_variable (p->var); - free_value (p->value); - free (p); - } -} - - -/* Free all data in a namespace. */ - -static void -gfc_free_data_all (gfc_namespace *ns) -{ - gfc_data *d; - - for (;ns->data;) - { - d = ns->data->next; - free (ns->data); - ns->data = d; - } -} - -/* Reject data parsed since the last restore point was marked. */ - -void -gfc_reject_data (gfc_namespace *ns) -{ - gfc_data *d; - - while (ns->data && ns->data != ns->old_data) - { - d = ns->data->next; - free (ns->data); - ns->data = d; - } -} - -static match var_element (gfc_data_variable *); - -/* Match a list of variables terminated by an iterator and a right - parenthesis. */ - -static match -var_list (gfc_data_variable *parent) -{ - gfc_data_variable *tail, var; - match m; - - m = var_element (&var); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - goto syntax; - - tail = gfc_get_data_variable (); - *tail = var; - - parent->list = tail; - - for (;;) - { - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = gfc_match_iterator (&parent->iter, 1); - if (m == MATCH_YES) - break; - if (m == MATCH_ERROR) - return MATCH_ERROR; - - m = var_element (&var); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - goto syntax; - - tail->next = gfc_get_data_variable (); - tail = tail->next; - - *tail = var; - } - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_DATA); - return MATCH_ERROR; -} - - -/* Match a single element in a data variable list, which can be a - variable-iterator list. */ - -static match -var_element (gfc_data_variable *new_var) -{ - match m; - gfc_symbol *sym; - - memset (new_var, 0, sizeof (gfc_data_variable)); - - if (gfc_match_char ('(') == MATCH_YES) - return var_list (new_var); - - m = gfc_match_variable (&new_var->expr, 0); - if (m != MATCH_YES) - return m; - - if (new_var->expr->expr_type == EXPR_CONSTANT - && new_var->expr->symtree == NULL) - { - gfc_error ("Inquiry parameter cannot appear in a " - "data-stmt-object-list at %C"); - return MATCH_ERROR; - } - - sym = new_var->expr->symtree->n.sym; - - /* Symbol should already have an associated type. */ - if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus)) - return MATCH_ERROR; - - if (!sym->attr.function && gfc_current_ns->parent - && gfc_current_ns->parent == sym->ns) - { - gfc_error ("Host associated variable %qs may not be in the DATA " - "statement at %C", sym->name); - return MATCH_ERROR; - } - - if (gfc_current_state () != COMP_BLOCK_DATA - && sym->attr.in_common - && !gfc_notify_std (GFC_STD_GNU, "initialization of " - "common block variable %qs in DATA statement at %C", - sym->name)) - return MATCH_ERROR; - - if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* Match the top-level list of data variables. */ - -static match -top_var_list (gfc_data *d) -{ - gfc_data_variable var, *tail, *new_var; - match m; - - tail = NULL; - - for (;;) - { - m = var_element (&var); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return MATCH_ERROR; - - new_var = gfc_get_data_variable (); - *new_var = var; - if (new_var->expr) - new_var->expr->where = gfc_current_locus; - - if (tail == NULL) - d->var = new_var; - else - tail->next = new_var; - - tail = new_var; - - if (gfc_match_char ('/') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_DATA); - gfc_free_data_all (gfc_current_ns); - return MATCH_ERROR; -} - - -static match -match_data_constant (gfc_expr **result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym, *dt_sym = NULL; - gfc_expr *expr; - match m; - locus old_loc; - - m = gfc_match_literal_constant (&expr, 1); - if (m == MATCH_YES) - { - *result = expr; - return MATCH_YES; - } - - if (m == MATCH_ERROR) - return MATCH_ERROR; - - m = gfc_match_null (result); - if (m != MATCH_NO) - return m; - - old_loc = gfc_current_locus; - - /* Should this be a structure component, try to match it - before matching a name. */ - m = gfc_match_rvalue (result); - if (m == MATCH_ERROR) - return m; - - if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE) - { - if (!gfc_simplify_expr (*result, 0)) - m = MATCH_ERROR; - return m; - } - else if (m == MATCH_YES) - { - /* If a parameter inquiry ends up here, symtree is NULL but **result - contains the right constant expression. Check here. */ - if ((*result)->symtree == NULL - && (*result)->expr_type == EXPR_CONSTANT - && ((*result)->ts.type == BT_INTEGER - || (*result)->ts.type == BT_REAL)) - return m; - - /* F2018:R845 data-stmt-constant is initial-data-target. - A data-stmt-constant shall be ... initial-data-target if and - only if the corresponding data-stmt-object has the POINTER - attribute. ... If data-stmt-constant is initial-data-target - the corresponding data statement object shall be - data-pointer-initialization compatible (7.5.4.6) with the initial - data target; the data statement object is initially associated - with the target. */ - if ((*result)->symtree->n.sym->attr.save - && (*result)->symtree->n.sym->attr.target) - return m; - gfc_free_expr (*result); - } - - gfc_current_locus = old_loc; - - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - if (gfc_find_symbol (name, NULL, 1, &sym)) - return MATCH_ERROR; - - if (sym && sym->attr.generic) - dt_sym = gfc_find_dt_in_generic (sym); - - if (sym == NULL - || (sym->attr.flavor != FL_PARAMETER - && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor)))) - { - gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", - name); - *result = NULL; - return MATCH_ERROR; - } - else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)) - return gfc_match_structure_constructor (dt_sym, result); - - /* Check to see if the value is an initialization array expression. */ - if (sym->value->expr_type == EXPR_ARRAY) - { - gfc_current_locus = old_loc; - - m = gfc_match_init_expr (result); - if (m == MATCH_ERROR) - return m; - - if (m == MATCH_YES) - { - if (!gfc_simplify_expr (*result, 0)) - m = MATCH_ERROR; - - if ((*result)->expr_type == EXPR_CONSTANT) - return m; - else - { - gfc_error ("Invalid initializer %s in Data statement at %C", name); - return MATCH_ERROR; - } - } - } - - *result = gfc_copy_expr (sym->value); - return MATCH_YES; -} - - -/* Match a list of values in a DATA statement. The leading '/' has - already been seen at this point. */ - -static match -top_val_list (gfc_data *data) -{ - gfc_data_value *new_val, *tail; - gfc_expr *expr; - match m; - - tail = NULL; - - for (;;) - { - m = match_data_constant (&expr); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return MATCH_ERROR; - - new_val = gfc_get_data_value (); - mpz_init (new_val->repeat); - - if (tail == NULL) - data->value = new_val; - else - tail->next = new_val; - - tail = new_val; - - if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) - { - tail->expr = expr; - mpz_set_ui (tail->repeat, 1); - } - else - { - mpz_set (tail->repeat, expr->value.integer); - gfc_free_expr (expr); - - m = match_data_constant (&tail->expr); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return MATCH_ERROR; - } - - if (gfc_match_char ('/') == MATCH_YES) - break; - if (gfc_match_char (',') == MATCH_NO) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_DATA); - gfc_free_data_all (gfc_current_ns); - return MATCH_ERROR; -} - - -/* Matches an old style initialization. */ - -static match -match_old_style_init (const char *name) -{ - match m; - gfc_symtree *st; - gfc_symbol *sym; - gfc_data *newdata, *nd; - - /* Set up data structure to hold initializers. */ - gfc_find_sym_tree (name, NULL, 0, &st); - sym = st->n.sym; - - newdata = gfc_get_data (); - newdata->var = gfc_get_data_variable (); - newdata->var->expr = gfc_get_variable_expr (st); - newdata->var->expr->where = sym->declared_at; - newdata->where = gfc_current_locus; - - /* Match initial value list. This also eats the terminal '/'. */ - m = top_val_list (newdata); - if (m != MATCH_YES) - { - free (newdata); - return m; - } - - /* Check that a BOZ did not creep into an old-style initialization. */ - for (nd = newdata; nd; nd = nd->next) - { - if (nd->value->expr->ts.type == BT_BOZ - && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style " - "initialization"), &nd->value->expr->where)) - return MATCH_ERROR; - - if (nd->var->expr->ts.type != BT_INTEGER - && nd->var->expr->ts.type != BT_REAL - && nd->value->expr->ts.type == BT_BOZ) - { - gfc_error (G_("BOZ literal constant near %L cannot be assigned to " - "a %qs variable in an old-style initialization"), - &nd->value->expr->where, - gfc_typename (&nd->value->expr->ts)); - return MATCH_ERROR; - } - } - - if (gfc_pure (NULL)) - { - gfc_error ("Initialization at %C is not allowed in a PURE procedure"); - free (newdata); - return MATCH_ERROR; - } - gfc_unset_implicit_pure (gfc_current_ns->proc_name); - - /* Mark the variable as having appeared in a data statement. */ - if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at)) - { - free (newdata); - return MATCH_ERROR; - } - - /* Chain in namespace list of DATA initializers. */ - newdata->next = gfc_current_ns->data; - gfc_current_ns->data = newdata; - - return m; -} - - -/* Match the stuff following a DATA statement. If ERROR_FLAG is set, - we are matching a DATA statement and are therefore issuing an error - if we encounter something unexpected, if not, we're trying to match - an old-style initialization expression of the form INTEGER I /2/. */ - -match -gfc_match_data (void) -{ - gfc_data *new_data; - gfc_expr *e; - gfc_ref *ref; - match m; - char c; - - /* DATA has been matched. In free form source code, the next character - needs to be whitespace or '(' from an implied do-loop. Check that - here. */ - c = gfc_peek_ascii_char (); - if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(') - return MATCH_NO; - - /* Before parsing the rest of a DATA statement, check F2008:c1206. */ - if ((gfc_current_state () == COMP_FUNCTION - || gfc_current_state () == COMP_SUBROUTINE) - && gfc_state_stack->previous->state == COMP_INTERFACE) - { - gfc_error ("DATA statement at %C cannot appear within an INTERFACE"); - return MATCH_ERROR; - } - - set_in_match_data (true); - - for (;;) - { - new_data = gfc_get_data (); - new_data->where = gfc_current_locus; - - m = top_var_list (new_data); - if (m != MATCH_YES) - goto cleanup; - - if (new_data->var->iter.var - && new_data->var->iter.var->ts.type == BT_INTEGER - && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1 - && new_data->var->list - && new_data->var->list->expr - && new_data->var->list->expr->ts.type == BT_CHARACTER - && new_data->var->list->expr->ref - && new_data->var->list->expr->ref->type == REF_SUBSTRING) - { - gfc_error ("Invalid substring in data-implied-do at %L in DATA " - "statement", &new_data->var->list->expr->where); - goto cleanup; - } - - /* Check for an entity with an allocatable component, which is not - allowed. */ - e = new_data->var->expr; - if (e) - { - bool invalid; - - invalid = false; - for (ref = e->ref; ref; ref = ref->next) - if ((ref->type == REF_COMPONENT - && ref->u.c.component->attr.allocatable) - || (ref->type == REF_ARRAY - && e->symtree->n.sym->attr.pointer != 1 - && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED)) - invalid = true; - - if (invalid) - { - gfc_error ("Allocatable component or deferred-shaped array " - "near %C in DATA statement"); - goto cleanup; - } - - /* F2008:C567 (R536) A data-i-do-object or a variable that appears - as a data-stmt-object shall not be an object designator in which - a pointer appears other than as the entire rightmost part-ref. */ - if (!e->ref && e->ts.type == BT_DERIVED - && e->symtree->n.sym->attr.pointer) - goto partref; - - ref = e->ref; - if (e->symtree->n.sym->ts.type == BT_DERIVED - && e->symtree->n.sym->attr.pointer - && ref->type == REF_COMPONENT) - goto partref; - - for (; ref; ref = ref->next) - if (ref->type == REF_COMPONENT - && ref->u.c.component->attr.pointer - && ref->next) - goto partref; - } - - m = top_val_list (new_data); - if (m != MATCH_YES) - goto cleanup; - - new_data->next = gfc_current_ns->data; - gfc_current_ns->data = new_data; - - /* A BOZ literal constant cannot appear in a structure constructor. - Check for that here for a data statement value. */ - if (new_data->value->expr->ts.type == BT_DERIVED - && new_data->value->expr->value.constructor) - { - gfc_constructor *c; - c = gfc_constructor_first (new_data->value->expr->value.constructor); - for (; c; c = gfc_constructor_next (c)) - if (c->expr && c->expr->ts.type == BT_BOZ) - { - gfc_error ("BOZ literal constant at %L cannot appear in a " - "structure constructor", &c->expr->where); - return MATCH_ERROR; - } - } - - if (gfc_match_eos () == MATCH_YES) - break; - - gfc_match_char (','); /* Optional comma */ - } - - set_in_match_data (false); - - if (gfc_pure (NULL)) - { - gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); - return MATCH_ERROR; - } - gfc_unset_implicit_pure (gfc_current_ns->proc_name); - - return MATCH_YES; - -partref: - - gfc_error ("part-ref with pointer attribute near %L is not " - "rightmost part-ref of data-stmt-object", - &e->where); - -cleanup: - set_in_match_data (false); - gfc_free_data (new_data); - return MATCH_ERROR; -} - - -/************************ Declaration statements *********************/ - - -/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization - list). The difference here is the expression is a list of constants - and is surrounded by '/'. - The typespec ts must match the typespec of the variable which the - clist is initializing. - The arrayspec tells whether this should match a list of constants - corresponding to array elements or a scalar (as == NULL). */ - -static match -match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) -{ - gfc_constructor_base array_head = NULL; - gfc_expr *expr = NULL; - match m = MATCH_ERROR; - locus where; - mpz_t repeat, cons_size, as_size; - bool scalar; - int cmp; - - gcc_assert (ts); - - /* We have already matched '/' - now look for a constant list, as with - top_val_list from decl.c, but append the result to an array. */ - if (gfc_match ("/") == MATCH_YES) - { - gfc_error ("Empty old style initializer list at %C"); - return MATCH_ERROR; - } - - where = gfc_current_locus; - scalar = !as || !as->rank; - - if (!scalar && !spec_size (as, &as_size)) - { - gfc_error ("Array in initializer list at %L must have an explicit shape", - as->type == AS_EXPLICIT ? &as->upper[0]->where : &where); - /* Nothing to cleanup yet. */ - return MATCH_ERROR; - } - - mpz_init_set_ui (repeat, 0); - - for (;;) - { - m = match_data_constant (&expr); - if (m != MATCH_YES) - expr = NULL; /* match_data_constant may set expr to garbage */ - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - /* Found r in repeat spec r*c; look for the constant to repeat. */ - if ( gfc_match_char ('*') == MATCH_YES) - { - if (scalar) - { - gfc_error ("Repeat spec invalid in scalar initializer at %C"); - goto cleanup; - } - if (expr->ts.type != BT_INTEGER) - { - gfc_error ("Repeat spec must be an integer at %C"); - goto cleanup; - } - mpz_set (repeat, expr->value.integer); - gfc_free_expr (expr); - expr = NULL; - - m = match_data_constant (&expr); - if (m == MATCH_NO) - { - m = MATCH_ERROR; - gfc_error ("Expected data constant after repeat spec at %C"); - } - if (m != MATCH_YES) - goto cleanup; - } - /* No repeat spec, we matched the data constant itself. */ - else - mpz_set_ui (repeat, 1); - - if (!scalar) - { - /* Add the constant initializer as many times as repeated. */ - for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1)) - { - /* Make sure types of elements match */ - if(ts && !gfc_compare_types (&expr->ts, ts) - && !gfc_convert_type (expr, ts, 1)) - goto cleanup; - - gfc_constructor_append_expr (&array_head, - gfc_copy_expr (expr), &gfc_current_locus); - } - - gfc_free_expr (expr); - expr = NULL; - } - - /* For scalar initializers quit after one element. */ - else - { - if(gfc_match_char ('/') != MATCH_YES) - { - gfc_error ("End of scalar initializer expected at %C"); - goto cleanup; - } - break; - } - - if (gfc_match_char ('/') == MATCH_YES) - break; - if (gfc_match_char (',') == MATCH_NO) - goto syntax; - } - - /* If we break early from here out, we encountered an error. */ - m = MATCH_ERROR; - - /* Set up expr as an array constructor. */ - if (!scalar) - { - expr = gfc_get_array_expr (ts->type, ts->kind, &where); - expr->ts = *ts; - expr->value.constructor = array_head; - - /* Validate sizes. We built expr ourselves, so cons_size will be - constant (we fail above for non-constant expressions). - We still need to verify that the sizes match. */ - gcc_assert (gfc_array_size (expr, &cons_size)); - cmp = mpz_cmp (cons_size, as_size); - if (cmp < 0) - gfc_error ("Not enough elements in array initializer at %C"); - else if (cmp > 0) - gfc_error ("Too many elements in array initializer at %C"); - mpz_clear (cons_size); - if (cmp) - goto cleanup; - - /* Set the rank/shape to match the LHS as auto-reshape is implied. */ - expr->rank = as->rank; - expr->shape = gfc_get_shape (as->rank); - for (int i = 0; i < as->rank; ++i) - spec_dimen_size (as, i, &expr->shape[i]); - } - - /* Make sure scalar types match. */ - else if (!gfc_compare_types (&expr->ts, ts) - && !gfc_convert_type (expr, ts, 1)) - goto cleanup; - - if (expr->ts.u.cl) - expr->ts.u.cl->length_from_typespec = 1; - - *result = expr; - m = MATCH_YES; - goto done; - -syntax: - m = MATCH_ERROR; - gfc_error ("Syntax error in old style initializer list at %C"); - -cleanup: - if (expr) - expr->value.constructor = NULL; - gfc_free_expr (expr); - gfc_constructor_free (array_head); - -done: - mpz_clear (repeat); - if (!scalar) - mpz_clear (as_size); - return m; -} - - -/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */ - -static bool -merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) -{ - if ((from->type == AS_ASSUMED_RANK && to->corank) - || (to->type == AS_ASSUMED_RANK && from->corank)) - { - gfc_error ("The assumed-rank array at %C shall not have a codimension"); - return false; - } - - if (to->rank == 0 && from->rank > 0) - { - to->rank = from->rank; - to->type = from->type; - to->cray_pointee = from->cray_pointee; - to->cp_was_assumed = from->cp_was_assumed; - - for (int i = to->corank - 1; i >= 0; i--) - { - /* Do not exceed the limits on lower[] and upper[]. gfortran - cleans up elsewhere. */ - int j = from->rank + i; - if (j >= GFC_MAX_DIMENSIONS) - break; - - to->lower[j] = to->lower[i]; - to->upper[j] = to->upper[i]; - } - for (int i = 0; i < from->rank; i++) - { - if (copy) - { - to->lower[i] = gfc_copy_expr (from->lower[i]); - to->upper[i] = gfc_copy_expr (from->upper[i]); - } - else - { - to->lower[i] = from->lower[i]; - to->upper[i] = from->upper[i]; - } - } - } - else if (to->corank == 0 && from->corank > 0) - { - to->corank = from->corank; - to->cotype = from->cotype; - - for (int i = 0; i < from->corank; i++) - { - /* Do not exceed the limits on lower[] and upper[]. gfortran - cleans up elsewhere. */ - int k = from->rank + i; - int j = to->rank + i; - if (j >= GFC_MAX_DIMENSIONS) - break; - - if (copy) - { - to->lower[j] = gfc_copy_expr (from->lower[k]); - to->upper[j] = gfc_copy_expr (from->upper[k]); - } - else - { - to->lower[j] = from->lower[k]; - to->upper[j] = from->upper[k]; - } - } - } - - if (to->rank + to->corank > GFC_MAX_DIMENSIONS) - { - gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum " - "allowed dimensions of %d", - to->rank, to->corank, GFC_MAX_DIMENSIONS); - to->corank = GFC_MAX_DIMENSIONS - to->rank; - return false; - } - return true; -} - - -/* Match an intent specification. Since this can only happen after an - INTENT word, a legal intent-spec must follow. */ - -static sym_intent -match_intent_spec (void) -{ - - if (gfc_match (" ( in out )") == MATCH_YES) - return INTENT_INOUT; - if (gfc_match (" ( in )") == MATCH_YES) - return INTENT_IN; - if (gfc_match (" ( out )") == MATCH_YES) - return INTENT_OUT; - - gfc_error ("Bad INTENT specification at %C"); - return INTENT_UNKNOWN; -} - - -/* Matches a character length specification, which is either a - specification expression, '*', or ':'. */ - -static match -char_len_param_value (gfc_expr **expr, bool *deferred) -{ - match m; - - *expr = NULL; - *deferred = false; - - if (gfc_match_char ('*') == MATCH_YES) - return MATCH_YES; - - if (gfc_match_char (':') == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C")) - return MATCH_ERROR; - - *deferred = true; - - return MATCH_YES; - } - - m = gfc_match_expr (expr); - - if (m == MATCH_NO || m == MATCH_ERROR) - return m; - - if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) - return MATCH_ERROR; - - /* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things - like CHARACTER(([1])). */ - if ((*expr)->expr_type == EXPR_OP) - gfc_simplify_expr (*expr, 1); - - if ((*expr)->expr_type == EXPR_FUNCTION) - { - if ((*expr)->ts.type == BT_INTEGER - || ((*expr)->ts.type == BT_UNKNOWN - && strcmp((*expr)->symtree->name, "null") != 0)) - return MATCH_YES; - - goto syntax; - } - else if ((*expr)->expr_type == EXPR_CONSTANT) - { - /* F2008, 4.4.3.1: The length is a type parameter; its kind is - processor dependent and its value is greater than or equal to zero. - F2008, 4.4.3.2: If the character length parameter value evaluates - to a negative value, the length of character entities declared - is zero. */ - - if ((*expr)->ts.type == BT_INTEGER) - { - if (mpz_cmp_si ((*expr)->value.integer, 0) < 0) - mpz_set_si ((*expr)->value.integer, 0); - } - else - goto syntax; - } - else if ((*expr)->expr_type == EXPR_ARRAY) - goto syntax; - else if ((*expr)->expr_type == EXPR_VARIABLE) - { - bool t; - gfc_expr *e; - - e = gfc_copy_expr (*expr); - - /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']", - which causes an ICE if gfc_reduce_init_expr() is called. */ - if (e->ref && e->ref->type == REF_ARRAY - && e->ref->u.ar.type == AR_UNKNOWN - && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) - goto syntax; - - t = gfc_reduce_init_expr (e); - - if (!t && e->ts.type == BT_UNKNOWN - && e->symtree->n.sym->attr.untyped == 1 - && (flag_implicit_none - || e->symtree->n.sym->ns->seen_implicit_none == 1 - || e->symtree->n.sym->ns->parent->seen_implicit_none == 1)) - { - gfc_free_expr (e); - goto syntax; - } - - if ((e->ref && e->ref->type == REF_ARRAY - && e->ref->u.ar.type != AR_ELEMENT) - || (!e->ref && e->expr_type == EXPR_ARRAY)) - { - gfc_free_expr (e); - goto syntax; - } - - gfc_free_expr (e); - } - - if (gfc_seen_div0) - m = MATCH_ERROR; - - return m; - -syntax: - gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where); - return MATCH_ERROR; -} - - -/* A character length is a '*' followed by a literal integer or a - char_len_param_value in parenthesis. */ - -static match -match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) -{ - int length; - match m; - - *deferred = false; - m = gfc_match_char ('*'); - if (m != MATCH_YES) - return m; - - m = gfc_match_small_literal_int (&length, NULL); - if (m == MATCH_ERROR) - return m; - - if (m == MATCH_YES) - { - if (obsolescent_check - && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C")) - return MATCH_ERROR; - *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length); - return m; - } - - if (gfc_match_char ('(') == MATCH_NO) - goto syntax; - - m = char_len_param_value (expr, deferred); - if (m != MATCH_YES && gfc_matching_function) - { - gfc_undo_symbols (); - m = MATCH_YES; - } - - if (m == MATCH_ERROR) - return m; - if (m == MATCH_NO) - goto syntax; - - if (gfc_match_char (')') == MATCH_NO) - { - gfc_free_expr (*expr); - *expr = NULL; - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in character length specification at %C"); - return MATCH_ERROR; -} - - -/* Special subroutine for finding a symbol. Check if the name is found - in the current name space. If not, and we're compiling a function or - subroutine and the parent compilation unit is an interface, then check - to see if the name we've been given is the name of the interface - (located in another namespace). */ - -static int -find_special (const char *name, gfc_symbol **result, bool allow_subroutine) -{ - gfc_state_data *s; - gfc_symtree *st; - int i; - - i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine); - if (i == 0) - { - *result = st ? st->n.sym : NULL; - goto end; - } - - if (gfc_current_state () != COMP_SUBROUTINE - && gfc_current_state () != COMP_FUNCTION) - goto end; - - s = gfc_state_stack->previous; - if (s == NULL) - goto end; - - if (s->state != COMP_INTERFACE) - goto end; - if (s->sym == NULL) - goto end; /* Nameless interface. */ - - if (strcmp (name, s->sym->name) == 0) - { - *result = s->sym; - return 0; - } - -end: - return i; -} - - -/* Special subroutine for getting a symbol node associated with a - procedure name, used in SUBROUTINE and FUNCTION statements. The - symbol is created in the parent using with symtree node in the - child unit pointing to the symbol. If the current namespace has no - parent, then the symbol is just created in the current unit. */ - -static int -get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) -{ - gfc_symtree *st; - gfc_symbol *sym; - int rc = 0; - - /* Module functions have to be left in their own namespace because - they have potentially (almost certainly!) already been referenced. - In this sense, they are rather like external functions. This is - fixed up in resolve.c(resolve_entries), where the symbol name- - space is set to point to the master function, so that the fake - result mechanism can work. */ - if (module_fcn_entry) - { - /* Present if entry is declared to be a module procedure. */ - rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result); - - if (*result == NULL) - rc = gfc_get_symbol (name, NULL, result); - else if (!gfc_get_symbol (name, NULL, &sym) && sym - && (*result)->ts.type == BT_UNKNOWN - && sym->attr.flavor == FL_UNKNOWN) - /* Pick up the typespec for the entry, if declared in the function - body. Note that this symbol is FL_UNKNOWN because it will - only have appeared in a type declaration. The local symtree - is set to point to the module symbol and a unique symtree - to the local version. This latter ensures a correct clearing - of the symbols. */ - { - /* If the ENTRY proceeds its specification, we need to ensure - that this does not raise a "has no IMPLICIT type" error. */ - if (sym->ts.type == BT_UNKNOWN) - sym->attr.untyped = 1; - - (*result)->ts = sym->ts; - - /* Put the symbol in the procedure namespace so that, should - the ENTRY precede its specification, the specification - can be applied. */ - (*result)->ns = gfc_current_ns; - - gfc_find_sym_tree (name, gfc_current_ns, 0, &st); - st->n.sym = *result; - st = gfc_get_unique_symtree (gfc_current_ns); - sym->refs++; - st->n.sym = sym; - } - } - else - rc = gfc_get_symbol (name, gfc_current_ns->parent, result); - - if (rc) - return rc; - - sym = *result; - if (sym->attr.proc == PROC_ST_FUNCTION) - return rc; - - if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY) - { - /* Create a partially populated interface symbol to carry the - characteristics of the procedure and the result. */ - sym->tlink = gfc_new_symbol (name, sym->ns); - gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus); - gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL); - if (sym->attr.dimension) - sym->tlink->as = gfc_copy_array_spec (sym->as); - - /* Ideally, at this point, a copy would be made of the formal - arguments and their namespace. However, this does not appear - to be necessary, albeit at the expense of not being able to - use gfc_compare_interfaces directly. */ - - if (sym->result && sym->result != sym) - { - sym->tlink->result = sym->result; - sym->result = NULL; - } - else if (sym->result) - { - sym->tlink->result = sym->tlink; - } - } - else if (sym && !sym->gfc_new - && gfc_current_state () != COMP_INTERFACE) - { - /* Trap another encompassed procedure with the same name. All - these conditions are necessary to avoid picking up an entry - whose name clashes with that of the encompassing procedure; - this is handled using gsymbols to register unique, globally - accessible names. */ - if (sym->attr.flavor != 0 - && sym->attr.proc != 0 - && (sym->attr.subroutine || sym->attr.function || sym->attr.entry) - && sym->attr.if_source != IFSRC_UNKNOWN) - { - gfc_error_now ("Procedure %qs at %C is already defined at %L", - name, &sym->declared_at); - return true; - } - if (sym->attr.flavor != 0 - && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN) - { - gfc_error_now ("Procedure %qs at %C is already defined at %L", - name, &sym->declared_at); - return true; - } - - if (sym->attr.external && sym->attr.procedure - && gfc_current_state () == COMP_CONTAINS) - { - gfc_error_now ("Contained procedure %qs at %C clashes with " - "procedure defined at %L", - name, &sym->declared_at); - return true; - } - - /* Trap a procedure with a name the same as interface in the - encompassing scope. */ - if (sym->attr.generic != 0 - && (sym->attr.subroutine || sym->attr.function) - && !sym->attr.mod_proc) - { - gfc_error_now ("Name %qs at %C is already defined" - " as a generic interface at %L", - name, &sym->declared_at); - return true; - } - - /* Trap declarations of attributes in encompassing scope. The - signature for this is that ts.kind is nonzero for no-CLASS - entity. For a CLASS entity, ts.kind is zero. */ - if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS) - && !sym->attr.implicit_type - && sym->attr.proc == 0 - && gfc_current_ns->parent != NULL - && sym->attr.access == 0 - && !module_fcn_entry) - { - gfc_error_now ("Procedure %qs at %C has an explicit interface " - "from a previous declaration", name); - return true; - } - } - - /* C1246 (R1225) MODULE shall appear only in the function-stmt or - subroutine-stmt of a module subprogram or of a nonabstract interface - body that is declared in the scoping unit of a module or submodule. */ - if (sym->attr.external - && (sym->attr.subroutine || sym->attr.function) - && sym->attr.if_source == IFSRC_IFBODY - && !current_attr.module_procedure - && sym->attr.proc == PROC_MODULE - && gfc_state_stack->state == COMP_CONTAINS) - { - gfc_error_now ("Procedure %qs defined in interface body at %L " - "clashes with internal procedure defined at %C", - name, &sym->declared_at); - return true; - } - - if (sym && !sym->gfc_new - && sym->attr.flavor != FL_UNKNOWN - && sym->attr.referenced == 0 && sym->attr.subroutine == 1 - && gfc_state_stack->state == COMP_CONTAINS - && gfc_state_stack->previous->state == COMP_SUBROUTINE) - { - gfc_error_now ("Procedure %qs at %C is already defined at %L", - name, &sym->declared_at); - return true; - } - - if (gfc_current_ns->parent == NULL || *result == NULL) - return rc; - - /* Module function entries will already have a symtree in - the current namespace but will need one at module level. */ - if (module_fcn_entry) - { - /* Present if entry is declared to be a module procedure. */ - rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st); - if (st == NULL) - st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name); - } - else - st = gfc_new_symtree (&gfc_current_ns->sym_root, name); - - st->n.sym = sym; - sym->refs++; - - /* See if the procedure should be a module procedure. */ - - if (((sym->ns->proc_name != NULL - && sym->ns->proc_name->attr.flavor == FL_MODULE - && sym->attr.proc != PROC_MODULE) - || (module_fcn_entry && sym->attr.proc != PROC_MODULE)) - && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) - rc = 2; - - return rc; -} - - -/* Verify that the given symbol representing a parameter is C - interoperable, by checking to see if it was marked as such after - its declaration. If the given symbol is not interoperable, a - warning is reported, thus removing the need to return the status to - the calling function. The standard does not require the user use - one of the iso_c_binding named constants to declare an - interoperable parameter, but we can't be sure if the param is C - interop or not if the user doesn't. For example, integer(4) may be - legal Fortran, but doesn't have meaning in C. It may interop with - a number of the C types, which causes a problem because the - compiler can't know which one. This code is almost certainly not - portable, and the user will get what they deserve if the C type - across platforms isn't always interoperable with integer(4). If - the user had used something like integer(c_int) or integer(c_long), - the compiler could have automatically handled the varying sizes - across platforms. */ - -bool -gfc_verify_c_interop_param (gfc_symbol *sym) -{ - int is_c_interop = 0; - bool retval = true; - - /* We check implicitly typed variables in symbol.c:gfc_set_default_type(). - Don't repeat the checks here. */ - if (sym->attr.implicit_type) - return true; - - /* For subroutines or functions that are passed to a BIND(C) procedure, - they're interoperable if they're BIND(C) and their params are all - interoperable. */ - if (sym->attr.flavor == FL_PROCEDURE) - { - if (sym->attr.is_bind_c == 0) - { - gfc_error_now ("Procedure %qs at %L must have the BIND(C) " - "attribute to be C interoperable", sym->name, - &(sym->declared_at)); - return false; - } - else - { - if (sym->attr.is_c_interop == 1) - /* We've already checked this procedure; don't check it again. */ - return true; - else - return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, - sym->common_block); - } - } - - /* See if we've stored a reference to a procedure that owns sym. */ - if (sym->ns != NULL && sym->ns->proc_name != NULL) - { - if (sym->ns->proc_name->attr.is_bind_c == 1) - { - is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0); - - if (is_c_interop != 1) - { - /* Make personalized messages to give better feedback. */ - if (sym->ts.type == BT_DERIVED) - gfc_error ("Variable %qs at %L is a dummy argument to the " - "BIND(C) procedure %qs but is not C interoperable " - "because derived type %qs is not C interoperable", - sym->name, &(sym->declared_at), - sym->ns->proc_name->name, - sym->ts.u.derived->name); - else if (sym->ts.type == BT_CLASS) - gfc_error ("Variable %qs at %L is a dummy argument to the " - "BIND(C) procedure %qs but is not C interoperable " - "because it is polymorphic", - sym->name, &(sym->declared_at), - sym->ns->proc_name->name); - else if (warn_c_binding_type) - gfc_warning (OPT_Wc_binding_type, - "Variable %qs at %L is a dummy argument of the " - "BIND(C) procedure %qs but may not be C " - "interoperable", - sym->name, &(sym->declared_at), - sym->ns->proc_name->name); - } - - /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */ - if (sym->attr.pointer && sym->attr.contiguous) - gfc_error ("Dummy argument %qs at %L may not be a pointer with " - "CONTIGUOUS attribute as procedure %qs is BIND(C)", - sym->name, &sym->declared_at, sym->ns->proc_name->name); - - /* Per F2018, C1557, pointer/allocatable dummies to a bind(c) - procedure that are default-initialized are not permitted. */ - if ((sym->attr.pointer || sym->attr.allocatable) - && sym->ts.type == BT_DERIVED - && gfc_has_default_initializer (sym->ts.u.derived)) - { - gfc_error ("Default-initialized %s dummy argument %qs " - "at %L is not permitted in BIND(C) procedure %qs", - (sym->attr.pointer ? "pointer" : "allocatable"), - sym->name, &sym->declared_at, - sym->ns->proc_name->name); - retval = false; - } - - /* Character strings are only C interoperable if they have a - length of 1. However, as an argument they are also iteroperable - when passed as descriptor (which requires len=: or len=*). */ - if (sym->ts.type == BT_CHARACTER) - { - gfc_charlen *cl = sym->ts.u.cl; - - if (sym->attr.allocatable || sym->attr.pointer) - { - /* F2018, 18.3.6 (6). */ - if (!sym->ts.deferred) - { - if (sym->attr.allocatable) - gfc_error ("Allocatable character dummy argument %qs " - "at %L must have deferred length as " - "procedure %qs is BIND(C)", sym->name, - &sym->declared_at, sym->ns->proc_name->name); - else - gfc_error ("Pointer character dummy argument %qs at %L " - "must have deferred length as procedure %qs " - "is BIND(C)", sym->name, &sym->declared_at, - sym->ns->proc_name->name); - retval = false; - } - else if (!gfc_notify_std (GFC_STD_F2018, - "Deferred-length character dummy " - "argument %qs at %L of procedure " - "%qs with BIND(C) attribute", - sym->name, &sym->declared_at, - sym->ns->proc_name->name)) - retval = false; - } - else if (sym->attr.value - && (!cl || !cl->length - || cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (cl->length->value.integer, 1) != 0)) - { - gfc_error ("Character dummy argument %qs at %L must be " - "of length 1 as it has the VALUE attribute", - sym->name, &sym->declared_at); - retval = false; - } - else if (!cl || !cl->length) - { - /* Assumed length; F2018, 18.3.6 (5)(2). - Uses the CFI array descriptor - also for scalars and - explicit-size/assumed-size arrays. */ - if (!gfc_notify_std (GFC_STD_F2018, - "Assumed-length character dummy argument " - "%qs at %L of procedure %qs with BIND(C) " - "attribute", sym->name, &sym->declared_at, - sym->ns->proc_name->name)) - retval = false; - } - else if (cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (cl->length->value.integer, 1) != 0) - { - /* F2018, 18.3.6, (5), item 4. */ - if (!sym->attr.dimension - || sym->as->type == AS_ASSUMED_SIZE - || sym->as->type == AS_EXPLICIT) - { - gfc_error ("Character dummy argument %qs at %L must be " - "of constant length of one or assumed length, " - "unless it has assumed shape or assumed rank, " - "as procedure %qs has the BIND(C) attribute", - sym->name, &sym->declared_at, - sym->ns->proc_name->name); - retval = false; - } - /* else: valid only since F2018 - and an assumed-shape/rank - array; however, gfc_notify_std is already called when - those array types are used. Thus, silently accept F200x. */ - } - } - - /* We have to make sure that any param to a bind(c) routine does - not have the allocatable, pointer, or optional attributes, - according to J3/04-007, section 5.1. */ - if (sym->attr.allocatable == 1 - && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with " - "ALLOCATABLE attribute in procedure %qs " - "with BIND(C)", sym->name, - &(sym->declared_at), - sym->ns->proc_name->name)) - retval = false; - - if (sym->attr.pointer == 1 - && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with " - "POINTER attribute in procedure %qs " - "with BIND(C)", sym->name, - &(sym->declared_at), - sym->ns->proc_name->name)) - retval = false; - - if (sym->attr.optional == 1 && sym->attr.value) - { - gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " - "and the VALUE attribute because procedure %qs " - "is BIND(C)", sym->name, &(sym->declared_at), - sym->ns->proc_name->name); - retval = false; - } - else if (sym->attr.optional == 1 - && !gfc_notify_std (GFC_STD_F2018, "Variable %qs " - "at %L with OPTIONAL attribute in " - "procedure %qs which is BIND(C)", - sym->name, &(sym->declared_at), - sym->ns->proc_name->name)) - retval = false; - - /* Make sure that if it has the dimension attribute, that it is - either assumed size or explicit shape. Deferred shape is already - covered by the pointer/allocatable attribute. */ - if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE - && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs " - "at %L as dummy argument to the BIND(C) " - "procedure %qs at %L", sym->name, - &(sym->declared_at), - sym->ns->proc_name->name, - &(sym->ns->proc_name->declared_at))) - retval = false; - } - } - - return retval; -} - - - -/* Function called by variable_decl() that adds a name to the symbol table. */ - -static bool -build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, - gfc_array_spec **as, locus *var_locus) -{ - symbol_attribute attr; - gfc_symbol *sym; - int upper; - gfc_symtree *st; - - /* Symbols in a submodule are host associated from the parent module or - submodules. Therefore, they can be overridden by declarations in the - submodule scope. Deal with this by attaching the existing symbol to - a new symtree and recycling the old symtree with a new symbol... */ - st = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE - && st->n.sym != NULL - && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule) - { - gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); - s->n.sym = st->n.sym; - sym = gfc_new_symbol (name, gfc_current_ns); - - - st->n.sym = sym; - sym->refs++; - gfc_set_sym_referenced (sym); - } - /* ...Otherwise generate a new symtree and new symbol. */ - else if (gfc_get_symbol (name, NULL, &sym)) - return false; - - /* Check if the name has already been defined as a type. The - first letter of the symtree will be in upper case then. Of - course, this is only necessary if the upper case letter is - actually different. */ - - upper = TOUPPER(name[0]); - if (upper != name[0]) - { - char u_name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symtree *st; - - gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN); - strcpy (u_name, name); - u_name[0] = upper; - - st = gfc_find_symtree (gfc_current_ns->sym_root, u_name); - - /* STRUCTURE types can alias symbol names */ - if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT) - { - gfc_error ("Symbol %qs at %C also declared as a type at %L", name, - &st->n.sym->declared_at); - return false; - } - } - - /* Start updating the symbol table. Add basic type attribute if present. */ - if (current_ts.type != BT_UNKNOWN - && (sym->attr.implicit_type == 0 - || !gfc_compare_types (&sym->ts, ¤t_ts)) - && !gfc_add_type (sym, ¤t_ts, var_locus)) - return false; - - if (sym->ts.type == BT_CHARACTER) - { - sym->ts.u.cl = cl; - sym->ts.deferred = cl_deferred; - } - - /* Add dimension attribute if present. */ - if (!gfc_set_array_spec (sym, *as, var_locus)) - return false; - *as = NULL; - - /* Add attribute to symbol. The copy is so that we can reset the - dimension attribute. */ - attr = current_attr; - attr.dimension = 0; - attr.codimension = 0; - - if (!gfc_copy_attr (&sym->attr, &attr, var_locus)) - return false; - - /* Finish any work that may need to be done for the binding label, - if it's a bind(c). The bind(c) attr is found before the symbol - is made, and before the symbol name (for data decls), so the - current_ts is holding the binding label, or nothing if the - name= attr wasn't given. Therefore, test here if we're dealing - with a bind(c) and make sure the binding label is set correctly. */ - if (sym->attr.is_bind_c == 1) - { - if (!sym->binding_label) - { - /* Set the binding label and verify that if a NAME= was specified - then only one identifier was in the entity-decl-list. */ - if (!set_binding_label (&sym->binding_label, sym->name, - num_idents_on_line)) - return false; - } - } - - /* See if we know we're in a common block, and if it's a bind(c) - common then we need to make sure we're an interoperable type. */ - if (sym->attr.in_common == 1) - { - /* Test the common block object. */ - if (sym->common_block != NULL && sym->common_block->is_bind_c == 1 - && sym->ts.is_c_interop != 1) - { - gfc_error_now ("Variable %qs in common block %qs at %C " - "must be declared with a C interoperable " - "kind since common block %qs is BIND(C)", - sym->name, sym->common_block->name, - sym->common_block->name); - gfc_clear_error (); - } - } - - sym->attr.implied_index = 0; - - /* Use the parameter expressions for a parameterized derived type. */ - if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) - && sym->ts.u.derived->attr.pdt_type && type_param_spec_list) - sym->param_list = gfc_copy_actual_arglist (type_param_spec_list); - - if (sym->ts.type == BT_CLASS) - return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); - - return true; -} - - -/* Set character constant to the given length. The constant will be padded or - truncated. If we're inside an array constructor without a typespec, we - additionally check that all elements have the same length; check_len -1 - means no checking. */ - -void -gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr, - gfc_charlen_t check_len) -{ - gfc_char_t *s; - gfc_charlen_t slen; - - if (expr->ts.type != BT_CHARACTER) - return; - - if (expr->expr_type != EXPR_CONSTANT) - { - gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where); - return; - } - - slen = expr->value.character.length; - if (len != slen) - { - s = gfc_get_wide_string (len + 1); - memcpy (s, expr->value.character.string, - MIN (len, slen) * sizeof (gfc_char_t)); - if (len > slen) - gfc_wide_memset (&s[slen], ' ', len - slen); - - if (warn_character_truncation && slen > len) - gfc_warning_now (OPT_Wcharacter_truncation, - "CHARACTER expression at %L is being truncated " - "(%ld/%ld)", &expr->where, - (long) slen, (long) len); - - /* Apply the standard by 'hand' otherwise it gets cleared for - initializers. */ - if (check_len != -1 && slen != check_len - && !(gfc_option.allow_std & GFC_STD_GNU)) - gfc_error_now ("The CHARACTER elements of the array constructor " - "at %L must have the same length (%ld/%ld)", - &expr->where, (long) slen, - (long) check_len); - - s[len] = '\0'; - free (expr->value.character.string); - expr->value.character.string = s; - expr->value.character.length = len; - /* If explicit representation was given, clear it - as it is no longer needed after padding. */ - if (expr->representation.length) - { - expr->representation.length = 0; - free (expr->representation.string); - expr->representation.string = NULL; - } - } -} - - -/* Function to create and update the enumerator history - using the information passed as arguments. - Pointer "max_enum" is also updated, to point to - enum history node containing largest initializer. - - SYM points to the symbol node of enumerator. - INIT points to its enumerator value. */ - -static void -create_enum_history (gfc_symbol *sym, gfc_expr *init) -{ - enumerator_history *new_enum_history; - gcc_assert (sym != NULL && init != NULL); - - new_enum_history = XCNEW (enumerator_history); - - new_enum_history->sym = sym; - new_enum_history->initializer = init; - new_enum_history->next = NULL; - - if (enum_history == NULL) - { - enum_history = new_enum_history; - max_enum = enum_history; - } - else - { - new_enum_history->next = enum_history; - enum_history = new_enum_history; - - if (mpz_cmp (max_enum->initializer->value.integer, - new_enum_history->initializer->value.integer) < 0) - max_enum = new_enum_history; - } -} - - -/* Function to free enum kind history. */ - -void -gfc_free_enum_history (void) -{ - enumerator_history *current = enum_history; - enumerator_history *next; - - while (current != NULL) - { - next = current->next; - free (current); - current = next; - } - max_enum = NULL; - enum_history = NULL; -} - - -/* Function called by variable_decl() that adds an initialization - expression to a symbol. */ - -static bool -add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) -{ - symbol_attribute attr; - gfc_symbol *sym; - gfc_expr *init; - - init = *initp; - if (find_special (name, &sym, false)) - return false; - - attr = sym->attr; - - /* If this symbol is confirming an implicit parameter type, - then an initialization expression is not allowed. */ - if (attr.flavor == FL_PARAMETER && sym->value != NULL) - { - if (*initp != NULL) - { - gfc_error ("Initializer not allowed for PARAMETER %qs at %C", - sym->name); - return false; - } - else - return true; - } - - if (init == NULL) - { - /* An initializer is required for PARAMETER declarations. */ - if (attr.flavor == FL_PARAMETER) - { - gfc_error ("PARAMETER at %L is missing an initializer", var_locus); - return false; - } - } - else - { - /* If a variable appears in a DATA block, it cannot have an - initializer. */ - if (sym->attr.data) - { - gfc_error ("Variable %qs at %C with an initializer already " - "appears in a DATA statement", sym->name); - return false; - } - - /* Check if the assignment can happen. This has to be put off - until later for derived type variables and procedure pointers. */ - if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type) - && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS - && !sym->attr.proc_pointer - && !gfc_check_assign_symbol (sym, NULL, init)) - return false; - - if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl - && init->ts.type == BT_CHARACTER) - { - /* Update symbol character length according initializer. */ - if (!gfc_check_assign_symbol (sym, NULL, init)) - return false; - - if (sym->ts.u.cl->length == NULL) - { - gfc_charlen_t clen; - /* If there are multiple CHARACTER variables declared on the - same line, we don't want them to share the same length. */ - sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - - if (sym->attr.flavor == FL_PARAMETER) - { - if (init->expr_type == EXPR_CONSTANT) - { - clen = init->value.character.length; - sym->ts.u.cl->length - = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, clen); - } - else if (init->expr_type == EXPR_ARRAY) - { - if (init->ts.u.cl && init->ts.u.cl->length) - { - const gfc_expr *length = init->ts.u.cl->length; - if (length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Cannot initialize parameter array " - "at %L " - "with variable length elements", - &sym->declared_at); - return false; - } - clen = mpz_get_si (length->value.integer); - } - else if (init->value.constructor) - { - gfc_constructor *c; - c = gfc_constructor_first (init->value.constructor); - clen = c->expr->value.character.length; - } - else - gcc_unreachable (); - sym->ts.u.cl->length - = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, clen); - } - else if (init->ts.u.cl && init->ts.u.cl->length) - sym->ts.u.cl->length = - gfc_copy_expr (init->ts.u.cl->length); - } - } - /* Update initializer character length according symbol. */ - else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - if (!gfc_specification_expr (sym->ts.u.cl->length)) - return false; - - int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, - false); - /* resolve_charlen will complain later on if the length - is too large. Just skeep the initialization in that case. */ - if (mpz_cmp (sym->ts.u.cl->length->value.integer, - gfc_integer_kinds[k].huge) <= 0) - { - HOST_WIDE_INT len - = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer); - - if (init->expr_type == EXPR_CONSTANT) - gfc_set_constant_character_len (len, init, -1); - else if (init->expr_type == EXPR_ARRAY) - { - gfc_constructor *c; - - /* Build a new charlen to prevent simplification from - deleting the length before it is resolved. */ - init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - init->ts.u.cl->length - = gfc_copy_expr (sym->ts.u.cl->length); - - for (c = gfc_constructor_first (init->value.constructor); - c; c = gfc_constructor_next (c)) - gfc_set_constant_character_len (len, c->expr, -1); - } - } - } - } - - if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as - && sym->as->rank && init->rank && init->rank != sym->as->rank) - { - gfc_error ("Rank mismatch of array at %L and its initializer " - "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank); - return false; - } - - /* If sym is implied-shape, set its upper bounds from init. */ - if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension - && sym->as->type == AS_IMPLIED_SHAPE) - { - int dim; - - if (init->rank == 0) - { - gfc_error ("Cannot initialize implied-shape array at %L" - " with scalar", &sym->declared_at); - return false; - } - - /* The shape may be NULL for EXPR_ARRAY, set it. */ - if (init->shape == NULL) - { - gcc_assert (init->expr_type == EXPR_ARRAY); - init->shape = gfc_get_shape (1); - if (!gfc_array_size (init, &init->shape[0])) - gfc_internal_error ("gfc_array_size failed"); - } - - for (dim = 0; dim < sym->as->rank; ++dim) - { - int k; - gfc_expr *e, *lower; - - lower = sym->as->lower[dim]; - - /* If the lower bound is an array element from another - parameterized array, then it is marked with EXPR_VARIABLE and - is an initialization expression. Try to reduce it. */ - if (lower->expr_type == EXPR_VARIABLE) - gfc_reduce_init_expr (lower); - - if (lower->expr_type == EXPR_CONSTANT) - { - /* All dimensions must be without upper bound. */ - gcc_assert (!sym->as->upper[dim]); - - k = lower->ts.kind; - e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); - mpz_add (e->value.integer, lower->value.integer, - init->shape[dim]); - mpz_sub_ui (e->value.integer, e->value.integer, 1); - sym->as->upper[dim] = e; - } - else - { - gfc_error ("Non-constant lower bound in implied-shape" - " declaration at %L", &lower->where); - return false; - } - } - - sym->as->type = AS_EXPLICIT; - } - - /* Ensure that explicit bounds are simplified. */ - if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension - && sym->as->type == AS_EXPLICIT) - { - for (int dim = 0; dim < sym->as->rank; ++dim) - { - gfc_expr *e; - - e = sym->as->lower[dim]; - if (e->expr_type != EXPR_CONSTANT) - gfc_reduce_init_expr (e); - - e = sym->as->upper[dim]; - if (e->expr_type != EXPR_CONSTANT) - gfc_reduce_init_expr (e); - } - } - - /* Need to check if the expression we initialized this - to was one of the iso_c_binding named constants. If so, - and we're a parameter (constant), let it be iso_c. - For example: - integer(c_int), parameter :: my_int = c_int - integer(my_int) :: my_int_2 - If we mark my_int as iso_c (since we can see it's value - is equal to one of the named constants), then my_int_2 - will be considered C interoperable. */ - if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type)) - { - sym->ts.is_iso_c |= init->ts.is_iso_c; - sym->ts.is_c_interop |= init->ts.is_c_interop; - /* attr bits needed for module files. */ - sym->attr.is_iso_c |= init->ts.is_iso_c; - sym->attr.is_c_interop |= init->ts.is_c_interop; - if (init->ts.is_iso_c) - sym->ts.f90_type = init->ts.f90_type; - } - - /* Add initializer. Make sure we keep the ranks sane. */ - if (sym->attr.dimension && init->rank == 0) - { - mpz_t size; - gfc_expr *array; - int n; - if (sym->attr.flavor == FL_PARAMETER - && gfc_is_constant_expr (init) - && (init->expr_type == EXPR_CONSTANT - || init->expr_type == EXPR_STRUCTURE) - && spec_size (sym->as, &size) - && mpz_cmp_si (size, 0) > 0) - { - array = gfc_get_array_expr (init->ts.type, init->ts.kind, - &init->where); - if (init->ts.type == BT_DERIVED) - array->ts.u.derived = init->ts.u.derived; - for (n = 0; n < (int)mpz_get_si (size); n++) - gfc_constructor_append_expr (&array->value.constructor, - n == 0 - ? init - : gfc_copy_expr (init), - &init->where); - - array->shape = gfc_get_shape (sym->as->rank); - for (n = 0; n < sym->as->rank; n++) - spec_dimen_size (sym->as, n, &array->shape[n]); - - init = array; - mpz_clear (size); - } - init->rank = sym->as->rank; - } - - sym->value = init; - if (sym->attr.save == SAVE_NONE) - sym->attr.save = SAVE_IMPLICIT; - *initp = NULL; - } - - return true; -} - - -/* Function called by variable_decl() that adds a name to a structure - being built. */ - -static bool -build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, - gfc_array_spec **as) -{ - gfc_state_data *s; - gfc_component *c; - - /* F03:C438/C439. If the current symbol is of the same derived type that we're - constructing, it must have the pointer attribute. */ - if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) - && current_ts.u.derived == gfc_current_block () - && current_attr.pointer == 0) - { - if (current_attr.allocatable - && !gfc_notify_std(GFC_STD_F2008, "Component at %C " - "must have the POINTER attribute")) - { - return false; - } - else if (current_attr.allocatable == 0) - { - gfc_error ("Component at %C must have the POINTER attribute"); - return false; - } - } - - /* F03:C437. */ - if (current_ts.type == BT_CLASS - && !(current_attr.pointer || current_attr.allocatable)) - { - gfc_error ("Component %qs with CLASS at %C must be allocatable " - "or pointer", name); - return false; - } - - if (gfc_current_block ()->attr.pointer && (*as)->rank != 0) - { - if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT) - { - gfc_error ("Array component of structure at %C must have explicit " - "or deferred shape"); - return false; - } - } - - /* If we are in a nested union/map definition, gfc_add_component will not - properly find repeated components because: - (i) gfc_add_component does a flat search, where components of unions - and maps are implicity chained so nested components may conflict. - (ii) Unions and maps are not linked as components of their parent - structures until after they are parsed. - For (i) we use gfc_find_component which searches recursively, and for (ii) - we search each block directly from the parse stack until we find the top - level structure. */ - - s = gfc_state_stack; - if (s->state == COMP_UNION || s->state == COMP_MAP) - { - while (s->state == COMP_UNION || gfc_comp_struct (s->state)) - { - c = gfc_find_component (s->sym, name, true, true, NULL); - if (c != NULL) - { - gfc_error_now ("Component %qs at %C already declared at %L", - name, &c->loc); - return false; - } - /* Break after we've searched the entire chain. */ - if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE) - break; - s = s->previous; - } - } - - if (!gfc_add_component (gfc_current_block(), name, &c)) - return false; - - c->ts = current_ts; - if (c->ts.type == BT_CHARACTER) - c->ts.u.cl = cl; - - if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED - && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER) - && saved_kind_expr != NULL) - c->kind_expr = gfc_copy_expr (saved_kind_expr); - - c->attr = current_attr; - - c->initializer = *init; - *init = NULL; - - c->as = *as; - if (c->as != NULL) - { - if (c->as->corank) - c->attr.codimension = 1; - if (c->as->rank) - c->attr.dimension = 1; - } - *as = NULL; - - gfc_apply_init (&c->ts, &c->attr, c->initializer); - - /* Check array components. */ - if (!c->attr.dimension) - goto scalar; - - if (c->attr.pointer) - { - if (c->as->type != AS_DEFERRED) - { - gfc_error ("Pointer array component of structure at %C must have a " - "deferred shape"); - return false; - } - } - else if (c->attr.allocatable) - { - if (c->as->type != AS_DEFERRED) - { - gfc_error ("Allocatable component of structure at %C must have a " - "deferred shape"); - return false; - } - } - else - { - if (c->as->type != AS_EXPLICIT) - { - gfc_error ("Array component of structure at %C must have an " - "explicit shape"); - return false; - } - } - -scalar: - if (c->ts.type == BT_CLASS) - return gfc_build_class_symbol (&c->ts, &c->attr, &c->as); - - if (c->attr.pdt_kind || c->attr.pdt_len) - { - gfc_symbol *sym; - gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived, - 0, &sym); - if (sym == NULL) - { - gfc_error ("Type parameter %qs at %C has no corresponding entry " - "in the type parameter name list at %L", - c->name, &gfc_current_block ()->declared_at); - return false; - } - sym->ts = c->ts; - sym->attr.pdt_kind = c->attr.pdt_kind; - sym->attr.pdt_len = c->attr.pdt_len; - if (c->initializer) - sym->value = gfc_copy_expr (c->initializer); - sym->attr.flavor = FL_VARIABLE; - } - - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived && c->ts.u.derived->attr.pdt_template - && decl_type_param_list) - c->param_list = gfc_copy_actual_arglist (decl_type_param_list); - - return true; -} - - -/* Match a 'NULL()', and possibly take care of some side effects. */ - -match -gfc_match_null (gfc_expr **result) -{ - gfc_symbol *sym; - match m, m2 = MATCH_NO; - - if ((m = gfc_match (" null ( )")) == MATCH_ERROR) - return MATCH_ERROR; - - if (m == MATCH_NO) - { - locus old_loc; - char name[GFC_MAX_SYMBOL_LEN + 1]; - - if ((m2 = gfc_match (" null (")) != MATCH_YES) - return m2; - - old_loc = gfc_current_locus; - if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR) - return MATCH_ERROR; - if (m2 != MATCH_YES - && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR)) - return MATCH_ERROR; - if (m2 == MATCH_NO) - { - gfc_current_locus = old_loc; - return MATCH_NO; - } - } - - /* The NULL symbol now has to be/become an intrinsic function. */ - if (gfc_get_symbol ("null", NULL, &sym)) - { - gfc_error ("NULL() initialization at %C is ambiguous"); - return MATCH_ERROR; - } - - gfc_intrinsic_symbol (sym); - - if (sym->attr.proc != PROC_INTRINSIC - && !(sym->attr.use_assoc && sym->attr.intrinsic) - && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL) - || !gfc_add_function (&sym->attr, sym->name, NULL))) - return MATCH_ERROR; - - *result = gfc_get_null_expr (&gfc_current_locus); - - /* Invalid per F2008, C512. */ - if (m2 == MATCH_YES) - { - gfc_error ("NULL() initialization at %C may not have MOLD"); - return MATCH_ERROR; - } - - return MATCH_YES; -} - - -/* Match the initialization expr for a data pointer or procedure pointer. */ - -static match -match_pointer_init (gfc_expr **init, int procptr) -{ - match m; - - if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state)) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - return MATCH_ERROR; - } - gfc_unset_implicit_pure (gfc_current_ns->proc_name); - - /* Match NULL() initialization. */ - m = gfc_match_null (init); - if (m != MATCH_NO) - return m; - - /* Match non-NULL initialization. */ - gfc_matching_ptr_assignment = !procptr; - gfc_matching_procptr_assignment = procptr; - m = gfc_match_rvalue (init); - gfc_matching_ptr_assignment = 0; - gfc_matching_procptr_assignment = 0; - if (m == MATCH_ERROR) - return MATCH_ERROR; - else if (m == MATCH_NO) - { - gfc_error ("Error in pointer initialization at %C"); - return MATCH_ERROR; - } - - if (!procptr && !gfc_resolve_expr (*init)) - return MATCH_ERROR; - - if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer " - "initialization at %C")) - return MATCH_ERROR; - - return MATCH_YES; -} - - -static bool -check_function_name (char *name) -{ - /* In functions that have a RESULT variable defined, the function name always - refers to function calls. Therefore, the name is not allowed to appear in - specification statements. When checking this, be careful about - 'hidden' procedure pointer results ('ppr@'). */ - - if (gfc_current_state () == COMP_FUNCTION) - { - gfc_symbol *block = gfc_current_block (); - if (block && block->result && block->result != block - && strcmp (block->result->name, "ppr@") != 0 - && strcmp (block->name, name) == 0) - { - gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C " - "from appearing in a specification statement", - block->result->name, &block->result->declared_at, name); - return false; - } - } - - return true; -} - - -/* Match a variable name with an optional initializer. When this - subroutine is called, a variable is expected to be parsed next. - Depending on what is happening at the moment, updates either the - symbol table or the current interface. */ - -static match -variable_decl (int elem) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - static unsigned int fill_id = 0; - gfc_expr *initializer, *char_len; - gfc_array_spec *as; - gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ - gfc_charlen *cl; - bool cl_deferred; - locus var_locus; - match m; - bool t; - gfc_symbol *sym; - char c; - - initializer = NULL; - as = NULL; - cp_as = NULL; - - /* When we get here, we've just matched a list of attributes and - maybe a type and a double colon. The next thing we expect to see - is the name of the symbol. */ - - /* If we are parsing a structure with legacy support, we allow the symbol - name to be '%FILL' which gives it an anonymous (inaccessible) name. */ - m = MATCH_NO; - gfc_gobble_whitespace (); - c = gfc_peek_ascii_char (); - if (c == '%') - { - gfc_next_ascii_char (); /* Burn % character. */ - m = gfc_match ("fill"); - if (m == MATCH_YES) - { - if (gfc_current_state () != COMP_STRUCTURE) - { - if (flag_dec_structure) - gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL"); - else - gfc_error ("%qs at %C is a DEC extension, enable with " - "%<-fdec-structure%>", "%FILL"); - m = MATCH_ERROR; - goto cleanup; - } - - if (attr_seen) - { - gfc_error ("%qs entity cannot have attributes at %C", "%FILL"); - m = MATCH_ERROR; - goto cleanup; - } - - /* %FILL components are given invalid fortran names. */ - snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++); - } - else - { - gfc_error ("Invalid character %qc in variable name at %C", c); - return MATCH_ERROR; - } - } - else - { - m = gfc_match_name (name); - if (m != MATCH_YES) - goto cleanup; - } - - var_locus = gfc_current_locus; - - /* Now we could see the optional array spec. or character length. */ - m = gfc_match_array_spec (&as, true, true); - if (m == MATCH_ERROR) - goto cleanup; - - if (m == MATCH_NO) - as = gfc_copy_array_spec (current_as); - else if (current_as - && !merge_array_spec (current_as, as, true)) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (flag_cray_pointer) - cp_as = gfc_copy_array_spec (as); - - /* At this point, we know for sure if the symbol is PARAMETER and can thus - determine (and check) whether it can be implied-shape. If it - was parsed as assumed-size, change it because PARAMETERs cannot - be assumed-size. - - An explicit-shape-array cannot appear under several conditions. - That check is done here as well. */ - if (as) - { - if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) - { - m = MATCH_ERROR; - gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape", - name, &var_locus); - goto cleanup; - } - - if (as->type == AS_ASSUMED_SIZE && as->rank == 1 - && current_attr.flavor == FL_PARAMETER) - as->type = AS_IMPLIED_SHAPE; - - if (as->type == AS_IMPLIED_SHAPE - && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L", - &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - - gfc_seen_div0 = false; - - /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not - constant expressions shall appear only in a subprogram, derived - type definition, BLOCK construct, or interface body. */ - if (as->type == AS_EXPLICIT - && gfc_current_state () != COMP_BLOCK - && gfc_current_state () != COMP_DERIVED - && gfc_current_state () != COMP_FUNCTION - && gfc_current_state () != COMP_INTERFACE - && gfc_current_state () != COMP_SUBROUTINE) - { - gfc_expr *e; - bool not_constant = false; - - for (int i = 0; i < as->rank; i++) - { - e = gfc_copy_expr (as->lower[i]); - if (!gfc_resolve_expr (e) && gfc_seen_div0) - { - m = MATCH_ERROR; - goto cleanup; - } - - gfc_simplify_expr (e, 0); - if (e && (e->expr_type != EXPR_CONSTANT)) - { - not_constant = true; - break; - } - gfc_free_expr (e); - - e = gfc_copy_expr (as->upper[i]); - if (!gfc_resolve_expr (e) && gfc_seen_div0) - { - m = MATCH_ERROR; - goto cleanup; - } - - gfc_simplify_expr (e, 0); - if (e && (e->expr_type != EXPR_CONSTANT)) - { - not_constant = true; - break; - } - gfc_free_expr (e); - } - - if (not_constant && e->ts.type != BT_INTEGER) - { - gfc_error ("Explicit array shape at %C must be constant of " - "INTEGER type and not %s type", - gfc_basic_typename (e->ts.type)); - m = MATCH_ERROR; - goto cleanup; - } - if (not_constant) - { - gfc_error ("Explicit shaped array with nonconstant bounds at %C"); - m = MATCH_ERROR; - goto cleanup; - } - } - if (as->type == AS_EXPLICIT) - { - for (int i = 0; i < as->rank; i++) - { - gfc_expr *e, *n; - e = as->lower[i]; - if (e->expr_type != EXPR_CONSTANT) - { - n = gfc_copy_expr (e); - if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (n->expr_type == EXPR_CONSTANT) - gfc_replace_expr (e, n); - else - gfc_free_expr (n); - } - e = as->upper[i]; - if (e->expr_type != EXPR_CONSTANT) - { - n = gfc_copy_expr (e); - if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (n->expr_type == EXPR_CONSTANT) - gfc_replace_expr (e, n); - else - gfc_free_expr (n); - } - } - } - } - - char_len = NULL; - cl = NULL; - cl_deferred = false; - - if (current_ts.type == BT_CHARACTER) - { - switch (match_char_length (&char_len, &cl_deferred, false)) - { - case MATCH_YES: - cl = gfc_new_charlen (gfc_current_ns, NULL); - - cl->length = char_len; - break; - - /* Non-constant lengths need to be copied after the first - element. Also copy assumed lengths. */ - case MATCH_NO: - if (elem > 1 - && (current_ts.u.cl->length == NULL - || current_ts.u.cl->length->expr_type != EXPR_CONSTANT)) - { - cl = gfc_new_charlen (gfc_current_ns, NULL); - cl->length = gfc_copy_expr (current_ts.u.cl->length); - } - else - cl = current_ts.u.cl; - - cl_deferred = current_ts.deferred; - - break; - - case MATCH_ERROR: - goto cleanup; - } - } - - /* The dummy arguments and result of the abreviated form of MODULE - PROCEDUREs, used in SUBMODULES should not be redefined. */ - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->abr_modproc_decl) - { - gfc_find_symbol (name, gfc_current_ns, 1, &sym); - if (sym != NULL && (sym->attr.dummy || sym->attr.result)) - { - m = MATCH_ERROR; - gfc_error ("%qs at %C is a redefinition of the declaration " - "in the corresponding interface for MODULE " - "PROCEDURE %qs", sym->name, - gfc_current_ns->proc_name->name); - goto cleanup; - } - } - - /* %FILL components may not have initializers. */ - if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES) - { - gfc_error ("%qs entity cannot have an initializer at %C", "%FILL"); - m = MATCH_ERROR; - goto cleanup; - } - - /* If this symbol has already shown up in a Cray Pointer declaration, - and this is not a component declaration, - then we want to set the type & bail out. */ - if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ())) - { - gfc_find_symbol (name, gfc_current_ns, 0, &sym); - if (sym != NULL && sym->attr.cray_pointee) - { - m = MATCH_YES; - if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - - /* Check to see if we have an array specification. */ - if (cp_as != NULL) - { - if (sym->as != NULL) - { - gfc_error ("Duplicate array spec for Cray pointee at %C"); - gfc_free_array_spec (cp_as); - m = MATCH_ERROR; - goto cleanup; - } - else - { - if (!gfc_set_array_spec (sym, cp_as, &var_locus)) - gfc_internal_error ("Cannot set pointee array spec."); - - /* Fix the array spec. */ - m = gfc_mod_pointee_as (sym->as); - if (m == MATCH_ERROR) - goto cleanup; - } - } - goto cleanup; - } - else - { - gfc_free_array_spec (cp_as); - } - } - - /* Procedure pointer as function result. */ - if (gfc_current_state () == COMP_FUNCTION - && strcmp ("ppr@", gfc_current_block ()->name) == 0 - && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0) - strcpy (name, "ppr@"); - - if (gfc_current_state () == COMP_FUNCTION - && strcmp (name, gfc_current_block ()->name) == 0 - && gfc_current_block ()->result - && strcmp ("ppr@", gfc_current_block ()->result->name) == 0) - strcpy (name, "ppr@"); - - /* OK, we've successfully matched the declaration. Now put the - symbol in the current namespace, because it might be used in the - optional initialization expression for this symbol, e.g. this is - perfectly legal: - - integer, parameter :: i = huge(i) - - This is only true for parameters or variables of a basic type. - For components of derived types, it is not true, so we don't - create a symbol for those yet. If we fail to create the symbol, - bail out. */ - if (!gfc_comp_struct (gfc_current_state ()) - && !build_sym (name, cl, cl_deferred, &as, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (!check_function_name (name)) - { - m = MATCH_ERROR; - goto cleanup; - } - - /* We allow old-style initializations of the form - integer i /2/, j(4) /3*3, 1/ - (if no colon has been seen). These are different from data - statements in that initializers are only allowed to apply to the - variable immediately preceding, i.e. - integer i, j /1, 2/ - is not allowed. Therefore we have to do some work manually, that - could otherwise be left to the matchers for DATA statements. */ - - if (!colon_seen && gfc_match (" /") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_GNU, "Old-style " - "initialization at %C")) - return MATCH_ERROR; - - /* Allow old style initializations for components of STRUCTUREs and MAPs - but not components of derived types. */ - else if (gfc_current_state () == COMP_DERIVED) - { - gfc_error ("Invalid old style initialization for derived type " - "component at %C"); - m = MATCH_ERROR; - goto cleanup; - } - - /* For structure components, read the initializer as a special - expression and let the rest of this function apply the initializer - as usual. */ - else if (gfc_comp_struct (gfc_current_state ())) - { - m = match_clist_expr (&initializer, ¤t_ts, as); - if (m == MATCH_NO) - gfc_error ("Syntax error in old style initialization of %s at %C", - name); - if (m != MATCH_YES) - goto cleanup; - } - - /* Otherwise we treat the old style initialization just like a - DATA declaration for the current variable. */ - else - return match_old_style_init (name); - } - - /* The double colon must be present in order to have initializers. - Otherwise the statement is ambiguous with an assignment statement. */ - if (colon_seen) - { - if (gfc_match (" =>") == MATCH_YES) - { - if (!current_attr.pointer) - { - gfc_error ("Initialization at %C isn't for a pointer variable"); - m = MATCH_ERROR; - goto cleanup; - } - - m = match_pointer_init (&initializer, 0); - if (m != MATCH_YES) - goto cleanup; - - /* The target of a pointer initialization must have the SAVE - attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope - is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */ - if (initializer->expr_type == EXPR_VARIABLE - && initializer->symtree->n.sym->attr.save == SAVE_NONE - && (gfc_current_state () == COMP_PROGRAM - || gfc_current_state () == COMP_MODULE - || gfc_current_state () == COMP_SUBMODULE)) - initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT; - } - else if (gfc_match_char ('=') == MATCH_YES) - { - if (current_attr.pointer) - { - gfc_error ("Pointer initialization at %C requires %<=>%>, " - "not %<=%>"); - m = MATCH_ERROR; - goto cleanup; - } - - m = gfc_match_init_expr (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Expected an initialization expression at %C"); - m = MATCH_ERROR; - } - - if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL) - && !gfc_comp_struct (gfc_state_stack->state)) - { - gfc_error ("Initialization of variable at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } - - if (current_attr.flavor != FL_PARAMETER - && !gfc_comp_struct (gfc_state_stack->state)) - gfc_unset_implicit_pure (gfc_current_ns->proc_name); - - if (m != MATCH_YES) - goto cleanup; - } - } - - if (initializer != NULL && current_attr.allocatable - && gfc_comp_struct (gfc_current_state ())) - { - gfc_error ("Initialization of allocatable component at %C is not " - "allowed"); - m = MATCH_ERROR; - goto cleanup; - } - - if (gfc_current_state () == COMP_DERIVED - && initializer && initializer->ts.type == BT_HOLLERITH) - { - gfc_error ("Initialization of structure component with a HOLLERITH " - "constant at %L is not allowed", &initializer->where); - m = MATCH_ERROR; - goto cleanup; - } - - if (gfc_current_state () == COMP_DERIVED - && gfc_current_block ()->attr.pdt_template) - { - gfc_symbol *param; - gfc_find_symbol (name, gfc_current_block ()->f2k_derived, - 0, ¶m); - if (!param && (current_attr.pdt_kind || current_attr.pdt_len)) - { - gfc_error ("The component with KIND or LEN attribute at %C does not " - "not appear in the type parameter list at %L", - &gfc_current_block ()->declared_at); - m = MATCH_ERROR; - goto cleanup; - } - else if (param && !(current_attr.pdt_kind || current_attr.pdt_len)) - { - gfc_error ("The component at %C that appears in the type parameter " - "list at %L has neither the KIND nor LEN attribute", - &gfc_current_block ()->declared_at); - m = MATCH_ERROR; - goto cleanup; - } - else if (as && (current_attr.pdt_kind || current_attr.pdt_len)) - { - gfc_error ("The component at %C which is a type parameter must be " - "a scalar"); - m = MATCH_ERROR; - goto cleanup; - } - else if (param && initializer) - { - if (initializer->ts.type == BT_BOZ) - { - gfc_error ("BOZ literal constant at %L cannot appear as an " - "initializer", &initializer->where); - m = MATCH_ERROR; - goto cleanup; - } - param->value = gfc_copy_expr (initializer); - } - } - - /* Before adding a possible initilizer, do a simple check for compatibility - of lhs and rhs types. Assigning a REAL value to a derived type is not a - good thing. */ - if (current_ts.type == BT_DERIVED && initializer - && (gfc_numeric_ts (&initializer->ts) - || initializer->ts.type == BT_LOGICAL - || initializer->ts.type == BT_CHARACTER)) - { - gfc_error ("Incompatible initialization between a derived type " - "entity and an entity with %qs type at %C", - gfc_typename (initializer)); - m = MATCH_ERROR; - goto cleanup; - } - - - /* Add the initializer. Note that it is fine if initializer is - NULL here, because we sometimes also need to check if a - declaration *must* have an initialization expression. */ - if (!gfc_comp_struct (gfc_current_state ())) - t = add_init_expr_to_sym (name, &initializer, &var_locus); - else - { - if (current_ts.type == BT_DERIVED - && !current_attr.pointer && !initializer) - initializer = gfc_default_initializer (¤t_ts); - t = build_struct (name, cl, &initializer, &as); - - /* If we match a nested structure definition we expect to see the - * body even if the variable declarations blow up, so we need to keep - * the structure declaration around. */ - if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT) - gfc_commit_symbol (gfc_new_block); - } - - m = (t) ? MATCH_YES : MATCH_ERROR; - -cleanup: - /* Free stuff up and return. */ - gfc_seen_div0 = false; - gfc_free_expr (initializer); - gfc_free_array_spec (as); - - return m; -} - - -/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification. - This assumes that the byte size is equal to the kind number for - non-COMPLEX types, and equal to twice the kind number for COMPLEX. */ - -static match -gfc_match_old_kind_spec (gfc_typespec *ts) -{ - match m; - int original_kind; - - if (gfc_match_char ('*') != MATCH_YES) - return MATCH_NO; - - m = gfc_match_small_literal_int (&ts->kind, NULL); - if (m != MATCH_YES) - return MATCH_ERROR; - - original_kind = ts->kind; - - /* Massage the kind numbers for complex types. */ - if (ts->type == BT_COMPLEX) - { - if (ts->kind % 2) - { - gfc_error ("Old-style type declaration %s*%d not supported at %C", - gfc_basic_typename (ts->type), original_kind); - return MATCH_ERROR; - } - ts->kind /= 2; - - } - - if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) - ts->kind = 8; - - if (ts->type == BT_REAL || ts->type == BT_COMPLEX) - { - if (ts->kind == 4) - { - if (flag_real4_kind == 8) - ts->kind = 8; - if (flag_real4_kind == 10) - ts->kind = 10; - if (flag_real4_kind == 16) - ts->kind = 16; - } - else if (ts->kind == 8) - { - if (flag_real8_kind == 4) - ts->kind = 4; - if (flag_real8_kind == 10) - ts->kind = 10; - if (flag_real8_kind == 16) - ts->kind = 16; - } - } - - if (gfc_validate_kind (ts->type, ts->kind, true) < 0) - { - gfc_error ("Old-style type declaration %s*%d not supported at %C", - gfc_basic_typename (ts->type), original_kind); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_GNU, - "Nonstandard type declaration %s*%d at %C", - gfc_basic_typename(ts->type), original_kind)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* Match a kind specification. Since kinds are generally optional, we - usually return MATCH_NO if something goes wrong. If a "kind=" - string is found, then we know we have an error. */ - -match -gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) -{ - locus where, loc; - gfc_expr *e; - match m, n; - char c; - - m = MATCH_NO; - n = MATCH_YES; - e = NULL; - saved_kind_expr = NULL; - - where = loc = gfc_current_locus; - - if (kind_expr_only) - goto kind_expr; - - if (gfc_match_char ('(') == MATCH_NO) - return MATCH_NO; - - /* Also gobbles optional text. */ - if (gfc_match (" kind = ") == MATCH_YES) - m = MATCH_ERROR; - - loc = gfc_current_locus; - -kind_expr: - - n = gfc_match_init_expr (&e); - - if (gfc_derived_parameter_expr (e)) - { - ts->kind = 0; - saved_kind_expr = gfc_copy_expr (e); - goto close_brackets; - } - - if (n != MATCH_YES) - { - if (gfc_matching_function) - { - /* The function kind expression might include use associated or - imported parameters and try again after the specification - expressions..... */ - if (gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Missing right parenthesis at %C"); - m = MATCH_ERROR; - goto no_match; - } - - gfc_free_expr (e); - gfc_undo_symbols (); - return MATCH_YES; - } - else - { - /* ....or else, the match is real. */ - if (n == MATCH_NO) - gfc_error ("Expected initialization expression at %C"); - if (n != MATCH_YES) - return MATCH_ERROR; - } - } - - if (e->rank != 0) - { - gfc_error ("Expected scalar initialization expression at %C"); - m = MATCH_ERROR; - goto no_match; - } - - if (gfc_extract_int (e, &ts->kind, 1)) - { - m = MATCH_ERROR; - goto no_match; - } - - /* Before throwing away the expression, let's see if we had a - C interoperable kind (and store the fact). */ - if (e->ts.is_c_interop == 1) - { - /* Mark this as C interoperable if being declared with one - of the named constants from iso_c_binding. */ - ts->is_c_interop = e->ts.is_iso_c; - ts->f90_type = e->ts.f90_type; - if (e->symtree) - ts->interop_kind = e->symtree->n.sym; - } - - gfc_free_expr (e); - e = NULL; - - /* Ignore errors to this point, if we've gotten here. This means - we ignore the m=MATCH_ERROR from above. */ - if (gfc_validate_kind (ts->type, ts->kind, true) < 0) - { - gfc_error ("Kind %d not supported for type %s at %C", ts->kind, - gfc_basic_typename (ts->type)); - gfc_current_locus = where; - return MATCH_ERROR; - } - - /* Warn if, e.g., c_int is used for a REAL variable, but not - if, e.g., c_double is used for COMPLEX as the standard - explicitly says that the kind type parameter for complex and real - variable is the same, i.e. c_float == c_float_complex. */ - if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type - && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX) - || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL))) - gfc_warning_now (0, "C kind type parameter is for type %s but type at %L " - "is %s", gfc_basic_typename (ts->f90_type), &where, - gfc_basic_typename (ts->type)); - -close_brackets: - - gfc_gobble_whitespace (); - if ((c = gfc_next_ascii_char ()) != ')' - && (ts->type != BT_CHARACTER || c != ',')) - { - if (ts->type == BT_CHARACTER) - gfc_error ("Missing right parenthesis or comma at %C"); - else - gfc_error ("Missing right parenthesis at %C"); - m = MATCH_ERROR; - } - else - /* All tests passed. */ - m = MATCH_YES; - - if(m == MATCH_ERROR) - gfc_current_locus = where; - - if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) - ts->kind = 8; - - if (ts->type == BT_REAL || ts->type == BT_COMPLEX) - { - if (ts->kind == 4) - { - if (flag_real4_kind == 8) - ts->kind = 8; - if (flag_real4_kind == 10) - ts->kind = 10; - if (flag_real4_kind == 16) - ts->kind = 16; - } - else if (ts->kind == 8) - { - if (flag_real8_kind == 4) - ts->kind = 4; - if (flag_real8_kind == 10) - ts->kind = 10; - if (flag_real8_kind == 16) - ts->kind = 16; - } - } - - /* Return what we know from the test(s). */ - return m; - -no_match: - gfc_free_expr (e); - gfc_current_locus = where; - return m; -} - - -static match -match_char_kind (int * kind, int * is_iso_c) -{ - locus where; - gfc_expr *e; - match m, n; - bool fail; - - m = MATCH_NO; - e = NULL; - where = gfc_current_locus; - - n = gfc_match_init_expr (&e); - - if (n != MATCH_YES && gfc_matching_function) - { - /* The expression might include use-associated or imported - parameters and try again after the specification - expressions. */ - gfc_free_expr (e); - gfc_undo_symbols (); - return MATCH_YES; - } - - if (n == MATCH_NO) - gfc_error ("Expected initialization expression at %C"); - if (n != MATCH_YES) - return MATCH_ERROR; - - if (e->rank != 0) - { - gfc_error ("Expected scalar initialization expression at %C"); - m = MATCH_ERROR; - goto no_match; - } - - if (gfc_derived_parameter_expr (e)) - { - saved_kind_expr = e; - *kind = 0; - return MATCH_YES; - } - - fail = gfc_extract_int (e, kind, 1); - *is_iso_c = e->ts.is_iso_c; - if (fail) - { - m = MATCH_ERROR; - goto no_match; - } - - gfc_free_expr (e); - - /* Ignore errors to this point, if we've gotten here. This means - we ignore the m=MATCH_ERROR from above. */ - if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0) - { - gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind); - m = MATCH_ERROR; - } - else - /* All tests passed. */ - m = MATCH_YES; - - if (m == MATCH_ERROR) - gfc_current_locus = where; - - /* Return what we know from the test(s). */ - return m; - -no_match: - gfc_free_expr (e); - gfc_current_locus = where; - return m; -} - - -/* Match the various kind/length specifications in a CHARACTER - declaration. We don't return MATCH_NO. */ - -match -gfc_match_char_spec (gfc_typespec *ts) -{ - int kind, seen_length, is_iso_c; - gfc_charlen *cl; - gfc_expr *len; - match m; - bool deferred; - - len = NULL; - seen_length = 0; - kind = 0; - is_iso_c = 0; - deferred = false; - - /* Try the old-style specification first. */ - old_char_selector = 0; - - m = match_char_length (&len, &deferred, true); - if (m != MATCH_NO) - { - if (m == MATCH_YES) - old_char_selector = 1; - seen_length = 1; - goto done; - } - - m = gfc_match_char ('('); - if (m != MATCH_YES) - { - m = MATCH_YES; /* Character without length is a single char. */ - goto done; - } - - /* Try the weird case: ( KIND = [ , LEN = ] ). */ - if (gfc_match (" kind =") == MATCH_YES) - { - m = match_char_kind (&kind, &is_iso_c); - - if (m == MATCH_ERROR) - goto done; - if (m == MATCH_NO) - goto syntax; - - if (gfc_match (" , len =") == MATCH_NO) - goto rparen; - - m = char_len_param_value (&len, &deferred); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto done; - seen_length = 1; - - goto rparen; - } - - /* Try to match "LEN = " or "LEN = , KIND = ". */ - if (gfc_match (" len =") == MATCH_YES) - { - m = char_len_param_value (&len, &deferred); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto done; - seen_length = 1; - - if (gfc_match_char (')') == MATCH_YES) - goto done; - - if (gfc_match (" , kind =") != MATCH_YES) - goto syntax; - - if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR) - goto done; - - goto rparen; - } - - /* Try to match ( ) or ( , [ KIND = ] ). */ - m = char_len_param_value (&len, &deferred); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto done; - seen_length = 1; - - m = gfc_match_char (')'); - if (m == MATCH_YES) - goto done; - - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - gfc_match (" kind ="); /* Gobble optional text. */ - - m = match_char_kind (&kind, &is_iso_c); - if (m == MATCH_ERROR) - goto done; - if (m == MATCH_NO) - goto syntax; - -rparen: - /* Require a right-paren at this point. */ - m = gfc_match_char (')'); - if (m == MATCH_YES) - goto done; - -syntax: - gfc_error ("Syntax error in CHARACTER declaration at %C"); - m = MATCH_ERROR; - gfc_free_expr (len); - return m; - -done: - /* Deal with character functions after USE and IMPORT statements. */ - if (gfc_matching_function) - { - gfc_free_expr (len); - gfc_undo_symbols (); - return MATCH_YES; - } - - if (m != MATCH_YES) - { - gfc_free_expr (len); - return m; - } - - /* Do some final massaging of the length values. */ - cl = gfc_new_charlen (gfc_current_ns, NULL); - - if (seen_length == 0) - cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); - else - { - /* If gfortran ends up here, then len may be reducible to a constant. - Try to do that here. If it does not reduce, simply assign len to - charlen. A complication occurs with user-defined generic functions, - which are not resolved. Use a private namespace to deal with - generic functions. */ - - if (len && len->expr_type != EXPR_CONSTANT) - { - gfc_namespace *old_ns; - gfc_expr *e; - - old_ns = gfc_current_ns; - gfc_current_ns = gfc_get_namespace (NULL, 0); - - e = gfc_copy_expr (len); - gfc_push_suppress_errors (); - gfc_reduce_init_expr (e); - gfc_pop_suppress_errors (); - if (e->expr_type == EXPR_CONSTANT) - { - gfc_replace_expr (len, e); - if (mpz_cmp_si (len->value.integer, 0) < 0) - mpz_set_ui (len->value.integer, 0); - } - else - gfc_free_expr (e); - - gfc_free_namespace (gfc_current_ns); - gfc_current_ns = old_ns; - } - - cl->length = len; - } - - ts->u.cl = cl; - ts->kind = kind == 0 ? gfc_default_character_kind : kind; - ts->deferred = deferred; - - /* We have to know if it was a C interoperable kind so we can - do accurate type checking of bind(c) procs, etc. */ - if (kind != 0) - /* Mark this as C interoperable if being declared with one - of the named constants from iso_c_binding. */ - ts->is_c_interop = is_iso_c; - else if (len != NULL) - /* Here, we might have parsed something such as: character(c_char) - In this case, the parsing code above grabs the c_char when - looking for the length (line 1690, roughly). it's the last - testcase for parsing the kind params of a character variable. - However, it's not actually the length. this seems like it - could be an error. - To see if the user used a C interop kind, test the expr - of the so called length, and see if it's C interoperable. */ - ts->is_c_interop = len->ts.is_iso_c; - - return MATCH_YES; -} - - -/* Matches a RECORD declaration. */ - -static match -match_record_decl (char *name) -{ - locus old_loc; - old_loc = gfc_current_locus; - match m; - - m = gfc_match (" record /"); - if (m == MATCH_YES) - { - if (!flag_dec_structure) - { - gfc_current_locus = old_loc; - gfc_error ("RECORD at %C is an extension, enable it with " - "%<-fdec-structure%>"); - return MATCH_ERROR; - } - m = gfc_match (" %n/", name); - if (m == MATCH_YES) - return MATCH_YES; - } - - gfc_current_locus = old_loc; - if (flag_dec_structure - && (gfc_match (" record% ") == MATCH_YES - || gfc_match (" record%t") == MATCH_YES)) - gfc_error ("Structure name expected after RECORD at %C"); - if (m == MATCH_NO) - return MATCH_NO; - - return MATCH_ERROR; -} - - -/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source - of expressions to substitute into the possibly parameterized expression - 'e'. Using a list is inefficient but should not be too bad since the - number of type parameters is not likely to be large. */ -static bool -insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, - int* f) -{ - gfc_actual_arglist *param; - gfc_expr *copy; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - gcc_assert (e->symtree); - if (e->symtree->n.sym->attr.pdt_kind - || (*f != 0 && e->symtree->n.sym->attr.pdt_len)) - { - for (param = type_param_spec_list; param; param = param->next) - if (strcmp (e->symtree->n.sym->name, param->name) == 0) - break; - - if (param) - { - copy = gfc_copy_expr (param->expr); - *e = *copy; - free (copy); - } - } - - return false; -} - - -static bool -gfc_insert_kind_parameter_exprs (gfc_expr *e) -{ - return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0); -} - - -bool -gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list) -{ - gfc_actual_arglist *old_param_spec_list = type_param_spec_list; - type_param_spec_list = param_list; - bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1); - type_param_spec_list = old_param_spec_list; - return res; -} - -/* Determines the instance of a parameterized derived type to be used by - matching determining the values of the kind parameters and using them - in the name of the instance. If the instance exists, it is used, otherwise - a new derived type is created. */ -match -gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, - gfc_actual_arglist **ext_param_list) -{ - /* The PDT template symbol. */ - gfc_symbol *pdt = *sym; - /* The symbol for the parameter in the template f2k_namespace. */ - gfc_symbol *param; - /* The hoped for instance of the PDT. */ - gfc_symbol *instance; - /* The list of parameters appearing in the PDT declaration. */ - gfc_formal_arglist *type_param_name_list; - /* Used to store the parameter specification list during recursive calls. */ - gfc_actual_arglist *old_param_spec_list; - /* Pointers to the parameter specification being used. */ - gfc_actual_arglist *actual_param; - gfc_actual_arglist *tail = NULL; - /* Used to build up the name of the PDT instance. The prefix uses 4 - characters and each KIND parameter 2 more. Allow 8 of the latter. */ - char name[GFC_MAX_SYMBOL_LEN + 21]; - - bool name_seen = (param_list == NULL); - bool assumed_seen = false; - bool deferred_seen = false; - bool spec_error = false; - int kind_value, i; - gfc_expr *kind_expr; - gfc_component *c1, *c2; - match m; - - type_param_spec_list = NULL; - - type_param_name_list = pdt->formal; - actual_param = param_list; - sprintf (name, "Pdt%s", pdt->name); - - /* Run through the parameter name list and pick up the actual - parameter values or use the default values in the PDT declaration. */ - for (; type_param_name_list; - type_param_name_list = type_param_name_list->next) - { - if (actual_param && actual_param->spec_type != SPEC_EXPLICIT) - { - if (actual_param->spec_type == SPEC_ASSUMED) - spec_error = deferred_seen; - else - spec_error = assumed_seen; - - if (spec_error) - { - gfc_error ("The type parameter spec list at %C cannot contain " - "both ASSUMED and DEFERRED parameters"); - goto error_return; - } - } - - if (actual_param && actual_param->name) - name_seen = true; - param = type_param_name_list->sym; - - if (!param || !param->name) - continue; - - c1 = gfc_find_component (pdt, param->name, false, true, NULL); - /* An error should already have been thrown in resolve.c - (resolve_fl_derived0). */ - if (!pdt->attr.use_assoc && !c1) - goto error_return; - - kind_expr = NULL; - if (!name_seen) - { - if (!actual_param && !(c1 && c1->initializer)) - { - gfc_error ("The type parameter spec list at %C does not contain " - "enough parameter expressions"); - goto error_return; - } - else if (!actual_param && c1 && c1->initializer) - kind_expr = gfc_copy_expr (c1->initializer); - else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) - kind_expr = gfc_copy_expr (actual_param->expr); - } - else - { - actual_param = param_list; - for (;actual_param; actual_param = actual_param->next) - if (actual_param->name - && strcmp (actual_param->name, param->name) == 0) - break; - if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) - kind_expr = gfc_copy_expr (actual_param->expr); - else - { - if (c1->initializer) - kind_expr = gfc_copy_expr (c1->initializer); - else if (!(actual_param && param->attr.pdt_len)) - { - gfc_error ("The derived parameter %qs at %C does not " - "have a default value", param->name); - goto error_return; - } - } - } - - /* Store the current parameter expressions in a temporary actual - arglist 'list' so that they can be substituted in the corresponding - expressions in the PDT instance. */ - if (type_param_spec_list == NULL) - { - type_param_spec_list = gfc_get_actual_arglist (); - tail = type_param_spec_list; - } - else - { - tail->next = gfc_get_actual_arglist (); - tail = tail->next; - } - tail->name = param->name; - - if (kind_expr) - { - /* Try simplification even for LEN expressions. */ - bool ok; - gfc_resolve_expr (kind_expr); - ok = gfc_simplify_expr (kind_expr, 1); - /* Variable expressions seem to default to BT_PROCEDURE. - TODO find out why this is and fix it. */ - if (kind_expr->ts.type != BT_INTEGER - && kind_expr->ts.type != BT_PROCEDURE) - { - gfc_error ("The parameter expression at %C must be of " - "INTEGER type and not %s type", - gfc_basic_typename (kind_expr->ts.type)); - goto error_return; - } - if (kind_expr->ts.type == BT_INTEGER && !ok) - { - gfc_error ("The parameter expression at %C does not " - "simplify to an INTEGER constant"); - goto error_return; - } - - tail->expr = gfc_copy_expr (kind_expr); - } - - if (actual_param) - tail->spec_type = actual_param->spec_type; - - if (!param->attr.pdt_kind) - { - if (!name_seen && actual_param) - actual_param = actual_param->next; - if (kind_expr) - { - gfc_free_expr (kind_expr); - kind_expr = NULL; - } - continue; - } - - if (actual_param - && (actual_param->spec_type == SPEC_ASSUMED - || actual_param->spec_type == SPEC_DEFERRED)) - { - gfc_error ("The KIND parameter %qs at %C cannot either be " - "ASSUMED or DEFERRED", param->name); - goto error_return; - } - - if (!kind_expr || !gfc_is_constant_expr (kind_expr)) - { - gfc_error ("The value for the KIND parameter %qs at %C does not " - "reduce to a constant expression", param->name); - goto error_return; - } - - gfc_extract_int (kind_expr, &kind_value); - sprintf (name + strlen (name), "_%d", kind_value); - - if (!name_seen && actual_param) - actual_param = actual_param->next; - gfc_free_expr (kind_expr); - } - - if (!name_seen && actual_param) - { - gfc_error ("The type parameter spec list at %C contains too many " - "parameter expressions"); - goto error_return; - } - - /* Now we search for the PDT instance 'name'. If it doesn't exist, we - build it, using 'pdt' as a template. */ - if (gfc_get_symbol (name, pdt->ns, &instance)) - { - gfc_error ("Parameterized derived type at %C is ambiguous"); - goto error_return; - } - - m = MATCH_YES; - - if (instance->attr.flavor == FL_DERIVED - && instance->attr.pdt_type) - { - instance->refs++; - if (ext_param_list) - *ext_param_list = type_param_spec_list; - *sym = instance; - gfc_commit_symbols (); - return m; - } - - /* Start building the new instance of the parameterized type. */ - gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at); - instance->attr.pdt_template = 0; - instance->attr.pdt_type = 1; - instance->declared_at = gfc_current_locus; - - /* Add the components, replacing the parameters in all expressions - with the expressions for their values in 'type_param_spec_list'. */ - c1 = pdt->components; - tail = type_param_spec_list; - for (; c1; c1 = c1->next) - { - gfc_add_component (instance, c1->name, &c2); - - c2->ts = c1->ts; - c2->attr = c1->attr; - - /* The order of declaration of the type_specs might not be the - same as that of the components. */ - if (c1->attr.pdt_kind || c1->attr.pdt_len) - { - for (tail = type_param_spec_list; tail; tail = tail->next) - if (strcmp (c1->name, tail->name) == 0) - break; - } - - /* Deal with type extension by recursively calling this function - to obtain the instance of the extended type. */ - if (gfc_current_state () != COMP_DERIVED - && c1 == pdt->components - && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) - && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template - && gfc_get_derived_super_type (*sym) == c2->ts.u.derived) - { - gfc_formal_arglist *f; - - old_param_spec_list = type_param_spec_list; - - /* Obtain a spec list appropriate to the extended type..*/ - actual_param = gfc_copy_actual_arglist (type_param_spec_list); - type_param_spec_list = actual_param; - for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) - actual_param = actual_param->next; - if (actual_param) - { - gfc_free_actual_arglist (actual_param->next); - actual_param->next = NULL; - } - - /* Now obtain the PDT instance for the extended type. */ - c2->param_list = type_param_spec_list; - m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, - NULL); - type_param_spec_list = old_param_spec_list; - - c2->ts.u.derived->refs++; - gfc_set_sym_referenced (c2->ts.u.derived); - - /* Set extension level. */ - if (c2->ts.u.derived->attr.extension == 255) - { - /* Since the extension field is 8 bit wide, we can only have - up to 255 extension levels. */ - gfc_error ("Maximum extension level reached with type %qs at %L", - c2->ts.u.derived->name, - &c2->ts.u.derived->declared_at); - goto error_return; - } - instance->attr.extension = c2->ts.u.derived->attr.extension + 1; - - continue; - } - - /* Set the component kind using the parameterized expression. */ - if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER) - && c1->kind_expr != NULL) - { - gfc_expr *e = gfc_copy_expr (c1->kind_expr); - gfc_insert_kind_parameter_exprs (e); - gfc_simplify_expr (e, 1); - gfc_extract_int (e, &c2->ts.kind); - gfc_free_expr (e); - if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0) - { - gfc_error ("Kind %d not supported for type %s at %C", - c2->ts.kind, gfc_basic_typename (c2->ts.type)); - goto error_return; - } - } - - /* Similarly, set the string length if parameterized. */ - if (c1->ts.type == BT_CHARACTER - && c1->ts.u.cl->length - && gfc_derived_parameter_expr (c1->ts.u.cl->length)) - { - gfc_expr *e; - e = gfc_copy_expr (c1->ts.u.cl->length); - gfc_insert_kind_parameter_exprs (e); - gfc_simplify_expr (e, 1); - c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - c2->ts.u.cl->length = e; - c2->attr.pdt_string = 1; - } - - /* Set up either the KIND/LEN initializer, if constant, - or the parameterized expression. Use the template - initializer if one is not already set in this instance. */ - if (c2->attr.pdt_kind || c2->attr.pdt_len) - { - if (tail && tail->expr && gfc_is_constant_expr (tail->expr)) - c2->initializer = gfc_copy_expr (tail->expr); - else if (tail && tail->expr) - { - c2->param_list = gfc_get_actual_arglist (); - c2->param_list->name = tail->name; - c2->param_list->expr = gfc_copy_expr (tail->expr); - c2->param_list->next = NULL; - } - - if (!c2->initializer && c1->initializer) - c2->initializer = gfc_copy_expr (c1->initializer); - } - - /* Copy the array spec. */ - c2->as = gfc_copy_array_spec (c1->as); - if (c1->ts.type == BT_CLASS) - CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as); - - /* Determine if an array spec is parameterized. If so, substitute - in the parameter expressions for the bounds and set the pdt_array - attribute. Notice that this attribute must be unconditionally set - if this is an array of parameterized character length. */ - if (c1->as && c1->as->type == AS_EXPLICIT) - { - bool pdt_array = false; - - /* Are the bounds of the array parameterized? */ - for (i = 0; i < c1->as->rank; i++) - { - if (gfc_derived_parameter_expr (c1->as->lower[i])) - pdt_array = true; - if (gfc_derived_parameter_expr (c1->as->upper[i])) - pdt_array = true; - } - - /* If they are, free the expressions for the bounds and - replace them with the template expressions with substitute - values. */ - for (i = 0; pdt_array && i < c1->as->rank; i++) - { - gfc_expr *e; - e = gfc_copy_expr (c1->as->lower[i]); - gfc_insert_kind_parameter_exprs (e); - gfc_simplify_expr (e, 1); - gfc_free_expr (c2->as->lower[i]); - c2->as->lower[i] = e; - e = gfc_copy_expr (c1->as->upper[i]); - gfc_insert_kind_parameter_exprs (e); - gfc_simplify_expr (e, 1); - gfc_free_expr (c2->as->upper[i]); - c2->as->upper[i] = e; - } - c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string; - if (c1->initializer) - { - c2->initializer = gfc_copy_expr (c1->initializer); - gfc_insert_kind_parameter_exprs (c2->initializer); - gfc_simplify_expr (c2->initializer, 1); - } - } - - /* Recurse into this function for PDT components. */ - if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) - && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template) - { - gfc_actual_arglist *params; - /* The component in the template has a list of specification - expressions derived from its declaration. */ - params = gfc_copy_actual_arglist (c1->param_list); - actual_param = params; - /* Substitute the template parameters with the expressions - from the specification list. */ - for (;actual_param; actual_param = actual_param->next) - gfc_insert_parameter_exprs (actual_param->expr, - type_param_spec_list); - - /* Now obtain the PDT instance for the component. */ - old_param_spec_list = type_param_spec_list; - m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL); - type_param_spec_list = old_param_spec_list; - - c2->param_list = params; - if (!(c2->attr.pointer || c2->attr.allocatable)) - c2->initializer = gfc_default_initializer (&c2->ts); - - if (c2->attr.allocatable) - instance->attr.alloc_comp = 1; - } - } - - gfc_commit_symbol (instance); - if (ext_param_list) - *ext_param_list = type_param_spec_list; - *sym = instance; - return m; - -error_return: - gfc_free_actual_arglist (type_param_spec_list); - return MATCH_ERROR; -} - - -/* Match a legacy nonstandard BYTE type-spec. */ - -static match -match_byte_typespec (gfc_typespec *ts) -{ - if (gfc_match (" byte") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C")) - return MATCH_ERROR; - - if (gfc_current_form == FORM_FREE) - { - char c = gfc_peek_ascii_char (); - if (!gfc_is_whitespace (c) && c != ',') - return MATCH_NO; - } - - if (gfc_validate_kind (BT_INTEGER, 1, true) < 0) - { - gfc_error ("BYTE type used at %C " - "is not available on the target machine"); - return MATCH_ERROR; - } - - ts->type = BT_INTEGER; - ts->kind = 1; - return MATCH_YES; - } - return MATCH_NO; -} - - -/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts - structure to the matched specification. This is necessary for FUNCTION and - IMPLICIT statements. - - If implicit_flag is nonzero, then we don't check for the optional - kind specification. Not doing so is needed for matching an IMPLICIT - statement correctly. */ - -match -gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) -{ - /* Provide sufficient space to hold "pdtsymbol". */ - char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1); - gfc_symbol *sym, *dt_sym; - match m; - char c; - bool seen_deferred_kind, matched_type; - const char *dt_name; - - decl_type_param_list = NULL; - - /* A belt and braces check that the typespec is correctly being treated - as a deferred characteristic association. */ - seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION) - && (gfc_current_block ()->result->ts.kind == -1) - && (ts->kind == -1); - gfc_clear_ts (ts); - if (seen_deferred_kind) - ts->kind = -1; - - /* Clear the current binding label, in case one is given. */ - curr_binding_label = NULL; - - /* Match BYTE type-spec. */ - m = match_byte_typespec (ts); - if (m != MATCH_NO) - return m; - - m = gfc_match (" type ("); - matched_type = (m == MATCH_YES); - if (matched_type) - { - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () == '*') - { - if ((m = gfc_match ("* ) ")) != MATCH_YES) - return m; - if (gfc_comp_struct (gfc_current_state ())) - { - gfc_error ("Assumed type at %C is not allowed for components"); - return MATCH_ERROR; - } - if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C")) - return MATCH_ERROR; - ts->type = BT_ASSUMED; - return MATCH_YES; - } - - m = gfc_match ("%n", name); - matched_type = (m == MATCH_YES); - } - - if ((matched_type && strcmp ("integer", name) == 0) - || (!matched_type && gfc_match (" integer") == MATCH_YES)) - { - ts->type = BT_INTEGER; - ts->kind = gfc_default_integer_kind; - goto get_kind; - } - - if ((matched_type && strcmp ("character", name) == 0) - || (!matched_type && gfc_match (" character") == MATCH_YES)) - { - if (matched_type - && !gfc_notify_std (GFC_STD_F2008, "TYPE with " - "intrinsic-type-spec at %C")) - return MATCH_ERROR; - - ts->type = BT_CHARACTER; - if (implicit_flag == 0) - m = gfc_match_char_spec (ts); - else - m = MATCH_YES; - - if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Malformed type-spec at %C"); - return MATCH_ERROR; - } - - return m; - } - - if ((matched_type && strcmp ("real", name) == 0) - || (!matched_type && gfc_match (" real") == MATCH_YES)) - { - ts->type = BT_REAL; - ts->kind = gfc_default_real_kind; - goto get_kind; - } - - if ((matched_type - && (strcmp ("doubleprecision", name) == 0 - || (strcmp ("double", name) == 0 - && gfc_match (" precision") == MATCH_YES))) - || (!matched_type && gfc_match (" double precision") == MATCH_YES)) - { - if (matched_type - && !gfc_notify_std (GFC_STD_F2008, "TYPE with " - "intrinsic-type-spec at %C")) - return MATCH_ERROR; - - if (matched_type && gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Malformed type-spec at %C"); - return MATCH_ERROR; - } - - ts->type = BT_REAL; - ts->kind = gfc_default_double_kind; - return MATCH_YES; - } - - if ((matched_type && strcmp ("complex", name) == 0) - || (!matched_type && gfc_match (" complex") == MATCH_YES)) - { - ts->type = BT_COMPLEX; - ts->kind = gfc_default_complex_kind; - goto get_kind; - } - - if ((matched_type - && (strcmp ("doublecomplex", name) == 0 - || (strcmp ("double", name) == 0 - && gfc_match (" complex") == MATCH_YES))) - || (!matched_type && gfc_match (" double complex") == MATCH_YES)) - { - if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C")) - return MATCH_ERROR; - - if (matched_type - && !gfc_notify_std (GFC_STD_F2008, "TYPE with " - "intrinsic-type-spec at %C")) - return MATCH_ERROR; - - if (matched_type && gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Malformed type-spec at %C"); - return MATCH_ERROR; - } - - ts->type = BT_COMPLEX; - ts->kind = gfc_default_double_kind; - return MATCH_YES; - } - - if ((matched_type && strcmp ("logical", name) == 0) - || (!matched_type && gfc_match (" logical") == MATCH_YES)) - { - ts->type = BT_LOGICAL; - ts->kind = gfc_default_logical_kind; - goto get_kind; - } - - if (matched_type) - { - m = gfc_match_actual_arglist (1, &decl_type_param_list, true); - if (m == MATCH_ERROR) - return m; - - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () != ')') - { - gfc_error ("Malformed type-spec at %C"); - return MATCH_ERROR; - } - m = gfc_match_char (')'); /* Burn closing ')'. */ - } - - if (m != MATCH_YES) - m = match_record_decl (name); - - if (matched_type || m == MATCH_YES) - { - ts->type = BT_DERIVED; - /* We accept record/s/ or type(s) where s is a structure, but we - * don't need all the extra derived-type stuff for structures. */ - if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym)) - { - gfc_error ("Type name %qs at %C is ambiguous", name); - return MATCH_ERROR; - } - - if (sym && sym->attr.flavor == FL_DERIVED - && sym->attr.pdt_template - && gfc_current_state () != COMP_DERIVED) - { - m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); - if (m != MATCH_YES) - return m; - gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); - ts->u.derived = sym; - const char* lower = gfc_dt_lower_string (sym->name); - size_t len = strlen (lower); - /* Reallocate with sufficient size. */ - if (len > GFC_MAX_SYMBOL_LEN) - name = XALLOCAVEC (char, len + 1); - memcpy (name, lower, len); - name[len] = '\0'; - } - - if (sym && sym->attr.flavor == FL_STRUCT) - { - ts->u.derived = sym; - return MATCH_YES; - } - /* Actually a derived type. */ - } - - else - { - /* Match nested STRUCTURE declarations; only valid within another - structure declaration. */ - if (flag_dec_structure - && (gfc_current_state () == COMP_STRUCTURE - || gfc_current_state () == COMP_MAP)) - { - m = gfc_match (" structure"); - if (m == MATCH_YES) - { - m = gfc_match_structure_decl (); - if (m == MATCH_YES) - { - /* gfc_new_block is updated by match_structure_decl. */ - ts->type = BT_DERIVED; - ts->u.derived = gfc_new_block; - return MATCH_YES; - } - } - if (m == MATCH_ERROR) - return MATCH_ERROR; - } - - /* Match CLASS declarations. */ - m = gfc_match (" class ( * )"); - if (m == MATCH_ERROR) - return MATCH_ERROR; - else if (m == MATCH_YES) - { - gfc_symbol *upe; - gfc_symtree *st; - ts->type = BT_CLASS; - gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe); - if (upe == NULL) - { - upe = gfc_new_symbol ("STAR", gfc_current_ns); - st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR"); - st->n.sym = upe; - gfc_set_sym_referenced (upe); - upe->refs++; - upe->ts.type = BT_VOID; - upe->attr.unlimited_polymorphic = 1; - /* This is essential to force the construction of - unlimited polymorphic component class containers. */ - upe->attr.zero_comp = 1; - if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, - &gfc_current_locus)) - return MATCH_ERROR; - } - else - { - st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR"); - st->n.sym = upe; - upe->refs++; - } - ts->u.derived = upe; - return m; - } - - m = gfc_match (" class ("); - - if (m == MATCH_YES) - m = gfc_match ("%n", name); - else - return m; - - if (m != MATCH_YES) - return m; - ts->type = BT_CLASS; - - if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C")) - return MATCH_ERROR; - - m = gfc_match_actual_arglist (1, &decl_type_param_list, true); - if (m == MATCH_ERROR) - return m; - - m = gfc_match_char (')'); - if (m != MATCH_YES) - return m; - } - - /* Defer association of the derived type until the end of the - specification block. However, if the derived type can be - found, add it to the typespec. */ - if (gfc_matching_function) - { - ts->u.derived = NULL; - if (gfc_current_state () != COMP_INTERFACE - && !gfc_find_symbol (name, NULL, 1, &sym) && sym) - { - sym = gfc_find_dt_in_generic (sym); - ts->u.derived = sym; - } - return MATCH_YES; - } - - /* Search for the name but allow the components to be defined later. If - type = -1, this typespec has been seen in a function declaration but - the type could not be accessed at that point. The actual derived type is - stored in a symtree with the first letter of the name capitalized; the - symtree with the all lower-case name contains the associated - generic function. */ - dt_name = gfc_dt_upper_string (name); - sym = NULL; - dt_sym = NULL; - if (ts->kind != -1) - { - gfc_get_ha_symbol (name, &sym); - if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) - { - gfc_error ("Type name %qs at %C is ambiguous", name); - return MATCH_ERROR; - } - if (sym->generic && !dt_sym) - dt_sym = gfc_find_dt_in_generic (sym); - - /* Host associated PDTs can get confused with their constructors - because they ar instantiated in the template's namespace. */ - if (!dt_sym) - { - if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) - { - gfc_error ("Type name %qs at %C is ambiguous", name); - return MATCH_ERROR; - } - if (dt_sym && !dt_sym->attr.pdt_type) - dt_sym = NULL; - } - } - else if (ts->kind == -1) - { - int iface = gfc_state_stack->previous->state != COMP_INTERFACE - || gfc_current_ns->has_import_set; - gfc_find_symbol (name, NULL, iface, &sym); - if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) - { - gfc_error ("Type name %qs at %C is ambiguous", name); - return MATCH_ERROR; - } - if (sym && sym->generic && !dt_sym) - dt_sym = gfc_find_dt_in_generic (sym); - - ts->kind = 0; - if (sym == NULL) - return MATCH_NO; - } - - if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT - && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) - || sym->attr.subroutine) - { - gfc_error ("Type name %qs at %C conflicts with previously declared " - "entity at %L, which has the same name", name, - &sym->declared_at); - return MATCH_ERROR; - } - - if (sym && sym->attr.flavor == FL_DERIVED - && sym->attr.pdt_template - && gfc_current_state () != COMP_DERIVED) - { - m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); - if (m != MATCH_YES) - return m; - gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); - ts->u.derived = sym; - strcpy (name, gfc_dt_lower_string (sym->name)); - } - - gfc_save_symbol_data (sym); - gfc_set_sym_referenced (sym); - if (!sym->attr.generic - && !gfc_add_generic (&sym->attr, sym->name, NULL)) - return MATCH_ERROR; - - if (!sym->attr.function - && !gfc_add_function (&sym->attr, sym->name, NULL)) - return MATCH_ERROR; - - if (dt_sym && dt_sym->attr.flavor == FL_DERIVED - && dt_sym->attr.pdt_template - && gfc_current_state () != COMP_DERIVED) - { - m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL); - if (m != MATCH_YES) - return m; - gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type); - } - - if (!dt_sym) - { - gfc_interface *intr, *head; - - /* Use upper case to save the actual derived-type symbol. */ - gfc_get_symbol (dt_name, NULL, &dt_sym); - dt_sym->name = gfc_get_string ("%s", sym->name); - head = sym->generic; - intr = gfc_get_interface (); - intr->sym = dt_sym; - intr->where = gfc_current_locus; - intr->next = head; - sym->generic = intr; - sym->attr.if_source = IFSRC_DECL; - } - else - gfc_save_symbol_data (dt_sym); - - gfc_set_sym_referenced (dt_sym); - - if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT - && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)) - return MATCH_ERROR; - - ts->u.derived = dt_sym; - - return MATCH_YES; - -get_kind: - if (matched_type - && !gfc_notify_std (GFC_STD_F2008, "TYPE with " - "intrinsic-type-spec at %C")) - return MATCH_ERROR; - - /* For all types except double, derived and character, look for an - optional kind specifier. MATCH_NO is actually OK at this point. */ - if (implicit_flag == 1) - { - if (matched_type && gfc_match_char (')') != MATCH_YES) - return MATCH_ERROR; - - return MATCH_YES; - } - - if (gfc_current_form == FORM_FREE) - { - c = gfc_peek_ascii_char (); - if (!gfc_is_whitespace (c) && c != '*' && c != '(' - && c != ':' && c != ',') - { - if (matched_type && c == ')') - { - gfc_next_ascii_char (); - return MATCH_YES; - } - gfc_error ("Malformed type-spec at %C"); - return MATCH_NO; - } - } - - m = gfc_match_kind_spec (ts, false); - if (m == MATCH_NO && ts->type != BT_CHARACTER) - { - m = gfc_match_old_kind_spec (ts); - if (gfc_validate_kind (ts->type, ts->kind, true) == -1) - return MATCH_ERROR; - } - - if (matched_type && gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Malformed type-spec at %C"); - return MATCH_ERROR; - } - - /* Defer association of the KIND expression of function results - until after USE and IMPORT statements. */ - if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) - || gfc_matching_function) - return MATCH_YES; - - if (m == MATCH_NO) - m = MATCH_YES; /* No kind specifier found. */ - - return m; -} - - -/* Match an IMPLICIT NONE statement. Actually, this statement is - already matched in parse.c, or we would not end up here in the - first place. So the only thing we need to check, is if there is - trailing garbage. If not, the match is successful. */ - -match -gfc_match_implicit_none (void) -{ - char c; - match m; - char name[GFC_MAX_SYMBOL_LEN + 1]; - bool type = false; - bool external = false; - locus cur_loc = gfc_current_locus; - - if (gfc_current_ns->seen_implicit_none - || gfc_current_ns->has_implicit_none_export) - { - gfc_error ("Duplicate IMPLICIT NONE statement at %C"); - return MATCH_ERROR; - } - - gfc_gobble_whitespace (); - c = gfc_peek_ascii_char (); - if (c == '(') - { - (void) gfc_next_ascii_char (); - if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C")) - return MATCH_ERROR; - - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () == ')') - { - (void) gfc_next_ascii_char (); - type = true; - } - else - for(;;) - { - m = gfc_match (" %n", name); - if (m != MATCH_YES) - return MATCH_ERROR; - - if (strcmp (name, "type") == 0) - type = true; - else if (strcmp (name, "external") == 0) - external = true; - else - return MATCH_ERROR; - - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - if (c == ',') - continue; - if (c == ')') - break; - return MATCH_ERROR; - } - } - else - type = true; - - if (gfc_match_eos () != MATCH_YES) - return MATCH_ERROR; - - gfc_set_implicit_none (type, external, &cur_loc); - - return MATCH_YES; -} - - -/* Match the letter range(s) of an IMPLICIT statement. */ - -static match -match_implicit_range (void) -{ - char c, c1, c2; - int inner; - locus cur_loc; - - cur_loc = gfc_current_locus; - - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - if (c != '(') - { - gfc_error ("Missing character range in IMPLICIT at %C"); - goto bad; - } - - inner = 1; - while (inner) - { - gfc_gobble_whitespace (); - c1 = gfc_next_ascii_char (); - if (!ISALPHA (c1)) - goto bad; - - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - - switch (c) - { - case ')': - inner = 0; /* Fall through. */ - - case ',': - c2 = c1; - break; - - case '-': - gfc_gobble_whitespace (); - c2 = gfc_next_ascii_char (); - if (!ISALPHA (c2)) - goto bad; - - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - - if ((c != ',') && (c != ')')) - goto bad; - if (c == ')') - inner = 0; - - break; - - default: - goto bad; - } - - if (c1 > c2) - { - gfc_error ("Letters must be in alphabetic order in " - "IMPLICIT statement at %C"); - goto bad; - } - - /* See if we can add the newly matched range to the pending - implicits from this IMPLICIT statement. We do not check for - conflicts with whatever earlier IMPLICIT statements may have - set. This is done when we've successfully finished matching - the current one. */ - if (!gfc_add_new_implicit_range (c1, c2)) - goto bad; - } - - return MATCH_YES; - -bad: - gfc_syntax_error (ST_IMPLICIT); - - gfc_current_locus = cur_loc; - return MATCH_ERROR; -} - - -/* Match an IMPLICIT statement, storing the types for - gfc_set_implicit() if the statement is accepted by the parser. - There is a strange looking, but legal syntactic construction - possible. It looks like: - - IMPLICIT INTEGER (a-b) (c-d) - - This is legal if "a-b" is a constant expression that happens to - equal one of the legal kinds for integers. The real problem - happens with an implicit specification that looks like: - - IMPLICIT INTEGER (a-b) - - In this case, a typespec matcher that is "greedy" (as most of the - matchers are) gobbles the character range as a kindspec, leaving - nothing left. We therefore have to go a bit more slowly in the - matching process by inhibiting the kindspec checking during - typespec matching and checking for a kind later. */ - -match -gfc_match_implicit (void) -{ - gfc_typespec ts; - locus cur_loc; - char c; - match m; - - if (gfc_current_ns->seen_implicit_none) - { - gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) " - "statement"); - return MATCH_ERROR; - } - - gfc_clear_ts (&ts); - - /* We don't allow empty implicit statements. */ - if (gfc_match_eos () == MATCH_YES) - { - gfc_error ("Empty IMPLICIT statement at %C"); - return MATCH_ERROR; - } - - do - { - /* First cleanup. */ - gfc_clear_new_implicit (); - - /* A basic type is mandatory here. */ - m = gfc_match_decl_type_spec (&ts, 1); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - goto syntax; - - cur_loc = gfc_current_locus; - m = match_implicit_range (); - - if (m == MATCH_YES) - { - /* We may have (). */ - gfc_gobble_whitespace (); - c = gfc_peek_ascii_char (); - if (c == ',' || c == '\n' || c == ';' || c == '!') - { - /* Check for CHARACTER with no length parameter. */ - if (ts.type == BT_CHARACTER && !ts.u.cl) - { - ts.kind = gfc_default_character_kind; - ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, 1); - } - - /* Record the Successful match. */ - if (!gfc_merge_new_implicit (&ts)) - return MATCH_ERROR; - if (c == ',') - c = gfc_next_ascii_char (); - else if (gfc_match_eos () == MATCH_ERROR) - goto error; - continue; - } - - gfc_current_locus = cur_loc; - } - - /* Discard the (incorrectly) matched range. */ - gfc_clear_new_implicit (); - - /* Last chance -- check (). */ - if (ts.type == BT_CHARACTER) - m = gfc_match_char_spec (&ts); - else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL) - { - m = gfc_match_kind_spec (&ts, false); - if (m == MATCH_NO) - { - m = gfc_match_old_kind_spec (&ts); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - goto syntax; - } - } - if (m == MATCH_ERROR) - goto error; - - m = match_implicit_range (); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - goto syntax; - - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - if (c != ',' && gfc_match_eos () != MATCH_YES) - goto syntax; - - if (!gfc_merge_new_implicit (&ts)) - return MATCH_ERROR; - } - while (c == ','); - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_IMPLICIT); - -error: - return MATCH_ERROR; -} - - -match -gfc_match_import (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - match m; - gfc_symbol *sym; - gfc_symtree *st; - - if (gfc_current_ns->proc_name == NULL - || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY) - { - gfc_error ("IMPORT statement at %C only permitted in " - "an INTERFACE body"); - return MATCH_ERROR; - } - - if (gfc_current_ns->proc_name->attr.module_procedure) - { - gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted " - "in a module procedure interface body"); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")) - return MATCH_ERROR; - - if (gfc_match_eos () == MATCH_YES) - { - /* All host variables should be imported. */ - gfc_current_ns->has_import_set = 1; - return MATCH_YES; - } - - if (gfc_match (" ::") == MATCH_YES) - { - if (gfc_match_eos () == MATCH_YES) - { - gfc_error ("Expecting list of named entities at %C"); - return MATCH_ERROR; - } - } - - for(;;) - { - sym = NULL; - m = gfc_match (" %n", name); - switch (m) - { - case MATCH_YES: - if (gfc_current_ns->parent != NULL - && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) - { - gfc_error ("Type name %qs at %C is ambiguous", name); - return MATCH_ERROR; - } - else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL - && gfc_find_symbol (name, - gfc_current_ns->proc_name->ns->parent, - 1, &sym)) - { - gfc_error ("Type name %qs at %C is ambiguous", name); - return MATCH_ERROR; - } - - if (sym == NULL) - { - gfc_error ("Cannot IMPORT %qs from host scoping unit " - "at %C - does not exist.", name); - return MATCH_ERROR; - } - - if (gfc_find_symtree (gfc_current_ns->sym_root, name)) - { - gfc_warning (0, "%qs is already IMPORTed from host scoping unit " - "at %C", name); - goto next_item; - } - - st = gfc_new_symtree (&gfc_current_ns->sym_root, name); - st->n.sym = sym; - sym->refs++; - sym->attr.imported = 1; - - if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) - { - /* The actual derived type is stored in a symtree with the first - letter of the name capitalized; the symtree with the all - lower-case name contains the associated generic function. */ - st = gfc_new_symtree (&gfc_current_ns->sym_root, - gfc_dt_upper_string (name)); - st->n.sym = sym; - sym->refs++; - sym->attr.imported = 1; - } - - goto next_item; - - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - } - - next_item: - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in IMPORT statement at %C"); - return MATCH_ERROR; -} - - -/* A minimal implementation of gfc_match without whitespace, escape - characters or variable arguments. Returns true if the next - characters match the TARGET template exactly. */ - -static bool -match_string_p (const char *target) -{ - const char *p; - - for (p = target; *p; p++) - if ((char) gfc_next_ascii_char () != *p) - return false; - return true; -} - -/* Matches an attribute specification including array specs. If - successful, leaves the variables current_attr and current_as - holding the specification. Also sets the colon_seen variable for - later use by matchers associated with initializations. - - This subroutine is a little tricky in the sense that we don't know - if we really have an attr-spec until we hit the double colon. - Until that time, we can only return MATCH_NO. This forces us to - check for duplicate specification at this level. */ - -static match -match_attr_spec (void) -{ - /* Modifiers that can exist in a type statement. */ - enum - { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN, - DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT, - DECL_DIMENSION, DECL_EXTERNAL, - DECL_INTRINSIC, DECL_OPTIONAL, - DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, - DECL_STATIC, DECL_AUTOMATIC, - DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, - DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, - DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */ - }; - -/* GFC_DECL_END is the sentinel, index starts at 0. */ -#define NUM_DECL GFC_DECL_END - - /* Make sure that values from sym_intent are safe to be used here. */ - gcc_assert (INTENT_IN > 0); - - locus start, seen_at[NUM_DECL]; - int seen[NUM_DECL]; - unsigned int d; - const char *attr; - match m; - bool t; - - gfc_clear_attr (¤t_attr); - start = gfc_current_locus; - - current_as = NULL; - colon_seen = 0; - attr_seen = 0; - - /* See if we get all of the keywords up to the final double colon. */ - for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) - seen[d] = 0; - - for (;;) - { - char ch; - - d = DECL_NONE; - gfc_gobble_whitespace (); - - ch = gfc_next_ascii_char (); - if (ch == ':') - { - /* This is the successful exit condition for the loop. */ - if (gfc_next_ascii_char () == ':') - break; - } - else if (ch == ',') - { - gfc_gobble_whitespace (); - switch (gfc_peek_ascii_char ()) - { - case 'a': - gfc_next_ascii_char (); - switch (gfc_next_ascii_char ()) - { - case 'l': - if (match_string_p ("locatable")) - { - /* Matched "allocatable". */ - d = DECL_ALLOCATABLE; - } - break; - - case 's': - if (match_string_p ("ynchronous")) - { - /* Matched "asynchronous". */ - d = DECL_ASYNCHRONOUS; - } - break; - - case 'u': - if (match_string_p ("tomatic")) - { - /* Matched "automatic". */ - d = DECL_AUTOMATIC; - } - break; - } - break; - - case 'b': - /* Try and match the bind(c). */ - m = gfc_match_bind_c (NULL, true); - if (m == MATCH_YES) - d = DECL_IS_BIND_C; - else if (m == MATCH_ERROR) - goto cleanup; - break; - - case 'c': - gfc_next_ascii_char (); - if ('o' != gfc_next_ascii_char ()) - break; - switch (gfc_next_ascii_char ()) - { - case 'd': - if (match_string_p ("imension")) - { - d = DECL_CODIMENSION; - break; - } - /* FALLTHRU */ - case 'n': - if (match_string_p ("tiguous")) - { - d = DECL_CONTIGUOUS; - break; - } - } - break; - - case 'd': - if (match_string_p ("dimension")) - d = DECL_DIMENSION; - break; - - case 'e': - if (match_string_p ("external")) - d = DECL_EXTERNAL; - break; - - case 'i': - if (match_string_p ("int")) - { - ch = gfc_next_ascii_char (); - if (ch == 'e') - { - if (match_string_p ("nt")) - { - /* Matched "intent". */ - d = match_intent_spec (); - if (d == INTENT_UNKNOWN) - { - m = MATCH_ERROR; - goto cleanup; - } - } - } - else if (ch == 'r') - { - if (match_string_p ("insic")) - { - /* Matched "intrinsic". */ - d = DECL_INTRINSIC; - } - } - } - break; - - case 'k': - if (match_string_p ("kind")) - d = DECL_KIND; - break; - - case 'l': - if (match_string_p ("len")) - d = DECL_LEN; - break; - - case 'o': - if (match_string_p ("optional")) - d = DECL_OPTIONAL; - break; - - case 'p': - gfc_next_ascii_char (); - switch (gfc_next_ascii_char ()) - { - case 'a': - if (match_string_p ("rameter")) - { - /* Matched "parameter". */ - d = DECL_PARAMETER; - } - break; - - case 'o': - if (match_string_p ("inter")) - { - /* Matched "pointer". */ - d = DECL_POINTER; - } - break; - - case 'r': - ch = gfc_next_ascii_char (); - if (ch == 'i') - { - if (match_string_p ("vate")) - { - /* Matched "private". */ - d = DECL_PRIVATE; - } - } - else if (ch == 'o') - { - if (match_string_p ("tected")) - { - /* Matched "protected". */ - d = DECL_PROTECTED; - } - } - break; - - case 'u': - if (match_string_p ("blic")) - { - /* Matched "public". */ - d = DECL_PUBLIC; - } - break; - } - break; - - case 's': - gfc_next_ascii_char (); - switch (gfc_next_ascii_char ()) - { - case 'a': - if (match_string_p ("ve")) - { - /* Matched "save". */ - d = DECL_SAVE; - } - break; - - case 't': - if (match_string_p ("atic")) - { - /* Matched "static". */ - d = DECL_STATIC; - } - break; - } - break; - - case 't': - if (match_string_p ("target")) - d = DECL_TARGET; - break; - - case 'v': - gfc_next_ascii_char (); - ch = gfc_next_ascii_char (); - if (ch == 'a') - { - if (match_string_p ("lue")) - { - /* Matched "value". */ - d = DECL_VALUE; - } - } - else if (ch == 'o') - { - if (match_string_p ("latile")) - { - /* Matched "volatile". */ - d = DECL_VOLATILE; - } - } - break; - } - } - - /* No double colon and no recognizable decl_type, so assume that - we've been looking at something else the whole time. */ - if (d == DECL_NONE) - { - m = MATCH_NO; - goto cleanup; - } - - /* Check to make sure any parens are paired up correctly. */ - if (gfc_match_parens () == MATCH_ERROR) - { - m = MATCH_ERROR; - goto cleanup; - } - - seen[d]++; - seen_at[d] = gfc_current_locus; - - if (d == DECL_DIMENSION || d == DECL_CODIMENSION) - { - gfc_array_spec *as = NULL; - - m = gfc_match_array_spec (&as, d == DECL_DIMENSION, - d == DECL_CODIMENSION); - - if (current_as == NULL) - current_as = as; - else if (m == MATCH_YES) - { - if (!merge_array_spec (as, current_as, false)) - m = MATCH_ERROR; - free (as); - } - - if (m == MATCH_NO) - { - if (d == DECL_CODIMENSION) - gfc_error ("Missing codimension specification at %C"); - else - gfc_error ("Missing dimension specification at %C"); - m = MATCH_ERROR; - } - - if (m == MATCH_ERROR) - goto cleanup; - } - } - - /* Since we've seen a double colon, we have to be looking at an - attr-spec. This means that we can now issue errors. */ - for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) - if (seen[d] > 1) - { - switch (d) - { - case DECL_ALLOCATABLE: - attr = "ALLOCATABLE"; - break; - case DECL_ASYNCHRONOUS: - attr = "ASYNCHRONOUS"; - break; - case DECL_CODIMENSION: - attr = "CODIMENSION"; - break; - case DECL_CONTIGUOUS: - attr = "CONTIGUOUS"; - break; - case DECL_DIMENSION: - attr = "DIMENSION"; - break; - case DECL_EXTERNAL: - attr = "EXTERNAL"; - break; - case DECL_IN: - attr = "INTENT (IN)"; - break; - case DECL_OUT: - attr = "INTENT (OUT)"; - break; - case DECL_INOUT: - attr = "INTENT (IN OUT)"; - break; - case DECL_INTRINSIC: - attr = "INTRINSIC"; - break; - case DECL_OPTIONAL: - attr = "OPTIONAL"; - break; - case DECL_KIND: - attr = "KIND"; - break; - case DECL_LEN: - attr = "LEN"; - break; - case DECL_PARAMETER: - attr = "PARAMETER"; - break; - case DECL_POINTER: - attr = "POINTER"; - break; - case DECL_PROTECTED: - attr = "PROTECTED"; - break; - case DECL_PRIVATE: - attr = "PRIVATE"; - break; - case DECL_PUBLIC: - attr = "PUBLIC"; - break; - case DECL_SAVE: - attr = "SAVE"; - break; - case DECL_STATIC: - attr = "STATIC"; - break; - case DECL_AUTOMATIC: - attr = "AUTOMATIC"; - break; - case DECL_TARGET: - attr = "TARGET"; - break; - case DECL_IS_BIND_C: - attr = "IS_BIND_C"; - break; - case DECL_VALUE: - attr = "VALUE"; - break; - case DECL_VOLATILE: - attr = "VOLATILE"; - break; - default: - attr = NULL; /* This shouldn't happen. */ - } - - gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]); - m = MATCH_ERROR; - goto cleanup; - } - - /* Now that we've dealt with duplicate attributes, add the attributes - to the current attribute. */ - for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) - { - if (seen[d] == 0) - continue; - else - attr_seen = 1; - - if ((d == DECL_STATIC || d == DECL_AUTOMATIC) - && !flag_dec_static) - { - gfc_error ("%s at %L is a DEC extension, enable with " - "%<-fdec-static%>", - d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]); - m = MATCH_ERROR; - goto cleanup; - } - /* Allow SAVE with STATIC, but don't complain. */ - if (d == DECL_STATIC && seen[DECL_SAVE]) - continue; - - if (gfc_comp_struct (gfc_current_state ()) - && d != DECL_DIMENSION && d != DECL_CODIMENSION - && d != DECL_POINTER && d != DECL_PRIVATE - && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) - { - bool is_derived = gfc_current_state () == COMP_DERIVED; - if (d == DECL_ALLOCATABLE) - { - if (!gfc_notify_std (GFC_STD_F2003, is_derived - ? G_("ALLOCATABLE attribute at %C in a " - "TYPE definition") - : G_("ALLOCATABLE attribute at %C in a " - "STRUCTURE definition"))) - { - m = MATCH_ERROR; - goto cleanup; - } - } - else if (d == DECL_KIND) - { - if (!gfc_notify_std (GFC_STD_F2003, is_derived - ? G_("KIND attribute at %C in a " - "TYPE definition") - : G_("KIND attribute at %C in a " - "STRUCTURE definition"))) - { - m = MATCH_ERROR; - goto cleanup; - } - if (current_ts.type != BT_INTEGER) - { - gfc_error ("Component with KIND attribute at %C must be " - "INTEGER"); - m = MATCH_ERROR; - goto cleanup; - } - } - else if (d == DECL_LEN) - { - if (!gfc_notify_std (GFC_STD_F2003, is_derived - ? G_("LEN attribute at %C in a " - "TYPE definition") - : G_("LEN attribute at %C in a " - "STRUCTURE definition"))) - { - m = MATCH_ERROR; - goto cleanup; - } - if (current_ts.type != BT_INTEGER) - { - gfc_error ("Component with LEN attribute at %C must be " - "INTEGER"); - m = MATCH_ERROR; - goto cleanup; - } - } - else - { - gfc_error (is_derived ? G_("Attribute at %L is not allowed in a " - "TYPE definition") - : G_("Attribute at %L is not allowed in a " - "STRUCTURE definition"), &seen_at[d]); - m = MATCH_ERROR; - goto cleanup; - } - } - - if ((d == DECL_PRIVATE || d == DECL_PUBLIC) - && gfc_current_state () != COMP_MODULE) - { - if (d == DECL_PRIVATE) - attr = "PRIVATE"; - else - attr = "PUBLIC"; - if (gfc_current_state () == COMP_DERIVED - && gfc_state_stack->previous - && gfc_state_stack->previous->state == COMP_MODULE) - { - if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s " - "at %L in a TYPE definition", attr, - &seen_at[d])) - { - m = MATCH_ERROR; - goto cleanup; - } - } - else - { - gfc_error ("%s attribute at %L is not allowed outside of the " - "specification part of a module", attr, &seen_at[d]); - m = MATCH_ERROR; - goto cleanup; - } - } - - if (gfc_current_state () != COMP_DERIVED - && (d == DECL_KIND || d == DECL_LEN)) - { - gfc_error ("Attribute at %L is not allowed outside a TYPE " - "definition", &seen_at[d]); - m = MATCH_ERROR; - goto cleanup; - } - - switch (d) - { - case DECL_ALLOCATABLE: - t = gfc_add_allocatable (¤t_attr, &seen_at[d]); - break; - - case DECL_ASYNCHRONOUS: - if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C")) - t = false; - else - t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]); - break; - - case DECL_CODIMENSION: - t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); - break; - - case DECL_CONTIGUOUS: - if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C")) - t = false; - else - t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]); - break; - - case DECL_DIMENSION: - t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); - break; - - case DECL_EXTERNAL: - t = gfc_add_external (¤t_attr, &seen_at[d]); - break; - - case DECL_IN: - t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]); - break; - - case DECL_OUT: - t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]); - break; - - case DECL_INOUT: - t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]); - break; - - case DECL_INTRINSIC: - t = gfc_add_intrinsic (¤t_attr, &seen_at[d]); - break; - - case DECL_OPTIONAL: - t = gfc_add_optional (¤t_attr, &seen_at[d]); - break; - - case DECL_KIND: - t = gfc_add_kind (¤t_attr, &seen_at[d]); - break; - - case DECL_LEN: - t = gfc_add_len (¤t_attr, &seen_at[d]); - break; - - case DECL_PARAMETER: - t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]); - break; - - case DECL_POINTER: - t = gfc_add_pointer (¤t_attr, &seen_at[d]); - break; - - case DECL_PROTECTED: - if (gfc_current_state () != COMP_MODULE - || (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.flavor != FL_MODULE)) - { - gfc_error ("PROTECTED at %C only allowed in specification " - "part of a module"); - t = false; - break; - } - - if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C")) - t = false; - else - t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]); - break; - - case DECL_PRIVATE: - t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, - &seen_at[d]); - break; - - case DECL_PUBLIC: - t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL, - &seen_at[d]); - break; - - case DECL_STATIC: - case DECL_SAVE: - t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); - break; - - case DECL_AUTOMATIC: - t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]); - break; - - case DECL_TARGET: - t = gfc_add_target (¤t_attr, &seen_at[d]); - break; - - case DECL_IS_BIND_C: - t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0); - break; - - case DECL_VALUE: - if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C")) - t = false; - else - t = gfc_add_value (¤t_attr, NULL, &seen_at[d]); - break; - - case DECL_VOLATILE: - if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C")) - t = false; - else - t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]); - break; - - default: - gfc_internal_error ("match_attr_spec(): Bad attribute"); - } - - if (!t) - { - m = MATCH_ERROR; - goto cleanup; - } - } - - /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */ - if ((gfc_current_state () == COMP_MODULE - || gfc_current_state () == COMP_SUBMODULE) - && !current_attr.save - && (gfc_option.allow_std & GFC_STD_F2008) != 0) - current_attr.save = SAVE_IMPLICIT; - - colon_seen = 1; - return MATCH_YES; - -cleanup: - gfc_current_locus = start; - gfc_free_array_spec (current_as); - current_as = NULL; - attr_seen = 0; - return m; -} - - -/* Set the binding label, dest_label, either with the binding label - stored in the given gfc_typespec, ts, or if none was provided, it - will be the symbol name in all lower case, as required by the draft - (J3/04-007, section 15.4.1). If a binding label was given and - there is more than one argument (num_idents), it is an error. */ - -static bool -set_binding_label (const char **dest_label, const char *sym_name, - int num_idents) -{ - if (num_idents > 1 && has_name_equals) - { - gfc_error ("Multiple identifiers provided with " - "single NAME= specifier at %C"); - return false; - } - - if (curr_binding_label) - /* Binding label given; store in temp holder till have sym. */ - *dest_label = curr_binding_label; - else - { - /* No binding label given, and the NAME= specifier did not exist, - which means there was no NAME="". */ - if (sym_name != NULL && has_name_equals == 0) - *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name)); - } - - return true; -} - - -/* Set the status of the given common block as being BIND(C) or not, - depending on the given parameter, is_bind_c. */ - -static void -set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c) -{ - com_block->is_bind_c = is_bind_c; - return; -} - - -/* Verify that the given gfc_typespec is for a C interoperable type. */ - -bool -gfc_verify_c_interop (gfc_typespec *ts) -{ - if (ts->type == BT_DERIVED && ts->u.derived != NULL) - return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c) - ? true : false; - else if (ts->type == BT_CLASS) - return false; - else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED) - return false; - - return true; -} - - -/* Verify that the variables of a given common block, which has been - defined with the attribute specifier bind(c), to be of a C - interoperable type. Errors will be reported here, if - encountered. */ - -bool -verify_com_block_vars_c_interop (gfc_common_head *com_block) -{ - gfc_symbol *curr_sym = NULL; - bool retval = true; - - curr_sym = com_block->head; - - /* Make sure we have at least one symbol. */ - if (curr_sym == NULL) - return retval; - - /* Here we know we have a symbol, so we'll execute this loop - at least once. */ - do - { - /* The second to last param, 1, says this is in a common block. */ - retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block); - curr_sym = curr_sym->common_next; - } while (curr_sym != NULL); - - return retval; -} - - -/* Verify that a given BIND(C) symbol is C interoperable. If it is not, - an appropriate error message is reported. */ - -bool -verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, - int is_in_common, gfc_common_head *com_block) -{ - bool bind_c_function = false; - bool retval = true; - - if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c) - bind_c_function = true; - - if (tmp_sym->attr.function && tmp_sym->result != NULL) - { - tmp_sym = tmp_sym->result; - /* Make sure it wasn't an implicitly typed result. */ - if (tmp_sym->attr.implicit_type && warn_c_binding_type) - { - gfc_warning (OPT_Wc_binding_type, - "Implicitly declared BIND(C) function %qs at " - "%L may not be C interoperable", tmp_sym->name, - &tmp_sym->declared_at); - tmp_sym->ts.f90_type = tmp_sym->ts.type; - /* Mark it as C interoperable to prevent duplicate warnings. */ - tmp_sym->ts.is_c_interop = 1; - tmp_sym->attr.is_c_interop = 1; - } - } - - /* Here, we know we have the bind(c) attribute, so if we have - enough type info, then verify that it's a C interop kind. - The info could be in the symbol already, or possibly still in - the given ts (current_ts), so look in both. */ - if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) - { - if (!gfc_verify_c_interop (&(tmp_sym->ts))) - { - /* See if we're dealing with a sym in a common block or not. */ - if (is_in_common == 1 && warn_c_binding_type) - { - gfc_warning (OPT_Wc_binding_type, - "Variable %qs in common block %qs at %L " - "may not be a C interoperable " - "kind though common block %qs is BIND(C)", - tmp_sym->name, com_block->name, - &(tmp_sym->declared_at), com_block->name); - } - else - { - if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED) - gfc_error ("Type declaration %qs at %L is not C " - "interoperable but it is BIND(C)", - tmp_sym->name, &(tmp_sym->declared_at)); - else if (warn_c_binding_type) - gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L " - "may not be a C interoperable " - "kind but it is BIND(C)", - tmp_sym->name, &(tmp_sym->declared_at)); - } - } - - /* Variables declared w/in a common block can't be bind(c) - since there's no way for C to see these variables, so there's - semantically no reason for the attribute. */ - if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) - { - gfc_error ("Variable %qs in common block %qs at " - "%L cannot be declared with BIND(C) " - "since it is not a global", - tmp_sym->name, com_block->name, - &(tmp_sym->declared_at)); - retval = false; - } - - /* Scalar variables that are bind(c) cannot have the pointer - or allocatable attributes. */ - if (tmp_sym->attr.is_bind_c == 1) - { - if (tmp_sym->attr.pointer == 1) - { - gfc_error ("Variable %qs at %L cannot have both the " - "POINTER and BIND(C) attributes", - tmp_sym->name, &(tmp_sym->declared_at)); - retval = false; - } - - if (tmp_sym->attr.allocatable == 1) - { - gfc_error ("Variable %qs at %L cannot have both the " - "ALLOCATABLE and BIND(C) attributes", - tmp_sym->name, &(tmp_sym->declared_at)); - retval = false; - } - - } - - /* If it is a BIND(C) function, make sure the return value is a - scalar value. The previous tests in this function made sure - the type is interoperable. */ - if (bind_c_function && tmp_sym->as != NULL) - gfc_error ("Return type of BIND(C) function %qs at %L cannot " - "be an array", tmp_sym->name, &(tmp_sym->declared_at)); - - /* BIND(C) functions cannot return a character string. */ - if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) - if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL - || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT - || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0) - gfc_error ("Return type of BIND(C) function %qs of character " - "type at %L must have length 1", tmp_sym->name, - &(tmp_sym->declared_at)); - } - - /* See if the symbol has been marked as private. If it has, make sure - there is no binding label and warn the user if there is one. */ - if (tmp_sym->attr.access == ACCESS_PRIVATE - && tmp_sym->binding_label) - /* Use gfc_warning_now because we won't say that the symbol fails - just because of this. */ - gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been " - "given the binding label %qs", tmp_sym->name, - &(tmp_sym->declared_at), tmp_sym->binding_label); - - return retval; -} - - -/* Set the appropriate fields for a symbol that's been declared as - BIND(C) (the is_bind_c flag and the binding label), and verify that - the type is C interoperable. Errors are reported by the functions - used to set/test these fields. */ - -static bool -set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) -{ - bool retval = true; - - /* TODO: Do we need to make sure the vars aren't marked private? */ - - /* Set the is_bind_c bit in symbol_attribute. */ - gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0); - - if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents)) - return false; - - return retval; -} - - -/* Set the fields marking the given common block as BIND(C), including - a binding label, and report any errors encountered. */ - -static bool -set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) -{ - bool retval = true; - - /* destLabel, common name, typespec (which may have binding label). */ - if (!set_binding_label (&com_block->binding_label, com_block->name, - num_idents)) - return false; - - /* Set the given common block (com_block) to being bind(c) (1). */ - set_com_block_bind_c (com_block, 1); - - return retval; -} - - -/* Retrieve the list of one or more identifiers that the given bind(c) - attribute applies to. */ - -static bool -get_bind_c_idents (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - int num_idents = 0; - gfc_symbol *tmp_sym = NULL; - match found_id; - gfc_common_head *com_block = NULL; - - if (gfc_match_name (name) == MATCH_YES) - { - found_id = MATCH_YES; - gfc_get_ha_symbol (name, &tmp_sym); - } - else if (gfc_match_common_name (name) == MATCH_YES) - { - found_id = MATCH_YES; - com_block = gfc_get_common (name, 0); - } - else - { - gfc_error ("Need either entity or common block name for " - "attribute specification statement at %C"); - return false; - } - - /* Save the current identifier and look for more. */ - do - { - /* Increment the number of identifiers found for this spec stmt. */ - num_idents++; - - /* Make sure we have a sym or com block, and verify that it can - be bind(c). Set the appropriate field(s) and look for more - identifiers. */ - if (tmp_sym != NULL || com_block != NULL) - { - if (tmp_sym != NULL) - { - if (!set_verify_bind_c_sym (tmp_sym, num_idents)) - return false; - } - else - { - if (!set_verify_bind_c_com_block (com_block, num_idents)) - return false; - } - - /* Look to see if we have another identifier. */ - tmp_sym = NULL; - if (gfc_match_eos () == MATCH_YES) - found_id = MATCH_NO; - else if (gfc_match_char (',') != MATCH_YES) - found_id = MATCH_NO; - else if (gfc_match_name (name) == MATCH_YES) - { - found_id = MATCH_YES; - gfc_get_ha_symbol (name, &tmp_sym); - } - else if (gfc_match_common_name (name) == MATCH_YES) - { - found_id = MATCH_YES; - com_block = gfc_get_common (name, 0); - } - else - { - gfc_error ("Missing entity or common block name for " - "attribute specification statement at %C"); - return false; - } - } - else - { - gfc_internal_error ("Missing symbol"); - } - } while (found_id == MATCH_YES); - - /* if we get here we were successful */ - return true; -} - - -/* Try and match a BIND(C) attribute specification statement. */ - -match -gfc_match_bind_c_stmt (void) -{ - match found_match = MATCH_NO; - gfc_typespec *ts; - - ts = ¤t_ts; - - /* This may not be necessary. */ - gfc_clear_ts (ts); - /* Clear the temporary binding label holder. */ - curr_binding_label = NULL; - - /* Look for the bind(c). */ - found_match = gfc_match_bind_c (NULL, true); - - if (found_match == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C")) - return MATCH_ERROR; - - /* Look for the :: now, but it is not required. */ - gfc_match (" :: "); - - /* Get the identifier(s) that needs to be updated. This may need to - change to hand the flag(s) for the attr specified so all identifiers - found can have all appropriate parts updated (assuming that the same - spec stmt can have multiple attrs, such as both bind(c) and - allocatable...). */ - if (!get_bind_c_idents ()) - /* Error message should have printed already. */ - return MATCH_ERROR; - } - - return found_match; -} - - -/* Match a data declaration statement. */ - -match -gfc_match_data_decl (void) -{ - gfc_symbol *sym; - match m; - int elem; - - type_param_spec_list = NULL; - decl_type_param_list = NULL; - - num_idents_on_line = 0; - - m = gfc_match_decl_type_spec (¤t_ts, 0); - if (m != MATCH_YES) - return m; - - if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) - && !gfc_comp_struct (gfc_current_state ())) - { - sym = gfc_use_derived (current_ts.u.derived); - - if (sym == NULL) - { - m = MATCH_ERROR; - goto cleanup; - } - - current_ts.u.derived = sym; - } - - m = match_attr_spec (); - if (m == MATCH_ERROR) - { - m = MATCH_NO; - goto cleanup; - } - - if (current_ts.type == BT_CLASS - && current_ts.u.derived->attr.unlimited_polymorphic) - goto ok; - - if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) - && current_ts.u.derived->components == NULL - && !current_ts.u.derived->attr.zero_comp) - { - - if (current_attr.pointer && gfc_comp_struct (gfc_current_state ())) - goto ok; - - if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED) - goto ok; - - gfc_find_symbol (current_ts.u.derived->name, - current_ts.u.derived->ns, 1, &sym); - - /* Any symbol that we find had better be a type definition - which has its components defined, or be a structure definition - actively being parsed. */ - if (sym != NULL && gfc_fl_struct (sym->attr.flavor) - && (current_ts.u.derived->components != NULL - || current_ts.u.derived->attr.zero_comp - || current_ts.u.derived == gfc_new_block)) - goto ok; - - gfc_error ("Derived type at %C has not been previously defined " - "and so cannot appear in a derived type definition"); - m = MATCH_ERROR; - goto cleanup; - } - -ok: - /* If we have an old-style character declaration, and no new-style - attribute specifications, then there a comma is optional between - the type specification and the variable list. */ - if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector) - gfc_match_char (','); - - /* Give the types/attributes to symbols that follow. Give the element - a number so that repeat character length expressions can be copied. */ - elem = 1; - for (;;) - { - num_idents_on_line++; - m = variable_decl (elem++); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - break; - - if (gfc_match_eos () == MATCH_YES) - goto cleanup; - if (gfc_match_char (',') != MATCH_YES) - break; - } - - if (!gfc_error_flag_test ()) - { - /* An anonymous structure declaration is unambiguous; if we matched one - according to gfc_match_structure_decl, we need to return MATCH_YES - here to avoid confusing the remaining matchers, even if there was an - error during variable_decl. We must flush any such errors. Note this - causes the parser to gracefully continue parsing the remaining input - as a structure body, which likely follows. */ - if (current_ts.type == BT_DERIVED && current_ts.u.derived - && gfc_fl_struct (current_ts.u.derived->attr.flavor)) - { - gfc_error_now ("Syntax error in anonymous structure declaration" - " at %C"); - /* Skip the bad variable_decl and line up for the start of the - structure body. */ - gfc_error_recovery (); - m = MATCH_YES; - goto cleanup; - } - - gfc_error ("Syntax error in data declaration at %C"); - } - - m = MATCH_ERROR; - - gfc_free_data_all (gfc_current_ns); - -cleanup: - if (saved_kind_expr) - gfc_free_expr (saved_kind_expr); - if (type_param_spec_list) - gfc_free_actual_arglist (type_param_spec_list); - if (decl_type_param_list) - gfc_free_actual_arglist (decl_type_param_list); - saved_kind_expr = NULL; - gfc_free_array_spec (current_as); - current_as = NULL; - return m; -} - -static bool -in_module_or_interface(void) -{ - if (gfc_current_state () == COMP_MODULE - || gfc_current_state () == COMP_SUBMODULE - || gfc_current_state () == COMP_INTERFACE) - return true; - - if (gfc_state_stack->state == COMP_CONTAINS - || gfc_state_stack->state == COMP_FUNCTION - || gfc_state_stack->state == COMP_SUBROUTINE) - { - gfc_state_data *p; - for (p = gfc_state_stack->previous; p ; p = p->previous) - { - if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE - || p->state == COMP_INTERFACE) - return true; - } - } - return false; -} - -/* Match a prefix associated with a function or subroutine - declaration. If the typespec pointer is nonnull, then a typespec - can be matched. Note that if nothing matches, MATCH_YES is - returned (the null string was matched). */ - -match -gfc_match_prefix (gfc_typespec *ts) -{ - bool seen_type; - bool seen_impure; - bool found_prefix; - - gfc_clear_attr (¤t_attr); - seen_type = false; - seen_impure = false; - - gcc_assert (!gfc_matching_prefix); - gfc_matching_prefix = true; - - do - { - found_prefix = false; - - /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a - corresponding attribute seems natural and distinguishes these - procedures from procedure types of PROC_MODULE, which these are - as well. */ - if (gfc_match ("module% ") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C")) - goto error; - - if (!in_module_or_interface ()) - { - gfc_error ("MODULE prefix at %C found outside of a module, " - "submodule, or interface"); - goto error; - } - - current_attr.module_procedure = 1; - found_prefix = true; - } - - if (!seen_type && ts != NULL) - { - match m; - m = gfc_match_decl_type_spec (ts, 0); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES && gfc_match_space () == MATCH_YES) - { - seen_type = true; - found_prefix = true; - } - } - - if (gfc_match ("elemental% ") == MATCH_YES) - { - if (!gfc_add_elemental (¤t_attr, NULL)) - goto error; - - found_prefix = true; - } - - if (gfc_match ("pure% ") == MATCH_YES) - { - if (!gfc_add_pure (¤t_attr, NULL)) - goto error; - - found_prefix = true; - } - - if (gfc_match ("recursive% ") == MATCH_YES) - { - if (!gfc_add_recursive (¤t_attr, NULL)) - goto error; - - found_prefix = true; - } - - /* IMPURE is a somewhat special case, as it needs not set an actual - attribute but rather only prevents ELEMENTAL routines from being - automatically PURE. */ - if (gfc_match ("impure% ") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C")) - goto error; - - seen_impure = true; - found_prefix = true; - } - } - while (found_prefix); - - /* IMPURE and PURE must not both appear, of course. */ - if (seen_impure && current_attr.pure) - { - gfc_error ("PURE and IMPURE must not appear both at %C"); - goto error; - } - - /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */ - if (!seen_impure && current_attr.elemental && !current_attr.pure) - { - if (!gfc_add_pure (¤t_attr, NULL)) - goto error; - } - - /* At this point, the next item is not a prefix. */ - gcc_assert (gfc_matching_prefix); - - gfc_matching_prefix = false; - return MATCH_YES; - -error: - gcc_assert (gfc_matching_prefix); - gfc_matching_prefix = false; - return MATCH_ERROR; -} - - -/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */ - -static bool -copy_prefix (symbol_attribute *dest, locus *where) -{ - if (dest->module_procedure) - { - if (current_attr.elemental) - dest->elemental = 1; - - if (current_attr.pure) - dest->pure = 1; - - if (current_attr.recursive) - dest->recursive = 1; - - /* Module procedures are unusual in that the 'dest' is copied from - the interface declaration. However, this is an oportunity to - check that the submodule declaration is compliant with the - interface. */ - if (dest->elemental && !current_attr.elemental) - { - gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is " - "missing at %L", where); - return false; - } - - if (dest->pure && !current_attr.pure) - { - gfc_error ("PURE prefix in MODULE PROCEDURE interface is " - "missing at %L", where); - return false; - } - - if (dest->recursive && !current_attr.recursive) - { - gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is " - "missing at %L", where); - return false; - } - - return true; - } - - if (current_attr.elemental && !gfc_add_elemental (dest, where)) - return false; - - if (current_attr.pure && !gfc_add_pure (dest, where)) - return false; - - if (current_attr.recursive && !gfc_add_recursive (dest, where)) - return false; - - return true; -} - - -/* Match a formal argument list or, if typeparam is true, a - type_param_name_list. */ - -match -gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, - int null_flag, bool typeparam) -{ - gfc_formal_arglist *head, *tail, *p, *q; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - gfc_formal_arglist *formal = NULL; - - head = tail = NULL; - - /* Keep the interface formal argument list and null it so that the - matching for the new declaration can be done. The numbers and - names of the arguments are checked here. The interface formal - arguments are retained in formal_arglist and the characteristics - are compared in resolve.c(resolve_fl_procedure). See the remark - in get_proc_name about the eventual need to copy the formal_arglist - and populate the formal namespace of the interface symbol. */ - if (progname->attr.module_procedure - && progname->attr.host_assoc) - { - formal = progname->formal; - progname->formal = NULL; - } - - if (gfc_match_char ('(') != MATCH_YES) - { - if (null_flag) - goto ok; - return MATCH_NO; - } - - if (gfc_match_char (')') == MATCH_YES) - { - if (typeparam) - { - gfc_error_now ("A type parameter list is required at %C"); - m = MATCH_ERROR; - goto cleanup; - } - else - goto ok; - } - - for (;;) - { - if (gfc_match_char ('*') == MATCH_YES) - { - sym = NULL; - if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS, - "Alternate-return argument at %C")) - { - m = MATCH_ERROR; - goto cleanup; - } - else if (typeparam) - gfc_error_now ("A parameter name is required at %C"); - } - else - { - m = gfc_match_name (name); - if (m != MATCH_YES) - { - if(typeparam) - gfc_error_now ("A parameter name is required at %C"); - goto cleanup; - } - - if (!typeparam && gfc_get_symbol (name, NULL, &sym)) - goto cleanup; - else if (typeparam - && gfc_get_symbol (name, progname->f2k_derived, &sym)) - goto cleanup; - } - - p = gfc_get_formal_arglist (); - - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = p; - } - - tail->sym = sym; - - /* We don't add the VARIABLE flavor because the name could be a - dummy procedure. We don't apply these attributes to formal - arguments of statement functions. */ - if (sym != NULL && !st_flag - && (!gfc_add_dummy(&sym->attr, sym->name, NULL) - || !gfc_missing_attr (&sym->attr, NULL))) - { - m = MATCH_ERROR; - goto cleanup; - } - - /* The name of a program unit can be in a different namespace, - so check for it explicitly. After the statement is accepted, - the name is checked for especially in gfc_get_symbol(). */ - if (gfc_new_block != NULL && sym != NULL && !typeparam - && strcmp (sym->name, gfc_new_block->name) == 0) - { - gfc_error ("Name %qs at %C is the name of the procedure", - sym->name); - m = MATCH_ERROR; - goto cleanup; - } - - if (gfc_match_char (')') == MATCH_YES) - goto ok; - - m = gfc_match_char (','); - if (m != MATCH_YES) - { - if (typeparam) - gfc_error_now ("Expected parameter list in type declaration " - "at %C"); - else - gfc_error ("Unexpected junk in formal argument list at %C"); - goto cleanup; - } - } - -ok: - /* Check for duplicate symbols in the formal argument list. */ - if (head != NULL) - { - for (p = head; p->next; p = p->next) - { - if (p->sym == NULL) - continue; - - for (q = p->next; q; q = q->next) - if (p->sym == q->sym) - { - if (typeparam) - gfc_error_now ("Duplicate name %qs in parameter " - "list at %C", p->sym->name); - else - gfc_error ("Duplicate symbol %qs in formal argument " - "list at %C", p->sym->name); - - m = MATCH_ERROR; - goto cleanup; - } - } - } - - if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)) - { - m = MATCH_ERROR; - goto cleanup; - } - - /* gfc_error_now used in following and return with MATCH_YES because - doing otherwise results in a cascade of extraneous errors and in - some cases an ICE in symbol.c(gfc_release_symbol). */ - if (progname->attr.module_procedure && progname->attr.host_assoc) - { - bool arg_count_mismatch = false; - - if (!formal && head) - arg_count_mismatch = true; - - /* Abbreviated module procedure declaration is not meant to have any - formal arguments! */ - if (!progname->abr_modproc_decl && formal && !head) - arg_count_mismatch = true; - - for (p = formal, q = head; p && q; p = p->next, q = q->next) - { - if ((p->next != NULL && q->next == NULL) - || (p->next == NULL && q->next != NULL)) - arg_count_mismatch = true; - else if ((p->sym == NULL && q->sym == NULL) - || strcmp (p->sym->name, q->sym->name) == 0) - continue; - else - gfc_error_now ("Mismatch in MODULE PROCEDURE formal " - "argument names (%s/%s) at %C", - p->sym->name, q->sym->name); - } - - if (arg_count_mismatch) - gfc_error_now ("Mismatch in number of MODULE PROCEDURE " - "formal arguments at %C"); - } - - return MATCH_YES; - -cleanup: - gfc_free_formal_arglist (head); - return m; -} - - -/* Match a RESULT specification following a function declaration or - ENTRY statement. Also matches the end-of-statement. */ - -static match -match_result (gfc_symbol *function, gfc_symbol **result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *r; - match m; - - if (gfc_match (" result (") != MATCH_YES) - return MATCH_NO; - - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - /* Get the right paren, and that's it because there could be the - bind(c) attribute after the result clause. */ - if (gfc_match_char (')') != MATCH_YES) - { - /* TODO: should report the missing right paren here. */ - return MATCH_ERROR; - } - - if (strcmp (function->name, name) == 0) - { - gfc_error ("RESULT variable at %C must be different than function name"); - return MATCH_ERROR; - } - - if (gfc_get_symbol (name, NULL, &r)) - return MATCH_ERROR; - - if (!gfc_add_result (&r->attr, r->name, NULL)) - return MATCH_ERROR; - - *result = r; - - return MATCH_YES; -} - - -/* Match a function suffix, which could be a combination of a result - clause and BIND(C), either one, or neither. The draft does not - require them to come in a specific order. */ - -static match -gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) -{ - match is_bind_c; /* Found bind(c). */ - match is_result; /* Found result clause. */ - match found_match; /* Status of whether we've found a good match. */ - char peek_char; /* Character we're going to peek at. */ - bool allow_binding_name; - - /* Initialize to having found nothing. */ - found_match = MATCH_NO; - is_bind_c = MATCH_NO; - is_result = MATCH_NO; - - /* Get the next char to narrow between result and bind(c). */ - gfc_gobble_whitespace (); - peek_char = gfc_peek_ascii_char (); - - /* C binding names are not allowed for internal procedures. */ - if (gfc_current_state () == COMP_CONTAINS - && sym->ns->proc_name->attr.flavor != FL_MODULE) - allow_binding_name = false; - else - allow_binding_name = true; - - switch (peek_char) - { - case 'r': - /* Look for result clause. */ - is_result = match_result (sym, result); - if (is_result == MATCH_YES) - { - /* Now see if there is a bind(c) after it. */ - is_bind_c = gfc_match_bind_c (sym, allow_binding_name); - /* We've found the result clause and possibly bind(c). */ - found_match = MATCH_YES; - } - else - /* This should only be MATCH_ERROR. */ - found_match = is_result; - break; - case 'b': - /* Look for bind(c) first. */ - is_bind_c = gfc_match_bind_c (sym, allow_binding_name); - if (is_bind_c == MATCH_YES) - { - /* Now see if a result clause followed it. */ - is_result = match_result (sym, result); - found_match = MATCH_YES; - } - else - { - /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */ - found_match = MATCH_ERROR; - } - break; - default: - gfc_error ("Unexpected junk after function declaration at %C"); - found_match = MATCH_ERROR; - break; - } - - if (is_bind_c == MATCH_YES) - { - /* Fortran 2008 draft allows BIND(C) for internal procedures. */ - if (gfc_current_state () == COMP_CONTAINS - && sym->ns->proc_name->attr.flavor != FL_MODULE - && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " - "at %L may not be specified for an internal " - "procedure", &gfc_current_locus)) - return MATCH_ERROR; - - if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)) - return MATCH_ERROR; - } - - return found_match; -} - - -/* Procedure pointer return value without RESULT statement: - Add "hidden" result variable named "ppr@". */ - -static bool -add_hidden_procptr_result (gfc_symbol *sym) -{ - bool case1,case2; - - if (gfc_notification_std (GFC_STD_F2003) == ERROR) - return false; - - /* First usage case: PROCEDURE and EXTERNAL statements. */ - case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block () - && strcmp (gfc_current_block ()->name, sym->name) == 0 - && sym->attr.external; - /* Second usage case: INTERFACE statements. */ - case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous - && gfc_state_stack->previous->state == COMP_FUNCTION - && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0; - - if (case1 || case2) - { - gfc_symtree *stree; - if (case1) - gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false); - else - { - gfc_symtree *st2; - gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false); - st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@"); - st2->n.sym = stree->n.sym; - stree->n.sym->refs++; - } - sym->result = stree->n.sym; - - sym->result->attr.proc_pointer = sym->attr.proc_pointer; - sym->result->attr.pointer = sym->attr.pointer; - sym->result->attr.external = sym->attr.external; - sym->result->attr.referenced = sym->attr.referenced; - sym->result->ts = sym->ts; - sym->attr.proc_pointer = 0; - sym->attr.pointer = 0; - sym->attr.external = 0; - if (sym->result->attr.external && sym->result->attr.pointer) - { - sym->result->attr.pointer = 0; - sym->result->attr.proc_pointer = 1; - } - - return gfc_add_result (&sym->result->attr, sym->result->name, NULL); - } - /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */ - else if (sym->attr.function && !sym->attr.external && sym->attr.pointer - && sym->result && sym->result != sym && sym->result->attr.external - && sym == gfc_current_ns->proc_name - && sym == sym->result->ns->proc_name - && strcmp ("ppr@", sym->result->name) == 0) - { - sym->result->attr.proc_pointer = 1; - sym->attr.pointer = 0; - return true; - } - else - return false; -} - - -/* Match the interface for a PROCEDURE declaration, - including brackets (R1212). */ - -static match -match_procedure_interface (gfc_symbol **proc_if) -{ - match m; - gfc_symtree *st; - locus old_loc, entry_loc; - gfc_namespace *old_ns = gfc_current_ns; - char name[GFC_MAX_SYMBOL_LEN + 1]; - - old_loc = entry_loc = gfc_current_locus; - gfc_clear_ts (¤t_ts); - - if (gfc_match (" (") != MATCH_YES) - { - gfc_current_locus = entry_loc; - return MATCH_NO; - } - - /* Get the type spec. for the procedure interface. */ - old_loc = gfc_current_locus; - m = gfc_match_decl_type_spec (¤t_ts, 0); - gfc_gobble_whitespace (); - if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')')) - goto got_ts; - - if (m == MATCH_ERROR) - return m; - - /* Procedure interface is itself a procedure. */ - gfc_current_locus = old_loc; - m = gfc_match_name (name); - - /* First look to see if it is already accessible in the current - namespace because it is use associated or contained. */ - st = NULL; - if (gfc_find_sym_tree (name, NULL, 0, &st)) - return MATCH_ERROR; - - /* If it is still not found, then try the parent namespace, if it - exists and create the symbol there if it is still not found. */ - if (gfc_current_ns->parent) - gfc_current_ns = gfc_current_ns->parent; - if (st == NULL && gfc_get_ha_sym_tree (name, &st)) - return MATCH_ERROR; - - gfc_current_ns = old_ns; - *proc_if = st->n.sym; - - if (*proc_if) - { - (*proc_if)->refs++; - /* Resolve interface if possible. That way, attr.procedure is only set - if it is declared by a later procedure-declaration-stmt, which is - invalid per F08:C1216 (cf. resolve_procedure_interface). */ - while ((*proc_if)->ts.interface - && *proc_if != (*proc_if)->ts.interface) - *proc_if = (*proc_if)->ts.interface; - - if ((*proc_if)->attr.flavor == FL_UNKNOWN - && (*proc_if)->ts.type == BT_UNKNOWN - && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, - (*proc_if)->name, NULL)) - return MATCH_ERROR; - } - -got_ts: - if (gfc_match (" )") != MATCH_YES) - { - gfc_current_locus = entry_loc; - return MATCH_NO; - } - - return MATCH_YES; -} - - -/* Match a PROCEDURE declaration (R1211). */ - -static match -match_procedure_decl (void) -{ - match m; - gfc_symbol *sym, *proc_if = NULL; - int num; - gfc_expr *initializer = NULL; - - /* Parse interface (with brackets). */ - m = match_procedure_interface (&proc_if); - if (m != MATCH_YES) - return m; - - /* Parse attributes (with colons). */ - m = match_attr_spec(); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c) - { - current_attr.is_bind_c = 1; - has_name_equals = 0; - curr_binding_label = NULL; - } - - /* Get procedure symbols. */ - for(num=1;;num++) - { - m = gfc_match_symbol (&sym, 0); - if (m == MATCH_NO) - goto syntax; - else if (m == MATCH_ERROR) - return m; - - /* Add current_attr to the symbol attributes. */ - if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL)) - return MATCH_ERROR; - - if (sym->attr.is_bind_c) - { - /* Check for C1218. */ - if (!proc_if || !proc_if->attr.is_bind_c) - { - gfc_error ("BIND(C) attribute at %C requires " - "an interface with BIND(C)"); - return MATCH_ERROR; - } - /* Check for C1217. */ - if (has_name_equals && sym->attr.pointer) - { - gfc_error ("BIND(C) procedure with NAME may not have " - "POINTER attribute at %C"); - return MATCH_ERROR; - } - if (has_name_equals && sym->attr.dummy) - { - gfc_error ("Dummy procedure at %C may not have " - "BIND(C) attribute with NAME"); - return MATCH_ERROR; - } - /* Set binding label for BIND(C). */ - if (!set_binding_label (&sym->binding_label, sym->name, num)) - return MATCH_ERROR; - } - - if (!gfc_add_external (&sym->attr, NULL)) - return MATCH_ERROR; - - if (add_hidden_procptr_result (sym)) - sym = sym->result; - - if (!gfc_add_proc (&sym->attr, sym->name, NULL)) - return MATCH_ERROR; - - /* Set interface. */ - if (proc_if != NULL) - { - if (sym->ts.type != BT_UNKNOWN) - { - gfc_error ("Procedure %qs at %L already has basic type of %s", - sym->name, &gfc_current_locus, - gfc_basic_typename (sym->ts.type)); - return MATCH_ERROR; - } - sym->ts.interface = proc_if; - sym->attr.untyped = 1; - sym->attr.if_source = IFSRC_IFBODY; - } - else if (current_ts.type != BT_UNKNOWN) - { - if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) - return MATCH_ERROR; - sym->ts.interface = gfc_new_symbol ("", gfc_current_ns); - sym->ts.interface->ts = current_ts; - sym->ts.interface->attr.flavor = FL_PROCEDURE; - sym->ts.interface->attr.function = 1; - sym->attr.function = 1; - sym->attr.if_source = IFSRC_UNKNOWN; - } - - if (gfc_match (" =>") == MATCH_YES) - { - if (!current_attr.pointer) - { - gfc_error ("Initialization at %C isn't for a pointer variable"); - m = MATCH_ERROR; - goto cleanup; - } - - m = match_pointer_init (&initializer, 1); - if (m != MATCH_YES) - goto cleanup; - - if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)) - goto cleanup; - - } - - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - -syntax: - gfc_error ("Syntax error in PROCEDURE statement at %C"); - return MATCH_ERROR; - -cleanup: - /* Free stuff up and return. */ - gfc_free_expr (initializer); - return m; -} - - -static match -match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc); - - -/* Match a procedure pointer component declaration (R445). */ - -static match -match_ppc_decl (void) -{ - match m; - gfc_symbol *proc_if = NULL; - gfc_typespec ts; - int num; - gfc_component *c; - gfc_expr *initializer = NULL; - gfc_typebound_proc* tb; - char name[GFC_MAX_SYMBOL_LEN + 1]; - - /* Parse interface (with brackets). */ - m = match_procedure_interface (&proc_if); - if (m != MATCH_YES) - goto syntax; - - /* Parse attributes. */ - tb = XCNEW (gfc_typebound_proc); - tb->where = gfc_current_locus; - m = match_binding_attributes (tb, false, true); - if (m == MATCH_ERROR) - return m; - - gfc_clear_attr (¤t_attr); - current_attr.procedure = 1; - current_attr.proc_pointer = 1; - current_attr.access = tb->access; - current_attr.flavor = FL_PROCEDURE; - - /* Match the colons (required). */ - if (gfc_match (" ::") != MATCH_YES) - { - gfc_error ("Expected %<::%> after binding-attributes at %C"); - return MATCH_ERROR; - } - - /* Check for C450. */ - if (!tb->nopass && proc_if == NULL) - { - gfc_error("NOPASS or explicit interface required at %C"); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C")) - return MATCH_ERROR; - - /* Match PPC names. */ - ts = current_ts; - for(num=1;;num++) - { - m = gfc_match_name (name); - if (m == MATCH_NO) - goto syntax; - else if (m == MATCH_ERROR) - return m; - - if (!gfc_add_component (gfc_current_block(), name, &c)) - return MATCH_ERROR; - - /* Add current_attr to the symbol attributes. */ - if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL)) - return MATCH_ERROR; - - if (!gfc_add_external (&c->attr, NULL)) - return MATCH_ERROR; - - if (!gfc_add_proc (&c->attr, name, NULL)) - return MATCH_ERROR; - - if (num == 1) - c->tb = tb; - else - { - c->tb = XCNEW (gfc_typebound_proc); - c->tb->where = gfc_current_locus; - *c->tb = *tb; - } - - /* Set interface. */ - if (proc_if != NULL) - { - c->ts.interface = proc_if; - c->attr.untyped = 1; - c->attr.if_source = IFSRC_IFBODY; - } - else if (ts.type != BT_UNKNOWN) - { - c->ts = ts; - c->ts.interface = gfc_new_symbol ("", gfc_current_ns); - c->ts.interface->result = c->ts.interface; - c->ts.interface->ts = ts; - c->ts.interface->attr.flavor = FL_PROCEDURE; - c->ts.interface->attr.function = 1; - c->attr.function = 1; - c->attr.if_source = IFSRC_UNKNOWN; - } - - if (gfc_match (" =>") == MATCH_YES) - { - m = match_pointer_init (&initializer, 1); - if (m != MATCH_YES) - { - gfc_free_expr (initializer); - return m; - } - c->initializer = initializer; - } - - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - -syntax: - gfc_error ("Syntax error in procedure pointer component at %C"); - return MATCH_ERROR; -} - - -/* Match a PROCEDURE declaration inside an interface (R1206). */ - -static match -match_procedure_in_interface (void) -{ - match m; - gfc_symbol *sym; - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; - - if (current_interface.type == INTERFACE_NAMELESS - || current_interface.type == INTERFACE_ABSTRACT) - { - gfc_error ("PROCEDURE at %C must be in a generic interface"); - return MATCH_ERROR; - } - - /* Check if the F2008 optional double colon appears. */ - gfc_gobble_whitespace (); - old_locus = gfc_current_locus; - if (gfc_match ("::") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2008, "double colon in " - "MODULE PROCEDURE statement at %L", &old_locus)) - return MATCH_ERROR; - } - else - gfc_current_locus = old_locus; - - for(;;) - { - m = gfc_match_name (name); - if (m == MATCH_NO) - goto syntax; - else if (m == MATCH_ERROR) - return m; - if (gfc_get_symbol (name, gfc_current_ns->parent, &sym)) - return MATCH_ERROR; - - if (!gfc_add_interface (sym)) - return MATCH_ERROR; - - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in PROCEDURE statement at %C"); - return MATCH_ERROR; -} - - -/* General matcher for PROCEDURE declarations. */ - -static match match_procedure_in_type (void); - -match -gfc_match_procedure (void) -{ - match m; - - switch (gfc_current_state ()) - { - case COMP_NONE: - case COMP_PROGRAM: - case COMP_MODULE: - case COMP_SUBMODULE: - case COMP_SUBROUTINE: - case COMP_FUNCTION: - case COMP_BLOCK: - m = match_procedure_decl (); - break; - case COMP_INTERFACE: - m = match_procedure_in_interface (); - break; - case COMP_DERIVED: - m = match_ppc_decl (); - break; - case COMP_DERIVED_CONTAINS: - m = match_procedure_in_type (); - break; - default: - return MATCH_NO; - } - - if (m != MATCH_YES) - return m; - - if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C")) - return MATCH_ERROR; - - return m; -} - - -/* Warn if a matched procedure has the same name as an intrinsic; this is - simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current - parser-state-stack to find out whether we're in a module. */ - -static void -do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func) -{ - bool in_module; - - in_module = (gfc_state_stack->previous - && (gfc_state_stack->previous->state == COMP_MODULE - || gfc_state_stack->previous->state == COMP_SUBMODULE)); - - gfc_warn_intrinsic_shadow (sym, in_module, func); -} - - -/* Match a function declaration. */ - -match -gfc_match_function_decl (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym, *result; - locus old_loc; - match m; - match suffix_match; - match found_match; /* Status returned by match func. */ - - if (gfc_current_state () != COMP_NONE - && gfc_current_state () != COMP_INTERFACE - && gfc_current_state () != COMP_CONTAINS) - return MATCH_NO; - - gfc_clear_ts (¤t_ts); - - old_loc = gfc_current_locus; - - m = gfc_match_prefix (¤t_ts); - if (m != MATCH_YES) - { - gfc_current_locus = old_loc; - return m; - } - - if (gfc_match ("function% %n", name) != MATCH_YES) - { - gfc_current_locus = old_loc; - return MATCH_NO; - } - - if (get_proc_name (name, &sym, false)) - return MATCH_ERROR; - - if (add_hidden_procptr_result (sym)) - sym = sym->result; - - if (current_attr.module_procedure) - sym->attr.module_procedure = 1; - - gfc_new_block = sym; - - m = gfc_match_formal_arglist (sym, 0, 0); - if (m == MATCH_NO) - { - gfc_error ("Expected formal argument list in function " - "definition at %C"); - m = MATCH_ERROR; - goto cleanup; - } - else if (m == MATCH_ERROR) - goto cleanup; - - result = NULL; - - /* According to the draft, the bind(c) and result clause can - come in either order after the formal_arg_list (i.e., either - can be first, both can exist together or by themselves or neither - one). Therefore, the match_result can't match the end of the - string, and check for the bind(c) or result clause in either order. */ - found_match = gfc_match_eos (); - - /* Make sure that it isn't already declared as BIND(C). If it is, it - must have been marked BIND(C) with a BIND(C) attribute and that is - not allowed for procedures. */ - if (sym->attr.is_bind_c == 1) - { - sym->attr.is_bind_c = 0; - - if (gfc_state_stack->previous - && gfc_state_stack->previous->state != COMP_SUBMODULE) - { - locus loc; - loc = sym->old_symbol != NULL - ? sym->old_symbol->declared_at : gfc_current_locus; - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", &loc); - } - } - - if (found_match != MATCH_YES) - { - /* If we haven't found the end-of-statement, look for a suffix. */ - suffix_match = gfc_match_suffix (sym, &result); - if (suffix_match == MATCH_YES) - /* Need to get the eos now. */ - found_match = gfc_match_eos (); - else - found_match = suffix_match; - } - - /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module - subprogram and a binding label is specified, it shall be the - same as the binding label specified in the corresponding module - procedure interface body. */ - if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol - && strcmp (sym->name, sym->old_symbol->name) == 0 - && sym->binding_label && sym->old_symbol->binding_label - && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) - { - const char *null = "NULL", *s1, *s2; - s1 = sym->binding_label; - if (!s1) s1 = null; - s2 = sym->old_symbol->binding_label; - if (!s2) s2 = null; - gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); - sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ - return MATCH_ERROR; - } - - if(found_match != MATCH_YES) - m = MATCH_ERROR; - else - { - /* Make changes to the symbol. */ - m = MATCH_ERROR; - - if (!gfc_add_function (&sym->attr, sym->name, NULL)) - goto cleanup; - - if (!gfc_missing_attr (&sym->attr, NULL)) - goto cleanup; - - if (!copy_prefix (&sym->attr, &sym->declared_at)) - { - if(!sym->attr.module_procedure) - goto cleanup; - else - gfc_error_check (); - } - - /* Delay matching the function characteristics until after the - specification block by signalling kind=-1. */ - sym->declared_at = old_loc; - if (current_ts.type != BT_UNKNOWN) - current_ts.kind = -1; - else - current_ts.kind = 0; - - if (result == NULL) - { - if (current_ts.type != BT_UNKNOWN - && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) - goto cleanup; - sym->result = sym; - } - else - { - if (current_ts.type != BT_UNKNOWN - && !gfc_add_type (result, ¤t_ts, &gfc_current_locus)) - goto cleanup; - sym->result = result; - } - - /* Warn if this procedure has the same name as an intrinsic. */ - do_warn_intrinsic_shadow (sym, true); - - return MATCH_YES; - } - -cleanup: - gfc_current_locus = old_loc; - return m; -} - - -/* This is mostly a copy of parse.c(add_global_procedure) but modified to - pass the name of the entry, rather than the gfc_current_block name, and - to return false upon finding an existing global entry. */ - -static bool -add_global_entry (const char *name, const char *binding_label, bool sub, - locus *where) -{ - gfc_gsymbol *s; - enum gfc_symbol_type type; - - type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; - - /* Only in Fortran 2003: For procedures with a binding label also the Fortran - name is a global identifier. */ - if (!binding_label || gfc_notification_std (GFC_STD_F2008)) - { - s = gfc_get_gsymbol (name, false); - - if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) - { - gfc_global_used (s, where); - return false; - } - else - { - s->type = type; - s->sym_name = name; - s->where = *where; - s->defined = 1; - s->ns = gfc_current_ns; - } - } - - /* Don't add the symbol multiple times. */ - if (binding_label - && (!gfc_notification_std (GFC_STD_F2008) - || strcmp (name, binding_label) != 0)) - { - s = gfc_get_gsymbol (binding_label, true); - - if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) - { - gfc_global_used (s, where); - return false; - } - else - { - s->type = type; - s->sym_name = name; - s->binding_label = binding_label; - s->where = *where; - s->defined = 1; - s->ns = gfc_current_ns; - } - } - - return true; -} - - -/* Match an ENTRY statement. */ - -match -gfc_match_entry (void) -{ - gfc_symbol *proc; - gfc_symbol *result; - gfc_symbol *entry; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_compile_state state; - match m; - gfc_entry_list *el; - locus old_loc; - bool module_procedure; - char peek_char; - match is_bind_c; - - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C")) - return MATCH_ERROR; - - state = gfc_current_state (); - if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) - { - switch (state) - { - case COMP_PROGRAM: - gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM"); - break; - case COMP_MODULE: - gfc_error ("ENTRY statement at %C cannot appear within a MODULE"); - break; - case COMP_SUBMODULE: - gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE"); - break; - case COMP_BLOCK_DATA: - gfc_error ("ENTRY statement at %C cannot appear within " - "a BLOCK DATA"); - break; - case COMP_INTERFACE: - gfc_error ("ENTRY statement at %C cannot appear within " - "an INTERFACE"); - break; - case COMP_STRUCTURE: - gfc_error ("ENTRY statement at %C cannot appear within " - "a STRUCTURE block"); - break; - case COMP_DERIVED: - gfc_error ("ENTRY statement at %C cannot appear within " - "a DERIVED TYPE block"); - break; - case COMP_IF: - gfc_error ("ENTRY statement at %C cannot appear within " - "an IF-THEN block"); - break; - case COMP_DO: - case COMP_DO_CONCURRENT: - gfc_error ("ENTRY statement at %C cannot appear within " - "a DO block"); - break; - case COMP_SELECT: - gfc_error ("ENTRY statement at %C cannot appear within " - "a SELECT block"); - break; - case COMP_FORALL: - gfc_error ("ENTRY statement at %C cannot appear within " - "a FORALL block"); - break; - case COMP_WHERE: - gfc_error ("ENTRY statement at %C cannot appear within " - "a WHERE block"); - break; - case COMP_CONTAINS: - gfc_error ("ENTRY statement at %C cannot appear within " - "a contained subprogram"); - break; - default: - gfc_error ("Unexpected ENTRY statement at %C"); - } - return MATCH_ERROR; - } - - if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION) - && gfc_state_stack->previous->state == COMP_INTERFACE) - { - gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE"); - return MATCH_ERROR; - } - - module_procedure = gfc_current_ns->parent != NULL - && gfc_current_ns->parent->proc_name - && gfc_current_ns->parent->proc_name->attr.flavor - == FL_MODULE; - - if (gfc_current_ns->parent != NULL - && gfc_current_ns->parent->proc_name - && !module_procedure) - { - gfc_error("ENTRY statement at %C cannot appear in a " - "contained procedure"); - return MATCH_ERROR; - } - - /* Module function entries need special care in get_proc_name - because previous references within the function will have - created symbols attached to the current namespace. */ - if (get_proc_name (name, &entry, - gfc_current_ns->parent != NULL - && module_procedure)) - return MATCH_ERROR; - - proc = gfc_current_block (); - - /* Make sure that it isn't already declared as BIND(C). If it is, it - must have been marked BIND(C) with a BIND(C) attribute and that is - not allowed for procedures. */ - if (entry->attr.is_bind_c == 1) - { - locus loc; - - entry->attr.is_bind_c = 0; - - loc = entry->old_symbol != NULL - ? entry->old_symbol->declared_at : gfc_current_locus; - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", &loc); - } - - /* Check what next non-whitespace character is so we can tell if there - is the required parens if we have a BIND(C). */ - old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - peek_char = gfc_peek_ascii_char (); - - if (state == COMP_SUBROUTINE) - { - m = gfc_match_formal_arglist (entry, 0, 1); - if (m != MATCH_YES) - return MATCH_ERROR; - - /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can - never be an internal procedure. */ - is_bind_c = gfc_match_bind_c (entry, true); - if (is_bind_c == MATCH_ERROR) - return MATCH_ERROR; - if (is_bind_c == MATCH_YES) - { - if (peek_char != '(') - { - gfc_error ("Missing required parentheses before BIND(C) at %C"); - return MATCH_ERROR; - } - - if (!gfc_add_is_bind_c (&(entry->attr), entry->name, - &(entry->declared_at), 1)) - return MATCH_ERROR; - - } - - if (!gfc_current_ns->parent - && !add_global_entry (name, entry->binding_label, true, - &old_loc)) - return MATCH_ERROR; - - /* An entry in a subroutine. */ - if (!gfc_add_entry (&entry->attr, entry->name, NULL) - || !gfc_add_subroutine (&entry->attr, entry->name, NULL)) - return MATCH_ERROR; - } - else - { - /* An entry in a function. - We need to take special care because writing - ENTRY f() - as - ENTRY f - is allowed, whereas - ENTRY f() RESULT (r) - can't be written as - ENTRY f RESULT (r). */ - if (gfc_match_eos () == MATCH_YES) - { - gfc_current_locus = old_loc; - /* Match the empty argument list, and add the interface to - the symbol. */ - m = gfc_match_formal_arglist (entry, 0, 1); - } - else - m = gfc_match_formal_arglist (entry, 0, 0); - - if (m != MATCH_YES) - return MATCH_ERROR; - - result = NULL; - - if (gfc_match_eos () == MATCH_YES) - { - if (!gfc_add_entry (&entry->attr, entry->name, NULL) - || !gfc_add_function (&entry->attr, entry->name, NULL)) - return MATCH_ERROR; - - entry->result = entry; - } - else - { - m = gfc_match_suffix (entry, &result); - if (m == MATCH_NO) - gfc_syntax_error (ST_ENTRY); - if (m != MATCH_YES) - return MATCH_ERROR; - - if (result) - { - if (!gfc_add_result (&result->attr, result->name, NULL) - || !gfc_add_entry (&entry->attr, result->name, NULL) - || !gfc_add_function (&entry->attr, result->name, NULL)) - return MATCH_ERROR; - entry->result = result; - } - else - { - if (!gfc_add_entry (&entry->attr, entry->name, NULL) - || !gfc_add_function (&entry->attr, entry->name, NULL)) - return MATCH_ERROR; - entry->result = entry; - } - } - - if (!gfc_current_ns->parent - && !add_global_entry (name, entry->binding_label, false, - &old_loc)) - return MATCH_ERROR; - } - - if (gfc_match_eos () != MATCH_YES) - { - gfc_syntax_error (ST_ENTRY); - return MATCH_ERROR; - } - - /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */ - if (proc->attr.elemental && entry->attr.is_bind_c) - { - gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an " - "elemental procedure", &entry->declared_at); - return MATCH_ERROR; - } - - entry->attr.recursive = proc->attr.recursive; - entry->attr.elemental = proc->attr.elemental; - entry->attr.pure = proc->attr.pure; - - el = gfc_get_entry_list (); - el->sym = entry; - el->next = gfc_current_ns->entries; - gfc_current_ns->entries = el; - if (el->next) - el->id = el->next->id + 1; - else - el->id = 1; - - new_st.op = EXEC_ENTRY; - new_st.ext.entry = el; - - return MATCH_YES; -} - - -/* Match a subroutine statement, including optional prefixes. */ - -match -gfc_match_subroutine (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - match is_bind_c; - char peek_char; - bool allow_binding_name; - locus loc; - - if (gfc_current_state () != COMP_NONE - && gfc_current_state () != COMP_INTERFACE - && gfc_current_state () != COMP_CONTAINS) - return MATCH_NO; - - m = gfc_match_prefix (NULL); - if (m != MATCH_YES) - return m; - - m = gfc_match ("subroutine% %n", name); - if (m != MATCH_YES) - return m; - - if (get_proc_name (name, &sym, false)) - return MATCH_ERROR; - - /* Set declared_at as it might point to, e.g., a PUBLIC statement, if - the symbol existed before. */ - sym->declared_at = gfc_current_locus; - - if (current_attr.module_procedure) - sym->attr.module_procedure = 1; - - if (add_hidden_procptr_result (sym)) - sym = sym->result; - - gfc_new_block = sym; - - /* Check what next non-whitespace character is so we can tell if there - is the required parens if we have a BIND(C). */ - gfc_gobble_whitespace (); - peek_char = gfc_peek_ascii_char (); - - if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) - return MATCH_ERROR; - - if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) - return MATCH_ERROR; - - /* Make sure that it isn't already declared as BIND(C). If it is, it - must have been marked BIND(C) with a BIND(C) attribute and that is - not allowed for procedures. */ - if (sym->attr.is_bind_c == 1) - { - sym->attr.is_bind_c = 0; - - if (gfc_state_stack->previous - && gfc_state_stack->previous->state != COMP_SUBMODULE) - { - locus loc; - loc = sym->old_symbol != NULL - ? sym->old_symbol->declared_at : gfc_current_locus; - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", &loc); - } - } - - /* C binding names are not allowed for internal procedures. */ - if (gfc_current_state () == COMP_CONTAINS - && sym->ns->proc_name->attr.flavor != FL_MODULE) - allow_binding_name = false; - else - allow_binding_name = true; - - /* Here, we are just checking if it has the bind(c) attribute, and if - so, then we need to make sure it's all correct. If it doesn't, - we still need to continue matching the rest of the subroutine line. */ - gfc_gobble_whitespace (); - loc = gfc_current_locus; - is_bind_c = gfc_match_bind_c (sym, allow_binding_name); - if (is_bind_c == MATCH_ERROR) - { - /* There was an attempt at the bind(c), but it was wrong. An - error message should have been printed w/in the gfc_match_bind_c - so here we'll just return the MATCH_ERROR. */ - return MATCH_ERROR; - } - - if (is_bind_c == MATCH_YES) - { - gfc_formal_arglist *arg; - - /* The following is allowed in the Fortran 2008 draft. */ - if (gfc_current_state () == COMP_CONTAINS - && sym->ns->proc_name->attr.flavor != FL_MODULE - && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " - "at %L may not be specified for an internal " - "procedure", &gfc_current_locus)) - return MATCH_ERROR; - - if (peek_char != '(') - { - gfc_error ("Missing required parentheses before BIND(C) at %C"); - return MATCH_ERROR; - } - - /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module - subprogram and a binding label is specified, it shall be the - same as the binding label specified in the corresponding module - procedure interface body. */ - if (sym->attr.module_procedure && sym->old_symbol - && strcmp (sym->name, sym->old_symbol->name) == 0 - && sym->binding_label && sym->old_symbol->binding_label - && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) - { - const char *null = "NULL", *s1, *s2; - s1 = sym->binding_label; - if (!s1) s1 = null; - s2 = sym->old_symbol->binding_label; - if (!s2) s2 = null; - gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); - sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ - return MATCH_ERROR; - } - - /* Scan the dummy arguments for an alternate return. */ - for (arg = sym->formal; arg; arg = arg->next) - if (!arg->sym) - { - gfc_error ("Alternate return dummy argument cannot appear in a " - "SUBROUTINE with the BIND(C) attribute at %L", &loc); - return MATCH_ERROR; - } - - if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)) - return MATCH_ERROR; - } - - if (gfc_match_eos () != MATCH_YES) - { - gfc_syntax_error (ST_SUBROUTINE); - return MATCH_ERROR; - } - - if (!copy_prefix (&sym->attr, &sym->declared_at)) - { - if(!sym->attr.module_procedure) - return MATCH_ERROR; - else - gfc_error_check (); - } - - /* Warn if it has the same name as an intrinsic. */ - do_warn_intrinsic_shadow (sym, false); - - return MATCH_YES; -} - - -/* Check that the NAME identifier in a BIND attribute or statement - is conform to C identifier rules. */ - -match -check_bind_name_identifier (char **name) -{ - char *n = *name, *p; - - /* Remove leading spaces. */ - while (*n == ' ') - n++; - - /* On an empty string, free memory and set name to NULL. */ - if (*n == '\0') - { - free (*name); - *name = NULL; - return MATCH_YES; - } - - /* Remove trailing spaces. */ - p = n + strlen(n) - 1; - while (*p == ' ') - *(p--) = '\0'; - - /* Insert the identifier into the symbol table. */ - p = xstrdup (n); - free (*name); - *name = p; - - /* Now check that identifier is valid under C rules. */ - if (ISDIGIT (*p)) - { - gfc_error ("Invalid C identifier in NAME= specifier at %C"); - return MATCH_ERROR; - } - - for (; *p; p++) - if (!(ISALNUM (*p) || *p == '_' || *p == '$')) - { - gfc_error ("Invalid C identifier in NAME= specifier at %C"); - return MATCH_ERROR; - } - - return MATCH_YES; -} - - -/* Match a BIND(C) specifier, with the optional 'name=' specifier if - given, and set the binding label in either the given symbol (if not - NULL), or in the current_ts. The symbol may be NULL because we may - encounter the BIND(C) before the declaration itself. Return - MATCH_NO if what we're looking at isn't a BIND(C) specifier, - MATCH_ERROR if it is a BIND(C) clause but an error was encountered, - or MATCH_YES if the specifier was correct and the binding label and - bind(c) fields were set correctly for the given symbol or the - current_ts. If allow_binding_name is false, no binding name may be - given. */ - -match -gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) -{ - char *binding_label = NULL; - gfc_expr *e = NULL; - - /* Initialize the flag that specifies whether we encountered a NAME= - specifier or not. */ - has_name_equals = 0; - - /* This much we have to be able to match, in this order, if - there is a bind(c) label. */ - if (gfc_match (" bind ( c ") != MATCH_YES) - return MATCH_NO; - - /* Now see if there is a binding label, or if we've reached the - end of the bind(c) attribute without one. */ - if (gfc_match_char (',') == MATCH_YES) - { - if (gfc_match (" name = ") != MATCH_YES) - { - gfc_error ("Syntax error in NAME= specifier for binding label " - "at %C"); - /* should give an error message here */ - return MATCH_ERROR; - } - - has_name_equals = 1; - - if (gfc_match_init_expr (&e) != MATCH_YES) - { - gfc_free_expr (e); - return MATCH_ERROR; - } - - if (!gfc_simplify_expr(e, 0)) - { - gfc_error ("NAME= specifier at %C should be a constant expression"); - gfc_free_expr (e); - return MATCH_ERROR; - } - - if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER - || e->ts.kind != gfc_default_character_kind || e->rank != 0) - { - gfc_error ("NAME= specifier at %C should be a scalar of " - "default character kind"); - gfc_free_expr(e); - return MATCH_ERROR; - } - - // Get a C string from the Fortran string constant - binding_label = gfc_widechar_to_char (e->value.character.string, - e->value.character.length); - gfc_free_expr(e); - - // Check that it is valid (old gfc_match_name_C) - if (check_bind_name_identifier (&binding_label) != MATCH_YES) - return MATCH_ERROR; - } - - /* Get the required right paren. */ - if (gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Missing closing paren for binding label at %C"); - return MATCH_ERROR; - } - - if (has_name_equals && !allow_binding_name) - { - gfc_error ("No binding name is allowed in BIND(C) at %C"); - return MATCH_ERROR; - } - - if (has_name_equals && sym != NULL && sym->attr.dummy) - { - gfc_error ("For dummy procedure %s, no binding name is " - "allowed in BIND(C) at %C", sym->name); - return MATCH_ERROR; - } - - - /* Save the binding label to the symbol. If sym is null, we're - probably matching the typespec attributes of a declaration and - haven't gotten the name yet, and therefore, no symbol yet. */ - if (binding_label) - { - if (sym != NULL) - sym->binding_label = binding_label; - else - curr_binding_label = binding_label; - } - else if (allow_binding_name) - { - /* No binding label, but if symbol isn't null, we - can set the label for it here. - If name="" or allow_binding_name is false, no C binding name is - created. */ - if (sym != NULL && sym->name != NULL && has_name_equals == 0) - sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name)); - } - - if (has_name_equals && gfc_current_state () == COMP_INTERFACE - && current_interface.type == INTERFACE_ABSTRACT) - { - gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C"); - return MATCH_ERROR; - } - - return MATCH_YES; -} - - -/* Return nonzero if we're currently compiling a contained procedure. */ - -static int -contained_procedure (void) -{ - gfc_state_data *s = gfc_state_stack; - - if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION) - && s->previous != NULL && s->previous->state == COMP_CONTAINS) - return 1; - - return 0; -} - -/* Set the kind of each enumerator. The kind is selected such that it is - interoperable with the corresponding C enumeration type, making - sure that -fshort-enums is honored. */ - -static void -set_enum_kind(void) -{ - enumerator_history *current_history = NULL; - int kind; - int i; - - if (max_enum == NULL || enum_history == NULL) - return; - - if (!flag_short_enums) - return; - - i = 0; - do - { - kind = gfc_integer_kinds[i++].kind; - } - while (kind < gfc_c_int_kind - && gfc_check_integer_range (max_enum->initializer->value.integer, - kind) != ARITH_OK); - - current_history = enum_history; - while (current_history != NULL) - { - current_history->sym->ts.kind = kind; - current_history = current_history->next; - } -} - - -/* Match any of the various end-block statements. Returns the type of - END to the caller. The END INTERFACE, END IF, END DO, END SELECT - and END BLOCK statements cannot be replaced by a single END statement. */ - -match -gfc_match_end (gfc_statement *st) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_compile_state state; - locus old_loc; - const char *block_name; - const char *target; - int eos_ok; - match m; - gfc_namespace *parent_ns, *ns, *prev_ns; - gfc_namespace **nsp; - bool abreviated_modproc_decl = false; - bool got_matching_end = false; - - old_loc = gfc_current_locus; - if (gfc_match ("end") != MATCH_YES) - return MATCH_NO; - - state = gfc_current_state (); - block_name = gfc_current_block () == NULL - ? NULL : gfc_current_block ()->name; - - switch (state) - { - case COMP_ASSOCIATE: - case COMP_BLOCK: - if (startswith (block_name, "block@")) - block_name = NULL; - break; - - case COMP_CONTAINS: - case COMP_DERIVED_CONTAINS: - state = gfc_state_stack->previous->state; - block_name = gfc_state_stack->previous->sym == NULL - ? NULL : gfc_state_stack->previous->sym->name; - abreviated_modproc_decl = gfc_state_stack->previous->sym - && gfc_state_stack->previous->sym->abr_modproc_decl; - break; - - default: - break; - } - - if (!abreviated_modproc_decl) - abreviated_modproc_decl = gfc_current_block () - && gfc_current_block ()->abr_modproc_decl; - - switch (state) - { - case COMP_NONE: - case COMP_PROGRAM: - *st = ST_END_PROGRAM; - target = " program"; - eos_ok = 1; - break; - - case COMP_SUBROUTINE: - *st = ST_END_SUBROUTINE; - if (!abreviated_modproc_decl) - target = " subroutine"; - else - target = " procedure"; - eos_ok = !contained_procedure (); - break; - - case COMP_FUNCTION: - *st = ST_END_FUNCTION; - if (!abreviated_modproc_decl) - target = " function"; - else - target = " procedure"; - eos_ok = !contained_procedure (); - break; - - case COMP_BLOCK_DATA: - *st = ST_END_BLOCK_DATA; - target = " block data"; - eos_ok = 1; - break; - - case COMP_MODULE: - *st = ST_END_MODULE; - target = " module"; - eos_ok = 1; - break; - - case COMP_SUBMODULE: - *st = ST_END_SUBMODULE; - target = " submodule"; - eos_ok = 1; - break; - - case COMP_INTERFACE: - *st = ST_END_INTERFACE; - target = " interface"; - eos_ok = 0; - break; - - case COMP_MAP: - *st = ST_END_MAP; - target = " map"; - eos_ok = 0; - break; - - case COMP_UNION: - *st = ST_END_UNION; - target = " union"; - eos_ok = 0; - break; - - case COMP_STRUCTURE: - *st = ST_END_STRUCTURE; - target = " structure"; - eos_ok = 0; - break; - - case COMP_DERIVED: - case COMP_DERIVED_CONTAINS: - *st = ST_END_TYPE; - target = " type"; - eos_ok = 0; - break; - - case COMP_ASSOCIATE: - *st = ST_END_ASSOCIATE; - target = " associate"; - eos_ok = 0; - break; - - case COMP_BLOCK: - case COMP_OMP_STRICTLY_STRUCTURED_BLOCK: - *st = ST_END_BLOCK; - target = " block"; - eos_ok = 0; - break; - - case COMP_IF: - *st = ST_ENDIF; - target = " if"; - eos_ok = 0; - break; - - case COMP_DO: - case COMP_DO_CONCURRENT: - *st = ST_ENDDO; - target = " do"; - eos_ok = 0; - break; - - case COMP_CRITICAL: - *st = ST_END_CRITICAL; - target = " critical"; - eos_ok = 0; - break; - - case COMP_SELECT: - case COMP_SELECT_TYPE: - case COMP_SELECT_RANK: - *st = ST_END_SELECT; - target = " select"; - eos_ok = 0; - break; - - case COMP_FORALL: - *st = ST_END_FORALL; - target = " forall"; - eos_ok = 0; - break; - - case COMP_WHERE: - *st = ST_END_WHERE; - target = " where"; - eos_ok = 0; - break; - - case COMP_ENUM: - *st = ST_END_ENUM; - target = " enum"; - eos_ok = 0; - last_initializer = NULL; - set_enum_kind (); - gfc_free_enum_history (); - break; - - default: - gfc_error ("Unexpected END statement at %C"); - goto cleanup; - } - - old_loc = gfc_current_locus; - if (gfc_match_eos () == MATCH_YES) - { - if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) - { - if (!gfc_notify_std (GFC_STD_F2008, "END statement " - "instead of %s statement at %L", - abreviated_modproc_decl ? "END PROCEDURE" - : gfc_ascii_statement(*st), &old_loc)) - goto cleanup; - } - else if (!eos_ok) - { - /* We would have required END [something]. */ - gfc_error ("%s statement expected at %L", - gfc_ascii_statement (*st), &old_loc); - goto cleanup; - } - - return MATCH_YES; - } - - /* Verify that we've got the sort of end-block that we're expecting. */ - if (gfc_match (target) != MATCH_YES) - { - gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl - ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc); - goto cleanup; - } - else - got_matching_end = true; - - old_loc = gfc_current_locus; - /* If we're at the end, make sure a block name wasn't required. */ - if (gfc_match_eos () == MATCH_YES) - { - - if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT - && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK - && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) - return MATCH_YES; - - if (!block_name) - return MATCH_YES; - - gfc_error ("Expected block name of %qs in %s statement at %L", - block_name, gfc_ascii_statement (*st), &old_loc); - - return MATCH_ERROR; - } - - /* END INTERFACE has a special handler for its several possible endings. */ - if (*st == ST_END_INTERFACE) - return gfc_match_end_interface (); - - /* We haven't hit the end of statement, so what is left must be an - end-name. */ - m = gfc_match_space (); - if (m == MATCH_YES) - m = gfc_match_name (name); - - if (m == MATCH_NO) - gfc_error ("Expected terminating name at %C"); - if (m != MATCH_YES) - goto cleanup; - - if (block_name == NULL) - goto syntax; - - /* We have to pick out the declared submodule name from the composite - required by F2008:11.2.3 para 2, which ends in the declared name. */ - if (state == COMP_SUBMODULE) - block_name = strchr (block_name, '.') + 1; - - if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) - { - gfc_error ("Expected label %qs for %s statement at %C", block_name, - gfc_ascii_statement (*st)); - goto cleanup; - } - /* Procedure pointer as function result. */ - else if (strcmp (block_name, "ppr@") == 0 - && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) - { - gfc_error ("Expected label %qs for %s statement at %C", - gfc_current_block ()->ns->proc_name->name, - gfc_ascii_statement (*st)); - goto cleanup; - } - - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - -syntax: - gfc_syntax_error (*st); - -cleanup: - gfc_current_locus = old_loc; - - /* If we are missing an END BLOCK, we created a half-ready namespace. - Remove it from the parent namespace's sibling list. */ - - while (state == COMP_BLOCK && !got_matching_end) - { - parent_ns = gfc_current_ns->parent; - - nsp = &(gfc_state_stack->previous->tail->ext.block.ns); - - prev_ns = NULL; - ns = *nsp; - while (ns) - { - if (ns == gfc_current_ns) - { - if (prev_ns == NULL) - *nsp = NULL; - else - prev_ns->sibling = ns->sibling; - } - prev_ns = ns; - ns = ns->sibling; - } - - gfc_free_namespace (gfc_current_ns); - gfc_current_ns = parent_ns; - gfc_state_stack = gfc_state_stack->previous; - state = gfc_current_state (); - } - - return MATCH_ERROR; -} - - - -/***************** Attribute declaration statements ****************/ - -/* Set the attribute of a single variable. */ - -static match -attr_decl1 (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_array_spec *as; - - /* Workaround -Wmaybe-uninitialized false positive during - profiledbootstrap by initializing them. */ - gfc_symbol *sym = NULL; - locus var_locus; - match m; - - as = NULL; - - m = gfc_match_name (name); - if (m != MATCH_YES) - goto cleanup; - - if (find_special (name, &sym, false)) - return MATCH_ERROR; - - if (!check_function_name (name)) - { - m = MATCH_ERROR; - goto cleanup; - } - - var_locus = gfc_current_locus; - - /* Deal with possible array specification for certain attributes. */ - if (current_attr.dimension - || current_attr.codimension - || current_attr.allocatable - || current_attr.pointer - || current_attr.target) - { - m = gfc_match_array_spec (&as, !current_attr.codimension, - !current_attr.dimension - && !current_attr.pointer - && !current_attr.target); - if (m == MATCH_ERROR) - goto cleanup; - - if (current_attr.dimension && m == MATCH_NO) - { - gfc_error ("Missing array specification at %L in DIMENSION " - "statement", &var_locus); - m = MATCH_ERROR; - goto cleanup; - } - - if (current_attr.dimension && sym->value) - { - gfc_error ("Dimensions specified for %s at %L after its " - "initialization", sym->name, &var_locus); - m = MATCH_ERROR; - goto cleanup; - } - - if (current_attr.codimension && m == MATCH_NO) - { - gfc_error ("Missing array specification at %L in CODIMENSION " - "statement", &var_locus); - m = MATCH_ERROR; - goto cleanup; - } - - if ((current_attr.allocatable || current_attr.pointer) - && (m == MATCH_YES) && (as->type != AS_DEFERRED)) - { - gfc_error ("Array specification must be deferred at %L", &var_locus); - m = MATCH_ERROR; - goto cleanup; - } - } - - /* Update symbol table. DIMENSION attribute is set in - gfc_set_array_spec(). For CLASS variables, this must be applied - to the first component, or '_data' field. */ - if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class) - { - /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check - for duplicate attribute here. */ - if (CLASS_DATA(sym)->attr.dimension == 1 && as) - { - gfc_error ("Duplicate DIMENSION attribute at %C"); - m = MATCH_ERROR; - goto cleanup; - } - - if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - } - else - { - if (current_attr.dimension == 0 && current_attr.codimension == 0 - && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - } - - if (sym->ts.type == BT_CLASS - && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (!gfc_set_array_spec (sym, as, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (sym->attr.cray_pointee && sym->as != NULL) - { - /* Fix the array spec. */ - m = gfc_mod_pointee_as (sym->as); - if (m == MATCH_ERROR) - goto cleanup; - } - - if (!gfc_add_attribute (&sym->attr, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - - if ((current_attr.external || current_attr.intrinsic) - && sym->attr.flavor != FL_PROCEDURE - && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL)) - { - m = MATCH_ERROR; - goto cleanup; - } - - add_hidden_procptr_result (sym); - - return MATCH_YES; - -cleanup: - gfc_free_array_spec (as); - return m; -} - - -/* Generic attribute declaration subroutine. Used for attributes that - just have a list of names. */ - -static match -attr_decl (void) -{ - match m; - - /* Gobble the optional double colon, by simply ignoring the result - of gfc_match(). */ - gfc_match (" ::"); - - for (;;) - { - m = attr_decl1 (); - if (m != MATCH_YES) - break; - - if (gfc_match_eos () == MATCH_YES) - { - m = MATCH_YES; - break; - } - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Unexpected character in variable list at %C"); - m = MATCH_ERROR; - break; - } - } - - return m; -} - - -/* This routine matches Cray Pointer declarations of the form: - pointer ( , ) - or - pointer ( , ), ( , ), ... - The pointer, if already declared, should be an integer. Otherwise, we - set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may - be either a scalar, or an array declaration. No space is allocated for - the pointee. For the statement - pointer (ipt, ar(10)) - any subsequent uses of ar will be translated (in C-notation) as - ar(i) => (( *) ipt)(i) - After gimplification, pointee variable will disappear in the code. */ - -static match -cray_pointer_decl (void) -{ - match m; - gfc_array_spec *as = NULL; - gfc_symbol *cptr; /* Pointer symbol. */ - gfc_symbol *cpte; /* Pointee symbol. */ - locus var_locus; - bool done = false; - - while (!done) - { - if (gfc_match_char ('(') != MATCH_YES) - { - gfc_error ("Expected %<(%> at %C"); - return MATCH_ERROR; - } - - /* Match pointer. */ - var_locus = gfc_current_locus; - gfc_clear_attr (¤t_attr); - gfc_add_cray_pointer (¤t_attr, &var_locus); - current_ts.type = BT_INTEGER; - current_ts.kind = gfc_index_integer_kind; - - m = gfc_match_symbol (&cptr, 0); - if (m != MATCH_YES) - { - gfc_error ("Expected variable name at %C"); - return m; - } - - if (!gfc_add_cray_pointer (&cptr->attr, &var_locus)) - return MATCH_ERROR; - - gfc_set_sym_referenced (cptr); - - if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */ - { - cptr->ts.type = BT_INTEGER; - cptr->ts.kind = gfc_index_integer_kind; - } - else if (cptr->ts.type != BT_INTEGER) - { - gfc_error ("Cray pointer at %C must be an integer"); - return MATCH_ERROR; - } - else if (cptr->ts.kind < gfc_index_integer_kind) - gfc_warning (0, "Cray pointer at %C has %d bytes of precision;" - " memory addresses require %d bytes", - cptr->ts.kind, gfc_index_integer_kind); - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expected \",\" at %C"); - return MATCH_ERROR; - } - - /* Match Pointee. */ - var_locus = gfc_current_locus; - gfc_clear_attr (¤t_attr); - gfc_add_cray_pointee (¤t_attr, &var_locus); - current_ts.type = BT_UNKNOWN; - current_ts.kind = 0; - - m = gfc_match_symbol (&cpte, 0); - if (m != MATCH_YES) - { - gfc_error ("Expected variable name at %C"); - return m; - } - - /* Check for an optional array spec. */ - m = gfc_match_array_spec (&as, true, false); - if (m == MATCH_ERROR) - { - gfc_free_array_spec (as); - return m; - } - else if (m == MATCH_NO) - { - gfc_free_array_spec (as); - as = NULL; - } - - if (!gfc_add_cray_pointee (&cpte->attr, &var_locus)) - return MATCH_ERROR; - - gfc_set_sym_referenced (cpte); - - if (cpte->as == NULL) - { - if (!gfc_set_array_spec (cpte, as, &var_locus)) - gfc_internal_error ("Cannot set Cray pointee array spec."); - } - else if (as != NULL) - { - gfc_error ("Duplicate array spec for Cray pointee at %C"); - gfc_free_array_spec (as); - return MATCH_ERROR; - } - - as = NULL; - - if (cpte->as != NULL) - { - /* Fix array spec. */ - m = gfc_mod_pointee_as (cpte->as); - if (m == MATCH_ERROR) - return m; - } - - /* Point the Pointee at the Pointer. */ - cpte->cp_pointer = cptr; - - if (gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Expected \")\" at %C"); - return MATCH_ERROR; - } - m = gfc_match_char (','); - if (m != MATCH_YES) - done = true; /* Stop searching for more declarations. */ - - } - - if (m == MATCH_ERROR /* Failed when trying to find ',' above. */ - || gfc_match_eos () != MATCH_YES) - { - gfc_error ("Expected %<,%> or end of statement at %C"); - return MATCH_ERROR; - } - return MATCH_YES; -} - - -match -gfc_match_external (void) -{ - - gfc_clear_attr (¤t_attr); - current_attr.external = 1; - - return attr_decl (); -} - - -match -gfc_match_intent (void) -{ - sym_intent intent; - - /* This is not allowed within a BLOCK construct! */ - if (gfc_current_state () == COMP_BLOCK) - { - gfc_error ("INTENT is not allowed inside of BLOCK at %C"); - return MATCH_ERROR; - } - - intent = match_intent_spec (); - if (intent == INTENT_UNKNOWN) - return MATCH_ERROR; - - gfc_clear_attr (¤t_attr); - current_attr.intent = intent; - - return attr_decl (); -} - - -match -gfc_match_intrinsic (void) -{ - - gfc_clear_attr (¤t_attr); - current_attr.intrinsic = 1; - - return attr_decl (); -} - - -match -gfc_match_optional (void) -{ - /* This is not allowed within a BLOCK construct! */ - if (gfc_current_state () == COMP_BLOCK) - { - gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C"); - return MATCH_ERROR; - } - - gfc_clear_attr (¤t_attr); - current_attr.optional = 1; - - return attr_decl (); -} - - -match -gfc_match_pointer (void) -{ - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () == '(') - { - if (!flag_cray_pointer) - { - gfc_error ("Cray pointer declaration at %C requires " - "%<-fcray-pointer%> flag"); - return MATCH_ERROR; - } - return cray_pointer_decl (); - } - else - { - gfc_clear_attr (¤t_attr); - current_attr.pointer = 1; - - return attr_decl (); - } -} - - -match -gfc_match_allocatable (void) -{ - gfc_clear_attr (¤t_attr); - current_attr.allocatable = 1; - - return attr_decl (); -} - - -match -gfc_match_codimension (void) -{ - gfc_clear_attr (¤t_attr); - current_attr.codimension = 1; - - return attr_decl (); -} - - -match -gfc_match_contiguous (void) -{ - if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C")) - return MATCH_ERROR; - - gfc_clear_attr (¤t_attr); - current_attr.contiguous = 1; - - return attr_decl (); -} - - -match -gfc_match_dimension (void) -{ - gfc_clear_attr (¤t_attr); - current_attr.dimension = 1; - - return attr_decl (); -} - - -match -gfc_match_target (void) -{ - gfc_clear_attr (¤t_attr); - current_attr.target = 1; - - return attr_decl (); -} - - -/* Match the list of entities being specified in a PUBLIC or PRIVATE - statement. */ - -static match -access_attr_decl (gfc_statement st) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - interface_type type; - gfc_user_op *uop; - gfc_symbol *sym, *dt_sym; - gfc_intrinsic_op op; - match m; - gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; - - if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) - goto done; - - for (;;) - { - m = gfc_match_generic_spec (&type, name, &op); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto done; - - switch (type) - { - case INTERFACE_NAMELESS: - case INTERFACE_ABSTRACT: - goto syntax; - - case INTERFACE_GENERIC: - case INTERFACE_DTIO: - - if (gfc_get_symbol (name, NULL, &sym)) - goto done; - - if (type == INTERFACE_DTIO - && gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.flavor == FL_MODULE - && sym->attr.flavor == FL_UNKNOWN) - sym->attr.flavor = FL_PROCEDURE; - - if (!gfc_add_access (&sym->attr, access, sym->name, NULL)) - goto done; - - if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym)) - && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL)) - goto done; - - break; - - case INTERFACE_INTRINSIC_OP: - if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN) - { - gfc_intrinsic_op other_op; - - gfc_current_ns->operator_access[op] = access; - - /* Handle the case if there is another op with the same - function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */ - other_op = gfc_equivalent_op (op); - - if (other_op != INTRINSIC_NONE) - gfc_current_ns->operator_access[other_op] = access; - } - else - { - gfc_error ("Access specification of the %s operator at %C has " - "already been specified", gfc_op2string (op)); - goto done; - } - - break; - - case INTERFACE_USER_OP: - uop = gfc_get_uop (name); - - if (uop->access == ACCESS_UNKNOWN) - { - uop->access = access; - } - else - { - gfc_error ("Access specification of the .%s. operator at %C " - "has already been specified", uop->name); - goto done; - } - - break; - } - - if (gfc_match_char (',') == MATCH_NO) - break; - } - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - return MATCH_YES; - -syntax: - gfc_syntax_error (st); - -done: - return MATCH_ERROR; -} - - -match -gfc_match_protected (void) -{ - gfc_symbol *sym; - match m; - char c; - - /* PROTECTED has already been seen, but must be followed by whitespace - or ::. */ - c = gfc_peek_ascii_char (); - if (!gfc_is_whitespace (c) && c != ':') - return MATCH_NO; - - if (!gfc_current_ns->proc_name - || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) - { - gfc_error ("PROTECTED at %C only allowed in specification " - "part of a module"); - return MATCH_ERROR; - - } - - gfc_match (" ::"); - - if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C")) - return MATCH_ERROR; - - /* PROTECTED has an entity-list. */ - if (gfc_match_eos () == MATCH_YES) - goto syntax; - - for(;;) - { - m = gfc_match_symbol (&sym, 0); - switch (m) - { - case MATCH_YES: - if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)) - return MATCH_ERROR; - goto next_item; - - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - } - - next_item: - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in PROTECTED statement at %C"); - return MATCH_ERROR; -} - - -/* The PRIVATE statement is a bit weird in that it can be an attribute - declaration, but also works as a standalone statement inside of a - type declaration or a module. */ - -match -gfc_match_private (gfc_statement *st) -{ - gfc_state_data *prev; - - if (gfc_match ("private") != MATCH_YES) - return MATCH_NO; - - /* Try matching PRIVATE without an access-list. */ - if (gfc_match_eos () == MATCH_YES) - { - prev = gfc_state_stack->previous; - if (gfc_current_state () != COMP_MODULE - && !(gfc_current_state () == COMP_DERIVED - && prev && prev->state == COMP_MODULE) - && !(gfc_current_state () == COMP_DERIVED_CONTAINS - && prev->previous && prev->previous->state == COMP_MODULE)) - { - gfc_error ("PRIVATE statement at %C is only allowed in the " - "specification part of a module"); - return MATCH_ERROR; - } - - *st = ST_PRIVATE; - return MATCH_YES; - } - - /* At this point in free-form source code, PRIVATE must be followed - by whitespace or ::. */ - if (gfc_current_form == FORM_FREE) - { - char c = gfc_peek_ascii_char (); - if (!gfc_is_whitespace (c) && c != ':') - return MATCH_NO; - } - - prev = gfc_state_stack->previous; - if (gfc_current_state () != COMP_MODULE - && !(gfc_current_state () == COMP_DERIVED - && prev && prev->state == COMP_MODULE) - && !(gfc_current_state () == COMP_DERIVED_CONTAINS - && prev->previous && prev->previous->state == COMP_MODULE)) - { - gfc_error ("PRIVATE statement at %C is only allowed in the " - "specification part of a module"); - return MATCH_ERROR; - } - - *st = ST_ATTR_DECL; - return access_attr_decl (ST_PRIVATE); -} - - -match -gfc_match_public (gfc_statement *st) -{ - if (gfc_match ("public") != MATCH_YES) - return MATCH_NO; - - /* Try matching PUBLIC without an access-list. */ - if (gfc_match_eos () == MATCH_YES) - { - if (gfc_current_state () != COMP_MODULE) - { - gfc_error ("PUBLIC statement at %C is only allowed in the " - "specification part of a module"); - return MATCH_ERROR; - } - - *st = ST_PUBLIC; - return MATCH_YES; - } - - /* At this point in free-form source code, PUBLIC must be followed - by whitespace or ::. */ - if (gfc_current_form == FORM_FREE) - { - char c = gfc_peek_ascii_char (); - if (!gfc_is_whitespace (c) && c != ':') - return MATCH_NO; - } - - if (gfc_current_state () != COMP_MODULE) - { - gfc_error ("PUBLIC statement at %C is only allowed in the " - "specification part of a module"); - return MATCH_ERROR; - } - - *st = ST_ATTR_DECL; - return access_attr_decl (ST_PUBLIC); -} - - -/* Workhorse for gfc_match_parameter. */ - -static match -do_parm (void) -{ - gfc_symbol *sym; - gfc_expr *init; - match m; - bool t; - - m = gfc_match_symbol (&sym, 0); - if (m == MATCH_NO) - gfc_error ("Expected variable name at %C in PARAMETER statement"); - - if (m != MATCH_YES) - return m; - - if (gfc_match_char ('=') == MATCH_NO) - { - gfc_error ("Expected = sign in PARAMETER statement at %C"); - return MATCH_ERROR; - } - - m = gfc_match_init_expr (&init); - if (m == MATCH_NO) - gfc_error ("Expected expression at %C in PARAMETER statement"); - if (m != MATCH_YES) - return m; - - if (sym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (sym, 1, NULL)) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (!gfc_check_assign_symbol (sym, NULL, init) - || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL)) - { - m = MATCH_ERROR; - goto cleanup; - } - - if (sym->value) - { - gfc_error ("Initializing already initialized variable at %C"); - m = MATCH_ERROR; - goto cleanup; - } - - t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus); - return (t) ? MATCH_YES : MATCH_ERROR; - -cleanup: - gfc_free_expr (init); - return m; -} - - -/* Match a parameter statement, with the weird syntax that these have. */ - -match -gfc_match_parameter (void) -{ - const char *term = " )%t"; - match m; - - if (gfc_match_char ('(') == MATCH_NO) - { - /* With legacy PARAMETER statements, don't expect a terminating ')'. */ - if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C")) - return MATCH_NO; - term = " %t"; - } - - for (;;) - { - m = do_parm (); - if (m != MATCH_YES) - break; - - if (gfc_match (term) == MATCH_YES) - break; - - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Unexpected characters in PARAMETER statement at %C"); - m = MATCH_ERROR; - break; - } - } - - return m; -} - - -match -gfc_match_automatic (void) -{ - gfc_symbol *sym; - match m; - bool seen_symbol = false; - - if (!flag_dec_static) - { - gfc_error ("%s at %C is a DEC extension, enable with " - "%<-fdec-static%>", - "AUTOMATIC" - ); - return MATCH_ERROR; - } - - gfc_match (" ::"); - - for (;;) - { - m = gfc_match_symbol (&sym, 0); - switch (m) - { - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - - case MATCH_YES: - if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus)) - return MATCH_ERROR; - seen_symbol = true; - break; - } - - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - if (!seen_symbol) - { - gfc_error ("Expected entity-list in AUTOMATIC statement at %C"); - return MATCH_ERROR; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in AUTOMATIC statement at %C"); - return MATCH_ERROR; -} - - -match -gfc_match_static (void) -{ - gfc_symbol *sym; - match m; - bool seen_symbol = false; - - if (!flag_dec_static) - { - gfc_error ("%s at %C is a DEC extension, enable with " - "%<-fdec-static%>", - "STATIC"); - return MATCH_ERROR; - } - - gfc_match (" ::"); - - for (;;) - { - m = gfc_match_symbol (&sym, 0); - switch (m) - { - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - - case MATCH_YES: - if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, - &gfc_current_locus)) - return MATCH_ERROR; - seen_symbol = true; - break; - } - - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - if (!seen_symbol) - { - gfc_error ("Expected entity-list in STATIC statement at %C"); - return MATCH_ERROR; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in STATIC statement at %C"); - return MATCH_ERROR; -} - - -/* Save statements have a special syntax. */ - -match -gfc_match_save (void) -{ - char n[GFC_MAX_SYMBOL_LEN+1]; - gfc_common_head *c; - gfc_symbol *sym; - match m; - - if (gfc_match_eos () == MATCH_YES) - { - if (gfc_current_ns->seen_save) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C " - "follows previous SAVE statement")) - return MATCH_ERROR; - } - - gfc_current_ns->save_all = gfc_current_ns->seen_save = 1; - return MATCH_YES; - } - - if (gfc_current_ns->save_all) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows " - "blanket SAVE statement")) - return MATCH_ERROR; - } - - gfc_match (" ::"); - - for (;;) - { - m = gfc_match_symbol (&sym, 0); - switch (m) - { - case MATCH_YES: - if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, - &gfc_current_locus)) - return MATCH_ERROR; - goto next_item; - - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - } - - m = gfc_match (" / %n /", &n); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - goto syntax; - - c = gfc_get_common (n, 0); - c->saved = 1; - - gfc_current_ns->seen_save = 1; - - next_item: - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - if (gfc_current_ns->seen_save) - { - gfc_error ("Syntax error in SAVE statement at %C"); - return MATCH_ERROR; - } - else - return MATCH_NO; -} - - -match -gfc_match_value (void) -{ - gfc_symbol *sym; - match m; - - /* This is not allowed within a BLOCK construct! */ - if (gfc_current_state () == COMP_BLOCK) - { - gfc_error ("VALUE is not allowed inside of BLOCK at %C"); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C")) - return MATCH_ERROR; - - if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) - { - return MATCH_ERROR; - } - - if (gfc_match_eos () == MATCH_YES) - goto syntax; - - for(;;) - { - m = gfc_match_symbol (&sym, 0); - switch (m) - { - case MATCH_YES: - if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)) - return MATCH_ERROR; - goto next_item; - - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - } - - next_item: - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in VALUE statement at %C"); - return MATCH_ERROR; -} - - -match -gfc_match_volatile (void) -{ - gfc_symbol *sym; - char *name; - match m; - - if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C")) - return MATCH_ERROR; - - if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) - { - return MATCH_ERROR; - } - - if (gfc_match_eos () == MATCH_YES) - goto syntax; - - for(;;) - { - /* VOLATILE is special because it can be added to host-associated - symbols locally. Except for coarrays. */ - m = gfc_match_symbol (&sym, 1); - switch (m) - { - case MATCH_YES: - name = XCNEWVAR (char, strlen (sym->name) + 1); - strcpy (name, sym->name); - if (!check_function_name (name)) - return MATCH_ERROR; - /* F2008, C560+C561. VOLATILE for host-/use-associated variable or - for variable in a BLOCK which is defined outside of the BLOCK. */ - if (sym->ns != gfc_current_ns && sym->attr.codimension) - { - gfc_error ("Specifying VOLATILE for coarray variable %qs at " - "%C, which is use-/host-associated", sym->name); - return MATCH_ERROR; - } - if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)) - return MATCH_ERROR; - goto next_item; - - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - } - - next_item: - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in VOLATILE statement at %C"); - return MATCH_ERROR; -} - - -match -gfc_match_asynchronous (void) -{ - gfc_symbol *sym; - char *name; - match m; - - if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C")) - return MATCH_ERROR; - - if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) - { - return MATCH_ERROR; - } - - if (gfc_match_eos () == MATCH_YES) - goto syntax; - - for(;;) - { - /* ASYNCHRONOUS is special because it can be added to host-associated - symbols locally. */ - m = gfc_match_symbol (&sym, 1); - switch (m) - { - case MATCH_YES: - name = XCNEWVAR (char, strlen (sym->name) + 1); - strcpy (name, sym->name); - if (!check_function_name (name)) - return MATCH_ERROR; - if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus)) - return MATCH_ERROR; - goto next_item; - - case MATCH_NO: - break; - - case MATCH_ERROR: - return MATCH_ERROR; - } - - next_item: - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in ASYNCHRONOUS statement at %C"); - return MATCH_ERROR; -} - - -/* Match a module procedure statement in a submodule. */ - -match -gfc_match_submod_proc (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym, *fsym; - match m; - gfc_formal_arglist *formal, *head, *tail; - - if (gfc_current_state () != COMP_CONTAINS - || !(gfc_state_stack->previous - && (gfc_state_stack->previous->state == COMP_SUBMODULE - || gfc_state_stack->previous->state == COMP_MODULE))) - return MATCH_NO; - - m = gfc_match (" module% procedure% %n", name); - if (m != MATCH_YES) - return m; - - if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration " - "at %C")) - return MATCH_ERROR; - - if (get_proc_name (name, &sym, false)) - return MATCH_ERROR; - - /* Make sure that the result field is appropriately filled. */ - if (sym->tlink && sym->tlink->attr.function) - { - if (sym->tlink->result && sym->tlink->result != sym->tlink) - { - sym->result = sym->tlink->result; - if (!sym->result->attr.use_assoc) - { - gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root, - sym->result->name); - st->n.sym = sym->result; - sym->result->refs++; - } - } - else - sym->result = sym; - } - - /* Set declared_at as it might point to, e.g., a PUBLIC statement, if - the symbol existed before. */ - sym->declared_at = gfc_current_locus; - - if (!sym->attr.module_procedure) - return MATCH_ERROR; - - /* Signal match_end to expect "end procedure". */ - sym->abr_modproc_decl = 1; - - /* Change from IFSRC_IFBODY coming from the interface declaration. */ - sym->attr.if_source = IFSRC_DECL; - - gfc_new_block = sym; - - /* Make a new formal arglist with the symbols in the procedure - namespace. */ - head = tail = NULL; - for (formal = sym->formal; formal && formal->sym; formal = formal->next) - { - if (formal == sym->formal) - head = tail = gfc_get_formal_arglist (); - else - { - tail->next = gfc_get_formal_arglist (); - tail = tail->next; - } - - if (gfc_copy_dummy_sym (&fsym, formal->sym, 0)) - goto cleanup; - - tail->sym = fsym; - gfc_set_sym_referenced (fsym); - } - - /* The dummy symbols get cleaned up, when the formal_namespace of the - interface declaration is cleared. This allows us to add the - explicit interface as is done for other type of procedure. */ - if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head, - &gfc_current_locus)) - return MATCH_ERROR; - - if (gfc_match_eos () != MATCH_YES) - { - /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are - undone, such that the st->n.sym->formal points to the original symbol; - if now this namespace is finalized, the formal namespace is freed, - but it might be still needed in the parent namespace. */ - gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name); - st->n.sym = NULL; - gfc_free_symbol (sym->tlink); - sym->tlink = NULL; - sym->refs--; - gfc_syntax_error (ST_MODULE_PROC); - return MATCH_ERROR; - } - - return MATCH_YES; - -cleanup: - gfc_free_formal_arglist (head); - return MATCH_ERROR; -} - - -/* Match a module procedure statement. Note that we have to modify - symbols in the parent's namespace because the current one was there - to receive symbols that are in an interface's formal argument list. */ - -match -gfc_match_modproc (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - locus old_locus; - gfc_namespace *module_ns; - gfc_interface *old_interface_head, *interface; - - if ((gfc_state_stack->state != COMP_INTERFACE - && gfc_state_stack->state != COMP_CONTAINS) - || gfc_state_stack->previous == NULL - || current_interface.type == INTERFACE_NAMELESS - || current_interface.type == INTERFACE_ABSTRACT) - { - gfc_error ("MODULE PROCEDURE at %C must be in a generic module " - "interface"); - return MATCH_ERROR; - } - - module_ns = gfc_current_ns->parent; - for (; module_ns; module_ns = module_ns->parent) - if (module_ns->proc_name->attr.flavor == FL_MODULE - || module_ns->proc_name->attr.flavor == FL_PROGRAM - || (module_ns->proc_name->attr.flavor == FL_PROCEDURE - && !module_ns->proc_name->attr.contained)) - break; - - if (module_ns == NULL) - return MATCH_ERROR; - - /* Store the current state of the interface. We will need it if we - end up with a syntax error and need to recover. */ - old_interface_head = gfc_current_interface_head (); - - /* Check if the F2008 optional double colon appears. */ - gfc_gobble_whitespace (); - old_locus = gfc_current_locus; - if (gfc_match ("::") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2008, "double colon in " - "MODULE PROCEDURE statement at %L", &old_locus)) - return MATCH_ERROR; - } - else - gfc_current_locus = old_locus; - - for (;;) - { - bool last = false; - old_locus = gfc_current_locus; - - m = gfc_match_name (name); - if (m == MATCH_NO) - goto syntax; - if (m != MATCH_YES) - return MATCH_ERROR; - - /* Check for syntax error before starting to add symbols to the - current namespace. */ - if (gfc_match_eos () == MATCH_YES) - last = true; - - if (!last && gfc_match_char (',') != MATCH_YES) - goto syntax; - - /* Now we're sure the syntax is valid, we process this item - further. */ - if (gfc_get_symbol (name, module_ns, &sym)) - return MATCH_ERROR; - - if (sym->attr.intrinsic) - { - gfc_error ("Intrinsic procedure at %L cannot be a MODULE " - "PROCEDURE", &old_locus); - return MATCH_ERROR; - } - - if (sym->attr.proc != PROC_MODULE - && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) - return MATCH_ERROR; - - if (!gfc_add_interface (sym)) - return MATCH_ERROR; - - sym->attr.mod_proc = 1; - sym->declared_at = old_locus; - - if (last) - break; - } - - return MATCH_YES; - -syntax: - /* Restore the previous state of the interface. */ - interface = gfc_current_interface_head (); - gfc_set_current_interface_head (old_interface_head); - - /* Free the new interfaces. */ - while (interface != old_interface_head) - { - gfc_interface *i = interface->next; - free (interface); - interface = i; - } - - /* And issue a syntax error. */ - gfc_syntax_error (ST_MODULE_PROC); - return MATCH_ERROR; -} - - -/* Check a derived type that is being extended. */ - -static gfc_symbol* -check_extended_derived_type (char *name) -{ - gfc_symbol *extended; - - if (gfc_find_symbol (name, gfc_current_ns, 1, &extended)) - { - gfc_error ("Ambiguous symbol in TYPE definition at %C"); - return NULL; - } - - extended = gfc_find_dt_in_generic (extended); - - /* F08:C428. */ - if (!extended) - { - gfc_error ("Symbol %qs at %C has not been previously defined", name); - return NULL; - } - - if (extended->attr.flavor != FL_DERIVED) - { - gfc_error ("%qs in EXTENDS expression at %C is not a " - "derived type", name); - return NULL; - } - - if (extended->attr.is_bind_c) - { - gfc_error ("%qs cannot be extended at %C because it " - "is BIND(C)", extended->name); - return NULL; - } - - if (extended->attr.sequence) - { - gfc_error ("%qs cannot be extended at %C because it " - "is a SEQUENCE type", extended->name); - return NULL; - } - - return extended; -} - - -/* Match the optional attribute specifiers for a type declaration. - Return MATCH_ERROR if an error is encountered in one of the handled - attributes (public, private, bind(c)), MATCH_NO if what's found is - not a handled attribute, and MATCH_YES otherwise. TODO: More error - checking on attribute conflicts needs to be done. */ - -static match -gfc_get_type_attr_spec (symbol_attribute *attr, char *name) -{ - /* See if the derived type is marked as private. */ - if (gfc_match (" , private") == MATCH_YES) - { - if (gfc_current_state () != COMP_MODULE) - { - gfc_error ("Derived type at %C can only be PRIVATE in the " - "specification part of a module"); - return MATCH_ERROR; - } - - if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL)) - return MATCH_ERROR; - } - else if (gfc_match (" , public") == MATCH_YES) - { - if (gfc_current_state () != COMP_MODULE) - { - gfc_error ("Derived type at %C can only be PUBLIC in the " - "specification part of a module"); - return MATCH_ERROR; - } - - if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL)) - return MATCH_ERROR; - } - else if (gfc_match (" , bind ( c )") == MATCH_YES) - { - /* If the type is defined to be bind(c) it then needs to make - sure that all fields are interoperable. This will - need to be a semantic check on the finished derived type. - See 15.2.3 (lines 9-12) of F2003 draft. */ - if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0)) - return MATCH_ERROR; - - /* TODO: attr conflicts need to be checked, probably in symbol.c. */ - } - else if (gfc_match (" , abstract") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C")) - return MATCH_ERROR; - - if (!gfc_add_abstract (attr, &gfc_current_locus)) - return MATCH_ERROR; - } - else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES) - { - if (!gfc_add_extension (attr, &gfc_current_locus)) - return MATCH_ERROR; - } - else - return MATCH_NO; - - /* If we get here, something matched. */ - return MATCH_YES; -} - - -/* Common function for type declaration blocks similar to derived types, such - as STRUCTURES and MAPs. Unlike derived types, a structure type - does NOT have a generic symbol matching the name given by the user. - STRUCTUREs can share names with variables and PARAMETERs so we must allow - for the creation of an independent symbol. - Other parameters are a message to prefix errors with, the name of the new - type to be created, and the flavor to add to the resulting symbol. */ - -static bool -get_struct_decl (const char *name, sym_flavor fl, locus *decl, - gfc_symbol **result) -{ - gfc_symbol *sym; - locus where; - - gcc_assert (name[0] == (char) TOUPPER (name[0])); - - if (decl) - where = *decl; - else - where = gfc_current_locus; - - if (gfc_get_symbol (name, NULL, &sym)) - return false; - - if (!sym) - { - gfc_internal_error ("Failed to create structure type '%s' at %C", name); - return false; - } - - if (sym->components != NULL || sym->attr.zero_comp) - { - gfc_error ("Type definition of %qs at %C was already defined at %L", - sym->name, &sym->declared_at); - return false; - } - - sym->declared_at = where; - - if (sym->attr.flavor != fl - && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL)) - return false; - - if (!sym->hash_value) - /* Set the hash for the compound name for this type. */ - sym->hash_value = gfc_hash_value (sym); - - /* Normally the type is expected to have been completely parsed by the time - a field declaration with this type is seen. For unions, maps, and nested - structure declarations, we need to indicate that it is okay that we - haven't seen any components yet. This will be updated after the structure - is fully parsed. */ - sym->attr.zero_comp = 0; - - /* Structures always act like derived-types with the SEQUENCE attribute */ - gfc_add_sequence (&sym->attr, sym->name, NULL); - - if (result) *result = sym; - - return true; -} - - -/* Match the opening of a MAP block. Like a struct within a union in C; - behaves identical to STRUCTURE blocks. */ - -match -gfc_match_map (void) -{ - /* Counter used to give unique internal names to map structures. */ - static unsigned int gfc_map_id = 0; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - locus old_loc; - - old_loc = gfc_current_locus; - - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after MAP statement at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } - - /* Map blocks are anonymous so we make up unique names for the symbol table - which are invalid Fortran identifiers. */ - snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++); - - if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym)) - return MATCH_ERROR; - - gfc_new_block = sym; - - return MATCH_YES; -} - - -/* Match the opening of a UNION block. */ - -match -gfc_match_union (void) -{ - /* Counter used to give unique internal names to union types. */ - static unsigned int gfc_union_id = 0; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - locus old_loc; - - old_loc = gfc_current_locus; - - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after UNION statement at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } - - /* Unions are anonymous so we make up unique names for the symbol table - which are invalid Fortran identifiers. */ - snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++); - - if (!get_struct_decl (name, FL_UNION, &old_loc, &sym)) - return MATCH_ERROR; - - gfc_new_block = sym; - - return MATCH_YES; -} - - -/* Match the beginning of a STRUCTURE declaration. This is similar to - matching the beginning of a derived type declaration with a few - twists. The resulting type symbol has no access control or other - interesting attributes. */ - -match -gfc_match_structure_decl (void) -{ - /* Counter used to give unique internal names to anonymous structures. */ - static unsigned int gfc_structure_id = 0; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - locus where; - - if (!flag_dec_structure) - { - gfc_error ("%s at %C is a DEC extension, enable with " - "%<-fdec-structure%>", - "STRUCTURE"); - return MATCH_ERROR; - } - - name[0] = '\0'; - - m = gfc_match (" /%n/", name); - if (m != MATCH_YES) - { - /* Non-nested structure declarations require a structure name. */ - if (!gfc_comp_struct (gfc_current_state ())) - { - gfc_error ("Structure name expected in non-nested structure " - "declaration at %C"); - return MATCH_ERROR; - } - /* This is an anonymous structure; make up a unique name for it - (upper-case letters never make it to symbol names from the source). - The important thing is initializing the type variable - and setting gfc_new_symbol, which is immediately used by - parse_structure () and variable_decl () to add components of - this type. */ - snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++); - } - - where = gfc_current_locus; - /* No field list allowed after non-nested structure declaration. */ - if (!gfc_comp_struct (gfc_current_state ()) - && gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after non-nested STRUCTURE statement at %C"); - return MATCH_ERROR; - } - - /* Make sure the name is not the name of an intrinsic type. */ - if (gfc_is_intrinsic_typename (name)) - { - gfc_error ("Structure name %qs at %C cannot be the same as an" - " intrinsic type", name); - return MATCH_ERROR; - } - - /* Store the actual type symbol for the structure with an upper-case first - letter (an invalid Fortran identifier). */ - - if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym)) - return MATCH_ERROR; - - gfc_new_block = sym; - return MATCH_YES; -} - - -/* This function does some work to determine which matcher should be used to - * match a statement beginning with "TYPE". This is used to disambiguate TYPE - * as an alias for PRINT from derived type declarations, TYPE IS statements, - * and [parameterized] derived type declarations. */ - -match -gfc_match_type (gfc_statement *st) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - match m; - locus old_loc; - - /* Requires -fdec. */ - if (!flag_dec) - return MATCH_NO; - - m = gfc_match ("type"); - if (m != MATCH_YES) - return m; - /* If we already have an error in the buffer, it is probably from failing to - * match a derived type data declaration. Let it happen. */ - else if (gfc_error_flag_test ()) - return MATCH_NO; - - old_loc = gfc_current_locus; - *st = ST_NONE; - - /* If we see an attribute list before anything else it's definitely a derived - * type declaration. */ - if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES) - goto derived; - - /* By now "TYPE" has already been matched. If we do not see a name, this may - * be something like "TYPE *" or "TYPE ". */ - m = gfc_match_name (name); - if (m != MATCH_YES) - { - /* Let print match if it can, otherwise throw an error from - * gfc_match_derived_decl. */ - gfc_current_locus = old_loc; - if (gfc_match_print () == MATCH_YES) - { - *st = ST_WRITE; - return MATCH_YES; - } - goto derived; - } - - /* Check for EOS. */ - if (gfc_match_eos () == MATCH_YES) - { - /* By now we have "TYPE ". Check first if the name is an - * intrinsic typename - if so let gfc_match_derived_decl dump an error. - * Otherwise if gfc_match_derived_decl fails it's probably an existing - * symbol which can be printed. */ - gfc_current_locus = old_loc; - m = gfc_match_derived_decl (); - if (gfc_is_intrinsic_typename (name) || m == MATCH_YES) - { - *st = ST_DERIVED_DECL; - return m; - } - } - else - { - /* Here we have "TYPE ". Check for or a PDT declaration - like . */ - gfc_gobble_whitespace (); - bool paren = gfc_peek_ascii_char () == '('; - if (paren) - { - if (strcmp ("is", name) == 0) - goto typeis; - else - goto derived; - } - } - - /* Treat TYPE... like PRINT... */ - gfc_current_locus = old_loc; - *st = ST_WRITE; - return gfc_match_print (); - -derived: - gfc_current_locus = old_loc; - *st = ST_DERIVED_DECL; - return gfc_match_derived_decl (); - -typeis: - gfc_current_locus = old_loc; - *st = ST_TYPE_IS; - return gfc_match_type_is (); -} - - -/* Match the beginning of a derived type declaration. If a type name - was the result of a function, then it is possible to have a symbol - already to be known as a derived type yet have no components. */ - -match -gfc_match_derived_decl (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - char parent[GFC_MAX_SYMBOL_LEN + 1]; - symbol_attribute attr; - gfc_symbol *sym, *gensym; - gfc_symbol *extended; - match m; - match is_type_attr_spec = MATCH_NO; - bool seen_attr = false; - gfc_interface *intr = NULL, *head; - bool parameterized_type = false; - bool seen_colons = false; - - if (gfc_comp_struct (gfc_current_state ())) - return MATCH_NO; - - name[0] = '\0'; - parent[0] = '\0'; - gfc_clear_attr (&attr); - extended = NULL; - - do - { - is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent); - if (is_type_attr_spec == MATCH_ERROR) - return MATCH_ERROR; - if (is_type_attr_spec == MATCH_YES) - seen_attr = true; - } while (is_type_attr_spec == MATCH_YES); - - /* Deal with derived type extensions. The extension attribute has - been added to 'attr' but now the parent type must be found and - checked. */ - if (parent[0]) - extended = check_extended_derived_type (parent); - - if (parent[0] && !extended) - return MATCH_ERROR; - - m = gfc_match (" ::"); - if (m == MATCH_YES) - { - seen_colons = true; - } - else if (seen_attr) - { - gfc_error ("Expected :: in TYPE definition at %C"); - return MATCH_ERROR; - } - - /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX. - But, we need to simply return for TYPE(. */ - if (m == MATCH_NO && gfc_current_form == FORM_FREE) - { - char c = gfc_peek_ascii_char (); - if (c == '(') - return m; - if (!gfc_is_whitespace (c)) - { - gfc_error ("Mangled derived type definition at %C"); - return MATCH_NO; - } - } - - m = gfc_match (" %n ", name); - if (m != MATCH_YES) - return m; - - /* Make sure that we don't identify TYPE IS (...) as a parameterized - derived type named 'is'. - TODO Expand the check, when 'name' = "is" by matching " (tname) " - and checking if this is a(n intrinsic) typename. This picks up - misplaced TYPE IS statements such as in select_type_1.f03. */ - if (gfc_peek_ascii_char () == '(') - { - if (gfc_current_state () == COMP_SELECT_TYPE - || (!seen_colons && !strcmp (name, "is"))) - return MATCH_NO; - parameterized_type = true; - } - - m = gfc_match_eos (); - if (m != MATCH_YES && !parameterized_type) - return m; - - /* Make sure the name is not the name of an intrinsic type. */ - if (gfc_is_intrinsic_typename (name)) - { - gfc_error ("Type name %qs at %C cannot be the same as an intrinsic " - "type", name); - return MATCH_ERROR; - } - - if (gfc_get_symbol (name, NULL, &gensym)) - return MATCH_ERROR; - - if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) - { - if (gensym->ts.u.derived) - gfc_error ("Derived type name %qs at %C already has a basic type " - "of %s", gensym->name, gfc_typename (&gensym->ts)); - else - gfc_error ("Derived type name %qs at %C already has a basic type", - gensym->name); - return MATCH_ERROR; - } - - if (!gensym->attr.generic - && !gfc_add_generic (&gensym->attr, gensym->name, NULL)) - return MATCH_ERROR; - - if (!gensym->attr.function - && !gfc_add_function (&gensym->attr, gensym->name, NULL)) - return MATCH_ERROR; - - if (gensym->attr.dummy) - { - gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C", - name, &gensym->declared_at); - return MATCH_ERROR; - } - - sym = gfc_find_dt_in_generic (gensym); - - if (sym && (sym->components != NULL || sym->attr.zero_comp)) - { - gfc_error ("Derived type definition of %qs at %C has already been " - "defined", sym->name); - return MATCH_ERROR; - } - - if (!sym) - { - /* Use upper case to save the actual derived-type symbol. */ - gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym); - sym->name = gfc_get_string ("%s", gensym->name); - head = gensym->generic; - intr = gfc_get_interface (); - intr->sym = sym; - intr->where = gfc_current_locus; - intr->sym->declared_at = gfc_current_locus; - intr->next = head; - gensym->generic = intr; - gensym->attr.if_source = IFSRC_DECL; - } - - /* The symbol may already have the derived attribute without the - components. The ways this can happen is via a function - definition, an INTRINSIC statement or a subtype in another - derived type that is a pointer. The first part of the AND clause - is true if the symbol is not the return value of a function. */ - if (sym->attr.flavor != FL_DERIVED - && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL)) - return MATCH_ERROR; - - if (attr.access != ACCESS_UNKNOWN - && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL)) - return MATCH_ERROR; - else if (sym->attr.access == ACCESS_UNKNOWN - && gensym->attr.access != ACCESS_UNKNOWN - && !gfc_add_access (&sym->attr, gensym->attr.access, - sym->name, NULL)) - return MATCH_ERROR; - - if (sym->attr.access != ACCESS_UNKNOWN - && gensym->attr.access == ACCESS_UNKNOWN) - gensym->attr.access = sym->attr.access; - - /* See if the derived type was labeled as bind(c). */ - if (attr.is_bind_c != 0) - sym->attr.is_bind_c = attr.is_bind_c; - - /* Construct the f2k_derived namespace if it is not yet there. */ - if (!sym->f2k_derived) - sym->f2k_derived = gfc_get_namespace (NULL, 0); - - if (parameterized_type) - { - /* Ignore error or mismatches by going to the end of the statement - in order to avoid the component declarations causing problems. */ - m = gfc_match_formal_arglist (sym, 0, 0, true); - if (m != MATCH_YES) - gfc_error_recovery (); - else - sym->attr.pdt_template = 1; - m = gfc_match_eos (); - if (m != MATCH_YES) - { - gfc_error_recovery (); - gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C"); - } - } - - if (extended && !sym->components) - { - gfc_component *p; - gfc_formal_arglist *f, *g, *h; - - /* Add the extended derived type as the first component. */ - gfc_add_component (sym, parent, &p); - extended->refs++; - gfc_set_sym_referenced (extended); - - p->ts.type = BT_DERIVED; - p->ts.u.derived = extended; - p->initializer = gfc_default_initializer (&p->ts); - - /* Set extension level. */ - if (extended->attr.extension == 255) - { - /* Since the extension field is 8 bit wide, we can only have - up to 255 extension levels. */ - gfc_error ("Maximum extension level reached with type %qs at %L", - extended->name, &extended->declared_at); - return MATCH_ERROR; - } - sym->attr.extension = extended->attr.extension + 1; - - /* Provide the links between the extended type and its extension. */ - if (!extended->f2k_derived) - extended->f2k_derived = gfc_get_namespace (NULL, 0); - - /* Copy the extended type-param-name-list from the extended type, - append those of the extension and add the whole lot to the - extension. */ - if (extended->attr.pdt_template) - { - g = h = NULL; - sym->attr.pdt_template = 1; - for (f = extended->formal; f; f = f->next) - { - if (f == extended->formal) - { - g = gfc_get_formal_arglist (); - h = g; - } - else - { - g->next = gfc_get_formal_arglist (); - g = g->next; - } - g->sym = f->sym; - } - g->next = sym->formal; - sym->formal = h; - } - } - - if (!sym->hash_value) - /* Set the hash for the compound name for this type. */ - sym->hash_value = gfc_hash_value (sym); - - /* Take over the ABSTRACT attribute. */ - sym->attr.abstract = attr.abstract; - - gfc_new_block = sym; - - return MATCH_YES; -} - - -/* Cray Pointees can be declared as: - pointer (ipt, a (n,m,...,*)) */ - -match -gfc_mod_pointee_as (gfc_array_spec *as) -{ - as->cray_pointee = true; /* This will be useful to know later. */ - if (as->type == AS_ASSUMED_SIZE) - as->cp_was_assumed = true; - else if (as->type == AS_ASSUMED_SHAPE) - { - gfc_error ("Cray Pointee at %C cannot be assumed shape array"); - return MATCH_ERROR; - } - return MATCH_YES; -} - - -/* Match the enum definition statement, here we are trying to match - the first line of enum definition statement. - Returns MATCH_YES if match is found. */ - -match -gfc_match_enum (void) -{ - match m; - - m = gfc_match_eos (); - if (m != MATCH_YES) - return m; - - if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C")) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* Returns an initializer whose value is one higher than the value of the - LAST_INITIALIZER argument. If the argument is NULL, the - initializers value will be set to zero. The initializer's kind - will be set to gfc_c_int_kind. - - If -fshort-enums is given, the appropriate kind will be selected - later after all enumerators have been parsed. A warning is issued - here if an initializer exceeds gfc_c_int_kind. */ - -static gfc_expr * -enum_initializer (gfc_expr *last_initializer, locus where) -{ - gfc_expr *result; - result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where); - - mpz_init (result->value.integer); - - if (last_initializer != NULL) - { - mpz_add_ui (result->value.integer, last_initializer->value.integer, 1); - result->where = last_initializer->where; - - if (gfc_check_integer_range (result->value.integer, - gfc_c_int_kind) != ARITH_OK) - { - gfc_error ("Enumerator exceeds the C integer type at %C"); - return NULL; - } - } - else - { - /* Control comes here, if it's the very first enumerator and no - initializer has been given. It will be initialized to zero. */ - mpz_set_si (result->value.integer, 0); - } - - return result; -} - - -/* Match a variable name with an optional initializer. When this - subroutine is called, a variable is expected to be parsed next. - Depending on what is happening at the moment, updates either the - symbol table or the current interface. */ - -static match -enumerator_decl (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_expr *initializer; - gfc_array_spec *as = NULL; - gfc_symbol *sym; - locus var_locus; - match m; - bool t; - locus old_locus; - - initializer = NULL; - old_locus = gfc_current_locus; - - /* When we get here, we've just matched a list of attributes and - maybe a type and a double colon. The next thing we expect to see - is the name of the symbol. */ - m = gfc_match_name (name); - if (m != MATCH_YES) - goto cleanup; - - var_locus = gfc_current_locus; - - /* OK, we've successfully matched the declaration. Now put the - symbol in the current namespace. If we fail to create the symbol, - bail out. */ - if (!build_sym (name, NULL, false, &as, &var_locus)) - { - m = MATCH_ERROR; - goto cleanup; - } - - /* The double colon must be present in order to have initializers. - Otherwise the statement is ambiguous with an assignment statement. */ - if (colon_seen) - { - if (gfc_match_char ('=') == MATCH_YES) - { - m = gfc_match_init_expr (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Expected an initialization expression at %C"); - m = MATCH_ERROR; - } - - if (m != MATCH_YES) - goto cleanup; - } - } - - /* If we do not have an initializer, the initialization value of the - previous enumerator (stored in last_initializer) is incremented - by 1 and is used to initialize the current enumerator. */ - if (initializer == NULL) - initializer = enum_initializer (last_initializer, old_locus); - - if (initializer == NULL || initializer->ts.type != BT_INTEGER) - { - gfc_error ("ENUMERATOR %L not initialized with integer expression", - &var_locus); - m = MATCH_ERROR; - goto cleanup; - } - - /* Store this current initializer, for the next enumerator variable - to be parsed. add_init_expr_to_sym() zeros initializer, so we - use last_initializer below. */ - last_initializer = initializer; - t = add_init_expr_to_sym (name, &initializer, &var_locus); - - /* Maintain enumerator history. */ - gfc_find_symbol (name, NULL, 0, &sym); - create_enum_history (sym, last_initializer); - - return (t) ? MATCH_YES : MATCH_ERROR; - -cleanup: - /* Free stuff up and return. */ - gfc_free_expr (initializer); - - return m; -} - - -/* Match the enumerator definition statement. */ - -match -gfc_match_enumerator_def (void) -{ - match m; - bool t; - - gfc_clear_ts (¤t_ts); - - m = gfc_match (" enumerator"); - if (m != MATCH_YES) - return m; - - m = gfc_match (" :: "); - if (m == MATCH_ERROR) - return m; - - colon_seen = (m == MATCH_YES); - - if (gfc_current_state () != COMP_ENUM) - { - gfc_error ("ENUM definition statement expected before %C"); - gfc_free_enum_history (); - return MATCH_ERROR; - } - - (¤t_ts)->type = BT_INTEGER; - (¤t_ts)->kind = gfc_c_int_kind; - - gfc_clear_attr (¤t_attr); - t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL); - if (!t) - { - m = MATCH_ERROR; - goto cleanup; - } - - for (;;) - { - m = enumerator_decl (); - if (m == MATCH_ERROR) - { - gfc_free_enum_history (); - goto cleanup; - } - if (m == MATCH_NO) - break; - - if (gfc_match_eos () == MATCH_YES) - goto cleanup; - if (gfc_match_char (',') != MATCH_YES) - break; - } - - if (gfc_current_state () == COMP_ENUM) - { - gfc_free_enum_history (); - gfc_error ("Syntax error in ENUMERATOR definition at %C"); - m = MATCH_ERROR; - } - -cleanup: - gfc_free_array_spec (current_as); - current_as = NULL; - return m; - -} - - -/* Match binding attributes. */ - -static match -match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) -{ - bool found_passing = false; - bool seen_ptr = false; - match m = MATCH_YES; - - /* Initialize to defaults. Do so even before the MATCH_NO check so that in - this case the defaults are in there. */ - ba->access = ACCESS_UNKNOWN; - ba->pass_arg = NULL; - ba->pass_arg_num = 0; - ba->nopass = 0; - ba->non_overridable = 0; - ba->deferred = 0; - ba->ppc = ppc; - - /* If we find a comma, we believe there are binding attributes. */ - m = gfc_match_char (','); - if (m == MATCH_NO) - goto done; - - do - { - /* Access specifier. */ - - m = gfc_match (" public"); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - { - if (ba->access != ACCESS_UNKNOWN) - { - gfc_error ("Duplicate access-specifier at %C"); - goto error; - } - - ba->access = ACCESS_PUBLIC; - continue; - } - - m = gfc_match (" private"); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - { - if (ba->access != ACCESS_UNKNOWN) - { - gfc_error ("Duplicate access-specifier at %C"); - goto error; - } - - ba->access = ACCESS_PRIVATE; - continue; - } - - /* If inside GENERIC, the following is not allowed. */ - if (!generic) - { - - /* NOPASS flag. */ - m = gfc_match (" nopass"); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - { - if (found_passing) - { - gfc_error ("Binding attributes already specify passing," - " illegal NOPASS at %C"); - goto error; - } - - found_passing = true; - ba->nopass = 1; - continue; - } - - /* PASS possibly including argument. */ - m = gfc_match (" pass"); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - { - char arg[GFC_MAX_SYMBOL_LEN + 1]; - - if (found_passing) - { - gfc_error ("Binding attributes already specify passing," - " illegal PASS at %C"); - goto error; - } - - m = gfc_match (" ( %n )", arg); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - ba->pass_arg = gfc_get_string ("%s", arg); - gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); - - found_passing = true; - ba->nopass = 0; - continue; - } - - if (ppc) - { - /* POINTER flag. */ - m = gfc_match (" pointer"); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - { - if (seen_ptr) - { - gfc_error ("Duplicate POINTER attribute at %C"); - goto error; - } - - seen_ptr = true; - continue; - } - } - else - { - /* NON_OVERRIDABLE flag. */ - m = gfc_match (" non_overridable"); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - { - if (ba->non_overridable) - { - gfc_error ("Duplicate NON_OVERRIDABLE at %C"); - goto error; - } - - ba->non_overridable = 1; - continue; - } - - /* DEFERRED flag. */ - m = gfc_match (" deferred"); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_YES) - { - if (ba->deferred) - { - gfc_error ("Duplicate DEFERRED at %C"); - goto error; - } - - ba->deferred = 1; - continue; - } - } - - } - - /* Nothing matching found. */ - if (generic) - gfc_error ("Expected access-specifier at %C"); - else - gfc_error ("Expected binding attribute at %C"); - goto error; - } - while (gfc_match_char (',') == MATCH_YES); - - /* NON_OVERRIDABLE and DEFERRED exclude themselves. */ - if (ba->non_overridable && ba->deferred) - { - gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C"); - goto error; - } - - m = MATCH_YES; - -done: - if (ba->access == ACCESS_UNKNOWN) - ba->access = ppc ? gfc_current_block()->component_access - : gfc_typebound_default_access; - - if (ppc && !seen_ptr) - { - gfc_error ("POINTER attribute is required for procedure pointer component" - " at %C"); - goto error; - } - - return m; - -error: - return MATCH_ERROR; -} - - -/* Match a PROCEDURE specific binding inside a derived type. */ - -static match -match_procedure_in_type (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - char target_buf[GFC_MAX_SYMBOL_LEN + 1]; - char* target = NULL, *ifc = NULL; - gfc_typebound_proc tb; - bool seen_colons; - bool seen_attrs; - match m; - gfc_symtree* stree; - gfc_namespace* ns; - gfc_symbol* block; - int num; - - /* Check current state. */ - gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); - block = gfc_state_stack->previous->sym; - gcc_assert (block); - - /* Try to match PROCEDURE(interface). */ - if (gfc_match (" (") == MATCH_YES) - { - m = gfc_match_name (target_buf); - if (m == MATCH_ERROR) - return m; - if (m != MATCH_YES) - { - gfc_error ("Interface-name expected after %<(%> at %C"); - return MATCH_ERROR; - } - - if (gfc_match (" )") != MATCH_YES) - { - gfc_error ("%<)%> expected at %C"); - return MATCH_ERROR; - } - - ifc = target_buf; - } - - /* Construct the data structure. */ - memset (&tb, 0, sizeof (tb)); - tb.where = gfc_current_locus; - - /* Match binding attributes. */ - m = match_binding_attributes (&tb, false, false); - if (m == MATCH_ERROR) - return m; - seen_attrs = (m == MATCH_YES); - - /* Check that attribute DEFERRED is given if an interface is specified. */ - if (tb.deferred && !ifc) - { - gfc_error ("Interface must be specified for DEFERRED binding at %C"); - return MATCH_ERROR; - } - if (ifc && !tb.deferred) - { - gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED"); - return MATCH_ERROR; - } - - /* Match the colons. */ - m = gfc_match (" ::"); - if (m == MATCH_ERROR) - return m; - seen_colons = (m == MATCH_YES); - if (seen_attrs && !seen_colons) - { - gfc_error ("Expected %<::%> after binding-attributes at %C"); - return MATCH_ERROR; - } - - /* Match the binding names. */ - for(num=1;;num++) - { - m = gfc_match_name (name); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_NO) - { - gfc_error ("Expected binding name at %C"); - return MATCH_ERROR; - } - - if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C")) - return MATCH_ERROR; - - /* Try to match the '=> target', if it's there. */ - target = ifc; - m = gfc_match (" =>"); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_YES) - { - if (tb.deferred) - { - gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C"); - return MATCH_ERROR; - } - - if (!seen_colons) - { - gfc_error ("%<::%> needed in PROCEDURE binding with explicit target" - " at %C"); - return MATCH_ERROR; - } - - m = gfc_match_name (target_buf); - if (m == MATCH_ERROR) - return m; - if (m == MATCH_NO) - { - gfc_error ("Expected binding target after %<=>%> at %C"); - return MATCH_ERROR; - } - target = target_buf; - } - - /* If no target was found, it has the same name as the binding. */ - if (!target) - target = name; - - /* Get the namespace to insert the symbols into. */ - ns = block->f2k_derived; - gcc_assert (ns); - - /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ - if (tb.deferred && !block->attr.abstract) - { - gfc_error ("Type %qs containing DEFERRED binding at %C " - "is not ABSTRACT", block->name); - return MATCH_ERROR; - } - - /* See if we already have a binding with this name in the symtree which - would be an error. If a GENERIC already targeted this binding, it may - be already there but then typebound is still NULL. */ - stree = gfc_find_symtree (ns->tb_sym_root, name); - if (stree && stree->n.tb) - { - gfc_error ("There is already a procedure with binding name %qs for " - "the derived type %qs at %C", name, block->name); - return MATCH_ERROR; - } - - /* Insert it and set attributes. */ - - if (!stree) - { - stree = gfc_new_symtree (&ns->tb_sym_root, name); - gcc_assert (stree); - } - stree->n.tb = gfc_get_typebound_proc (&tb); - - if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific, - false)) - return MATCH_ERROR; - gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); - gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE, - target, &stree->n.tb->u.specific->n.sym->declared_at); - - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - -syntax: - gfc_error ("Syntax error in PROCEDURE statement at %C"); - return MATCH_ERROR; -} - - -/* Match a GENERIC procedure binding inside a derived type. */ - -match -gfc_match_generic (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */ - gfc_symbol* block; - gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */ - gfc_typebound_proc* tb; - gfc_namespace* ns; - interface_type op_type; - gfc_intrinsic_op op; - match m; - - /* Check current state. */ - if (gfc_current_state () == COMP_DERIVED) - { - gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS"); - return MATCH_ERROR; - } - if (gfc_current_state () != COMP_DERIVED_CONTAINS) - return MATCH_NO; - block = gfc_state_stack->previous->sym; - ns = block->f2k_derived; - gcc_assert (block && ns); - - memset (&tbattr, 0, sizeof (tbattr)); - tbattr.where = gfc_current_locus; - - /* See if we get an access-specifier. */ - m = match_binding_attributes (&tbattr, true, false); - if (m == MATCH_ERROR) - goto error; - - /* Now the colons, those are required. */ - if (gfc_match (" ::") != MATCH_YES) - { - gfc_error ("Expected %<::%> at %C"); - goto error; - } - - /* Match the binding name; depending on type (operator / generic) format - it for future error messages into bind_name. */ - - m = gfc_match_generic_spec (&op_type, name, &op); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - { - gfc_error ("Expected generic name or operator descriptor at %C"); - goto error; - } - - switch (op_type) - { - case INTERFACE_GENERIC: - case INTERFACE_DTIO: - snprintf (bind_name, sizeof (bind_name), "%s", name); - break; - - case INTERFACE_USER_OP: - snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name); - break; - - case INTERFACE_INTRINSIC_OP: - snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)", - gfc_op2string (op)); - break; - - case INTERFACE_NAMELESS: - gfc_error ("Malformed GENERIC statement at %C"); - goto error; - break; - - default: - gcc_unreachable (); - } - - /* Match the required =>. */ - if (gfc_match (" =>") != MATCH_YES) - { - gfc_error ("Expected %<=>%> at %C"); - goto error; - } - - /* Try to find existing GENERIC binding with this name / for this operator; - if there is something, check that it is another GENERIC and then extend - it rather than building a new node. Otherwise, create it and put it - at the right position. */ - - switch (op_type) - { - case INTERFACE_DTIO: - case INTERFACE_USER_OP: - case INTERFACE_GENERIC: - { - const bool is_op = (op_type == INTERFACE_USER_OP); - gfc_symtree* st; - - st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name); - tb = st ? st->n.tb : NULL; - break; - } - - case INTERFACE_INTRINSIC_OP: - tb = ns->tb_op[op]; - break; - - default: - gcc_unreachable (); - } - - if (tb) - { - if (!tb->is_generic) - { - gcc_assert (op_type == INTERFACE_GENERIC); - gfc_error ("There's already a non-generic procedure with binding name" - " %qs for the derived type %qs at %C", - bind_name, block->name); - goto error; - } - - if (tb->access != tbattr.access) - { - gfc_error ("Binding at %C must have the same access as already" - " defined binding %qs", bind_name); - goto error; - } - } - else - { - tb = gfc_get_typebound_proc (NULL); - tb->where = gfc_current_locus; - tb->access = tbattr.access; - tb->is_generic = 1; - tb->u.generic = NULL; - - switch (op_type) - { - case INTERFACE_DTIO: - case INTERFACE_GENERIC: - case INTERFACE_USER_OP: - { - const bool is_op = (op_type == INTERFACE_USER_OP); - gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root : - &ns->tb_sym_root, name); - gcc_assert (st); - st->n.tb = tb; - - break; - } - - case INTERFACE_INTRINSIC_OP: - ns->tb_op[op] = tb; - break; - - default: - gcc_unreachable (); - } - } - - /* Now, match all following names as specific targets. */ - do - { - gfc_symtree* target_st; - gfc_tbp_generic* target; - - m = gfc_match_name (name); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - { - gfc_error ("Expected specific binding name at %C"); - goto error; - } - - target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name); - - /* See if this is a duplicate specification. */ - for (target = tb->u.generic; target; target = target->next) - if (target_st == target->specific_st) - { - gfc_error ("%qs already defined as specific binding for the" - " generic %qs at %C", name, bind_name); - goto error; - } - - target = gfc_get_tbp_generic (); - target->specific_st = target_st; - target->specific = NULL; - target->next = tb->u.generic; - target->is_operator = ((op_type == INTERFACE_USER_OP) - || (op_type == INTERFACE_INTRINSIC_OP)); - tb->u.generic = target; - } - while (gfc_match (" ,") == MATCH_YES); - - /* Here should be the end. */ - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after GENERIC binding at %C"); - goto error; - } - - return MATCH_YES; - -error: - return MATCH_ERROR; -} - - -/* Match a FINAL declaration inside a derived type. */ - -match -gfc_match_final_decl (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol* sym; - match m; - gfc_namespace* module_ns; - bool first, last; - gfc_symbol* block; - - if (gfc_current_form == FORM_FREE) - { - char c = gfc_peek_ascii_char (); - if (!gfc_is_whitespace (c) && c != ':') - return MATCH_NO; - } - - if (gfc_state_stack->state != COMP_DERIVED_CONTAINS) - { - if (gfc_current_form == FORM_FIXED) - return MATCH_NO; - - gfc_error ("FINAL declaration at %C must be inside a derived type " - "CONTAINS section"); - return MATCH_ERROR; - } - - block = gfc_state_stack->previous->sym; - gcc_assert (block); - - if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous - || gfc_state_stack->previous->previous->state != COMP_MODULE) - { - gfc_error ("Derived type declaration with FINAL at %C must be in the" - " specification part of a MODULE"); - return MATCH_ERROR; - } - - module_ns = gfc_current_ns; - gcc_assert (module_ns); - gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE); - - /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */ - if (gfc_match (" ::") == MATCH_ERROR) - return MATCH_ERROR; - - /* Match the sequence of procedure names. */ - first = true; - last = false; - do - { - gfc_finalizer* f; - - if (first && gfc_match_eos () == MATCH_YES) - { - gfc_error ("Empty FINAL at %C"); - return MATCH_ERROR; - } - - m = gfc_match_name (name); - if (m == MATCH_NO) - { - gfc_error ("Expected module procedure name at %C"); - return MATCH_ERROR; - } - else if (m != MATCH_YES) - return MATCH_ERROR; - - if (gfc_match_eos () == MATCH_YES) - last = true; - if (!last && gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expected %<,%> at %C"); - return MATCH_ERROR; - } - - if (gfc_get_symbol (name, module_ns, &sym)) - { - gfc_error ("Unknown procedure name %qs at %C", name); - return MATCH_ERROR; - } - - /* Mark the symbol as module procedure. */ - if (sym->attr.proc != PROC_MODULE - && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) - return MATCH_ERROR; - - /* Check if we already have this symbol in the list, this is an error. */ - for (f = block->f2k_derived->finalizers; f; f = f->next) - if (f->proc_sym == sym) - { - gfc_error ("%qs at %C is already defined as FINAL procedure", - name); - return MATCH_ERROR; - } - - /* Add this symbol to the list of finalizers. */ - gcc_assert (block->f2k_derived); - sym->refs++; - f = XCNEW (gfc_finalizer); - f->proc_sym = sym; - f->proc_tree = NULL; - f->where = gfc_current_locus; - f->next = block->f2k_derived->finalizers; - block->f2k_derived->finalizers = f; - - first = false; - } - while (!last); - - return MATCH_YES; -} - - -const ext_attr_t ext_attr_list[] = { - { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" }, - { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" }, - { "cdecl", EXT_ATTR_CDECL, "cdecl" }, - { "stdcall", EXT_ATTR_STDCALL, "stdcall" }, - { "fastcall", EXT_ATTR_FASTCALL, "fastcall" }, - { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL }, - { "deprecated", EXT_ATTR_DEPRECATED, NULL }, - { NULL, EXT_ATTR_LAST, NULL } -}; - -/* Match a !GCC$ ATTRIBUTES statement of the form: - !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ... - When we come here, we have already matched the !GCC$ ATTRIBUTES string. - - TODO: We should support all GCC attributes using the same syntax for - the attribute list, i.e. the list in C - __attributes(( attribute-list )) - matches then - !GCC$ ATTRIBUTES attribute-list :: - Cf. c-parser.c's c_parser_attributes; the data can then directly be - saved into a TREE. - - As there is absolutely no risk of confusion, we should never return - MATCH_NO. */ -match -gfc_match_gcc_attributes (void) -{ - symbol_attribute attr; - char name[GFC_MAX_SYMBOL_LEN + 1]; - unsigned id; - gfc_symbol *sym; - match m; - - gfc_clear_attr (&attr); - for(;;) - { - char ch; - - if (gfc_match_name (name) != MATCH_YES) - return MATCH_ERROR; - - for (id = 0; id < EXT_ATTR_LAST; id++) - if (strcmp (name, ext_attr_list[id].name) == 0) - break; - - if (id == EXT_ATTR_LAST) - { - gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C"); - return MATCH_ERROR; - } - - if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus)) - return MATCH_ERROR; - - gfc_gobble_whitespace (); - ch = gfc_next_ascii_char (); - if (ch == ':') - { - /* This is the successful exit condition for the loop. */ - if (gfc_next_ascii_char () == ':') - break; - } - - if (ch == ',') - continue; - - goto syntax; - } - - if (gfc_match_eos () == MATCH_YES) - goto syntax; - - for(;;) - { - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - if (find_special (name, &sym, true)) - return MATCH_ERROR; - - sym->attr.ext_attr |= attr.ext_attr; - - if (gfc_match_eos () == MATCH_YES) - break; - - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C"); - return MATCH_ERROR; -} - - -/* Match a !GCC$ UNROLL statement of the form: - !GCC$ UNROLL n - - The parameter n is the number of times we are supposed to unroll. - - When we come here, we have already matched the !GCC$ UNROLL string. */ -match -gfc_match_gcc_unroll (void) -{ - int value; - - /* FIXME: use gfc_match_small_literal_int instead, delete small_int */ - if (gfc_match_small_int (&value) == MATCH_YES) - { - if (value < 0 || value > USHRT_MAX) - { - gfc_error ("% directive requires a" - " non-negative integral constant" - " less than or equal to %u at %C", - USHRT_MAX - ); - return MATCH_ERROR; - } - if (gfc_match_eos () == MATCH_YES) - { - directive_unroll = value == 0 ? 1 : value; - return MATCH_YES; - } - } - - gfc_error ("Syntax error in !GCC$ UNROLL directive at %C"); - return MATCH_ERROR; -} - -/* Match a !GCC$ builtin (b) attributes simd flags if('target') form: - - The parameter b is name of a middle-end built-in. - FLAGS is optional and must be one of: - - (inbranch) - - (notinbranch) - - IF('target') is optional and TARGET is a name of a multilib ABI. - - When we come here, we have already matched the !GCC$ builtin string. */ - -match -gfc_match_gcc_builtin (void) -{ - char builtin[GFC_MAX_SYMBOL_LEN + 1]; - char target[GFC_MAX_SYMBOL_LEN + 1]; - - if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES) - return MATCH_ERROR; - - gfc_simd_clause clause = SIMD_NONE; - if (gfc_match (" ( notinbranch ) ") == MATCH_YES) - clause = SIMD_NOTINBRANCH; - else if (gfc_match (" ( inbranch ) ") == MATCH_YES) - clause = SIMD_INBRANCH; - - if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES) - { - const char *abi = targetm.get_multilib_abi_name (); - if (abi == NULL || strcmp (abi, target) != 0) - return MATCH_YES; - } - - if (gfc_vectorized_builtins == NULL) - gfc_vectorized_builtins = new hash_map (); - - char *r = XNEWVEC (char, strlen (builtin) + 32); - sprintf (r, "__builtin_%s", builtin); - - bool existed; - int &value = gfc_vectorized_builtins->get_or_insert (r, &existed); - value |= clause; - if (existed) - free (r); - - return MATCH_YES; -} - -/* Match an !GCC$ IVDEP statement. - When we come here, we have already matched the !GCC$ IVDEP string. */ - -match -gfc_match_gcc_ivdep (void) -{ - if (gfc_match_eos () == MATCH_YES) - { - directive_ivdep = true; - return MATCH_YES; - } - - gfc_error ("Syntax error in !GCC$ IVDEP directive at %C"); - return MATCH_ERROR; -} - -/* Match an !GCC$ VECTOR statement. - When we come here, we have already matched the !GCC$ VECTOR string. */ - -match -gfc_match_gcc_vector (void) -{ - if (gfc_match_eos () == MATCH_YES) - { - directive_vector = true; - directive_novector = false; - return MATCH_YES; - } - - gfc_error ("Syntax error in !GCC$ VECTOR directive at %C"); - return MATCH_ERROR; -} - -/* Match an !GCC$ NOVECTOR statement. - When we come here, we have already matched the !GCC$ NOVECTOR string. */ - -match -gfc_match_gcc_novector (void) -{ - if (gfc_match_eos () == MATCH_YES) - { - directive_novector = true; - directive_vector = false; - return MATCH_YES; - } - - gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C"); - return MATCH_ERROR; -} diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc new file mode 100644 index 0000000..c846923 --- /dev/null +++ b/gcc/fortran/decl.cc @@ -0,0 +1,11910 @@ +/* Declaration statement matcher + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "stringpool.h" +#include "match.h" +#include "parse.h" +#include "constructor.h" +#include "target.h" + +/* Macros to access allocate memory for gfc_data_variable, + gfc_data_value and gfc_data. */ +#define gfc_get_data_variable() XCNEW (gfc_data_variable) +#define gfc_get_data_value() XCNEW (gfc_data_value) +#define gfc_get_data() XCNEW (gfc_data) + + +static bool set_binding_label (const char **, const char *, int); + + +/* This flag is set if an old-style length selector is matched + during a type-declaration statement. */ + +static int old_char_selector; + +/* When variables acquire types and attributes from a declaration + statement, they get them from the following static variables. The + first part of a declaration sets these variables and the second + part copies these into symbol structures. */ + +static gfc_typespec current_ts; + +static symbol_attribute current_attr; +static gfc_array_spec *current_as; +static int colon_seen; +static int attr_seen; + +/* The current binding label (if any). */ +static const char* curr_binding_label; +/* Need to know how many identifiers are on the current data declaration + line in case we're given the BIND(C) attribute with a NAME= specifier. */ +static int num_idents_on_line; +/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we + can supply a name if the curr_binding_label is nil and NAME= was not. */ +static int has_name_equals = 0; + +/* Initializer of the previous enumerator. */ + +static gfc_expr *last_initializer; + +/* History of all the enumerators is maintained, so that + kind values of all the enumerators could be updated depending + upon the maximum initialized value. */ + +typedef struct enumerator_history +{ + gfc_symbol *sym; + gfc_expr *initializer; + struct enumerator_history *next; +} +enumerator_history; + +/* Header of enum history chain. */ + +static enumerator_history *enum_history = NULL; + +/* Pointer of enum history node containing largest initializer. */ + +static enumerator_history *max_enum = NULL; + +/* gfc_new_block points to the symbol of a newly matched block. */ + +gfc_symbol *gfc_new_block; + +bool gfc_matching_function; + +/* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */ +int directive_unroll = -1; + +/* Set upon parsing supported !GCC$ pragmas for use in the next loop. */ +bool directive_ivdep = false; +bool directive_vector = false; +bool directive_novector = false; + +/* Map of middle-end built-ins that should be vectorized. */ +hash_map *gfc_vectorized_builtins; + +/* If a kind expression of a component of a parameterized derived type is + parameterized, temporarily store the expression here. */ +static gfc_expr *saved_kind_expr = NULL; + +/* Used to store the parameter list arising in a PDT declaration and + in the typespec of a PDT variable or component. */ +static gfc_actual_arglist *decl_type_param_list; +static gfc_actual_arglist *type_param_spec_list; + +/********************* DATA statement subroutines *********************/ + +static bool in_match_data = false; + +bool +gfc_in_match_data (void) +{ + return in_match_data; +} + +static void +set_in_match_data (bool set_value) +{ + in_match_data = set_value; +} + +/* Free a gfc_data_variable structure and everything beneath it. */ + +static void +free_variable (gfc_data_variable *p) +{ + gfc_data_variable *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free_iterator (&p->iter, 0); + free_variable (p->list); + free (p); + } +} + + +/* Free a gfc_data_value structure and everything beneath it. */ + +static void +free_value (gfc_data_value *p) +{ + gfc_data_value *q; + + for (; p; p = q) + { + q = p->next; + mpz_clear (p->repeat); + gfc_free_expr (p->expr); + free (p); + } +} + + +/* Free a list of gfc_data structures. */ + +void +gfc_free_data (gfc_data *p) +{ + gfc_data *q; + + for (; p; p = q) + { + q = p->next; + free_variable (p->var); + free_value (p->value); + free (p); + } +} + + +/* Free all data in a namespace. */ + +static void +gfc_free_data_all (gfc_namespace *ns) +{ + gfc_data *d; + + for (;ns->data;) + { + d = ns->data->next; + free (ns->data); + ns->data = d; + } +} + +/* Reject data parsed since the last restore point was marked. */ + +void +gfc_reject_data (gfc_namespace *ns) +{ + gfc_data *d; + + while (ns->data && ns->data != ns->old_data) + { + d = ns->data->next; + free (ns->data); + ns->data = d; + } +} + +static match var_element (gfc_data_variable *); + +/* Match a list of variables terminated by an iterator and a right + parenthesis. */ + +static match +var_list (gfc_data_variable *parent) +{ + gfc_data_variable *tail, var; + match m; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail = gfc_get_data_variable (); + *tail = var; + + parent->list = tail; + + for (;;) + { + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = gfc_match_iterator (&parent->iter, 1); + if (m == MATCH_YES) + break; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail->next = gfc_get_data_variable (); + tail = tail->next; + + *tail = var; + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +/* Match a single element in a data variable list, which can be a + variable-iterator list. */ + +static match +var_element (gfc_data_variable *new_var) +{ + match m; + gfc_symbol *sym; + + memset (new_var, 0, sizeof (gfc_data_variable)); + + if (gfc_match_char ('(') == MATCH_YES) + return var_list (new_var); + + m = gfc_match_variable (&new_var->expr, 0); + if (m != MATCH_YES) + return m; + + if (new_var->expr->expr_type == EXPR_CONSTANT + && new_var->expr->symtree == NULL) + { + gfc_error ("Inquiry parameter cannot appear in a " + "data-stmt-object-list at %C"); + return MATCH_ERROR; + } + + sym = new_var->expr->symtree->n.sym; + + /* Symbol should already have an associated type. */ + if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus)) + return MATCH_ERROR; + + if (!sym->attr.function && gfc_current_ns->parent + && gfc_current_ns->parent == sym->ns) + { + gfc_error ("Host associated variable %qs may not be in the DATA " + "statement at %C", sym->name); + return MATCH_ERROR; + } + + if (gfc_current_state () != COMP_BLOCK_DATA + && sym->attr.in_common + && !gfc_notify_std (GFC_STD_GNU, "initialization of " + "common block variable %qs in DATA statement at %C", + sym->name)) + return MATCH_ERROR; + + if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Match the top-level list of data variables. */ + +static match +top_var_list (gfc_data *d) +{ + gfc_data_variable var, *tail, *new_var; + match m; + + tail = NULL; + + for (;;) + { + m = var_element (&var); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new_var = gfc_get_data_variable (); + *new_var = var; + if (new_var->expr) + new_var->expr->where = gfc_current_locus; + + if (tail == NULL) + d->var = new_var; + else + tail->next = new_var; + + tail = new_var; + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + gfc_free_data_all (gfc_current_ns); + return MATCH_ERROR; +} + + +static match +match_data_constant (gfc_expr **result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym, *dt_sym = NULL; + gfc_expr *expr; + match m; + locus old_loc; + + m = gfc_match_literal_constant (&expr, 1); + if (m == MATCH_YES) + { + *result = expr; + return MATCH_YES; + } + + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match_null (result); + if (m != MATCH_NO) + return m; + + old_loc = gfc_current_locus; + + /* Should this be a structure component, try to match it + before matching a name. */ + m = gfc_match_rvalue (result); + if (m == MATCH_ERROR) + return m; + + if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE) + { + if (!gfc_simplify_expr (*result, 0)) + m = MATCH_ERROR; + return m; + } + else if (m == MATCH_YES) + { + /* If a parameter inquiry ends up here, symtree is NULL but **result + contains the right constant expression. Check here. */ + if ((*result)->symtree == NULL + && (*result)->expr_type == EXPR_CONSTANT + && ((*result)->ts.type == BT_INTEGER + || (*result)->ts.type == BT_REAL)) + return m; + + /* F2018:R845 data-stmt-constant is initial-data-target. + A data-stmt-constant shall be ... initial-data-target if and + only if the corresponding data-stmt-object has the POINTER + attribute. ... If data-stmt-constant is initial-data-target + the corresponding data statement object shall be + data-pointer-initialization compatible (7.5.4.6) with the initial + data target; the data statement object is initially associated + with the target. */ + if ((*result)->symtree->n.sym->attr.save + && (*result)->symtree->n.sym->attr.target) + return m; + gfc_free_expr (*result); + } + + gfc_current_locus = old_loc; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym && sym->attr.generic) + dt_sym = gfc_find_dt_in_generic (sym); + + if (sym == NULL + || (sym->attr.flavor != FL_PARAMETER + && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor)))) + { + gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", + name); + *result = NULL; + return MATCH_ERROR; + } + else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)) + return gfc_match_structure_constructor (dt_sym, result); + + /* Check to see if the value is an initialization array expression. */ + if (sym->value->expr_type == EXPR_ARRAY) + { + gfc_current_locus = old_loc; + + m = gfc_match_init_expr (result); + if (m == MATCH_ERROR) + return m; + + if (m == MATCH_YES) + { + if (!gfc_simplify_expr (*result, 0)) + m = MATCH_ERROR; + + if ((*result)->expr_type == EXPR_CONSTANT) + return m; + else + { + gfc_error ("Invalid initializer %s in Data statement at %C", name); + return MATCH_ERROR; + } + } + } + + *result = gfc_copy_expr (sym->value); + return MATCH_YES; +} + + +/* Match a list of values in a DATA statement. The leading '/' has + already been seen at this point. */ + +static match +top_val_list (gfc_data *data) +{ + gfc_data_value *new_val, *tail; + gfc_expr *expr; + match m; + + tail = NULL; + + for (;;) + { + m = match_data_constant (&expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new_val = gfc_get_data_value (); + mpz_init (new_val->repeat); + + if (tail == NULL) + data->value = new_val; + else + tail->next = new_val; + + tail = new_val; + + if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) + { + tail->expr = expr; + mpz_set_ui (tail->repeat, 1); + } + else + { + mpz_set (tail->repeat, expr->value.integer); + gfc_free_expr (expr); + + m = match_data_constant (&tail->expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + } + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') == MATCH_NO) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + gfc_free_data_all (gfc_current_ns); + return MATCH_ERROR; +} + + +/* Matches an old style initialization. */ + +static match +match_old_style_init (const char *name) +{ + match m; + gfc_symtree *st; + gfc_symbol *sym; + gfc_data *newdata, *nd; + + /* Set up data structure to hold initializers. */ + gfc_find_sym_tree (name, NULL, 0, &st); + sym = st->n.sym; + + newdata = gfc_get_data (); + newdata->var = gfc_get_data_variable (); + newdata->var->expr = gfc_get_variable_expr (st); + newdata->var->expr->where = sym->declared_at; + newdata->where = gfc_current_locus; + + /* Match initial value list. This also eats the terminal '/'. */ + m = top_val_list (newdata); + if (m != MATCH_YES) + { + free (newdata); + return m; + } + + /* Check that a BOZ did not creep into an old-style initialization. */ + for (nd = newdata; nd; nd = nd->next) + { + if (nd->value->expr->ts.type == BT_BOZ + && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style " + "initialization"), &nd->value->expr->where)) + return MATCH_ERROR; + + if (nd->var->expr->ts.type != BT_INTEGER + && nd->var->expr->ts.type != BT_REAL + && nd->value->expr->ts.type == BT_BOZ) + { + gfc_error (G_("BOZ literal constant near %L cannot be assigned to " + "a %qs variable in an old-style initialization"), + &nd->value->expr->where, + gfc_typename (&nd->value->expr->ts)); + return MATCH_ERROR; + } + } + + if (gfc_pure (NULL)) + { + gfc_error ("Initialization at %C is not allowed in a PURE procedure"); + free (newdata); + return MATCH_ERROR; + } + gfc_unset_implicit_pure (gfc_current_ns->proc_name); + + /* Mark the variable as having appeared in a data statement. */ + if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at)) + { + free (newdata); + return MATCH_ERROR; + } + + /* Chain in namespace list of DATA initializers. */ + newdata->next = gfc_current_ns->data; + gfc_current_ns->data = newdata; + + return m; +} + + +/* Match the stuff following a DATA statement. If ERROR_FLAG is set, + we are matching a DATA statement and are therefore issuing an error + if we encounter something unexpected, if not, we're trying to match + an old-style initialization expression of the form INTEGER I /2/. */ + +match +gfc_match_data (void) +{ + gfc_data *new_data; + gfc_expr *e; + gfc_ref *ref; + match m; + char c; + + /* DATA has been matched. In free form source code, the next character + needs to be whitespace or '(' from an implied do-loop. Check that + here. */ + c = gfc_peek_ascii_char (); + if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(') + return MATCH_NO; + + /* Before parsing the rest of a DATA statement, check F2008:c1206. */ + if ((gfc_current_state () == COMP_FUNCTION + || gfc_current_state () == COMP_SUBROUTINE) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("DATA statement at %C cannot appear within an INTERFACE"); + return MATCH_ERROR; + } + + set_in_match_data (true); + + for (;;) + { + new_data = gfc_get_data (); + new_data->where = gfc_current_locus; + + m = top_var_list (new_data); + if (m != MATCH_YES) + goto cleanup; + + if (new_data->var->iter.var + && new_data->var->iter.var->ts.type == BT_INTEGER + && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1 + && new_data->var->list + && new_data->var->list->expr + && new_data->var->list->expr->ts.type == BT_CHARACTER + && new_data->var->list->expr->ref + && new_data->var->list->expr->ref->type == REF_SUBSTRING) + { + gfc_error ("Invalid substring in data-implied-do at %L in DATA " + "statement", &new_data->var->list->expr->where); + goto cleanup; + } + + /* Check for an entity with an allocatable component, which is not + allowed. */ + e = new_data->var->expr; + if (e) + { + bool invalid; + + invalid = false; + for (ref = e->ref; ref; ref = ref->next) + if ((ref->type == REF_COMPONENT + && ref->u.c.component->attr.allocatable) + || (ref->type == REF_ARRAY + && e->symtree->n.sym->attr.pointer != 1 + && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED)) + invalid = true; + + if (invalid) + { + gfc_error ("Allocatable component or deferred-shaped array " + "near %C in DATA statement"); + goto cleanup; + } + + /* F2008:C567 (R536) A data-i-do-object or a variable that appears + as a data-stmt-object shall not be an object designator in which + a pointer appears other than as the entire rightmost part-ref. */ + if (!e->ref && e->ts.type == BT_DERIVED + && e->symtree->n.sym->attr.pointer) + goto partref; + + ref = e->ref; + if (e->symtree->n.sym->ts.type == BT_DERIVED + && e->symtree->n.sym->attr.pointer + && ref->type == REF_COMPONENT) + goto partref; + + for (; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && ref->u.c.component->attr.pointer + && ref->next) + goto partref; + } + + m = top_val_list (new_data); + if (m != MATCH_YES) + goto cleanup; + + new_data->next = gfc_current_ns->data; + gfc_current_ns->data = new_data; + + /* A BOZ literal constant cannot appear in a structure constructor. + Check for that here for a data statement value. */ + if (new_data->value->expr->ts.type == BT_DERIVED + && new_data->value->expr->value.constructor) + { + gfc_constructor *c; + c = gfc_constructor_first (new_data->value->expr->value.constructor); + for (; c; c = gfc_constructor_next (c)) + if (c->expr && c->expr->ts.type == BT_BOZ) + { + gfc_error ("BOZ literal constant at %L cannot appear in a " + "structure constructor", &c->expr->where); + return MATCH_ERROR; + } + } + + if (gfc_match_eos () == MATCH_YES) + break; + + gfc_match_char (','); /* Optional comma */ + } + + set_in_match_data (false); + + if (gfc_pure (NULL)) + { + gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); + return MATCH_ERROR; + } + gfc_unset_implicit_pure (gfc_current_ns->proc_name); + + return MATCH_YES; + +partref: + + gfc_error ("part-ref with pointer attribute near %L is not " + "rightmost part-ref of data-stmt-object", + &e->where); + +cleanup: + set_in_match_data (false); + gfc_free_data (new_data); + return MATCH_ERROR; +} + + +/************************ Declaration statements *********************/ + + +/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization + list). The difference here is the expression is a list of constants + and is surrounded by '/'. + The typespec ts must match the typespec of the variable which the + clist is initializing. + The arrayspec tells whether this should match a list of constants + corresponding to array elements or a scalar (as == NULL). */ + +static match +match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) +{ + gfc_constructor_base array_head = NULL; + gfc_expr *expr = NULL; + match m = MATCH_ERROR; + locus where; + mpz_t repeat, cons_size, as_size; + bool scalar; + int cmp; + + gcc_assert (ts); + + /* We have already matched '/' - now look for a constant list, as with + top_val_list from decl.c, but append the result to an array. */ + if (gfc_match ("/") == MATCH_YES) + { + gfc_error ("Empty old style initializer list at %C"); + return MATCH_ERROR; + } + + where = gfc_current_locus; + scalar = !as || !as->rank; + + if (!scalar && !spec_size (as, &as_size)) + { + gfc_error ("Array in initializer list at %L must have an explicit shape", + as->type == AS_EXPLICIT ? &as->upper[0]->where : &where); + /* Nothing to cleanup yet. */ + return MATCH_ERROR; + } + + mpz_init_set_ui (repeat, 0); + + for (;;) + { + m = match_data_constant (&expr); + if (m != MATCH_YES) + expr = NULL; /* match_data_constant may set expr to garbage */ + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + /* Found r in repeat spec r*c; look for the constant to repeat. */ + if ( gfc_match_char ('*') == MATCH_YES) + { + if (scalar) + { + gfc_error ("Repeat spec invalid in scalar initializer at %C"); + goto cleanup; + } + if (expr->ts.type != BT_INTEGER) + { + gfc_error ("Repeat spec must be an integer at %C"); + goto cleanup; + } + mpz_set (repeat, expr->value.integer); + gfc_free_expr (expr); + expr = NULL; + + m = match_data_constant (&expr); + if (m == MATCH_NO) + { + m = MATCH_ERROR; + gfc_error ("Expected data constant after repeat spec at %C"); + } + if (m != MATCH_YES) + goto cleanup; + } + /* No repeat spec, we matched the data constant itself. */ + else + mpz_set_ui (repeat, 1); + + if (!scalar) + { + /* Add the constant initializer as many times as repeated. */ + for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1)) + { + /* Make sure types of elements match */ + if(ts && !gfc_compare_types (&expr->ts, ts) + && !gfc_convert_type (expr, ts, 1)) + goto cleanup; + + gfc_constructor_append_expr (&array_head, + gfc_copy_expr (expr), &gfc_current_locus); + } + + gfc_free_expr (expr); + expr = NULL; + } + + /* For scalar initializers quit after one element. */ + else + { + if(gfc_match_char ('/') != MATCH_YES) + { + gfc_error ("End of scalar initializer expected at %C"); + goto cleanup; + } + break; + } + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') == MATCH_NO) + goto syntax; + } + + /* If we break early from here out, we encountered an error. */ + m = MATCH_ERROR; + + /* Set up expr as an array constructor. */ + if (!scalar) + { + expr = gfc_get_array_expr (ts->type, ts->kind, &where); + expr->ts = *ts; + expr->value.constructor = array_head; + + /* Validate sizes. We built expr ourselves, so cons_size will be + constant (we fail above for non-constant expressions). + We still need to verify that the sizes match. */ + gcc_assert (gfc_array_size (expr, &cons_size)); + cmp = mpz_cmp (cons_size, as_size); + if (cmp < 0) + gfc_error ("Not enough elements in array initializer at %C"); + else if (cmp > 0) + gfc_error ("Too many elements in array initializer at %C"); + mpz_clear (cons_size); + if (cmp) + goto cleanup; + + /* Set the rank/shape to match the LHS as auto-reshape is implied. */ + expr->rank = as->rank; + expr->shape = gfc_get_shape (as->rank); + for (int i = 0; i < as->rank; ++i) + spec_dimen_size (as, i, &expr->shape[i]); + } + + /* Make sure scalar types match. */ + else if (!gfc_compare_types (&expr->ts, ts) + && !gfc_convert_type (expr, ts, 1)) + goto cleanup; + + if (expr->ts.u.cl) + expr->ts.u.cl->length_from_typespec = 1; + + *result = expr; + m = MATCH_YES; + goto done; + +syntax: + m = MATCH_ERROR; + gfc_error ("Syntax error in old style initializer list at %C"); + +cleanup: + if (expr) + expr->value.constructor = NULL; + gfc_free_expr (expr); + gfc_constructor_free (array_head); + +done: + mpz_clear (repeat); + if (!scalar) + mpz_clear (as_size); + return m; +} + + +/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */ + +static bool +merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) +{ + if ((from->type == AS_ASSUMED_RANK && to->corank) + || (to->type == AS_ASSUMED_RANK && from->corank)) + { + gfc_error ("The assumed-rank array at %C shall not have a codimension"); + return false; + } + + if (to->rank == 0 && from->rank > 0) + { + to->rank = from->rank; + to->type = from->type; + to->cray_pointee = from->cray_pointee; + to->cp_was_assumed = from->cp_was_assumed; + + for (int i = to->corank - 1; i >= 0; i--) + { + /* Do not exceed the limits on lower[] and upper[]. gfortran + cleans up elsewhere. */ + int j = from->rank + i; + if (j >= GFC_MAX_DIMENSIONS) + break; + + to->lower[j] = to->lower[i]; + to->upper[j] = to->upper[i]; + } + for (int i = 0; i < from->rank; i++) + { + if (copy) + { + to->lower[i] = gfc_copy_expr (from->lower[i]); + to->upper[i] = gfc_copy_expr (from->upper[i]); + } + else + { + to->lower[i] = from->lower[i]; + to->upper[i] = from->upper[i]; + } + } + } + else if (to->corank == 0 && from->corank > 0) + { + to->corank = from->corank; + to->cotype = from->cotype; + + for (int i = 0; i < from->corank; i++) + { + /* Do not exceed the limits on lower[] and upper[]. gfortran + cleans up elsewhere. */ + int k = from->rank + i; + int j = to->rank + i; + if (j >= GFC_MAX_DIMENSIONS) + break; + + if (copy) + { + to->lower[j] = gfc_copy_expr (from->lower[k]); + to->upper[j] = gfc_copy_expr (from->upper[k]); + } + else + { + to->lower[j] = from->lower[k]; + to->upper[j] = from->upper[k]; + } + } + } + + if (to->rank + to->corank > GFC_MAX_DIMENSIONS) + { + gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum " + "allowed dimensions of %d", + to->rank, to->corank, GFC_MAX_DIMENSIONS); + to->corank = GFC_MAX_DIMENSIONS - to->rank; + return false; + } + return true; +} + + +/* Match an intent specification. Since this can only happen after an + INTENT word, a legal intent-spec must follow. */ + +static sym_intent +match_intent_spec (void) +{ + + if (gfc_match (" ( in out )") == MATCH_YES) + return INTENT_INOUT; + if (gfc_match (" ( in )") == MATCH_YES) + return INTENT_IN; + if (gfc_match (" ( out )") == MATCH_YES) + return INTENT_OUT; + + gfc_error ("Bad INTENT specification at %C"); + return INTENT_UNKNOWN; +} + + +/* Matches a character length specification, which is either a + specification expression, '*', or ':'. */ + +static match +char_len_param_value (gfc_expr **expr, bool *deferred) +{ + match m; + + *expr = NULL; + *deferred = false; + + if (gfc_match_char ('*') == MATCH_YES) + return MATCH_YES; + + if (gfc_match_char (':') == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C")) + return MATCH_ERROR; + + *deferred = true; + + return MATCH_YES; + } + + m = gfc_match_expr (expr); + + if (m == MATCH_NO || m == MATCH_ERROR) + return m; + + if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) + return MATCH_ERROR; + + /* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things + like CHARACTER(([1])). */ + if ((*expr)->expr_type == EXPR_OP) + gfc_simplify_expr (*expr, 1); + + if ((*expr)->expr_type == EXPR_FUNCTION) + { + if ((*expr)->ts.type == BT_INTEGER + || ((*expr)->ts.type == BT_UNKNOWN + && strcmp((*expr)->symtree->name, "null") != 0)) + return MATCH_YES; + + goto syntax; + } + else if ((*expr)->expr_type == EXPR_CONSTANT) + { + /* F2008, 4.4.3.1: The length is a type parameter; its kind is + processor dependent and its value is greater than or equal to zero. + F2008, 4.4.3.2: If the character length parameter value evaluates + to a negative value, the length of character entities declared + is zero. */ + + if ((*expr)->ts.type == BT_INTEGER) + { + if (mpz_cmp_si ((*expr)->value.integer, 0) < 0) + mpz_set_si ((*expr)->value.integer, 0); + } + else + goto syntax; + } + else if ((*expr)->expr_type == EXPR_ARRAY) + goto syntax; + else if ((*expr)->expr_type == EXPR_VARIABLE) + { + bool t; + gfc_expr *e; + + e = gfc_copy_expr (*expr); + + /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']", + which causes an ICE if gfc_reduce_init_expr() is called. */ + if (e->ref && e->ref->type == REF_ARRAY + && e->ref->u.ar.type == AR_UNKNOWN + && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) + goto syntax; + + t = gfc_reduce_init_expr (e); + + if (!t && e->ts.type == BT_UNKNOWN + && e->symtree->n.sym->attr.untyped == 1 + && (flag_implicit_none + || e->symtree->n.sym->ns->seen_implicit_none == 1 + || e->symtree->n.sym->ns->parent->seen_implicit_none == 1)) + { + gfc_free_expr (e); + goto syntax; + } + + if ((e->ref && e->ref->type == REF_ARRAY + && e->ref->u.ar.type != AR_ELEMENT) + || (!e->ref && e->expr_type == EXPR_ARRAY)) + { + gfc_free_expr (e); + goto syntax; + } + + gfc_free_expr (e); + } + + if (gfc_seen_div0) + m = MATCH_ERROR; + + return m; + +syntax: + gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where); + return MATCH_ERROR; +} + + +/* A character length is a '*' followed by a literal integer or a + char_len_param_value in parenthesis. */ + +static match +match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) +{ + int length; + match m; + + *deferred = false; + m = gfc_match_char ('*'); + if (m != MATCH_YES) + return m; + + m = gfc_match_small_literal_int (&length, NULL); + if (m == MATCH_ERROR) + return m; + + if (m == MATCH_YES) + { + if (obsolescent_check + && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C")) + return MATCH_ERROR; + *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length); + return m; + } + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + m = char_len_param_value (expr, deferred); + if (m != MATCH_YES && gfc_matching_function) + { + gfc_undo_symbols (); + m = MATCH_YES; + } + + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match_char (')') == MATCH_NO) + { + gfc_free_expr (*expr); + *expr = NULL; + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in character length specification at %C"); + return MATCH_ERROR; +} + + +/* Special subroutine for finding a symbol. Check if the name is found + in the current name space. If not, and we're compiling a function or + subroutine and the parent compilation unit is an interface, then check + to see if the name we've been given is the name of the interface + (located in another namespace). */ + +static int +find_special (const char *name, gfc_symbol **result, bool allow_subroutine) +{ + gfc_state_data *s; + gfc_symtree *st; + int i; + + i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine); + if (i == 0) + { + *result = st ? st->n.sym : NULL; + goto end; + } + + if (gfc_current_state () != COMP_SUBROUTINE + && gfc_current_state () != COMP_FUNCTION) + goto end; + + s = gfc_state_stack->previous; + if (s == NULL) + goto end; + + if (s->state != COMP_INTERFACE) + goto end; + if (s->sym == NULL) + goto end; /* Nameless interface. */ + + if (strcmp (name, s->sym->name) == 0) + { + *result = s->sym; + return 0; + } + +end: + return i; +} + + +/* Special subroutine for getting a symbol node associated with a + procedure name, used in SUBROUTINE and FUNCTION statements. The + symbol is created in the parent using with symtree node in the + child unit pointing to the symbol. If the current namespace has no + parent, then the symbol is just created in the current unit. */ + +static int +get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) +{ + gfc_symtree *st; + gfc_symbol *sym; + int rc = 0; + + /* Module functions have to be left in their own namespace because + they have potentially (almost certainly!) already been referenced. + In this sense, they are rather like external functions. This is + fixed up in resolve.c(resolve_entries), where the symbol name- + space is set to point to the master function, so that the fake + result mechanism can work. */ + if (module_fcn_entry) + { + /* Present if entry is declared to be a module procedure. */ + rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result); + + if (*result == NULL) + rc = gfc_get_symbol (name, NULL, result); + else if (!gfc_get_symbol (name, NULL, &sym) && sym + && (*result)->ts.type == BT_UNKNOWN + && sym->attr.flavor == FL_UNKNOWN) + /* Pick up the typespec for the entry, if declared in the function + body. Note that this symbol is FL_UNKNOWN because it will + only have appeared in a type declaration. The local symtree + is set to point to the module symbol and a unique symtree + to the local version. This latter ensures a correct clearing + of the symbols. */ + { + /* If the ENTRY proceeds its specification, we need to ensure + that this does not raise a "has no IMPLICIT type" error. */ + if (sym->ts.type == BT_UNKNOWN) + sym->attr.untyped = 1; + + (*result)->ts = sym->ts; + + /* Put the symbol in the procedure namespace so that, should + the ENTRY precede its specification, the specification + can be applied. */ + (*result)->ns = gfc_current_ns; + + gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + st->n.sym = *result; + st = gfc_get_unique_symtree (gfc_current_ns); + sym->refs++; + st->n.sym = sym; + } + } + else + rc = gfc_get_symbol (name, gfc_current_ns->parent, result); + + if (rc) + return rc; + + sym = *result; + if (sym->attr.proc == PROC_ST_FUNCTION) + return rc; + + if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY) + { + /* Create a partially populated interface symbol to carry the + characteristics of the procedure and the result. */ + sym->tlink = gfc_new_symbol (name, sym->ns); + gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus); + gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL); + if (sym->attr.dimension) + sym->tlink->as = gfc_copy_array_spec (sym->as); + + /* Ideally, at this point, a copy would be made of the formal + arguments and their namespace. However, this does not appear + to be necessary, albeit at the expense of not being able to + use gfc_compare_interfaces directly. */ + + if (sym->result && sym->result != sym) + { + sym->tlink->result = sym->result; + sym->result = NULL; + } + else if (sym->result) + { + sym->tlink->result = sym->tlink; + } + } + else if (sym && !sym->gfc_new + && gfc_current_state () != COMP_INTERFACE) + { + /* Trap another encompassed procedure with the same name. All + these conditions are necessary to avoid picking up an entry + whose name clashes with that of the encompassing procedure; + this is handled using gsymbols to register unique, globally + accessible names. */ + if (sym->attr.flavor != 0 + && sym->attr.proc != 0 + && (sym->attr.subroutine || sym->attr.function || sym->attr.entry) + && sym->attr.if_source != IFSRC_UNKNOWN) + { + gfc_error_now ("Procedure %qs at %C is already defined at %L", + name, &sym->declared_at); + return true; + } + if (sym->attr.flavor != 0 + && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN) + { + gfc_error_now ("Procedure %qs at %C is already defined at %L", + name, &sym->declared_at); + return true; + } + + if (sym->attr.external && sym->attr.procedure + && gfc_current_state () == COMP_CONTAINS) + { + gfc_error_now ("Contained procedure %qs at %C clashes with " + "procedure defined at %L", + name, &sym->declared_at); + return true; + } + + /* Trap a procedure with a name the same as interface in the + encompassing scope. */ + if (sym->attr.generic != 0 + && (sym->attr.subroutine || sym->attr.function) + && !sym->attr.mod_proc) + { + gfc_error_now ("Name %qs at %C is already defined" + " as a generic interface at %L", + name, &sym->declared_at); + return true; + } + + /* Trap declarations of attributes in encompassing scope. The + signature for this is that ts.kind is nonzero for no-CLASS + entity. For a CLASS entity, ts.kind is zero. */ + if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS) + && !sym->attr.implicit_type + && sym->attr.proc == 0 + && gfc_current_ns->parent != NULL + && sym->attr.access == 0 + && !module_fcn_entry) + { + gfc_error_now ("Procedure %qs at %C has an explicit interface " + "from a previous declaration", name); + return true; + } + } + + /* C1246 (R1225) MODULE shall appear only in the function-stmt or + subroutine-stmt of a module subprogram or of a nonabstract interface + body that is declared in the scoping unit of a module or submodule. */ + if (sym->attr.external + && (sym->attr.subroutine || sym->attr.function) + && sym->attr.if_source == IFSRC_IFBODY + && !current_attr.module_procedure + && sym->attr.proc == PROC_MODULE + && gfc_state_stack->state == COMP_CONTAINS) + { + gfc_error_now ("Procedure %qs defined in interface body at %L " + "clashes with internal procedure defined at %C", + name, &sym->declared_at); + return true; + } + + if (sym && !sym->gfc_new + && sym->attr.flavor != FL_UNKNOWN + && sym->attr.referenced == 0 && sym->attr.subroutine == 1 + && gfc_state_stack->state == COMP_CONTAINS + && gfc_state_stack->previous->state == COMP_SUBROUTINE) + { + gfc_error_now ("Procedure %qs at %C is already defined at %L", + name, &sym->declared_at); + return true; + } + + if (gfc_current_ns->parent == NULL || *result == NULL) + return rc; + + /* Module function entries will already have a symtree in + the current namespace but will need one at module level. */ + if (module_fcn_entry) + { + /* Present if entry is declared to be a module procedure. */ + rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st); + if (st == NULL) + st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name); + } + else + st = gfc_new_symtree (&gfc_current_ns->sym_root, name); + + st->n.sym = sym; + sym->refs++; + + /* See if the procedure should be a module procedure. */ + + if (((sym->ns->proc_name != NULL + && sym->ns->proc_name->attr.flavor == FL_MODULE + && sym->attr.proc != PROC_MODULE) + || (module_fcn_entry && sym->attr.proc != PROC_MODULE)) + && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) + rc = 2; + + return rc; +} + + +/* Verify that the given symbol representing a parameter is C + interoperable, by checking to see if it was marked as such after + its declaration. If the given symbol is not interoperable, a + warning is reported, thus removing the need to return the status to + the calling function. The standard does not require the user use + one of the iso_c_binding named constants to declare an + interoperable parameter, but we can't be sure if the param is C + interop or not if the user doesn't. For example, integer(4) may be + legal Fortran, but doesn't have meaning in C. It may interop with + a number of the C types, which causes a problem because the + compiler can't know which one. This code is almost certainly not + portable, and the user will get what they deserve if the C type + across platforms isn't always interoperable with integer(4). If + the user had used something like integer(c_int) or integer(c_long), + the compiler could have automatically handled the varying sizes + across platforms. */ + +bool +gfc_verify_c_interop_param (gfc_symbol *sym) +{ + int is_c_interop = 0; + bool retval = true; + + /* We check implicitly typed variables in symbol.c:gfc_set_default_type(). + Don't repeat the checks here. */ + if (sym->attr.implicit_type) + return true; + + /* For subroutines or functions that are passed to a BIND(C) procedure, + they're interoperable if they're BIND(C) and their params are all + interoperable. */ + if (sym->attr.flavor == FL_PROCEDURE) + { + if (sym->attr.is_bind_c == 0) + { + gfc_error_now ("Procedure %qs at %L must have the BIND(C) " + "attribute to be C interoperable", sym->name, + &(sym->declared_at)); + return false; + } + else + { + if (sym->attr.is_c_interop == 1) + /* We've already checked this procedure; don't check it again. */ + return true; + else + return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, + sym->common_block); + } + } + + /* See if we've stored a reference to a procedure that owns sym. */ + if (sym->ns != NULL && sym->ns->proc_name != NULL) + { + if (sym->ns->proc_name->attr.is_bind_c == 1) + { + is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0); + + if (is_c_interop != 1) + { + /* Make personalized messages to give better feedback. */ + if (sym->ts.type == BT_DERIVED) + gfc_error ("Variable %qs at %L is a dummy argument to the " + "BIND(C) procedure %qs but is not C interoperable " + "because derived type %qs is not C interoperable", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name, + sym->ts.u.derived->name); + else if (sym->ts.type == BT_CLASS) + gfc_error ("Variable %qs at %L is a dummy argument to the " + "BIND(C) procedure %qs but is not C interoperable " + "because it is polymorphic", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name); + else if (warn_c_binding_type) + gfc_warning (OPT_Wc_binding_type, + "Variable %qs at %L is a dummy argument of the " + "BIND(C) procedure %qs but may not be C " + "interoperable", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name); + } + + /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */ + if (sym->attr.pointer && sym->attr.contiguous) + gfc_error ("Dummy argument %qs at %L may not be a pointer with " + "CONTIGUOUS attribute as procedure %qs is BIND(C)", + sym->name, &sym->declared_at, sym->ns->proc_name->name); + + /* Per F2018, C1557, pointer/allocatable dummies to a bind(c) + procedure that are default-initialized are not permitted. */ + if ((sym->attr.pointer || sym->attr.allocatable) + && sym->ts.type == BT_DERIVED + && gfc_has_default_initializer (sym->ts.u.derived)) + { + gfc_error ("Default-initialized %s dummy argument %qs " + "at %L is not permitted in BIND(C) procedure %qs", + (sym->attr.pointer ? "pointer" : "allocatable"), + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + + /* Character strings are only C interoperable if they have a + length of 1. However, as an argument they are also iteroperable + when passed as descriptor (which requires len=: or len=*). */ + if (sym->ts.type == BT_CHARACTER) + { + gfc_charlen *cl = sym->ts.u.cl; + + if (sym->attr.allocatable || sym->attr.pointer) + { + /* F2018, 18.3.6 (6). */ + if (!sym->ts.deferred) + { + if (sym->attr.allocatable) + gfc_error ("Allocatable character dummy argument %qs " + "at %L must have deferred length as " + "procedure %qs is BIND(C)", sym->name, + &sym->declared_at, sym->ns->proc_name->name); + else + gfc_error ("Pointer character dummy argument %qs at %L " + "must have deferred length as procedure %qs " + "is BIND(C)", sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + else if (!gfc_notify_std (GFC_STD_F2018, + "Deferred-length character dummy " + "argument %qs at %L of procedure " + "%qs with BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; + } + else if (sym->attr.value + && (!cl || !cl->length + || cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (cl->length->value.integer, 1) != 0)) + { + gfc_error ("Character dummy argument %qs at %L must be " + "of length 1 as it has the VALUE attribute", + sym->name, &sym->declared_at); + retval = false; + } + else if (!cl || !cl->length) + { + /* Assumed length; F2018, 18.3.6 (5)(2). + Uses the CFI array descriptor - also for scalars and + explicit-size/assumed-size arrays. */ + if (!gfc_notify_std (GFC_STD_F2018, + "Assumed-length character dummy argument " + "%qs at %L of procedure %qs with BIND(C) " + "attribute", sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + retval = false; + } + else if (cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (cl->length->value.integer, 1) != 0) + { + /* F2018, 18.3.6, (5), item 4. */ + if (!sym->attr.dimension + || sym->as->type == AS_ASSUMED_SIZE + || sym->as->type == AS_EXPLICIT) + { + gfc_error ("Character dummy argument %qs at %L must be " + "of constant length of one or assumed length, " + "unless it has assumed shape or assumed rank, " + "as procedure %qs has the BIND(C) attribute", + sym->name, &sym->declared_at, + sym->ns->proc_name->name); + retval = false; + } + /* else: valid only since F2018 - and an assumed-shape/rank + array; however, gfc_notify_std is already called when + those array types are used. Thus, silently accept F200x. */ + } + } + + /* We have to make sure that any param to a bind(c) routine does + not have the allocatable, pointer, or optional attributes, + according to J3/04-007, section 5.1. */ + if (sym->attr.allocatable == 1 + && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with " + "ALLOCATABLE attribute in procedure %qs " + "with BIND(C)", sym->name, + &(sym->declared_at), + sym->ns->proc_name->name)) + retval = false; + + if (sym->attr.pointer == 1 + && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with " + "POINTER attribute in procedure %qs " + "with BIND(C)", sym->name, + &(sym->declared_at), + sym->ns->proc_name->name)) + retval = false; + + if (sym->attr.optional == 1 && sym->attr.value) + { + gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " + "and the VALUE attribute because procedure %qs " + "is BIND(C)", sym->name, &(sym->declared_at), + sym->ns->proc_name->name); + retval = false; + } + else if (sym->attr.optional == 1 + && !gfc_notify_std (GFC_STD_F2018, "Variable %qs " + "at %L with OPTIONAL attribute in " + "procedure %qs which is BIND(C)", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name)) + retval = false; + + /* Make sure that if it has the dimension attribute, that it is + either assumed size or explicit shape. Deferred shape is already + covered by the pointer/allocatable attribute. */ + if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE + && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs " + "at %L as dummy argument to the BIND(C) " + "procedure %qs at %L", sym->name, + &(sym->declared_at), + sym->ns->proc_name->name, + &(sym->ns->proc_name->declared_at))) + retval = false; + } + } + + return retval; +} + + + +/* Function called by variable_decl() that adds a name to the symbol table. */ + +static bool +build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, + gfc_array_spec **as, locus *var_locus) +{ + symbol_attribute attr; + gfc_symbol *sym; + int upper; + gfc_symtree *st; + + /* Symbols in a submodule are host associated from the parent module or + submodules. Therefore, they can be overridden by declarations in the + submodule scope. Deal with this by attaching the existing symbol to + a new symtree and recycling the old symtree with a new symbol... */ + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE + && st->n.sym != NULL + && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule) + { + gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); + s->n.sym = st->n.sym; + sym = gfc_new_symbol (name, gfc_current_ns); + + + st->n.sym = sym; + sym->refs++; + gfc_set_sym_referenced (sym); + } + /* ...Otherwise generate a new symtree and new symbol. */ + else if (gfc_get_symbol (name, NULL, &sym)) + return false; + + /* Check if the name has already been defined as a type. The + first letter of the symtree will be in upper case then. Of + course, this is only necessary if the upper case letter is + actually different. */ + + upper = TOUPPER(name[0]); + if (upper != name[0]) + { + char u_name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree *st; + + gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN); + strcpy (u_name, name); + u_name[0] = upper; + + st = gfc_find_symtree (gfc_current_ns->sym_root, u_name); + + /* STRUCTURE types can alias symbol names */ + if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT) + { + gfc_error ("Symbol %qs at %C also declared as a type at %L", name, + &st->n.sym->declared_at); + return false; + } + } + + /* Start updating the symbol table. Add basic type attribute if present. */ + if (current_ts.type != BT_UNKNOWN + && (sym->attr.implicit_type == 0 + || !gfc_compare_types (&sym->ts, ¤t_ts)) + && !gfc_add_type (sym, ¤t_ts, var_locus)) + return false; + + if (sym->ts.type == BT_CHARACTER) + { + sym->ts.u.cl = cl; + sym->ts.deferred = cl_deferred; + } + + /* Add dimension attribute if present. */ + if (!gfc_set_array_spec (sym, *as, var_locus)) + return false; + *as = NULL; + + /* Add attribute to symbol. The copy is so that we can reset the + dimension attribute. */ + attr = current_attr; + attr.dimension = 0; + attr.codimension = 0; + + if (!gfc_copy_attr (&sym->attr, &attr, var_locus)) + return false; + + /* Finish any work that may need to be done for the binding label, + if it's a bind(c). The bind(c) attr is found before the symbol + is made, and before the symbol name (for data decls), so the + current_ts is holding the binding label, or nothing if the + name= attr wasn't given. Therefore, test here if we're dealing + with a bind(c) and make sure the binding label is set correctly. */ + if (sym->attr.is_bind_c == 1) + { + if (!sym->binding_label) + { + /* Set the binding label and verify that if a NAME= was specified + then only one identifier was in the entity-decl-list. */ + if (!set_binding_label (&sym->binding_label, sym->name, + num_idents_on_line)) + return false; + } + } + + /* See if we know we're in a common block, and if it's a bind(c) + common then we need to make sure we're an interoperable type. */ + if (sym->attr.in_common == 1) + { + /* Test the common block object. */ + if (sym->common_block != NULL && sym->common_block->is_bind_c == 1 + && sym->ts.is_c_interop != 1) + { + gfc_error_now ("Variable %qs in common block %qs at %C " + "must be declared with a C interoperable " + "kind since common block %qs is BIND(C)", + sym->name, sym->common_block->name, + sym->common_block->name); + gfc_clear_error (); + } + } + + sym->attr.implied_index = 0; + + /* Use the parameter expressions for a parameterized derived type. */ + if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + && sym->ts.u.derived->attr.pdt_type && type_param_spec_list) + sym->param_list = gfc_copy_actual_arglist (type_param_spec_list); + + if (sym->ts.type == BT_CLASS) + return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); + + return true; +} + + +/* Set character constant to the given length. The constant will be padded or + truncated. If we're inside an array constructor without a typespec, we + additionally check that all elements have the same length; check_len -1 + means no checking. */ + +void +gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr, + gfc_charlen_t check_len) +{ + gfc_char_t *s; + gfc_charlen_t slen; + + if (expr->ts.type != BT_CHARACTER) + return; + + if (expr->expr_type != EXPR_CONSTANT) + { + gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where); + return; + } + + slen = expr->value.character.length; + if (len != slen) + { + s = gfc_get_wide_string (len + 1); + memcpy (s, expr->value.character.string, + MIN (len, slen) * sizeof (gfc_char_t)); + if (len > slen) + gfc_wide_memset (&s[slen], ' ', len - slen); + + if (warn_character_truncation && slen > len) + gfc_warning_now (OPT_Wcharacter_truncation, + "CHARACTER expression at %L is being truncated " + "(%ld/%ld)", &expr->where, + (long) slen, (long) len); + + /* Apply the standard by 'hand' otherwise it gets cleared for + initializers. */ + if (check_len != -1 && slen != check_len + && !(gfc_option.allow_std & GFC_STD_GNU)) + gfc_error_now ("The CHARACTER elements of the array constructor " + "at %L must have the same length (%ld/%ld)", + &expr->where, (long) slen, + (long) check_len); + + s[len] = '\0'; + free (expr->value.character.string); + expr->value.character.string = s; + expr->value.character.length = len; + /* If explicit representation was given, clear it + as it is no longer needed after padding. */ + if (expr->representation.length) + { + expr->representation.length = 0; + free (expr->representation.string); + expr->representation.string = NULL; + } + } +} + + +/* Function to create and update the enumerator history + using the information passed as arguments. + Pointer "max_enum" is also updated, to point to + enum history node containing largest initializer. + + SYM points to the symbol node of enumerator. + INIT points to its enumerator value. */ + +static void +create_enum_history (gfc_symbol *sym, gfc_expr *init) +{ + enumerator_history *new_enum_history; + gcc_assert (sym != NULL && init != NULL); + + new_enum_history = XCNEW (enumerator_history); + + new_enum_history->sym = sym; + new_enum_history->initializer = init; + new_enum_history->next = NULL; + + if (enum_history == NULL) + { + enum_history = new_enum_history; + max_enum = enum_history; + } + else + { + new_enum_history->next = enum_history; + enum_history = new_enum_history; + + if (mpz_cmp (max_enum->initializer->value.integer, + new_enum_history->initializer->value.integer) < 0) + max_enum = new_enum_history; + } +} + + +/* Function to free enum kind history. */ + +void +gfc_free_enum_history (void) +{ + enumerator_history *current = enum_history; + enumerator_history *next; + + while (current != NULL) + { + next = current->next; + free (current); + current = next; + } + max_enum = NULL; + enum_history = NULL; +} + + +/* Function called by variable_decl() that adds an initialization + expression to a symbol. */ + +static bool +add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) +{ + symbol_attribute attr; + gfc_symbol *sym; + gfc_expr *init; + + init = *initp; + if (find_special (name, &sym, false)) + return false; + + attr = sym->attr; + + /* If this symbol is confirming an implicit parameter type, + then an initialization expression is not allowed. */ + if (attr.flavor == FL_PARAMETER && sym->value != NULL) + { + if (*initp != NULL) + { + gfc_error ("Initializer not allowed for PARAMETER %qs at %C", + sym->name); + return false; + } + else + return true; + } + + if (init == NULL) + { + /* An initializer is required for PARAMETER declarations. */ + if (attr.flavor == FL_PARAMETER) + { + gfc_error ("PARAMETER at %L is missing an initializer", var_locus); + return false; + } + } + else + { + /* If a variable appears in a DATA block, it cannot have an + initializer. */ + if (sym->attr.data) + { + gfc_error ("Variable %qs at %C with an initializer already " + "appears in a DATA statement", sym->name); + return false; + } + + /* Check if the assignment can happen. This has to be put off + until later for derived type variables and procedure pointers. */ + if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type) + && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS + && !sym->attr.proc_pointer + && !gfc_check_assign_symbol (sym, NULL, init)) + return false; + + if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl + && init->ts.type == BT_CHARACTER) + { + /* Update symbol character length according initializer. */ + if (!gfc_check_assign_symbol (sym, NULL, init)) + return false; + + if (sym->ts.u.cl->length == NULL) + { + gfc_charlen_t clen; + /* If there are multiple CHARACTER variables declared on the + same line, we don't want them to share the same length. */ + sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + if (sym->attr.flavor == FL_PARAMETER) + { + if (init->expr_type == EXPR_CONSTANT) + { + clen = init->value.character.length; + sym->ts.u.cl->length + = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, clen); + } + else if (init->expr_type == EXPR_ARRAY) + { + if (init->ts.u.cl && init->ts.u.cl->length) + { + const gfc_expr *length = init->ts.u.cl->length; + if (length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Cannot initialize parameter array " + "at %L " + "with variable length elements", + &sym->declared_at); + return false; + } + clen = mpz_get_si (length->value.integer); + } + else if (init->value.constructor) + { + gfc_constructor *c; + c = gfc_constructor_first (init->value.constructor); + clen = c->expr->value.character.length; + } + else + gcc_unreachable (); + sym->ts.u.cl->length + = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, clen); + } + else if (init->ts.u.cl && init->ts.u.cl->length) + sym->ts.u.cl->length = + gfc_copy_expr (init->ts.u.cl->length); + } + } + /* Update initializer character length according symbol. */ + else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) + { + if (!gfc_specification_expr (sym->ts.u.cl->length)) + return false; + + int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, + false); + /* resolve_charlen will complain later on if the length + is too large. Just skeep the initialization in that case. */ + if (mpz_cmp (sym->ts.u.cl->length->value.integer, + gfc_integer_kinds[k].huge) <= 0) + { + HOST_WIDE_INT len + = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer); + + if (init->expr_type == EXPR_CONSTANT) + gfc_set_constant_character_len (len, init, -1); + else if (init->expr_type == EXPR_ARRAY) + { + gfc_constructor *c; + + /* Build a new charlen to prevent simplification from + deleting the length before it is resolved. */ + init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + init->ts.u.cl->length + = gfc_copy_expr (sym->ts.u.cl->length); + + for (c = gfc_constructor_first (init->value.constructor); + c; c = gfc_constructor_next (c)) + gfc_set_constant_character_len (len, c->expr, -1); + } + } + } + } + + if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as + && sym->as->rank && init->rank && init->rank != sym->as->rank) + { + gfc_error ("Rank mismatch of array at %L and its initializer " + "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank); + return false; + } + + /* If sym is implied-shape, set its upper bounds from init. */ + if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension + && sym->as->type == AS_IMPLIED_SHAPE) + { + int dim; + + if (init->rank == 0) + { + gfc_error ("Cannot initialize implied-shape array at %L" + " with scalar", &sym->declared_at); + return false; + } + + /* The shape may be NULL for EXPR_ARRAY, set it. */ + if (init->shape == NULL) + { + gcc_assert (init->expr_type == EXPR_ARRAY); + init->shape = gfc_get_shape (1); + if (!gfc_array_size (init, &init->shape[0])) + gfc_internal_error ("gfc_array_size failed"); + } + + for (dim = 0; dim < sym->as->rank; ++dim) + { + int k; + gfc_expr *e, *lower; + + lower = sym->as->lower[dim]; + + /* If the lower bound is an array element from another + parameterized array, then it is marked with EXPR_VARIABLE and + is an initialization expression. Try to reduce it. */ + if (lower->expr_type == EXPR_VARIABLE) + gfc_reduce_init_expr (lower); + + if (lower->expr_type == EXPR_CONSTANT) + { + /* All dimensions must be without upper bound. */ + gcc_assert (!sym->as->upper[dim]); + + k = lower->ts.kind; + e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); + mpz_add (e->value.integer, lower->value.integer, + init->shape[dim]); + mpz_sub_ui (e->value.integer, e->value.integer, 1); + sym->as->upper[dim] = e; + } + else + { + gfc_error ("Non-constant lower bound in implied-shape" + " declaration at %L", &lower->where); + return false; + } + } + + sym->as->type = AS_EXPLICIT; + } + + /* Ensure that explicit bounds are simplified. */ + if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension + && sym->as->type == AS_EXPLICIT) + { + for (int dim = 0; dim < sym->as->rank; ++dim) + { + gfc_expr *e; + + e = sym->as->lower[dim]; + if (e->expr_type != EXPR_CONSTANT) + gfc_reduce_init_expr (e); + + e = sym->as->upper[dim]; + if (e->expr_type != EXPR_CONSTANT) + gfc_reduce_init_expr (e); + } + } + + /* Need to check if the expression we initialized this + to was one of the iso_c_binding named constants. If so, + and we're a parameter (constant), let it be iso_c. + For example: + integer(c_int), parameter :: my_int = c_int + integer(my_int) :: my_int_2 + If we mark my_int as iso_c (since we can see it's value + is equal to one of the named constants), then my_int_2 + will be considered C interoperable. */ + if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type)) + { + sym->ts.is_iso_c |= init->ts.is_iso_c; + sym->ts.is_c_interop |= init->ts.is_c_interop; + /* attr bits needed for module files. */ + sym->attr.is_iso_c |= init->ts.is_iso_c; + sym->attr.is_c_interop |= init->ts.is_c_interop; + if (init->ts.is_iso_c) + sym->ts.f90_type = init->ts.f90_type; + } + + /* Add initializer. Make sure we keep the ranks sane. */ + if (sym->attr.dimension && init->rank == 0) + { + mpz_t size; + gfc_expr *array; + int n; + if (sym->attr.flavor == FL_PARAMETER + && gfc_is_constant_expr (init) + && (init->expr_type == EXPR_CONSTANT + || init->expr_type == EXPR_STRUCTURE) + && spec_size (sym->as, &size) + && mpz_cmp_si (size, 0) > 0) + { + array = gfc_get_array_expr (init->ts.type, init->ts.kind, + &init->where); + if (init->ts.type == BT_DERIVED) + array->ts.u.derived = init->ts.u.derived; + for (n = 0; n < (int)mpz_get_si (size); n++) + gfc_constructor_append_expr (&array->value.constructor, + n == 0 + ? init + : gfc_copy_expr (init), + &init->where); + + array->shape = gfc_get_shape (sym->as->rank); + for (n = 0; n < sym->as->rank; n++) + spec_dimen_size (sym->as, n, &array->shape[n]); + + init = array; + mpz_clear (size); + } + init->rank = sym->as->rank; + } + + sym->value = init; + if (sym->attr.save == SAVE_NONE) + sym->attr.save = SAVE_IMPLICIT; + *initp = NULL; + } + + return true; +} + + +/* Function called by variable_decl() that adds a name to a structure + being built. */ + +static bool +build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, + gfc_array_spec **as) +{ + gfc_state_data *s; + gfc_component *c; + + /* F03:C438/C439. If the current symbol is of the same derived type that we're + constructing, it must have the pointer attribute. */ + if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) + && current_ts.u.derived == gfc_current_block () + && current_attr.pointer == 0) + { + if (current_attr.allocatable + && !gfc_notify_std(GFC_STD_F2008, "Component at %C " + "must have the POINTER attribute")) + { + return false; + } + else if (current_attr.allocatable == 0) + { + gfc_error ("Component at %C must have the POINTER attribute"); + return false; + } + } + + /* F03:C437. */ + if (current_ts.type == BT_CLASS + && !(current_attr.pointer || current_attr.allocatable)) + { + gfc_error ("Component %qs with CLASS at %C must be allocatable " + "or pointer", name); + return false; + } + + if (gfc_current_block ()->attr.pointer && (*as)->rank != 0) + { + if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT) + { + gfc_error ("Array component of structure at %C must have explicit " + "or deferred shape"); + return false; + } + } + + /* If we are in a nested union/map definition, gfc_add_component will not + properly find repeated components because: + (i) gfc_add_component does a flat search, where components of unions + and maps are implicity chained so nested components may conflict. + (ii) Unions and maps are not linked as components of their parent + structures until after they are parsed. + For (i) we use gfc_find_component which searches recursively, and for (ii) + we search each block directly from the parse stack until we find the top + level structure. */ + + s = gfc_state_stack; + if (s->state == COMP_UNION || s->state == COMP_MAP) + { + while (s->state == COMP_UNION || gfc_comp_struct (s->state)) + { + c = gfc_find_component (s->sym, name, true, true, NULL); + if (c != NULL) + { + gfc_error_now ("Component %qs at %C already declared at %L", + name, &c->loc); + return false; + } + /* Break after we've searched the entire chain. */ + if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE) + break; + s = s->previous; + } + } + + if (!gfc_add_component (gfc_current_block(), name, &c)) + return false; + + c->ts = current_ts; + if (c->ts.type == BT_CHARACTER) + c->ts.u.cl = cl; + + if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED + && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER) + && saved_kind_expr != NULL) + c->kind_expr = gfc_copy_expr (saved_kind_expr); + + c->attr = current_attr; + + c->initializer = *init; + *init = NULL; + + c->as = *as; + if (c->as != NULL) + { + if (c->as->corank) + c->attr.codimension = 1; + if (c->as->rank) + c->attr.dimension = 1; + } + *as = NULL; + + gfc_apply_init (&c->ts, &c->attr, c->initializer); + + /* Check array components. */ + if (!c->attr.dimension) + goto scalar; + + if (c->attr.pointer) + { + if (c->as->type != AS_DEFERRED) + { + gfc_error ("Pointer array component of structure at %C must have a " + "deferred shape"); + return false; + } + } + else if (c->attr.allocatable) + { + if (c->as->type != AS_DEFERRED) + { + gfc_error ("Allocatable component of structure at %C must have a " + "deferred shape"); + return false; + } + } + else + { + if (c->as->type != AS_EXPLICIT) + { + gfc_error ("Array component of structure at %C must have an " + "explicit shape"); + return false; + } + } + +scalar: + if (c->ts.type == BT_CLASS) + return gfc_build_class_symbol (&c->ts, &c->attr, &c->as); + + if (c->attr.pdt_kind || c->attr.pdt_len) + { + gfc_symbol *sym; + gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived, + 0, &sym); + if (sym == NULL) + { + gfc_error ("Type parameter %qs at %C has no corresponding entry " + "in the type parameter name list at %L", + c->name, &gfc_current_block ()->declared_at); + return false; + } + sym->ts = c->ts; + sym->attr.pdt_kind = c->attr.pdt_kind; + sym->attr.pdt_len = c->attr.pdt_len; + if (c->initializer) + sym->value = gfc_copy_expr (c->initializer); + sym->attr.flavor = FL_VARIABLE; + } + + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && c->ts.u.derived && c->ts.u.derived->attr.pdt_template + && decl_type_param_list) + c->param_list = gfc_copy_actual_arglist (decl_type_param_list); + + return true; +} + + +/* Match a 'NULL()', and possibly take care of some side effects. */ + +match +gfc_match_null (gfc_expr **result) +{ + gfc_symbol *sym; + match m, m2 = MATCH_NO; + + if ((m = gfc_match (" null ( )")) == MATCH_ERROR) + return MATCH_ERROR; + + if (m == MATCH_NO) + { + locus old_loc; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + if ((m2 = gfc_match (" null (")) != MATCH_YES) + return m2; + + old_loc = gfc_current_locus; + if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR) + return MATCH_ERROR; + if (m2 != MATCH_YES + && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR)) + return MATCH_ERROR; + if (m2 == MATCH_NO) + { + gfc_current_locus = old_loc; + return MATCH_NO; + } + } + + /* The NULL symbol now has to be/become an intrinsic function. */ + if (gfc_get_symbol ("null", NULL, &sym)) + { + gfc_error ("NULL() initialization at %C is ambiguous"); + return MATCH_ERROR; + } + + gfc_intrinsic_symbol (sym); + + if (sym->attr.proc != PROC_INTRINSIC + && !(sym->attr.use_assoc && sym->attr.intrinsic) + && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL) + || !gfc_add_function (&sym->attr, sym->name, NULL))) + return MATCH_ERROR; + + *result = gfc_get_null_expr (&gfc_current_locus); + + /* Invalid per F2008, C512. */ + if (m2 == MATCH_YES) + { + gfc_error ("NULL() initialization at %C may not have MOLD"); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Match the initialization expr for a data pointer or procedure pointer. */ + +static match +match_pointer_init (gfc_expr **init, int procptr) +{ + match m; + + if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state)) + { + gfc_error ("Initialization of pointer at %C is not allowed in " + "a PURE procedure"); + return MATCH_ERROR; + } + gfc_unset_implicit_pure (gfc_current_ns->proc_name); + + /* Match NULL() initialization. */ + m = gfc_match_null (init); + if (m != MATCH_NO) + return m; + + /* Match non-NULL initialization. */ + gfc_matching_ptr_assignment = !procptr; + gfc_matching_procptr_assignment = procptr; + m = gfc_match_rvalue (init); + gfc_matching_ptr_assignment = 0; + gfc_matching_procptr_assignment = 0; + if (m == MATCH_ERROR) + return MATCH_ERROR; + else if (m == MATCH_NO) + { + gfc_error ("Error in pointer initialization at %C"); + return MATCH_ERROR; + } + + if (!procptr && !gfc_resolve_expr (*init)) + return MATCH_ERROR; + + if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer " + "initialization at %C")) + return MATCH_ERROR; + + return MATCH_YES; +} + + +static bool +check_function_name (char *name) +{ + /* In functions that have a RESULT variable defined, the function name always + refers to function calls. Therefore, the name is not allowed to appear in + specification statements. When checking this, be careful about + 'hidden' procedure pointer results ('ppr@'). */ + + if (gfc_current_state () == COMP_FUNCTION) + { + gfc_symbol *block = gfc_current_block (); + if (block && block->result && block->result != block + && strcmp (block->result->name, "ppr@") != 0 + && strcmp (block->name, name) == 0) + { + gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C " + "from appearing in a specification statement", + block->result->name, &block->result->declared_at, name); + return false; + } + } + + return true; +} + + +/* Match a variable name with an optional initializer. When this + subroutine is called, a variable is expected to be parsed next. + Depending on what is happening at the moment, updates either the + symbol table or the current interface. */ + +static match +variable_decl (int elem) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + static unsigned int fill_id = 0; + gfc_expr *initializer, *char_len; + gfc_array_spec *as; + gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ + gfc_charlen *cl; + bool cl_deferred; + locus var_locus; + match m; + bool t; + gfc_symbol *sym; + char c; + + initializer = NULL; + as = NULL; + cp_as = NULL; + + /* When we get here, we've just matched a list of attributes and + maybe a type and a double colon. The next thing we expect to see + is the name of the symbol. */ + + /* If we are parsing a structure with legacy support, we allow the symbol + name to be '%FILL' which gives it an anonymous (inaccessible) name. */ + m = MATCH_NO; + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c == '%') + { + gfc_next_ascii_char (); /* Burn % character. */ + m = gfc_match ("fill"); + if (m == MATCH_YES) + { + if (gfc_current_state () != COMP_STRUCTURE) + { + if (flag_dec_structure) + gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL"); + else + gfc_error ("%qs at %C is a DEC extension, enable with " + "%<-fdec-structure%>", "%FILL"); + m = MATCH_ERROR; + goto cleanup; + } + + if (attr_seen) + { + gfc_error ("%qs entity cannot have attributes at %C", "%FILL"); + m = MATCH_ERROR; + goto cleanup; + } + + /* %FILL components are given invalid fortran names. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++); + } + else + { + gfc_error ("Invalid character %qc in variable name at %C", c); + return MATCH_ERROR; + } + } + else + { + m = gfc_match_name (name); + if (m != MATCH_YES) + goto cleanup; + } + + var_locus = gfc_current_locus; + + /* Now we could see the optional array spec. or character length. */ + m = gfc_match_array_spec (&as, true, true); + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_NO) + as = gfc_copy_array_spec (current_as); + else if (current_as + && !merge_array_spec (current_as, as, true)) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (flag_cray_pointer) + cp_as = gfc_copy_array_spec (as); + + /* At this point, we know for sure if the symbol is PARAMETER and can thus + determine (and check) whether it can be implied-shape. If it + was parsed as assumed-size, change it because PARAMETERs cannot + be assumed-size. + + An explicit-shape-array cannot appear under several conditions. + That check is done here as well. */ + if (as) + { + if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) + { + m = MATCH_ERROR; + gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape", + name, &var_locus); + goto cleanup; + } + + if (as->type == AS_ASSUMED_SIZE && as->rank == 1 + && current_attr.flavor == FL_PARAMETER) + as->type = AS_IMPLIED_SHAPE; + + if (as->type == AS_IMPLIED_SHAPE + && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L", + &var_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + + gfc_seen_div0 = false; + + /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not + constant expressions shall appear only in a subprogram, derived + type definition, BLOCK construct, or interface body. */ + if (as->type == AS_EXPLICIT + && gfc_current_state () != COMP_BLOCK + && gfc_current_state () != COMP_DERIVED + && gfc_current_state () != COMP_FUNCTION + && gfc_current_state () != COMP_INTERFACE + && gfc_current_state () != COMP_SUBROUTINE) + { + gfc_expr *e; + bool not_constant = false; + + for (int i = 0; i < as->rank; i++) + { + e = gfc_copy_expr (as->lower[i]); + if (!gfc_resolve_expr (e) && gfc_seen_div0) + { + m = MATCH_ERROR; + goto cleanup; + } + + gfc_simplify_expr (e, 0); + if (e && (e->expr_type != EXPR_CONSTANT)) + { + not_constant = true; + break; + } + gfc_free_expr (e); + + e = gfc_copy_expr (as->upper[i]); + if (!gfc_resolve_expr (e) && gfc_seen_div0) + { + m = MATCH_ERROR; + goto cleanup; + } + + gfc_simplify_expr (e, 0); + if (e && (e->expr_type != EXPR_CONSTANT)) + { + not_constant = true; + break; + } + gfc_free_expr (e); + } + + if (not_constant && e->ts.type != BT_INTEGER) + { + gfc_error ("Explicit array shape at %C must be constant of " + "INTEGER type and not %s type", + gfc_basic_typename (e->ts.type)); + m = MATCH_ERROR; + goto cleanup; + } + if (not_constant) + { + gfc_error ("Explicit shaped array with nonconstant bounds at %C"); + m = MATCH_ERROR; + goto cleanup; + } + } + if (as->type == AS_EXPLICIT) + { + for (int i = 0; i < as->rank; i++) + { + gfc_expr *e, *n; + e = as->lower[i]; + if (e->expr_type != EXPR_CONSTANT) + { + n = gfc_copy_expr (e); + if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (n->expr_type == EXPR_CONSTANT) + gfc_replace_expr (e, n); + else + gfc_free_expr (n); + } + e = as->upper[i]; + if (e->expr_type != EXPR_CONSTANT) + { + n = gfc_copy_expr (e); + if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (n->expr_type == EXPR_CONSTANT) + gfc_replace_expr (e, n); + else + gfc_free_expr (n); + } + } + } + } + + char_len = NULL; + cl = NULL; + cl_deferred = false; + + if (current_ts.type == BT_CHARACTER) + { + switch (match_char_length (&char_len, &cl_deferred, false)) + { + case MATCH_YES: + cl = gfc_new_charlen (gfc_current_ns, NULL); + + cl->length = char_len; + break; + + /* Non-constant lengths need to be copied after the first + element. Also copy assumed lengths. */ + case MATCH_NO: + if (elem > 1 + && (current_ts.u.cl->length == NULL + || current_ts.u.cl->length->expr_type != EXPR_CONSTANT)) + { + cl = gfc_new_charlen (gfc_current_ns, NULL); + cl->length = gfc_copy_expr (current_ts.u.cl->length); + } + else + cl = current_ts.u.cl; + + cl_deferred = current_ts.deferred; + + break; + + case MATCH_ERROR: + goto cleanup; + } + } + + /* The dummy arguments and result of the abreviated form of MODULE + PROCEDUREs, used in SUBMODULES should not be redefined. */ + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->abr_modproc_decl) + { + gfc_find_symbol (name, gfc_current_ns, 1, &sym); + if (sym != NULL && (sym->attr.dummy || sym->attr.result)) + { + m = MATCH_ERROR; + gfc_error ("%qs at %C is a redefinition of the declaration " + "in the corresponding interface for MODULE " + "PROCEDURE %qs", sym->name, + gfc_current_ns->proc_name->name); + goto cleanup; + } + } + + /* %FILL components may not have initializers. */ + if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES) + { + gfc_error ("%qs entity cannot have an initializer at %C", "%FILL"); + m = MATCH_ERROR; + goto cleanup; + } + + /* If this symbol has already shown up in a Cray Pointer declaration, + and this is not a component declaration, + then we want to set the type & bail out. */ + if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ())) + { + gfc_find_symbol (name, gfc_current_ns, 0, &sym); + if (sym != NULL && sym->attr.cray_pointee) + { + m = MATCH_YES; + if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + + /* Check to see if we have an array specification. */ + if (cp_as != NULL) + { + if (sym->as != NULL) + { + gfc_error ("Duplicate array spec for Cray pointee at %C"); + gfc_free_array_spec (cp_as); + m = MATCH_ERROR; + goto cleanup; + } + else + { + if (!gfc_set_array_spec (sym, cp_as, &var_locus)) + gfc_internal_error ("Cannot set pointee array spec."); + + /* Fix the array spec. */ + m = gfc_mod_pointee_as (sym->as); + if (m == MATCH_ERROR) + goto cleanup; + } + } + goto cleanup; + } + else + { + gfc_free_array_spec (cp_as); + } + } + + /* Procedure pointer as function result. */ + if (gfc_current_state () == COMP_FUNCTION + && strcmp ("ppr@", gfc_current_block ()->name) == 0 + && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0) + strcpy (name, "ppr@"); + + if (gfc_current_state () == COMP_FUNCTION + && strcmp (name, gfc_current_block ()->name) == 0 + && gfc_current_block ()->result + && strcmp ("ppr@", gfc_current_block ()->result->name) == 0) + strcpy (name, "ppr@"); + + /* OK, we've successfully matched the declaration. Now put the + symbol in the current namespace, because it might be used in the + optional initialization expression for this symbol, e.g. this is + perfectly legal: + + integer, parameter :: i = huge(i) + + This is only true for parameters or variables of a basic type. + For components of derived types, it is not true, so we don't + create a symbol for those yet. If we fail to create the symbol, + bail out. */ + if (!gfc_comp_struct (gfc_current_state ()) + && !build_sym (name, cl, cl_deferred, &as, &var_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (!check_function_name (name)) + { + m = MATCH_ERROR; + goto cleanup; + } + + /* We allow old-style initializations of the form + integer i /2/, j(4) /3*3, 1/ + (if no colon has been seen). These are different from data + statements in that initializers are only allowed to apply to the + variable immediately preceding, i.e. + integer i, j /1, 2/ + is not allowed. Therefore we have to do some work manually, that + could otherwise be left to the matchers for DATA statements. */ + + if (!colon_seen && gfc_match (" /") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_GNU, "Old-style " + "initialization at %C")) + return MATCH_ERROR; + + /* Allow old style initializations for components of STRUCTUREs and MAPs + but not components of derived types. */ + else if (gfc_current_state () == COMP_DERIVED) + { + gfc_error ("Invalid old style initialization for derived type " + "component at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + /* For structure components, read the initializer as a special + expression and let the rest of this function apply the initializer + as usual. */ + else if (gfc_comp_struct (gfc_current_state ())) + { + m = match_clist_expr (&initializer, ¤t_ts, as); + if (m == MATCH_NO) + gfc_error ("Syntax error in old style initialization of %s at %C", + name); + if (m != MATCH_YES) + goto cleanup; + } + + /* Otherwise we treat the old style initialization just like a + DATA declaration for the current variable. */ + else + return match_old_style_init (name); + } + + /* The double colon must be present in order to have initializers. + Otherwise the statement is ambiguous with an assignment statement. */ + if (colon_seen) + { + if (gfc_match (" =>") == MATCH_YES) + { + if (!current_attr.pointer) + { + gfc_error ("Initialization at %C isn't for a pointer variable"); + m = MATCH_ERROR; + goto cleanup; + } + + m = match_pointer_init (&initializer, 0); + if (m != MATCH_YES) + goto cleanup; + + /* The target of a pointer initialization must have the SAVE + attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope + is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */ + if (initializer->expr_type == EXPR_VARIABLE + && initializer->symtree->n.sym->attr.save == SAVE_NONE + && (gfc_current_state () == COMP_PROGRAM + || gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE)) + initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT; + } + else if (gfc_match_char ('=') == MATCH_YES) + { + if (current_attr.pointer) + { + gfc_error ("Pointer initialization at %C requires %<=>%>, " + "not %<=%>"); + m = MATCH_ERROR; + goto cleanup; + } + + m = gfc_match_init_expr (&initializer); + if (m == MATCH_NO) + { + gfc_error ("Expected an initialization expression at %C"); + m = MATCH_ERROR; + } + + if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL) + && !gfc_comp_struct (gfc_state_stack->state)) + { + gfc_error ("Initialization of variable at %C is not allowed in " + "a PURE procedure"); + m = MATCH_ERROR; + } + + if (current_attr.flavor != FL_PARAMETER + && !gfc_comp_struct (gfc_state_stack->state)) + gfc_unset_implicit_pure (gfc_current_ns->proc_name); + + if (m != MATCH_YES) + goto cleanup; + } + } + + if (initializer != NULL && current_attr.allocatable + && gfc_comp_struct (gfc_current_state ())) + { + gfc_error ("Initialization of allocatable component at %C is not " + "allowed"); + m = MATCH_ERROR; + goto cleanup; + } + + if (gfc_current_state () == COMP_DERIVED + && initializer && initializer->ts.type == BT_HOLLERITH) + { + gfc_error ("Initialization of structure component with a HOLLERITH " + "constant at %L is not allowed", &initializer->where); + m = MATCH_ERROR; + goto cleanup; + } + + if (gfc_current_state () == COMP_DERIVED + && gfc_current_block ()->attr.pdt_template) + { + gfc_symbol *param; + gfc_find_symbol (name, gfc_current_block ()->f2k_derived, + 0, ¶m); + if (!param && (current_attr.pdt_kind || current_attr.pdt_len)) + { + gfc_error ("The component with KIND or LEN attribute at %C does not " + "not appear in the type parameter list at %L", + &gfc_current_block ()->declared_at); + m = MATCH_ERROR; + goto cleanup; + } + else if (param && !(current_attr.pdt_kind || current_attr.pdt_len)) + { + gfc_error ("The component at %C that appears in the type parameter " + "list at %L has neither the KIND nor LEN attribute", + &gfc_current_block ()->declared_at); + m = MATCH_ERROR; + goto cleanup; + } + else if (as && (current_attr.pdt_kind || current_attr.pdt_len)) + { + gfc_error ("The component at %C which is a type parameter must be " + "a scalar"); + m = MATCH_ERROR; + goto cleanup; + } + else if (param && initializer) + { + if (initializer->ts.type == BT_BOZ) + { + gfc_error ("BOZ literal constant at %L cannot appear as an " + "initializer", &initializer->where); + m = MATCH_ERROR; + goto cleanup; + } + param->value = gfc_copy_expr (initializer); + } + } + + /* Before adding a possible initilizer, do a simple check for compatibility + of lhs and rhs types. Assigning a REAL value to a derived type is not a + good thing. */ + if (current_ts.type == BT_DERIVED && initializer + && (gfc_numeric_ts (&initializer->ts) + || initializer->ts.type == BT_LOGICAL + || initializer->ts.type == BT_CHARACTER)) + { + gfc_error ("Incompatible initialization between a derived type " + "entity and an entity with %qs type at %C", + gfc_typename (initializer)); + m = MATCH_ERROR; + goto cleanup; + } + + + /* Add the initializer. Note that it is fine if initializer is + NULL here, because we sometimes also need to check if a + declaration *must* have an initialization expression. */ + if (!gfc_comp_struct (gfc_current_state ())) + t = add_init_expr_to_sym (name, &initializer, &var_locus); + else + { + if (current_ts.type == BT_DERIVED + && !current_attr.pointer && !initializer) + initializer = gfc_default_initializer (¤t_ts); + t = build_struct (name, cl, &initializer, &as); + + /* If we match a nested structure definition we expect to see the + * body even if the variable declarations blow up, so we need to keep + * the structure declaration around. */ + if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT) + gfc_commit_symbol (gfc_new_block); + } + + m = (t) ? MATCH_YES : MATCH_ERROR; + +cleanup: + /* Free stuff up and return. */ + gfc_seen_div0 = false; + gfc_free_expr (initializer); + gfc_free_array_spec (as); + + return m; +} + + +/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification. + This assumes that the byte size is equal to the kind number for + non-COMPLEX types, and equal to twice the kind number for COMPLEX. */ + +static match +gfc_match_old_kind_spec (gfc_typespec *ts) +{ + match m; + int original_kind; + + if (gfc_match_char ('*') != MATCH_YES) + return MATCH_NO; + + m = gfc_match_small_literal_int (&ts->kind, NULL); + if (m != MATCH_YES) + return MATCH_ERROR; + + original_kind = ts->kind; + + /* Massage the kind numbers for complex types. */ + if (ts->type == BT_COMPLEX) + { + if (ts->kind % 2) + { + gfc_error ("Old-style type declaration %s*%d not supported at %C", + gfc_basic_typename (ts->type), original_kind); + return MATCH_ERROR; + } + ts->kind /= 2; + + } + + if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) + ts->kind = 8; + + if (ts->type == BT_REAL || ts->type == BT_COMPLEX) + { + if (ts->kind == 4) + { + if (flag_real4_kind == 8) + ts->kind = 8; + if (flag_real4_kind == 10) + ts->kind = 10; + if (flag_real4_kind == 16) + ts->kind = 16; + } + else if (ts->kind == 8) + { + if (flag_real8_kind == 4) + ts->kind = 4; + if (flag_real8_kind == 10) + ts->kind = 10; + if (flag_real8_kind == 16) + ts->kind = 16; + } + } + + if (gfc_validate_kind (ts->type, ts->kind, true) < 0) + { + gfc_error ("Old-style type declaration %s*%d not supported at %C", + gfc_basic_typename (ts->type), original_kind); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_GNU, + "Nonstandard type declaration %s*%d at %C", + gfc_basic_typename(ts->type), original_kind)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Match a kind specification. Since kinds are generally optional, we + usually return MATCH_NO if something goes wrong. If a "kind=" + string is found, then we know we have an error. */ + +match +gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) +{ + locus where, loc; + gfc_expr *e; + match m, n; + char c; + + m = MATCH_NO; + n = MATCH_YES; + e = NULL; + saved_kind_expr = NULL; + + where = loc = gfc_current_locus; + + if (kind_expr_only) + goto kind_expr; + + if (gfc_match_char ('(') == MATCH_NO) + return MATCH_NO; + + /* Also gobbles optional text. */ + if (gfc_match (" kind = ") == MATCH_YES) + m = MATCH_ERROR; + + loc = gfc_current_locus; + +kind_expr: + + n = gfc_match_init_expr (&e); + + if (gfc_derived_parameter_expr (e)) + { + ts->kind = 0; + saved_kind_expr = gfc_copy_expr (e); + goto close_brackets; + } + + if (n != MATCH_YES) + { + if (gfc_matching_function) + { + /* The function kind expression might include use associated or + imported parameters and try again after the specification + expressions..... */ + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Missing right parenthesis at %C"); + m = MATCH_ERROR; + goto no_match; + } + + gfc_free_expr (e); + gfc_undo_symbols (); + return MATCH_YES; + } + else + { + /* ....or else, the match is real. */ + if (n == MATCH_NO) + gfc_error ("Expected initialization expression at %C"); + if (n != MATCH_YES) + return MATCH_ERROR; + } + } + + if (e->rank != 0) + { + gfc_error ("Expected scalar initialization expression at %C"); + m = MATCH_ERROR; + goto no_match; + } + + if (gfc_extract_int (e, &ts->kind, 1)) + { + m = MATCH_ERROR; + goto no_match; + } + + /* Before throwing away the expression, let's see if we had a + C interoperable kind (and store the fact). */ + if (e->ts.is_c_interop == 1) + { + /* Mark this as C interoperable if being declared with one + of the named constants from iso_c_binding. */ + ts->is_c_interop = e->ts.is_iso_c; + ts->f90_type = e->ts.f90_type; + if (e->symtree) + ts->interop_kind = e->symtree->n.sym; + } + + gfc_free_expr (e); + e = NULL; + + /* Ignore errors to this point, if we've gotten here. This means + we ignore the m=MATCH_ERROR from above. */ + if (gfc_validate_kind (ts->type, ts->kind, true) < 0) + { + gfc_error ("Kind %d not supported for type %s at %C", ts->kind, + gfc_basic_typename (ts->type)); + gfc_current_locus = where; + return MATCH_ERROR; + } + + /* Warn if, e.g., c_int is used for a REAL variable, but not + if, e.g., c_double is used for COMPLEX as the standard + explicitly says that the kind type parameter for complex and real + variable is the same, i.e. c_float == c_float_complex. */ + if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type + && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX) + || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL))) + gfc_warning_now (0, "C kind type parameter is for type %s but type at %L " + "is %s", gfc_basic_typename (ts->f90_type), &where, + gfc_basic_typename (ts->type)); + +close_brackets: + + gfc_gobble_whitespace (); + if ((c = gfc_next_ascii_char ()) != ')' + && (ts->type != BT_CHARACTER || c != ',')) + { + if (ts->type == BT_CHARACTER) + gfc_error ("Missing right parenthesis or comma at %C"); + else + gfc_error ("Missing right parenthesis at %C"); + m = MATCH_ERROR; + } + else + /* All tests passed. */ + m = MATCH_YES; + + if(m == MATCH_ERROR) + gfc_current_locus = where; + + if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) + ts->kind = 8; + + if (ts->type == BT_REAL || ts->type == BT_COMPLEX) + { + if (ts->kind == 4) + { + if (flag_real4_kind == 8) + ts->kind = 8; + if (flag_real4_kind == 10) + ts->kind = 10; + if (flag_real4_kind == 16) + ts->kind = 16; + } + else if (ts->kind == 8) + { + if (flag_real8_kind == 4) + ts->kind = 4; + if (flag_real8_kind == 10) + ts->kind = 10; + if (flag_real8_kind == 16) + ts->kind = 16; + } + } + + /* Return what we know from the test(s). */ + return m; + +no_match: + gfc_free_expr (e); + gfc_current_locus = where; + return m; +} + + +static match +match_char_kind (int * kind, int * is_iso_c) +{ + locus where; + gfc_expr *e; + match m, n; + bool fail; + + m = MATCH_NO; + e = NULL; + where = gfc_current_locus; + + n = gfc_match_init_expr (&e); + + if (n != MATCH_YES && gfc_matching_function) + { + /* The expression might include use-associated or imported + parameters and try again after the specification + expressions. */ + gfc_free_expr (e); + gfc_undo_symbols (); + return MATCH_YES; + } + + if (n == MATCH_NO) + gfc_error ("Expected initialization expression at %C"); + if (n != MATCH_YES) + return MATCH_ERROR; + + if (e->rank != 0) + { + gfc_error ("Expected scalar initialization expression at %C"); + m = MATCH_ERROR; + goto no_match; + } + + if (gfc_derived_parameter_expr (e)) + { + saved_kind_expr = e; + *kind = 0; + return MATCH_YES; + } + + fail = gfc_extract_int (e, kind, 1); + *is_iso_c = e->ts.is_iso_c; + if (fail) + { + m = MATCH_ERROR; + goto no_match; + } + + gfc_free_expr (e); + + /* Ignore errors to this point, if we've gotten here. This means + we ignore the m=MATCH_ERROR from above. */ + if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0) + { + gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind); + m = MATCH_ERROR; + } + else + /* All tests passed. */ + m = MATCH_YES; + + if (m == MATCH_ERROR) + gfc_current_locus = where; + + /* Return what we know from the test(s). */ + return m; + +no_match: + gfc_free_expr (e); + gfc_current_locus = where; + return m; +} + + +/* Match the various kind/length specifications in a CHARACTER + declaration. We don't return MATCH_NO. */ + +match +gfc_match_char_spec (gfc_typespec *ts) +{ + int kind, seen_length, is_iso_c; + gfc_charlen *cl; + gfc_expr *len; + match m; + bool deferred; + + len = NULL; + seen_length = 0; + kind = 0; + is_iso_c = 0; + deferred = false; + + /* Try the old-style specification first. */ + old_char_selector = 0; + + m = match_char_length (&len, &deferred, true); + if (m != MATCH_NO) + { + if (m == MATCH_YES) + old_char_selector = 1; + seen_length = 1; + goto done; + } + + m = gfc_match_char ('('); + if (m != MATCH_YES) + { + m = MATCH_YES; /* Character without length is a single char. */ + goto done; + } + + /* Try the weird case: ( KIND = [ , LEN = ] ). */ + if (gfc_match (" kind =") == MATCH_YES) + { + m = match_char_kind (&kind, &is_iso_c); + + if (m == MATCH_ERROR) + goto done; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match (" , len =") == MATCH_NO) + goto rparen; + + m = char_len_param_value (&len, &deferred); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto done; + seen_length = 1; + + goto rparen; + } + + /* Try to match "LEN = " or "LEN = , KIND = ". */ + if (gfc_match (" len =") == MATCH_YES) + { + m = char_len_param_value (&len, &deferred); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto done; + seen_length = 1; + + if (gfc_match_char (')') == MATCH_YES) + goto done; + + if (gfc_match (" , kind =") != MATCH_YES) + goto syntax; + + if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR) + goto done; + + goto rparen; + } + + /* Try to match ( ) or ( , [ KIND = ] ). */ + m = char_len_param_value (&len, &deferred); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto done; + seen_length = 1; + + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + gfc_match (" kind ="); /* Gobble optional text. */ + + m = match_char_kind (&kind, &is_iso_c); + if (m == MATCH_ERROR) + goto done; + if (m == MATCH_NO) + goto syntax; + +rparen: + /* Require a right-paren at this point. */ + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + +syntax: + gfc_error ("Syntax error in CHARACTER declaration at %C"); + m = MATCH_ERROR; + gfc_free_expr (len); + return m; + +done: + /* Deal with character functions after USE and IMPORT statements. */ + if (gfc_matching_function) + { + gfc_free_expr (len); + gfc_undo_symbols (); + return MATCH_YES; + } + + if (m != MATCH_YES) + { + gfc_free_expr (len); + return m; + } + + /* Do some final massaging of the length values. */ + cl = gfc_new_charlen (gfc_current_ns, NULL); + + if (seen_length == 0) + cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); + else + { + /* If gfortran ends up here, then len may be reducible to a constant. + Try to do that here. If it does not reduce, simply assign len to + charlen. A complication occurs with user-defined generic functions, + which are not resolved. Use a private namespace to deal with + generic functions. */ + + if (len && len->expr_type != EXPR_CONSTANT) + { + gfc_namespace *old_ns; + gfc_expr *e; + + old_ns = gfc_current_ns; + gfc_current_ns = gfc_get_namespace (NULL, 0); + + e = gfc_copy_expr (len); + gfc_push_suppress_errors (); + gfc_reduce_init_expr (e); + gfc_pop_suppress_errors (); + if (e->expr_type == EXPR_CONSTANT) + { + gfc_replace_expr (len, e); + if (mpz_cmp_si (len->value.integer, 0) < 0) + mpz_set_ui (len->value.integer, 0); + } + else + gfc_free_expr (e); + + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = old_ns; + } + + cl->length = len; + } + + ts->u.cl = cl; + ts->kind = kind == 0 ? gfc_default_character_kind : kind; + ts->deferred = deferred; + + /* We have to know if it was a C interoperable kind so we can + do accurate type checking of bind(c) procs, etc. */ + if (kind != 0) + /* Mark this as C interoperable if being declared with one + of the named constants from iso_c_binding. */ + ts->is_c_interop = is_iso_c; + else if (len != NULL) + /* Here, we might have parsed something such as: character(c_char) + In this case, the parsing code above grabs the c_char when + looking for the length (line 1690, roughly). it's the last + testcase for parsing the kind params of a character variable. + However, it's not actually the length. this seems like it + could be an error. + To see if the user used a C interop kind, test the expr + of the so called length, and see if it's C interoperable. */ + ts->is_c_interop = len->ts.is_iso_c; + + return MATCH_YES; +} + + +/* Matches a RECORD declaration. */ + +static match +match_record_decl (char *name) +{ + locus old_loc; + old_loc = gfc_current_locus; + match m; + + m = gfc_match (" record /"); + if (m == MATCH_YES) + { + if (!flag_dec_structure) + { + gfc_current_locus = old_loc; + gfc_error ("RECORD at %C is an extension, enable it with " + "%<-fdec-structure%>"); + return MATCH_ERROR; + } + m = gfc_match (" %n/", name); + if (m == MATCH_YES) + return MATCH_YES; + } + + gfc_current_locus = old_loc; + if (flag_dec_structure + && (gfc_match (" record% ") == MATCH_YES + || gfc_match (" record%t") == MATCH_YES)) + gfc_error ("Structure name expected after RECORD at %C"); + if (m == MATCH_NO) + return MATCH_NO; + + return MATCH_ERROR; +} + + +/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source + of expressions to substitute into the possibly parameterized expression + 'e'. Using a list is inefficient but should not be too bad since the + number of type parameters is not likely to be large. */ +static bool +insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, + int* f) +{ + gfc_actual_arglist *param; + gfc_expr *copy; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + gcc_assert (e->symtree); + if (e->symtree->n.sym->attr.pdt_kind + || (*f != 0 && e->symtree->n.sym->attr.pdt_len)) + { + for (param = type_param_spec_list; param; param = param->next) + if (strcmp (e->symtree->n.sym->name, param->name) == 0) + break; + + if (param) + { + copy = gfc_copy_expr (param->expr); + *e = *copy; + free (copy); + } + } + + return false; +} + + +static bool +gfc_insert_kind_parameter_exprs (gfc_expr *e) +{ + return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0); +} + + +bool +gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list) +{ + gfc_actual_arglist *old_param_spec_list = type_param_spec_list; + type_param_spec_list = param_list; + bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1); + type_param_spec_list = old_param_spec_list; + return res; +} + +/* Determines the instance of a parameterized derived type to be used by + matching determining the values of the kind parameters and using them + in the name of the instance. If the instance exists, it is used, otherwise + a new derived type is created. */ +match +gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, + gfc_actual_arglist **ext_param_list) +{ + /* The PDT template symbol. */ + gfc_symbol *pdt = *sym; + /* The symbol for the parameter in the template f2k_namespace. */ + gfc_symbol *param; + /* The hoped for instance of the PDT. */ + gfc_symbol *instance; + /* The list of parameters appearing in the PDT declaration. */ + gfc_formal_arglist *type_param_name_list; + /* Used to store the parameter specification list during recursive calls. */ + gfc_actual_arglist *old_param_spec_list; + /* Pointers to the parameter specification being used. */ + gfc_actual_arglist *actual_param; + gfc_actual_arglist *tail = NULL; + /* Used to build up the name of the PDT instance. The prefix uses 4 + characters and each KIND parameter 2 more. Allow 8 of the latter. */ + char name[GFC_MAX_SYMBOL_LEN + 21]; + + bool name_seen = (param_list == NULL); + bool assumed_seen = false; + bool deferred_seen = false; + bool spec_error = false; + int kind_value, i; + gfc_expr *kind_expr; + gfc_component *c1, *c2; + match m; + + type_param_spec_list = NULL; + + type_param_name_list = pdt->formal; + actual_param = param_list; + sprintf (name, "Pdt%s", pdt->name); + + /* Run through the parameter name list and pick up the actual + parameter values or use the default values in the PDT declaration. */ + for (; type_param_name_list; + type_param_name_list = type_param_name_list->next) + { + if (actual_param && actual_param->spec_type != SPEC_EXPLICIT) + { + if (actual_param->spec_type == SPEC_ASSUMED) + spec_error = deferred_seen; + else + spec_error = assumed_seen; + + if (spec_error) + { + gfc_error ("The type parameter spec list at %C cannot contain " + "both ASSUMED and DEFERRED parameters"); + goto error_return; + } + } + + if (actual_param && actual_param->name) + name_seen = true; + param = type_param_name_list->sym; + + if (!param || !param->name) + continue; + + c1 = gfc_find_component (pdt, param->name, false, true, NULL); + /* An error should already have been thrown in resolve.c + (resolve_fl_derived0). */ + if (!pdt->attr.use_assoc && !c1) + goto error_return; + + kind_expr = NULL; + if (!name_seen) + { + if (!actual_param && !(c1 && c1->initializer)) + { + gfc_error ("The type parameter spec list at %C does not contain " + "enough parameter expressions"); + goto error_return; + } + else if (!actual_param && c1 && c1->initializer) + kind_expr = gfc_copy_expr (c1->initializer); + else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) + kind_expr = gfc_copy_expr (actual_param->expr); + } + else + { + actual_param = param_list; + for (;actual_param; actual_param = actual_param->next) + if (actual_param->name + && strcmp (actual_param->name, param->name) == 0) + break; + if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) + kind_expr = gfc_copy_expr (actual_param->expr); + else + { + if (c1->initializer) + kind_expr = gfc_copy_expr (c1->initializer); + else if (!(actual_param && param->attr.pdt_len)) + { + gfc_error ("The derived parameter %qs at %C does not " + "have a default value", param->name); + goto error_return; + } + } + } + + /* Store the current parameter expressions in a temporary actual + arglist 'list' so that they can be substituted in the corresponding + expressions in the PDT instance. */ + if (type_param_spec_list == NULL) + { + type_param_spec_list = gfc_get_actual_arglist (); + tail = type_param_spec_list; + } + else + { + tail->next = gfc_get_actual_arglist (); + tail = tail->next; + } + tail->name = param->name; + + if (kind_expr) + { + /* Try simplification even for LEN expressions. */ + bool ok; + gfc_resolve_expr (kind_expr); + ok = gfc_simplify_expr (kind_expr, 1); + /* Variable expressions seem to default to BT_PROCEDURE. + TODO find out why this is and fix it. */ + if (kind_expr->ts.type != BT_INTEGER + && kind_expr->ts.type != BT_PROCEDURE) + { + gfc_error ("The parameter expression at %C must be of " + "INTEGER type and not %s type", + gfc_basic_typename (kind_expr->ts.type)); + goto error_return; + } + if (kind_expr->ts.type == BT_INTEGER && !ok) + { + gfc_error ("The parameter expression at %C does not " + "simplify to an INTEGER constant"); + goto error_return; + } + + tail->expr = gfc_copy_expr (kind_expr); + } + + if (actual_param) + tail->spec_type = actual_param->spec_type; + + if (!param->attr.pdt_kind) + { + if (!name_seen && actual_param) + actual_param = actual_param->next; + if (kind_expr) + { + gfc_free_expr (kind_expr); + kind_expr = NULL; + } + continue; + } + + if (actual_param + && (actual_param->spec_type == SPEC_ASSUMED + || actual_param->spec_type == SPEC_DEFERRED)) + { + gfc_error ("The KIND parameter %qs at %C cannot either be " + "ASSUMED or DEFERRED", param->name); + goto error_return; + } + + if (!kind_expr || !gfc_is_constant_expr (kind_expr)) + { + gfc_error ("The value for the KIND parameter %qs at %C does not " + "reduce to a constant expression", param->name); + goto error_return; + } + + gfc_extract_int (kind_expr, &kind_value); + sprintf (name + strlen (name), "_%d", kind_value); + + if (!name_seen && actual_param) + actual_param = actual_param->next; + gfc_free_expr (kind_expr); + } + + if (!name_seen && actual_param) + { + gfc_error ("The type parameter spec list at %C contains too many " + "parameter expressions"); + goto error_return; + } + + /* Now we search for the PDT instance 'name'. If it doesn't exist, we + build it, using 'pdt' as a template. */ + if (gfc_get_symbol (name, pdt->ns, &instance)) + { + gfc_error ("Parameterized derived type at %C is ambiguous"); + goto error_return; + } + + m = MATCH_YES; + + if (instance->attr.flavor == FL_DERIVED + && instance->attr.pdt_type) + { + instance->refs++; + if (ext_param_list) + *ext_param_list = type_param_spec_list; + *sym = instance; + gfc_commit_symbols (); + return m; + } + + /* Start building the new instance of the parameterized type. */ + gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at); + instance->attr.pdt_template = 0; + instance->attr.pdt_type = 1; + instance->declared_at = gfc_current_locus; + + /* Add the components, replacing the parameters in all expressions + with the expressions for their values in 'type_param_spec_list'. */ + c1 = pdt->components; + tail = type_param_spec_list; + for (; c1; c1 = c1->next) + { + gfc_add_component (instance, c1->name, &c2); + + c2->ts = c1->ts; + c2->attr = c1->attr; + + /* The order of declaration of the type_specs might not be the + same as that of the components. */ + if (c1->attr.pdt_kind || c1->attr.pdt_len) + { + for (tail = type_param_spec_list; tail; tail = tail->next) + if (strcmp (c1->name, tail->name) == 0) + break; + } + + /* Deal with type extension by recursively calling this function + to obtain the instance of the extended type. */ + if (gfc_current_state () != COMP_DERIVED + && c1 == pdt->components + && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) + && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template + && gfc_get_derived_super_type (*sym) == c2->ts.u.derived) + { + gfc_formal_arglist *f; + + old_param_spec_list = type_param_spec_list; + + /* Obtain a spec list appropriate to the extended type..*/ + actual_param = gfc_copy_actual_arglist (type_param_spec_list); + type_param_spec_list = actual_param; + for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) + actual_param = actual_param->next; + if (actual_param) + { + gfc_free_actual_arglist (actual_param->next); + actual_param->next = NULL; + } + + /* Now obtain the PDT instance for the extended type. */ + c2->param_list = type_param_spec_list; + m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, + NULL); + type_param_spec_list = old_param_spec_list; + + c2->ts.u.derived->refs++; + gfc_set_sym_referenced (c2->ts.u.derived); + + /* Set extension level. */ + if (c2->ts.u.derived->attr.extension == 255) + { + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + gfc_error ("Maximum extension level reached with type %qs at %L", + c2->ts.u.derived->name, + &c2->ts.u.derived->declared_at); + goto error_return; + } + instance->attr.extension = c2->ts.u.derived->attr.extension + 1; + + continue; + } + + /* Set the component kind using the parameterized expression. */ + if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER) + && c1->kind_expr != NULL) + { + gfc_expr *e = gfc_copy_expr (c1->kind_expr); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + gfc_extract_int (e, &c2->ts.kind); + gfc_free_expr (e); + if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0) + { + gfc_error ("Kind %d not supported for type %s at %C", + c2->ts.kind, gfc_basic_typename (c2->ts.type)); + goto error_return; + } + } + + /* Similarly, set the string length if parameterized. */ + if (c1->ts.type == BT_CHARACTER + && c1->ts.u.cl->length + && gfc_derived_parameter_expr (c1->ts.u.cl->length)) + { + gfc_expr *e; + e = gfc_copy_expr (c1->ts.u.cl->length); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + c2->ts.u.cl->length = e; + c2->attr.pdt_string = 1; + } + + /* Set up either the KIND/LEN initializer, if constant, + or the parameterized expression. Use the template + initializer if one is not already set in this instance. */ + if (c2->attr.pdt_kind || c2->attr.pdt_len) + { + if (tail && tail->expr && gfc_is_constant_expr (tail->expr)) + c2->initializer = gfc_copy_expr (tail->expr); + else if (tail && tail->expr) + { + c2->param_list = gfc_get_actual_arglist (); + c2->param_list->name = tail->name; + c2->param_list->expr = gfc_copy_expr (tail->expr); + c2->param_list->next = NULL; + } + + if (!c2->initializer && c1->initializer) + c2->initializer = gfc_copy_expr (c1->initializer); + } + + /* Copy the array spec. */ + c2->as = gfc_copy_array_spec (c1->as); + if (c1->ts.type == BT_CLASS) + CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as); + + /* Determine if an array spec is parameterized. If so, substitute + in the parameter expressions for the bounds and set the pdt_array + attribute. Notice that this attribute must be unconditionally set + if this is an array of parameterized character length. */ + if (c1->as && c1->as->type == AS_EXPLICIT) + { + bool pdt_array = false; + + /* Are the bounds of the array parameterized? */ + for (i = 0; i < c1->as->rank; i++) + { + if (gfc_derived_parameter_expr (c1->as->lower[i])) + pdt_array = true; + if (gfc_derived_parameter_expr (c1->as->upper[i])) + pdt_array = true; + } + + /* If they are, free the expressions for the bounds and + replace them with the template expressions with substitute + values. */ + for (i = 0; pdt_array && i < c1->as->rank; i++) + { + gfc_expr *e; + e = gfc_copy_expr (c1->as->lower[i]); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + gfc_free_expr (c2->as->lower[i]); + c2->as->lower[i] = e; + e = gfc_copy_expr (c1->as->upper[i]); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + gfc_free_expr (c2->as->upper[i]); + c2->as->upper[i] = e; + } + c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string; + if (c1->initializer) + { + c2->initializer = gfc_copy_expr (c1->initializer); + gfc_insert_kind_parameter_exprs (c2->initializer); + gfc_simplify_expr (c2->initializer, 1); + } + } + + /* Recurse into this function for PDT components. */ + if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) + && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template) + { + gfc_actual_arglist *params; + /* The component in the template has a list of specification + expressions derived from its declaration. */ + params = gfc_copy_actual_arglist (c1->param_list); + actual_param = params; + /* Substitute the template parameters with the expressions + from the specification list. */ + for (;actual_param; actual_param = actual_param->next) + gfc_insert_parameter_exprs (actual_param->expr, + type_param_spec_list); + + /* Now obtain the PDT instance for the component. */ + old_param_spec_list = type_param_spec_list; + m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL); + type_param_spec_list = old_param_spec_list; + + c2->param_list = params; + if (!(c2->attr.pointer || c2->attr.allocatable)) + c2->initializer = gfc_default_initializer (&c2->ts); + + if (c2->attr.allocatable) + instance->attr.alloc_comp = 1; + } + } + + gfc_commit_symbol (instance); + if (ext_param_list) + *ext_param_list = type_param_spec_list; + *sym = instance; + return m; + +error_return: + gfc_free_actual_arglist (type_param_spec_list); + return MATCH_ERROR; +} + + +/* Match a legacy nonstandard BYTE type-spec. */ + +static match +match_byte_typespec (gfc_typespec *ts) +{ + if (gfc_match (" byte") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C")) + return MATCH_ERROR; + + if (gfc_current_form == FORM_FREE) + { + char c = gfc_peek_ascii_char (); + if (!gfc_is_whitespace (c) && c != ',') + return MATCH_NO; + } + + if (gfc_validate_kind (BT_INTEGER, 1, true) < 0) + { + gfc_error ("BYTE type used at %C " + "is not available on the target machine"); + return MATCH_ERROR; + } + + ts->type = BT_INTEGER; + ts->kind = 1; + return MATCH_YES; + } + return MATCH_NO; +} + + +/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts + structure to the matched specification. This is necessary for FUNCTION and + IMPLICIT statements. + + If implicit_flag is nonzero, then we don't check for the optional + kind specification. Not doing so is needed for matching an IMPLICIT + statement correctly. */ + +match +gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) +{ + /* Provide sufficient space to hold "pdtsymbol". */ + char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1); + gfc_symbol *sym, *dt_sym; + match m; + char c; + bool seen_deferred_kind, matched_type; + const char *dt_name; + + decl_type_param_list = NULL; + + /* A belt and braces check that the typespec is correctly being treated + as a deferred characteristic association. */ + seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION) + && (gfc_current_block ()->result->ts.kind == -1) + && (ts->kind == -1); + gfc_clear_ts (ts); + if (seen_deferred_kind) + ts->kind = -1; + + /* Clear the current binding label, in case one is given. */ + curr_binding_label = NULL; + + /* Match BYTE type-spec. */ + m = match_byte_typespec (ts); + if (m != MATCH_NO) + return m; + + m = gfc_match (" type ("); + matched_type = (m == MATCH_YES); + if (matched_type) + { + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '*') + { + if ((m = gfc_match ("* ) ")) != MATCH_YES) + return m; + if (gfc_comp_struct (gfc_current_state ())) + { + gfc_error ("Assumed type at %C is not allowed for components"); + return MATCH_ERROR; + } + if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C")) + return MATCH_ERROR; + ts->type = BT_ASSUMED; + return MATCH_YES; + } + + m = gfc_match ("%n", name); + matched_type = (m == MATCH_YES); + } + + if ((matched_type && strcmp ("integer", name) == 0) + || (!matched_type && gfc_match (" integer") == MATCH_YES)) + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + goto get_kind; + } + + if ((matched_type && strcmp ("character", name) == 0) + || (!matched_type && gfc_match (" character") == MATCH_YES)) + { + if (matched_type + && !gfc_notify_std (GFC_STD_F2008, "TYPE with " + "intrinsic-type-spec at %C")) + return MATCH_ERROR; + + ts->type = BT_CHARACTER; + if (implicit_flag == 0) + m = gfc_match_char_spec (ts); + else + m = MATCH_YES; + + if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Malformed type-spec at %C"); + return MATCH_ERROR; + } + + return m; + } + + if ((matched_type && strcmp ("real", name) == 0) + || (!matched_type && gfc_match (" real") == MATCH_YES)) + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + goto get_kind; + } + + if ((matched_type + && (strcmp ("doubleprecision", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" precision") == MATCH_YES))) + || (!matched_type && gfc_match (" double precision") == MATCH_YES)) + { + if (matched_type + && !gfc_notify_std (GFC_STD_F2008, "TYPE with " + "intrinsic-type-spec at %C")) + return MATCH_ERROR; + + if (matched_type && gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Malformed type-spec at %C"); + return MATCH_ERROR; + } + + ts->type = BT_REAL; + ts->kind = gfc_default_double_kind; + return MATCH_YES; + } + + if ((matched_type && strcmp ("complex", name) == 0) + || (!matched_type && gfc_match (" complex") == MATCH_YES)) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_complex_kind; + goto get_kind; + } + + if ((matched_type + && (strcmp ("doublecomplex", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" complex") == MATCH_YES))) + || (!matched_type && gfc_match (" double complex") == MATCH_YES)) + { + if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C")) + return MATCH_ERROR; + + if (matched_type + && !gfc_notify_std (GFC_STD_F2008, "TYPE with " + "intrinsic-type-spec at %C")) + return MATCH_ERROR; + + if (matched_type && gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Malformed type-spec at %C"); + return MATCH_ERROR; + } + + ts->type = BT_COMPLEX; + ts->kind = gfc_default_double_kind; + return MATCH_YES; + } + + if ((matched_type && strcmp ("logical", name) == 0) + || (!matched_type && gfc_match (" logical") == MATCH_YES)) + { + ts->type = BT_LOGICAL; + ts->kind = gfc_default_logical_kind; + goto get_kind; + } + + if (matched_type) + { + m = gfc_match_actual_arglist (1, &decl_type_param_list, true); + if (m == MATCH_ERROR) + return m; + + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () != ')') + { + gfc_error ("Malformed type-spec at %C"); + return MATCH_ERROR; + } + m = gfc_match_char (')'); /* Burn closing ')'. */ + } + + if (m != MATCH_YES) + m = match_record_decl (name); + + if (matched_type || m == MATCH_YES) + { + ts->type = BT_DERIVED; + /* We accept record/s/ or type(s) where s is a structure, but we + * don't need all the extra derived-type stuff for structures. */ + if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym)) + { + gfc_error ("Type name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + + if (sym && sym->attr.flavor == FL_DERIVED + && sym->attr.pdt_template + && gfc_current_state () != COMP_DERIVED) + { + m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); + if (m != MATCH_YES) + return m; + gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); + ts->u.derived = sym; + const char* lower = gfc_dt_lower_string (sym->name); + size_t len = strlen (lower); + /* Reallocate with sufficient size. */ + if (len > GFC_MAX_SYMBOL_LEN) + name = XALLOCAVEC (char, len + 1); + memcpy (name, lower, len); + name[len] = '\0'; + } + + if (sym && sym->attr.flavor == FL_STRUCT) + { + ts->u.derived = sym; + return MATCH_YES; + } + /* Actually a derived type. */ + } + + else + { + /* Match nested STRUCTURE declarations; only valid within another + structure declaration. */ + if (flag_dec_structure + && (gfc_current_state () == COMP_STRUCTURE + || gfc_current_state () == COMP_MAP)) + { + m = gfc_match (" structure"); + if (m == MATCH_YES) + { + m = gfc_match_structure_decl (); + if (m == MATCH_YES) + { + /* gfc_new_block is updated by match_structure_decl. */ + ts->type = BT_DERIVED; + ts->u.derived = gfc_new_block; + return MATCH_YES; + } + } + if (m == MATCH_ERROR) + return MATCH_ERROR; + } + + /* Match CLASS declarations. */ + m = gfc_match (" class ( * )"); + if (m == MATCH_ERROR) + return MATCH_ERROR; + else if (m == MATCH_YES) + { + gfc_symbol *upe; + gfc_symtree *st; + ts->type = BT_CLASS; + gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe); + if (upe == NULL) + { + upe = gfc_new_symbol ("STAR", gfc_current_ns); + st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR"); + st->n.sym = upe; + gfc_set_sym_referenced (upe); + upe->refs++; + upe->ts.type = BT_VOID; + upe->attr.unlimited_polymorphic = 1; + /* This is essential to force the construction of + unlimited polymorphic component class containers. */ + upe->attr.zero_comp = 1; + if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, + &gfc_current_locus)) + return MATCH_ERROR; + } + else + { + st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR"); + st->n.sym = upe; + upe->refs++; + } + ts->u.derived = upe; + return m; + } + + m = gfc_match (" class ("); + + if (m == MATCH_YES) + m = gfc_match ("%n", name); + else + return m; + + if (m != MATCH_YES) + return m; + ts->type = BT_CLASS; + + if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C")) + return MATCH_ERROR; + + m = gfc_match_actual_arglist (1, &decl_type_param_list, true); + if (m == MATCH_ERROR) + return m; + + m = gfc_match_char (')'); + if (m != MATCH_YES) + return m; + } + + /* Defer association of the derived type until the end of the + specification block. However, if the derived type can be + found, add it to the typespec. */ + if (gfc_matching_function) + { + ts->u.derived = NULL; + if (gfc_current_state () != COMP_INTERFACE + && !gfc_find_symbol (name, NULL, 1, &sym) && sym) + { + sym = gfc_find_dt_in_generic (sym); + ts->u.derived = sym; + } + return MATCH_YES; + } + + /* Search for the name but allow the components to be defined later. If + type = -1, this typespec has been seen in a function declaration but + the type could not be accessed at that point. The actual derived type is + stored in a symtree with the first letter of the name capitalized; the + symtree with the all lower-case name contains the associated + generic function. */ + dt_name = gfc_dt_upper_string (name); + sym = NULL; + dt_sym = NULL; + if (ts->kind != -1) + { + gfc_get_ha_symbol (name, &sym); + if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) + { + gfc_error ("Type name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + if (sym->generic && !dt_sym) + dt_sym = gfc_find_dt_in_generic (sym); + + /* Host associated PDTs can get confused with their constructors + because they ar instantiated in the template's namespace. */ + if (!dt_sym) + { + if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) + { + gfc_error ("Type name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + if (dt_sym && !dt_sym->attr.pdt_type) + dt_sym = NULL; + } + } + else if (ts->kind == -1) + { + int iface = gfc_state_stack->previous->state != COMP_INTERFACE + || gfc_current_ns->has_import_set; + gfc_find_symbol (name, NULL, iface, &sym); + if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) + { + gfc_error ("Type name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + if (sym && sym->generic && !dt_sym) + dt_sym = gfc_find_dt_in_generic (sym); + + ts->kind = 0; + if (sym == NULL) + return MATCH_NO; + } + + if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) + || sym->attr.subroutine) + { + gfc_error ("Type name %qs at %C conflicts with previously declared " + "entity at %L, which has the same name", name, + &sym->declared_at); + return MATCH_ERROR; + } + + if (sym && sym->attr.flavor == FL_DERIVED + && sym->attr.pdt_template + && gfc_current_state () != COMP_DERIVED) + { + m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); + if (m != MATCH_YES) + return m; + gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); + ts->u.derived = sym; + strcpy (name, gfc_dt_lower_string (sym->name)); + } + + gfc_save_symbol_data (sym); + gfc_set_sym_referenced (sym); + if (!sym->attr.generic + && !gfc_add_generic (&sym->attr, sym->name, NULL)) + return MATCH_ERROR; + + if (!sym->attr.function + && !gfc_add_function (&sym->attr, sym->name, NULL)) + return MATCH_ERROR; + + if (dt_sym && dt_sym->attr.flavor == FL_DERIVED + && dt_sym->attr.pdt_template + && gfc_current_state () != COMP_DERIVED) + { + m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL); + if (m != MATCH_YES) + return m; + gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type); + } + + if (!dt_sym) + { + gfc_interface *intr, *head; + + /* Use upper case to save the actual derived-type symbol. */ + gfc_get_symbol (dt_name, NULL, &dt_sym); + dt_sym->name = gfc_get_string ("%s", sym->name); + head = sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + sym->generic = intr; + sym->attr.if_source = IFSRC_DECL; + } + else + gfc_save_symbol_data (dt_sym); + + gfc_set_sym_referenced (dt_sym); + + if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT + && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)) + return MATCH_ERROR; + + ts->u.derived = dt_sym; + + return MATCH_YES; + +get_kind: + if (matched_type + && !gfc_notify_std (GFC_STD_F2008, "TYPE with " + "intrinsic-type-spec at %C")) + return MATCH_ERROR; + + /* For all types except double, derived and character, look for an + optional kind specifier. MATCH_NO is actually OK at this point. */ + if (implicit_flag == 1) + { + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + + return MATCH_YES; + } + + if (gfc_current_form == FORM_FREE) + { + c = gfc_peek_ascii_char (); + if (!gfc_is_whitespace (c) && c != '*' && c != '(' + && c != ':' && c != ',') + { + if (matched_type && c == ')') + { + gfc_next_ascii_char (); + return MATCH_YES; + } + gfc_error ("Malformed type-spec at %C"); + return MATCH_NO; + } + } + + m = gfc_match_kind_spec (ts, false); + if (m == MATCH_NO && ts->type != BT_CHARACTER) + { + m = gfc_match_old_kind_spec (ts); + if (gfc_validate_kind (ts->type, ts->kind, true) == -1) + return MATCH_ERROR; + } + + if (matched_type && gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Malformed type-spec at %C"); + return MATCH_ERROR; + } + + /* Defer association of the KIND expression of function results + until after USE and IMPORT statements. */ + if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) + || gfc_matching_function) + return MATCH_YES; + + if (m == MATCH_NO) + m = MATCH_YES; /* No kind specifier found. */ + + return m; +} + + +/* Match an IMPLICIT NONE statement. Actually, this statement is + already matched in parse.c, or we would not end up here in the + first place. So the only thing we need to check, is if there is + trailing garbage. If not, the match is successful. */ + +match +gfc_match_implicit_none (void) +{ + char c; + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + bool type = false; + bool external = false; + locus cur_loc = gfc_current_locus; + + if (gfc_current_ns->seen_implicit_none + || gfc_current_ns->has_implicit_none_export) + { + gfc_error ("Duplicate IMPLICIT NONE statement at %C"); + return MATCH_ERROR; + } + + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c == '(') + { + (void) gfc_next_ascii_char (); + if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C")) + return MATCH_ERROR; + + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == ')') + { + (void) gfc_next_ascii_char (); + type = true; + } + else + for(;;) + { + m = gfc_match (" %n", name); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (strcmp (name, "type") == 0) + type = true; + else if (strcmp (name, "external") == 0) + external = true; + else + return MATCH_ERROR; + + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + if (c == ',') + continue; + if (c == ')') + break; + return MATCH_ERROR; + } + } + else + type = true; + + if (gfc_match_eos () != MATCH_YES) + return MATCH_ERROR; + + gfc_set_implicit_none (type, external, &cur_loc); + + return MATCH_YES; +} + + +/* Match the letter range(s) of an IMPLICIT statement. */ + +static match +match_implicit_range (void) +{ + char c, c1, c2; + int inner; + locus cur_loc; + + cur_loc = gfc_current_locus; + + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + if (c != '(') + { + gfc_error ("Missing character range in IMPLICIT at %C"); + goto bad; + } + + inner = 1; + while (inner) + { + gfc_gobble_whitespace (); + c1 = gfc_next_ascii_char (); + if (!ISALPHA (c1)) + goto bad; + + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + + switch (c) + { + case ')': + inner = 0; /* Fall through. */ + + case ',': + c2 = c1; + break; + + case '-': + gfc_gobble_whitespace (); + c2 = gfc_next_ascii_char (); + if (!ISALPHA (c2)) + goto bad; + + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + + if ((c != ',') && (c != ')')) + goto bad; + if (c == ')') + inner = 0; + + break; + + default: + goto bad; + } + + if (c1 > c2) + { + gfc_error ("Letters must be in alphabetic order in " + "IMPLICIT statement at %C"); + goto bad; + } + + /* See if we can add the newly matched range to the pending + implicits from this IMPLICIT statement. We do not check for + conflicts with whatever earlier IMPLICIT statements may have + set. This is done when we've successfully finished matching + the current one. */ + if (!gfc_add_new_implicit_range (c1, c2)) + goto bad; + } + + return MATCH_YES; + +bad: + gfc_syntax_error (ST_IMPLICIT); + + gfc_current_locus = cur_loc; + return MATCH_ERROR; +} + + +/* Match an IMPLICIT statement, storing the types for + gfc_set_implicit() if the statement is accepted by the parser. + There is a strange looking, but legal syntactic construction + possible. It looks like: + + IMPLICIT INTEGER (a-b) (c-d) + + This is legal if "a-b" is a constant expression that happens to + equal one of the legal kinds for integers. The real problem + happens with an implicit specification that looks like: + + IMPLICIT INTEGER (a-b) + + In this case, a typespec matcher that is "greedy" (as most of the + matchers are) gobbles the character range as a kindspec, leaving + nothing left. We therefore have to go a bit more slowly in the + matching process by inhibiting the kindspec checking during + typespec matching and checking for a kind later. */ + +match +gfc_match_implicit (void) +{ + gfc_typespec ts; + locus cur_loc; + char c; + match m; + + if (gfc_current_ns->seen_implicit_none) + { + gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) " + "statement"); + return MATCH_ERROR; + } + + gfc_clear_ts (&ts); + + /* We don't allow empty implicit statements. */ + if (gfc_match_eos () == MATCH_YES) + { + gfc_error ("Empty IMPLICIT statement at %C"); + return MATCH_ERROR; + } + + do + { + /* First cleanup. */ + gfc_clear_new_implicit (); + + /* A basic type is mandatory here. */ + m = gfc_match_decl_type_spec (&ts, 1); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + + cur_loc = gfc_current_locus; + m = match_implicit_range (); + + if (m == MATCH_YES) + { + /* We may have (). */ + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c == ',' || c == '\n' || c == ';' || c == '!') + { + /* Check for CHARACTER with no length parameter. */ + if (ts.type == BT_CHARACTER && !ts.u.cl) + { + ts.kind = gfc_default_character_kind; + ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, 1); + } + + /* Record the Successful match. */ + if (!gfc_merge_new_implicit (&ts)) + return MATCH_ERROR; + if (c == ',') + c = gfc_next_ascii_char (); + else if (gfc_match_eos () == MATCH_ERROR) + goto error; + continue; + } + + gfc_current_locus = cur_loc; + } + + /* Discard the (incorrectly) matched range. */ + gfc_clear_new_implicit (); + + /* Last chance -- check (). */ + if (ts.type == BT_CHARACTER) + m = gfc_match_char_spec (&ts); + else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL) + { + m = gfc_match_kind_spec (&ts, false); + if (m == MATCH_NO) + { + m = gfc_match_old_kind_spec (&ts); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + } + } + if (m == MATCH_ERROR) + goto error; + + m = match_implicit_range (); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + if (c != ',' && gfc_match_eos () != MATCH_YES) + goto syntax; + + if (!gfc_merge_new_implicit (&ts)) + return MATCH_ERROR; + } + while (c == ','); + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_IMPLICIT); + +error: + return MATCH_ERROR; +} + + +match +gfc_match_import (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + gfc_symbol *sym; + gfc_symtree *st; + + if (gfc_current_ns->proc_name == NULL + || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY) + { + gfc_error ("IMPORT statement at %C only permitted in " + "an INTERFACE body"); + return MATCH_ERROR; + } + + if (gfc_current_ns->proc_name->attr.module_procedure) + { + gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted " + "in a module procedure interface body"); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")) + return MATCH_ERROR; + + if (gfc_match_eos () == MATCH_YES) + { + /* All host variables should be imported. */ + gfc_current_ns->has_import_set = 1; + return MATCH_YES; + } + + if (gfc_match (" ::") == MATCH_YES) + { + if (gfc_match_eos () == MATCH_YES) + { + gfc_error ("Expecting list of named entities at %C"); + return MATCH_ERROR; + } + } + + for(;;) + { + sym = NULL; + m = gfc_match (" %n", name); + switch (m) + { + case MATCH_YES: + if (gfc_current_ns->parent != NULL + && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) + { + gfc_error ("Type name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL + && gfc_find_symbol (name, + gfc_current_ns->proc_name->ns->parent, + 1, &sym)) + { + gfc_error ("Type name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + + if (sym == NULL) + { + gfc_error ("Cannot IMPORT %qs from host scoping unit " + "at %C - does not exist.", name); + return MATCH_ERROR; + } + + if (gfc_find_symtree (gfc_current_ns->sym_root, name)) + { + gfc_warning (0, "%qs is already IMPORTed from host scoping unit " + "at %C", name); + goto next_item; + } + + st = gfc_new_symtree (&gfc_current_ns->sym_root, name); + st->n.sym = sym; + sym->refs++; + sym->attr.imported = 1; + + if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) + { + /* The actual derived type is stored in a symtree with the first + letter of the name capitalized; the symtree with the all + lower-case name contains the associated generic function. */ + st = gfc_new_symtree (&gfc_current_ns->sym_root, + gfc_dt_upper_string (name)); + st->n.sym = sym; + sym->refs++; + sym->attr.imported = 1; + } + + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in IMPORT statement at %C"); + return MATCH_ERROR; +} + + +/* A minimal implementation of gfc_match without whitespace, escape + characters or variable arguments. Returns true if the next + characters match the TARGET template exactly. */ + +static bool +match_string_p (const char *target) +{ + const char *p; + + for (p = target; *p; p++) + if ((char) gfc_next_ascii_char () != *p) + return false; + return true; +} + +/* Matches an attribute specification including array specs. If + successful, leaves the variables current_attr and current_as + holding the specification. Also sets the colon_seen variable for + later use by matchers associated with initializations. + + This subroutine is a little tricky in the sense that we don't know + if we really have an attr-spec until we hit the double colon. + Until that time, we can only return MATCH_NO. This forces us to + check for duplicate specification at this level. */ + +static match +match_attr_spec (void) +{ + /* Modifiers that can exist in a type statement. */ + enum + { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN, + DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT, + DECL_DIMENSION, DECL_EXTERNAL, + DECL_INTRINSIC, DECL_OPTIONAL, + DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, + DECL_STATIC, DECL_AUTOMATIC, + DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, + DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, + DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */ + }; + +/* GFC_DECL_END is the sentinel, index starts at 0. */ +#define NUM_DECL GFC_DECL_END + + /* Make sure that values from sym_intent are safe to be used here. */ + gcc_assert (INTENT_IN > 0); + + locus start, seen_at[NUM_DECL]; + int seen[NUM_DECL]; + unsigned int d; + const char *attr; + match m; + bool t; + + gfc_clear_attr (¤t_attr); + start = gfc_current_locus; + + current_as = NULL; + colon_seen = 0; + attr_seen = 0; + + /* See if we get all of the keywords up to the final double colon. */ + for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) + seen[d] = 0; + + for (;;) + { + char ch; + + d = DECL_NONE; + gfc_gobble_whitespace (); + + ch = gfc_next_ascii_char (); + if (ch == ':') + { + /* This is the successful exit condition for the loop. */ + if (gfc_next_ascii_char () == ':') + break; + } + else if (ch == ',') + { + gfc_gobble_whitespace (); + switch (gfc_peek_ascii_char ()) + { + case 'a': + gfc_next_ascii_char (); + switch (gfc_next_ascii_char ()) + { + case 'l': + if (match_string_p ("locatable")) + { + /* Matched "allocatable". */ + d = DECL_ALLOCATABLE; + } + break; + + case 's': + if (match_string_p ("ynchronous")) + { + /* Matched "asynchronous". */ + d = DECL_ASYNCHRONOUS; + } + break; + + case 'u': + if (match_string_p ("tomatic")) + { + /* Matched "automatic". */ + d = DECL_AUTOMATIC; + } + break; + } + break; + + case 'b': + /* Try and match the bind(c). */ + m = gfc_match_bind_c (NULL, true); + if (m == MATCH_YES) + d = DECL_IS_BIND_C; + else if (m == MATCH_ERROR) + goto cleanup; + break; + + case 'c': + gfc_next_ascii_char (); + if ('o' != gfc_next_ascii_char ()) + break; + switch (gfc_next_ascii_char ()) + { + case 'd': + if (match_string_p ("imension")) + { + d = DECL_CODIMENSION; + break; + } + /* FALLTHRU */ + case 'n': + if (match_string_p ("tiguous")) + { + d = DECL_CONTIGUOUS; + break; + } + } + break; + + case 'd': + if (match_string_p ("dimension")) + d = DECL_DIMENSION; + break; + + case 'e': + if (match_string_p ("external")) + d = DECL_EXTERNAL; + break; + + case 'i': + if (match_string_p ("int")) + { + ch = gfc_next_ascii_char (); + if (ch == 'e') + { + if (match_string_p ("nt")) + { + /* Matched "intent". */ + d = match_intent_spec (); + if (d == INTENT_UNKNOWN) + { + m = MATCH_ERROR; + goto cleanup; + } + } + } + else if (ch == 'r') + { + if (match_string_p ("insic")) + { + /* Matched "intrinsic". */ + d = DECL_INTRINSIC; + } + } + } + break; + + case 'k': + if (match_string_p ("kind")) + d = DECL_KIND; + break; + + case 'l': + if (match_string_p ("len")) + d = DECL_LEN; + break; + + case 'o': + if (match_string_p ("optional")) + d = DECL_OPTIONAL; + break; + + case 'p': + gfc_next_ascii_char (); + switch (gfc_next_ascii_char ()) + { + case 'a': + if (match_string_p ("rameter")) + { + /* Matched "parameter". */ + d = DECL_PARAMETER; + } + break; + + case 'o': + if (match_string_p ("inter")) + { + /* Matched "pointer". */ + d = DECL_POINTER; + } + break; + + case 'r': + ch = gfc_next_ascii_char (); + if (ch == 'i') + { + if (match_string_p ("vate")) + { + /* Matched "private". */ + d = DECL_PRIVATE; + } + } + else if (ch == 'o') + { + if (match_string_p ("tected")) + { + /* Matched "protected". */ + d = DECL_PROTECTED; + } + } + break; + + case 'u': + if (match_string_p ("blic")) + { + /* Matched "public". */ + d = DECL_PUBLIC; + } + break; + } + break; + + case 's': + gfc_next_ascii_char (); + switch (gfc_next_ascii_char ()) + { + case 'a': + if (match_string_p ("ve")) + { + /* Matched "save". */ + d = DECL_SAVE; + } + break; + + case 't': + if (match_string_p ("atic")) + { + /* Matched "static". */ + d = DECL_STATIC; + } + break; + } + break; + + case 't': + if (match_string_p ("target")) + d = DECL_TARGET; + break; + + case 'v': + gfc_next_ascii_char (); + ch = gfc_next_ascii_char (); + if (ch == 'a') + { + if (match_string_p ("lue")) + { + /* Matched "value". */ + d = DECL_VALUE; + } + } + else if (ch == 'o') + { + if (match_string_p ("latile")) + { + /* Matched "volatile". */ + d = DECL_VOLATILE; + } + } + break; + } + } + + /* No double colon and no recognizable decl_type, so assume that + we've been looking at something else the whole time. */ + if (d == DECL_NONE) + { + m = MATCH_NO; + goto cleanup; + } + + /* Check to make sure any parens are paired up correctly. */ + if (gfc_match_parens () == MATCH_ERROR) + { + m = MATCH_ERROR; + goto cleanup; + } + + seen[d]++; + seen_at[d] = gfc_current_locus; + + if (d == DECL_DIMENSION || d == DECL_CODIMENSION) + { + gfc_array_spec *as = NULL; + + m = gfc_match_array_spec (&as, d == DECL_DIMENSION, + d == DECL_CODIMENSION); + + if (current_as == NULL) + current_as = as; + else if (m == MATCH_YES) + { + if (!merge_array_spec (as, current_as, false)) + m = MATCH_ERROR; + free (as); + } + + if (m == MATCH_NO) + { + if (d == DECL_CODIMENSION) + gfc_error ("Missing codimension specification at %C"); + else + gfc_error ("Missing dimension specification at %C"); + m = MATCH_ERROR; + } + + if (m == MATCH_ERROR) + goto cleanup; + } + } + + /* Since we've seen a double colon, we have to be looking at an + attr-spec. This means that we can now issue errors. */ + for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) + if (seen[d] > 1) + { + switch (d) + { + case DECL_ALLOCATABLE: + attr = "ALLOCATABLE"; + break; + case DECL_ASYNCHRONOUS: + attr = "ASYNCHRONOUS"; + break; + case DECL_CODIMENSION: + attr = "CODIMENSION"; + break; + case DECL_CONTIGUOUS: + attr = "CONTIGUOUS"; + break; + case DECL_DIMENSION: + attr = "DIMENSION"; + break; + case DECL_EXTERNAL: + attr = "EXTERNAL"; + break; + case DECL_IN: + attr = "INTENT (IN)"; + break; + case DECL_OUT: + attr = "INTENT (OUT)"; + break; + case DECL_INOUT: + attr = "INTENT (IN OUT)"; + break; + case DECL_INTRINSIC: + attr = "INTRINSIC"; + break; + case DECL_OPTIONAL: + attr = "OPTIONAL"; + break; + case DECL_KIND: + attr = "KIND"; + break; + case DECL_LEN: + attr = "LEN"; + break; + case DECL_PARAMETER: + attr = "PARAMETER"; + break; + case DECL_POINTER: + attr = "POINTER"; + break; + case DECL_PROTECTED: + attr = "PROTECTED"; + break; + case DECL_PRIVATE: + attr = "PRIVATE"; + break; + case DECL_PUBLIC: + attr = "PUBLIC"; + break; + case DECL_SAVE: + attr = "SAVE"; + break; + case DECL_STATIC: + attr = "STATIC"; + break; + case DECL_AUTOMATIC: + attr = "AUTOMATIC"; + break; + case DECL_TARGET: + attr = "TARGET"; + break; + case DECL_IS_BIND_C: + attr = "IS_BIND_C"; + break; + case DECL_VALUE: + attr = "VALUE"; + break; + case DECL_VOLATILE: + attr = "VOLATILE"; + break; + default: + attr = NULL; /* This shouldn't happen. */ + } + + gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + + /* Now that we've dealt with duplicate attributes, add the attributes + to the current attribute. */ + for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) + { + if (seen[d] == 0) + continue; + else + attr_seen = 1; + + if ((d == DECL_STATIC || d == DECL_AUTOMATIC) + && !flag_dec_static) + { + gfc_error ("%s at %L is a DEC extension, enable with " + "%<-fdec-static%>", + d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + /* Allow SAVE with STATIC, but don't complain. */ + if (d == DECL_STATIC && seen[DECL_SAVE]) + continue; + + if (gfc_comp_struct (gfc_current_state ()) + && d != DECL_DIMENSION && d != DECL_CODIMENSION + && d != DECL_POINTER && d != DECL_PRIVATE + && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) + { + bool is_derived = gfc_current_state () == COMP_DERIVED; + if (d == DECL_ALLOCATABLE) + { + if (!gfc_notify_std (GFC_STD_F2003, is_derived + ? G_("ALLOCATABLE attribute at %C in a " + "TYPE definition") + : G_("ALLOCATABLE attribute at %C in a " + "STRUCTURE definition"))) + { + m = MATCH_ERROR; + goto cleanup; + } + } + else if (d == DECL_KIND) + { + if (!gfc_notify_std (GFC_STD_F2003, is_derived + ? G_("KIND attribute at %C in a " + "TYPE definition") + : G_("KIND attribute at %C in a " + "STRUCTURE definition"))) + { + m = MATCH_ERROR; + goto cleanup; + } + if (current_ts.type != BT_INTEGER) + { + gfc_error ("Component with KIND attribute at %C must be " + "INTEGER"); + m = MATCH_ERROR; + goto cleanup; + } + } + else if (d == DECL_LEN) + { + if (!gfc_notify_std (GFC_STD_F2003, is_derived + ? G_("LEN attribute at %C in a " + "TYPE definition") + : G_("LEN attribute at %C in a " + "STRUCTURE definition"))) + { + m = MATCH_ERROR; + goto cleanup; + } + if (current_ts.type != BT_INTEGER) + { + gfc_error ("Component with LEN attribute at %C must be " + "INTEGER"); + m = MATCH_ERROR; + goto cleanup; + } + } + else + { + gfc_error (is_derived ? G_("Attribute at %L is not allowed in a " + "TYPE definition") + : G_("Attribute at %L is not allowed in a " + "STRUCTURE definition"), &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + } + + if ((d == DECL_PRIVATE || d == DECL_PUBLIC) + && gfc_current_state () != COMP_MODULE) + { + if (d == DECL_PRIVATE) + attr = "PRIVATE"; + else + attr = "PUBLIC"; + if (gfc_current_state () == COMP_DERIVED + && gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_MODULE) + { + if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s " + "at %L in a TYPE definition", attr, + &seen_at[d])) + { + m = MATCH_ERROR; + goto cleanup; + } + } + else + { + gfc_error ("%s attribute at %L is not allowed outside of the " + "specification part of a module", attr, &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + } + + if (gfc_current_state () != COMP_DERIVED + && (d == DECL_KIND || d == DECL_LEN)) + { + gfc_error ("Attribute at %L is not allowed outside a TYPE " + "definition", &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + + switch (d) + { + case DECL_ALLOCATABLE: + t = gfc_add_allocatable (¤t_attr, &seen_at[d]); + break; + + case DECL_ASYNCHRONOUS: + if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C")) + t = false; + else + t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_CODIMENSION: + t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_CONTIGUOUS: + if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C")) + t = false; + else + t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_DIMENSION: + t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_EXTERNAL: + t = gfc_add_external (¤t_attr, &seen_at[d]); + break; + + case DECL_IN: + t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]); + break; + + case DECL_OUT: + t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]); + break; + + case DECL_INOUT: + t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]); + break; + + case DECL_INTRINSIC: + t = gfc_add_intrinsic (¤t_attr, &seen_at[d]); + break; + + case DECL_OPTIONAL: + t = gfc_add_optional (¤t_attr, &seen_at[d]); + break; + + case DECL_KIND: + t = gfc_add_kind (¤t_attr, &seen_at[d]); + break; + + case DECL_LEN: + t = gfc_add_len (¤t_attr, &seen_at[d]); + break; + + case DECL_PARAMETER: + t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]); + break; + + case DECL_POINTER: + t = gfc_add_pointer (¤t_attr, &seen_at[d]); + break; + + case DECL_PROTECTED: + if (gfc_current_state () != COMP_MODULE + || (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor != FL_MODULE)) + { + gfc_error ("PROTECTED at %C only allowed in specification " + "part of a module"); + t = false; + break; + } + + if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C")) + t = false; + else + t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_PRIVATE: + t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, + &seen_at[d]); + break; + + case DECL_PUBLIC: + t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL, + &seen_at[d]); + break; + + case DECL_STATIC: + case DECL_SAVE: + t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); + break; + + case DECL_AUTOMATIC: + t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_TARGET: + t = gfc_add_target (¤t_attr, &seen_at[d]); + break; + + case DECL_IS_BIND_C: + t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0); + break; + + case DECL_VALUE: + if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C")) + t = false; + else + t = gfc_add_value (¤t_attr, NULL, &seen_at[d]); + break; + + case DECL_VOLATILE: + if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C")) + t = false; + else + t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]); + break; + + default: + gfc_internal_error ("match_attr_spec(): Bad attribute"); + } + + if (!t) + { + m = MATCH_ERROR; + goto cleanup; + } + } + + /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */ + if ((gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE) + && !current_attr.save + && (gfc_option.allow_std & GFC_STD_F2008) != 0) + current_attr.save = SAVE_IMPLICIT; + + colon_seen = 1; + return MATCH_YES; + +cleanup: + gfc_current_locus = start; + gfc_free_array_spec (current_as); + current_as = NULL; + attr_seen = 0; + return m; +} + + +/* Set the binding label, dest_label, either with the binding label + stored in the given gfc_typespec, ts, or if none was provided, it + will be the symbol name in all lower case, as required by the draft + (J3/04-007, section 15.4.1). If a binding label was given and + there is more than one argument (num_idents), it is an error. */ + +static bool +set_binding_label (const char **dest_label, const char *sym_name, + int num_idents) +{ + if (num_idents > 1 && has_name_equals) + { + gfc_error ("Multiple identifiers provided with " + "single NAME= specifier at %C"); + return false; + } + + if (curr_binding_label) + /* Binding label given; store in temp holder till have sym. */ + *dest_label = curr_binding_label; + else + { + /* No binding label given, and the NAME= specifier did not exist, + which means there was no NAME="". */ + if (sym_name != NULL && has_name_equals == 0) + *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name)); + } + + return true; +} + + +/* Set the status of the given common block as being BIND(C) or not, + depending on the given parameter, is_bind_c. */ + +static void +set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c) +{ + com_block->is_bind_c = is_bind_c; + return; +} + + +/* Verify that the given gfc_typespec is for a C interoperable type. */ + +bool +gfc_verify_c_interop (gfc_typespec *ts) +{ + if (ts->type == BT_DERIVED && ts->u.derived != NULL) + return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c) + ? true : false; + else if (ts->type == BT_CLASS) + return false; + else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED) + return false; + + return true; +} + + +/* Verify that the variables of a given common block, which has been + defined with the attribute specifier bind(c), to be of a C + interoperable type. Errors will be reported here, if + encountered. */ + +bool +verify_com_block_vars_c_interop (gfc_common_head *com_block) +{ + gfc_symbol *curr_sym = NULL; + bool retval = true; + + curr_sym = com_block->head; + + /* Make sure we have at least one symbol. */ + if (curr_sym == NULL) + return retval; + + /* Here we know we have a symbol, so we'll execute this loop + at least once. */ + do + { + /* The second to last param, 1, says this is in a common block. */ + retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block); + curr_sym = curr_sym->common_next; + } while (curr_sym != NULL); + + return retval; +} + + +/* Verify that a given BIND(C) symbol is C interoperable. If it is not, + an appropriate error message is reported. */ + +bool +verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, + int is_in_common, gfc_common_head *com_block) +{ + bool bind_c_function = false; + bool retval = true; + + if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c) + bind_c_function = true; + + if (tmp_sym->attr.function && tmp_sym->result != NULL) + { + tmp_sym = tmp_sym->result; + /* Make sure it wasn't an implicitly typed result. */ + if (tmp_sym->attr.implicit_type && warn_c_binding_type) + { + gfc_warning (OPT_Wc_binding_type, + "Implicitly declared BIND(C) function %qs at " + "%L may not be C interoperable", tmp_sym->name, + &tmp_sym->declared_at); + tmp_sym->ts.f90_type = tmp_sym->ts.type; + /* Mark it as C interoperable to prevent duplicate warnings. */ + tmp_sym->ts.is_c_interop = 1; + tmp_sym->attr.is_c_interop = 1; + } + } + + /* Here, we know we have the bind(c) attribute, so if we have + enough type info, then verify that it's a C interop kind. + The info could be in the symbol already, or possibly still in + the given ts (current_ts), so look in both. */ + if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) + { + if (!gfc_verify_c_interop (&(tmp_sym->ts))) + { + /* See if we're dealing with a sym in a common block or not. */ + if (is_in_common == 1 && warn_c_binding_type) + { + gfc_warning (OPT_Wc_binding_type, + "Variable %qs in common block %qs at %L " + "may not be a C interoperable " + "kind though common block %qs is BIND(C)", + tmp_sym->name, com_block->name, + &(tmp_sym->declared_at), com_block->name); + } + else + { + if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED) + gfc_error ("Type declaration %qs at %L is not C " + "interoperable but it is BIND(C)", + tmp_sym->name, &(tmp_sym->declared_at)); + else if (warn_c_binding_type) + gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L " + "may not be a C interoperable " + "kind but it is BIND(C)", + tmp_sym->name, &(tmp_sym->declared_at)); + } + } + + /* Variables declared w/in a common block can't be bind(c) + since there's no way for C to see these variables, so there's + semantically no reason for the attribute. */ + if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) + { + gfc_error ("Variable %qs in common block %qs at " + "%L cannot be declared with BIND(C) " + "since it is not a global", + tmp_sym->name, com_block->name, + &(tmp_sym->declared_at)); + retval = false; + } + + /* Scalar variables that are bind(c) cannot have the pointer + or allocatable attributes. */ + if (tmp_sym->attr.is_bind_c == 1) + { + if (tmp_sym->attr.pointer == 1) + { + gfc_error ("Variable %qs at %L cannot have both the " + "POINTER and BIND(C) attributes", + tmp_sym->name, &(tmp_sym->declared_at)); + retval = false; + } + + if (tmp_sym->attr.allocatable == 1) + { + gfc_error ("Variable %qs at %L cannot have both the " + "ALLOCATABLE and BIND(C) attributes", + tmp_sym->name, &(tmp_sym->declared_at)); + retval = false; + } + + } + + /* If it is a BIND(C) function, make sure the return value is a + scalar value. The previous tests in this function made sure + the type is interoperable. */ + if (bind_c_function && tmp_sym->as != NULL) + gfc_error ("Return type of BIND(C) function %qs at %L cannot " + "be an array", tmp_sym->name, &(tmp_sym->declared_at)); + + /* BIND(C) functions cannot return a character string. */ + if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) + if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL + || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT + || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0) + gfc_error ("Return type of BIND(C) function %qs of character " + "type at %L must have length 1", tmp_sym->name, + &(tmp_sym->declared_at)); + } + + /* See if the symbol has been marked as private. If it has, make sure + there is no binding label and warn the user if there is one. */ + if (tmp_sym->attr.access == ACCESS_PRIVATE + && tmp_sym->binding_label) + /* Use gfc_warning_now because we won't say that the symbol fails + just because of this. */ + gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been " + "given the binding label %qs", tmp_sym->name, + &(tmp_sym->declared_at), tmp_sym->binding_label); + + return retval; +} + + +/* Set the appropriate fields for a symbol that's been declared as + BIND(C) (the is_bind_c flag and the binding label), and verify that + the type is C interoperable. Errors are reported by the functions + used to set/test these fields. */ + +static bool +set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) +{ + bool retval = true; + + /* TODO: Do we need to make sure the vars aren't marked private? */ + + /* Set the is_bind_c bit in symbol_attribute. */ + gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0); + + if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents)) + return false; + + return retval; +} + + +/* Set the fields marking the given common block as BIND(C), including + a binding label, and report any errors encountered. */ + +static bool +set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) +{ + bool retval = true; + + /* destLabel, common name, typespec (which may have binding label). */ + if (!set_binding_label (&com_block->binding_label, com_block->name, + num_idents)) + return false; + + /* Set the given common block (com_block) to being bind(c) (1). */ + set_com_block_bind_c (com_block, 1); + + return retval; +} + + +/* Retrieve the list of one or more identifiers that the given bind(c) + attribute applies to. */ + +static bool +get_bind_c_idents (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + int num_idents = 0; + gfc_symbol *tmp_sym = NULL; + match found_id; + gfc_common_head *com_block = NULL; + + if (gfc_match_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + gfc_get_ha_symbol (name, &tmp_sym); + } + else if (gfc_match_common_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + com_block = gfc_get_common (name, 0); + } + else + { + gfc_error ("Need either entity or common block name for " + "attribute specification statement at %C"); + return false; + } + + /* Save the current identifier and look for more. */ + do + { + /* Increment the number of identifiers found for this spec stmt. */ + num_idents++; + + /* Make sure we have a sym or com block, and verify that it can + be bind(c). Set the appropriate field(s) and look for more + identifiers. */ + if (tmp_sym != NULL || com_block != NULL) + { + if (tmp_sym != NULL) + { + if (!set_verify_bind_c_sym (tmp_sym, num_idents)) + return false; + } + else + { + if (!set_verify_bind_c_com_block (com_block, num_idents)) + return false; + } + + /* Look to see if we have another identifier. */ + tmp_sym = NULL; + if (gfc_match_eos () == MATCH_YES) + found_id = MATCH_NO; + else if (gfc_match_char (',') != MATCH_YES) + found_id = MATCH_NO; + else if (gfc_match_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + gfc_get_ha_symbol (name, &tmp_sym); + } + else if (gfc_match_common_name (name) == MATCH_YES) + { + found_id = MATCH_YES; + com_block = gfc_get_common (name, 0); + } + else + { + gfc_error ("Missing entity or common block name for " + "attribute specification statement at %C"); + return false; + } + } + else + { + gfc_internal_error ("Missing symbol"); + } + } while (found_id == MATCH_YES); + + /* if we get here we were successful */ + return true; +} + + +/* Try and match a BIND(C) attribute specification statement. */ + +match +gfc_match_bind_c_stmt (void) +{ + match found_match = MATCH_NO; + gfc_typespec *ts; + + ts = ¤t_ts; + + /* This may not be necessary. */ + gfc_clear_ts (ts); + /* Clear the temporary binding label holder. */ + curr_binding_label = NULL; + + /* Look for the bind(c). */ + found_match = gfc_match_bind_c (NULL, true); + + if (found_match == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C")) + return MATCH_ERROR; + + /* Look for the :: now, but it is not required. */ + gfc_match (" :: "); + + /* Get the identifier(s) that needs to be updated. This may need to + change to hand the flag(s) for the attr specified so all identifiers + found can have all appropriate parts updated (assuming that the same + spec stmt can have multiple attrs, such as both bind(c) and + allocatable...). */ + if (!get_bind_c_idents ()) + /* Error message should have printed already. */ + return MATCH_ERROR; + } + + return found_match; +} + + +/* Match a data declaration statement. */ + +match +gfc_match_data_decl (void) +{ + gfc_symbol *sym; + match m; + int elem; + + type_param_spec_list = NULL; + decl_type_param_list = NULL; + + num_idents_on_line = 0; + + m = gfc_match_decl_type_spec (¤t_ts, 0); + if (m != MATCH_YES) + return m; + + if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) + && !gfc_comp_struct (gfc_current_state ())) + { + sym = gfc_use_derived (current_ts.u.derived); + + if (sym == NULL) + { + m = MATCH_ERROR; + goto cleanup; + } + + current_ts.u.derived = sym; + } + + m = match_attr_spec (); + if (m == MATCH_ERROR) + { + m = MATCH_NO; + goto cleanup; + } + + if (current_ts.type == BT_CLASS + && current_ts.u.derived->attr.unlimited_polymorphic) + goto ok; + + if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) + && current_ts.u.derived->components == NULL + && !current_ts.u.derived->attr.zero_comp) + { + + if (current_attr.pointer && gfc_comp_struct (gfc_current_state ())) + goto ok; + + if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED) + goto ok; + + gfc_find_symbol (current_ts.u.derived->name, + current_ts.u.derived->ns, 1, &sym); + + /* Any symbol that we find had better be a type definition + which has its components defined, or be a structure definition + actively being parsed. */ + if (sym != NULL && gfc_fl_struct (sym->attr.flavor) + && (current_ts.u.derived->components != NULL + || current_ts.u.derived->attr.zero_comp + || current_ts.u.derived == gfc_new_block)) + goto ok; + + gfc_error ("Derived type at %C has not been previously defined " + "and so cannot appear in a derived type definition"); + m = MATCH_ERROR; + goto cleanup; + } + +ok: + /* If we have an old-style character declaration, and no new-style + attribute specifications, then there a comma is optional between + the type specification and the variable list. */ + if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector) + gfc_match_char (','); + + /* Give the types/attributes to symbols that follow. Give the element + a number so that repeat character length expressions can be copied. */ + elem = 1; + for (;;) + { + num_idents_on_line++; + m = variable_decl (elem++); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + break; + + if (gfc_match_eos () == MATCH_YES) + goto cleanup; + if (gfc_match_char (',') != MATCH_YES) + break; + } + + if (!gfc_error_flag_test ()) + { + /* An anonymous structure declaration is unambiguous; if we matched one + according to gfc_match_structure_decl, we need to return MATCH_YES + here to avoid confusing the remaining matchers, even if there was an + error during variable_decl. We must flush any such errors. Note this + causes the parser to gracefully continue parsing the remaining input + as a structure body, which likely follows. */ + if (current_ts.type == BT_DERIVED && current_ts.u.derived + && gfc_fl_struct (current_ts.u.derived->attr.flavor)) + { + gfc_error_now ("Syntax error in anonymous structure declaration" + " at %C"); + /* Skip the bad variable_decl and line up for the start of the + structure body. */ + gfc_error_recovery (); + m = MATCH_YES; + goto cleanup; + } + + gfc_error ("Syntax error in data declaration at %C"); + } + + m = MATCH_ERROR; + + gfc_free_data_all (gfc_current_ns); + +cleanup: + if (saved_kind_expr) + gfc_free_expr (saved_kind_expr); + if (type_param_spec_list) + gfc_free_actual_arglist (type_param_spec_list); + if (decl_type_param_list) + gfc_free_actual_arglist (decl_type_param_list); + saved_kind_expr = NULL; + gfc_free_array_spec (current_as); + current_as = NULL; + return m; +} + +static bool +in_module_or_interface(void) +{ + if (gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE + || gfc_current_state () == COMP_INTERFACE) + return true; + + if (gfc_state_stack->state == COMP_CONTAINS + || gfc_state_stack->state == COMP_FUNCTION + || gfc_state_stack->state == COMP_SUBROUTINE) + { + gfc_state_data *p; + for (p = gfc_state_stack->previous; p ; p = p->previous) + { + if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE + || p->state == COMP_INTERFACE) + return true; + } + } + return false; +} + +/* Match a prefix associated with a function or subroutine + declaration. If the typespec pointer is nonnull, then a typespec + can be matched. Note that if nothing matches, MATCH_YES is + returned (the null string was matched). */ + +match +gfc_match_prefix (gfc_typespec *ts) +{ + bool seen_type; + bool seen_impure; + bool found_prefix; + + gfc_clear_attr (¤t_attr); + seen_type = false; + seen_impure = false; + + gcc_assert (!gfc_matching_prefix); + gfc_matching_prefix = true; + + do + { + found_prefix = false; + + /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a + corresponding attribute seems natural and distinguishes these + procedures from procedure types of PROC_MODULE, which these are + as well. */ + if (gfc_match ("module% ") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C")) + goto error; + + if (!in_module_or_interface ()) + { + gfc_error ("MODULE prefix at %C found outside of a module, " + "submodule, or interface"); + goto error; + } + + current_attr.module_procedure = 1; + found_prefix = true; + } + + if (!seen_type && ts != NULL) + { + match m; + m = gfc_match_decl_type_spec (ts, 0); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES && gfc_match_space () == MATCH_YES) + { + seen_type = true; + found_prefix = true; + } + } + + if (gfc_match ("elemental% ") == MATCH_YES) + { + if (!gfc_add_elemental (¤t_attr, NULL)) + goto error; + + found_prefix = true; + } + + if (gfc_match ("pure% ") == MATCH_YES) + { + if (!gfc_add_pure (¤t_attr, NULL)) + goto error; + + found_prefix = true; + } + + if (gfc_match ("recursive% ") == MATCH_YES) + { + if (!gfc_add_recursive (¤t_attr, NULL)) + goto error; + + found_prefix = true; + } + + /* IMPURE is a somewhat special case, as it needs not set an actual + attribute but rather only prevents ELEMENTAL routines from being + automatically PURE. */ + if (gfc_match ("impure% ") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C")) + goto error; + + seen_impure = true; + found_prefix = true; + } + } + while (found_prefix); + + /* IMPURE and PURE must not both appear, of course. */ + if (seen_impure && current_attr.pure) + { + gfc_error ("PURE and IMPURE must not appear both at %C"); + goto error; + } + + /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */ + if (!seen_impure && current_attr.elemental && !current_attr.pure) + { + if (!gfc_add_pure (¤t_attr, NULL)) + goto error; + } + + /* At this point, the next item is not a prefix. */ + gcc_assert (gfc_matching_prefix); + + gfc_matching_prefix = false; + return MATCH_YES; + +error: + gcc_assert (gfc_matching_prefix); + gfc_matching_prefix = false; + return MATCH_ERROR; +} + + +/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */ + +static bool +copy_prefix (symbol_attribute *dest, locus *where) +{ + if (dest->module_procedure) + { + if (current_attr.elemental) + dest->elemental = 1; + + if (current_attr.pure) + dest->pure = 1; + + if (current_attr.recursive) + dest->recursive = 1; + + /* Module procedures are unusual in that the 'dest' is copied from + the interface declaration. However, this is an oportunity to + check that the submodule declaration is compliant with the + interface. */ + if (dest->elemental && !current_attr.elemental) + { + gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is " + "missing at %L", where); + return false; + } + + if (dest->pure && !current_attr.pure) + { + gfc_error ("PURE prefix in MODULE PROCEDURE interface is " + "missing at %L", where); + return false; + } + + if (dest->recursive && !current_attr.recursive) + { + gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is " + "missing at %L", where); + return false; + } + + return true; + } + + if (current_attr.elemental && !gfc_add_elemental (dest, where)) + return false; + + if (current_attr.pure && !gfc_add_pure (dest, where)) + return false; + + if (current_attr.recursive && !gfc_add_recursive (dest, where)) + return false; + + return true; +} + + +/* Match a formal argument list or, if typeparam is true, a + type_param_name_list. */ + +match +gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, + int null_flag, bool typeparam) +{ + gfc_formal_arglist *head, *tail, *p, *q; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + gfc_formal_arglist *formal = NULL; + + head = tail = NULL; + + /* Keep the interface formal argument list and null it so that the + matching for the new declaration can be done. The numbers and + names of the arguments are checked here. The interface formal + arguments are retained in formal_arglist and the characteristics + are compared in resolve.c(resolve_fl_procedure). See the remark + in get_proc_name about the eventual need to copy the formal_arglist + and populate the formal namespace of the interface symbol. */ + if (progname->attr.module_procedure + && progname->attr.host_assoc) + { + formal = progname->formal; + progname->formal = NULL; + } + + if (gfc_match_char ('(') != MATCH_YES) + { + if (null_flag) + goto ok; + return MATCH_NO; + } + + if (gfc_match_char (')') == MATCH_YES) + { + if (typeparam) + { + gfc_error_now ("A type parameter list is required at %C"); + m = MATCH_ERROR; + goto cleanup; + } + else + goto ok; + } + + for (;;) + { + if (gfc_match_char ('*') == MATCH_YES) + { + sym = NULL; + if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS, + "Alternate-return argument at %C")) + { + m = MATCH_ERROR; + goto cleanup; + } + else if (typeparam) + gfc_error_now ("A parameter name is required at %C"); + } + else + { + m = gfc_match_name (name); + if (m != MATCH_YES) + { + if(typeparam) + gfc_error_now ("A parameter name is required at %C"); + goto cleanup; + } + + if (!typeparam && gfc_get_symbol (name, NULL, &sym)) + goto cleanup; + else if (typeparam + && gfc_get_symbol (name, progname->f2k_derived, &sym)) + goto cleanup; + } + + p = gfc_get_formal_arglist (); + + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = p; + } + + tail->sym = sym; + + /* We don't add the VARIABLE flavor because the name could be a + dummy procedure. We don't apply these attributes to formal + arguments of statement functions. */ + if (sym != NULL && !st_flag + && (!gfc_add_dummy(&sym->attr, sym->name, NULL) + || !gfc_missing_attr (&sym->attr, NULL))) + { + m = MATCH_ERROR; + goto cleanup; + } + + /* The name of a program unit can be in a different namespace, + so check for it explicitly. After the statement is accepted, + the name is checked for especially in gfc_get_symbol(). */ + if (gfc_new_block != NULL && sym != NULL && !typeparam + && strcmp (sym->name, gfc_new_block->name) == 0) + { + gfc_error ("Name %qs at %C is the name of the procedure", + sym->name); + m = MATCH_ERROR; + goto cleanup; + } + + if (gfc_match_char (')') == MATCH_YES) + goto ok; + + m = gfc_match_char (','); + if (m != MATCH_YES) + { + if (typeparam) + gfc_error_now ("Expected parameter list in type declaration " + "at %C"); + else + gfc_error ("Unexpected junk in formal argument list at %C"); + goto cleanup; + } + } + +ok: + /* Check for duplicate symbols in the formal argument list. */ + if (head != NULL) + { + for (p = head; p->next; p = p->next) + { + if (p->sym == NULL) + continue; + + for (q = p->next; q; q = q->next) + if (p->sym == q->sym) + { + if (typeparam) + gfc_error_now ("Duplicate name %qs in parameter " + "list at %C", p->sym->name); + else + gfc_error ("Duplicate symbol %qs in formal argument " + "list at %C", p->sym->name); + + m = MATCH_ERROR; + goto cleanup; + } + } + } + + if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)) + { + m = MATCH_ERROR; + goto cleanup; + } + + /* gfc_error_now used in following and return with MATCH_YES because + doing otherwise results in a cascade of extraneous errors and in + some cases an ICE in symbol.c(gfc_release_symbol). */ + if (progname->attr.module_procedure && progname->attr.host_assoc) + { + bool arg_count_mismatch = false; + + if (!formal && head) + arg_count_mismatch = true; + + /* Abbreviated module procedure declaration is not meant to have any + formal arguments! */ + if (!progname->abr_modproc_decl && formal && !head) + arg_count_mismatch = true; + + for (p = formal, q = head; p && q; p = p->next, q = q->next) + { + if ((p->next != NULL && q->next == NULL) + || (p->next == NULL && q->next != NULL)) + arg_count_mismatch = true; + else if ((p->sym == NULL && q->sym == NULL) + || strcmp (p->sym->name, q->sym->name) == 0) + continue; + else + gfc_error_now ("Mismatch in MODULE PROCEDURE formal " + "argument names (%s/%s) at %C", + p->sym->name, q->sym->name); + } + + if (arg_count_mismatch) + gfc_error_now ("Mismatch in number of MODULE PROCEDURE " + "formal arguments at %C"); + } + + return MATCH_YES; + +cleanup: + gfc_free_formal_arglist (head); + return m; +} + + +/* Match a RESULT specification following a function declaration or + ENTRY statement. Also matches the end-of-statement. */ + +static match +match_result (gfc_symbol *function, gfc_symbol **result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *r; + match m; + + if (gfc_match (" result (") != MATCH_YES) + return MATCH_NO; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + /* Get the right paren, and that's it because there could be the + bind(c) attribute after the result clause. */ + if (gfc_match_char (')') != MATCH_YES) + { + /* TODO: should report the missing right paren here. */ + return MATCH_ERROR; + } + + if (strcmp (function->name, name) == 0) + { + gfc_error ("RESULT variable at %C must be different than function name"); + return MATCH_ERROR; + } + + if (gfc_get_symbol (name, NULL, &r)) + return MATCH_ERROR; + + if (!gfc_add_result (&r->attr, r->name, NULL)) + return MATCH_ERROR; + + *result = r; + + return MATCH_YES; +} + + +/* Match a function suffix, which could be a combination of a result + clause and BIND(C), either one, or neither. The draft does not + require them to come in a specific order. */ + +static match +gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) +{ + match is_bind_c; /* Found bind(c). */ + match is_result; /* Found result clause. */ + match found_match; /* Status of whether we've found a good match. */ + char peek_char; /* Character we're going to peek at. */ + bool allow_binding_name; + + /* Initialize to having found nothing. */ + found_match = MATCH_NO; + is_bind_c = MATCH_NO; + is_result = MATCH_NO; + + /* Get the next char to narrow between result and bind(c). */ + gfc_gobble_whitespace (); + peek_char = gfc_peek_ascii_char (); + + /* C binding names are not allowed for internal procedures. */ + if (gfc_current_state () == COMP_CONTAINS + && sym->ns->proc_name->attr.flavor != FL_MODULE) + allow_binding_name = false; + else + allow_binding_name = true; + + switch (peek_char) + { + case 'r': + /* Look for result clause. */ + is_result = match_result (sym, result); + if (is_result == MATCH_YES) + { + /* Now see if there is a bind(c) after it. */ + is_bind_c = gfc_match_bind_c (sym, allow_binding_name); + /* We've found the result clause and possibly bind(c). */ + found_match = MATCH_YES; + } + else + /* This should only be MATCH_ERROR. */ + found_match = is_result; + break; + case 'b': + /* Look for bind(c) first. */ + is_bind_c = gfc_match_bind_c (sym, allow_binding_name); + if (is_bind_c == MATCH_YES) + { + /* Now see if a result clause followed it. */ + is_result = match_result (sym, result); + found_match = MATCH_YES; + } + else + { + /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */ + found_match = MATCH_ERROR; + } + break; + default: + gfc_error ("Unexpected junk after function declaration at %C"); + found_match = MATCH_ERROR; + break; + } + + if (is_bind_c == MATCH_YES) + { + /* Fortran 2008 draft allows BIND(C) for internal procedures. */ + if (gfc_current_state () == COMP_CONTAINS + && sym->ns->proc_name->attr.flavor != FL_MODULE + && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " + "at %L may not be specified for an internal " + "procedure", &gfc_current_locus)) + return MATCH_ERROR; + + if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)) + return MATCH_ERROR; + } + + return found_match; +} + + +/* Procedure pointer return value without RESULT statement: + Add "hidden" result variable named "ppr@". */ + +static bool +add_hidden_procptr_result (gfc_symbol *sym) +{ + bool case1,case2; + + if (gfc_notification_std (GFC_STD_F2003) == ERROR) + return false; + + /* First usage case: PROCEDURE and EXTERNAL statements. */ + case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block () + && strcmp (gfc_current_block ()->name, sym->name) == 0 + && sym->attr.external; + /* Second usage case: INTERFACE statements. */ + case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_FUNCTION + && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0; + + if (case1 || case2) + { + gfc_symtree *stree; + if (case1) + gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false); + else + { + gfc_symtree *st2; + gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false); + st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@"); + st2->n.sym = stree->n.sym; + stree->n.sym->refs++; + } + sym->result = stree->n.sym; + + sym->result->attr.proc_pointer = sym->attr.proc_pointer; + sym->result->attr.pointer = sym->attr.pointer; + sym->result->attr.external = sym->attr.external; + sym->result->attr.referenced = sym->attr.referenced; + sym->result->ts = sym->ts; + sym->attr.proc_pointer = 0; + sym->attr.pointer = 0; + sym->attr.external = 0; + if (sym->result->attr.external && sym->result->attr.pointer) + { + sym->result->attr.pointer = 0; + sym->result->attr.proc_pointer = 1; + } + + return gfc_add_result (&sym->result->attr, sym->result->name, NULL); + } + /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */ + else if (sym->attr.function && !sym->attr.external && sym->attr.pointer + && sym->result && sym->result != sym && sym->result->attr.external + && sym == gfc_current_ns->proc_name + && sym == sym->result->ns->proc_name + && strcmp ("ppr@", sym->result->name) == 0) + { + sym->result->attr.proc_pointer = 1; + sym->attr.pointer = 0; + return true; + } + else + return false; +} + + +/* Match the interface for a PROCEDURE declaration, + including brackets (R1212). */ + +static match +match_procedure_interface (gfc_symbol **proc_if) +{ + match m; + gfc_symtree *st; + locus old_loc, entry_loc; + gfc_namespace *old_ns = gfc_current_ns; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + old_loc = entry_loc = gfc_current_locus; + gfc_clear_ts (¤t_ts); + + if (gfc_match (" (") != MATCH_YES) + { + gfc_current_locus = entry_loc; + return MATCH_NO; + } + + /* Get the type spec. for the procedure interface. */ + old_loc = gfc_current_locus; + m = gfc_match_decl_type_spec (¤t_ts, 0); + gfc_gobble_whitespace (); + if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')')) + goto got_ts; + + if (m == MATCH_ERROR) + return m; + + /* Procedure interface is itself a procedure. */ + gfc_current_locus = old_loc; + m = gfc_match_name (name); + + /* First look to see if it is already accessible in the current + namespace because it is use associated or contained. */ + st = NULL; + if (gfc_find_sym_tree (name, NULL, 0, &st)) + return MATCH_ERROR; + + /* If it is still not found, then try the parent namespace, if it + exists and create the symbol there if it is still not found. */ + if (gfc_current_ns->parent) + gfc_current_ns = gfc_current_ns->parent; + if (st == NULL && gfc_get_ha_sym_tree (name, &st)) + return MATCH_ERROR; + + gfc_current_ns = old_ns; + *proc_if = st->n.sym; + + if (*proc_if) + { + (*proc_if)->refs++; + /* Resolve interface if possible. That way, attr.procedure is only set + if it is declared by a later procedure-declaration-stmt, which is + invalid per F08:C1216 (cf. resolve_procedure_interface). */ + while ((*proc_if)->ts.interface + && *proc_if != (*proc_if)->ts.interface) + *proc_if = (*proc_if)->ts.interface; + + if ((*proc_if)->attr.flavor == FL_UNKNOWN + && (*proc_if)->ts.type == BT_UNKNOWN + && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, + (*proc_if)->name, NULL)) + return MATCH_ERROR; + } + +got_ts: + if (gfc_match (" )") != MATCH_YES) + { + gfc_current_locus = entry_loc; + return MATCH_NO; + } + + return MATCH_YES; +} + + +/* Match a PROCEDURE declaration (R1211). */ + +static match +match_procedure_decl (void) +{ + match m; + gfc_symbol *sym, *proc_if = NULL; + int num; + gfc_expr *initializer = NULL; + + /* Parse interface (with brackets). */ + m = match_procedure_interface (&proc_if); + if (m != MATCH_YES) + return m; + + /* Parse attributes (with colons). */ + m = match_attr_spec(); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c) + { + current_attr.is_bind_c = 1; + has_name_equals = 0; + curr_binding_label = NULL; + } + + /* Get procedure symbols. */ + for(num=1;;num++) + { + m = gfc_match_symbol (&sym, 0); + if (m == MATCH_NO) + goto syntax; + else if (m == MATCH_ERROR) + return m; + + /* Add current_attr to the symbol attributes. */ + if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL)) + return MATCH_ERROR; + + if (sym->attr.is_bind_c) + { + /* Check for C1218. */ + if (!proc_if || !proc_if->attr.is_bind_c) + { + gfc_error ("BIND(C) attribute at %C requires " + "an interface with BIND(C)"); + return MATCH_ERROR; + } + /* Check for C1217. */ + if (has_name_equals && sym->attr.pointer) + { + gfc_error ("BIND(C) procedure with NAME may not have " + "POINTER attribute at %C"); + return MATCH_ERROR; + } + if (has_name_equals && sym->attr.dummy) + { + gfc_error ("Dummy procedure at %C may not have " + "BIND(C) attribute with NAME"); + return MATCH_ERROR; + } + /* Set binding label for BIND(C). */ + if (!set_binding_label (&sym->binding_label, sym->name, num)) + return MATCH_ERROR; + } + + if (!gfc_add_external (&sym->attr, NULL)) + return MATCH_ERROR; + + if (add_hidden_procptr_result (sym)) + sym = sym->result; + + if (!gfc_add_proc (&sym->attr, sym->name, NULL)) + return MATCH_ERROR; + + /* Set interface. */ + if (proc_if != NULL) + { + if (sym->ts.type != BT_UNKNOWN) + { + gfc_error ("Procedure %qs at %L already has basic type of %s", + sym->name, &gfc_current_locus, + gfc_basic_typename (sym->ts.type)); + return MATCH_ERROR; + } + sym->ts.interface = proc_if; + sym->attr.untyped = 1; + sym->attr.if_source = IFSRC_IFBODY; + } + else if (current_ts.type != BT_UNKNOWN) + { + if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) + return MATCH_ERROR; + sym->ts.interface = gfc_new_symbol ("", gfc_current_ns); + sym->ts.interface->ts = current_ts; + sym->ts.interface->attr.flavor = FL_PROCEDURE; + sym->ts.interface->attr.function = 1; + sym->attr.function = 1; + sym->attr.if_source = IFSRC_UNKNOWN; + } + + if (gfc_match (" =>") == MATCH_YES) + { + if (!current_attr.pointer) + { + gfc_error ("Initialization at %C isn't for a pointer variable"); + m = MATCH_ERROR; + goto cleanup; + } + + m = match_pointer_init (&initializer, 1); + if (m != MATCH_YES) + goto cleanup; + + if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)) + goto cleanup; + + } + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + +syntax: + gfc_error ("Syntax error in PROCEDURE statement at %C"); + return MATCH_ERROR; + +cleanup: + /* Free stuff up and return. */ + gfc_free_expr (initializer); + return m; +} + + +static match +match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc); + + +/* Match a procedure pointer component declaration (R445). */ + +static match +match_ppc_decl (void) +{ + match m; + gfc_symbol *proc_if = NULL; + gfc_typespec ts; + int num; + gfc_component *c; + gfc_expr *initializer = NULL; + gfc_typebound_proc* tb; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + /* Parse interface (with brackets). */ + m = match_procedure_interface (&proc_if); + if (m != MATCH_YES) + goto syntax; + + /* Parse attributes. */ + tb = XCNEW (gfc_typebound_proc); + tb->where = gfc_current_locus; + m = match_binding_attributes (tb, false, true); + if (m == MATCH_ERROR) + return m; + + gfc_clear_attr (¤t_attr); + current_attr.procedure = 1; + current_attr.proc_pointer = 1; + current_attr.access = tb->access; + current_attr.flavor = FL_PROCEDURE; + + /* Match the colons (required). */ + if (gfc_match (" ::") != MATCH_YES) + { + gfc_error ("Expected %<::%> after binding-attributes at %C"); + return MATCH_ERROR; + } + + /* Check for C450. */ + if (!tb->nopass && proc_if == NULL) + { + gfc_error("NOPASS or explicit interface required at %C"); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C")) + return MATCH_ERROR; + + /* Match PPC names. */ + ts = current_ts; + for(num=1;;num++) + { + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + else if (m == MATCH_ERROR) + return m; + + if (!gfc_add_component (gfc_current_block(), name, &c)) + return MATCH_ERROR; + + /* Add current_attr to the symbol attributes. */ + if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL)) + return MATCH_ERROR; + + if (!gfc_add_external (&c->attr, NULL)) + return MATCH_ERROR; + + if (!gfc_add_proc (&c->attr, name, NULL)) + return MATCH_ERROR; + + if (num == 1) + c->tb = tb; + else + { + c->tb = XCNEW (gfc_typebound_proc); + c->tb->where = gfc_current_locus; + *c->tb = *tb; + } + + /* Set interface. */ + if (proc_if != NULL) + { + c->ts.interface = proc_if; + c->attr.untyped = 1; + c->attr.if_source = IFSRC_IFBODY; + } + else if (ts.type != BT_UNKNOWN) + { + c->ts = ts; + c->ts.interface = gfc_new_symbol ("", gfc_current_ns); + c->ts.interface->result = c->ts.interface; + c->ts.interface->ts = ts; + c->ts.interface->attr.flavor = FL_PROCEDURE; + c->ts.interface->attr.function = 1; + c->attr.function = 1; + c->attr.if_source = IFSRC_UNKNOWN; + } + + if (gfc_match (" =>") == MATCH_YES) + { + m = match_pointer_init (&initializer, 1); + if (m != MATCH_YES) + { + gfc_free_expr (initializer); + return m; + } + c->initializer = initializer; + } + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + +syntax: + gfc_error ("Syntax error in procedure pointer component at %C"); + return MATCH_ERROR; +} + + +/* Match a PROCEDURE declaration inside an interface (R1206). */ + +static match +match_procedure_in_interface (void) +{ + match m; + gfc_symbol *sym; + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + + if (current_interface.type == INTERFACE_NAMELESS + || current_interface.type == INTERFACE_ABSTRACT) + { + gfc_error ("PROCEDURE at %C must be in a generic interface"); + return MATCH_ERROR; + } + + /* Check if the F2008 optional double colon appears. */ + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + if (gfc_match ("::") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2008, "double colon in " + "MODULE PROCEDURE statement at %L", &old_locus)) + return MATCH_ERROR; + } + else + gfc_current_locus = old_locus; + + for(;;) + { + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + else if (m == MATCH_ERROR) + return m; + if (gfc_get_symbol (name, gfc_current_ns->parent, &sym)) + return MATCH_ERROR; + + if (!gfc_add_interface (sym)) + return MATCH_ERROR; + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in PROCEDURE statement at %C"); + return MATCH_ERROR; +} + + +/* General matcher for PROCEDURE declarations. */ + +static match match_procedure_in_type (void); + +match +gfc_match_procedure (void) +{ + match m; + + switch (gfc_current_state ()) + { + case COMP_NONE: + case COMP_PROGRAM: + case COMP_MODULE: + case COMP_SUBMODULE: + case COMP_SUBROUTINE: + case COMP_FUNCTION: + case COMP_BLOCK: + m = match_procedure_decl (); + break; + case COMP_INTERFACE: + m = match_procedure_in_interface (); + break; + case COMP_DERIVED: + m = match_ppc_decl (); + break; + case COMP_DERIVED_CONTAINS: + m = match_procedure_in_type (); + break; + default: + return MATCH_NO; + } + + if (m != MATCH_YES) + return m; + + if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C")) + return MATCH_ERROR; + + return m; +} + + +/* Warn if a matched procedure has the same name as an intrinsic; this is + simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current + parser-state-stack to find out whether we're in a module. */ + +static void +do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func) +{ + bool in_module; + + in_module = (gfc_state_stack->previous + && (gfc_state_stack->previous->state == COMP_MODULE + || gfc_state_stack->previous->state == COMP_SUBMODULE)); + + gfc_warn_intrinsic_shadow (sym, in_module, func); +} + + +/* Match a function declaration. */ + +match +gfc_match_function_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym, *result; + locus old_loc; + match m; + match suffix_match; + match found_match; /* Status returned by match func. */ + + if (gfc_current_state () != COMP_NONE + && gfc_current_state () != COMP_INTERFACE + && gfc_current_state () != COMP_CONTAINS) + return MATCH_NO; + + gfc_clear_ts (¤t_ts); + + old_loc = gfc_current_locus; + + m = gfc_match_prefix (¤t_ts); + if (m != MATCH_YES) + { + gfc_current_locus = old_loc; + return m; + } + + if (gfc_match ("function% %n", name) != MATCH_YES) + { + gfc_current_locus = old_loc; + return MATCH_NO; + } + + if (get_proc_name (name, &sym, false)) + return MATCH_ERROR; + + if (add_hidden_procptr_result (sym)) + sym = sym->result; + + if (current_attr.module_procedure) + sym->attr.module_procedure = 1; + + gfc_new_block = sym; + + m = gfc_match_formal_arglist (sym, 0, 0); + if (m == MATCH_NO) + { + gfc_error ("Expected formal argument list in function " + "definition at %C"); + m = MATCH_ERROR; + goto cleanup; + } + else if (m == MATCH_ERROR) + goto cleanup; + + result = NULL; + + /* According to the draft, the bind(c) and result clause can + come in either order after the formal_arg_list (i.e., either + can be first, both can exist together or by themselves or neither + one). Therefore, the match_result can't match the end of the + string, and check for the bind(c) or result clause in either order. */ + found_match = gfc_match_eos (); + + /* Make sure that it isn't already declared as BIND(C). If it is, it + must have been marked BIND(C) with a BIND(C) attribute and that is + not allowed for procedures. */ + if (sym->attr.is_bind_c == 1) + { + sym->attr.is_bind_c = 0; + + if (gfc_state_stack->previous + && gfc_state_stack->previous->state != COMP_SUBMODULE) + { + locus loc; + loc = sym->old_symbol != NULL + ? sym->old_symbol->declared_at : gfc_current_locus; + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &loc); + } + } + + if (found_match != MATCH_YES) + { + /* If we haven't found the end-of-statement, look for a suffix. */ + suffix_match = gfc_match_suffix (sym, &result); + if (suffix_match == MATCH_YES) + /* Need to get the eos now. */ + found_match = gfc_match_eos (); + else + found_match = suffix_match; + } + + /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module + subprogram and a binding label is specified, it shall be the + same as the binding label specified in the corresponding module + procedure interface body. */ + if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol + && strcmp (sym->name, sym->old_symbol->name) == 0 + && sym->binding_label && sym->old_symbol->binding_label + && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) + { + const char *null = "NULL", *s1, *s2; + s1 = sym->binding_label; + if (!s1) s1 = null; + s2 = sym->old_symbol->binding_label; + if (!s2) s2 = null; + gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); + sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ + return MATCH_ERROR; + } + + if(found_match != MATCH_YES) + m = MATCH_ERROR; + else + { + /* Make changes to the symbol. */ + m = MATCH_ERROR; + + if (!gfc_add_function (&sym->attr, sym->name, NULL)) + goto cleanup; + + if (!gfc_missing_attr (&sym->attr, NULL)) + goto cleanup; + + if (!copy_prefix (&sym->attr, &sym->declared_at)) + { + if(!sym->attr.module_procedure) + goto cleanup; + else + gfc_error_check (); + } + + /* Delay matching the function characteristics until after the + specification block by signalling kind=-1. */ + sym->declared_at = old_loc; + if (current_ts.type != BT_UNKNOWN) + current_ts.kind = -1; + else + current_ts.kind = 0; + + if (result == NULL) + { + if (current_ts.type != BT_UNKNOWN + && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) + goto cleanup; + sym->result = sym; + } + else + { + if (current_ts.type != BT_UNKNOWN + && !gfc_add_type (result, ¤t_ts, &gfc_current_locus)) + goto cleanup; + sym->result = result; + } + + /* Warn if this procedure has the same name as an intrinsic. */ + do_warn_intrinsic_shadow (sym, true); + + return MATCH_YES; + } + +cleanup: + gfc_current_locus = old_loc; + return m; +} + + +/* This is mostly a copy of parse.c(add_global_procedure) but modified to + pass the name of the entry, rather than the gfc_current_block name, and + to return false upon finding an existing global entry. */ + +static bool +add_global_entry (const char *name, const char *binding_label, bool sub, + locus *where) +{ + gfc_gsymbol *s; + enum gfc_symbol_type type; + + type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + + /* Only in Fortran 2003: For procedures with a binding label also the Fortran + name is a global identifier. */ + if (!binding_label || gfc_notification_std (GFC_STD_F2008)) + { + s = gfc_get_gsymbol (name, false); + + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) + { + gfc_global_used (s, where); + return false; + } + else + { + s->type = type; + s->sym_name = name; + s->where = *where; + s->defined = 1; + s->ns = gfc_current_ns; + } + } + + /* Don't add the symbol multiple times. */ + if (binding_label + && (!gfc_notification_std (GFC_STD_F2008) + || strcmp (name, binding_label) != 0)) + { + s = gfc_get_gsymbol (binding_label, true); + + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) + { + gfc_global_used (s, where); + return false; + } + else + { + s->type = type; + s->sym_name = name; + s->binding_label = binding_label; + s->where = *where; + s->defined = 1; + s->ns = gfc_current_ns; + } + } + + return true; +} + + +/* Match an ENTRY statement. */ + +match +gfc_match_entry (void) +{ + gfc_symbol *proc; + gfc_symbol *result; + gfc_symbol *entry; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_compile_state state; + match m; + gfc_entry_list *el; + locus old_loc; + bool module_procedure; + char peek_char; + match is_bind_c; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C")) + return MATCH_ERROR; + + state = gfc_current_state (); + if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) + { + switch (state) + { + case COMP_PROGRAM: + gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM"); + break; + case COMP_MODULE: + gfc_error ("ENTRY statement at %C cannot appear within a MODULE"); + break; + case COMP_SUBMODULE: + gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE"); + break; + case COMP_BLOCK_DATA: + gfc_error ("ENTRY statement at %C cannot appear within " + "a BLOCK DATA"); + break; + case COMP_INTERFACE: + gfc_error ("ENTRY statement at %C cannot appear within " + "an INTERFACE"); + break; + case COMP_STRUCTURE: + gfc_error ("ENTRY statement at %C cannot appear within " + "a STRUCTURE block"); + break; + case COMP_DERIVED: + gfc_error ("ENTRY statement at %C cannot appear within " + "a DERIVED TYPE block"); + break; + case COMP_IF: + gfc_error ("ENTRY statement at %C cannot appear within " + "an IF-THEN block"); + break; + case COMP_DO: + case COMP_DO_CONCURRENT: + gfc_error ("ENTRY statement at %C cannot appear within " + "a DO block"); + break; + case COMP_SELECT: + gfc_error ("ENTRY statement at %C cannot appear within " + "a SELECT block"); + break; + case COMP_FORALL: + gfc_error ("ENTRY statement at %C cannot appear within " + "a FORALL block"); + break; + case COMP_WHERE: + gfc_error ("ENTRY statement at %C cannot appear within " + "a WHERE block"); + break; + case COMP_CONTAINS: + gfc_error ("ENTRY statement at %C cannot appear within " + "a contained subprogram"); + break; + default: + gfc_error ("Unexpected ENTRY statement at %C"); + } + return MATCH_ERROR; + } + + if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE"); + return MATCH_ERROR; + } + + module_procedure = gfc_current_ns->parent != NULL + && gfc_current_ns->parent->proc_name + && gfc_current_ns->parent->proc_name->attr.flavor + == FL_MODULE; + + if (gfc_current_ns->parent != NULL + && gfc_current_ns->parent->proc_name + && !module_procedure) + { + gfc_error("ENTRY statement at %C cannot appear in a " + "contained procedure"); + return MATCH_ERROR; + } + + /* Module function entries need special care in get_proc_name + because previous references within the function will have + created symbols attached to the current namespace. */ + if (get_proc_name (name, &entry, + gfc_current_ns->parent != NULL + && module_procedure)) + return MATCH_ERROR; + + proc = gfc_current_block (); + + /* Make sure that it isn't already declared as BIND(C). If it is, it + must have been marked BIND(C) with a BIND(C) attribute and that is + not allowed for procedures. */ + if (entry->attr.is_bind_c == 1) + { + locus loc; + + entry->attr.is_bind_c = 0; + + loc = entry->old_symbol != NULL + ? entry->old_symbol->declared_at : gfc_current_locus; + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &loc); + } + + /* Check what next non-whitespace character is so we can tell if there + is the required parens if we have a BIND(C). */ + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + peek_char = gfc_peek_ascii_char (); + + if (state == COMP_SUBROUTINE) + { + m = gfc_match_formal_arglist (entry, 0, 1); + if (m != MATCH_YES) + return MATCH_ERROR; + + /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can + never be an internal procedure. */ + is_bind_c = gfc_match_bind_c (entry, true); + if (is_bind_c == MATCH_ERROR) + return MATCH_ERROR; + if (is_bind_c == MATCH_YES) + { + if (peek_char != '(') + { + gfc_error ("Missing required parentheses before BIND(C) at %C"); + return MATCH_ERROR; + } + + if (!gfc_add_is_bind_c (&(entry->attr), entry->name, + &(entry->declared_at), 1)) + return MATCH_ERROR; + + } + + if (!gfc_current_ns->parent + && !add_global_entry (name, entry->binding_label, true, + &old_loc)) + return MATCH_ERROR; + + /* An entry in a subroutine. */ + if (!gfc_add_entry (&entry->attr, entry->name, NULL) + || !gfc_add_subroutine (&entry->attr, entry->name, NULL)) + return MATCH_ERROR; + } + else + { + /* An entry in a function. + We need to take special care because writing + ENTRY f() + as + ENTRY f + is allowed, whereas + ENTRY f() RESULT (r) + can't be written as + ENTRY f RESULT (r). */ + if (gfc_match_eos () == MATCH_YES) + { + gfc_current_locus = old_loc; + /* Match the empty argument list, and add the interface to + the symbol. */ + m = gfc_match_formal_arglist (entry, 0, 1); + } + else + m = gfc_match_formal_arglist (entry, 0, 0); + + if (m != MATCH_YES) + return MATCH_ERROR; + + result = NULL; + + if (gfc_match_eos () == MATCH_YES) + { + if (!gfc_add_entry (&entry->attr, entry->name, NULL) + || !gfc_add_function (&entry->attr, entry->name, NULL)) + return MATCH_ERROR; + + entry->result = entry; + } + else + { + m = gfc_match_suffix (entry, &result); + if (m == MATCH_NO) + gfc_syntax_error (ST_ENTRY); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (result) + { + if (!gfc_add_result (&result->attr, result->name, NULL) + || !gfc_add_entry (&entry->attr, result->name, NULL) + || !gfc_add_function (&entry->attr, result->name, NULL)) + return MATCH_ERROR; + entry->result = result; + } + else + { + if (!gfc_add_entry (&entry->attr, entry->name, NULL) + || !gfc_add_function (&entry->attr, entry->name, NULL)) + return MATCH_ERROR; + entry->result = entry; + } + } + + if (!gfc_current_ns->parent + && !add_global_entry (name, entry->binding_label, false, + &old_loc)) + return MATCH_ERROR; + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_ENTRY); + return MATCH_ERROR; + } + + /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */ + if (proc->attr.elemental && entry->attr.is_bind_c) + { + gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an " + "elemental procedure", &entry->declared_at); + return MATCH_ERROR; + } + + entry->attr.recursive = proc->attr.recursive; + entry->attr.elemental = proc->attr.elemental; + entry->attr.pure = proc->attr.pure; + + el = gfc_get_entry_list (); + el->sym = entry; + el->next = gfc_current_ns->entries; + gfc_current_ns->entries = el; + if (el->next) + el->id = el->next->id + 1; + else + el->id = 1; + + new_st.op = EXEC_ENTRY; + new_st.ext.entry = el; + + return MATCH_YES; +} + + +/* Match a subroutine statement, including optional prefixes. */ + +match +gfc_match_subroutine (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + match is_bind_c; + char peek_char; + bool allow_binding_name; + locus loc; + + if (gfc_current_state () != COMP_NONE + && gfc_current_state () != COMP_INTERFACE + && gfc_current_state () != COMP_CONTAINS) + return MATCH_NO; + + m = gfc_match_prefix (NULL); + if (m != MATCH_YES) + return m; + + m = gfc_match ("subroutine% %n", name); + if (m != MATCH_YES) + return m; + + if (get_proc_name (name, &sym, false)) + return MATCH_ERROR; + + /* Set declared_at as it might point to, e.g., a PUBLIC statement, if + the symbol existed before. */ + sym->declared_at = gfc_current_locus; + + if (current_attr.module_procedure) + sym->attr.module_procedure = 1; + + if (add_hidden_procptr_result (sym)) + sym = sym->result; + + gfc_new_block = sym; + + /* Check what next non-whitespace character is so we can tell if there + is the required parens if we have a BIND(C). */ + gfc_gobble_whitespace (); + peek_char = gfc_peek_ascii_char (); + + if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) + return MATCH_ERROR; + + if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) + return MATCH_ERROR; + + /* Make sure that it isn't already declared as BIND(C). If it is, it + must have been marked BIND(C) with a BIND(C) attribute and that is + not allowed for procedures. */ + if (sym->attr.is_bind_c == 1) + { + sym->attr.is_bind_c = 0; + + if (gfc_state_stack->previous + && gfc_state_stack->previous->state != COMP_SUBMODULE) + { + locus loc; + loc = sym->old_symbol != NULL + ? sym->old_symbol->declared_at : gfc_current_locus; + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", &loc); + } + } + + /* C binding names are not allowed for internal procedures. */ + if (gfc_current_state () == COMP_CONTAINS + && sym->ns->proc_name->attr.flavor != FL_MODULE) + allow_binding_name = false; + else + allow_binding_name = true; + + /* Here, we are just checking if it has the bind(c) attribute, and if + so, then we need to make sure it's all correct. If it doesn't, + we still need to continue matching the rest of the subroutine line. */ + gfc_gobble_whitespace (); + loc = gfc_current_locus; + is_bind_c = gfc_match_bind_c (sym, allow_binding_name); + if (is_bind_c == MATCH_ERROR) + { + /* There was an attempt at the bind(c), but it was wrong. An + error message should have been printed w/in the gfc_match_bind_c + so here we'll just return the MATCH_ERROR. */ + return MATCH_ERROR; + } + + if (is_bind_c == MATCH_YES) + { + gfc_formal_arglist *arg; + + /* The following is allowed in the Fortran 2008 draft. */ + if (gfc_current_state () == COMP_CONTAINS + && sym->ns->proc_name->attr.flavor != FL_MODULE + && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " + "at %L may not be specified for an internal " + "procedure", &gfc_current_locus)) + return MATCH_ERROR; + + if (peek_char != '(') + { + gfc_error ("Missing required parentheses before BIND(C) at %C"); + return MATCH_ERROR; + } + + /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module + subprogram and a binding label is specified, it shall be the + same as the binding label specified in the corresponding module + procedure interface body. */ + if (sym->attr.module_procedure && sym->old_symbol + && strcmp (sym->name, sym->old_symbol->name) == 0 + && sym->binding_label && sym->old_symbol->binding_label + && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) + { + const char *null = "NULL", *s1, *s2; + s1 = sym->binding_label; + if (!s1) s1 = null; + s2 = sym->old_symbol->binding_label; + if (!s2) s2 = null; + gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); + sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ + return MATCH_ERROR; + } + + /* Scan the dummy arguments for an alternate return. */ + for (arg = sym->formal; arg; arg = arg->next) + if (!arg->sym) + { + gfc_error ("Alternate return dummy argument cannot appear in a " + "SUBROUTINE with the BIND(C) attribute at %L", &loc); + return MATCH_ERROR; + } + + if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)) + return MATCH_ERROR; + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_SUBROUTINE); + return MATCH_ERROR; + } + + if (!copy_prefix (&sym->attr, &sym->declared_at)) + { + if(!sym->attr.module_procedure) + return MATCH_ERROR; + else + gfc_error_check (); + } + + /* Warn if it has the same name as an intrinsic. */ + do_warn_intrinsic_shadow (sym, false); + + return MATCH_YES; +} + + +/* Check that the NAME identifier in a BIND attribute or statement + is conform to C identifier rules. */ + +match +check_bind_name_identifier (char **name) +{ + char *n = *name, *p; + + /* Remove leading spaces. */ + while (*n == ' ') + n++; + + /* On an empty string, free memory and set name to NULL. */ + if (*n == '\0') + { + free (*name); + *name = NULL; + return MATCH_YES; + } + + /* Remove trailing spaces. */ + p = n + strlen(n) - 1; + while (*p == ' ') + *(p--) = '\0'; + + /* Insert the identifier into the symbol table. */ + p = xstrdup (n); + free (*name); + *name = p; + + /* Now check that identifier is valid under C rules. */ + if (ISDIGIT (*p)) + { + gfc_error ("Invalid C identifier in NAME= specifier at %C"); + return MATCH_ERROR; + } + + for (; *p; p++) + if (!(ISALNUM (*p) || *p == '_' || *p == '$')) + { + gfc_error ("Invalid C identifier in NAME= specifier at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Match a BIND(C) specifier, with the optional 'name=' specifier if + given, and set the binding label in either the given symbol (if not + NULL), or in the current_ts. The symbol may be NULL because we may + encounter the BIND(C) before the declaration itself. Return + MATCH_NO if what we're looking at isn't a BIND(C) specifier, + MATCH_ERROR if it is a BIND(C) clause but an error was encountered, + or MATCH_YES if the specifier was correct and the binding label and + bind(c) fields were set correctly for the given symbol or the + current_ts. If allow_binding_name is false, no binding name may be + given. */ + +match +gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) +{ + char *binding_label = NULL; + gfc_expr *e = NULL; + + /* Initialize the flag that specifies whether we encountered a NAME= + specifier or not. */ + has_name_equals = 0; + + /* This much we have to be able to match, in this order, if + there is a bind(c) label. */ + if (gfc_match (" bind ( c ") != MATCH_YES) + return MATCH_NO; + + /* Now see if there is a binding label, or if we've reached the + end of the bind(c) attribute without one. */ + if (gfc_match_char (',') == MATCH_YES) + { + if (gfc_match (" name = ") != MATCH_YES) + { + gfc_error ("Syntax error in NAME= specifier for binding label " + "at %C"); + /* should give an error message here */ + return MATCH_ERROR; + } + + has_name_equals = 1; + + if (gfc_match_init_expr (&e) != MATCH_YES) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + + if (!gfc_simplify_expr(e, 0)) + { + gfc_error ("NAME= specifier at %C should be a constant expression"); + gfc_free_expr (e); + return MATCH_ERROR; + } + + if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER + || e->ts.kind != gfc_default_character_kind || e->rank != 0) + { + gfc_error ("NAME= specifier at %C should be a scalar of " + "default character kind"); + gfc_free_expr(e); + return MATCH_ERROR; + } + + // Get a C string from the Fortran string constant + binding_label = gfc_widechar_to_char (e->value.character.string, + e->value.character.length); + gfc_free_expr(e); + + // Check that it is valid (old gfc_match_name_C) + if (check_bind_name_identifier (&binding_label) != MATCH_YES) + return MATCH_ERROR; + } + + /* Get the required right paren. */ + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Missing closing paren for binding label at %C"); + return MATCH_ERROR; + } + + if (has_name_equals && !allow_binding_name) + { + gfc_error ("No binding name is allowed in BIND(C) at %C"); + return MATCH_ERROR; + } + + if (has_name_equals && sym != NULL && sym->attr.dummy) + { + gfc_error ("For dummy procedure %s, no binding name is " + "allowed in BIND(C) at %C", sym->name); + return MATCH_ERROR; + } + + + /* Save the binding label to the symbol. If sym is null, we're + probably matching the typespec attributes of a declaration and + haven't gotten the name yet, and therefore, no symbol yet. */ + if (binding_label) + { + if (sym != NULL) + sym->binding_label = binding_label; + else + curr_binding_label = binding_label; + } + else if (allow_binding_name) + { + /* No binding label, but if symbol isn't null, we + can set the label for it here. + If name="" or allow_binding_name is false, no C binding name is + created. */ + if (sym != NULL && sym->name != NULL && has_name_equals == 0) + sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name)); + } + + if (has_name_equals && gfc_current_state () == COMP_INTERFACE + && current_interface.type == INTERFACE_ABSTRACT) + { + gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Return nonzero if we're currently compiling a contained procedure. */ + +static int +contained_procedure (void) +{ + gfc_state_data *s = gfc_state_stack; + + if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION) + && s->previous != NULL && s->previous->state == COMP_CONTAINS) + return 1; + + return 0; +} + +/* Set the kind of each enumerator. The kind is selected such that it is + interoperable with the corresponding C enumeration type, making + sure that -fshort-enums is honored. */ + +static void +set_enum_kind(void) +{ + enumerator_history *current_history = NULL; + int kind; + int i; + + if (max_enum == NULL || enum_history == NULL) + return; + + if (!flag_short_enums) + return; + + i = 0; + do + { + kind = gfc_integer_kinds[i++].kind; + } + while (kind < gfc_c_int_kind + && gfc_check_integer_range (max_enum->initializer->value.integer, + kind) != ARITH_OK); + + current_history = enum_history; + while (current_history != NULL) + { + current_history->sym->ts.kind = kind; + current_history = current_history->next; + } +} + + +/* Match any of the various end-block statements. Returns the type of + END to the caller. The END INTERFACE, END IF, END DO, END SELECT + and END BLOCK statements cannot be replaced by a single END statement. */ + +match +gfc_match_end (gfc_statement *st) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_compile_state state; + locus old_loc; + const char *block_name; + const char *target; + int eos_ok; + match m; + gfc_namespace *parent_ns, *ns, *prev_ns; + gfc_namespace **nsp; + bool abreviated_modproc_decl = false; + bool got_matching_end = false; + + old_loc = gfc_current_locus; + if (gfc_match ("end") != MATCH_YES) + return MATCH_NO; + + state = gfc_current_state (); + block_name = gfc_current_block () == NULL + ? NULL : gfc_current_block ()->name; + + switch (state) + { + case COMP_ASSOCIATE: + case COMP_BLOCK: + if (startswith (block_name, "block@")) + block_name = NULL; + break; + + case COMP_CONTAINS: + case COMP_DERIVED_CONTAINS: + state = gfc_state_stack->previous->state; + block_name = gfc_state_stack->previous->sym == NULL + ? NULL : gfc_state_stack->previous->sym->name; + abreviated_modproc_decl = gfc_state_stack->previous->sym + && gfc_state_stack->previous->sym->abr_modproc_decl; + break; + + default: + break; + } + + if (!abreviated_modproc_decl) + abreviated_modproc_decl = gfc_current_block () + && gfc_current_block ()->abr_modproc_decl; + + switch (state) + { + case COMP_NONE: + case COMP_PROGRAM: + *st = ST_END_PROGRAM; + target = " program"; + eos_ok = 1; + break; + + case COMP_SUBROUTINE: + *st = ST_END_SUBROUTINE; + if (!abreviated_modproc_decl) + target = " subroutine"; + else + target = " procedure"; + eos_ok = !contained_procedure (); + break; + + case COMP_FUNCTION: + *st = ST_END_FUNCTION; + if (!abreviated_modproc_decl) + target = " function"; + else + target = " procedure"; + eos_ok = !contained_procedure (); + break; + + case COMP_BLOCK_DATA: + *st = ST_END_BLOCK_DATA; + target = " block data"; + eos_ok = 1; + break; + + case COMP_MODULE: + *st = ST_END_MODULE; + target = " module"; + eos_ok = 1; + break; + + case COMP_SUBMODULE: + *st = ST_END_SUBMODULE; + target = " submodule"; + eos_ok = 1; + break; + + case COMP_INTERFACE: + *st = ST_END_INTERFACE; + target = " interface"; + eos_ok = 0; + break; + + case COMP_MAP: + *st = ST_END_MAP; + target = " map"; + eos_ok = 0; + break; + + case COMP_UNION: + *st = ST_END_UNION; + target = " union"; + eos_ok = 0; + break; + + case COMP_STRUCTURE: + *st = ST_END_STRUCTURE; + target = " structure"; + eos_ok = 0; + break; + + case COMP_DERIVED: + case COMP_DERIVED_CONTAINS: + *st = ST_END_TYPE; + target = " type"; + eos_ok = 0; + break; + + case COMP_ASSOCIATE: + *st = ST_END_ASSOCIATE; + target = " associate"; + eos_ok = 0; + break; + + case COMP_BLOCK: + case COMP_OMP_STRICTLY_STRUCTURED_BLOCK: + *st = ST_END_BLOCK; + target = " block"; + eos_ok = 0; + break; + + case COMP_IF: + *st = ST_ENDIF; + target = " if"; + eos_ok = 0; + break; + + case COMP_DO: + case COMP_DO_CONCURRENT: + *st = ST_ENDDO; + target = " do"; + eos_ok = 0; + break; + + case COMP_CRITICAL: + *st = ST_END_CRITICAL; + target = " critical"; + eos_ok = 0; + break; + + case COMP_SELECT: + case COMP_SELECT_TYPE: + case COMP_SELECT_RANK: + *st = ST_END_SELECT; + target = " select"; + eos_ok = 0; + break; + + case COMP_FORALL: + *st = ST_END_FORALL; + target = " forall"; + eos_ok = 0; + break; + + case COMP_WHERE: + *st = ST_END_WHERE; + target = " where"; + eos_ok = 0; + break; + + case COMP_ENUM: + *st = ST_END_ENUM; + target = " enum"; + eos_ok = 0; + last_initializer = NULL; + set_enum_kind (); + gfc_free_enum_history (); + break; + + default: + gfc_error ("Unexpected END statement at %C"); + goto cleanup; + } + + old_loc = gfc_current_locus; + if (gfc_match_eos () == MATCH_YES) + { + if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) + { + if (!gfc_notify_std (GFC_STD_F2008, "END statement " + "instead of %s statement at %L", + abreviated_modproc_decl ? "END PROCEDURE" + : gfc_ascii_statement(*st), &old_loc)) + goto cleanup; + } + else if (!eos_ok) + { + /* We would have required END [something]. */ + gfc_error ("%s statement expected at %L", + gfc_ascii_statement (*st), &old_loc); + goto cleanup; + } + + return MATCH_YES; + } + + /* Verify that we've got the sort of end-block that we're expecting. */ + if (gfc_match (target) != MATCH_YES) + { + gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl + ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc); + goto cleanup; + } + else + got_matching_end = true; + + old_loc = gfc_current_locus; + /* If we're at the end, make sure a block name wasn't required. */ + if (gfc_match_eos () == MATCH_YES) + { + + if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT + && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK + && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) + return MATCH_YES; + + if (!block_name) + return MATCH_YES; + + gfc_error ("Expected block name of %qs in %s statement at %L", + block_name, gfc_ascii_statement (*st), &old_loc); + + return MATCH_ERROR; + } + + /* END INTERFACE has a special handler for its several possible endings. */ + if (*st == ST_END_INTERFACE) + return gfc_match_end_interface (); + + /* We haven't hit the end of statement, so what is left must be an + end-name. */ + m = gfc_match_space (); + if (m == MATCH_YES) + m = gfc_match_name (name); + + if (m == MATCH_NO) + gfc_error ("Expected terminating name at %C"); + if (m != MATCH_YES) + goto cleanup; + + if (block_name == NULL) + goto syntax; + + /* We have to pick out the declared submodule name from the composite + required by F2008:11.2.3 para 2, which ends in the declared name. */ + if (state == COMP_SUBMODULE) + block_name = strchr (block_name, '.') + 1; + + if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) + { + gfc_error ("Expected label %qs for %s statement at %C", block_name, + gfc_ascii_statement (*st)); + goto cleanup; + } + /* Procedure pointer as function result. */ + else if (strcmp (block_name, "ppr@") == 0 + && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) + { + gfc_error ("Expected label %qs for %s statement at %C", + gfc_current_block ()->ns->proc_name->name, + gfc_ascii_statement (*st)); + goto cleanup; + } + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + +syntax: + gfc_syntax_error (*st); + +cleanup: + gfc_current_locus = old_loc; + + /* If we are missing an END BLOCK, we created a half-ready namespace. + Remove it from the parent namespace's sibling list. */ + + while (state == COMP_BLOCK && !got_matching_end) + { + parent_ns = gfc_current_ns->parent; + + nsp = &(gfc_state_stack->previous->tail->ext.block.ns); + + prev_ns = NULL; + ns = *nsp; + while (ns) + { + if (ns == gfc_current_ns) + { + if (prev_ns == NULL) + *nsp = NULL; + else + prev_ns->sibling = ns->sibling; + } + prev_ns = ns; + ns = ns->sibling; + } + + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = parent_ns; + gfc_state_stack = gfc_state_stack->previous; + state = gfc_current_state (); + } + + return MATCH_ERROR; +} + + + +/***************** Attribute declaration statements ****************/ + +/* Set the attribute of a single variable. */ + +static match +attr_decl1 (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_array_spec *as; + + /* Workaround -Wmaybe-uninitialized false positive during + profiledbootstrap by initializing them. */ + gfc_symbol *sym = NULL; + locus var_locus; + match m; + + as = NULL; + + m = gfc_match_name (name); + if (m != MATCH_YES) + goto cleanup; + + if (find_special (name, &sym, false)) + return MATCH_ERROR; + + if (!check_function_name (name)) + { + m = MATCH_ERROR; + goto cleanup; + } + + var_locus = gfc_current_locus; + + /* Deal with possible array specification for certain attributes. */ + if (current_attr.dimension + || current_attr.codimension + || current_attr.allocatable + || current_attr.pointer + || current_attr.target) + { + m = gfc_match_array_spec (&as, !current_attr.codimension, + !current_attr.dimension + && !current_attr.pointer + && !current_attr.target); + if (m == MATCH_ERROR) + goto cleanup; + + if (current_attr.dimension && m == MATCH_NO) + { + gfc_error ("Missing array specification at %L in DIMENSION " + "statement", &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + + if (current_attr.dimension && sym->value) + { + gfc_error ("Dimensions specified for %s at %L after its " + "initialization", sym->name, &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + + if (current_attr.codimension && m == MATCH_NO) + { + gfc_error ("Missing array specification at %L in CODIMENSION " + "statement", &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + + if ((current_attr.allocatable || current_attr.pointer) + && (m == MATCH_YES) && (as->type != AS_DEFERRED)) + { + gfc_error ("Array specification must be deferred at %L", &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + } + + /* Update symbol table. DIMENSION attribute is set in + gfc_set_array_spec(). For CLASS variables, this must be applied + to the first component, or '_data' field. */ + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class) + { + /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check + for duplicate attribute here. */ + if (CLASS_DATA(sym)->attr.dimension == 1 && as) + { + gfc_error ("Duplicate DIMENSION attribute at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + } + else + { + if (current_attr.dimension == 0 && current_attr.codimension == 0 + && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + } + + if (sym->ts.type == BT_CLASS + && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (!gfc_set_array_spec (sym, as, &var_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (sym->attr.cray_pointee && sym->as != NULL) + { + /* Fix the array spec. */ + m = gfc_mod_pointee_as (sym->as); + if (m == MATCH_ERROR) + goto cleanup; + } + + if (!gfc_add_attribute (&sym->attr, &var_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + + if ((current_attr.external || current_attr.intrinsic) + && sym->attr.flavor != FL_PROCEDURE + && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL)) + { + m = MATCH_ERROR; + goto cleanup; + } + + add_hidden_procptr_result (sym); + + return MATCH_YES; + +cleanup: + gfc_free_array_spec (as); + return m; +} + + +/* Generic attribute declaration subroutine. Used for attributes that + just have a list of names. */ + +static match +attr_decl (void) +{ + match m; + + /* Gobble the optional double colon, by simply ignoring the result + of gfc_match(). */ + gfc_match (" ::"); + + for (;;) + { + m = attr_decl1 (); + if (m != MATCH_YES) + break; + + if (gfc_match_eos () == MATCH_YES) + { + m = MATCH_YES; + break; + } + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Unexpected character in variable list at %C"); + m = MATCH_ERROR; + break; + } + } + + return m; +} + + +/* This routine matches Cray Pointer declarations of the form: + pointer ( , ) + or + pointer ( , ), ( , ), ... + The pointer, if already declared, should be an integer. Otherwise, we + set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may + be either a scalar, or an array declaration. No space is allocated for + the pointee. For the statement + pointer (ipt, ar(10)) + any subsequent uses of ar will be translated (in C-notation) as + ar(i) => (( *) ipt)(i) + After gimplification, pointee variable will disappear in the code. */ + +static match +cray_pointer_decl (void) +{ + match m; + gfc_array_spec *as = NULL; + gfc_symbol *cptr; /* Pointer symbol. */ + gfc_symbol *cpte; /* Pointee symbol. */ + locus var_locus; + bool done = false; + + while (!done) + { + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected %<(%> at %C"); + return MATCH_ERROR; + } + + /* Match pointer. */ + var_locus = gfc_current_locus; + gfc_clear_attr (¤t_attr); + gfc_add_cray_pointer (¤t_attr, &var_locus); + current_ts.type = BT_INTEGER; + current_ts.kind = gfc_index_integer_kind; + + m = gfc_match_symbol (&cptr, 0); + if (m != MATCH_YES) + { + gfc_error ("Expected variable name at %C"); + return m; + } + + if (!gfc_add_cray_pointer (&cptr->attr, &var_locus)) + return MATCH_ERROR; + + gfc_set_sym_referenced (cptr); + + if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */ + { + cptr->ts.type = BT_INTEGER; + cptr->ts.kind = gfc_index_integer_kind; + } + else if (cptr->ts.type != BT_INTEGER) + { + gfc_error ("Cray pointer at %C must be an integer"); + return MATCH_ERROR; + } + else if (cptr->ts.kind < gfc_index_integer_kind) + gfc_warning (0, "Cray pointer at %C has %d bytes of precision;" + " memory addresses require %d bytes", + cptr->ts.kind, gfc_index_integer_kind); + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected \",\" at %C"); + return MATCH_ERROR; + } + + /* Match Pointee. */ + var_locus = gfc_current_locus; + gfc_clear_attr (¤t_attr); + gfc_add_cray_pointee (¤t_attr, &var_locus); + current_ts.type = BT_UNKNOWN; + current_ts.kind = 0; + + m = gfc_match_symbol (&cpte, 0); + if (m != MATCH_YES) + { + gfc_error ("Expected variable name at %C"); + return m; + } + + /* Check for an optional array spec. */ + m = gfc_match_array_spec (&as, true, false); + if (m == MATCH_ERROR) + { + gfc_free_array_spec (as); + return m; + } + else if (m == MATCH_NO) + { + gfc_free_array_spec (as); + as = NULL; + } + + if (!gfc_add_cray_pointee (&cpte->attr, &var_locus)) + return MATCH_ERROR; + + gfc_set_sym_referenced (cpte); + + if (cpte->as == NULL) + { + if (!gfc_set_array_spec (cpte, as, &var_locus)) + gfc_internal_error ("Cannot set Cray pointee array spec."); + } + else if (as != NULL) + { + gfc_error ("Duplicate array spec for Cray pointee at %C"); + gfc_free_array_spec (as); + return MATCH_ERROR; + } + + as = NULL; + + if (cpte->as != NULL) + { + /* Fix array spec. */ + m = gfc_mod_pointee_as (cpte->as); + if (m == MATCH_ERROR) + return m; + } + + /* Point the Pointee at the Pointer. */ + cpte->cp_pointer = cptr; + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Expected \")\" at %C"); + return MATCH_ERROR; + } + m = gfc_match_char (','); + if (m != MATCH_YES) + done = true; /* Stop searching for more declarations. */ + + } + + if (m == MATCH_ERROR /* Failed when trying to find ',' above. */ + || gfc_match_eos () != MATCH_YES) + { + gfc_error ("Expected %<,%> or end of statement at %C"); + return MATCH_ERROR; + } + return MATCH_YES; +} + + +match +gfc_match_external (void) +{ + + gfc_clear_attr (¤t_attr); + current_attr.external = 1; + + return attr_decl (); +} + + +match +gfc_match_intent (void) +{ + sym_intent intent; + + /* This is not allowed within a BLOCK construct! */ + if (gfc_current_state () == COMP_BLOCK) + { + gfc_error ("INTENT is not allowed inside of BLOCK at %C"); + return MATCH_ERROR; + } + + intent = match_intent_spec (); + if (intent == INTENT_UNKNOWN) + return MATCH_ERROR; + + gfc_clear_attr (¤t_attr); + current_attr.intent = intent; + + return attr_decl (); +} + + +match +gfc_match_intrinsic (void) +{ + + gfc_clear_attr (¤t_attr); + current_attr.intrinsic = 1; + + return attr_decl (); +} + + +match +gfc_match_optional (void) +{ + /* This is not allowed within a BLOCK construct! */ + if (gfc_current_state () == COMP_BLOCK) + { + gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C"); + return MATCH_ERROR; + } + + gfc_clear_attr (¤t_attr); + current_attr.optional = 1; + + return attr_decl (); +} + + +match +gfc_match_pointer (void) +{ + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '(') + { + if (!flag_cray_pointer) + { + gfc_error ("Cray pointer declaration at %C requires " + "%<-fcray-pointer%> flag"); + return MATCH_ERROR; + } + return cray_pointer_decl (); + } + else + { + gfc_clear_attr (¤t_attr); + current_attr.pointer = 1; + + return attr_decl (); + } +} + + +match +gfc_match_allocatable (void) +{ + gfc_clear_attr (¤t_attr); + current_attr.allocatable = 1; + + return attr_decl (); +} + + +match +gfc_match_codimension (void) +{ + gfc_clear_attr (¤t_attr); + current_attr.codimension = 1; + + return attr_decl (); +} + + +match +gfc_match_contiguous (void) +{ + if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C")) + return MATCH_ERROR; + + gfc_clear_attr (¤t_attr); + current_attr.contiguous = 1; + + return attr_decl (); +} + + +match +gfc_match_dimension (void) +{ + gfc_clear_attr (¤t_attr); + current_attr.dimension = 1; + + return attr_decl (); +} + + +match +gfc_match_target (void) +{ + gfc_clear_attr (¤t_attr); + current_attr.target = 1; + + return attr_decl (); +} + + +/* Match the list of entities being specified in a PUBLIC or PRIVATE + statement. */ + +static match +access_attr_decl (gfc_statement st) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + interface_type type; + gfc_user_op *uop; + gfc_symbol *sym, *dt_sym; + gfc_intrinsic_op op; + match m; + gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; + + if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) + goto done; + + for (;;) + { + m = gfc_match_generic_spec (&type, name, &op); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto done; + + switch (type) + { + case INTERFACE_NAMELESS: + case INTERFACE_ABSTRACT: + goto syntax; + + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + + if (gfc_get_symbol (name, NULL, &sym)) + goto done; + + if (type == INTERFACE_DTIO + && gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE + && sym->attr.flavor == FL_UNKNOWN) + sym->attr.flavor = FL_PROCEDURE; + + if (!gfc_add_access (&sym->attr, access, sym->name, NULL)) + goto done; + + if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym)) + && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL)) + goto done; + + break; + + case INTERFACE_INTRINSIC_OP: + if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN) + { + gfc_intrinsic_op other_op; + + gfc_current_ns->operator_access[op] = access; + + /* Handle the case if there is another op with the same + function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */ + other_op = gfc_equivalent_op (op); + + if (other_op != INTRINSIC_NONE) + gfc_current_ns->operator_access[other_op] = access; + } + else + { + gfc_error ("Access specification of the %s operator at %C has " + "already been specified", gfc_op2string (op)); + goto done; + } + + break; + + case INTERFACE_USER_OP: + uop = gfc_get_uop (name); + + if (uop->access == ACCESS_UNKNOWN) + { + uop->access = access; + } + else + { + gfc_error ("Access specification of the .%s. operator at %C " + "has already been specified", uop->name); + goto done; + } + + break; + } + + if (gfc_match_char (',') == MATCH_NO) + break; + } + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +done: + return MATCH_ERROR; +} + + +match +gfc_match_protected (void) +{ + gfc_symbol *sym; + match m; + char c; + + /* PROTECTED has already been seen, but must be followed by whitespace + or ::. */ + c = gfc_peek_ascii_char (); + if (!gfc_is_whitespace (c) && c != ':') + return MATCH_NO; + + if (!gfc_current_ns->proc_name + || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) + { + gfc_error ("PROTECTED at %C only allowed in specification " + "part of a module"); + return MATCH_ERROR; + + } + + gfc_match (" ::"); + + if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C")) + return MATCH_ERROR; + + /* PROTECTED has an entity-list. */ + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for(;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in PROTECTED statement at %C"); + return MATCH_ERROR; +} + + +/* The PRIVATE statement is a bit weird in that it can be an attribute + declaration, but also works as a standalone statement inside of a + type declaration or a module. */ + +match +gfc_match_private (gfc_statement *st) +{ + gfc_state_data *prev; + + if (gfc_match ("private") != MATCH_YES) + return MATCH_NO; + + /* Try matching PRIVATE without an access-list. */ + if (gfc_match_eos () == MATCH_YES) + { + prev = gfc_state_stack->previous; + if (gfc_current_state () != COMP_MODULE + && !(gfc_current_state () == COMP_DERIVED + && prev && prev->state == COMP_MODULE) + && !(gfc_current_state () == COMP_DERIVED_CONTAINS + && prev->previous && prev->previous->state == COMP_MODULE)) + { + gfc_error ("PRIVATE statement at %C is only allowed in the " + "specification part of a module"); + return MATCH_ERROR; + } + + *st = ST_PRIVATE; + return MATCH_YES; + } + + /* At this point in free-form source code, PRIVATE must be followed + by whitespace or ::. */ + if (gfc_current_form == FORM_FREE) + { + char c = gfc_peek_ascii_char (); + if (!gfc_is_whitespace (c) && c != ':') + return MATCH_NO; + } + + prev = gfc_state_stack->previous; + if (gfc_current_state () != COMP_MODULE + && !(gfc_current_state () == COMP_DERIVED + && prev && prev->state == COMP_MODULE) + && !(gfc_current_state () == COMP_DERIVED_CONTAINS + && prev->previous && prev->previous->state == COMP_MODULE)) + { + gfc_error ("PRIVATE statement at %C is only allowed in the " + "specification part of a module"); + return MATCH_ERROR; + } + + *st = ST_ATTR_DECL; + return access_attr_decl (ST_PRIVATE); +} + + +match +gfc_match_public (gfc_statement *st) +{ + if (gfc_match ("public") != MATCH_YES) + return MATCH_NO; + + /* Try matching PUBLIC without an access-list. */ + if (gfc_match_eos () == MATCH_YES) + { + if (gfc_current_state () != COMP_MODULE) + { + gfc_error ("PUBLIC statement at %C is only allowed in the " + "specification part of a module"); + return MATCH_ERROR; + } + + *st = ST_PUBLIC; + return MATCH_YES; + } + + /* At this point in free-form source code, PUBLIC must be followed + by whitespace or ::. */ + if (gfc_current_form == FORM_FREE) + { + char c = gfc_peek_ascii_char (); + if (!gfc_is_whitespace (c) && c != ':') + return MATCH_NO; + } + + if (gfc_current_state () != COMP_MODULE) + { + gfc_error ("PUBLIC statement at %C is only allowed in the " + "specification part of a module"); + return MATCH_ERROR; + } + + *st = ST_ATTR_DECL; + return access_attr_decl (ST_PUBLIC); +} + + +/* Workhorse for gfc_match_parameter. */ + +static match +do_parm (void) +{ + gfc_symbol *sym; + gfc_expr *init; + match m; + bool t; + + m = gfc_match_symbol (&sym, 0); + if (m == MATCH_NO) + gfc_error ("Expected variable name at %C in PARAMETER statement"); + + if (m != MATCH_YES) + return m; + + if (gfc_match_char ('=') == MATCH_NO) + { + gfc_error ("Expected = sign in PARAMETER statement at %C"); + return MATCH_ERROR; + } + + m = gfc_match_init_expr (&init); + if (m == MATCH_NO) + gfc_error ("Expected expression at %C in PARAMETER statement"); + if (m != MATCH_YES) + return m; + + if (sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (sym, 1, NULL)) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (!gfc_check_assign_symbol (sym, NULL, init) + || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL)) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (sym->value) + { + gfc_error ("Initializing already initialized variable at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus); + return (t) ? MATCH_YES : MATCH_ERROR; + +cleanup: + gfc_free_expr (init); + return m; +} + + +/* Match a parameter statement, with the weird syntax that these have. */ + +match +gfc_match_parameter (void) +{ + const char *term = " )%t"; + match m; + + if (gfc_match_char ('(') == MATCH_NO) + { + /* With legacy PARAMETER statements, don't expect a terminating ')'. */ + if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C")) + return MATCH_NO; + term = " %t"; + } + + for (;;) + { + m = do_parm (); + if (m != MATCH_YES) + break; + + if (gfc_match (term) == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Unexpected characters in PARAMETER statement at %C"); + m = MATCH_ERROR; + break; + } + } + + return m; +} + + +match +gfc_match_automatic (void) +{ + gfc_symbol *sym; + match m; + bool seen_symbol = false; + + if (!flag_dec_static) + { + gfc_error ("%s at %C is a DEC extension, enable with " + "%<-fdec-static%>", + "AUTOMATIC" + ); + return MATCH_ERROR; + } + + gfc_match (" ::"); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + + case MATCH_YES: + if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus)) + return MATCH_ERROR; + seen_symbol = true; + break; + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + if (!seen_symbol) + { + gfc_error ("Expected entity-list in AUTOMATIC statement at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in AUTOMATIC statement at %C"); + return MATCH_ERROR; +} + + +match +gfc_match_static (void) +{ + gfc_symbol *sym; + match m; + bool seen_symbol = false; + + if (!flag_dec_static) + { + gfc_error ("%s at %C is a DEC extension, enable with " + "%<-fdec-static%>", + "STATIC"); + return MATCH_ERROR; + } + + gfc_match (" ::"); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + + case MATCH_YES: + if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, + &gfc_current_locus)) + return MATCH_ERROR; + seen_symbol = true; + break; + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + if (!seen_symbol) + { + gfc_error ("Expected entity-list in STATIC statement at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in STATIC statement at %C"); + return MATCH_ERROR; +} + + +/* Save statements have a special syntax. */ + +match +gfc_match_save (void) +{ + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_common_head *c; + gfc_symbol *sym; + match m; + + if (gfc_match_eos () == MATCH_YES) + { + if (gfc_current_ns->seen_save) + { + if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C " + "follows previous SAVE statement")) + return MATCH_ERROR; + } + + gfc_current_ns->save_all = gfc_current_ns->seen_save = 1; + return MATCH_YES; + } + + if (gfc_current_ns->save_all) + { + if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows " + "blanket SAVE statement")) + return MATCH_ERROR; + } + + gfc_match (" ::"); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, + &gfc_current_locus)) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + m = gfc_match (" / %n /", &n); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + c = gfc_get_common (n, 0); + c->saved = 1; + + gfc_current_ns->seen_save = 1; + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + if (gfc_current_ns->seen_save) + { + gfc_error ("Syntax error in SAVE statement at %C"); + return MATCH_ERROR; + } + else + return MATCH_NO; +} + + +match +gfc_match_value (void) +{ + gfc_symbol *sym; + match m; + + /* This is not allowed within a BLOCK construct! */ + if (gfc_current_state () == COMP_BLOCK) + { + gfc_error ("VALUE is not allowed inside of BLOCK at %C"); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C")) + return MATCH_ERROR; + + if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) + { + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for(;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in VALUE statement at %C"); + return MATCH_ERROR; +} + + +match +gfc_match_volatile (void) +{ + gfc_symbol *sym; + char *name; + match m; + + if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C")) + return MATCH_ERROR; + + if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) + { + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for(;;) + { + /* VOLATILE is special because it can be added to host-associated + symbols locally. Except for coarrays. */ + m = gfc_match_symbol (&sym, 1); + switch (m) + { + case MATCH_YES: + name = XCNEWVAR (char, strlen (sym->name) + 1); + strcpy (name, sym->name); + if (!check_function_name (name)) + return MATCH_ERROR; + /* F2008, C560+C561. VOLATILE for host-/use-associated variable or + for variable in a BLOCK which is defined outside of the BLOCK. */ + if (sym->ns != gfc_current_ns && sym->attr.codimension) + { + gfc_error ("Specifying VOLATILE for coarray variable %qs at " + "%C, which is use-/host-associated", sym->name); + return MATCH_ERROR; + } + if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in VOLATILE statement at %C"); + return MATCH_ERROR; +} + + +match +gfc_match_asynchronous (void) +{ + gfc_symbol *sym; + char *name; + match m; + + if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C")) + return MATCH_ERROR; + + if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) + { + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for(;;) + { + /* ASYNCHRONOUS is special because it can be added to host-associated + symbols locally. */ + m = gfc_match_symbol (&sym, 1); + switch (m) + { + case MATCH_YES: + name = XCNEWVAR (char, strlen (sym->name) + 1); + strcpy (name, sym->name); + if (!check_function_name (name)) + return MATCH_ERROR; + if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus)) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in ASYNCHRONOUS statement at %C"); + return MATCH_ERROR; +} + + +/* Match a module procedure statement in a submodule. */ + +match +gfc_match_submod_proc (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym, *fsym; + match m; + gfc_formal_arglist *formal, *head, *tail; + + if (gfc_current_state () != COMP_CONTAINS + || !(gfc_state_stack->previous + && (gfc_state_stack->previous->state == COMP_SUBMODULE + || gfc_state_stack->previous->state == COMP_MODULE))) + return MATCH_NO; + + m = gfc_match (" module% procedure% %n", name); + if (m != MATCH_YES) + return m; + + if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration " + "at %C")) + return MATCH_ERROR; + + if (get_proc_name (name, &sym, false)) + return MATCH_ERROR; + + /* Make sure that the result field is appropriately filled. */ + if (sym->tlink && sym->tlink->attr.function) + { + if (sym->tlink->result && sym->tlink->result != sym->tlink) + { + sym->result = sym->tlink->result; + if (!sym->result->attr.use_assoc) + { + gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root, + sym->result->name); + st->n.sym = sym->result; + sym->result->refs++; + } + } + else + sym->result = sym; + } + + /* Set declared_at as it might point to, e.g., a PUBLIC statement, if + the symbol existed before. */ + sym->declared_at = gfc_current_locus; + + if (!sym->attr.module_procedure) + return MATCH_ERROR; + + /* Signal match_end to expect "end procedure". */ + sym->abr_modproc_decl = 1; + + /* Change from IFSRC_IFBODY coming from the interface declaration. */ + sym->attr.if_source = IFSRC_DECL; + + gfc_new_block = sym; + + /* Make a new formal arglist with the symbols in the procedure + namespace. */ + head = tail = NULL; + for (formal = sym->formal; formal && formal->sym; formal = formal->next) + { + if (formal == sym->formal) + head = tail = gfc_get_formal_arglist (); + else + { + tail->next = gfc_get_formal_arglist (); + tail = tail->next; + } + + if (gfc_copy_dummy_sym (&fsym, formal->sym, 0)) + goto cleanup; + + tail->sym = fsym; + gfc_set_sym_referenced (fsym); + } + + /* The dummy symbols get cleaned up, when the formal_namespace of the + interface declaration is cleared. This allows us to add the + explicit interface as is done for other type of procedure. */ + if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head, + &gfc_current_locus)) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are + undone, such that the st->n.sym->formal points to the original symbol; + if now this namespace is finalized, the formal namespace is freed, + but it might be still needed in the parent namespace. */ + gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name); + st->n.sym = NULL; + gfc_free_symbol (sym->tlink); + sym->tlink = NULL; + sym->refs--; + gfc_syntax_error (ST_MODULE_PROC); + return MATCH_ERROR; + } + + return MATCH_YES; + +cleanup: + gfc_free_formal_arglist (head); + return MATCH_ERROR; +} + + +/* Match a module procedure statement. Note that we have to modify + symbols in the parent's namespace because the current one was there + to receive symbols that are in an interface's formal argument list. */ + +match +gfc_match_modproc (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + locus old_locus; + gfc_namespace *module_ns; + gfc_interface *old_interface_head, *interface; + + if ((gfc_state_stack->state != COMP_INTERFACE + && gfc_state_stack->state != COMP_CONTAINS) + || gfc_state_stack->previous == NULL + || current_interface.type == INTERFACE_NAMELESS + || current_interface.type == INTERFACE_ABSTRACT) + { + gfc_error ("MODULE PROCEDURE at %C must be in a generic module " + "interface"); + return MATCH_ERROR; + } + + module_ns = gfc_current_ns->parent; + for (; module_ns; module_ns = module_ns->parent) + if (module_ns->proc_name->attr.flavor == FL_MODULE + || module_ns->proc_name->attr.flavor == FL_PROGRAM + || (module_ns->proc_name->attr.flavor == FL_PROCEDURE + && !module_ns->proc_name->attr.contained)) + break; + + if (module_ns == NULL) + return MATCH_ERROR; + + /* Store the current state of the interface. We will need it if we + end up with a syntax error and need to recover. */ + old_interface_head = gfc_current_interface_head (); + + /* Check if the F2008 optional double colon appears. */ + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + if (gfc_match ("::") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2008, "double colon in " + "MODULE PROCEDURE statement at %L", &old_locus)) + return MATCH_ERROR; + } + else + gfc_current_locus = old_locus; + + for (;;) + { + bool last = false; + old_locus = gfc_current_locus; + + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return MATCH_ERROR; + + /* Check for syntax error before starting to add symbols to the + current namespace. */ + if (gfc_match_eos () == MATCH_YES) + last = true; + + if (!last && gfc_match_char (',') != MATCH_YES) + goto syntax; + + /* Now we're sure the syntax is valid, we process this item + further. */ + if (gfc_get_symbol (name, module_ns, &sym)) + return MATCH_ERROR; + + if (sym->attr.intrinsic) + { + gfc_error ("Intrinsic procedure at %L cannot be a MODULE " + "PROCEDURE", &old_locus); + return MATCH_ERROR; + } + + if (sym->attr.proc != PROC_MODULE + && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) + return MATCH_ERROR; + + if (!gfc_add_interface (sym)) + return MATCH_ERROR; + + sym->attr.mod_proc = 1; + sym->declared_at = old_locus; + + if (last) + break; + } + + return MATCH_YES; + +syntax: + /* Restore the previous state of the interface. */ + interface = gfc_current_interface_head (); + gfc_set_current_interface_head (old_interface_head); + + /* Free the new interfaces. */ + while (interface != old_interface_head) + { + gfc_interface *i = interface->next; + free (interface); + interface = i; + } + + /* And issue a syntax error. */ + gfc_syntax_error (ST_MODULE_PROC); + return MATCH_ERROR; +} + + +/* Check a derived type that is being extended. */ + +static gfc_symbol* +check_extended_derived_type (char *name) +{ + gfc_symbol *extended; + + if (gfc_find_symbol (name, gfc_current_ns, 1, &extended)) + { + gfc_error ("Ambiguous symbol in TYPE definition at %C"); + return NULL; + } + + extended = gfc_find_dt_in_generic (extended); + + /* F08:C428. */ + if (!extended) + { + gfc_error ("Symbol %qs at %C has not been previously defined", name); + return NULL; + } + + if (extended->attr.flavor != FL_DERIVED) + { + gfc_error ("%qs in EXTENDS expression at %C is not a " + "derived type", name); + return NULL; + } + + if (extended->attr.is_bind_c) + { + gfc_error ("%qs cannot be extended at %C because it " + "is BIND(C)", extended->name); + return NULL; + } + + if (extended->attr.sequence) + { + gfc_error ("%qs cannot be extended at %C because it " + "is a SEQUENCE type", extended->name); + return NULL; + } + + return extended; +} + + +/* Match the optional attribute specifiers for a type declaration. + Return MATCH_ERROR if an error is encountered in one of the handled + attributes (public, private, bind(c)), MATCH_NO if what's found is + not a handled attribute, and MATCH_YES otherwise. TODO: More error + checking on attribute conflicts needs to be done. */ + +static match +gfc_get_type_attr_spec (symbol_attribute *attr, char *name) +{ + /* See if the derived type is marked as private. */ + if (gfc_match (" , private") == MATCH_YES) + { + if (gfc_current_state () != COMP_MODULE) + { + gfc_error ("Derived type at %C can only be PRIVATE in the " + "specification part of a module"); + return MATCH_ERROR; + } + + if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL)) + return MATCH_ERROR; + } + else if (gfc_match (" , public") == MATCH_YES) + { + if (gfc_current_state () != COMP_MODULE) + { + gfc_error ("Derived type at %C can only be PUBLIC in the " + "specification part of a module"); + return MATCH_ERROR; + } + + if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL)) + return MATCH_ERROR; + } + else if (gfc_match (" , bind ( c )") == MATCH_YES) + { + /* If the type is defined to be bind(c) it then needs to make + sure that all fields are interoperable. This will + need to be a semantic check on the finished derived type. + See 15.2.3 (lines 9-12) of F2003 draft. */ + if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0)) + return MATCH_ERROR; + + /* TODO: attr conflicts need to be checked, probably in symbol.c. */ + } + else if (gfc_match (" , abstract") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C")) + return MATCH_ERROR; + + if (!gfc_add_abstract (attr, &gfc_current_locus)) + return MATCH_ERROR; + } + else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES) + { + if (!gfc_add_extension (attr, &gfc_current_locus)) + return MATCH_ERROR; + } + else + return MATCH_NO; + + /* If we get here, something matched. */ + return MATCH_YES; +} + + +/* Common function for type declaration blocks similar to derived types, such + as STRUCTURES and MAPs. Unlike derived types, a structure type + does NOT have a generic symbol matching the name given by the user. + STRUCTUREs can share names with variables and PARAMETERs so we must allow + for the creation of an independent symbol. + Other parameters are a message to prefix errors with, the name of the new + type to be created, and the flavor to add to the resulting symbol. */ + +static bool +get_struct_decl (const char *name, sym_flavor fl, locus *decl, + gfc_symbol **result) +{ + gfc_symbol *sym; + locus where; + + gcc_assert (name[0] == (char) TOUPPER (name[0])); + + if (decl) + where = *decl; + else + where = gfc_current_locus; + + if (gfc_get_symbol (name, NULL, &sym)) + return false; + + if (!sym) + { + gfc_internal_error ("Failed to create structure type '%s' at %C", name); + return false; + } + + if (sym->components != NULL || sym->attr.zero_comp) + { + gfc_error ("Type definition of %qs at %C was already defined at %L", + sym->name, &sym->declared_at); + return false; + } + + sym->declared_at = where; + + if (sym->attr.flavor != fl + && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL)) + return false; + + if (!sym->hash_value) + /* Set the hash for the compound name for this type. */ + sym->hash_value = gfc_hash_value (sym); + + /* Normally the type is expected to have been completely parsed by the time + a field declaration with this type is seen. For unions, maps, and nested + structure declarations, we need to indicate that it is okay that we + haven't seen any components yet. This will be updated after the structure + is fully parsed. */ + sym->attr.zero_comp = 0; + + /* Structures always act like derived-types with the SEQUENCE attribute */ + gfc_add_sequence (&sym->attr, sym->name, NULL); + + if (result) *result = sym; + + return true; +} + + +/* Match the opening of a MAP block. Like a struct within a union in C; + behaves identical to STRUCTURE blocks. */ + +match +gfc_match_map (void) +{ + /* Counter used to give unique internal names to map structures. */ + static unsigned int gfc_map_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + locus old_loc; + + old_loc = gfc_current_locus; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after MAP statement at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + /* Map blocks are anonymous so we make up unique names for the symbol table + which are invalid Fortran identifiers. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++); + + if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym)) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Match the opening of a UNION block. */ + +match +gfc_match_union (void) +{ + /* Counter used to give unique internal names to union types. */ + static unsigned int gfc_union_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + locus old_loc; + + old_loc = gfc_current_locus; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after UNION statement at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + /* Unions are anonymous so we make up unique names for the symbol table + which are invalid Fortran identifiers. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++); + + if (!get_struct_decl (name, FL_UNION, &old_loc, &sym)) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Match the beginning of a STRUCTURE declaration. This is similar to + matching the beginning of a derived type declaration with a few + twists. The resulting type symbol has no access control or other + interesting attributes. */ + +match +gfc_match_structure_decl (void) +{ + /* Counter used to give unique internal names to anonymous structures. */ + static unsigned int gfc_structure_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + locus where; + + if (!flag_dec_structure) + { + gfc_error ("%s at %C is a DEC extension, enable with " + "%<-fdec-structure%>", + "STRUCTURE"); + return MATCH_ERROR; + } + + name[0] = '\0'; + + m = gfc_match (" /%n/", name); + if (m != MATCH_YES) + { + /* Non-nested structure declarations require a structure name. */ + if (!gfc_comp_struct (gfc_current_state ())) + { + gfc_error ("Structure name expected in non-nested structure " + "declaration at %C"); + return MATCH_ERROR; + } + /* This is an anonymous structure; make up a unique name for it + (upper-case letters never make it to symbol names from the source). + The important thing is initializing the type variable + and setting gfc_new_symbol, which is immediately used by + parse_structure () and variable_decl () to add components of + this type. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++); + } + + where = gfc_current_locus; + /* No field list allowed after non-nested structure declaration. */ + if (!gfc_comp_struct (gfc_current_state ()) + && gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after non-nested STRUCTURE statement at %C"); + return MATCH_ERROR; + } + + /* Make sure the name is not the name of an intrinsic type. */ + if (gfc_is_intrinsic_typename (name)) + { + gfc_error ("Structure name %qs at %C cannot be the same as an" + " intrinsic type", name); + return MATCH_ERROR; + } + + /* Store the actual type symbol for the structure with an upper-case first + letter (an invalid Fortran identifier). */ + + if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym)) + return MATCH_ERROR; + + gfc_new_block = sym; + return MATCH_YES; +} + + +/* This function does some work to determine which matcher should be used to + * match a statement beginning with "TYPE". This is used to disambiguate TYPE + * as an alias for PRINT from derived type declarations, TYPE IS statements, + * and [parameterized] derived type declarations. */ + +match +gfc_match_type (gfc_statement *st) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + locus old_loc; + + /* Requires -fdec. */ + if (!flag_dec) + return MATCH_NO; + + m = gfc_match ("type"); + if (m != MATCH_YES) + return m; + /* If we already have an error in the buffer, it is probably from failing to + * match a derived type data declaration. Let it happen. */ + else if (gfc_error_flag_test ()) + return MATCH_NO; + + old_loc = gfc_current_locus; + *st = ST_NONE; + + /* If we see an attribute list before anything else it's definitely a derived + * type declaration. */ + if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES) + goto derived; + + /* By now "TYPE" has already been matched. If we do not see a name, this may + * be something like "TYPE *" or "TYPE ". */ + m = gfc_match_name (name); + if (m != MATCH_YES) + { + /* Let print match if it can, otherwise throw an error from + * gfc_match_derived_decl. */ + gfc_current_locus = old_loc; + if (gfc_match_print () == MATCH_YES) + { + *st = ST_WRITE; + return MATCH_YES; + } + goto derived; + } + + /* Check for EOS. */ + if (gfc_match_eos () == MATCH_YES) + { + /* By now we have "TYPE ". Check first if the name is an + * intrinsic typename - if so let gfc_match_derived_decl dump an error. + * Otherwise if gfc_match_derived_decl fails it's probably an existing + * symbol which can be printed. */ + gfc_current_locus = old_loc; + m = gfc_match_derived_decl (); + if (gfc_is_intrinsic_typename (name) || m == MATCH_YES) + { + *st = ST_DERIVED_DECL; + return m; + } + } + else + { + /* Here we have "TYPE ". Check for or a PDT declaration + like . */ + gfc_gobble_whitespace (); + bool paren = gfc_peek_ascii_char () == '('; + if (paren) + { + if (strcmp ("is", name) == 0) + goto typeis; + else + goto derived; + } + } + + /* Treat TYPE... like PRINT... */ + gfc_current_locus = old_loc; + *st = ST_WRITE; + return gfc_match_print (); + +derived: + gfc_current_locus = old_loc; + *st = ST_DERIVED_DECL; + return gfc_match_derived_decl (); + +typeis: + gfc_current_locus = old_loc; + *st = ST_TYPE_IS; + return gfc_match_type_is (); +} + + +/* Match the beginning of a derived type declaration. If a type name + was the result of a function, then it is possible to have a symbol + already to be known as a derived type yet have no components. */ + +match +gfc_match_derived_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + char parent[GFC_MAX_SYMBOL_LEN + 1]; + symbol_attribute attr; + gfc_symbol *sym, *gensym; + gfc_symbol *extended; + match m; + match is_type_attr_spec = MATCH_NO; + bool seen_attr = false; + gfc_interface *intr = NULL, *head; + bool parameterized_type = false; + bool seen_colons = false; + + if (gfc_comp_struct (gfc_current_state ())) + return MATCH_NO; + + name[0] = '\0'; + parent[0] = '\0'; + gfc_clear_attr (&attr); + extended = NULL; + + do + { + is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent); + if (is_type_attr_spec == MATCH_ERROR) + return MATCH_ERROR; + if (is_type_attr_spec == MATCH_YES) + seen_attr = true; + } while (is_type_attr_spec == MATCH_YES); + + /* Deal with derived type extensions. The extension attribute has + been added to 'attr' but now the parent type must be found and + checked. */ + if (parent[0]) + extended = check_extended_derived_type (parent); + + if (parent[0] && !extended) + return MATCH_ERROR; + + m = gfc_match (" ::"); + if (m == MATCH_YES) + { + seen_colons = true; + } + else if (seen_attr) + { + gfc_error ("Expected :: in TYPE definition at %C"); + return MATCH_ERROR; + } + + /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX. + But, we need to simply return for TYPE(. */ + if (m == MATCH_NO && gfc_current_form == FORM_FREE) + { + char c = gfc_peek_ascii_char (); + if (c == '(') + return m; + if (!gfc_is_whitespace (c)) + { + gfc_error ("Mangled derived type definition at %C"); + return MATCH_NO; + } + } + + m = gfc_match (" %n ", name); + if (m != MATCH_YES) + return m; + + /* Make sure that we don't identify TYPE IS (...) as a parameterized + derived type named 'is'. + TODO Expand the check, when 'name' = "is" by matching " (tname) " + and checking if this is a(n intrinsic) typename. This picks up + misplaced TYPE IS statements such as in select_type_1.f03. */ + if (gfc_peek_ascii_char () == '(') + { + if (gfc_current_state () == COMP_SELECT_TYPE + || (!seen_colons && !strcmp (name, "is"))) + return MATCH_NO; + parameterized_type = true; + } + + m = gfc_match_eos (); + if (m != MATCH_YES && !parameterized_type) + return m; + + /* Make sure the name is not the name of an intrinsic type. */ + if (gfc_is_intrinsic_typename (name)) + { + gfc_error ("Type name %qs at %C cannot be the same as an intrinsic " + "type", name); + return MATCH_ERROR; + } + + if (gfc_get_symbol (name, NULL, &gensym)) + return MATCH_ERROR; + + if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) + { + if (gensym->ts.u.derived) + gfc_error ("Derived type name %qs at %C already has a basic type " + "of %s", gensym->name, gfc_typename (&gensym->ts)); + else + gfc_error ("Derived type name %qs at %C already has a basic type", + gensym->name); + return MATCH_ERROR; + } + + if (!gensym->attr.generic + && !gfc_add_generic (&gensym->attr, gensym->name, NULL)) + return MATCH_ERROR; + + if (!gensym->attr.function + && !gfc_add_function (&gensym->attr, gensym->name, NULL)) + return MATCH_ERROR; + + if (gensym->attr.dummy) + { + gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C", + name, &gensym->declared_at); + return MATCH_ERROR; + } + + sym = gfc_find_dt_in_generic (gensym); + + if (sym && (sym->components != NULL || sym->attr.zero_comp)) + { + gfc_error ("Derived type definition of %qs at %C has already been " + "defined", sym->name); + return MATCH_ERROR; + } + + if (!sym) + { + /* Use upper case to save the actual derived-type symbol. */ + gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym); + sym->name = gfc_get_string ("%s", gensym->name); + head = gensym->generic; + intr = gfc_get_interface (); + intr->sym = sym; + intr->where = gfc_current_locus; + intr->sym->declared_at = gfc_current_locus; + intr->next = head; + gensym->generic = intr; + gensym->attr.if_source = IFSRC_DECL; + } + + /* The symbol may already have the derived attribute without the + components. The ways this can happen is via a function + definition, an INTRINSIC statement or a subtype in another + derived type that is a pointer. The first part of the AND clause + is true if the symbol is not the return value of a function. */ + if (sym->attr.flavor != FL_DERIVED + && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL)) + return MATCH_ERROR; + + if (attr.access != ACCESS_UNKNOWN + && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL)) + return MATCH_ERROR; + else if (sym->attr.access == ACCESS_UNKNOWN + && gensym->attr.access != ACCESS_UNKNOWN + && !gfc_add_access (&sym->attr, gensym->attr.access, + sym->name, NULL)) + return MATCH_ERROR; + + if (sym->attr.access != ACCESS_UNKNOWN + && gensym->attr.access == ACCESS_UNKNOWN) + gensym->attr.access = sym->attr.access; + + /* See if the derived type was labeled as bind(c). */ + if (attr.is_bind_c != 0) + sym->attr.is_bind_c = attr.is_bind_c; + + /* Construct the f2k_derived namespace if it is not yet there. */ + if (!sym->f2k_derived) + sym->f2k_derived = gfc_get_namespace (NULL, 0); + + if (parameterized_type) + { + /* Ignore error or mismatches by going to the end of the statement + in order to avoid the component declarations causing problems. */ + m = gfc_match_formal_arglist (sym, 0, 0, true); + if (m != MATCH_YES) + gfc_error_recovery (); + else + sym->attr.pdt_template = 1; + m = gfc_match_eos (); + if (m != MATCH_YES) + { + gfc_error_recovery (); + gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C"); + } + } + + if (extended && !sym->components) + { + gfc_component *p; + gfc_formal_arglist *f, *g, *h; + + /* Add the extended derived type as the first component. */ + gfc_add_component (sym, parent, &p); + extended->refs++; + gfc_set_sym_referenced (extended); + + p->ts.type = BT_DERIVED; + p->ts.u.derived = extended; + p->initializer = gfc_default_initializer (&p->ts); + + /* Set extension level. */ + if (extended->attr.extension == 255) + { + /* Since the extension field is 8 bit wide, we can only have + up to 255 extension levels. */ + gfc_error ("Maximum extension level reached with type %qs at %L", + extended->name, &extended->declared_at); + return MATCH_ERROR; + } + sym->attr.extension = extended->attr.extension + 1; + + /* Provide the links between the extended type and its extension. */ + if (!extended->f2k_derived) + extended->f2k_derived = gfc_get_namespace (NULL, 0); + + /* Copy the extended type-param-name-list from the extended type, + append those of the extension and add the whole lot to the + extension. */ + if (extended->attr.pdt_template) + { + g = h = NULL; + sym->attr.pdt_template = 1; + for (f = extended->formal; f; f = f->next) + { + if (f == extended->formal) + { + g = gfc_get_formal_arglist (); + h = g; + } + else + { + g->next = gfc_get_formal_arglist (); + g = g->next; + } + g->sym = f->sym; + } + g->next = sym->formal; + sym->formal = h; + } + } + + if (!sym->hash_value) + /* Set the hash for the compound name for this type. */ + sym->hash_value = gfc_hash_value (sym); + + /* Take over the ABSTRACT attribute. */ + sym->attr.abstract = attr.abstract; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Cray Pointees can be declared as: + pointer (ipt, a (n,m,...,*)) */ + +match +gfc_mod_pointee_as (gfc_array_spec *as) +{ + as->cray_pointee = true; /* This will be useful to know later. */ + if (as->type == AS_ASSUMED_SIZE) + as->cp_was_assumed = true; + else if (as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Cray Pointee at %C cannot be assumed shape array"); + return MATCH_ERROR; + } + return MATCH_YES; +} + + +/* Match the enum definition statement, here we are trying to match + the first line of enum definition statement. + Returns MATCH_YES if match is found. */ + +match +gfc_match_enum (void) +{ + match m; + + m = gfc_match_eos (); + if (m != MATCH_YES) + return m; + + if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C")) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Returns an initializer whose value is one higher than the value of the + LAST_INITIALIZER argument. If the argument is NULL, the + initializers value will be set to zero. The initializer's kind + will be set to gfc_c_int_kind. + + If -fshort-enums is given, the appropriate kind will be selected + later after all enumerators have been parsed. A warning is issued + here if an initializer exceeds gfc_c_int_kind. */ + +static gfc_expr * +enum_initializer (gfc_expr *last_initializer, locus where) +{ + gfc_expr *result; + result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where); + + mpz_init (result->value.integer); + + if (last_initializer != NULL) + { + mpz_add_ui (result->value.integer, last_initializer->value.integer, 1); + result->where = last_initializer->where; + + if (gfc_check_integer_range (result->value.integer, + gfc_c_int_kind) != ARITH_OK) + { + gfc_error ("Enumerator exceeds the C integer type at %C"); + return NULL; + } + } + else + { + /* Control comes here, if it's the very first enumerator and no + initializer has been given. It will be initialized to zero. */ + mpz_set_si (result->value.integer, 0); + } + + return result; +} + + +/* Match a variable name with an optional initializer. When this + subroutine is called, a variable is expected to be parsed next. + Depending on what is happening at the moment, updates either the + symbol table or the current interface. */ + +static match +enumerator_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *initializer; + gfc_array_spec *as = NULL; + gfc_symbol *sym; + locus var_locus; + match m; + bool t; + locus old_locus; + + initializer = NULL; + old_locus = gfc_current_locus; + + /* When we get here, we've just matched a list of attributes and + maybe a type and a double colon. The next thing we expect to see + is the name of the symbol. */ + m = gfc_match_name (name); + if (m != MATCH_YES) + goto cleanup; + + var_locus = gfc_current_locus; + + /* OK, we've successfully matched the declaration. Now put the + symbol in the current namespace. If we fail to create the symbol, + bail out. */ + if (!build_sym (name, NULL, false, &as, &var_locus)) + { + m = MATCH_ERROR; + goto cleanup; + } + + /* The double colon must be present in order to have initializers. + Otherwise the statement is ambiguous with an assignment statement. */ + if (colon_seen) + { + if (gfc_match_char ('=') == MATCH_YES) + { + m = gfc_match_init_expr (&initializer); + if (m == MATCH_NO) + { + gfc_error ("Expected an initialization expression at %C"); + m = MATCH_ERROR; + } + + if (m != MATCH_YES) + goto cleanup; + } + } + + /* If we do not have an initializer, the initialization value of the + previous enumerator (stored in last_initializer) is incremented + by 1 and is used to initialize the current enumerator. */ + if (initializer == NULL) + initializer = enum_initializer (last_initializer, old_locus); + + if (initializer == NULL || initializer->ts.type != BT_INTEGER) + { + gfc_error ("ENUMERATOR %L not initialized with integer expression", + &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + + /* Store this current initializer, for the next enumerator variable + to be parsed. add_init_expr_to_sym() zeros initializer, so we + use last_initializer below. */ + last_initializer = initializer; + t = add_init_expr_to_sym (name, &initializer, &var_locus); + + /* Maintain enumerator history. */ + gfc_find_symbol (name, NULL, 0, &sym); + create_enum_history (sym, last_initializer); + + return (t) ? MATCH_YES : MATCH_ERROR; + +cleanup: + /* Free stuff up and return. */ + gfc_free_expr (initializer); + + return m; +} + + +/* Match the enumerator definition statement. */ + +match +gfc_match_enumerator_def (void) +{ + match m; + bool t; + + gfc_clear_ts (¤t_ts); + + m = gfc_match (" enumerator"); + if (m != MATCH_YES) + return m; + + m = gfc_match (" :: "); + if (m == MATCH_ERROR) + return m; + + colon_seen = (m == MATCH_YES); + + if (gfc_current_state () != COMP_ENUM) + { + gfc_error ("ENUM definition statement expected before %C"); + gfc_free_enum_history (); + return MATCH_ERROR; + } + + (¤t_ts)->type = BT_INTEGER; + (¤t_ts)->kind = gfc_c_int_kind; + + gfc_clear_attr (¤t_attr); + t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL); + if (!t) + { + m = MATCH_ERROR; + goto cleanup; + } + + for (;;) + { + m = enumerator_decl (); + if (m == MATCH_ERROR) + { + gfc_free_enum_history (); + goto cleanup; + } + if (m == MATCH_NO) + break; + + if (gfc_match_eos () == MATCH_YES) + goto cleanup; + if (gfc_match_char (',') != MATCH_YES) + break; + } + + if (gfc_current_state () == COMP_ENUM) + { + gfc_free_enum_history (); + gfc_error ("Syntax error in ENUMERATOR definition at %C"); + m = MATCH_ERROR; + } + +cleanup: + gfc_free_array_spec (current_as); + current_as = NULL; + return m; + +} + + +/* Match binding attributes. */ + +static match +match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) +{ + bool found_passing = false; + bool seen_ptr = false; + match m = MATCH_YES; + + /* Initialize to defaults. Do so even before the MATCH_NO check so that in + this case the defaults are in there. */ + ba->access = ACCESS_UNKNOWN; + ba->pass_arg = NULL; + ba->pass_arg_num = 0; + ba->nopass = 0; + ba->non_overridable = 0; + ba->deferred = 0; + ba->ppc = ppc; + + /* If we find a comma, we believe there are binding attributes. */ + m = gfc_match_char (','); + if (m == MATCH_NO) + goto done; + + do + { + /* Access specifier. */ + + m = gfc_match (" public"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->access != ACCESS_UNKNOWN) + { + gfc_error ("Duplicate access-specifier at %C"); + goto error; + } + + ba->access = ACCESS_PUBLIC; + continue; + } + + m = gfc_match (" private"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->access != ACCESS_UNKNOWN) + { + gfc_error ("Duplicate access-specifier at %C"); + goto error; + } + + ba->access = ACCESS_PRIVATE; + continue; + } + + /* If inside GENERIC, the following is not allowed. */ + if (!generic) + { + + /* NOPASS flag. */ + m = gfc_match (" nopass"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (found_passing) + { + gfc_error ("Binding attributes already specify passing," + " illegal NOPASS at %C"); + goto error; + } + + found_passing = true; + ba->nopass = 1; + continue; + } + + /* PASS possibly including argument. */ + m = gfc_match (" pass"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + char arg[GFC_MAX_SYMBOL_LEN + 1]; + + if (found_passing) + { + gfc_error ("Binding attributes already specify passing," + " illegal PASS at %C"); + goto error; + } + + m = gfc_match (" ( %n )", arg); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + ba->pass_arg = gfc_get_string ("%s", arg); + gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); + + found_passing = true; + ba->nopass = 0; + continue; + } + + if (ppc) + { + /* POINTER flag. */ + m = gfc_match (" pointer"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (seen_ptr) + { + gfc_error ("Duplicate POINTER attribute at %C"); + goto error; + } + + seen_ptr = true; + continue; + } + } + else + { + /* NON_OVERRIDABLE flag. */ + m = gfc_match (" non_overridable"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->non_overridable) + { + gfc_error ("Duplicate NON_OVERRIDABLE at %C"); + goto error; + } + + ba->non_overridable = 1; + continue; + } + + /* DEFERRED flag. */ + m = gfc_match (" deferred"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->deferred) + { + gfc_error ("Duplicate DEFERRED at %C"); + goto error; + } + + ba->deferred = 1; + continue; + } + } + + } + + /* Nothing matching found. */ + if (generic) + gfc_error ("Expected access-specifier at %C"); + else + gfc_error ("Expected binding attribute at %C"); + goto error; + } + while (gfc_match_char (',') == MATCH_YES); + + /* NON_OVERRIDABLE and DEFERRED exclude themselves. */ + if (ba->non_overridable && ba->deferred) + { + gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C"); + goto error; + } + + m = MATCH_YES; + +done: + if (ba->access == ACCESS_UNKNOWN) + ba->access = ppc ? gfc_current_block()->component_access + : gfc_typebound_default_access; + + if (ppc && !seen_ptr) + { + gfc_error ("POINTER attribute is required for procedure pointer component" + " at %C"); + goto error; + } + + return m; + +error: + return MATCH_ERROR; +} + + +/* Match a PROCEDURE specific binding inside a derived type. */ + +static match +match_procedure_in_type (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + char target_buf[GFC_MAX_SYMBOL_LEN + 1]; + char* target = NULL, *ifc = NULL; + gfc_typebound_proc tb; + bool seen_colons; + bool seen_attrs; + match m; + gfc_symtree* stree; + gfc_namespace* ns; + gfc_symbol* block; + int num; + + /* Check current state. */ + gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); + block = gfc_state_stack->previous->sym; + gcc_assert (block); + + /* Try to match PROCEDURE(interface). */ + if (gfc_match (" (") == MATCH_YES) + { + m = gfc_match_name (target_buf); + if (m == MATCH_ERROR) + return m; + if (m != MATCH_YES) + { + gfc_error ("Interface-name expected after %<(%> at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("%<)%> expected at %C"); + return MATCH_ERROR; + } + + ifc = target_buf; + } + + /* Construct the data structure. */ + memset (&tb, 0, sizeof (tb)); + tb.where = gfc_current_locus; + + /* Match binding attributes. */ + m = match_binding_attributes (&tb, false, false); + if (m == MATCH_ERROR) + return m; + seen_attrs = (m == MATCH_YES); + + /* Check that attribute DEFERRED is given if an interface is specified. */ + if (tb.deferred && !ifc) + { + gfc_error ("Interface must be specified for DEFERRED binding at %C"); + return MATCH_ERROR; + } + if (ifc && !tb.deferred) + { + gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED"); + return MATCH_ERROR; + } + + /* Match the colons. */ + m = gfc_match (" ::"); + if (m == MATCH_ERROR) + return m; + seen_colons = (m == MATCH_YES); + if (seen_attrs && !seen_colons) + { + gfc_error ("Expected %<::%> after binding-attributes at %C"); + return MATCH_ERROR; + } + + /* Match the binding names. */ + for(num=1;;num++) + { + m = gfc_match_name (name); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding name at %C"); + return MATCH_ERROR; + } + + if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C")) + return MATCH_ERROR; + + /* Try to match the '=> target', if it's there. */ + target = ifc; + m = gfc_match (" =>"); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_YES) + { + if (tb.deferred) + { + gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C"); + return MATCH_ERROR; + } + + if (!seen_colons) + { + gfc_error ("%<::%> needed in PROCEDURE binding with explicit target" + " at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (target_buf); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding target after %<=>%> at %C"); + return MATCH_ERROR; + } + target = target_buf; + } + + /* If no target was found, it has the same name as the binding. */ + if (!target) + target = name; + + /* Get the namespace to insert the symbols into. */ + ns = block->f2k_derived; + gcc_assert (ns); + + /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ + if (tb.deferred && !block->attr.abstract) + { + gfc_error ("Type %qs containing DEFERRED binding at %C " + "is not ABSTRACT", block->name); + return MATCH_ERROR; + } + + /* See if we already have a binding with this name in the symtree which + would be an error. If a GENERIC already targeted this binding, it may + be already there but then typebound is still NULL. */ + stree = gfc_find_symtree (ns->tb_sym_root, name); + if (stree && stree->n.tb) + { + gfc_error ("There is already a procedure with binding name %qs for " + "the derived type %qs at %C", name, block->name); + return MATCH_ERROR; + } + + /* Insert it and set attributes. */ + + if (!stree) + { + stree = gfc_new_symtree (&ns->tb_sym_root, name); + gcc_assert (stree); + } + stree->n.tb = gfc_get_typebound_proc (&tb); + + if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific, + false)) + return MATCH_ERROR; + gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); + gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE, + target, &stree->n.tb->u.specific->n.sym->declared_at); + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + +syntax: + gfc_error ("Syntax error in PROCEDURE statement at %C"); + return MATCH_ERROR; +} + + +/* Match a GENERIC procedure binding inside a derived type. */ + +match +gfc_match_generic (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */ + gfc_symbol* block; + gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */ + gfc_typebound_proc* tb; + gfc_namespace* ns; + interface_type op_type; + gfc_intrinsic_op op; + match m; + + /* Check current state. */ + if (gfc_current_state () == COMP_DERIVED) + { + gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS"); + return MATCH_ERROR; + } + if (gfc_current_state () != COMP_DERIVED_CONTAINS) + return MATCH_NO; + block = gfc_state_stack->previous->sym; + ns = block->f2k_derived; + gcc_assert (block && ns); + + memset (&tbattr, 0, sizeof (tbattr)); + tbattr.where = gfc_current_locus; + + /* See if we get an access-specifier. */ + m = match_binding_attributes (&tbattr, true, false); + if (m == MATCH_ERROR) + goto error; + + /* Now the colons, those are required. */ + if (gfc_match (" ::") != MATCH_YES) + { + gfc_error ("Expected %<::%> at %C"); + goto error; + } + + /* Match the binding name; depending on type (operator / generic) format + it for future error messages into bind_name. */ + + m = gfc_match_generic_spec (&op_type, name, &op); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + { + gfc_error ("Expected generic name or operator descriptor at %C"); + goto error; + } + + switch (op_type) + { + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + snprintf (bind_name, sizeof (bind_name), "%s", name); + break; + + case INTERFACE_USER_OP: + snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name); + break; + + case INTERFACE_INTRINSIC_OP: + snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)", + gfc_op2string (op)); + break; + + case INTERFACE_NAMELESS: + gfc_error ("Malformed GENERIC statement at %C"); + goto error; + break; + + default: + gcc_unreachable (); + } + + /* Match the required =>. */ + if (gfc_match (" =>") != MATCH_YES) + { + gfc_error ("Expected %<=>%> at %C"); + goto error; + } + + /* Try to find existing GENERIC binding with this name / for this operator; + if there is something, check that it is another GENERIC and then extend + it rather than building a new node. Otherwise, create it and put it + at the right position. */ + + switch (op_type) + { + case INTERFACE_DTIO: + case INTERFACE_USER_OP: + case INTERFACE_GENERIC: + { + const bool is_op = (op_type == INTERFACE_USER_OP); + gfc_symtree* st; + + st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name); + tb = st ? st->n.tb : NULL; + break; + } + + case INTERFACE_INTRINSIC_OP: + tb = ns->tb_op[op]; + break; + + default: + gcc_unreachable (); + } + + if (tb) + { + if (!tb->is_generic) + { + gcc_assert (op_type == INTERFACE_GENERIC); + gfc_error ("There's already a non-generic procedure with binding name" + " %qs for the derived type %qs at %C", + bind_name, block->name); + goto error; + } + + if (tb->access != tbattr.access) + { + gfc_error ("Binding at %C must have the same access as already" + " defined binding %qs", bind_name); + goto error; + } + } + else + { + tb = gfc_get_typebound_proc (NULL); + tb->where = gfc_current_locus; + tb->access = tbattr.access; + tb->is_generic = 1; + tb->u.generic = NULL; + + switch (op_type) + { + case INTERFACE_DTIO: + case INTERFACE_GENERIC: + case INTERFACE_USER_OP: + { + const bool is_op = (op_type == INTERFACE_USER_OP); + gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root : + &ns->tb_sym_root, name); + gcc_assert (st); + st->n.tb = tb; + + break; + } + + case INTERFACE_INTRINSIC_OP: + ns->tb_op[op] = tb; + break; + + default: + gcc_unreachable (); + } + } + + /* Now, match all following names as specific targets. */ + do + { + gfc_symtree* target_st; + gfc_tbp_generic* target; + + m = gfc_match_name (name); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + { + gfc_error ("Expected specific binding name at %C"); + goto error; + } + + target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name); + + /* See if this is a duplicate specification. */ + for (target = tb->u.generic; target; target = target->next) + if (target_st == target->specific_st) + { + gfc_error ("%qs already defined as specific binding for the" + " generic %qs at %C", name, bind_name); + goto error; + } + + target = gfc_get_tbp_generic (); + target->specific_st = target_st; + target->specific = NULL; + target->next = tb->u.generic; + target->is_operator = ((op_type == INTERFACE_USER_OP) + || (op_type == INTERFACE_INTRINSIC_OP)); + tb->u.generic = target; + } + while (gfc_match (" ,") == MATCH_YES); + + /* Here should be the end. */ + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after GENERIC binding at %C"); + goto error; + } + + return MATCH_YES; + +error: + return MATCH_ERROR; +} + + +/* Match a FINAL declaration inside a derived type. */ + +match +gfc_match_final_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol* sym; + match m; + gfc_namespace* module_ns; + bool first, last; + gfc_symbol* block; + + if (gfc_current_form == FORM_FREE) + { + char c = gfc_peek_ascii_char (); + if (!gfc_is_whitespace (c) && c != ':') + return MATCH_NO; + } + + if (gfc_state_stack->state != COMP_DERIVED_CONTAINS) + { + if (gfc_current_form == FORM_FIXED) + return MATCH_NO; + + gfc_error ("FINAL declaration at %C must be inside a derived type " + "CONTAINS section"); + return MATCH_ERROR; + } + + block = gfc_state_stack->previous->sym; + gcc_assert (block); + + if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous + || gfc_state_stack->previous->previous->state != COMP_MODULE) + { + gfc_error ("Derived type declaration with FINAL at %C must be in the" + " specification part of a MODULE"); + return MATCH_ERROR; + } + + module_ns = gfc_current_ns; + gcc_assert (module_ns); + gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE); + + /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */ + if (gfc_match (" ::") == MATCH_ERROR) + return MATCH_ERROR; + + /* Match the sequence of procedure names. */ + first = true; + last = false; + do + { + gfc_finalizer* f; + + if (first && gfc_match_eos () == MATCH_YES) + { + gfc_error ("Empty FINAL at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (name); + if (m == MATCH_NO) + { + gfc_error ("Expected module procedure name at %C"); + return MATCH_ERROR; + } + else if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_eos () == MATCH_YES) + last = true; + if (!last && gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected %<,%> at %C"); + return MATCH_ERROR; + } + + if (gfc_get_symbol (name, module_ns, &sym)) + { + gfc_error ("Unknown procedure name %qs at %C", name); + return MATCH_ERROR; + } + + /* Mark the symbol as module procedure. */ + if (sym->attr.proc != PROC_MODULE + && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) + return MATCH_ERROR; + + /* Check if we already have this symbol in the list, this is an error. */ + for (f = block->f2k_derived->finalizers; f; f = f->next) + if (f->proc_sym == sym) + { + gfc_error ("%qs at %C is already defined as FINAL procedure", + name); + return MATCH_ERROR; + } + + /* Add this symbol to the list of finalizers. */ + gcc_assert (block->f2k_derived); + sym->refs++; + f = XCNEW (gfc_finalizer); + f->proc_sym = sym; + f->proc_tree = NULL; + f->where = gfc_current_locus; + f->next = block->f2k_derived->finalizers; + block->f2k_derived->finalizers = f; + + first = false; + } + while (!last); + + return MATCH_YES; +} + + +const ext_attr_t ext_attr_list[] = { + { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" }, + { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" }, + { "cdecl", EXT_ATTR_CDECL, "cdecl" }, + { "stdcall", EXT_ATTR_STDCALL, "stdcall" }, + { "fastcall", EXT_ATTR_FASTCALL, "fastcall" }, + { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL }, + { "deprecated", EXT_ATTR_DEPRECATED, NULL }, + { NULL, EXT_ATTR_LAST, NULL } +}; + +/* Match a !GCC$ ATTRIBUTES statement of the form: + !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ... + When we come here, we have already matched the !GCC$ ATTRIBUTES string. + + TODO: We should support all GCC attributes using the same syntax for + the attribute list, i.e. the list in C + __attributes(( attribute-list )) + matches then + !GCC$ ATTRIBUTES attribute-list :: + Cf. c-parser.c's c_parser_attributes; the data can then directly be + saved into a TREE. + + As there is absolutely no risk of confusion, we should never return + MATCH_NO. */ +match +gfc_match_gcc_attributes (void) +{ + symbol_attribute attr; + char name[GFC_MAX_SYMBOL_LEN + 1]; + unsigned id; + gfc_symbol *sym; + match m; + + gfc_clear_attr (&attr); + for(;;) + { + char ch; + + if (gfc_match_name (name) != MATCH_YES) + return MATCH_ERROR; + + for (id = 0; id < EXT_ATTR_LAST; id++) + if (strcmp (name, ext_attr_list[id].name) == 0) + break; + + if (id == EXT_ATTR_LAST) + { + gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C"); + return MATCH_ERROR; + } + + if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus)) + return MATCH_ERROR; + + gfc_gobble_whitespace (); + ch = gfc_next_ascii_char (); + if (ch == ':') + { + /* This is the successful exit condition for the loop. */ + if (gfc_next_ascii_char () == ':') + break; + } + + if (ch == ',') + continue; + + goto syntax; + } + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for(;;) + { + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (find_special (name, &sym, true)) + return MATCH_ERROR; + + sym->attr.ext_attr |= attr.ext_attr; + + if (gfc_match_eos () == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C"); + return MATCH_ERROR; +} + + +/* Match a !GCC$ UNROLL statement of the form: + !GCC$ UNROLL n + + The parameter n is the number of times we are supposed to unroll. + + When we come here, we have already matched the !GCC$ UNROLL string. */ +match +gfc_match_gcc_unroll (void) +{ + int value; + + /* FIXME: use gfc_match_small_literal_int instead, delete small_int */ + if (gfc_match_small_int (&value) == MATCH_YES) + { + if (value < 0 || value > USHRT_MAX) + { + gfc_error ("% directive requires a" + " non-negative integral constant" + " less than or equal to %u at %C", + USHRT_MAX + ); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) + { + directive_unroll = value == 0 ? 1 : value; + return MATCH_YES; + } + } + + gfc_error ("Syntax error in !GCC$ UNROLL directive at %C"); + return MATCH_ERROR; +} + +/* Match a !GCC$ builtin (b) attributes simd flags if('target') form: + + The parameter b is name of a middle-end built-in. + FLAGS is optional and must be one of: + - (inbranch) + - (notinbranch) + + IF('target') is optional and TARGET is a name of a multilib ABI. + + When we come here, we have already matched the !GCC$ builtin string. */ + +match +gfc_match_gcc_builtin (void) +{ + char builtin[GFC_MAX_SYMBOL_LEN + 1]; + char target[GFC_MAX_SYMBOL_LEN + 1]; + + if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES) + return MATCH_ERROR; + + gfc_simd_clause clause = SIMD_NONE; + if (gfc_match (" ( notinbranch ) ") == MATCH_YES) + clause = SIMD_NOTINBRANCH; + else if (gfc_match (" ( inbranch ) ") == MATCH_YES) + clause = SIMD_INBRANCH; + + if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES) + { + const char *abi = targetm.get_multilib_abi_name (); + if (abi == NULL || strcmp (abi, target) != 0) + return MATCH_YES; + } + + if (gfc_vectorized_builtins == NULL) + gfc_vectorized_builtins = new hash_map (); + + char *r = XNEWVEC (char, strlen (builtin) + 32); + sprintf (r, "__builtin_%s", builtin); + + bool existed; + int &value = gfc_vectorized_builtins->get_or_insert (r, &existed); + value |= clause; + if (existed) + free (r); + + return MATCH_YES; +} + +/* Match an !GCC$ IVDEP statement. + When we come here, we have already matched the !GCC$ IVDEP string. */ + +match +gfc_match_gcc_ivdep (void) +{ + if (gfc_match_eos () == MATCH_YES) + { + directive_ivdep = true; + return MATCH_YES; + } + + gfc_error ("Syntax error in !GCC$ IVDEP directive at %C"); + return MATCH_ERROR; +} + +/* Match an !GCC$ VECTOR statement. + When we come here, we have already matched the !GCC$ VECTOR string. */ + +match +gfc_match_gcc_vector (void) +{ + if (gfc_match_eos () == MATCH_YES) + { + directive_vector = true; + directive_novector = false; + return MATCH_YES; + } + + gfc_error ("Syntax error in !GCC$ VECTOR directive at %C"); + return MATCH_ERROR; +} + +/* Match an !GCC$ NOVECTOR statement. + When we come here, we have already matched the !GCC$ NOVECTOR string. */ + +match +gfc_match_gcc_novector (void) +{ + if (gfc_match_eos () == MATCH_YES) + { + directive_novector = true; + directive_vector = false; + return MATCH_YES; + } + + gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C"); + return MATCH_ERROR; +} diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c deleted file mode 100644 index 5d28606..0000000 --- a/gcc/fortran/dependency.c +++ /dev/null @@ -1,2336 +0,0 @@ -/* Dependency analysis - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - -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 -. */ - -/* dependency.c -- Expression dependency analysis code. */ -/* There's probably quite a bit of duplication in this file. We currently - have different dependency checking functions for different types - if dependencies. Ideally these would probably be merged. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "dependency.h" -#include "constructor.h" -#include "arith.h" -#include "options.h" - -/* static declarations */ -/* Enums */ -enum range {LHS, RHS, MID}; - -/* Dependency types. These must be in reverse order of priority. */ -enum gfc_dependency -{ - GFC_DEP_ERROR, - GFC_DEP_EQUAL, /* Identical Ranges. */ - GFC_DEP_FORWARD, /* e.g., a(1:3) = a(2:4). */ - GFC_DEP_BACKWARD, /* e.g. a(2:4) = a(1:3). */ - GFC_DEP_OVERLAP, /* May overlap in some other way. */ - GFC_DEP_NODEP /* Distinct ranges. */ -}; - -/* Macros */ -#define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0)) - -/* Forward declarations */ - -static gfc_dependency check_section_vs_section (gfc_array_ref *, - gfc_array_ref *, int); - -/* Returns 1 if the expr is an integer constant value 1, 0 if it is not or - def if the value could not be determined. */ - -int -gfc_expr_is_one (gfc_expr *expr, int def) -{ - gcc_assert (expr != NULL); - - if (expr->expr_type != EXPR_CONSTANT) - return def; - - if (expr->ts.type != BT_INTEGER) - return def; - - return mpz_cmp_si (expr->value.integer, 1) == 0; -} - -/* Check if two array references are known to be identical. Calls - gfc_dep_compare_expr if necessary for comparing array indices. */ - -static bool -identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2) -{ - int i; - - if (a1->type == AR_FULL && a2->type == AR_FULL) - return true; - - if (a1->type == AR_SECTION && a2->type == AR_SECTION) - { - gcc_assert (a1->dimen == a2->dimen); - - for ( i = 0; i < a1->dimen; i++) - { - /* TODO: Currently, we punt on an integer array as an index. */ - if (a1->dimen_type[i] != DIMEN_RANGE - || a2->dimen_type[i] != DIMEN_RANGE) - return false; - - if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL) - return false; - } - return true; - } - - if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT) - { - if (a1->dimen != a2->dimen) - gfc_internal_error ("identical_array_ref(): inconsistent dimensions"); - - for (i = 0; i < a1->dimen; i++) - { - if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0) - return false; - } - return true; - } - return false; -} - - - -/* Return true for identical variables, checking for references if - necessary. Calls identical_array_ref for checking array sections. */ - -static bool -are_identical_variables (gfc_expr *e1, gfc_expr *e2) -{ - gfc_ref *r1, *r2; - - if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy) - { - /* Dummy arguments: Only check for equal names. */ - if (e1->symtree->n.sym->name != e2->symtree->n.sym->name) - return false; - } - else - { - /* Check for equal symbols. */ - if (e1->symtree->n.sym != e2->symtree->n.sym) - return false; - } - - /* Volatile variables should never compare equal to themselves. */ - - if (e1->symtree->n.sym->attr.volatile_) - return false; - - r1 = e1->ref; - r2 = e2->ref; - - while (r1 != NULL || r2 != NULL) - { - - /* Assume the variables are not equal if one has a reference and the - other doesn't. - TODO: Handle full references like comparing a(:) to a. - */ - - if (r1 == NULL || r2 == NULL) - return false; - - if (r1->type != r2->type) - return false; - - switch (r1->type) - { - - case REF_ARRAY: - if (!identical_array_ref (&r1->u.ar, &r2->u.ar)) - return false; - - break; - - case REF_COMPONENT: - if (r1->u.c.component != r2->u.c.component) - return false; - break; - - case REF_SUBSTRING: - if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0) - return false; - - /* If both are NULL, the end length compares equal, because we - are looking at the same variable. This can only happen for - assumed- or deferred-length character arguments. */ - - if (r1->u.ss.end == NULL && r2->u.ss.end == NULL) - break; - - if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0) - return false; - - break; - - case REF_INQUIRY: - if (r1->u.i != r2->u.i) - return false; - break; - - default: - gfc_internal_error ("are_identical_variables: Bad type"); - } - r1 = r1->next; - r2 = r2->next; - } - return true; -} - -/* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If - impure_ok is false, only return 0 for pure functions. */ - -int -gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok) -{ - - gfc_actual_arglist *args1; - gfc_actual_arglist *args2; - - if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION) - return -2; - - if ((e1->value.function.esym && e2->value.function.esym - && e1->value.function.esym == e2->value.function.esym - && (e1->value.function.esym->result->attr.pure || impure_ok)) - || (e1->value.function.isym && e2->value.function.isym - && e1->value.function.isym == e2->value.function.isym - && (e1->value.function.isym->pure || impure_ok))) - { - args1 = e1->value.function.actual; - args2 = e2->value.function.actual; - - /* Compare the argument lists for equality. */ - while (args1 && args2) - { - /* Bitwise xor, since C has no non-bitwise xor operator. */ - if ((args1->expr == NULL) ^ (args2->expr == NULL)) - return -2; - - if (args1->expr != NULL && args2->expr != NULL) - { - gfc_expr *e1, *e2; - e1 = args1->expr; - e2 = args2->expr; - - if (gfc_dep_compare_expr (e1, e2) != 0) - return -2; - - /* Special case: String arguments which compare equal can have - different lengths, which makes them different in calls to - procedures. */ - - if (e1->expr_type == EXPR_CONSTANT - && e1->ts.type == BT_CHARACTER - && e2->expr_type == EXPR_CONSTANT - && e2->ts.type == BT_CHARACTER - && e1->value.character.length != e2->value.character.length) - return -2; - } - - args1 = args1->next; - args2 = args2->next; - } - return (args1 || args2) ? -2 : 0; - } - else - return -2; -} - -/* Helper function to look through parens, unary plus and widening - integer conversions. */ - -gfc_expr * -gfc_discard_nops (gfc_expr *e) -{ - gfc_actual_arglist *arglist; - - if (e == NULL) - return NULL; - - while (true) - { - if (e->expr_type == EXPR_OP - && (e->value.op.op == INTRINSIC_UPLUS - || e->value.op.op == INTRINSIC_PARENTHESES)) - { - e = e->value.op.op1; - continue; - } - - if (e->expr_type == EXPR_FUNCTION && e->value.function.isym - && e->value.function.isym->id == GFC_ISYM_CONVERSION - && e->ts.type == BT_INTEGER) - { - arglist = e->value.function.actual; - if (arglist->expr->ts.type == BT_INTEGER - && e->ts.kind > arglist->expr->ts.kind) - { - e = arglist->expr; - continue; - } - } - break; - } - - return e; -} - - -/* Compare two expressions. Return values: - * +1 if e1 > e2 - * 0 if e1 == e2 - * -1 if e1 < e2 - * -2 if the relationship could not be determined - * -3 if e1 /= e2, but we cannot tell which one is larger. - REAL and COMPLEX constants are only compared for equality - or inequality; if they are unequal, -2 is returned in all cases. */ - -int -gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) -{ - int i; - - if (e1 == NULL && e2 == NULL) - return 0; - else if (e1 == NULL || e2 == NULL) - return -2; - - e1 = gfc_discard_nops (e1); - e2 = gfc_discard_nops (e2); - - if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) - { - /* Compare X+C vs. X, for INTEGER only. */ - if (e1->value.op.op2->expr_type == EXPR_CONSTANT - && e1->value.op.op2->ts.type == BT_INTEGER - && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) - return mpz_sgn (e1->value.op.op2->value.integer); - - /* Compare P+Q vs. R+S. */ - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) - { - int l, r; - - l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); - r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); - if (l == 0 && r == 0) - return 0; - if (l == 0 && r > -2) - return r; - if (l > -2 && r == 0) - return l; - if (l == 1 && r == 1) - return 1; - if (l == -1 && r == -1) - return -1; - - l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2); - r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1); - if (l == 0 && r == 0) - return 0; - if (l == 0 && r > -2) - return r; - if (l > -2 && r == 0) - return l; - if (l == 1 && r == 1) - return 1; - if (l == -1 && r == -1) - return -1; - } - } - - /* Compare X vs. X+C, for INTEGER only. */ - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) - { - if (e2->value.op.op2->expr_type == EXPR_CONSTANT - && e2->value.op.op2->ts.type == BT_INTEGER - && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) - return -mpz_sgn (e2->value.op.op2->value.integer); - } - - /* Compare X-C vs. X, for INTEGER only. */ - if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) - { - if (e1->value.op.op2->expr_type == EXPR_CONSTANT - && e1->value.op.op2->ts.type == BT_INTEGER - && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) - return -mpz_sgn (e1->value.op.op2->value.integer); - - /* Compare P-Q vs. R-S. */ - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) - { - int l, r; - - l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); - r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); - if (l == 0 && r == 0) - return 0; - if (l > -2 && r == 0) - return l; - if (l == 0 && r > -2) - return -r; - if (l == 1 && r == -1) - return 1; - if (l == -1 && r == 1) - return -1; - } - } - - /* Compare A // B vs. C // D. */ - - if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT - && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT) - { - int l, r; - - l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); - r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); - - if (l != 0) - return l; - - /* Left expressions of // compare equal, but - watch out for 'A ' // x vs. 'A' // x. */ - gfc_expr *e1_left = e1->value.op.op1; - gfc_expr *e2_left = e2->value.op.op1; - - if (e1_left->expr_type == EXPR_CONSTANT - && e2_left->expr_type == EXPR_CONSTANT - && e1_left->value.character.length - != e2_left->value.character.length) - return -2; - else - return r; - } - - /* Compare X vs. X-C, for INTEGER only. */ - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) - { - if (e2->value.op.op2->expr_type == EXPR_CONSTANT - && e2->value.op.op2->ts.type == BT_INTEGER - && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) - return mpz_sgn (e2->value.op.op2->value.integer); - } - - if (e1->expr_type != e2->expr_type) - return -3; - - switch (e1->expr_type) - { - case EXPR_CONSTANT: - /* Compare strings for equality. */ - if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER) - return gfc_compare_string (e1, e2); - - /* Compare REAL and COMPLEX constants. Because of the - traps and pitfalls associated with comparing - a + 1.0 with a + 0.5, check for equality only. */ - if (e2->expr_type == EXPR_CONSTANT) - { - if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL) - { - if (mpfr_cmp (e1->value.real, e2->value.real) == 0) - return 0; - else - return -2; - } - else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX) - { - if (mpc_cmp (e1->value.complex, e2->value.complex) == 0) - return 0; - else - return -2; - } - } - - if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) - return -2; - - /* For INTEGER, all cases where e2 is not constant should have - been filtered out above. */ - gcc_assert (e2->expr_type == EXPR_CONSTANT); - - i = mpz_cmp (e1->value.integer, e2->value.integer); - if (i == 0) - return 0; - else if (i < 0) - return -1; - return 1; - - case EXPR_VARIABLE: - if (are_identical_variables (e1, e2)) - return 0; - else - return -3; - - case EXPR_OP: - /* Intrinsic operators are the same if their operands are the same. */ - if (e1->value.op.op != e2->value.op.op) - return -2; - if (e1->value.op.op2 == 0) - { - i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); - return i == 0 ? 0 : -2; - } - if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0 - && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0) - return 0; - else if (e1->value.op.op == INTRINSIC_TIMES - && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0 - && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0) - /* Commutativity of multiplication; addition is handled above. */ - return 0; - - return -2; - - case EXPR_FUNCTION: - return gfc_dep_compare_functions (e1, e2, false); - - default: - return -2; - } -} - - -/* Return the difference between two expressions. Integer expressions of - the form - - X + constant, X - constant and constant + X - - are handled. Return true on success, false on failure. result is assumed - to be uninitialized on entry, and will be initialized on success. -*/ - -bool -gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result) -{ - gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2; - - if (e1 == NULL || e2 == NULL) - return false; - - if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) - return false; - - e1 = gfc_discard_nops (e1); - e2 = gfc_discard_nops (e2); - - /* Inizialize tentatively, clear if we don't return anything. */ - mpz_init (*result); - - /* Case 1: c1 - c2 = c1 - c2, trivially. */ - - if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT) - { - mpz_sub (*result, e1->value.integer, e2->value.integer); - return true; - } - - if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) - { - e1_op1 = gfc_discard_nops (e1->value.op.op1); - e1_op2 = gfc_discard_nops (e1->value.op.op2); - - /* Case 2: (X + c1) - X = c1. */ - if (e1_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op1, e2) == 0) - { - mpz_set (*result, e1_op2->value.integer); - return true; - } - - /* Case 3: (c1 + X) - X = c1. */ - if (e1_op1->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op2, e2) == 0) - { - mpz_set (*result, e1_op1->value.integer); - return true; - } - - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) - { - e2_op1 = gfc_discard_nops (e2->value.op.op1); - e2_op2 = gfc_discard_nops (e2->value.op.op2); - - if (e1_op2->expr_type == EXPR_CONSTANT) - { - /* Case 4: X + c1 - (X + c2) = c1 - c2. */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) - { - mpz_sub (*result, e1_op2->value.integer, - e2_op2->value.integer); - return true; - } - /* Case 5: X + c1 - (c2 + X) = c1 - c2. */ - if (e2_op1->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) - { - mpz_sub (*result, e1_op2->value.integer, - e2_op1->value.integer); - return true; - } - } - else if (e1_op1->expr_type == EXPR_CONSTANT) - { - /* Case 6: c1 + X - (X + c2) = c1 - c2. */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) - { - mpz_sub (*result, e1_op1->value.integer, - e2_op2->value.integer); - return true; - } - /* Case 7: c1 + X - (c2 + X) = c1 - c2. */ - if (e2_op1->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op2, e2_op2) == 0) - { - mpz_sub (*result, e1_op1->value.integer, - e2_op1->value.integer); - return true; - } - } - } - - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) - { - e2_op1 = gfc_discard_nops (e2->value.op.op1); - e2_op2 = gfc_discard_nops (e2->value.op.op2); - - if (e1_op2->expr_type == EXPR_CONSTANT) - { - /* Case 8: X + c1 - (X - c2) = c1 + c2. */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) - { - mpz_add (*result, e1_op2->value.integer, - e2_op2->value.integer); - return true; - } - } - if (e1_op1->expr_type == EXPR_CONSTANT) - { - /* Case 9: c1 + X - (X - c2) = c1 + c2. */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) - { - mpz_add (*result, e1_op1->value.integer, - e2_op2->value.integer); - return true; - } - } - } - } - - if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) - { - e1_op1 = gfc_discard_nops (e1->value.op.op1); - e1_op2 = gfc_discard_nops (e1->value.op.op2); - - if (e1_op2->expr_type == EXPR_CONSTANT) - { - /* Case 10: (X - c1) - X = -c1 */ - - if (gfc_dep_compare_expr (e1_op1, e2) == 0) - { - mpz_neg (*result, e1_op2->value.integer); - return true; - } - - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) - { - e2_op1 = gfc_discard_nops (e2->value.op.op1); - e2_op2 = gfc_discard_nops (e2->value.op.op2); - - /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) - { - mpz_add (*result, e1_op2->value.integer, - e2_op2->value.integer); - mpz_neg (*result, *result); - return true; - } - - /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */ - if (e2_op1->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) - { - mpz_add (*result, e1_op2->value.integer, - e2_op1->value.integer); - mpz_neg (*result, *result); - return true; - } - } - - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) - { - e2_op1 = gfc_discard_nops (e2->value.op.op1); - e2_op2 = gfc_discard_nops (e2->value.op.op2); - - /* Case 13: (X - c1) - (X - c2) = c2 - c1. */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) - { - mpz_sub (*result, e2_op2->value.integer, - e1_op2->value.integer); - return true; - } - } - } - if (e1_op1->expr_type == EXPR_CONSTANT) - { - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) - { - e2_op1 = gfc_discard_nops (e2->value.op.op1); - e2_op2 = gfc_discard_nops (e2->value.op.op2); - - /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */ - if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0) - { - mpz_sub (*result, e1_op1->value.integer, - e2_op1->value.integer); - return true; - } - } - - } - } - - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) - { - e2_op1 = gfc_discard_nops (e2->value.op.op1); - e2_op2 = gfc_discard_nops (e2->value.op.op2); - - /* Case 15: X - (X + c2) = -c2. */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1, e2_op1) == 0) - { - mpz_neg (*result, e2_op2->value.integer); - return true; - } - /* Case 16: X - (c2 + X) = -c2. */ - if (e2_op1->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1, e2_op2) == 0) - { - mpz_neg (*result, e2_op1->value.integer); - return true; - } - } - - if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) - { - e2_op1 = gfc_discard_nops (e2->value.op.op1); - e2_op2 = gfc_discard_nops (e2->value.op.op2); - - /* Case 17: X - (X - c2) = c2. */ - if (e2_op2->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (e1, e2_op1) == 0) - { - mpz_set (*result, e2_op2->value.integer); - return true; - } - } - - if (gfc_dep_compare_expr (e1, e2) == 0) - { - /* Case 18: X - X = 0. */ - mpz_set_si (*result, 0); - return true; - } - - mpz_clear (*result); - return false; -} - -/* Returns 1 if the two ranges are the same and 0 if they are not (or if the - results are indeterminate). 'n' is the dimension to compare. */ - -static int -is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n) -{ - gfc_expr *e1; - gfc_expr *e2; - int i; - - /* TODO: More sophisticated range comparison. */ - gcc_assert (ar1 && ar2); - - gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]); - - e1 = ar1->stride[n]; - e2 = ar2->stride[n]; - /* Check for mismatching strides. A NULL stride means a stride of 1. */ - if (e1 && !e2) - { - i = gfc_expr_is_one (e1, -1); - if (i == -1 || i == 0) - return 0; - } - else if (e2 && !e1) - { - i = gfc_expr_is_one (e2, -1); - if (i == -1 || i == 0) - return 0; - } - else if (e1 && e2) - { - i = gfc_dep_compare_expr (e1, e2); - if (i != 0) - return 0; - } - /* The strides match. */ - - /* Check the range start. */ - e1 = ar1->start[n]; - e2 = ar2->start[n]; - if (e1 || e2) - { - /* Use the bound of the array if no bound is specified. */ - if (ar1->as && !e1) - e1 = ar1->as->lower[n]; - - if (ar2->as && !e2) - e2 = ar2->as->lower[n]; - - /* Check we have values for both. */ - if (!(e1 && e2)) - return 0; - - i = gfc_dep_compare_expr (e1, e2); - if (i != 0) - return 0; - } - - /* Check the range end. */ - e1 = ar1->end[n]; - e2 = ar2->end[n]; - if (e1 || e2) - { - /* Use the bound of the array if no bound is specified. */ - if (ar1->as && !e1) - e1 = ar1->as->upper[n]; - - if (ar2->as && !e2) - e2 = ar2->as->upper[n]; - - /* Check we have values for both. */ - if (!(e1 && e2)) - return 0; - - i = gfc_dep_compare_expr (e1, e2); - if (i != 0) - return 0; - } - - return 1; -} - - -/* Some array-returning intrinsics can be implemented by reusing the - data from one of the array arguments. For example, TRANSPOSE does - not necessarily need to allocate new data: it can be implemented - by copying the original array's descriptor and simply swapping the - two dimension specifications. - - If EXPR is a call to such an intrinsic, return the argument - whose data can be reused, otherwise return NULL. */ - -gfc_expr * -gfc_get_noncopying_intrinsic_argument (gfc_expr *expr) -{ - if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym) - return NULL; - - switch (expr->value.function.isym->id) - { - case GFC_ISYM_TRANSPOSE: - return expr->value.function.actual->expr; - - default: - return NULL; - } -} - - -/* Return true if the result of reference REF can only be constructed - using a temporary array. */ - -bool -gfc_ref_needs_temporary_p (gfc_ref *ref) -{ - int n; - bool subarray_p; - - subarray_p = false; - for (; ref; ref = ref->next) - switch (ref->type) - { - case REF_ARRAY: - /* Vector dimensions are generally not monotonic and must be - handled using a temporary. */ - if (ref->u.ar.type == AR_SECTION) - for (n = 0; n < ref->u.ar.dimen; n++) - if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) - return true; - - subarray_p = true; - break; - - case REF_SUBSTRING: - /* Within an array reference, character substrings generally - need a temporary. Character array strides are expressed as - multiples of the element size (consistent with other array - types), not in characters. */ - return subarray_p; - - case REF_COMPONENT: - case REF_INQUIRY: - break; - } - - return false; -} - - -static int -gfc_is_data_pointer (gfc_expr *e) -{ - gfc_ref *ref; - - if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) - return 0; - - /* No subreference if it is a function */ - gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref); - - if (e->symtree->n.sym->attr.pointer) - return 1; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) - return 1; - - return 0; -} - - -/* Return true if array variable VAR could be passed to the same function - as argument EXPR without interfering with EXPR. INTENT is the intent - of VAR. - - This is considerably less conservative than other dependencies - because many function arguments will already be copied into a - temporary. */ - -static int -gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, - gfc_expr *expr, gfc_dep_check elemental) -{ - gfc_expr *arg; - - gcc_assert (var->expr_type == EXPR_VARIABLE); - gcc_assert (var->rank > 0); - - switch (expr->expr_type) - { - case EXPR_VARIABLE: - /* In case of elemental subroutines, there is no dependency - between two same-range array references. */ - if (gfc_ref_needs_temporary_p (expr->ref) - || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) - { - if (elemental == ELEM_DONT_CHECK_VARIABLE) - { - /* Too many false positive with pointers. */ - if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr)) - { - /* Elemental procedures forbid unspecified intents, - and we don't check dependencies for INTENT_IN args. */ - gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT); - - /* We are told not to check dependencies. - We do it, however, and issue a warning in case we find one. - If a dependency is found in the case - elemental == ELEM_CHECK_VARIABLE, we will generate - a temporary, so we don't need to bother the user. */ - - if (var->expr_type == EXPR_VARIABLE - && expr->expr_type == EXPR_VARIABLE - && strcmp(var->symtree->name, expr->symtree->name) == 0) - gfc_warning (0, "INTENT(%s) actual argument at %L might " - "interfere with actual argument at %L.", - intent == INTENT_OUT ? "OUT" : "INOUT", - &var->where, &expr->where); - } - return 0; - } - else - return 1; - } - return 0; - - case EXPR_ARRAY: - /* the scalarizer always generates a temporary for array constructors, - so there is no dependency. */ - return 0; - - case EXPR_FUNCTION: - if (intent != INTENT_IN) - { - arg = gfc_get_noncopying_intrinsic_argument (expr); - if (arg != NULL) - return gfc_check_argument_var_dependency (var, intent, arg, - NOT_ELEMENTAL); - } - - if (elemental != NOT_ELEMENTAL) - { - if ((expr->value.function.esym - && expr->value.function.esym->attr.elemental) - || (expr->value.function.isym - && expr->value.function.isym->elemental)) - return gfc_check_fncall_dependency (var, intent, NULL, - expr->value.function.actual, - ELEM_CHECK_VARIABLE); - - if (gfc_inline_intrinsic_function_p (expr)) - { - /* The TRANSPOSE case should have been caught in the - noncopying intrinsic case above. */ - gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE); - - return gfc_check_fncall_dependency (var, intent, NULL, - expr->value.function.actual, - ELEM_CHECK_VARIABLE); - } - } - return 0; - - case EXPR_OP: - /* In case of non-elemental procedures, there is no need to catch - dependencies, as we will make a temporary anyway. */ - if (elemental) - { - /* If the actual arg EXPR is an expression, we need to catch - a dependency between variables in EXPR and VAR, - an intent((IN)OUT) variable. */ - if (expr->value.op.op1 - && gfc_check_argument_var_dependency (var, intent, - expr->value.op.op1, - ELEM_CHECK_VARIABLE)) - return 1; - else if (expr->value.op.op2 - && gfc_check_argument_var_dependency (var, intent, - expr->value.op.op2, - ELEM_CHECK_VARIABLE)) - return 1; - } - return 0; - - default: - return 0; - } -} - - -/* Like gfc_check_argument_var_dependency, but extended to any - array expression OTHER, not just variables. */ - -static int -gfc_check_argument_dependency (gfc_expr *other, sym_intent intent, - gfc_expr *expr, gfc_dep_check elemental) -{ - switch (other->expr_type) - { - case EXPR_VARIABLE: - return gfc_check_argument_var_dependency (other, intent, expr, elemental); - - case EXPR_FUNCTION: - other = gfc_get_noncopying_intrinsic_argument (other); - if (other != NULL) - return gfc_check_argument_dependency (other, INTENT_IN, expr, - NOT_ELEMENTAL); - - return 0; - - default: - return 0; - } -} - - -/* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL. - FNSYM is the function being called, or NULL if not known. */ - -int -gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent, - gfc_symbol *fnsym, gfc_actual_arglist *actual, - gfc_dep_check elemental) -{ - gfc_formal_arglist *formal; - gfc_expr *expr; - - formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL; - for (; actual; actual = actual->next, formal = formal ? formal->next : NULL) - { - expr = actual->expr; - - /* Skip args which are not present. */ - if (!expr) - continue; - - /* Skip other itself. */ - if (expr == other) - continue; - - /* Skip intent(in) arguments if OTHER itself is intent(in). */ - if (formal && intent == INTENT_IN - && formal->sym->attr.intent == INTENT_IN) - continue; - - if (gfc_check_argument_dependency (other, intent, expr, elemental)) - return 1; - } - - return 0; -} - - -/* Return 1 if e1 and e2 are equivalenced arrays, either - directly or indirectly; i.e., equivalence (a,b) for a and b - or equivalence (a,c),(b,c). This function uses the equiv_ - lists, generated in trans-common(add_equivalences), that are - guaranteed to pick up indirect equivalences. We explicitly - check for overlap using the offset and length of the equivalence. - This function is symmetric. - TODO: This function only checks whether the full top-level - symbols overlap. An improved implementation could inspect - e1->ref and e2->ref to determine whether the actually accessed - portions of these variables/arrays potentially overlap. */ - -int -gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2) -{ - gfc_equiv_list *l; - gfc_equiv_info *s, *fl1, *fl2; - - gcc_assert (e1->expr_type == EXPR_VARIABLE - && e2->expr_type == EXPR_VARIABLE); - - if (!e1->symtree->n.sym->attr.in_equivalence - || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank) - return 0; - - if (e1->symtree->n.sym->ns - && e1->symtree->n.sym->ns != gfc_current_ns) - l = e1->symtree->n.sym->ns->equiv_lists; - else - l = gfc_current_ns->equiv_lists; - - /* Go through the equiv_lists and return 1 if the variables - e1 and e2 are members of the same group and satisfy the - requirement on their relative offsets. */ - for (; l; l = l->next) - { - fl1 = NULL; - fl2 = NULL; - for (s = l->equiv; s; s = s->next) - { - if (s->sym == e1->symtree->n.sym) - { - fl1 = s; - if (fl2) - break; - } - if (s->sym == e2->symtree->n.sym) - { - fl2 = s; - if (fl1) - break; - } - } - - if (s) - { - /* Can these lengths be zero? */ - if (fl1->length <= 0 || fl2->length <= 0) - return 1; - /* These can't overlap if [f11,fl1+length] is before - [fl2,fl2+length], or [fl2,fl2+length] is before - [fl1,fl1+length], otherwise they do overlap. */ - if (fl1->offset + fl1->length > fl2->offset - && fl2->offset + fl2->length > fl1->offset) - return 1; - } - } - return 0; -} - - -/* Return true if there is no possibility of aliasing because of a type - mismatch between all the possible pointer references and the - potential target. Note that this function is asymmetric in the - arguments and so must be called twice with the arguments exchanged. */ - -static bool -check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2) -{ - gfc_component *cm1; - gfc_symbol *sym1; - gfc_symbol *sym2; - gfc_ref *ref1; - bool seen_component_ref; - - if (expr1->expr_type != EXPR_VARIABLE - || expr2->expr_type != EXPR_VARIABLE) - return false; - - sym1 = expr1->symtree->n.sym; - sym2 = expr2->symtree->n.sym; - - /* Keep it simple for now. */ - if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED) - return false; - - if (sym1->attr.pointer) - { - if (gfc_compare_types (&sym1->ts, &sym2->ts)) - return false; - } - - /* This is a conservative check on the components of the derived type - if no component references have been seen. Since we will not dig - into the components of derived type components, we play it safe by - returning false. First we check the reference chain and then, if - no component references have been seen, the components. */ - seen_component_ref = false; - if (sym1->ts.type == BT_DERIVED) - { - for (ref1 = expr1->ref; ref1; ref1 = ref1->next) - { - if (ref1->type != REF_COMPONENT) - continue; - - if (ref1->u.c.component->ts.type == BT_DERIVED) - return false; - - if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer) - && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts)) - return false; - - seen_component_ref = true; - } - } - - if (sym1->ts.type == BT_DERIVED && !seen_component_ref) - { - for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next) - { - if (cm1->ts.type == BT_DERIVED) - return false; - - if ((sym2->attr.pointer || cm1->attr.pointer) - && gfc_compare_types (&cm1->ts, &sym2->ts)) - return false; - } - } - - return true; -} - - -/* Return true if the statement body redefines the condition. Returns - true if expr2 depends on expr1. expr1 should be a single term - suitable for the lhs of an assignment. The IDENTICAL flag indicates - whether array references to the same symbol with identical range - references count as a dependency or not. Used for forall and where - statements. Also used with functions returning arrays without a - temporary. */ - -int -gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) -{ - gfc_actual_arglist *actual; - gfc_constructor *c; - int n; - - /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION - and a reference to _F.caf_get, so skip the assert. */ - if (expr1->expr_type == EXPR_FUNCTION - && strcmp (expr1->value.function.name, "_F.caf_get") == 0) - return 0; - - if (expr1->expr_type != EXPR_VARIABLE) - gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE"); - - switch (expr2->expr_type) - { - case EXPR_OP: - n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); - if (n) - return n; - if (expr2->value.op.op2) - return gfc_check_dependency (expr1, expr2->value.op.op2, identical); - return 0; - - case EXPR_VARIABLE: - /* The interesting cases are when the symbols don't match. */ - if (expr1->symtree->n.sym != expr2->symtree->n.sym) - { - symbol_attribute attr1, attr2; - gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; - gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; - - /* Return 1 if expr1 and expr2 are equivalenced arrays. */ - if (gfc_are_equivalenced_arrays (expr1, expr2)) - return 1; - - /* Symbols can only alias if they have the same type. */ - if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN - && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) - { - if (ts1->type != ts2->type || ts1->kind != ts2->kind) - return 0; - } - - /* We have to also include target-target as ptr%comp is not a - pointer but it still alias with "dt%comp" for "ptr => dt". As - subcomponents and array access to pointers retains the target - attribute, that's sufficient. */ - attr1 = gfc_expr_attr (expr1); - attr2 = gfc_expr_attr (expr2); - if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target)) - { - if (check_data_pointer_types (expr1, expr2) - && check_data_pointer_types (expr2, expr1)) - return 0; - - return 1; - } - else - { - gfc_symbol *sym1 = expr1->symtree->n.sym; - gfc_symbol *sym2 = expr2->symtree->n.sym; - if (sym1->attr.target && sym2->attr.target - && ((sym1->attr.dummy && !sym1->attr.contiguous - && (!sym1->attr.dimension - || sym2->as->type == AS_ASSUMED_SHAPE)) - || (sym2->attr.dummy && !sym2->attr.contiguous - && (!sym2->attr.dimension - || sym2->as->type == AS_ASSUMED_SHAPE)))) - return 1; - } - - /* Otherwise distinct symbols have no dependencies. */ - return 0; - } - - /* Identical and disjoint ranges return 0, - overlapping ranges return 1. */ - if (expr1->ref && expr2->ref) - return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical); - - return 1; - - case EXPR_FUNCTION: - if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL) - identical = 1; - - /* Remember possible differences between elemental and - transformational functions. All functions inside a FORALL - will be pure. */ - for (actual = expr2->value.function.actual; - actual; actual = actual->next) - { - if (!actual->expr) - continue; - n = gfc_check_dependency (expr1, actual->expr, identical); - if (n) - return n; - } - return 0; - - case EXPR_CONSTANT: - case EXPR_NULL: - return 0; - - case EXPR_ARRAY: - /* Loop through the array constructor's elements. */ - for (c = gfc_constructor_first (expr2->value.constructor); - c; c = gfc_constructor_next (c)) - { - /* If this is an iterator, assume the worst. */ - if (c->iterator) - return 1; - /* Avoid recursion in the common case. */ - if (c->expr->expr_type == EXPR_CONSTANT) - continue; - if (gfc_check_dependency (expr1, c->expr, 1)) - return 1; - } - return 0; - - default: - return 1; - } -} - - -/* Determines overlapping for two array sections. */ - -static gfc_dependency -check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) -{ - gfc_expr *l_start; - gfc_expr *l_end; - gfc_expr *l_stride; - gfc_expr *l_lower; - gfc_expr *l_upper; - int l_dir; - - gfc_expr *r_start; - gfc_expr *r_end; - gfc_expr *r_stride; - gfc_expr *r_lower; - gfc_expr *r_upper; - gfc_expr *one_expr; - int r_dir; - int stride_comparison; - int start_comparison; - mpz_t tmp; - - /* If they are the same range, return without more ado. */ - if (is_same_range (l_ar, r_ar, n)) - return GFC_DEP_EQUAL; - - l_start = l_ar->start[n]; - l_end = l_ar->end[n]; - l_stride = l_ar->stride[n]; - - r_start = r_ar->start[n]; - r_end = r_ar->end[n]; - r_stride = r_ar->stride[n]; - - /* If l_start is NULL take it from array specifier. */ - if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) - l_start = l_ar->as->lower[n]; - /* If l_end is NULL take it from array specifier. */ - if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) - l_end = l_ar->as->upper[n]; - - /* If r_start is NULL take it from array specifier. */ - if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) - r_start = r_ar->as->lower[n]; - /* If r_end is NULL take it from array specifier. */ - if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) - r_end = r_ar->as->upper[n]; - - /* Determine whether the l_stride is positive or negative. */ - if (!l_stride) - l_dir = 1; - else if (l_stride->expr_type == EXPR_CONSTANT - && l_stride->ts.type == BT_INTEGER) - l_dir = mpz_sgn (l_stride->value.integer); - else if (l_start && l_end) - l_dir = gfc_dep_compare_expr (l_end, l_start); - else - l_dir = -2; - - /* Determine whether the r_stride is positive or negative. */ - if (!r_stride) - r_dir = 1; - else if (r_stride->expr_type == EXPR_CONSTANT - && r_stride->ts.type == BT_INTEGER) - r_dir = mpz_sgn (r_stride->value.integer); - else if (r_start && r_end) - r_dir = gfc_dep_compare_expr (r_end, r_start); - else - r_dir = -2; - - /* The strides should never be zero. */ - if (l_dir == 0 || r_dir == 0) - return GFC_DEP_OVERLAP; - - /* Determine the relationship between the strides. Set stride_comparison to - -2 if the dependency cannot be determined - -1 if l_stride < r_stride - 0 if l_stride == r_stride - 1 if l_stride > r_stride - as determined by gfc_dep_compare_expr. */ - - one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - - stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr, - r_stride ? r_stride : one_expr); - - if (l_start && r_start) - start_comparison = gfc_dep_compare_expr (l_start, r_start); - else - start_comparison = -2; - - gfc_free_expr (one_expr); - - /* Determine LHS upper and lower bounds. */ - if (l_dir == 1) - { - l_lower = l_start; - l_upper = l_end; - } - else if (l_dir == -1) - { - l_lower = l_end; - l_upper = l_start; - } - else - { - l_lower = NULL; - l_upper = NULL; - } - - /* Determine RHS upper and lower bounds. */ - if (r_dir == 1) - { - r_lower = r_start; - r_upper = r_end; - } - else if (r_dir == -1) - { - r_lower = r_end; - r_upper = r_start; - } - else - { - r_lower = NULL; - r_upper = NULL; - } - - /* Check whether the ranges are disjoint. */ - if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1) - return GFC_DEP_NODEP; - if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1) - return GFC_DEP_NODEP; - - /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */ - if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0) - { - if (l_dir == 1 && r_dir == -1) - return GFC_DEP_EQUAL; - if (l_dir == -1 && r_dir == 1) - return GFC_DEP_EQUAL; - } - - /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */ - if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0) - { - if (l_dir == 1 && r_dir == -1) - return GFC_DEP_EQUAL; - if (l_dir == -1 && r_dir == 1) - return GFC_DEP_EQUAL; - } - - /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP. - There is no dependency if the remainder of - (l_start - r_start) / gcd(l_stride, r_stride) is - nonzero. - TODO: - - Cases like a(1:4:2) = a(2:3) are still not handled. - */ - -#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ - && (a)->ts.type == BT_INTEGER) - - if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride) - && gfc_dep_difference (l_start, r_start, &tmp)) - { - mpz_t gcd; - int result; - - mpz_init (gcd); - mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); - - mpz_fdiv_r (tmp, tmp, gcd); - result = mpz_cmp_si (tmp, 0L); - - mpz_clear (gcd); - mpz_clear (tmp); - - if (result != 0) - return GFC_DEP_NODEP; - } - -#undef IS_CONSTANT_INTEGER - - /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */ - - if (l_dir == 1 && r_dir == 1 && - (start_comparison == 0 || start_comparison == -1) - && (stride_comparison == 0 || stride_comparison == -1)) - return GFC_DEP_FORWARD; - - /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and - x:y:-1 vs. x:y:-2. */ - if (l_dir == -1 && r_dir == -1 && - (start_comparison == 0 || start_comparison == 1) - && (stride_comparison == 0 || stride_comparison == 1)) - return GFC_DEP_FORWARD; - - if (stride_comparison == 0 || stride_comparison == -1) - { - if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) - { - - /* Check for a(low:y:s) vs. a(z:x:s) or - a(low:y:s) vs. a(z:x:s+1) where a has a lower bound - of low, which is always at least a forward dependence. */ - - if (r_dir == 1 - && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0) - return GFC_DEP_FORWARD; - } - } - - if (stride_comparison == 0 || stride_comparison == 1) - { - if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) - { - - /* Check for a(high:y:-s) vs. a(z:x:-s) or - a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound - of high, which is always at least a forward dependence. */ - - if (r_dir == -1 - && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0) - return GFC_DEP_FORWARD; - } - } - - - if (stride_comparison == 0) - { - /* From here, check for backwards dependencies. */ - /* x+1:y vs. x:z. */ - if (l_dir == 1 && r_dir == 1 && start_comparison == 1) - return GFC_DEP_BACKWARD; - - /* x-1:y:-1 vs. x:z:-1. */ - if (l_dir == -1 && r_dir == -1 && start_comparison == -1) - return GFC_DEP_BACKWARD; - } - - return GFC_DEP_OVERLAP; -} - - -/* Determines overlapping for a single element and a section. */ - -static gfc_dependency -gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n) -{ - gfc_array_ref *ref; - gfc_expr *elem; - gfc_expr *start; - gfc_expr *end; - gfc_expr *stride; - int s; - - elem = lref->u.ar.start[n]; - if (!elem) - return GFC_DEP_OVERLAP; - - ref = &rref->u.ar; - start = ref->start[n] ; - end = ref->end[n] ; - stride = ref->stride[n]; - - if (!start && IS_ARRAY_EXPLICIT (ref->as)) - start = ref->as->lower[n]; - if (!end && IS_ARRAY_EXPLICIT (ref->as)) - end = ref->as->upper[n]; - - /* Determine whether the stride is positive or negative. */ - if (!stride) - s = 1; - else if (stride->expr_type == EXPR_CONSTANT - && stride->ts.type == BT_INTEGER) - s = mpz_sgn (stride->value.integer); - else - s = -2; - - /* Stride should never be zero. */ - if (s == 0) - return GFC_DEP_OVERLAP; - - /* Positive strides. */ - if (s == 1) - { - /* Check for elem < lower. */ - if (start && gfc_dep_compare_expr (elem, start) == -1) - return GFC_DEP_NODEP; - /* Check for elem > upper. */ - if (end && gfc_dep_compare_expr (elem, end) == 1) - return GFC_DEP_NODEP; - - if (start && end) - { - s = gfc_dep_compare_expr (start, end); - /* Check for an empty range. */ - if (s == 1) - return GFC_DEP_NODEP; - if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) - return GFC_DEP_EQUAL; - } - } - /* Negative strides. */ - else if (s == -1) - { - /* Check for elem > upper. */ - if (end && gfc_dep_compare_expr (elem, start) == 1) - return GFC_DEP_NODEP; - /* Check for elem < lower. */ - if (start && gfc_dep_compare_expr (elem, end) == -1) - return GFC_DEP_NODEP; - - if (start && end) - { - s = gfc_dep_compare_expr (start, end); - /* Check for an empty range. */ - if (s == -1) - return GFC_DEP_NODEP; - if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) - return GFC_DEP_EQUAL; - } - } - /* Unknown strides. */ - else - { - if (!start || !end) - return GFC_DEP_OVERLAP; - s = gfc_dep_compare_expr (start, end); - if (s <= -2) - return GFC_DEP_OVERLAP; - /* Assume positive stride. */ - if (s == -1) - { - /* Check for elem < lower. */ - if (gfc_dep_compare_expr (elem, start) == -1) - return GFC_DEP_NODEP; - /* Check for elem > upper. */ - if (gfc_dep_compare_expr (elem, end) == 1) - return GFC_DEP_NODEP; - } - /* Assume negative stride. */ - else if (s == 1) - { - /* Check for elem > upper. */ - if (gfc_dep_compare_expr (elem, start) == 1) - return GFC_DEP_NODEP; - /* Check for elem < lower. */ - if (gfc_dep_compare_expr (elem, end) == -1) - return GFC_DEP_NODEP; - } - /* Equal bounds. */ - else if (s == 0) - { - s = gfc_dep_compare_expr (elem, start); - if (s == 0) - return GFC_DEP_EQUAL; - if (s == 1 || s == -1) - return GFC_DEP_NODEP; - } - } - - return GFC_DEP_OVERLAP; -} - - -/* Traverse expr, checking all EXPR_VARIABLE symbols for their - forall_index attribute. Return true if any variable may be - being used as a FORALL index. Its safe to pessimistically - return true, and assume a dependency. */ - -static bool -contains_forall_index_p (gfc_expr *expr) -{ - gfc_actual_arglist *arg; - gfc_constructor *c; - gfc_ref *ref; - int i; - - if (!expr) - return false; - - switch (expr->expr_type) - { - case EXPR_VARIABLE: - if (expr->symtree->n.sym->forall_index) - return true; - break; - - case EXPR_OP: - if (contains_forall_index_p (expr->value.op.op1) - || contains_forall_index_p (expr->value.op.op2)) - return true; - break; - - case EXPR_FUNCTION: - for (arg = expr->value.function.actual; arg; arg = arg->next) - if (contains_forall_index_p (arg->expr)) - return true; - break; - - case EXPR_CONSTANT: - case EXPR_NULL: - case EXPR_SUBSTRING: - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - for (c = gfc_constructor_first (expr->value.constructor); - c; gfc_constructor_next (c)) - if (contains_forall_index_p (c->expr)) - return true; - break; - - default: - gcc_unreachable (); - } - - for (ref = expr->ref; ref; ref = ref->next) - switch (ref->type) - { - case REF_ARRAY: - for (i = 0; i < ref->u.ar.dimen; i++) - if (contains_forall_index_p (ref->u.ar.start[i]) - || contains_forall_index_p (ref->u.ar.end[i]) - || contains_forall_index_p (ref->u.ar.stride[i])) - return true; - break; - - case REF_COMPONENT: - break; - - case REF_SUBSTRING: - if (contains_forall_index_p (ref->u.ss.start) - || contains_forall_index_p (ref->u.ss.end)) - return true; - break; - - default: - gcc_unreachable (); - } - - return false; -} - -/* Determines overlapping for two single element array references. */ - -static gfc_dependency -gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n) -{ - gfc_array_ref l_ar; - gfc_array_ref r_ar; - gfc_expr *l_start; - gfc_expr *r_start; - int i; - - l_ar = lref->u.ar; - r_ar = rref->u.ar; - l_start = l_ar.start[n] ; - r_start = r_ar.start[n] ; - i = gfc_dep_compare_expr (r_start, l_start); - if (i == 0) - return GFC_DEP_EQUAL; - - /* Treat two scalar variables as potentially equal. This allows - us to prove that a(i,:) and a(j,:) have no dependency. See - Gerald Roth, "Evaluation of Array Syntax Dependence Analysis", - Proceedings of the International Conference on Parallel and - Distributed Processing Techniques and Applications (PDPTA2001), - Las Vegas, Nevada, June 2001. */ - /* However, we need to be careful when either scalar expression - contains a FORALL index, as these can potentially change value - during the scalarization/traversal of this array reference. */ - if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start)) - return GFC_DEP_OVERLAP; - - if (i > -2) - return GFC_DEP_NODEP; - - return GFC_DEP_EQUAL; -} - -/* Callback function for checking if an expression depends on a - dummy variable which is any other than INTENT(IN). */ - -static int -callback_dummy_intent_not_in (gfc_expr **ep, - int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_expr *e = *ep; - - if (e->expr_type == EXPR_VARIABLE && e->symtree - && e->symtree->n.sym->attr.dummy) - return e->symtree->n.sym->attr.intent != INTENT_IN; - else - return 0; -} - -/* Auxiliary function to check if subexpressions have dummy variables which - are not intent(in). -*/ - -static bool -dummy_intent_not_in (gfc_expr **ep) -{ - return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL); -} - -/* Determine if an array ref, usually an array section specifies the - entire array. In addition, if the second, pointer argument is - provided, the function will return true if the reference is - contiguous; eg. (:, 1) gives true but (1,:) gives false. - If one of the bounds depends on a dummy variable which is - not INTENT(IN), also return false, because the user may - have changed the variable. */ - -bool -gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) -{ - int i; - int n; - bool lbound_OK = true; - bool ubound_OK = true; - - if (contiguous) - *contiguous = false; - - if (ref->type != REF_ARRAY) - return false; - - if (ref->u.ar.type == AR_FULL) - { - if (contiguous) - *contiguous = true; - return true; - } - - if (ref->u.ar.type != AR_SECTION) - return false; - if (ref->next) - return false; - - for (i = 0; i < ref->u.ar.dimen; i++) - { - /* If we have a single element in the reference, for the reference - to be full, we need to ascertain that the array has a single - element in this dimension and that we actually reference the - correct element. */ - if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) - { - /* This is unconditionally a contiguous reference if all the - remaining dimensions are elements. */ - if (contiguous) - { - *contiguous = true; - for (n = i + 1; n < ref->u.ar.dimen; n++) - if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) - *contiguous = false; - } - - if (!ref->u.ar.as - || !ref->u.ar.as->lower[i] - || !ref->u.ar.as->upper[i] - || gfc_dep_compare_expr (ref->u.ar.as->lower[i], - ref->u.ar.as->upper[i]) - || !ref->u.ar.start[i] - || gfc_dep_compare_expr (ref->u.ar.start[i], - ref->u.ar.as->lower[i])) - return false; - else - continue; - } - - /* Check the lower bound. */ - if (ref->u.ar.start[i] - && (!ref->u.ar.as - || !ref->u.ar.as->lower[i] - || gfc_dep_compare_expr (ref->u.ar.start[i], - ref->u.ar.as->lower[i]) - || dummy_intent_not_in (&ref->u.ar.start[i]))) - lbound_OK = false; - /* Check the upper bound. */ - if (ref->u.ar.end[i] - && (!ref->u.ar.as - || !ref->u.ar.as->upper[i] - || gfc_dep_compare_expr (ref->u.ar.end[i], - ref->u.ar.as->upper[i]) - || dummy_intent_not_in (&ref->u.ar.end[i]))) - ubound_OK = false; - /* Check the stride. */ - if (ref->u.ar.stride[i] - && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) - return false; - - /* This is unconditionally a contiguous reference as long as all - the subsequent dimensions are elements. */ - if (contiguous) - { - *contiguous = true; - for (n = i + 1; n < ref->u.ar.dimen; n++) - if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) - *contiguous = false; - } - - if (!lbound_OK || !ubound_OK) - return false; - } - return true; -} - - -/* Determine if a full array is the same as an array section with one - variable limit. For this to be so, the strides must both be unity - and one of either start == lower or end == upper must be true. */ - -static bool -ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) -{ - int i; - bool upper_or_lower; - - if (full_ref->type != REF_ARRAY) - return false; - if (full_ref->u.ar.type != AR_FULL) - return false; - if (ref->type != REF_ARRAY) - return false; - if (ref->u.ar.type == AR_FULL) - return true; - if (ref->u.ar.type != AR_SECTION) - return false; - - for (i = 0; i < ref->u.ar.dimen; i++) - { - /* If we have a single element in the reference, we need to check - that the array has a single element and that we actually reference - the correct element. */ - if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) - { - if (!full_ref->u.ar.as - || !full_ref->u.ar.as->lower[i] - || !full_ref->u.ar.as->upper[i] - || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i], - full_ref->u.ar.as->upper[i]) - || !ref->u.ar.start[i] - || gfc_dep_compare_expr (ref->u.ar.start[i], - full_ref->u.ar.as->lower[i])) - return false; - } - - /* Check the strides. */ - if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0)) - return false; - if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) - return false; - - upper_or_lower = false; - /* Check the lower bound. */ - if (ref->u.ar.start[i] - && (ref->u.ar.as - && full_ref->u.ar.as->lower[i] - && gfc_dep_compare_expr (ref->u.ar.start[i], - full_ref->u.ar.as->lower[i]) == 0)) - upper_or_lower = true; - /* Check the upper bound. */ - if (ref->u.ar.end[i] - && (ref->u.ar.as - && full_ref->u.ar.as->upper[i] - && gfc_dep_compare_expr (ref->u.ar.end[i], - full_ref->u.ar.as->upper[i]) == 0)) - upper_or_lower = true; - if (!upper_or_lower) - return false; - } - return true; -} - - -/* Finds if two array references are overlapping or not. - Return value - 2 : array references are overlapping but reversal of one or - more dimensions will clear the dependency. - 1 : array references are overlapping, or identical is true and - there is some kind of overlap. - 0 : array references are identical or not overlapping. */ - -int -gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse, - bool identical) -{ - int n; - int m; - gfc_dependency fin_dep; - gfc_dependency this_dep; - bool same_component = false; - - this_dep = GFC_DEP_ERROR; - fin_dep = GFC_DEP_ERROR; - /* Dependencies due to pointers should already have been identified. - We only need to check for overlapping array references. */ - - while (lref && rref) - { - /* The refs might come in mixed, one with a _data component and one - without. Look at their next reference in order to avoid an - ICE. */ - - if (lref && lref->type == REF_COMPONENT && lref->u.c.component - && strcmp (lref->u.c.component->name, "_data") == 0) - lref = lref->next; - - if (rref && rref->type == REF_COMPONENT && rref->u.c.component - && strcmp (rref->u.c.component->name, "_data") == 0) - rref = rref->next; - - /* We're resolving from the same base symbol, so both refs should be - the same type. We traverse the reference chain until we find ranges - that are not equal. */ - gcc_assert (lref->type == rref->type); - switch (lref->type) - { - case REF_COMPONENT: - /* The two ranges can't overlap if they are from different - components. */ - if (lref->u.c.component != rref->u.c.component) - return 0; - - same_component = true; - break; - - case REF_SUBSTRING: - /* Substring overlaps are handled by the string assignment code - if there is not an underlying dependency. */ - return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0; - - case REF_ARRAY: - /* Coarrays: If there is a coindex, either the image differs and there - is no overlap or the image is the same - then the normal analysis - applies. Hence, return early if either ref is coindexed and more - than one image can exist. */ - if (flag_coarray != GFC_FCOARRAY_SINGLE - && ((lref->u.ar.codimen - && lref->u.ar.dimen_type[lref->u.ar.dimen] - != DIMEN_THIS_IMAGE) - || (rref->u.ar.codimen - && lref->u.ar.dimen_type[lref->u.ar.dimen] - != DIMEN_THIS_IMAGE))) - return 1; - if (lref->u.ar.dimen == 0 || rref->u.ar.dimen == 0) - { - /* Coindexed scalar coarray with GFC_FCOARRAY_SINGLE. */ - if (lref->u.ar.dimen || rref->u.ar.dimen) - return 1; /* Just to be sure. */ - fin_dep = GFC_DEP_EQUAL; - break; - } - - if (ref_same_as_full_array (lref, rref)) - return identical; - - if (ref_same_as_full_array (rref, lref)) - return identical; - - if (lref->u.ar.dimen != rref->u.ar.dimen) - { - if (lref->u.ar.type == AR_FULL) - fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL - : GFC_DEP_OVERLAP; - else if (rref->u.ar.type == AR_FULL) - fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL - : GFC_DEP_OVERLAP; - else - return 1; - break; - } - - /* Index for the reverse array. */ - m = -1; - for (n = 0; n < lref->u.ar.dimen; n++) - { - /* Handle dependency when either of array reference is vector - subscript. There is no dependency if the vector indices - are equal or if indices are known to be different in a - different dimension. */ - if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR - || rref->u.ar.dimen_type[n] == DIMEN_VECTOR) - { - if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR - && rref->u.ar.dimen_type[n] == DIMEN_VECTOR - && gfc_dep_compare_expr (lref->u.ar.start[n], - rref->u.ar.start[n]) == 0) - this_dep = GFC_DEP_EQUAL; - else - this_dep = GFC_DEP_OVERLAP; - - goto update_fin_dep; - } - - if (lref->u.ar.dimen_type[n] == DIMEN_RANGE - && rref->u.ar.dimen_type[n] == DIMEN_RANGE) - this_dep = check_section_vs_section (&lref->u.ar, - &rref->u.ar, n); - else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT - && rref->u.ar.dimen_type[n] == DIMEN_RANGE) - this_dep = gfc_check_element_vs_section (lref, rref, n); - else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT - && lref->u.ar.dimen_type[n] == DIMEN_RANGE) - this_dep = gfc_check_element_vs_section (rref, lref, n); - else - { - gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT - && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT); - this_dep = gfc_check_element_vs_element (rref, lref, n); - if (identical && this_dep == GFC_DEP_EQUAL) - this_dep = GFC_DEP_OVERLAP; - } - - /* If any dimension doesn't overlap, we have no dependency. */ - if (this_dep == GFC_DEP_NODEP) - return 0; - - /* Now deal with the loop reversal logic: This only works on - ranges and is activated by setting - reverse[n] == GFC_ENABLE_REVERSE - The ability to reverse or not is set by previous conditions - in this dimension. If reversal is not activated, the - value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */ - - /* Get the indexing right for the scalarizing loop. If this - is an element, there is no corresponding loop. */ - if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT) - m++; - - if (rref->u.ar.dimen_type[n] == DIMEN_RANGE - && lref->u.ar.dimen_type[n] == DIMEN_RANGE) - { - if (reverse) - { - /* Reverse if backward dependence and not inhibited. */ - if (reverse[m] == GFC_ENABLE_REVERSE - && this_dep == GFC_DEP_BACKWARD) - reverse[m] = GFC_REVERSE_SET; - - /* Forward if forward dependence and not inhibited. */ - if (reverse[m] == GFC_ENABLE_REVERSE - && this_dep == GFC_DEP_FORWARD) - reverse[m] = GFC_FORWARD_SET; - - /* Flag up overlap if dependence not compatible with - the overall state of the expression. */ - if (reverse[m] == GFC_REVERSE_SET - && this_dep == GFC_DEP_FORWARD) - { - reverse[m] = GFC_INHIBIT_REVERSE; - this_dep = GFC_DEP_OVERLAP; - } - else if (reverse[m] == GFC_FORWARD_SET - && this_dep == GFC_DEP_BACKWARD) - { - reverse[m] = GFC_INHIBIT_REVERSE; - this_dep = GFC_DEP_OVERLAP; - } - } - - /* If no intention of reversing or reversing is explicitly - inhibited, convert backward dependence to overlap. */ - if ((!reverse && this_dep == GFC_DEP_BACKWARD) - || (reverse && reverse[m] == GFC_INHIBIT_REVERSE)) - this_dep = GFC_DEP_OVERLAP; - } - - /* Overlap codes are in order of priority. We only need to - know the worst one.*/ - - update_fin_dep: - if (identical && this_dep == GFC_DEP_EQUAL) - this_dep = GFC_DEP_OVERLAP; - - if (this_dep > fin_dep) - fin_dep = this_dep; - } - - /* If this is an equal element, we have to keep going until we find - the "real" array reference. */ - if (lref->u.ar.type == AR_ELEMENT - && rref->u.ar.type == AR_ELEMENT - && fin_dep == GFC_DEP_EQUAL) - break; - - /* Exactly matching and forward overlapping ranges don't cause a - dependency. */ - if (fin_dep < GFC_DEP_BACKWARD && !identical) - return 0; - - /* Keep checking. We only have a dependency if - subsequent references also overlap. */ - break; - - case REF_INQUIRY: - if (lref->u.i != rref->u.i) - return 0; - - break; - - default: - gcc_unreachable (); - } - lref = lref->next; - rref = rref->next; - } - - /* Assume the worst if we nest to different depths. */ - if (lref || rref) - return 1; - - /* This can result from concatenation of assumed length string components. */ - if (same_component && fin_dep == GFC_DEP_ERROR) - return 1; - - /* If we haven't seen any array refs then something went wrong. */ - gcc_assert (fin_dep != GFC_DEP_ERROR); - - if (identical && fin_dep != GFC_DEP_NODEP) - return 1; - - return fin_dep == GFC_DEP_OVERLAP; -} diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc new file mode 100644 index 0000000..5d28606 --- /dev/null +++ b/gcc/fortran/dependency.cc @@ -0,0 +1,2336 @@ +/* Dependency analysis + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + +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 +. */ + +/* dependency.c -- Expression dependency analysis code. */ +/* There's probably quite a bit of duplication in this file. We currently + have different dependency checking functions for different types + if dependencies. Ideally these would probably be merged. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "dependency.h" +#include "constructor.h" +#include "arith.h" +#include "options.h" + +/* static declarations */ +/* Enums */ +enum range {LHS, RHS, MID}; + +/* Dependency types. These must be in reverse order of priority. */ +enum gfc_dependency +{ + GFC_DEP_ERROR, + GFC_DEP_EQUAL, /* Identical Ranges. */ + GFC_DEP_FORWARD, /* e.g., a(1:3) = a(2:4). */ + GFC_DEP_BACKWARD, /* e.g. a(2:4) = a(1:3). */ + GFC_DEP_OVERLAP, /* May overlap in some other way. */ + GFC_DEP_NODEP /* Distinct ranges. */ +}; + +/* Macros */ +#define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0)) + +/* Forward declarations */ + +static gfc_dependency check_section_vs_section (gfc_array_ref *, + gfc_array_ref *, int); + +/* Returns 1 if the expr is an integer constant value 1, 0 if it is not or + def if the value could not be determined. */ + +int +gfc_expr_is_one (gfc_expr *expr, int def) +{ + gcc_assert (expr != NULL); + + if (expr->expr_type != EXPR_CONSTANT) + return def; + + if (expr->ts.type != BT_INTEGER) + return def; + + return mpz_cmp_si (expr->value.integer, 1) == 0; +} + +/* Check if two array references are known to be identical. Calls + gfc_dep_compare_expr if necessary for comparing array indices. */ + +static bool +identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2) +{ + int i; + + if (a1->type == AR_FULL && a2->type == AR_FULL) + return true; + + if (a1->type == AR_SECTION && a2->type == AR_SECTION) + { + gcc_assert (a1->dimen == a2->dimen); + + for ( i = 0; i < a1->dimen; i++) + { + /* TODO: Currently, we punt on an integer array as an index. */ + if (a1->dimen_type[i] != DIMEN_RANGE + || a2->dimen_type[i] != DIMEN_RANGE) + return false; + + if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL) + return false; + } + return true; + } + + if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT) + { + if (a1->dimen != a2->dimen) + gfc_internal_error ("identical_array_ref(): inconsistent dimensions"); + + for (i = 0; i < a1->dimen; i++) + { + if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0) + return false; + } + return true; + } + return false; +} + + + +/* Return true for identical variables, checking for references if + necessary. Calls identical_array_ref for checking array sections. */ + +static bool +are_identical_variables (gfc_expr *e1, gfc_expr *e2) +{ + gfc_ref *r1, *r2; + + if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy) + { + /* Dummy arguments: Only check for equal names. */ + if (e1->symtree->n.sym->name != e2->symtree->n.sym->name) + return false; + } + else + { + /* Check for equal symbols. */ + if (e1->symtree->n.sym != e2->symtree->n.sym) + return false; + } + + /* Volatile variables should never compare equal to themselves. */ + + if (e1->symtree->n.sym->attr.volatile_) + return false; + + r1 = e1->ref; + r2 = e2->ref; + + while (r1 != NULL || r2 != NULL) + { + + /* Assume the variables are not equal if one has a reference and the + other doesn't. + TODO: Handle full references like comparing a(:) to a. + */ + + if (r1 == NULL || r2 == NULL) + return false; + + if (r1->type != r2->type) + return false; + + switch (r1->type) + { + + case REF_ARRAY: + if (!identical_array_ref (&r1->u.ar, &r2->u.ar)) + return false; + + break; + + case REF_COMPONENT: + if (r1->u.c.component != r2->u.c.component) + return false; + break; + + case REF_SUBSTRING: + if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0) + return false; + + /* If both are NULL, the end length compares equal, because we + are looking at the same variable. This can only happen for + assumed- or deferred-length character arguments. */ + + if (r1->u.ss.end == NULL && r2->u.ss.end == NULL) + break; + + if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0) + return false; + + break; + + case REF_INQUIRY: + if (r1->u.i != r2->u.i) + return false; + break; + + default: + gfc_internal_error ("are_identical_variables: Bad type"); + } + r1 = r1->next; + r2 = r2->next; + } + return true; +} + +/* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If + impure_ok is false, only return 0 for pure functions. */ + +int +gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok) +{ + + gfc_actual_arglist *args1; + gfc_actual_arglist *args2; + + if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION) + return -2; + + if ((e1->value.function.esym && e2->value.function.esym + && e1->value.function.esym == e2->value.function.esym + && (e1->value.function.esym->result->attr.pure || impure_ok)) + || (e1->value.function.isym && e2->value.function.isym + && e1->value.function.isym == e2->value.function.isym + && (e1->value.function.isym->pure || impure_ok))) + { + args1 = e1->value.function.actual; + args2 = e2->value.function.actual; + + /* Compare the argument lists for equality. */ + while (args1 && args2) + { + /* Bitwise xor, since C has no non-bitwise xor operator. */ + if ((args1->expr == NULL) ^ (args2->expr == NULL)) + return -2; + + if (args1->expr != NULL && args2->expr != NULL) + { + gfc_expr *e1, *e2; + e1 = args1->expr; + e2 = args2->expr; + + if (gfc_dep_compare_expr (e1, e2) != 0) + return -2; + + /* Special case: String arguments which compare equal can have + different lengths, which makes them different in calls to + procedures. */ + + if (e1->expr_type == EXPR_CONSTANT + && e1->ts.type == BT_CHARACTER + && e2->expr_type == EXPR_CONSTANT + && e2->ts.type == BT_CHARACTER + && e1->value.character.length != e2->value.character.length) + return -2; + } + + args1 = args1->next; + args2 = args2->next; + } + return (args1 || args2) ? -2 : 0; + } + else + return -2; +} + +/* Helper function to look through parens, unary plus and widening + integer conversions. */ + +gfc_expr * +gfc_discard_nops (gfc_expr *e) +{ + gfc_actual_arglist *arglist; + + if (e == NULL) + return NULL; + + while (true) + { + if (e->expr_type == EXPR_OP + && (e->value.op.op == INTRINSIC_UPLUS + || e->value.op.op == INTRINSIC_PARENTHESES)) + { + e = e->value.op.op1; + continue; + } + + if (e->expr_type == EXPR_FUNCTION && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CONVERSION + && e->ts.type == BT_INTEGER) + { + arglist = e->value.function.actual; + if (arglist->expr->ts.type == BT_INTEGER + && e->ts.kind > arglist->expr->ts.kind) + { + e = arglist->expr; + continue; + } + } + break; + } + + return e; +} + + +/* Compare two expressions. Return values: + * +1 if e1 > e2 + * 0 if e1 == e2 + * -1 if e1 < e2 + * -2 if the relationship could not be determined + * -3 if e1 /= e2, but we cannot tell which one is larger. + REAL and COMPLEX constants are only compared for equality + or inequality; if they are unequal, -2 is returned in all cases. */ + +int +gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) +{ + int i; + + if (e1 == NULL && e2 == NULL) + return 0; + else if (e1 == NULL || e2 == NULL) + return -2; + + e1 = gfc_discard_nops (e1); + e2 = gfc_discard_nops (e2); + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) + { + /* Compare X+C vs. X, for INTEGER only. */ + if (e1->value.op.op2->expr_type == EXPR_CONSTANT + && e1->value.op.op2->ts.type == BT_INTEGER + && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) + return mpz_sgn (e1->value.op.op2->value.integer); + + /* Compare P+Q vs. R+S. */ + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + int l, r; + + l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); + r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); + if (l == 0 && r == 0) + return 0; + if (l == 0 && r > -2) + return r; + if (l > -2 && r == 0) + return l; + if (l == 1 && r == 1) + return 1; + if (l == -1 && r == -1) + return -1; + + l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2); + r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1); + if (l == 0 && r == 0) + return 0; + if (l == 0 && r > -2) + return r; + if (l > -2 && r == 0) + return l; + if (l == 1 && r == 1) + return 1; + if (l == -1 && r == -1) + return -1; + } + } + + /* Compare X vs. X+C, for INTEGER only. */ + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + if (e2->value.op.op2->expr_type == EXPR_CONSTANT + && e2->value.op.op2->ts.type == BT_INTEGER + && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) + return -mpz_sgn (e2->value.op.op2->value.integer); + } + + /* Compare X-C vs. X, for INTEGER only. */ + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) + { + if (e1->value.op.op2->expr_type == EXPR_CONSTANT + && e1->value.op.op2->ts.type == BT_INTEGER + && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) + return -mpz_sgn (e1->value.op.op2->value.integer); + + /* Compare P-Q vs. R-S. */ + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + int l, r; + + l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); + r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); + if (l == 0 && r == 0) + return 0; + if (l > -2 && r == 0) + return l; + if (l == 0 && r > -2) + return -r; + if (l == 1 && r == -1) + return 1; + if (l == -1 && r == 1) + return -1; + } + } + + /* Compare A // B vs. C // D. */ + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT + && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT) + { + int l, r; + + l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); + r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); + + if (l != 0) + return l; + + /* Left expressions of // compare equal, but + watch out for 'A ' // x vs. 'A' // x. */ + gfc_expr *e1_left = e1->value.op.op1; + gfc_expr *e2_left = e2->value.op.op1; + + if (e1_left->expr_type == EXPR_CONSTANT + && e2_left->expr_type == EXPR_CONSTANT + && e1_left->value.character.length + != e2_left->value.character.length) + return -2; + else + return r; + } + + /* Compare X vs. X-C, for INTEGER only. */ + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + if (e2->value.op.op2->expr_type == EXPR_CONSTANT + && e2->value.op.op2->ts.type == BT_INTEGER + && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) + return mpz_sgn (e2->value.op.op2->value.integer); + } + + if (e1->expr_type != e2->expr_type) + return -3; + + switch (e1->expr_type) + { + case EXPR_CONSTANT: + /* Compare strings for equality. */ + if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER) + return gfc_compare_string (e1, e2); + + /* Compare REAL and COMPLEX constants. Because of the + traps and pitfalls associated with comparing + a + 1.0 with a + 0.5, check for equality only. */ + if (e2->expr_type == EXPR_CONSTANT) + { + if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL) + { + if (mpfr_cmp (e1->value.real, e2->value.real) == 0) + return 0; + else + return -2; + } + else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX) + { + if (mpc_cmp (e1->value.complex, e2->value.complex) == 0) + return 0; + else + return -2; + } + } + + if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) + return -2; + + /* For INTEGER, all cases where e2 is not constant should have + been filtered out above. */ + gcc_assert (e2->expr_type == EXPR_CONSTANT); + + i = mpz_cmp (e1->value.integer, e2->value.integer); + if (i == 0) + return 0; + else if (i < 0) + return -1; + return 1; + + case EXPR_VARIABLE: + if (are_identical_variables (e1, e2)) + return 0; + else + return -3; + + case EXPR_OP: + /* Intrinsic operators are the same if their operands are the same. */ + if (e1->value.op.op != e2->value.op.op) + return -2; + if (e1->value.op.op2 == 0) + { + i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); + return i == 0 ? 0 : -2; + } + if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0 + && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0) + return 0; + else if (e1->value.op.op == INTRINSIC_TIMES + && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0 + && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0) + /* Commutativity of multiplication; addition is handled above. */ + return 0; + + return -2; + + case EXPR_FUNCTION: + return gfc_dep_compare_functions (e1, e2, false); + + default: + return -2; + } +} + + +/* Return the difference between two expressions. Integer expressions of + the form + + X + constant, X - constant and constant + X + + are handled. Return true on success, false on failure. result is assumed + to be uninitialized on entry, and will be initialized on success. +*/ + +bool +gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result) +{ + gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2; + + if (e1 == NULL || e2 == NULL) + return false; + + if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) + return false; + + e1 = gfc_discard_nops (e1); + e2 = gfc_discard_nops (e2); + + /* Inizialize tentatively, clear if we don't return anything. */ + mpz_init (*result); + + /* Case 1: c1 - c2 = c1 - c2, trivially. */ + + if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT) + { + mpz_sub (*result, e1->value.integer, e2->value.integer); + return true; + } + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) + { + e1_op1 = gfc_discard_nops (e1->value.op.op1); + e1_op2 = gfc_discard_nops (e1->value.op.op2); + + /* Case 2: (X + c1) - X = c1. */ + if (e1_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2) == 0) + { + mpz_set (*result, e1_op2->value.integer); + return true; + } + + /* Case 3: (c1 + X) - X = c1. */ + if (e1_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2) == 0) + { + mpz_set (*result, e1_op1->value.integer); + return true; + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = gfc_discard_nops (e2->value.op.op1); + e2_op2 = gfc_discard_nops (e2->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 4: X + c1 - (X + c2) = c1 - c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_sub (*result, e1_op2->value.integer, + e2_op2->value.integer); + return true; + } + /* Case 5: X + c1 - (c2 + X) = c1 - c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) + { + mpz_sub (*result, e1_op2->value.integer, + e2_op1->value.integer); + return true; + } + } + else if (e1_op1->expr_type == EXPR_CONSTANT) + { + /* Case 6: c1 + X - (X + c2) = c1 - c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op2->value.integer); + return true; + } + /* Case 7: c1 + X - (c2 + X) = c1 - c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op2) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op1->value.integer); + return true; + } + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = gfc_discard_nops (e2->value.op.op1); + e2_op2 = gfc_discard_nops (e2->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 8: X + c1 - (X - c2) = c1 + c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op2->value.integer); + return true; + } + } + if (e1_op1->expr_type == EXPR_CONSTANT) + { + /* Case 9: c1 + X - (X - c2) = c1 + c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) + { + mpz_add (*result, e1_op1->value.integer, + e2_op2->value.integer); + return true; + } + } + } + } + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) + { + e1_op1 = gfc_discard_nops (e1->value.op.op1); + e1_op2 = gfc_discard_nops (e1->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 10: (X - c1) - X = -c1 */ + + if (gfc_dep_compare_expr (e1_op1, e2) == 0) + { + mpz_neg (*result, e1_op2->value.integer); + return true; + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = gfc_discard_nops (e2->value.op.op1); + e2_op2 = gfc_discard_nops (e2->value.op.op2); + + /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op2->value.integer); + mpz_neg (*result, *result); + return true; + } + + /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op1->value.integer); + mpz_neg (*result, *result); + return true; + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = gfc_discard_nops (e2->value.op.op1); + e2_op2 = gfc_discard_nops (e2->value.op.op2); + + /* Case 13: (X - c1) - (X - c2) = c2 - c1. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_sub (*result, e2_op2->value.integer, + e1_op2->value.integer); + return true; + } + } + } + if (e1_op1->expr_type == EXPR_CONSTANT) + { + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = gfc_discard_nops (e2->value.op.op1); + e2_op2 = gfc_discard_nops (e2->value.op.op2); + + /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */ + if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op1->value.integer); + return true; + } + } + + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = gfc_discard_nops (e2->value.op.op1); + e2_op2 = gfc_discard_nops (e2->value.op.op2); + + /* Case 15: X - (X + c2) = -c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op1) == 0) + { + mpz_neg (*result, e2_op2->value.integer); + return true; + } + /* Case 16: X - (c2 + X) = -c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op2) == 0) + { + mpz_neg (*result, e2_op1->value.integer); + return true; + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = gfc_discard_nops (e2->value.op.op1); + e2_op2 = gfc_discard_nops (e2->value.op.op2); + + /* Case 17: X - (X - c2) = c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op1) == 0) + { + mpz_set (*result, e2_op2->value.integer); + return true; + } + } + + if (gfc_dep_compare_expr (e1, e2) == 0) + { + /* Case 18: X - X = 0. */ + mpz_set_si (*result, 0); + return true; + } + + mpz_clear (*result); + return false; +} + +/* Returns 1 if the two ranges are the same and 0 if they are not (or if the + results are indeterminate). 'n' is the dimension to compare. */ + +static int +is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n) +{ + gfc_expr *e1; + gfc_expr *e2; + int i; + + /* TODO: More sophisticated range comparison. */ + gcc_assert (ar1 && ar2); + + gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]); + + e1 = ar1->stride[n]; + e2 = ar2->stride[n]; + /* Check for mismatching strides. A NULL stride means a stride of 1. */ + if (e1 && !e2) + { + i = gfc_expr_is_one (e1, -1); + if (i == -1 || i == 0) + return 0; + } + else if (e2 && !e1) + { + i = gfc_expr_is_one (e2, -1); + if (i == -1 || i == 0) + return 0; + } + else if (e1 && e2) + { + i = gfc_dep_compare_expr (e1, e2); + if (i != 0) + return 0; + } + /* The strides match. */ + + /* Check the range start. */ + e1 = ar1->start[n]; + e2 = ar2->start[n]; + if (e1 || e2) + { + /* Use the bound of the array if no bound is specified. */ + if (ar1->as && !e1) + e1 = ar1->as->lower[n]; + + if (ar2->as && !e2) + e2 = ar2->as->lower[n]; + + /* Check we have values for both. */ + if (!(e1 && e2)) + return 0; + + i = gfc_dep_compare_expr (e1, e2); + if (i != 0) + return 0; + } + + /* Check the range end. */ + e1 = ar1->end[n]; + e2 = ar2->end[n]; + if (e1 || e2) + { + /* Use the bound of the array if no bound is specified. */ + if (ar1->as && !e1) + e1 = ar1->as->upper[n]; + + if (ar2->as && !e2) + e2 = ar2->as->upper[n]; + + /* Check we have values for both. */ + if (!(e1 && e2)) + return 0; + + i = gfc_dep_compare_expr (e1, e2); + if (i != 0) + return 0; + } + + return 1; +} + + +/* Some array-returning intrinsics can be implemented by reusing the + data from one of the array arguments. For example, TRANSPOSE does + not necessarily need to allocate new data: it can be implemented + by copying the original array's descriptor and simply swapping the + two dimension specifications. + + If EXPR is a call to such an intrinsic, return the argument + whose data can be reused, otherwise return NULL. */ + +gfc_expr * +gfc_get_noncopying_intrinsic_argument (gfc_expr *expr) +{ + if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym) + return NULL; + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_TRANSPOSE: + return expr->value.function.actual->expr; + + default: + return NULL; + } +} + + +/* Return true if the result of reference REF can only be constructed + using a temporary array. */ + +bool +gfc_ref_needs_temporary_p (gfc_ref *ref) +{ + int n; + bool subarray_p; + + subarray_p = false; + for (; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + /* Vector dimensions are generally not monotonic and must be + handled using a temporary. */ + if (ref->u.ar.type == AR_SECTION) + for (n = 0; n < ref->u.ar.dimen; n++) + if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) + return true; + + subarray_p = true; + break; + + case REF_SUBSTRING: + /* Within an array reference, character substrings generally + need a temporary. Character array strides are expressed as + multiples of the element size (consistent with other array + types), not in characters. */ + return subarray_p; + + case REF_COMPONENT: + case REF_INQUIRY: + break; + } + + return false; +} + + +static int +gfc_is_data_pointer (gfc_expr *e) +{ + gfc_ref *ref; + + if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) + return 0; + + /* No subreference if it is a function */ + gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref); + + if (e->symtree->n.sym->attr.pointer) + return 1; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) + return 1; + + return 0; +} + + +/* Return true if array variable VAR could be passed to the same function + as argument EXPR without interfering with EXPR. INTENT is the intent + of VAR. + + This is considerably less conservative than other dependencies + because many function arguments will already be copied into a + temporary. */ + +static int +gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, + gfc_expr *expr, gfc_dep_check elemental) +{ + gfc_expr *arg; + + gcc_assert (var->expr_type == EXPR_VARIABLE); + gcc_assert (var->rank > 0); + + switch (expr->expr_type) + { + case EXPR_VARIABLE: + /* In case of elemental subroutines, there is no dependency + between two same-range array references. */ + if (gfc_ref_needs_temporary_p (expr->ref) + || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) + { + if (elemental == ELEM_DONT_CHECK_VARIABLE) + { + /* Too many false positive with pointers. */ + if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr)) + { + /* Elemental procedures forbid unspecified intents, + and we don't check dependencies for INTENT_IN args. */ + gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT); + + /* We are told not to check dependencies. + We do it, however, and issue a warning in case we find one. + If a dependency is found in the case + elemental == ELEM_CHECK_VARIABLE, we will generate + a temporary, so we don't need to bother the user. */ + + if (var->expr_type == EXPR_VARIABLE + && expr->expr_type == EXPR_VARIABLE + && strcmp(var->symtree->name, expr->symtree->name) == 0) + gfc_warning (0, "INTENT(%s) actual argument at %L might " + "interfere with actual argument at %L.", + intent == INTENT_OUT ? "OUT" : "INOUT", + &var->where, &expr->where); + } + return 0; + } + else + return 1; + } + return 0; + + case EXPR_ARRAY: + /* the scalarizer always generates a temporary for array constructors, + so there is no dependency. */ + return 0; + + case EXPR_FUNCTION: + if (intent != INTENT_IN) + { + arg = gfc_get_noncopying_intrinsic_argument (expr); + if (arg != NULL) + return gfc_check_argument_var_dependency (var, intent, arg, + NOT_ELEMENTAL); + } + + if (elemental != NOT_ELEMENTAL) + { + if ((expr->value.function.esym + && expr->value.function.esym->attr.elemental) + || (expr->value.function.isym + && expr->value.function.isym->elemental)) + return gfc_check_fncall_dependency (var, intent, NULL, + expr->value.function.actual, + ELEM_CHECK_VARIABLE); + + if (gfc_inline_intrinsic_function_p (expr)) + { + /* The TRANSPOSE case should have been caught in the + noncopying intrinsic case above. */ + gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE); + + return gfc_check_fncall_dependency (var, intent, NULL, + expr->value.function.actual, + ELEM_CHECK_VARIABLE); + } + } + return 0; + + case EXPR_OP: + /* In case of non-elemental procedures, there is no need to catch + dependencies, as we will make a temporary anyway. */ + if (elemental) + { + /* If the actual arg EXPR is an expression, we need to catch + a dependency between variables in EXPR and VAR, + an intent((IN)OUT) variable. */ + if (expr->value.op.op1 + && gfc_check_argument_var_dependency (var, intent, + expr->value.op.op1, + ELEM_CHECK_VARIABLE)) + return 1; + else if (expr->value.op.op2 + && gfc_check_argument_var_dependency (var, intent, + expr->value.op.op2, + ELEM_CHECK_VARIABLE)) + return 1; + } + return 0; + + default: + return 0; + } +} + + +/* Like gfc_check_argument_var_dependency, but extended to any + array expression OTHER, not just variables. */ + +static int +gfc_check_argument_dependency (gfc_expr *other, sym_intent intent, + gfc_expr *expr, gfc_dep_check elemental) +{ + switch (other->expr_type) + { + case EXPR_VARIABLE: + return gfc_check_argument_var_dependency (other, intent, expr, elemental); + + case EXPR_FUNCTION: + other = gfc_get_noncopying_intrinsic_argument (other); + if (other != NULL) + return gfc_check_argument_dependency (other, INTENT_IN, expr, + NOT_ELEMENTAL); + + return 0; + + default: + return 0; + } +} + + +/* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL. + FNSYM is the function being called, or NULL if not known. */ + +int +gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent, + gfc_symbol *fnsym, gfc_actual_arglist *actual, + gfc_dep_check elemental) +{ + gfc_formal_arglist *formal; + gfc_expr *expr; + + formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL; + for (; actual; actual = actual->next, formal = formal ? formal->next : NULL) + { + expr = actual->expr; + + /* Skip args which are not present. */ + if (!expr) + continue; + + /* Skip other itself. */ + if (expr == other) + continue; + + /* Skip intent(in) arguments if OTHER itself is intent(in). */ + if (formal && intent == INTENT_IN + && formal->sym->attr.intent == INTENT_IN) + continue; + + if (gfc_check_argument_dependency (other, intent, expr, elemental)) + return 1; + } + + return 0; +} + + +/* Return 1 if e1 and e2 are equivalenced arrays, either + directly or indirectly; i.e., equivalence (a,b) for a and b + or equivalence (a,c),(b,c). This function uses the equiv_ + lists, generated in trans-common(add_equivalences), that are + guaranteed to pick up indirect equivalences. We explicitly + check for overlap using the offset and length of the equivalence. + This function is symmetric. + TODO: This function only checks whether the full top-level + symbols overlap. An improved implementation could inspect + e1->ref and e2->ref to determine whether the actually accessed + portions of these variables/arrays potentially overlap. */ + +int +gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2) +{ + gfc_equiv_list *l; + gfc_equiv_info *s, *fl1, *fl2; + + gcc_assert (e1->expr_type == EXPR_VARIABLE + && e2->expr_type == EXPR_VARIABLE); + + if (!e1->symtree->n.sym->attr.in_equivalence + || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank) + return 0; + + if (e1->symtree->n.sym->ns + && e1->symtree->n.sym->ns != gfc_current_ns) + l = e1->symtree->n.sym->ns->equiv_lists; + else + l = gfc_current_ns->equiv_lists; + + /* Go through the equiv_lists and return 1 if the variables + e1 and e2 are members of the same group and satisfy the + requirement on their relative offsets. */ + for (; l; l = l->next) + { + fl1 = NULL; + fl2 = NULL; + for (s = l->equiv; s; s = s->next) + { + if (s->sym == e1->symtree->n.sym) + { + fl1 = s; + if (fl2) + break; + } + if (s->sym == e2->symtree->n.sym) + { + fl2 = s; + if (fl1) + break; + } + } + + if (s) + { + /* Can these lengths be zero? */ + if (fl1->length <= 0 || fl2->length <= 0) + return 1; + /* These can't overlap if [f11,fl1+length] is before + [fl2,fl2+length], or [fl2,fl2+length] is before + [fl1,fl1+length], otherwise they do overlap. */ + if (fl1->offset + fl1->length > fl2->offset + && fl2->offset + fl2->length > fl1->offset) + return 1; + } + } + return 0; +} + + +/* Return true if there is no possibility of aliasing because of a type + mismatch between all the possible pointer references and the + potential target. Note that this function is asymmetric in the + arguments and so must be called twice with the arguments exchanged. */ + +static bool +check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2) +{ + gfc_component *cm1; + gfc_symbol *sym1; + gfc_symbol *sym2; + gfc_ref *ref1; + bool seen_component_ref; + + if (expr1->expr_type != EXPR_VARIABLE + || expr2->expr_type != EXPR_VARIABLE) + return false; + + sym1 = expr1->symtree->n.sym; + sym2 = expr2->symtree->n.sym; + + /* Keep it simple for now. */ + if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED) + return false; + + if (sym1->attr.pointer) + { + if (gfc_compare_types (&sym1->ts, &sym2->ts)) + return false; + } + + /* This is a conservative check on the components of the derived type + if no component references have been seen. Since we will not dig + into the components of derived type components, we play it safe by + returning false. First we check the reference chain and then, if + no component references have been seen, the components. */ + seen_component_ref = false; + if (sym1->ts.type == BT_DERIVED) + { + for (ref1 = expr1->ref; ref1; ref1 = ref1->next) + { + if (ref1->type != REF_COMPONENT) + continue; + + if (ref1->u.c.component->ts.type == BT_DERIVED) + return false; + + if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer) + && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts)) + return false; + + seen_component_ref = true; + } + } + + if (sym1->ts.type == BT_DERIVED && !seen_component_ref) + { + for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next) + { + if (cm1->ts.type == BT_DERIVED) + return false; + + if ((sym2->attr.pointer || cm1->attr.pointer) + && gfc_compare_types (&cm1->ts, &sym2->ts)) + return false; + } + } + + return true; +} + + +/* Return true if the statement body redefines the condition. Returns + true if expr2 depends on expr1. expr1 should be a single term + suitable for the lhs of an assignment. The IDENTICAL flag indicates + whether array references to the same symbol with identical range + references count as a dependency or not. Used for forall and where + statements. Also used with functions returning arrays without a + temporary. */ + +int +gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) +{ + gfc_actual_arglist *actual; + gfc_constructor *c; + int n; + + /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION + and a reference to _F.caf_get, so skip the assert. */ + if (expr1->expr_type == EXPR_FUNCTION + && strcmp (expr1->value.function.name, "_F.caf_get") == 0) + return 0; + + if (expr1->expr_type != EXPR_VARIABLE) + gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE"); + + switch (expr2->expr_type) + { + case EXPR_OP: + n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); + if (n) + return n; + if (expr2->value.op.op2) + return gfc_check_dependency (expr1, expr2->value.op.op2, identical); + return 0; + + case EXPR_VARIABLE: + /* The interesting cases are when the symbols don't match. */ + if (expr1->symtree->n.sym != expr2->symtree->n.sym) + { + symbol_attribute attr1, attr2; + gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; + gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; + + /* Return 1 if expr1 and expr2 are equivalenced arrays. */ + if (gfc_are_equivalenced_arrays (expr1, expr2)) + return 1; + + /* Symbols can only alias if they have the same type. */ + if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN + && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) + { + if (ts1->type != ts2->type || ts1->kind != ts2->kind) + return 0; + } + + /* We have to also include target-target as ptr%comp is not a + pointer but it still alias with "dt%comp" for "ptr => dt". As + subcomponents and array access to pointers retains the target + attribute, that's sufficient. */ + attr1 = gfc_expr_attr (expr1); + attr2 = gfc_expr_attr (expr2); + if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target)) + { + if (check_data_pointer_types (expr1, expr2) + && check_data_pointer_types (expr2, expr1)) + return 0; + + return 1; + } + else + { + gfc_symbol *sym1 = expr1->symtree->n.sym; + gfc_symbol *sym2 = expr2->symtree->n.sym; + if (sym1->attr.target && sym2->attr.target + && ((sym1->attr.dummy && !sym1->attr.contiguous + && (!sym1->attr.dimension + || sym2->as->type == AS_ASSUMED_SHAPE)) + || (sym2->attr.dummy && !sym2->attr.contiguous + && (!sym2->attr.dimension + || sym2->as->type == AS_ASSUMED_SHAPE)))) + return 1; + } + + /* Otherwise distinct symbols have no dependencies. */ + return 0; + } + + /* Identical and disjoint ranges return 0, + overlapping ranges return 1. */ + if (expr1->ref && expr2->ref) + return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical); + + return 1; + + case EXPR_FUNCTION: + if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL) + identical = 1; + + /* Remember possible differences between elemental and + transformational functions. All functions inside a FORALL + will be pure. */ + for (actual = expr2->value.function.actual; + actual; actual = actual->next) + { + if (!actual->expr) + continue; + n = gfc_check_dependency (expr1, actual->expr, identical); + if (n) + return n; + } + return 0; + + case EXPR_CONSTANT: + case EXPR_NULL: + return 0; + + case EXPR_ARRAY: + /* Loop through the array constructor's elements. */ + for (c = gfc_constructor_first (expr2->value.constructor); + c; c = gfc_constructor_next (c)) + { + /* If this is an iterator, assume the worst. */ + if (c->iterator) + return 1; + /* Avoid recursion in the common case. */ + if (c->expr->expr_type == EXPR_CONSTANT) + continue; + if (gfc_check_dependency (expr1, c->expr, 1)) + return 1; + } + return 0; + + default: + return 1; + } +} + + +/* Determines overlapping for two array sections. */ + +static gfc_dependency +check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) +{ + gfc_expr *l_start; + gfc_expr *l_end; + gfc_expr *l_stride; + gfc_expr *l_lower; + gfc_expr *l_upper; + int l_dir; + + gfc_expr *r_start; + gfc_expr *r_end; + gfc_expr *r_stride; + gfc_expr *r_lower; + gfc_expr *r_upper; + gfc_expr *one_expr; + int r_dir; + int stride_comparison; + int start_comparison; + mpz_t tmp; + + /* If they are the same range, return without more ado. */ + if (is_same_range (l_ar, r_ar, n)) + return GFC_DEP_EQUAL; + + l_start = l_ar->start[n]; + l_end = l_ar->end[n]; + l_stride = l_ar->stride[n]; + + r_start = r_ar->start[n]; + r_end = r_ar->end[n]; + r_stride = r_ar->stride[n]; + + /* If l_start is NULL take it from array specifier. */ + if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) + l_start = l_ar->as->lower[n]; + /* If l_end is NULL take it from array specifier. */ + if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) + l_end = l_ar->as->upper[n]; + + /* If r_start is NULL take it from array specifier. */ + if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) + r_start = r_ar->as->lower[n]; + /* If r_end is NULL take it from array specifier. */ + if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) + r_end = r_ar->as->upper[n]; + + /* Determine whether the l_stride is positive or negative. */ + if (!l_stride) + l_dir = 1; + else if (l_stride->expr_type == EXPR_CONSTANT + && l_stride->ts.type == BT_INTEGER) + l_dir = mpz_sgn (l_stride->value.integer); + else if (l_start && l_end) + l_dir = gfc_dep_compare_expr (l_end, l_start); + else + l_dir = -2; + + /* Determine whether the r_stride is positive or negative. */ + if (!r_stride) + r_dir = 1; + else if (r_stride->expr_type == EXPR_CONSTANT + && r_stride->ts.type == BT_INTEGER) + r_dir = mpz_sgn (r_stride->value.integer); + else if (r_start && r_end) + r_dir = gfc_dep_compare_expr (r_end, r_start); + else + r_dir = -2; + + /* The strides should never be zero. */ + if (l_dir == 0 || r_dir == 0) + return GFC_DEP_OVERLAP; + + /* Determine the relationship between the strides. Set stride_comparison to + -2 if the dependency cannot be determined + -1 if l_stride < r_stride + 0 if l_stride == r_stride + 1 if l_stride > r_stride + as determined by gfc_dep_compare_expr. */ + + one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + + stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr, + r_stride ? r_stride : one_expr); + + if (l_start && r_start) + start_comparison = gfc_dep_compare_expr (l_start, r_start); + else + start_comparison = -2; + + gfc_free_expr (one_expr); + + /* Determine LHS upper and lower bounds. */ + if (l_dir == 1) + { + l_lower = l_start; + l_upper = l_end; + } + else if (l_dir == -1) + { + l_lower = l_end; + l_upper = l_start; + } + else + { + l_lower = NULL; + l_upper = NULL; + } + + /* Determine RHS upper and lower bounds. */ + if (r_dir == 1) + { + r_lower = r_start; + r_upper = r_end; + } + else if (r_dir == -1) + { + r_lower = r_end; + r_upper = r_start; + } + else + { + r_lower = NULL; + r_upper = NULL; + } + + /* Check whether the ranges are disjoint. */ + if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1) + return GFC_DEP_NODEP; + if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1) + return GFC_DEP_NODEP; + + /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */ + if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0) + { + if (l_dir == 1 && r_dir == -1) + return GFC_DEP_EQUAL; + if (l_dir == -1 && r_dir == 1) + return GFC_DEP_EQUAL; + } + + /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */ + if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0) + { + if (l_dir == 1 && r_dir == -1) + return GFC_DEP_EQUAL; + if (l_dir == -1 && r_dir == 1) + return GFC_DEP_EQUAL; + } + + /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP. + There is no dependency if the remainder of + (l_start - r_start) / gcd(l_stride, r_stride) is + nonzero. + TODO: + - Cases like a(1:4:2) = a(2:3) are still not handled. + */ + +#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ + && (a)->ts.type == BT_INTEGER) + + if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride) + && gfc_dep_difference (l_start, r_start, &tmp)) + { + mpz_t gcd; + int result; + + mpz_init (gcd); + mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); + + mpz_fdiv_r (tmp, tmp, gcd); + result = mpz_cmp_si (tmp, 0L); + + mpz_clear (gcd); + mpz_clear (tmp); + + if (result != 0) + return GFC_DEP_NODEP; + } + +#undef IS_CONSTANT_INTEGER + + /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */ + + if (l_dir == 1 && r_dir == 1 && + (start_comparison == 0 || start_comparison == -1) + && (stride_comparison == 0 || stride_comparison == -1)) + return GFC_DEP_FORWARD; + + /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and + x:y:-1 vs. x:y:-2. */ + if (l_dir == -1 && r_dir == -1 && + (start_comparison == 0 || start_comparison == 1) + && (stride_comparison == 0 || stride_comparison == 1)) + return GFC_DEP_FORWARD; + + if (stride_comparison == 0 || stride_comparison == -1) + { + if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) + { + + /* Check for a(low:y:s) vs. a(z:x:s) or + a(low:y:s) vs. a(z:x:s+1) where a has a lower bound + of low, which is always at least a forward dependence. */ + + if (r_dir == 1 + && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0) + return GFC_DEP_FORWARD; + } + } + + if (stride_comparison == 0 || stride_comparison == 1) + { + if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) + { + + /* Check for a(high:y:-s) vs. a(z:x:-s) or + a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound + of high, which is always at least a forward dependence. */ + + if (r_dir == -1 + && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0) + return GFC_DEP_FORWARD; + } + } + + + if (stride_comparison == 0) + { + /* From here, check for backwards dependencies. */ + /* x+1:y vs. x:z. */ + if (l_dir == 1 && r_dir == 1 && start_comparison == 1) + return GFC_DEP_BACKWARD; + + /* x-1:y:-1 vs. x:z:-1. */ + if (l_dir == -1 && r_dir == -1 && start_comparison == -1) + return GFC_DEP_BACKWARD; + } + + return GFC_DEP_OVERLAP; +} + + +/* Determines overlapping for a single element and a section. */ + +static gfc_dependency +gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n) +{ + gfc_array_ref *ref; + gfc_expr *elem; + gfc_expr *start; + gfc_expr *end; + gfc_expr *stride; + int s; + + elem = lref->u.ar.start[n]; + if (!elem) + return GFC_DEP_OVERLAP; + + ref = &rref->u.ar; + start = ref->start[n] ; + end = ref->end[n] ; + stride = ref->stride[n]; + + if (!start && IS_ARRAY_EXPLICIT (ref->as)) + start = ref->as->lower[n]; + if (!end && IS_ARRAY_EXPLICIT (ref->as)) + end = ref->as->upper[n]; + + /* Determine whether the stride is positive or negative. */ + if (!stride) + s = 1; + else if (stride->expr_type == EXPR_CONSTANT + && stride->ts.type == BT_INTEGER) + s = mpz_sgn (stride->value.integer); + else + s = -2; + + /* Stride should never be zero. */ + if (s == 0) + return GFC_DEP_OVERLAP; + + /* Positive strides. */ + if (s == 1) + { + /* Check for elem < lower. */ + if (start && gfc_dep_compare_expr (elem, start) == -1) + return GFC_DEP_NODEP; + /* Check for elem > upper. */ + if (end && gfc_dep_compare_expr (elem, end) == 1) + return GFC_DEP_NODEP; + + if (start && end) + { + s = gfc_dep_compare_expr (start, end); + /* Check for an empty range. */ + if (s == 1) + return GFC_DEP_NODEP; + if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) + return GFC_DEP_EQUAL; + } + } + /* Negative strides. */ + else if (s == -1) + { + /* Check for elem > upper. */ + if (end && gfc_dep_compare_expr (elem, start) == 1) + return GFC_DEP_NODEP; + /* Check for elem < lower. */ + if (start && gfc_dep_compare_expr (elem, end) == -1) + return GFC_DEP_NODEP; + + if (start && end) + { + s = gfc_dep_compare_expr (start, end); + /* Check for an empty range. */ + if (s == -1) + return GFC_DEP_NODEP; + if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) + return GFC_DEP_EQUAL; + } + } + /* Unknown strides. */ + else + { + if (!start || !end) + return GFC_DEP_OVERLAP; + s = gfc_dep_compare_expr (start, end); + if (s <= -2) + return GFC_DEP_OVERLAP; + /* Assume positive stride. */ + if (s == -1) + { + /* Check for elem < lower. */ + if (gfc_dep_compare_expr (elem, start) == -1) + return GFC_DEP_NODEP; + /* Check for elem > upper. */ + if (gfc_dep_compare_expr (elem, end) == 1) + return GFC_DEP_NODEP; + } + /* Assume negative stride. */ + else if (s == 1) + { + /* Check for elem > upper. */ + if (gfc_dep_compare_expr (elem, start) == 1) + return GFC_DEP_NODEP; + /* Check for elem < lower. */ + if (gfc_dep_compare_expr (elem, end) == -1) + return GFC_DEP_NODEP; + } + /* Equal bounds. */ + else if (s == 0) + { + s = gfc_dep_compare_expr (elem, start); + if (s == 0) + return GFC_DEP_EQUAL; + if (s == 1 || s == -1) + return GFC_DEP_NODEP; + } + } + + return GFC_DEP_OVERLAP; +} + + +/* Traverse expr, checking all EXPR_VARIABLE symbols for their + forall_index attribute. Return true if any variable may be + being used as a FORALL index. Its safe to pessimistically + return true, and assume a dependency. */ + +static bool +contains_forall_index_p (gfc_expr *expr) +{ + gfc_actual_arglist *arg; + gfc_constructor *c; + gfc_ref *ref; + int i; + + if (!expr) + return false; + + switch (expr->expr_type) + { + case EXPR_VARIABLE: + if (expr->symtree->n.sym->forall_index) + return true; + break; + + case EXPR_OP: + if (contains_forall_index_p (expr->value.op.op1) + || contains_forall_index_p (expr->value.op.op2)) + return true; + break; + + case EXPR_FUNCTION: + for (arg = expr->value.function.actual; arg; arg = arg->next) + if (contains_forall_index_p (arg->expr)) + return true; + break; + + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_SUBSTRING: + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + for (c = gfc_constructor_first (expr->value.constructor); + c; gfc_constructor_next (c)) + if (contains_forall_index_p (c->expr)) + return true; + break; + + default: + gcc_unreachable (); + } + + for (ref = expr->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + for (i = 0; i < ref->u.ar.dimen; i++) + if (contains_forall_index_p (ref->u.ar.start[i]) + || contains_forall_index_p (ref->u.ar.end[i]) + || contains_forall_index_p (ref->u.ar.stride[i])) + return true; + break; + + case REF_COMPONENT: + break; + + case REF_SUBSTRING: + if (contains_forall_index_p (ref->u.ss.start) + || contains_forall_index_p (ref->u.ss.end)) + return true; + break; + + default: + gcc_unreachable (); + } + + return false; +} + +/* Determines overlapping for two single element array references. */ + +static gfc_dependency +gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n) +{ + gfc_array_ref l_ar; + gfc_array_ref r_ar; + gfc_expr *l_start; + gfc_expr *r_start; + int i; + + l_ar = lref->u.ar; + r_ar = rref->u.ar; + l_start = l_ar.start[n] ; + r_start = r_ar.start[n] ; + i = gfc_dep_compare_expr (r_start, l_start); + if (i == 0) + return GFC_DEP_EQUAL; + + /* Treat two scalar variables as potentially equal. This allows + us to prove that a(i,:) and a(j,:) have no dependency. See + Gerald Roth, "Evaluation of Array Syntax Dependence Analysis", + Proceedings of the International Conference on Parallel and + Distributed Processing Techniques and Applications (PDPTA2001), + Las Vegas, Nevada, June 2001. */ + /* However, we need to be careful when either scalar expression + contains a FORALL index, as these can potentially change value + during the scalarization/traversal of this array reference. */ + if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start)) + return GFC_DEP_OVERLAP; + + if (i > -2) + return GFC_DEP_NODEP; + + return GFC_DEP_EQUAL; +} + +/* Callback function for checking if an expression depends on a + dummy variable which is any other than INTENT(IN). */ + +static int +callback_dummy_intent_not_in (gfc_expr **ep, + int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_expr *e = *ep; + + if (e->expr_type == EXPR_VARIABLE && e->symtree + && e->symtree->n.sym->attr.dummy) + return e->symtree->n.sym->attr.intent != INTENT_IN; + else + return 0; +} + +/* Auxiliary function to check if subexpressions have dummy variables which + are not intent(in). +*/ + +static bool +dummy_intent_not_in (gfc_expr **ep) +{ + return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL); +} + +/* Determine if an array ref, usually an array section specifies the + entire array. In addition, if the second, pointer argument is + provided, the function will return true if the reference is + contiguous; eg. (:, 1) gives true but (1,:) gives false. + If one of the bounds depends on a dummy variable which is + not INTENT(IN), also return false, because the user may + have changed the variable. */ + +bool +gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) +{ + int i; + int n; + bool lbound_OK = true; + bool ubound_OK = true; + + if (contiguous) + *contiguous = false; + + if (ref->type != REF_ARRAY) + return false; + + if (ref->u.ar.type == AR_FULL) + { + if (contiguous) + *contiguous = true; + return true; + } + + if (ref->u.ar.type != AR_SECTION) + return false; + if (ref->next) + return false; + + for (i = 0; i < ref->u.ar.dimen; i++) + { + /* If we have a single element in the reference, for the reference + to be full, we need to ascertain that the array has a single + element in this dimension and that we actually reference the + correct element. */ + if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) + { + /* This is unconditionally a contiguous reference if all the + remaining dimensions are elements. */ + if (contiguous) + { + *contiguous = true; + for (n = i + 1; n < ref->u.ar.dimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) + *contiguous = false; + } + + if (!ref->u.ar.as + || !ref->u.ar.as->lower[i] + || !ref->u.ar.as->upper[i] + || gfc_dep_compare_expr (ref->u.ar.as->lower[i], + ref->u.ar.as->upper[i]) + || !ref->u.ar.start[i] + || gfc_dep_compare_expr (ref->u.ar.start[i], + ref->u.ar.as->lower[i])) + return false; + else + continue; + } + + /* Check the lower bound. */ + if (ref->u.ar.start[i] + && (!ref->u.ar.as + || !ref->u.ar.as->lower[i] + || gfc_dep_compare_expr (ref->u.ar.start[i], + ref->u.ar.as->lower[i]) + || dummy_intent_not_in (&ref->u.ar.start[i]))) + lbound_OK = false; + /* Check the upper bound. */ + if (ref->u.ar.end[i] + && (!ref->u.ar.as + || !ref->u.ar.as->upper[i] + || gfc_dep_compare_expr (ref->u.ar.end[i], + ref->u.ar.as->upper[i]) + || dummy_intent_not_in (&ref->u.ar.end[i]))) + ubound_OK = false; + /* Check the stride. */ + if (ref->u.ar.stride[i] + && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) + return false; + + /* This is unconditionally a contiguous reference as long as all + the subsequent dimensions are elements. */ + if (contiguous) + { + *contiguous = true; + for (n = i + 1; n < ref->u.ar.dimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) + *contiguous = false; + } + + if (!lbound_OK || !ubound_OK) + return false; + } + return true; +} + + +/* Determine if a full array is the same as an array section with one + variable limit. For this to be so, the strides must both be unity + and one of either start == lower or end == upper must be true. */ + +static bool +ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) +{ + int i; + bool upper_or_lower; + + if (full_ref->type != REF_ARRAY) + return false; + if (full_ref->u.ar.type != AR_FULL) + return false; + if (ref->type != REF_ARRAY) + return false; + if (ref->u.ar.type == AR_FULL) + return true; + if (ref->u.ar.type != AR_SECTION) + return false; + + for (i = 0; i < ref->u.ar.dimen; i++) + { + /* If we have a single element in the reference, we need to check + that the array has a single element and that we actually reference + the correct element. */ + if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) + { + if (!full_ref->u.ar.as + || !full_ref->u.ar.as->lower[i] + || !full_ref->u.ar.as->upper[i] + || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i], + full_ref->u.ar.as->upper[i]) + || !ref->u.ar.start[i] + || gfc_dep_compare_expr (ref->u.ar.start[i], + full_ref->u.ar.as->lower[i])) + return false; + } + + /* Check the strides. */ + if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0)) + return false; + if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) + return false; + + upper_or_lower = false; + /* Check the lower bound. */ + if (ref->u.ar.start[i] + && (ref->u.ar.as + && full_ref->u.ar.as->lower[i] + && gfc_dep_compare_expr (ref->u.ar.start[i], + full_ref->u.ar.as->lower[i]) == 0)) + upper_or_lower = true; + /* Check the upper bound. */ + if (ref->u.ar.end[i] + && (ref->u.ar.as + && full_ref->u.ar.as->upper[i] + && gfc_dep_compare_expr (ref->u.ar.end[i], + full_ref->u.ar.as->upper[i]) == 0)) + upper_or_lower = true; + if (!upper_or_lower) + return false; + } + return true; +} + + +/* Finds if two array references are overlapping or not. + Return value + 2 : array references are overlapping but reversal of one or + more dimensions will clear the dependency. + 1 : array references are overlapping, or identical is true and + there is some kind of overlap. + 0 : array references are identical or not overlapping. */ + +int +gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse, + bool identical) +{ + int n; + int m; + gfc_dependency fin_dep; + gfc_dependency this_dep; + bool same_component = false; + + this_dep = GFC_DEP_ERROR; + fin_dep = GFC_DEP_ERROR; + /* Dependencies due to pointers should already have been identified. + We only need to check for overlapping array references. */ + + while (lref && rref) + { + /* The refs might come in mixed, one with a _data component and one + without. Look at their next reference in order to avoid an + ICE. */ + + if (lref && lref->type == REF_COMPONENT && lref->u.c.component + && strcmp (lref->u.c.component->name, "_data") == 0) + lref = lref->next; + + if (rref && rref->type == REF_COMPONENT && rref->u.c.component + && strcmp (rref->u.c.component->name, "_data") == 0) + rref = rref->next; + + /* We're resolving from the same base symbol, so both refs should be + the same type. We traverse the reference chain until we find ranges + that are not equal. */ + gcc_assert (lref->type == rref->type); + switch (lref->type) + { + case REF_COMPONENT: + /* The two ranges can't overlap if they are from different + components. */ + if (lref->u.c.component != rref->u.c.component) + return 0; + + same_component = true; + break; + + case REF_SUBSTRING: + /* Substring overlaps are handled by the string assignment code + if there is not an underlying dependency. */ + return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0; + + case REF_ARRAY: + /* Coarrays: If there is a coindex, either the image differs and there + is no overlap or the image is the same - then the normal analysis + applies. Hence, return early if either ref is coindexed and more + than one image can exist. */ + if (flag_coarray != GFC_FCOARRAY_SINGLE + && ((lref->u.ar.codimen + && lref->u.ar.dimen_type[lref->u.ar.dimen] + != DIMEN_THIS_IMAGE) + || (rref->u.ar.codimen + && lref->u.ar.dimen_type[lref->u.ar.dimen] + != DIMEN_THIS_IMAGE))) + return 1; + if (lref->u.ar.dimen == 0 || rref->u.ar.dimen == 0) + { + /* Coindexed scalar coarray with GFC_FCOARRAY_SINGLE. */ + if (lref->u.ar.dimen || rref->u.ar.dimen) + return 1; /* Just to be sure. */ + fin_dep = GFC_DEP_EQUAL; + break; + } + + if (ref_same_as_full_array (lref, rref)) + return identical; + + if (ref_same_as_full_array (rref, lref)) + return identical; + + if (lref->u.ar.dimen != rref->u.ar.dimen) + { + if (lref->u.ar.type == AR_FULL) + fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL + : GFC_DEP_OVERLAP; + else if (rref->u.ar.type == AR_FULL) + fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL + : GFC_DEP_OVERLAP; + else + return 1; + break; + } + + /* Index for the reverse array. */ + m = -1; + for (n = 0; n < lref->u.ar.dimen; n++) + { + /* Handle dependency when either of array reference is vector + subscript. There is no dependency if the vector indices + are equal or if indices are known to be different in a + different dimension. */ + if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR + || rref->u.ar.dimen_type[n] == DIMEN_VECTOR) + { + if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR + && rref->u.ar.dimen_type[n] == DIMEN_VECTOR + && gfc_dep_compare_expr (lref->u.ar.start[n], + rref->u.ar.start[n]) == 0) + this_dep = GFC_DEP_EQUAL; + else + this_dep = GFC_DEP_OVERLAP; + + goto update_fin_dep; + } + + if (lref->u.ar.dimen_type[n] == DIMEN_RANGE + && rref->u.ar.dimen_type[n] == DIMEN_RANGE) + this_dep = check_section_vs_section (&lref->u.ar, + &rref->u.ar, n); + else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT + && rref->u.ar.dimen_type[n] == DIMEN_RANGE) + this_dep = gfc_check_element_vs_section (lref, rref, n); + else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT + && lref->u.ar.dimen_type[n] == DIMEN_RANGE) + this_dep = gfc_check_element_vs_section (rref, lref, n); + else + { + gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT + && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT); + this_dep = gfc_check_element_vs_element (rref, lref, n); + if (identical && this_dep == GFC_DEP_EQUAL) + this_dep = GFC_DEP_OVERLAP; + } + + /* If any dimension doesn't overlap, we have no dependency. */ + if (this_dep == GFC_DEP_NODEP) + return 0; + + /* Now deal with the loop reversal logic: This only works on + ranges and is activated by setting + reverse[n] == GFC_ENABLE_REVERSE + The ability to reverse or not is set by previous conditions + in this dimension. If reversal is not activated, the + value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */ + + /* Get the indexing right for the scalarizing loop. If this + is an element, there is no corresponding loop. */ + if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT) + m++; + + if (rref->u.ar.dimen_type[n] == DIMEN_RANGE + && lref->u.ar.dimen_type[n] == DIMEN_RANGE) + { + if (reverse) + { + /* Reverse if backward dependence and not inhibited. */ + if (reverse[m] == GFC_ENABLE_REVERSE + && this_dep == GFC_DEP_BACKWARD) + reverse[m] = GFC_REVERSE_SET; + + /* Forward if forward dependence and not inhibited. */ + if (reverse[m] == GFC_ENABLE_REVERSE + && this_dep == GFC_DEP_FORWARD) + reverse[m] = GFC_FORWARD_SET; + + /* Flag up overlap if dependence not compatible with + the overall state of the expression. */ + if (reverse[m] == GFC_REVERSE_SET + && this_dep == GFC_DEP_FORWARD) + { + reverse[m] = GFC_INHIBIT_REVERSE; + this_dep = GFC_DEP_OVERLAP; + } + else if (reverse[m] == GFC_FORWARD_SET + && this_dep == GFC_DEP_BACKWARD) + { + reverse[m] = GFC_INHIBIT_REVERSE; + this_dep = GFC_DEP_OVERLAP; + } + } + + /* If no intention of reversing or reversing is explicitly + inhibited, convert backward dependence to overlap. */ + if ((!reverse && this_dep == GFC_DEP_BACKWARD) + || (reverse && reverse[m] == GFC_INHIBIT_REVERSE)) + this_dep = GFC_DEP_OVERLAP; + } + + /* Overlap codes are in order of priority. We only need to + know the worst one.*/ + + update_fin_dep: + if (identical && this_dep == GFC_DEP_EQUAL) + this_dep = GFC_DEP_OVERLAP; + + if (this_dep > fin_dep) + fin_dep = this_dep; + } + + /* If this is an equal element, we have to keep going until we find + the "real" array reference. */ + if (lref->u.ar.type == AR_ELEMENT + && rref->u.ar.type == AR_ELEMENT + && fin_dep == GFC_DEP_EQUAL) + break; + + /* Exactly matching and forward overlapping ranges don't cause a + dependency. */ + if (fin_dep < GFC_DEP_BACKWARD && !identical) + return 0; + + /* Keep checking. We only have a dependency if + subsequent references also overlap. */ + break; + + case REF_INQUIRY: + if (lref->u.i != rref->u.i) + return 0; + + break; + + default: + gcc_unreachable (); + } + lref = lref->next; + rref = rref->next; + } + + /* Assume the worst if we nest to different depths. */ + if (lref || rref) + return 1; + + /* This can result from concatenation of assumed length string components. */ + if (same_component && fin_dep == GFC_DEP_ERROR) + return 1; + + /* If we haven't seen any array refs then something went wrong. */ + gcc_assert (fin_dep != GFC_DEP_ERROR); + + if (identical && fin_dep != GFC_DEP_NODEP) + return 1; + + return fin_dep == GFC_DEP_OVERLAP; +} diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c deleted file mode 100644 index a618ae2..0000000 --- a/gcc/fortran/dump-parse-tree.c +++ /dev/null @@ -1,3924 +0,0 @@ -/* Parse tree dumper - Copyright (C) 2003-2022 Free Software Foundation, Inc. - Contributed by Steven Bosscher - -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 -. */ - - -/* Actually this is just a collection of routines that used to be - scattered around the sources. Now that they are all in a single - file, almost all of them can be static, and the other files don't - have this mess in them. - - As a nice side-effect, this file can act as documentation of the - gfc_code and gfc_expr structures and all their friends and - relatives. - - TODO: Dump DATA. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "constructor.h" -#include "version.h" - -/* Keep track of indentation for symbol tree dumps. */ -static int show_level = 0; - -/* The file handle we're dumping to is kept in a static variable. This - is not too cool, but it avoids a lot of passing it around. */ -static FILE *dumpfile; - -/* Forward declaration of some of the functions. */ -static void show_expr (gfc_expr *p); -static void show_code_node (int, gfc_code *); -static void show_namespace (gfc_namespace *ns); -static void show_code (int, gfc_code *); -static void show_symbol (gfc_symbol *); -static void show_typespec (gfc_typespec *); -static void show_ref (gfc_ref *); -static void show_attr (symbol_attribute *, const char *); - -/* Allow dumping of an expression in the debugger. */ -void gfc_debug_expr (gfc_expr *); - -void debug (symbol_attribute *attr) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_attr (attr, NULL); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_formal_arglist *formal) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - for (; formal; formal = formal->next) - { - fputc ('\n', dumpfile); - show_symbol (formal->sym); - } - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (symbol_attribute attr) -{ - debug (&attr); -} - -void debug (gfc_expr *e) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - if (e != NULL) - { - show_expr (e); - fputc (' ', dumpfile); - show_typespec (&e->ts); - } - else - fputs ("() ", dumpfile); - - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_typespec *ts) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_typespec (ts); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_typespec ts) -{ - debug (&ts); -} - -void debug (gfc_ref *p) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_ref (p); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void -gfc_debug_expr (gfc_expr *e) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_expr (e); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -/* Allow for dumping of a piece of code in the debugger. */ -void gfc_debug_code (gfc_code *c); - -void -gfc_debug_code (gfc_code *c) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_code (1, c); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -void debug (gfc_symbol *sym) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_symbol (sym); - fputc ('\n', dumpfile); - dumpfile = tmp; -} - -/* Do indentation for a specific level. */ - -static inline void -code_indent (int level, gfc_st_label *label) -{ - int i; - - if (label != NULL) - fprintf (dumpfile, "%-5d ", label->value); - - for (i = 0; i < (2 * level - (label ? 6 : 0)); i++) - fputc (' ', dumpfile); -} - - -/* Simple indentation at the current level. This one - is used to show symbols. */ - -static inline void -show_indent (void) -{ - fputc ('\n', dumpfile); - code_indent (show_level, NULL); -} - - -/* Show type-specific information. */ - -static void -show_typespec (gfc_typespec *ts) -{ - if (ts->type == BT_ASSUMED) - { - fputs ("(TYPE(*))", dumpfile); - return; - } - - fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type)); - - switch (ts->type) - { - case BT_DERIVED: - case BT_CLASS: - case BT_UNION: - fprintf (dumpfile, "%s", ts->u.derived->name); - break; - - case BT_CHARACTER: - if (ts->u.cl) - show_expr (ts->u.cl->length); - fprintf(dumpfile, " %d", ts->kind); - break; - - default: - fprintf (dumpfile, "%d", ts->kind); - break; - } - if (ts->is_c_interop) - fputs (" C_INTEROP", dumpfile); - - if (ts->is_iso_c) - fputs (" ISO_C", dumpfile); - - if (ts->deferred) - fputs (" DEFERRED", dumpfile); - - fputc (')', dumpfile); -} - - -/* Show an actual argument list. */ - -static void -show_actual_arglist (gfc_actual_arglist *a) -{ - fputc ('(', dumpfile); - - for (; a; a = a->next) - { - fputc ('(', dumpfile); - if (a->name != NULL) - fprintf (dumpfile, "%s = ", a->name); - if (a->expr != NULL) - show_expr (a->expr); - else - fputs ("(arg not-present)", dumpfile); - - fputc (')', dumpfile); - if (a->next != NULL) - fputc (' ', dumpfile); - } - - fputc (')', dumpfile); -} - - -/* Show a gfc_array_spec array specification structure. */ - -static void -show_array_spec (gfc_array_spec *as) -{ - const char *c; - int i; - - if (as == NULL) - { - fputs ("()", dumpfile); - return; - } - - fprintf (dumpfile, "(%d [%d]", as->rank, as->corank); - - if (as->rank + as->corank > 0 || as->rank == -1) - { - switch (as->type) - { - case AS_EXPLICIT: c = "AS_EXPLICIT"; break; - case AS_DEFERRED: c = "AS_DEFERRED"; break; - case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; - case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; - case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break; - default: - gfc_internal_error ("show_array_spec(): Unhandled array shape " - "type."); - } - fprintf (dumpfile, " %s ", c); - - for (i = 0; i < as->rank + as->corank; i++) - { - show_expr (as->lower[i]); - fputc (' ', dumpfile); - show_expr (as->upper[i]); - fputc (' ', dumpfile); - } - } - - fputc (')', dumpfile); -} - - -/* Show a gfc_array_ref array reference structure. */ - -static void -show_array_ref (gfc_array_ref * ar) -{ - int i; - - fputc ('(', dumpfile); - - switch (ar->type) - { - case AR_FULL: - fputs ("FULL", dumpfile); - break; - - case AR_SECTION: - for (i = 0; i < ar->dimen; i++) - { - /* There are two types of array sections: either the - elements are identified by an integer array ('vector'), - or by an index range. In the former case we only have to - print the start expression which contains the vector, in - the latter case we have to print any of lower and upper - bound and the stride, if they're present. */ - - if (ar->start[i] != NULL) - show_expr (ar->start[i]); - - if (ar->dimen_type[i] == DIMEN_RANGE) - { - fputc (':', dumpfile); - - if (ar->end[i] != NULL) - show_expr (ar->end[i]); - - if (ar->stride[i] != NULL) - { - fputc (':', dumpfile); - show_expr (ar->stride[i]); - } - } - - if (i != ar->dimen - 1) - fputs (" , ", dumpfile); - } - break; - - case AR_ELEMENT: - for (i = 0; i < ar->dimen; i++) - { - show_expr (ar->start[i]); - if (i != ar->dimen - 1) - fputs (" , ", dumpfile); - } - break; - - case AR_UNKNOWN: - fputs ("UNKNOWN", dumpfile); - break; - - default: - gfc_internal_error ("show_array_ref(): Unknown array reference"); - } - - fputc (')', dumpfile); - if (ar->codimen == 0) - return; - - /* Show coarray part of the reference, if any. */ - fputc ('[',dumpfile); - for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) - { - if (ar->dimen_type[i] == DIMEN_STAR) - fputc('*',dumpfile); - else if (ar->dimen_type[i] == DIMEN_THIS_IMAGE) - fputs("THIS_IMAGE", dumpfile); - else - { - show_expr (ar->start[i]); - if (ar->end[i]) - { - fputc(':', dumpfile); - show_expr (ar->end[i]); - } - } - if (i != ar->dimen + ar->codimen - 1) - fputs (" , ", dumpfile); - - } - fputc (']',dumpfile); -} - - -/* Show a list of gfc_ref structures. */ - -static void -show_ref (gfc_ref *p) -{ - for (; p; p = p->next) - switch (p->type) - { - case REF_ARRAY: - show_array_ref (&p->u.ar); - break; - - case REF_COMPONENT: - fprintf (dumpfile, " %% %s", p->u.c.component->name); - break; - - case REF_SUBSTRING: - fputc ('(', dumpfile); - show_expr (p->u.ss.start); - fputc (':', dumpfile); - show_expr (p->u.ss.end); - fputc (')', dumpfile); - break; - - case REF_INQUIRY: - switch (p->u.i) - { - case INQUIRY_KIND: - fprintf (dumpfile, " INQUIRY_KIND "); - break; - case INQUIRY_LEN: - fprintf (dumpfile, " INQUIRY_LEN "); - break; - case INQUIRY_RE: - fprintf (dumpfile, " INQUIRY_RE "); - break; - case INQUIRY_IM: - fprintf (dumpfile, " INQUIRY_IM "); - } - break; - - default: - gfc_internal_error ("show_ref(): Bad component code"); - } -} - - -/* Display a constructor. Works recursively for array constructors. */ - -static void -show_constructor (gfc_constructor_base base) -{ - gfc_constructor *c; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - if (c->iterator == NULL) - show_expr (c->expr); - else - { - fputc ('(', dumpfile); - show_expr (c->expr); - - fputc (' ', dumpfile); - show_expr (c->iterator->var); - fputc ('=', dumpfile); - show_expr (c->iterator->start); - fputc (',', dumpfile); - show_expr (c->iterator->end); - fputc (',', dumpfile); - show_expr (c->iterator->step); - - fputc (')', dumpfile); - } - - if (gfc_constructor_next (c) != NULL) - fputs (" , ", dumpfile); - } -} - - -static void -show_char_const (const gfc_char_t *c, gfc_charlen_t length) -{ - fputc ('\'', dumpfile); - for (size_t i = 0; i < (size_t) length; i++) - { - if (c[i] == '\'') - fputs ("''", dumpfile); - else - fputs (gfc_print_wide_char (c[i]), dumpfile); - } - fputc ('\'', dumpfile); -} - - -/* Show a component-call expression. */ - -static void -show_compcall (gfc_expr* p) -{ - gcc_assert (p->expr_type == EXPR_COMPCALL); - - fprintf (dumpfile, "%s", p->symtree->n.sym->name); - show_ref (p->ref); - fprintf (dumpfile, "%s", p->value.compcall.name); - - show_actual_arglist (p->value.compcall.actual); -} - - -/* Show an expression. */ - -static void -show_expr (gfc_expr *p) -{ - const char *c; - int i; - - if (p == NULL) - { - fputs ("()", dumpfile); - return; - } - - switch (p->expr_type) - { - case EXPR_SUBSTRING: - show_char_const (p->value.character.string, p->value.character.length); - show_ref (p->ref); - break; - - case EXPR_STRUCTURE: - fprintf (dumpfile, "%s(", p->ts.u.derived->name); - show_constructor (p->value.constructor); - fputc (')', dumpfile); - break; - - case EXPR_ARRAY: - fputs ("(/ ", dumpfile); - show_constructor (p->value.constructor); - fputs (" /)", dumpfile); - - show_ref (p->ref); - break; - - case EXPR_NULL: - fputs ("NULL()", dumpfile); - break; - - case EXPR_CONSTANT: - switch (p->ts.type) - { - case BT_INTEGER: - mpz_out_str (dumpfile, 10, p->value.integer); - - if (p->ts.kind != gfc_default_integer_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - break; - - case BT_LOGICAL: - if (p->value.logical) - fputs (".true.", dumpfile); - else - fputs (".false.", dumpfile); - break; - - case BT_REAL: - mpfr_out_str (dumpfile, 10, 0, p->value.real, GFC_RND_MODE); - if (p->ts.kind != gfc_default_real_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - break; - - case BT_CHARACTER: - show_char_const (p->value.character.string, - p->value.character.length); - break; - - case BT_COMPLEX: - fputs ("(complex ", dumpfile); - - mpfr_out_str (dumpfile, 10, 0, mpc_realref (p->value.complex), - GFC_RND_MODE); - if (p->ts.kind != gfc_default_complex_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - - fputc (' ', dumpfile); - - mpfr_out_str (dumpfile, 10, 0, mpc_imagref (p->value.complex), - GFC_RND_MODE); - if (p->ts.kind != gfc_default_complex_kind) - fprintf (dumpfile, "_%d", p->ts.kind); - - fputc (')', dumpfile); - break; - - case BT_BOZ: - if (p->boz.rdx == 2) - fputs ("b'", dumpfile); - else if (p->boz.rdx == 8) - fputs ("o'", dumpfile); - else - fputs ("z'", dumpfile); - fprintf (dumpfile, "%s'", p->boz.str); - break; - - case BT_HOLLERITH: - fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H", - p->representation.length); - c = p->representation.string; - for (i = 0; i < p->representation.length; i++, c++) - { - fputc (*c, dumpfile); - } - break; - - default: - fputs ("???", dumpfile); - break; - } - - if (p->representation.string) - { - fputs (" {", dumpfile); - c = p->representation.string; - for (i = 0; i < p->representation.length; i++, c++) - { - fprintf (dumpfile, "%.2x", (unsigned int) *c); - if (i < p->representation.length - 1) - fputc (',', dumpfile); - } - fputc ('}', dumpfile); - } - - break; - - case EXPR_VARIABLE: - if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name) - fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name); - fprintf (dumpfile, "%s", p->symtree->n.sym->name); - show_ref (p->ref); - break; - - case EXPR_OP: - fputc ('(', dumpfile); - switch (p->value.op.op) - { - case INTRINSIC_UPLUS: - fputs ("U+ ", dumpfile); - break; - case INTRINSIC_UMINUS: - fputs ("U- ", dumpfile); - break; - case INTRINSIC_PLUS: - fputs ("+ ", dumpfile); - break; - case INTRINSIC_MINUS: - fputs ("- ", dumpfile); - break; - case INTRINSIC_TIMES: - fputs ("* ", dumpfile); - break; - case INTRINSIC_DIVIDE: - fputs ("/ ", dumpfile); - break; - case INTRINSIC_POWER: - fputs ("** ", dumpfile); - break; - case INTRINSIC_CONCAT: - fputs ("// ", dumpfile); - break; - case INTRINSIC_AND: - fputs ("AND ", dumpfile); - break; - case INTRINSIC_OR: - fputs ("OR ", dumpfile); - break; - case INTRINSIC_EQV: - fputs ("EQV ", dumpfile); - break; - case INTRINSIC_NEQV: - fputs ("NEQV ", dumpfile); - break; - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - fputs ("== ", dumpfile); - break; - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - fputs ("/= ", dumpfile); - break; - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - fputs ("> ", dumpfile); - break; - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - fputs (">= ", dumpfile); - break; - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - fputs ("< ", dumpfile); - break; - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - fputs ("<= ", dumpfile); - break; - case INTRINSIC_NOT: - fputs ("NOT ", dumpfile); - break; - case INTRINSIC_PARENTHESES: - fputs ("parens ", dumpfile); - break; - - default: - gfc_internal_error - ("show_expr(): Bad intrinsic in expression"); - } - - show_expr (p->value.op.op1); - - if (p->value.op.op2) - { - fputc (' ', dumpfile); - show_expr (p->value.op.op2); - } - - fputc (')', dumpfile); - break; - - case EXPR_FUNCTION: - if (p->value.function.name == NULL) - { - fprintf (dumpfile, "%s", p->symtree->n.sym->name); - if (gfc_is_proc_ptr_comp (p)) - show_ref (p->ref); - fputc ('[', dumpfile); - show_actual_arglist (p->value.function.actual); - fputc (']', dumpfile); - } - else - { - fprintf (dumpfile, "%s", p->value.function.name); - if (gfc_is_proc_ptr_comp (p)) - show_ref (p->ref); - fputc ('[', dumpfile); - fputc ('[', dumpfile); - show_actual_arglist (p->value.function.actual); - fputc (']', dumpfile); - fputc (']', dumpfile); - } - - break; - - case EXPR_COMPCALL: - show_compcall (p); - break; - - default: - gfc_internal_error ("show_expr(): Don't know how to show expr"); - } -} - -/* Show symbol attributes. The flavor and intent are followed by - whatever single bit attributes are present. */ - -static void -show_attr (symbol_attribute *attr, const char * module) -{ - if (attr->flavor != FL_UNKNOWN) - { - if (attr->flavor == FL_DERIVED && attr->pdt_template) - fputs (" (PDT-TEMPLATE", dumpfile); - else - fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor)); - } - if (attr->access != ACCESS_UNKNOWN) - fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access)); - if (attr->proc != PROC_UNKNOWN) - fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc)); - if (attr->save != SAVE_NONE) - fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save)); - - if (attr->artificial) - fputs (" ARTIFICIAL", dumpfile); - if (attr->allocatable) - fputs (" ALLOCATABLE", dumpfile); - if (attr->asynchronous) - fputs (" ASYNCHRONOUS", dumpfile); - if (attr->codimension) - fputs (" CODIMENSION", dumpfile); - if (attr->dimension) - fputs (" DIMENSION", dumpfile); - if (attr->contiguous) - fputs (" CONTIGUOUS", dumpfile); - if (attr->external) - fputs (" EXTERNAL", dumpfile); - if (attr->intrinsic) - fputs (" INTRINSIC", dumpfile); - if (attr->optional) - fputs (" OPTIONAL", dumpfile); - if (attr->pdt_kind) - fputs (" KIND", dumpfile); - if (attr->pdt_len) - fputs (" LEN", dumpfile); - if (attr->pointer) - fputs (" POINTER", dumpfile); - if (attr->subref_array_pointer) - fputs (" SUBREF-ARRAY-POINTER", dumpfile); - if (attr->cray_pointer) - fputs (" CRAY-POINTER", dumpfile); - if (attr->cray_pointee) - fputs (" CRAY-POINTEE", dumpfile); - if (attr->is_protected) - fputs (" PROTECTED", dumpfile); - if (attr->value) - fputs (" VALUE", dumpfile); - if (attr->volatile_) - fputs (" VOLATILE", dumpfile); - if (attr->threadprivate) - fputs (" THREADPRIVATE", dumpfile); - if (attr->target) - fputs (" TARGET", dumpfile); - if (attr->dummy) - { - fputs (" DUMMY", dumpfile); - if (attr->intent != INTENT_UNKNOWN) - fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent)); - } - - if (attr->result) - fputs (" RESULT", dumpfile); - if (attr->entry) - fputs (" ENTRY", dumpfile); - if (attr->entry_master) - fputs (" ENTRY-MASTER", dumpfile); - if (attr->mixed_entry_master) - fputs (" MIXED-ENTRY-MASTER", dumpfile); - if (attr->is_bind_c) - fputs (" BIND(C)", dumpfile); - - if (attr->data) - fputs (" DATA", dumpfile); - if (attr->use_assoc) - { - fputs (" USE-ASSOC", dumpfile); - if (module != NULL) - fprintf (dumpfile, "(%s)", module); - } - - if (attr->in_namelist) - fputs (" IN-NAMELIST", dumpfile); - if (attr->in_common) - fputs (" IN-COMMON", dumpfile); - - if (attr->abstract) - fputs (" ABSTRACT", dumpfile); - if (attr->function) - fputs (" FUNCTION", dumpfile); - if (attr->subroutine) - fputs (" SUBROUTINE", dumpfile); - if (attr->implicit_type) - fputs (" IMPLICIT-TYPE", dumpfile); - - if (attr->sequence) - fputs (" SEQUENCE", dumpfile); - if (attr->alloc_comp) - fputs (" ALLOC-COMP", dumpfile); - if (attr->pointer_comp) - fputs (" POINTER-COMP", dumpfile); - if (attr->proc_pointer_comp) - fputs (" PROC-POINTER-COMP", dumpfile); - if (attr->private_comp) - fputs (" PRIVATE-COMP", dumpfile); - if (attr->zero_comp) - fputs (" ZERO-COMP", dumpfile); - if (attr->coarray_comp) - fputs (" COARRAY-COMP", dumpfile); - if (attr->lock_comp) - fputs (" LOCK-COMP", dumpfile); - if (attr->event_comp) - fputs (" EVENT-COMP", dumpfile); - if (attr->defined_assign_comp) - fputs (" DEFINED-ASSIGNED-COMP", dumpfile); - if (attr->unlimited_polymorphic) - fputs (" UNLIMITED-POLYMORPHIC", dumpfile); - if (attr->has_dtio_procs) - fputs (" HAS-DTIO-PROCS", dumpfile); - if (attr->caf_token) - fputs (" CAF-TOKEN", dumpfile); - if (attr->select_type_temporary) - fputs (" SELECT-TYPE-TEMPORARY", dumpfile); - if (attr->associate_var) - fputs (" ASSOCIATE-VAR", dumpfile); - if (attr->pdt_kind) - fputs (" PDT-KIND", dumpfile); - if (attr->pdt_len) - fputs (" PDT-LEN", dumpfile); - if (attr->pdt_type) - fputs (" PDT-TYPE", dumpfile); - if (attr->pdt_array) - fputs (" PDT-ARRAY", dumpfile); - if (attr->pdt_string) - fputs (" PDT-STRING", dumpfile); - if (attr->omp_udr_artificial_var) - fputs (" OMP-UDT-ARTIFICIAL-VAR", dumpfile); - if (attr->omp_declare_target) - fputs (" OMP-DECLARE-TARGET", dumpfile); - if (attr->omp_declare_target_link) - fputs (" OMP-DECLARE-TARGET-LINK", dumpfile); - if (attr->elemental) - fputs (" ELEMENTAL", dumpfile); - if (attr->pure) - fputs (" PURE", dumpfile); - if (attr->implicit_pure) - fputs (" IMPLICIT-PURE", dumpfile); - if (attr->recursive) - fputs (" RECURSIVE", dumpfile); - if (attr->unmaskable) - fputs (" UNMASKABKE", dumpfile); - if (attr->masked) - fputs (" MASKED", dumpfile); - if (attr->contained) - fputs (" CONTAINED", dumpfile); - if (attr->mod_proc) - fputs (" MOD-PROC", dumpfile); - if (attr->module_procedure) - fputs (" MODULE-PROCEDURE", dumpfile); - if (attr->public_used) - fputs (" PUBLIC_USED", dumpfile); - if (attr->array_outer_dependency) - fputs (" ARRAY-OUTER-DEPENDENCY", dumpfile); - if (attr->noreturn) - fputs (" NORETURN", dumpfile); - if (attr->always_explicit) - fputs (" ALWAYS-EXPLICIT", dumpfile); - if (attr->is_main_program) - fputs (" IS-MAIN-PROGRAM", dumpfile); - if (attr->oacc_routine_nohost) - fputs (" OACC-ROUTINE-NOHOST", dumpfile); - - /* FIXME: Still missing are oacc_routine_lop and ext_attr. */ - fputc (')', dumpfile); -} - - -/* Show components of a derived type. */ - -static void -show_components (gfc_symbol *sym) -{ - gfc_component *c; - - for (c = sym->components; c; c = c->next) - { - show_indent (); - fprintf (dumpfile, "(%s ", c->name); - show_typespec (&c->ts); - if (c->kind_expr) - { - fputs (" kind_expr: ", dumpfile); - show_expr (c->kind_expr); - } - if (c->param_list) - { - fputs ("PDT parameters", dumpfile); - show_actual_arglist (c->param_list); - } - - if (c->attr.allocatable) - fputs (" ALLOCATABLE", dumpfile); - if (c->attr.pdt_kind) - fputs (" KIND", dumpfile); - if (c->attr.pdt_len) - fputs (" LEN", dumpfile); - if (c->attr.pointer) - fputs (" POINTER", dumpfile); - if (c->attr.proc_pointer) - fputs (" PPC", dumpfile); - if (c->attr.dimension) - fputs (" DIMENSION", dumpfile); - fputc (' ', dumpfile); - show_array_spec (c->as); - if (c->attr.access) - fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access)); - fputc (')', dumpfile); - if (c->next != NULL) - fputc (' ', dumpfile); - } -} - - -/* Show the f2k_derived namespace with procedure bindings. */ - -static void -show_typebound_proc (gfc_typebound_proc* tb, const char* name) -{ - show_indent (); - - if (tb->is_generic) - fputs ("GENERIC", dumpfile); - else - { - fputs ("PROCEDURE, ", dumpfile); - if (tb->nopass) - fputs ("NOPASS", dumpfile); - else - { - if (tb->pass_arg) - fprintf (dumpfile, "PASS(%s)", tb->pass_arg); - else - fputs ("PASS", dumpfile); - } - if (tb->non_overridable) - fputs (", NON_OVERRIDABLE", dumpfile); - } - - if (tb->access == ACCESS_PUBLIC) - fputs (", PUBLIC", dumpfile); - else - fputs (", PRIVATE", dumpfile); - - fprintf (dumpfile, " :: %s => ", name); - - if (tb->is_generic) - { - gfc_tbp_generic* g; - for (g = tb->u.generic; g; g = g->next) - { - fputs (g->specific_st->name, dumpfile); - if (g->next) - fputs (", ", dumpfile); - } - } - else - fputs (tb->u.specific->n.sym->name, dumpfile); -} - -static void -show_typebound_symtree (gfc_symtree* st) -{ - gcc_assert (st->n.tb); - show_typebound_proc (st->n.tb, st->name); -} - -static void -show_f2k_derived (gfc_namespace* f2k) -{ - gfc_finalizer* f; - int op; - - show_indent (); - fputs ("Procedure bindings:", dumpfile); - ++show_level; - - /* Finalizer bindings. */ - for (f = f2k->finalizers; f; f = f->next) - { - show_indent (); - fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name); - } - - /* Type-bound procedures. */ - gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree); - - --show_level; - - show_indent (); - fputs ("Operator bindings:", dumpfile); - ++show_level; - - /* User-defined operators. */ - gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree); - - /* Intrinsic operators. */ - for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) - if (f2k->tb_op[op]) - show_typebound_proc (f2k->tb_op[op], - gfc_op2string ((gfc_intrinsic_op) op)); - - --show_level; -} - - -/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we - show the interface. Information needed to reconstruct the list of - specific interfaces associated with a generic symbol is done within - that symbol. */ - -static void -show_symbol (gfc_symbol *sym) -{ - gfc_formal_arglist *formal; - gfc_interface *intr; - int i,len; - - if (sym == NULL) - return; - - fprintf (dumpfile, "|| symbol: '%s' ", sym->name); - len = strlen (sym->name); - for (i=len; i<12; i++) - fputc(' ', dumpfile); - - if (sym->binding_label) - fprintf (dumpfile,"|| binding_label: '%s' ", sym->binding_label); - - ++show_level; - - show_indent (); - fputs ("type spec : ", dumpfile); - show_typespec (&sym->ts); - - show_indent (); - fputs ("attributes: ", dumpfile); - show_attr (&sym->attr, sym->module); - - if (sym->value) - { - show_indent (); - fputs ("value: ", dumpfile); - show_expr (sym->value); - } - - if (sym->ts.type != BT_CLASS && sym->as) - { - show_indent (); - fputs ("Array spec:", dumpfile); - show_array_spec (sym->as); - } - else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) - { - show_indent (); - fputs ("Array spec:", dumpfile); - show_array_spec (CLASS_DATA (sym)->as); - } - - if (sym->generic) - { - show_indent (); - fputs ("Generic interfaces:", dumpfile); - for (intr = sym->generic; intr; intr = intr->next) - fprintf (dumpfile, " %s", intr->sym->name); - } - - if (sym->result) - { - show_indent (); - fprintf (dumpfile, "result: %s", sym->result->name); - } - - if (sym->components) - { - show_indent (); - fputs ("components: ", dumpfile); - show_components (sym); - } - - if (sym->f2k_derived) - { - show_indent (); - if (sym->hash_value) - fprintf (dumpfile, "hash: %d", sym->hash_value); - show_f2k_derived (sym->f2k_derived); - } - - if (sym->formal) - { - show_indent (); - fputs ("Formal arglist:", dumpfile); - - for (formal = sym->formal; formal; formal = formal->next) - { - if (formal->sym != NULL) - fprintf (dumpfile, " %s", formal->sym->name); - else - fputs (" [Alt Return]", dumpfile); - } - } - - if (sym->formal_ns && (sym->formal_ns->proc_name != sym) - && sym->attr.proc != PROC_ST_FUNCTION - && !sym->attr.entry) - { - show_indent (); - fputs ("Formal namespace", dumpfile); - show_namespace (sym->formal_ns); - } - - if (sym->attr.flavor == FL_VARIABLE - && sym->param_list) - { - show_indent (); - fputs ("PDT parameters", dumpfile); - show_actual_arglist (sym->param_list); - } - - if (sym->attr.flavor == FL_NAMELIST) - { - gfc_namelist *nl; - show_indent (); - fputs ("variables : ", dumpfile); - for (nl = sym->namelist; nl; nl = nl->next) - fprintf (dumpfile, " %s",nl->sym->name); - } - - --show_level; -} - - -/* Show a user-defined operator. Just prints an operator - and the name of the associated subroutine, really. */ - -static void -show_uop (gfc_user_op *uop) -{ - gfc_interface *intr; - - show_indent (); - fprintf (dumpfile, "%s:", uop->name); - - for (intr = uop->op; intr; intr = intr->next) - fprintf (dumpfile, " %s", intr->sym->name); -} - - -/* Workhorse function for traversing the user operator symtree. */ - -static void -traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *)) -{ - if (st == NULL) - return; - - (*func) (st->n.uop); - - traverse_uop (st->left, func); - traverse_uop (st->right, func); -} - - -/* Traverse the tree of user operator nodes. */ - -void -gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *)) -{ - traverse_uop (ns->uop_root, func); -} - - -/* Function to display a common block. */ - -static void -show_common (gfc_symtree *st) -{ - gfc_symbol *s; - - show_indent (); - fprintf (dumpfile, "common: /%s/ ", st->name); - - s = st->n.common->head; - while (s) - { - fprintf (dumpfile, "%s", s->name); - s = s->common_next; - if (s) - fputs (", ", dumpfile); - } - fputc ('\n', dumpfile); -} - - -/* Worker function to display the symbol tree. */ - -static void -show_symtree (gfc_symtree *st) -{ - int len, i; - - show_indent (); - - len = strlen(st->name); - fprintf (dumpfile, "symtree: '%s'", st->name); - - for (i=len; i<12; i++) - fputc(' ', dumpfile); - - if (st->ambiguous) - fputs( " Ambiguous", dumpfile); - - if (st->n.sym->ns != gfc_current_ns) - fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name, - st->n.sym->ns->proc_name->name); - else - show_symbol (st->n.sym); -} - - -/******************* Show gfc_code structures **************/ - - -/* Show a list of code structures. Mutually recursive with - show_code_node(). */ - -static void -show_code (int level, gfc_code *c) -{ - for (; c; c = c->next) - show_code_node (level, c); -} - -static void -show_iterator (gfc_namespace *ns) -{ - for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) - { - gfc_constructor *c; - if (sym != ns->proc_name) - fputc (',', dumpfile); - fputs (sym->name, dumpfile); - fputc ('=', dumpfile); - c = gfc_constructor_first (sym->value->value.constructor); - show_expr (c->expr); - fputc (':', dumpfile); - c = gfc_constructor_next (c); - show_expr (c->expr); - c = gfc_constructor_next (c); - if (c) - { - fputc (':', dumpfile); - show_expr (c->expr); - } - } -} - -static void -show_omp_namelist (int list_type, gfc_omp_namelist *n) -{ - gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; - gfc_omp_namelist *n2 = n; - for (; n; n = n->next) - { - gfc_current_ns = ns_curr; - if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND) - { - gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr; - if (n->u2.ns != ns_iter) - { - if (n != n2) - fputs (list_type == OMP_LIST_AFFINITY - ? ") AFFINITY(" : ") DEPEND(", dumpfile); - if (n->u2.ns) - { - fputs ("ITERATOR(", dumpfile); - show_iterator (n->u2.ns); - fputc (')', dumpfile); - fputc (list_type == OMP_LIST_AFFINITY ? ':' : ',', dumpfile); - } - } - ns_iter = n->u2.ns; - } - if (list_type == OMP_LIST_REDUCTION) - switch (n->u.reduction_op) - { - case OMP_REDUCTION_PLUS: - case OMP_REDUCTION_TIMES: - case OMP_REDUCTION_MINUS: - case OMP_REDUCTION_AND: - case OMP_REDUCTION_OR: - case OMP_REDUCTION_EQV: - case OMP_REDUCTION_NEQV: - fprintf (dumpfile, "%s:", - gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op)); - break; - case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break; - case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break; - case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break; - case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break; - case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break; - case OMP_REDUCTION_USER: - if (n->u2.udr) - fprintf (dumpfile, "%s:", n->u2.udr->udr->name); - break; - default: break; - } - else if (list_type == OMP_LIST_DEPEND) - switch (n->u.depend_op) - { - case OMP_DEPEND_IN: fputs ("in:", dumpfile); break; - case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break; - case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break; - case OMP_DEPEND_DEPOBJ: fputs ("depobj:", dumpfile); break; - case OMP_DEPEND_MUTEXINOUTSET: - fputs ("mutexinoutset:", dumpfile); - break; - case OMP_DEPEND_SINK_FIRST: - fputs ("sink:", dumpfile); - while (1) - { - fprintf (dumpfile, "%s", n->sym->name); - if (n->expr) - { - fputc ('+', dumpfile); - show_expr (n->expr); - } - if (n->next == NULL) - break; - else if (n->next->u.depend_op != OMP_DEPEND_SINK) - { - fputs (") DEPEND(", dumpfile); - break; - } - fputc (',', dumpfile); - n = n->next; - } - continue; - default: break; - } - else if (list_type == OMP_LIST_MAP) - switch (n->u.map_op) - { - case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break; - case OMP_MAP_TO: fputs ("to:", dumpfile); break; - case OMP_MAP_FROM: fputs ("from:", dumpfile); break; - case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break; - default: break; - } - else if (list_type == OMP_LIST_LINEAR) - switch (n->u.linear_op) - { - case OMP_LINEAR_REF: fputs ("ref(", dumpfile); break; - case OMP_LINEAR_VAL: fputs ("val(", dumpfile); break; - case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break; - default: break; - } - fprintf (dumpfile, "%s", n->sym->name); - if (list_type == OMP_LIST_LINEAR && n->u.linear_op != OMP_LINEAR_DEFAULT) - fputc (')', dumpfile); - if (n->expr) - { - fputc (':', dumpfile); - show_expr (n->expr); - } - if (n->next) - fputc (',', dumpfile); - } - gfc_current_ns = ns_curr; -} - - -/* Show OpenMP or OpenACC clauses. */ - -static void -show_omp_clauses (gfc_omp_clauses *omp_clauses) -{ - int list_type, i; - - switch (omp_clauses->cancel) - { - case OMP_CANCEL_UNKNOWN: - break; - case OMP_CANCEL_PARALLEL: - fputs (" PARALLEL", dumpfile); - break; - case OMP_CANCEL_SECTIONS: - fputs (" SECTIONS", dumpfile); - break; - case OMP_CANCEL_DO: - fputs (" DO", dumpfile); - break; - case OMP_CANCEL_TASKGROUP: - fputs (" TASKGROUP", dumpfile); - break; - } - if (omp_clauses->if_expr) - { - fputs (" IF(", dumpfile); - show_expr (omp_clauses->if_expr); - fputc (')', dumpfile); - } - if (omp_clauses->final_expr) - { - fputs (" FINAL(", dumpfile); - show_expr (omp_clauses->final_expr); - fputc (')', dumpfile); - } - if (omp_clauses->num_threads) - { - fputs (" NUM_THREADS(", dumpfile); - show_expr (omp_clauses->num_threads); - fputc (')', dumpfile); - } - if (omp_clauses->async) - { - fputs (" ASYNC", dumpfile); - if (omp_clauses->async_expr) - { - fputc ('(', dumpfile); - show_expr (omp_clauses->async_expr); - fputc (')', dumpfile); - } - } - if (omp_clauses->num_gangs_expr) - { - fputs (" NUM_GANGS(", dumpfile); - show_expr (omp_clauses->num_gangs_expr); - fputc (')', dumpfile); - } - if (omp_clauses->num_workers_expr) - { - fputs (" NUM_WORKERS(", dumpfile); - show_expr (omp_clauses->num_workers_expr); - fputc (')', dumpfile); - } - if (omp_clauses->vector_length_expr) - { - fputs (" VECTOR_LENGTH(", dumpfile); - show_expr (omp_clauses->vector_length_expr); - fputc (')', dumpfile); - } - if (omp_clauses->gang) - { - fputs (" GANG", dumpfile); - if (omp_clauses->gang_num_expr || omp_clauses->gang_static_expr) - { - fputc ('(', dumpfile); - if (omp_clauses->gang_num_expr) - { - fprintf (dumpfile, "num:"); - show_expr (omp_clauses->gang_num_expr); - } - if (omp_clauses->gang_num_expr && omp_clauses->gang_static) - fputc (',', dumpfile); - if (omp_clauses->gang_static) - { - fprintf (dumpfile, "static:"); - if (omp_clauses->gang_static_expr) - show_expr (omp_clauses->gang_static_expr); - else - fputc ('*', dumpfile); - } - fputc (')', dumpfile); - } - } - if (omp_clauses->worker) - { - fputs (" WORKER", dumpfile); - if (omp_clauses->worker_expr) - { - fputc ('(', dumpfile); - show_expr (omp_clauses->worker_expr); - fputc (')', dumpfile); - } - } - if (omp_clauses->vector) - { - fputs (" VECTOR", dumpfile); - if (omp_clauses->vector_expr) - { - fputc ('(', dumpfile); - show_expr (omp_clauses->vector_expr); - fputc (')', dumpfile); - } - } - if (omp_clauses->sched_kind != OMP_SCHED_NONE) - { - const char *type; - switch (omp_clauses->sched_kind) - { - case OMP_SCHED_STATIC: type = "STATIC"; break; - case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break; - case OMP_SCHED_GUIDED: type = "GUIDED"; break; - case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; - case OMP_SCHED_AUTO: type = "AUTO"; break; - default: - gcc_unreachable (); - } - fputs (" SCHEDULE (", dumpfile); - if (omp_clauses->sched_simd) - { - if (omp_clauses->sched_monotonic - || omp_clauses->sched_nonmonotonic) - fputs ("SIMD, ", dumpfile); - else - fputs ("SIMD: ", dumpfile); - } - if (omp_clauses->sched_monotonic) - fputs ("MONOTONIC: ", dumpfile); - else if (omp_clauses->sched_nonmonotonic) - fputs ("NONMONOTONIC: ", dumpfile); - fputs (type, dumpfile); - if (omp_clauses->chunk_size) - { - fputc (',', dumpfile); - show_expr (omp_clauses->chunk_size); - } - fputc (')', dumpfile); - } - if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN) - { - const char *type; - switch (omp_clauses->default_sharing) - { - case OMP_DEFAULT_NONE: type = "NONE"; break; - case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break; - case OMP_DEFAULT_SHARED: type = "SHARED"; break; - case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; - case OMP_DEFAULT_PRESENT: type = "PRESENT"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " DEFAULT(%s)", type); - } - if (omp_clauses->tile_list) - { - gfc_expr_list *list; - fputs (" TILE(", dumpfile); - for (list = omp_clauses->tile_list; list; list = list->next) - { - show_expr (list->expr); - if (list->next) - fputs (", ", dumpfile); - } - fputc (')', dumpfile); - } - if (omp_clauses->wait_list) - { - gfc_expr_list *list; - fputs (" WAIT(", dumpfile); - for (list = omp_clauses->wait_list; list; list = list->next) - { - show_expr (list->expr); - if (list->next) - fputs (", ", dumpfile); - } - fputc (')', dumpfile); - } - if (omp_clauses->seq) - fputs (" SEQ", dumpfile); - if (omp_clauses->independent) - fputs (" INDEPENDENT", dumpfile); - if (omp_clauses->order_concurrent) - { - fputs (" ORDER(", dumpfile); - if (omp_clauses->order_unconstrained) - fputs ("UNCONSTRAINED:", dumpfile); - else if (omp_clauses->order_reproducible) - fputs ("REPRODUCIBLE:", dumpfile); - fputs ("CONCURRENT)", dumpfile); - } - if (omp_clauses->ordered) - { - if (omp_clauses->orderedc) - fprintf (dumpfile, " ORDERED(%d)", omp_clauses->orderedc); - else - fputs (" ORDERED", dumpfile); - } - if (omp_clauses->untied) - fputs (" UNTIED", dumpfile); - if (omp_clauses->mergeable) - fputs (" MERGEABLE", dumpfile); - if (omp_clauses->collapse) - fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse); - for (list_type = 0; list_type < OMP_LIST_NUM; list_type++) - if (omp_clauses->lists[list_type] != NULL - && list_type != OMP_LIST_COPYPRIVATE) - { - const char *type = NULL; - switch (list_type) - { - case OMP_LIST_PRIVATE: type = "PRIVATE"; break; - case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; - case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break; - case OMP_LIST_COPYPRIVATE: type = "COPYPRIVATE"; break; - case OMP_LIST_SHARED: type = "SHARED"; break; - case OMP_LIST_COPYIN: type = "COPYIN"; break; - case OMP_LIST_UNIFORM: type = "UNIFORM"; break; - case OMP_LIST_AFFINITY: type = "AFFINITY"; break; - case OMP_LIST_ALIGNED: type = "ALIGNED"; break; - case OMP_LIST_LINEAR: type = "LINEAR"; break; - case OMP_LIST_DEPEND: type = "DEPEND"; break; - case OMP_LIST_MAP: type = "MAP"; break; - case OMP_LIST_TO: type = "TO"; break; - case OMP_LIST_FROM: type = "FROM"; break; - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: type = "REDUCTION"; break; - case OMP_LIST_IN_REDUCTION: type = "IN_REDUCTION"; break; - case OMP_LIST_TASK_REDUCTION: type = "TASK_REDUCTION"; break; - case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break; - case OMP_LIST_LINK: type = "LINK"; break; - case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break; - case OMP_LIST_CACHE: type = "CACHE"; break; - case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break; - case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break; - case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break; - case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break; - case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break; - case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break; - case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " %s(", type); - if (list_type == OMP_LIST_REDUCTION_INSCAN) - fputs ("inscan, ", dumpfile); - if (list_type == OMP_LIST_REDUCTION_TASK) - fputs ("task, ", dumpfile); - show_omp_namelist (list_type, omp_clauses->lists[list_type]); - fputc (')', dumpfile); - } - if (omp_clauses->safelen_expr) - { - fputs (" SAFELEN(", dumpfile); - show_expr (omp_clauses->safelen_expr); - fputc (')', dumpfile); - } - if (omp_clauses->simdlen_expr) - { - fputs (" SIMDLEN(", dumpfile); - show_expr (omp_clauses->simdlen_expr); - fputc (')', dumpfile); - } - if (omp_clauses->inbranch) - fputs (" INBRANCH", dumpfile); - if (omp_clauses->notinbranch) - fputs (" NOTINBRANCH", dumpfile); - if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) - { - const char *type; - switch (omp_clauses->proc_bind) - { - case OMP_PROC_BIND_PRIMARY: type = "PRIMARY"; break; - case OMP_PROC_BIND_MASTER: type = "MASTER"; break; - case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break; - case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " PROC_BIND(%s)", type); - } - if (omp_clauses->bind != OMP_BIND_UNSET) - { - const char *type; - switch (omp_clauses->bind) - { - case OMP_BIND_TEAMS: type = "TEAMS"; break; - case OMP_BIND_PARALLEL: type = "PARALLEL"; break; - case OMP_BIND_THREAD: type = "THREAD"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, " BIND(%s)", type); - } - if (omp_clauses->num_teams_upper) - { - fputs (" NUM_TEAMS(", dumpfile); - if (omp_clauses->num_teams_lower) - { - show_expr (omp_clauses->num_teams_lower); - fputc (':', dumpfile); - } - show_expr (omp_clauses->num_teams_upper); - fputc (')', dumpfile); - } - if (omp_clauses->device) - { - fputs (" DEVICE(", dumpfile); - if (omp_clauses->ancestor) - fputs ("ANCESTOR:", dumpfile); - show_expr (omp_clauses->device); - fputc (')', dumpfile); - } - if (omp_clauses->thread_limit) - { - fputs (" THREAD_LIMIT(", dumpfile); - show_expr (omp_clauses->thread_limit); - fputc (')', dumpfile); - } - if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE) - { - fputs (" DIST_SCHEDULE (STATIC", dumpfile); - if (omp_clauses->dist_chunk_size) - { - fputc (',', dumpfile); - show_expr (omp_clauses->dist_chunk_size); - } - fputc (')', dumpfile); - } - for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) - { - const char *dfltmap; - if (omp_clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) - continue; - fputs (" DEFAULTMAP (", dumpfile); - switch (omp_clauses->defaultmap[i]) - { - case OMP_DEFAULTMAP_ALLOC: dfltmap = "ALLOC"; break; - case OMP_DEFAULTMAP_TO: dfltmap = "TO"; break; - case OMP_DEFAULTMAP_FROM: dfltmap = "FROM"; break; - case OMP_DEFAULTMAP_TOFROM: dfltmap = "TOFROM"; break; - case OMP_DEFAULTMAP_FIRSTPRIVATE: dfltmap = "FIRSTPRIVATE"; break; - case OMP_DEFAULTMAP_NONE: dfltmap = "NONE"; break; - case OMP_DEFAULTMAP_DEFAULT: dfltmap = "DEFAULT"; break; - case OMP_DEFAULTMAP_PRESENT: dfltmap = "PRESENT"; break; - default: gcc_unreachable (); - } - fputs (dfltmap, dumpfile); - if (i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED) - { - fputc (':', dumpfile); - switch ((enum gfc_omp_defaultmap_category) i) - { - case OMP_DEFAULTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break; - case OMP_DEFAULTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break; - case OMP_DEFAULTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break; - case OMP_DEFAULTMAP_CAT_POINTER: dfltmap = "POINTER"; break; - default: gcc_unreachable (); - } - fputs (dfltmap, dumpfile); - } - fputc (')', dumpfile); - } - if (omp_clauses->weak) - fputs (" WEAK", dumpfile); - if (omp_clauses->compare) - fputs (" COMPARE", dumpfile); - if (omp_clauses->nogroup) - fputs (" NOGROUP", dumpfile); - if (omp_clauses->simd) - fputs (" SIMD", dumpfile); - if (omp_clauses->threads) - fputs (" THREADS", dumpfile); - if (omp_clauses->grainsize) - { - fputs (" GRAINSIZE(", dumpfile); - if (omp_clauses->grainsize_strict) - fputs ("strict: ", dumpfile); - show_expr (omp_clauses->grainsize); - fputc (')', dumpfile); - } - if (omp_clauses->filter) - { - fputs (" FILTER(", dumpfile); - show_expr (omp_clauses->filter); - fputc (')', dumpfile); - } - if (omp_clauses->hint) - { - fputs (" HINT(", dumpfile); - show_expr (omp_clauses->hint); - fputc (')', dumpfile); - } - if (omp_clauses->num_tasks) - { - fputs (" NUM_TASKS(", dumpfile); - if (omp_clauses->num_tasks_strict) - fputs ("strict: ", dumpfile); - show_expr (omp_clauses->num_tasks); - fputc (')', dumpfile); - } - if (omp_clauses->priority) - { - fputs (" PRIORITY(", dumpfile); - show_expr (omp_clauses->priority); - fputc (')', dumpfile); - } - if (omp_clauses->detach) - { - fputs (" DETACH(", dumpfile); - show_expr (omp_clauses->detach); - fputc (')', dumpfile); - } - for (i = 0; i < OMP_IF_LAST; i++) - if (omp_clauses->if_exprs[i]) - { - static const char *ifs[] = { - "CANCEL", - "PARALLEL", - "SIMD", - "TASK", - "TASKLOOP", - "TARGET", - "TARGET DATA", - "TARGET UPDATE", - "TARGET ENTER DATA", - "TARGET EXIT DATA" - }; - fputs (" IF(", dumpfile); - fputs (ifs[i], dumpfile); - fputs (": ", dumpfile); - show_expr (omp_clauses->if_exprs[i]); - fputc (')', dumpfile); - } - if (omp_clauses->destroy) - fputs (" DESTROY", dumpfile); - if (omp_clauses->depend_source) - fputs (" DEPEND(source)", dumpfile); - if (omp_clauses->capture) - fputs (" CAPTURE", dumpfile); - if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) - { - const char *deptype; - fputs (" UPDATE(", dumpfile); - switch (omp_clauses->depobj_update) - { - case OMP_DEPEND_IN: deptype = "IN"; break; - case OMP_DEPEND_OUT: deptype = "OUT"; break; - case OMP_DEPEND_INOUT: deptype = "INOUT"; break; - case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break; - default: gcc_unreachable (); - } - fputs (deptype, dumpfile); - fputc (')', dumpfile); - } - if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET) - { - const char *atomic_op; - switch (omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) - { - case GFC_OMP_ATOMIC_READ: atomic_op = "READ"; break; - case GFC_OMP_ATOMIC_WRITE: atomic_op = "WRITE"; break; - case GFC_OMP_ATOMIC_UPDATE: atomic_op = "UPDATE"; break; - default: gcc_unreachable (); - } - fputc (' ', dumpfile); - fputs (atomic_op, dumpfile); - } - if (omp_clauses->memorder != OMP_MEMORDER_UNSET) - { - const char *memorder; - switch (omp_clauses->memorder) - { - case OMP_MEMORDER_ACQ_REL: memorder = "ACQ_REL"; break; - case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break; - case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break; - case OMP_MEMORDER_RELEASE: memorder = "RELEASE"; break; - case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break; - default: gcc_unreachable (); - } - fputc (' ', dumpfile); - fputs (memorder, dumpfile); - } - if (omp_clauses->fail != OMP_MEMORDER_UNSET) - { - const char *memorder; - switch (omp_clauses->fail) - { - case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break; - case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break; - case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break; - default: gcc_unreachable (); - } - fputs (" FAIL(", dumpfile); - fputs (memorder, dumpfile); - putc (')', dumpfile); - } - if (omp_clauses->at != OMP_AT_UNSET) - { - if (omp_clauses->at != OMP_AT_COMPILATION) - fputs (" AT (COMPILATION)", dumpfile); - else - fputs (" AT (EXECUTION)", dumpfile); - } - if (omp_clauses->severity != OMP_SEVERITY_UNSET) - { - if (omp_clauses->severity != OMP_SEVERITY_FATAL) - fputs (" SEVERITY (FATAL)", dumpfile); - else - fputs (" SEVERITY (WARNING)", dumpfile); - } - if (omp_clauses->message) - { - fputs (" ERROR (", dumpfile); - show_expr (omp_clauses->message); - fputc (')', dumpfile); - } -} - -/* Show a single OpenMP or OpenACC directive node and everything underneath it - if necessary. */ - -static void -show_omp_node (int level, gfc_code *c) -{ - gfc_omp_clauses *omp_clauses = NULL; - const char *name = NULL; - bool is_oacc = false; - - switch (c->op) - { - case EXEC_OACC_PARALLEL_LOOP: - name = "PARALLEL LOOP"; is_oacc = true; break; - case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break; - case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break; - case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break; - case EXEC_OACC_SERIAL_LOOP: name = "SERIAL LOOP"; is_oacc = true; break; - case EXEC_OACC_SERIAL: name = "SERIAL"; is_oacc = true; break; - case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break; - case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break; - case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break; - case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break; - case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break; - case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break; - case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break; - case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break; - case EXEC_OMP_ATOMIC: name = "ATOMIC"; break; - case EXEC_OMP_BARRIER: name = "BARRIER"; break; - case EXEC_OMP_CANCEL: name = "CANCEL"; break; - case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break; - case EXEC_OMP_CRITICAL: name = "CRITICAL"; break; - case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - name = "DISTRIBUTE PARALLEL DO"; break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "DISTRIBUTE PARALLEL DO SIMD"; break; - case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break; - case EXEC_OMP_DO: name = "DO"; break; - case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break; - case EXEC_OMP_ERROR: name = "ERROR"; break; - case EXEC_OMP_FLUSH: name = "FLUSH"; break; - case EXEC_OMP_LOOP: name = "LOOP"; break; - case EXEC_OMP_MASKED: name = "MASKED"; break; - case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break; - case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break; - case EXEC_OMP_MASTER: name = "MASTER"; break; - case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break; - case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break; - case EXEC_OMP_ORDERED: name = "ORDERED"; break; - case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break; - case EXEC_OMP_PARALLEL: name = "PARALLEL"; break; - case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break; - case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break; - case EXEC_OMP_PARALLEL_LOOP: name = "PARALLEL LOOP"; break; - case EXEC_OMP_PARALLEL_MASTER: name = "PARALLEL MASTER"; break; - case EXEC_OMP_PARALLEL_MASKED: name = "PARALLEL MASK"; break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - name = "PARALLEL MASK TASKLOOP"; break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - name = "PARALLEL MASK TASKLOOP SIMD"; break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - name = "PARALLEL MASTER TASKLOOP"; break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - name = "PARALLEL MASTER TASKLOOP SIMD"; break; - case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break; - case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break; - case EXEC_OMP_SCAN: name = "SCAN"; break; - case EXEC_OMP_SCOPE: name = "SCOPE"; break; - case EXEC_OMP_SECTIONS: name = "SECTIONS"; break; - case EXEC_OMP_SIMD: name = "SIMD"; break; - case EXEC_OMP_SINGLE: name = "SINGLE"; break; - case EXEC_OMP_TARGET: name = "TARGET"; break; - case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break; - case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break; - case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break; - case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break; - case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break; - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - name = "TARGET_PARALLEL_DO_SIMD"; break; - case EXEC_OMP_TARGET_PARALLEL_LOOP: name = "TARGET PARALLEL LOOP"; break; - case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break; - case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - name = "TARGET TEAMS DISTRIBUTE"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - name = "TARGET TEAMS DISTRIBUTE SIMD"; break; - case EXEC_OMP_TARGET_TEAMS_LOOP: name = "TARGET TEAMS LOOP"; break; - case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break; - case EXEC_OMP_TASK: name = "TASK"; break; - case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break; - case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break; - case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break; - case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break; - case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break; - case EXEC_OMP_TEAMS: name = "TEAMS"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - name = "TEAMS DISTRIBUTE PARALLEL DO"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break; - case EXEC_OMP_TEAMS_LOOP: name = "TEAMS LOOP"; break; - case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break; - default: - gcc_unreachable (); - } - fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name); - switch (c->op) - { - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_ERROR: - case EXEC_OMP_LOOP: - case EXEC_OMP_ORDERED: - case EXEC_OMP_MASKED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SCAN: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_WORKSHARE: - omp_clauses = c->ext.omp_clauses; - break; - case EXEC_OMP_CRITICAL: - omp_clauses = c->ext.omp_clauses; - if (omp_clauses) - fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); - break; - case EXEC_OMP_DEPOBJ: - omp_clauses = c->ext.omp_clauses; - if (omp_clauses) - { - fputc ('(', dumpfile); - show_expr (c->ext.omp_clauses->depobj); - fputc (')', dumpfile); - } - break; - case EXEC_OMP_FLUSH: - if (c->ext.omp_namelist) - { - fputs (" (", dumpfile); - show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist); - fputc (')', dumpfile); - } - return; - case EXEC_OMP_BARRIER: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - return; - case EXEC_OACC_ATOMIC: - case EXEC_OMP_ATOMIC: - omp_clauses = c->block ? c->block->ext.omp_clauses : NULL; - break; - default: - break; - } - if (omp_clauses) - show_omp_clauses (omp_clauses); - fputc ('\n', dumpfile); - - /* OpenMP and OpenACC executable directives don't have associated blocks. */ - if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE - || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA - || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA - || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN - || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR - || (c->op == EXEC_OMP_ORDERED && c->block == NULL)) - return; - if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) - { - gfc_code *d = c->block; - while (d != NULL) - { - show_code (level + 1, d->next); - if (d->block == NULL) - break; - code_indent (level, 0); - fputs ("!$OMP SECTION\n", dumpfile); - d = d->block; - } - } - else - show_code (level + 1, c->block->next); - if (c->op == EXEC_OMP_ATOMIC) - return; - fputc ('\n', dumpfile); - code_indent (level, 0); - fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name); - if (omp_clauses != NULL) - { - if (omp_clauses->lists[OMP_LIST_COPYPRIVATE]) - { - fputs (" COPYPRIVATE(", dumpfile); - show_omp_namelist (OMP_LIST_COPYPRIVATE, - omp_clauses->lists[OMP_LIST_COPYPRIVATE]); - fputc (')', dumpfile); - } - else if (omp_clauses->nowait) - fputs (" NOWAIT", dumpfile); - } - else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses) - fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); -} - - -/* Show a single code node and everything underneath it if necessary. */ - -static void -show_code_node (int level, gfc_code *c) -{ - gfc_forall_iterator *fa; - gfc_open *open; - gfc_case *cp; - gfc_alloc *a; - gfc_code *d; - gfc_close *close; - gfc_filepos *fp; - gfc_inquire *i; - gfc_dt *dt; - gfc_namespace *ns; - - if (c->here) - { - fputc ('\n', dumpfile); - code_indent (level, c->here); - } - else - show_indent (); - - switch (c->op) - { - case EXEC_END_PROCEDURE: - break; - - case EXEC_NOP: - fputs ("NOP", dumpfile); - break; - - case EXEC_CONTINUE: - fputs ("CONTINUE", dumpfile); - break; - - case EXEC_ENTRY: - fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name); - break; - - case EXEC_INIT_ASSIGN: - case EXEC_ASSIGN: - fputs ("ASSIGN ", dumpfile); - show_expr (c->expr1); - fputc (' ', dumpfile); - show_expr (c->expr2); - break; - - case EXEC_LABEL_ASSIGN: - fputs ("LABEL ASSIGN ", dumpfile); - show_expr (c->expr1); - fprintf (dumpfile, " %d", c->label1->value); - break; - - case EXEC_POINTER_ASSIGN: - fputs ("POINTER ASSIGN ", dumpfile); - show_expr (c->expr1); - fputc (' ', dumpfile); - show_expr (c->expr2); - break; - - case EXEC_GOTO: - fputs ("GOTO ", dumpfile); - if (c->label1) - fprintf (dumpfile, "%d", c->label1->value); - else - { - show_expr (c->expr1); - d = c->block; - if (d != NULL) - { - fputs (", (", dumpfile); - for (; d; d = d ->block) - { - code_indent (level, d->label1); - if (d->block != NULL) - fputc (',', dumpfile); - else - fputc (')', dumpfile); - } - } - } - break; - - case EXEC_CALL: - case EXEC_ASSIGN_CALL: - if (c->resolved_sym) - fprintf (dumpfile, "CALL %s ", c->resolved_sym->name); - else if (c->symtree) - fprintf (dumpfile, "CALL %s ", c->symtree->name); - else - fputs ("CALL ?? ", dumpfile); - - show_actual_arglist (c->ext.actual); - break; - - case EXEC_COMPCALL: - fputs ("CALL ", dumpfile); - show_compcall (c->expr1); - break; - - case EXEC_CALL_PPC: - fputs ("CALL ", dumpfile); - show_expr (c->expr1); - show_actual_arglist (c->ext.actual); - break; - - case EXEC_RETURN: - fputs ("RETURN ", dumpfile); - if (c->expr1) - show_expr (c->expr1); - break; - - case EXEC_PAUSE: - fputs ("PAUSE ", dumpfile); - - if (c->expr1 != NULL) - show_expr (c->expr1); - else - fprintf (dumpfile, "%d", c->ext.stop_code); - - break; - - case EXEC_ERROR_STOP: - fputs ("ERROR ", dumpfile); - /* Fall through. */ - - case EXEC_STOP: - fputs ("STOP ", dumpfile); - - if (c->expr1 != NULL) - show_expr (c->expr1); - else - fprintf (dumpfile, "%d", c->ext.stop_code); - - break; - - case EXEC_FAIL_IMAGE: - fputs ("FAIL IMAGE ", dumpfile); - break; - - case EXEC_CHANGE_TEAM: - fputs ("CHANGE TEAM", dumpfile); - break; - - case EXEC_END_TEAM: - fputs ("END TEAM", dumpfile); - break; - - case EXEC_FORM_TEAM: - fputs ("FORM TEAM", dumpfile); - break; - - case EXEC_SYNC_TEAM: - fputs ("SYNC TEAM", dumpfile); - break; - - case EXEC_SYNC_ALL: - fputs ("SYNC ALL ", dumpfile); - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_SYNC_MEMORY: - fputs ("SYNC MEMORY ", dumpfile); - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_SYNC_IMAGES: - fputs ("SYNC IMAGES image-set=", dumpfile); - if (c->expr1 != NULL) - show_expr (c->expr1); - else - fputs ("* ", dumpfile); - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_EVENT_POST: - case EXEC_EVENT_WAIT: - if (c->op == EXEC_EVENT_POST) - fputs ("EVENT POST ", dumpfile); - else - fputs ("EVENT WAIT ", dumpfile); - - fputs ("event-variable=", dumpfile); - if (c->expr1 != NULL) - show_expr (c->expr1); - if (c->expr4 != NULL) - { - fputs (" until_count=", dumpfile); - show_expr (c->expr4); - } - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_LOCK: - case EXEC_UNLOCK: - if (c->op == EXEC_LOCK) - fputs ("LOCK ", dumpfile); - else - fputs ("UNLOCK ", dumpfile); - - fputs ("lock-variable=", dumpfile); - if (c->expr1 != NULL) - show_expr (c->expr1); - if (c->expr4 != NULL) - { - fputs (" acquired_lock=", dumpfile); - show_expr (c->expr4); - } - if (c->expr2 != NULL) - { - fputs (" stat=", dumpfile); - show_expr (c->expr2); - } - if (c->expr3 != NULL) - { - fputs (" errmsg=", dumpfile); - show_expr (c->expr3); - } - break; - - case EXEC_ARITHMETIC_IF: - fputs ("IF ", dumpfile); - show_expr (c->expr1); - fprintf (dumpfile, " %d, %d, %d", - c->label1->value, c->label2->value, c->label3->value); - break; - - case EXEC_IF: - d = c->block; - fputs ("IF ", dumpfile); - show_expr (d->expr1); - - ++show_level; - show_code (level + 1, d->next); - --show_level; - - d = d->block; - for (; d; d = d->block) - { - fputs("\n", dumpfile); - code_indent (level, 0); - if (d->expr1 == NULL) - fputs ("ELSE", dumpfile); - else - { - fputs ("ELSE IF ", dumpfile); - show_expr (d->expr1); - } - - ++show_level; - show_code (level + 1, d->next); - --show_level; - } - - if (c->label1) - code_indent (level, c->label1); - else - show_indent (); - - fputs ("ENDIF", dumpfile); - break; - - case EXEC_BLOCK: - { - const char* blocktype; - gfc_namespace *saved_ns; - gfc_association_list *alist; - - if (c->ext.block.assoc) - blocktype = "ASSOCIATE"; - else - blocktype = "BLOCK"; - show_indent (); - fprintf (dumpfile, "%s ", blocktype); - for (alist = c->ext.block.assoc; alist; alist = alist->next) - { - fprintf (dumpfile, " %s = ", alist->name); - show_expr (alist->target); - } - - ++show_level; - ns = c->ext.block.ns; - saved_ns = gfc_current_ns; - gfc_current_ns = ns; - gfc_traverse_symtree (ns->sym_root, show_symtree); - gfc_current_ns = saved_ns; - show_code (show_level, ns->code); - --show_level; - show_indent (); - fprintf (dumpfile, "END %s ", blocktype); - break; - } - - case EXEC_END_BLOCK: - /* Only come here when there is a label on an - END ASSOCIATE construct. */ - break; - - case EXEC_SELECT: - case EXEC_SELECT_TYPE: - case EXEC_SELECT_RANK: - d = c->block; - fputc ('\n', dumpfile); - code_indent (level, 0); - if (c->op == EXEC_SELECT_RANK) - fputs ("SELECT RANK ", dumpfile); - else if (c->op == EXEC_SELECT_TYPE) - fputs ("SELECT TYPE ", dumpfile); - else - fputs ("SELECT CASE ", dumpfile); - show_expr (c->expr1); - - for (; d; d = d->block) - { - fputc ('\n', dumpfile); - code_indent (level, 0); - fputs ("CASE ", dumpfile); - for (cp = d->ext.block.case_list; cp; cp = cp->next) - { - fputc ('(', dumpfile); - show_expr (cp->low); - fputc (' ', dumpfile); - show_expr (cp->high); - fputc (')', dumpfile); - fputc (' ', dumpfile); - } - - show_code (level + 1, d->next); - fputc ('\n', dumpfile); - } - - code_indent (level, c->label1); - fputs ("END SELECT", dumpfile); - break; - - case EXEC_WHERE: - fputs ("WHERE ", dumpfile); - - d = c->block; - show_expr (d->expr1); - fputc ('\n', dumpfile); - - show_code (level + 1, d->next); - - for (d = d->block; d; d = d->block) - { - code_indent (level, 0); - fputs ("ELSE WHERE ", dumpfile); - show_expr (d->expr1); - fputc ('\n', dumpfile); - show_code (level + 1, d->next); - } - - code_indent (level, 0); - fputs ("END WHERE", dumpfile); - break; - - - case EXEC_FORALL: - fputs ("FORALL ", dumpfile); - for (fa = c->ext.forall_iterator; fa; fa = fa->next) - { - show_expr (fa->var); - fputc (' ', dumpfile); - show_expr (fa->start); - fputc (':', dumpfile); - show_expr (fa->end); - fputc (':', dumpfile); - show_expr (fa->stride); - - if (fa->next != NULL) - fputc (',', dumpfile); - } - - if (c->expr1 != NULL) - { - fputc (',', dumpfile); - show_expr (c->expr1); - } - fputc ('\n', dumpfile); - - show_code (level + 1, c->block->next); - - code_indent (level, 0); - fputs ("END FORALL", dumpfile); - break; - - case EXEC_CRITICAL: - fputs ("CRITICAL\n", dumpfile); - show_code (level + 1, c->block->next); - code_indent (level, 0); - fputs ("END CRITICAL", dumpfile); - break; - - case EXEC_DO: - fputs ("DO ", dumpfile); - if (c->label1) - fprintf (dumpfile, " %-5d ", c->label1->value); - - show_expr (c->ext.iterator->var); - fputc ('=', dumpfile); - show_expr (c->ext.iterator->start); - fputc (' ', dumpfile); - show_expr (c->ext.iterator->end); - fputc (' ', dumpfile); - show_expr (c->ext.iterator->step); - - ++show_level; - show_code (level + 1, c->block->next); - --show_level; - - if (c->label1) - break; - - show_indent (); - fputs ("END DO", dumpfile); - break; - - case EXEC_DO_CONCURRENT: - fputs ("DO CONCURRENT ", dumpfile); - for (fa = c->ext.forall_iterator; fa; fa = fa->next) - { - show_expr (fa->var); - fputc (' ', dumpfile); - show_expr (fa->start); - fputc (':', dumpfile); - show_expr (fa->end); - fputc (':', dumpfile); - show_expr (fa->stride); - - if (fa->next != NULL) - fputc (',', dumpfile); - } - show_expr (c->expr1); - ++show_level; - - show_code (level + 1, c->block->next); - --show_level; - code_indent (level, c->label1); - show_indent (); - fputs ("END DO", dumpfile); - break; - - case EXEC_DO_WHILE: - fputs ("DO WHILE ", dumpfile); - show_expr (c->expr1); - fputc ('\n', dumpfile); - - show_code (level + 1, c->block->next); - - code_indent (level, c->label1); - fputs ("END DO", dumpfile); - break; - - case EXEC_CYCLE: - fputs ("CYCLE", dumpfile); - if (c->symtree) - fprintf (dumpfile, " %s", c->symtree->n.sym->name); - break; - - case EXEC_EXIT: - fputs ("EXIT", dumpfile); - if (c->symtree) - fprintf (dumpfile, " %s", c->symtree->n.sym->name); - break; - - case EXEC_ALLOCATE: - fputs ("ALLOCATE ", dumpfile); - if (c->expr1) - { - fputs (" STAT=", dumpfile); - show_expr (c->expr1); - } - - if (c->expr2) - { - fputs (" ERRMSG=", dumpfile); - show_expr (c->expr2); - } - - if (c->expr3) - { - if (c->expr3->mold) - fputs (" MOLD=", dumpfile); - else - fputs (" SOURCE=", dumpfile); - show_expr (c->expr3); - } - - for (a = c->ext.alloc.list; a; a = a->next) - { - fputc (' ', dumpfile); - show_expr (a->expr); - } - - break; - - case EXEC_DEALLOCATE: - fputs ("DEALLOCATE ", dumpfile); - if (c->expr1) - { - fputs (" STAT=", dumpfile); - show_expr (c->expr1); - } - - if (c->expr2) - { - fputs (" ERRMSG=", dumpfile); - show_expr (c->expr2); - } - - for (a = c->ext.alloc.list; a; a = a->next) - { - fputc (' ', dumpfile); - show_expr (a->expr); - } - - break; - - case EXEC_OPEN: - fputs ("OPEN", dumpfile); - open = c->ext.open; - - if (open->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (open->unit); - } - if (open->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (open->iomsg); - } - if (open->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (open->iostat); - } - if (open->file) - { - fputs (" FILE=", dumpfile); - show_expr (open->file); - } - if (open->status) - { - fputs (" STATUS=", dumpfile); - show_expr (open->status); - } - if (open->access) - { - fputs (" ACCESS=", dumpfile); - show_expr (open->access); - } - if (open->form) - { - fputs (" FORM=", dumpfile); - show_expr (open->form); - } - if (open->recl) - { - fputs (" RECL=", dumpfile); - show_expr (open->recl); - } - if (open->blank) - { - fputs (" BLANK=", dumpfile); - show_expr (open->blank); - } - if (open->position) - { - fputs (" POSITION=", dumpfile); - show_expr (open->position); - } - if (open->action) - { - fputs (" ACTION=", dumpfile); - show_expr (open->action); - } - if (open->delim) - { - fputs (" DELIM=", dumpfile); - show_expr (open->delim); - } - if (open->pad) - { - fputs (" PAD=", dumpfile); - show_expr (open->pad); - } - if (open->decimal) - { - fputs (" DECIMAL=", dumpfile); - show_expr (open->decimal); - } - if (open->encoding) - { - fputs (" ENCODING=", dumpfile); - show_expr (open->encoding); - } - if (open->round) - { - fputs (" ROUND=", dumpfile); - show_expr (open->round); - } - if (open->sign) - { - fputs (" SIGN=", dumpfile); - show_expr (open->sign); - } - if (open->convert) - { - fputs (" CONVERT=", dumpfile); - show_expr (open->convert); - } - if (open->asynchronous) - { - fputs (" ASYNCHRONOUS=", dumpfile); - show_expr (open->asynchronous); - } - if (open->err != NULL) - fprintf (dumpfile, " ERR=%d", open->err->value); - - break; - - case EXEC_CLOSE: - fputs ("CLOSE", dumpfile); - close = c->ext.close; - - if (close->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (close->unit); - } - if (close->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (close->iomsg); - } - if (close->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (close->iostat); - } - if (close->status) - { - fputs (" STATUS=", dumpfile); - show_expr (close->status); - } - if (close->err != NULL) - fprintf (dumpfile, " ERR=%d", close->err->value); - break; - - case EXEC_BACKSPACE: - fputs ("BACKSPACE", dumpfile); - goto show_filepos; - - case EXEC_ENDFILE: - fputs ("ENDFILE", dumpfile); - goto show_filepos; - - case EXEC_REWIND: - fputs ("REWIND", dumpfile); - goto show_filepos; - - case EXEC_FLUSH: - fputs ("FLUSH", dumpfile); - - show_filepos: - fp = c->ext.filepos; - - if (fp->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (fp->unit); - } - if (fp->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (fp->iomsg); - } - if (fp->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (fp->iostat); - } - if (fp->err != NULL) - fprintf (dumpfile, " ERR=%d", fp->err->value); - break; - - case EXEC_INQUIRE: - fputs ("INQUIRE", dumpfile); - i = c->ext.inquire; - - if (i->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (i->unit); - } - if (i->file) - { - fputs (" FILE=", dumpfile); - show_expr (i->file); - } - - if (i->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (i->iomsg); - } - if (i->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (i->iostat); - } - if (i->exist) - { - fputs (" EXIST=", dumpfile); - show_expr (i->exist); - } - if (i->opened) - { - fputs (" OPENED=", dumpfile); - show_expr (i->opened); - } - if (i->number) - { - fputs (" NUMBER=", dumpfile); - show_expr (i->number); - } - if (i->named) - { - fputs (" NAMED=", dumpfile); - show_expr (i->named); - } - if (i->name) - { - fputs (" NAME=", dumpfile); - show_expr (i->name); - } - if (i->access) - { - fputs (" ACCESS=", dumpfile); - show_expr (i->access); - } - if (i->sequential) - { - fputs (" SEQUENTIAL=", dumpfile); - show_expr (i->sequential); - } - - if (i->direct) - { - fputs (" DIRECT=", dumpfile); - show_expr (i->direct); - } - if (i->form) - { - fputs (" FORM=", dumpfile); - show_expr (i->form); - } - if (i->formatted) - { - fputs (" FORMATTED", dumpfile); - show_expr (i->formatted); - } - if (i->unformatted) - { - fputs (" UNFORMATTED=", dumpfile); - show_expr (i->unformatted); - } - if (i->recl) - { - fputs (" RECL=", dumpfile); - show_expr (i->recl); - } - if (i->nextrec) - { - fputs (" NEXTREC=", dumpfile); - show_expr (i->nextrec); - } - if (i->blank) - { - fputs (" BLANK=", dumpfile); - show_expr (i->blank); - } - if (i->position) - { - fputs (" POSITION=", dumpfile); - show_expr (i->position); - } - if (i->action) - { - fputs (" ACTION=", dumpfile); - show_expr (i->action); - } - if (i->read) - { - fputs (" READ=", dumpfile); - show_expr (i->read); - } - if (i->write) - { - fputs (" WRITE=", dumpfile); - show_expr (i->write); - } - if (i->readwrite) - { - fputs (" READWRITE=", dumpfile); - show_expr (i->readwrite); - } - if (i->delim) - { - fputs (" DELIM=", dumpfile); - show_expr (i->delim); - } - if (i->pad) - { - fputs (" PAD=", dumpfile); - show_expr (i->pad); - } - if (i->convert) - { - fputs (" CONVERT=", dumpfile); - show_expr (i->convert); - } - if (i->asynchronous) - { - fputs (" ASYNCHRONOUS=", dumpfile); - show_expr (i->asynchronous); - } - if (i->decimal) - { - fputs (" DECIMAL=", dumpfile); - show_expr (i->decimal); - } - if (i->encoding) - { - fputs (" ENCODING=", dumpfile); - show_expr (i->encoding); - } - if (i->pending) - { - fputs (" PENDING=", dumpfile); - show_expr (i->pending); - } - if (i->round) - { - fputs (" ROUND=", dumpfile); - show_expr (i->round); - } - if (i->sign) - { - fputs (" SIGN=", dumpfile); - show_expr (i->sign); - } - if (i->size) - { - fputs (" SIZE=", dumpfile); - show_expr (i->size); - } - if (i->id) - { - fputs (" ID=", dumpfile); - show_expr (i->id); - } - - if (i->err != NULL) - fprintf (dumpfile, " ERR=%d", i->err->value); - break; - - case EXEC_IOLENGTH: - fputs ("IOLENGTH ", dumpfile); - show_expr (c->expr1); - goto show_dt_code; - break; - - case EXEC_READ: - fputs ("READ", dumpfile); - goto show_dt; - - case EXEC_WRITE: - fputs ("WRITE", dumpfile); - - show_dt: - dt = c->ext.dt; - if (dt->io_unit) - { - fputs (" UNIT=", dumpfile); - show_expr (dt->io_unit); - } - - if (dt->format_expr) - { - fputs (" FMT=", dumpfile); - show_expr (dt->format_expr); - } - - if (dt->format_label != NULL) - fprintf (dumpfile, " FMT=%d", dt->format_label->value); - if (dt->namelist) - fprintf (dumpfile, " NML=%s", dt->namelist->name); - - if (dt->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (dt->iomsg); - } - if (dt->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (dt->iostat); - } - if (dt->size) - { - fputs (" SIZE=", dumpfile); - show_expr (dt->size); - } - if (dt->rec) - { - fputs (" REC=", dumpfile); - show_expr (dt->rec); - } - if (dt->advance) - { - fputs (" ADVANCE=", dumpfile); - show_expr (dt->advance); - } - if (dt->id) - { - fputs (" ID=", dumpfile); - show_expr (dt->id); - } - if (dt->pos) - { - fputs (" POS=", dumpfile); - show_expr (dt->pos); - } - if (dt->asynchronous) - { - fputs (" ASYNCHRONOUS=", dumpfile); - show_expr (dt->asynchronous); - } - if (dt->blank) - { - fputs (" BLANK=", dumpfile); - show_expr (dt->blank); - } - if (dt->decimal) - { - fputs (" DECIMAL=", dumpfile); - show_expr (dt->decimal); - } - if (dt->delim) - { - fputs (" DELIM=", dumpfile); - show_expr (dt->delim); - } - if (dt->pad) - { - fputs (" PAD=", dumpfile); - show_expr (dt->pad); - } - if (dt->round) - { - fputs (" ROUND=", dumpfile); - show_expr (dt->round); - } - if (dt->sign) - { - fputs (" SIGN=", dumpfile); - show_expr (dt->sign); - } - - show_dt_code: - for (c = c->block->next; c; c = c->next) - show_code_node (level + (c->next != NULL), c); - return; - - case EXEC_TRANSFER: - fputs ("TRANSFER ", dumpfile); - show_expr (c->expr1); - break; - - case EXEC_DT_END: - fputs ("DT_END", dumpfile); - dt = c->ext.dt; - - if (dt->err != NULL) - fprintf (dumpfile, " ERR=%d", dt->err->value); - if (dt->end != NULL) - fprintf (dumpfile, " END=%d", dt->end->value); - if (dt->eor != NULL) - fprintf (dumpfile, " EOR=%d", dt->eor->value); - break; - - case EXEC_WAIT: - fputs ("WAIT", dumpfile); - - if (c->ext.wait != NULL) - { - gfc_wait *wait = c->ext.wait; - if (wait->unit) - { - fputs (" UNIT=", dumpfile); - show_expr (wait->unit); - } - if (wait->iostat) - { - fputs (" IOSTAT=", dumpfile); - show_expr (wait->iostat); - } - if (wait->iomsg) - { - fputs (" IOMSG=", dumpfile); - show_expr (wait->iomsg); - } - if (wait->id) - { - fputs (" ID=", dumpfile); - show_expr (wait->id); - } - if (wait->err) - fprintf (dumpfile, " ERR=%d", wait->err->value); - if (wait->end) - fprintf (dumpfile, " END=%d", wait->end->value); - if (wait->eor) - fprintf (dumpfile, " EOR=%d", wait->eor->value); - } - break; - - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OMP_ATOMIC: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_BARRIER: - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DEPOBJ: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_ERROR: - case EXEC_OMP_FLUSH: - case EXEC_OMP_LOOP: - case EXEC_OMP_MASKED: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_ORDERED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SCAN: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_WORKSHARE: - show_omp_node (level, c); - break; - - default: - gfc_internal_error ("show_code_node(): Bad statement code"); - } -} - - -/* Show an equivalence chain. */ - -static void -show_equiv (gfc_equiv *eq) -{ - show_indent (); - fputs ("Equivalence: ", dumpfile); - while (eq) - { - show_expr (eq->expr); - eq = eq->eq; - if (eq) - fputs (", ", dumpfile); - } -} - - -/* Show a freakin' whole namespace. */ - -static void -show_namespace (gfc_namespace *ns) -{ - gfc_interface *intr; - gfc_namespace *save; - int op; - gfc_equiv *eq; - int i; - - gcc_assert (ns); - save = gfc_current_ns; - - show_indent (); - fputs ("Namespace:", dumpfile); - - i = 0; - do - { - int l = i; - while (i < GFC_LETTERS - 1 - && gfc_compare_types (&ns->default_type[i+1], - &ns->default_type[l])) - i++; - - if (i > l) - fprintf (dumpfile, " %c-%c: ", l+'A', i+'A'); - else - fprintf (dumpfile, " %c: ", l+'A'); - - show_typespec(&ns->default_type[l]); - i++; - } while (i < GFC_LETTERS); - - if (ns->proc_name != NULL) - { - show_indent (); - fprintf (dumpfile, "procedure name = %s", ns->proc_name->name); - } - - ++show_level; - gfc_current_ns = ns; - gfc_traverse_symtree (ns->common_root, show_common); - - gfc_traverse_symtree (ns->sym_root, show_symtree); - - for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) - { - /* User operator interfaces */ - intr = ns->op[op]; - if (intr == NULL) - continue; - - show_indent (); - fprintf (dumpfile, "Operator interfaces for %s:", - gfc_op2string ((gfc_intrinsic_op) op)); - - for (; intr; intr = intr->next) - fprintf (dumpfile, " %s", intr->sym->name); - } - - if (ns->uop_root != NULL) - { - show_indent (); - fputs ("User operators:\n", dumpfile); - gfc_traverse_user_op (ns, show_uop); - } - - for (eq = ns->equiv; eq; eq = eq->next) - show_equiv (eq); - - if (ns->oacc_declare) - { - struct gfc_oacc_declare *decl; - /* Dump !$ACC DECLARE clauses. */ - for (decl = ns->oacc_declare; decl; decl = decl->next) - { - show_indent (); - fprintf (dumpfile, "!$ACC DECLARE"); - show_omp_clauses (decl->clauses); - } - } - - fputc ('\n', dumpfile); - show_indent (); - fputs ("code:", dumpfile); - show_code (show_level, ns->code); - --show_level; - - for (ns = ns->contained; ns; ns = ns->sibling) - { - fputs ("\nCONTAINS\n", dumpfile); - ++show_level; - show_namespace (ns); - --show_level; - } - - fputc ('\n', dumpfile); - gfc_current_ns = save; -} - - -/* Main function for dumping a parse tree. */ - -void -gfc_dump_parse_tree (gfc_namespace *ns, FILE *file) -{ - dumpfile = file; - show_namespace (ns); -} - -/* This part writes BIND(C) definition for use in external C programs. */ - -static void write_interop_decl (gfc_symbol *); -static void write_proc (gfc_symbol *, bool); - -void -gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file) -{ - int error_count; - gfc_get_errors (NULL, &error_count); - if (error_count != 0) - return; - dumpfile = file; - gfc_traverse_ns (ns, write_interop_decl); -} - -/* Loop over all global symbols, writing out their declrations. */ - -void -gfc_dump_external_c_prototypes (FILE * file) -{ - dumpfile = file; - fprintf (dumpfile, - _("/* Prototypes for external procedures generated from %s\n" - " by GNU Fortran %s%s.\n\n" - " Use of this interface is discouraged, consider using the\n" - " BIND(C) feature of standard Fortran instead. */\n\n"), - gfc_source_file, pkgversion_string, version_string); - - for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; - gfc_current_ns = gfc_current_ns->sibling) - { - gfc_symbol *sym = gfc_current_ns->proc_name; - - if (sym == NULL || sym->attr.flavor != FL_PROCEDURE - || sym->attr.is_bind_c) - continue; - - write_proc (sym, false); - } - return; -} - -enum type_return { T_OK=0, T_WARN, T_ERROR }; - -/* Return the name of the type for later output. Both function pointers and - void pointers will be mapped to void *. */ - -static enum type_return -get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, - const char **type_name, bool *asterisk, const char **post, - bool func_ret) -{ - static char post_buffer[40]; - enum type_return ret; - ret = T_ERROR; - - *pre = " "; - *asterisk = false; - *post = ""; - *type_name = ""; - if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX) - { - if (ts->is_c_interop && ts->interop_kind) - ret = T_OK; - else - ret = T_WARN; - - for (int i = 0; i < ISOCBINDING_NUMBER; i++) - { - if (c_interop_kinds_table[i].f90_type == ts->type - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - if (strcmp (*type_name, "signed_char") == 0) - *type_name = "signed char"; - else if (strcmp (*type_name, "size_t") == 0) - *type_name = "ssize_t"; - else if (strcmp (*type_name, "float_complex") == 0) - *type_name = "__GFORTRAN_FLOAT_COMPLEX"; - else if (strcmp (*type_name, "double_complex") == 0) - *type_name = "__GFORTRAN_DOUBLE_COMPLEX"; - else if (strcmp (*type_name, "long_double_complex") == 0) - *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX"; - - break; - } - } - } - else if (ts->type == BT_LOGICAL) - { - if (ts->is_c_interop && ts->interop_kind) - { - *type_name = "_Bool"; - ret = T_OK; - } - else - { - /* Let's select an appropriate int, with a warning. */ - for (int i = 0; i < ISOCBINDING_NUMBER; i++) - { - if (c_interop_kinds_table[i].f90_type == BT_INTEGER - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - ret = T_WARN; - } - } - } - } - else if (ts->type == BT_CHARACTER) - { - if (ts->is_c_interop) - { - *type_name = "char"; - ret = T_OK; - } - else - { - if (ts->kind == gfc_default_character_kind) - *type_name = "char"; - else - /* Let's select an appropriate int. */ - for (int i = 0; i < ISOCBINDING_NUMBER; i++) - { - if (c_interop_kinds_table[i].f90_type == BT_INTEGER - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - break; - } - } - ret = T_WARN; - - } - } - else if (ts->type == BT_DERIVED) - { - if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING) - { - if (strcmp (ts->u.derived->name, "c_ptr") == 0) - *type_name = "void"; - else if (strcmp (ts->u.derived->name, "c_funptr") == 0) - { - *type_name = "int "; - if (func_ret) - { - *pre = "("; - *post = "())"; - } - else - { - *pre = "("; - *post = ")()"; - } - } - *asterisk = true; - ret = T_OK; - } - else - *type_name = ts->u.derived->name; - - ret = T_OK; - } - - if (ret != T_ERROR && as) - { - mpz_t sz; - bool size_ok; - size_ok = spec_size (as, &sz); - gcc_assert (size_ok == true); - gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz); - *post = post_buffer; - mpz_clear (sz); - } - return ret; -} - -/* Write out a declaration. */ -static void -write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name, - bool func_ret, locus *where, bool bind_c) -{ - const char *pre, *type_name, *post; - bool asterisk; - enum type_return rok; - - rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret); - if (rok == T_ERROR) - { - gfc_error_now ("Cannot convert %qs to interoperable type at %L", - gfc_typename (ts), where); - fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */", - gfc_typename (ts)); - return; - } - fputs (type_name, dumpfile); - fputs (pre, dumpfile); - if (asterisk) - fputs ("*", dumpfile); - - fputs (sym_name, dumpfile); - fputs (post, dumpfile); - - if (rok == T_WARN && bind_c) - fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */", - gfc_typename (ts)); -} - -/* Write out an interoperable type. It will be written as a typedef - for a struct. */ - -static void -write_type (gfc_symbol *sym) -{ - gfc_component *c; - - fprintf (dumpfile, "typedef struct %s {\n", sym->name); - for (c = sym->components; c; c = c->next) - { - fputs (" ", dumpfile); - write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at, true); - fputs (";\n", dumpfile); - } - - fprintf (dumpfile, "} %s;\n", sym->name); -} - -/* Write out a variable. */ - -static void -write_variable (gfc_symbol *sym) -{ - const char *sym_name; - - gcc_assert (sym->attr.flavor == FL_VARIABLE); - - if (sym->binding_label) - sym_name = sym->binding_label; - else - sym_name = sym->name; - - fputs ("extern ", dumpfile); - write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at, true); - fputs (";\n", dumpfile); -} - - -/* Write out a procedure, including its arguments. */ -static void -write_proc (gfc_symbol *sym, bool bind_c) -{ - const char *pre, *type_name, *post; - bool asterisk; - enum type_return rok; - gfc_formal_arglist *f; - const char *sym_name; - const char *intent_in; - bool external_character; - - external_character = sym->ts.type == BT_CHARACTER && !bind_c; - - if (sym->binding_label) - sym_name = sym->binding_label; - else - sym_name = sym->name; - - if (sym->ts.type == BT_UNKNOWN || external_character) - { - fprintf (dumpfile, "void "); - fputs (sym_name, dumpfile); - } - else - write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c); - - if (!bind_c) - fputs ("_", dumpfile); - - fputs (" (", dumpfile); - if (external_character) - { - fprintf (dumpfile, "char *result_%s, size_t result_%s_len", - sym_name, sym_name); - if (sym->formal) - fputs (", ", dumpfile); - } - - for (f = sym->formal; f; f = f->next) - { - gfc_symbol *s; - s = f->sym; - rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk, - &post, false); - if (rok == T_ERROR) - { - gfc_error_now ("Cannot convert %qs to interoperable type at %L", - gfc_typename (&s->ts), &s->declared_at); - fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */", - gfc_typename (&s->ts)); - return; - } - - if (!s->attr.value) - asterisk = true; - - if (s->attr.intent == INTENT_IN && !s->attr.value) - intent_in = "const "; - else - intent_in = ""; - - fputs (intent_in, dumpfile); - fputs (type_name, dumpfile); - fputs (pre, dumpfile); - if (asterisk) - fputs ("*", dumpfile); - - fputs (s->name, dumpfile); - fputs (post, dumpfile); - if (bind_c && rok == T_WARN) - fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile); - - if (f->next) - fputs(", ", dumpfile); - } - if (!bind_c) - for (f = sym->formal; f; f = f->next) - if (f->sym->ts.type == BT_CHARACTER) - fprintf (dumpfile, ", size_t %s_len", f->sym->name); - - fputs (");\n", dumpfile); -} - - -/* Write a C-interoperable declaration as a C prototype or extern - declaration. */ - -static void -write_interop_decl (gfc_symbol *sym) -{ - /* Only dump bind(c) entities. */ - if (!sym->attr.is_bind_c) - return; - - /* Don't dump our iso c module. */ - if (sym->from_intmod == INTMOD_ISO_C_BINDING) - return; - - if (sym->attr.flavor == FL_VARIABLE) - write_variable (sym); - else if (sym->attr.flavor == FL_DERIVED) - write_type (sym); - else if (sym->attr.flavor == FL_PROCEDURE) - write_proc (sym, true); -} - -/* This section deals with dumping the global symbol tree. */ - -/* Callback function for printing out the contents of the tree. */ - -static void -show_global_symbol (gfc_gsymbol *gsym, void *f_data) -{ - FILE *out; - out = (FILE *) f_data; - - if (gsym->name) - fprintf (out, "name=%s", gsym->name); - - if (gsym->sym_name) - fprintf (out, ", sym_name=%s", gsym->sym_name); - - if (gsym->mod_name) - fprintf (out, ", mod_name=%s", gsym->mod_name); - - if (gsym->binding_label) - fprintf (out, ", binding_label=%s", gsym->binding_label); - - fputc ('\n', out); -} - -/* Show all global symbols. */ - -void -gfc_dump_global_symbols (FILE *f) -{ - if (gfc_gsym_root == NULL) - fprintf (f, "empty\n"); - else - gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f); -} - -/* Show an array ref. */ - -void debug (gfc_array_ref *ar) -{ - FILE *tmp = dumpfile; - dumpfile = stderr; - show_array_ref (ar); - fputc ('\n', dumpfile); - dumpfile = tmp; -} diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc new file mode 100644 index 0000000..a618ae2 --- /dev/null +++ b/gcc/fortran/dump-parse-tree.cc @@ -0,0 +1,3924 @@ +/* Parse tree dumper + Copyright (C) 2003-2022 Free Software Foundation, Inc. + Contributed by Steven Bosscher + +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 +. */ + + +/* Actually this is just a collection of routines that used to be + scattered around the sources. Now that they are all in a single + file, almost all of them can be static, and the other files don't + have this mess in them. + + As a nice side-effect, this file can act as documentation of the + gfc_code and gfc_expr structures and all their friends and + relatives. + + TODO: Dump DATA. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "constructor.h" +#include "version.h" + +/* Keep track of indentation for symbol tree dumps. */ +static int show_level = 0; + +/* The file handle we're dumping to is kept in a static variable. This + is not too cool, but it avoids a lot of passing it around. */ +static FILE *dumpfile; + +/* Forward declaration of some of the functions. */ +static void show_expr (gfc_expr *p); +static void show_code_node (int, gfc_code *); +static void show_namespace (gfc_namespace *ns); +static void show_code (int, gfc_code *); +static void show_symbol (gfc_symbol *); +static void show_typespec (gfc_typespec *); +static void show_ref (gfc_ref *); +static void show_attr (symbol_attribute *, const char *); + +/* Allow dumping of an expression in the debugger. */ +void gfc_debug_expr (gfc_expr *); + +void debug (symbol_attribute *attr) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_attr (attr, NULL); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +void debug (gfc_formal_arglist *formal) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + for (; formal; formal = formal->next) + { + fputc ('\n', dumpfile); + show_symbol (formal->sym); + } + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +void debug (symbol_attribute attr) +{ + debug (&attr); +} + +void debug (gfc_expr *e) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + if (e != NULL) + { + show_expr (e); + fputc (' ', dumpfile); + show_typespec (&e->ts); + } + else + fputs ("() ", dumpfile); + + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +void debug (gfc_typespec *ts) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_typespec (ts); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +void debug (gfc_typespec ts) +{ + debug (&ts); +} + +void debug (gfc_ref *p) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_ref (p); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +void +gfc_debug_expr (gfc_expr *e) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_expr (e); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +/* Allow for dumping of a piece of code in the debugger. */ +void gfc_debug_code (gfc_code *c); + +void +gfc_debug_code (gfc_code *c) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_code (1, c); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +void debug (gfc_symbol *sym) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_symbol (sym); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +/* Do indentation for a specific level. */ + +static inline void +code_indent (int level, gfc_st_label *label) +{ + int i; + + if (label != NULL) + fprintf (dumpfile, "%-5d ", label->value); + + for (i = 0; i < (2 * level - (label ? 6 : 0)); i++) + fputc (' ', dumpfile); +} + + +/* Simple indentation at the current level. This one + is used to show symbols. */ + +static inline void +show_indent (void) +{ + fputc ('\n', dumpfile); + code_indent (show_level, NULL); +} + + +/* Show type-specific information. */ + +static void +show_typespec (gfc_typespec *ts) +{ + if (ts->type == BT_ASSUMED) + { + fputs ("(TYPE(*))", dumpfile); + return; + } + + fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type)); + + switch (ts->type) + { + case BT_DERIVED: + case BT_CLASS: + case BT_UNION: + fprintf (dumpfile, "%s", ts->u.derived->name); + break; + + case BT_CHARACTER: + if (ts->u.cl) + show_expr (ts->u.cl->length); + fprintf(dumpfile, " %d", ts->kind); + break; + + default: + fprintf (dumpfile, "%d", ts->kind); + break; + } + if (ts->is_c_interop) + fputs (" C_INTEROP", dumpfile); + + if (ts->is_iso_c) + fputs (" ISO_C", dumpfile); + + if (ts->deferred) + fputs (" DEFERRED", dumpfile); + + fputc (')', dumpfile); +} + + +/* Show an actual argument list. */ + +static void +show_actual_arglist (gfc_actual_arglist *a) +{ + fputc ('(', dumpfile); + + for (; a; a = a->next) + { + fputc ('(', dumpfile); + if (a->name != NULL) + fprintf (dumpfile, "%s = ", a->name); + if (a->expr != NULL) + show_expr (a->expr); + else + fputs ("(arg not-present)", dumpfile); + + fputc (')', dumpfile); + if (a->next != NULL) + fputc (' ', dumpfile); + } + + fputc (')', dumpfile); +} + + +/* Show a gfc_array_spec array specification structure. */ + +static void +show_array_spec (gfc_array_spec *as) +{ + const char *c; + int i; + + if (as == NULL) + { + fputs ("()", dumpfile); + return; + } + + fprintf (dumpfile, "(%d [%d]", as->rank, as->corank); + + if (as->rank + as->corank > 0 || as->rank == -1) + { + switch (as->type) + { + case AS_EXPLICIT: c = "AS_EXPLICIT"; break; + case AS_DEFERRED: c = "AS_DEFERRED"; break; + case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; + case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; + case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break; + default: + gfc_internal_error ("show_array_spec(): Unhandled array shape " + "type."); + } + fprintf (dumpfile, " %s ", c); + + for (i = 0; i < as->rank + as->corank; i++) + { + show_expr (as->lower[i]); + fputc (' ', dumpfile); + show_expr (as->upper[i]); + fputc (' ', dumpfile); + } + } + + fputc (')', dumpfile); +} + + +/* Show a gfc_array_ref array reference structure. */ + +static void +show_array_ref (gfc_array_ref * ar) +{ + int i; + + fputc ('(', dumpfile); + + switch (ar->type) + { + case AR_FULL: + fputs ("FULL", dumpfile); + break; + + case AR_SECTION: + for (i = 0; i < ar->dimen; i++) + { + /* There are two types of array sections: either the + elements are identified by an integer array ('vector'), + or by an index range. In the former case we only have to + print the start expression which contains the vector, in + the latter case we have to print any of lower and upper + bound and the stride, if they're present. */ + + if (ar->start[i] != NULL) + show_expr (ar->start[i]); + + if (ar->dimen_type[i] == DIMEN_RANGE) + { + fputc (':', dumpfile); + + if (ar->end[i] != NULL) + show_expr (ar->end[i]); + + if (ar->stride[i] != NULL) + { + fputc (':', dumpfile); + show_expr (ar->stride[i]); + } + } + + if (i != ar->dimen - 1) + fputs (" , ", dumpfile); + } + break; + + case AR_ELEMENT: + for (i = 0; i < ar->dimen; i++) + { + show_expr (ar->start[i]); + if (i != ar->dimen - 1) + fputs (" , ", dumpfile); + } + break; + + case AR_UNKNOWN: + fputs ("UNKNOWN", dumpfile); + break; + + default: + gfc_internal_error ("show_array_ref(): Unknown array reference"); + } + + fputc (')', dumpfile); + if (ar->codimen == 0) + return; + + /* Show coarray part of the reference, if any. */ + fputc ('[',dumpfile); + for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) + { + if (ar->dimen_type[i] == DIMEN_STAR) + fputc('*',dumpfile); + else if (ar->dimen_type[i] == DIMEN_THIS_IMAGE) + fputs("THIS_IMAGE", dumpfile); + else + { + show_expr (ar->start[i]); + if (ar->end[i]) + { + fputc(':', dumpfile); + show_expr (ar->end[i]); + } + } + if (i != ar->dimen + ar->codimen - 1) + fputs (" , ", dumpfile); + + } + fputc (']',dumpfile); +} + + +/* Show a list of gfc_ref structures. */ + +static void +show_ref (gfc_ref *p) +{ + for (; p; p = p->next) + switch (p->type) + { + case REF_ARRAY: + show_array_ref (&p->u.ar); + break; + + case REF_COMPONENT: + fprintf (dumpfile, " %% %s", p->u.c.component->name); + break; + + case REF_SUBSTRING: + fputc ('(', dumpfile); + show_expr (p->u.ss.start); + fputc (':', dumpfile); + show_expr (p->u.ss.end); + fputc (')', dumpfile); + break; + + case REF_INQUIRY: + switch (p->u.i) + { + case INQUIRY_KIND: + fprintf (dumpfile, " INQUIRY_KIND "); + break; + case INQUIRY_LEN: + fprintf (dumpfile, " INQUIRY_LEN "); + break; + case INQUIRY_RE: + fprintf (dumpfile, " INQUIRY_RE "); + break; + case INQUIRY_IM: + fprintf (dumpfile, " INQUIRY_IM "); + } + break; + + default: + gfc_internal_error ("show_ref(): Bad component code"); + } +} + + +/* Display a constructor. Works recursively for array constructors. */ + +static void +show_constructor (gfc_constructor_base base) +{ + gfc_constructor *c; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + if (c->iterator == NULL) + show_expr (c->expr); + else + { + fputc ('(', dumpfile); + show_expr (c->expr); + + fputc (' ', dumpfile); + show_expr (c->iterator->var); + fputc ('=', dumpfile); + show_expr (c->iterator->start); + fputc (',', dumpfile); + show_expr (c->iterator->end); + fputc (',', dumpfile); + show_expr (c->iterator->step); + + fputc (')', dumpfile); + } + + if (gfc_constructor_next (c) != NULL) + fputs (" , ", dumpfile); + } +} + + +static void +show_char_const (const gfc_char_t *c, gfc_charlen_t length) +{ + fputc ('\'', dumpfile); + for (size_t i = 0; i < (size_t) length; i++) + { + if (c[i] == '\'') + fputs ("''", dumpfile); + else + fputs (gfc_print_wide_char (c[i]), dumpfile); + } + fputc ('\'', dumpfile); +} + + +/* Show a component-call expression. */ + +static void +show_compcall (gfc_expr* p) +{ + gcc_assert (p->expr_type == EXPR_COMPCALL); + + fprintf (dumpfile, "%s", p->symtree->n.sym->name); + show_ref (p->ref); + fprintf (dumpfile, "%s", p->value.compcall.name); + + show_actual_arglist (p->value.compcall.actual); +} + + +/* Show an expression. */ + +static void +show_expr (gfc_expr *p) +{ + const char *c; + int i; + + if (p == NULL) + { + fputs ("()", dumpfile); + return; + } + + switch (p->expr_type) + { + case EXPR_SUBSTRING: + show_char_const (p->value.character.string, p->value.character.length); + show_ref (p->ref); + break; + + case EXPR_STRUCTURE: + fprintf (dumpfile, "%s(", p->ts.u.derived->name); + show_constructor (p->value.constructor); + fputc (')', dumpfile); + break; + + case EXPR_ARRAY: + fputs ("(/ ", dumpfile); + show_constructor (p->value.constructor); + fputs (" /)", dumpfile); + + show_ref (p->ref); + break; + + case EXPR_NULL: + fputs ("NULL()", dumpfile); + break; + + case EXPR_CONSTANT: + switch (p->ts.type) + { + case BT_INTEGER: + mpz_out_str (dumpfile, 10, p->value.integer); + + if (p->ts.kind != gfc_default_integer_kind) + fprintf (dumpfile, "_%d", p->ts.kind); + break; + + case BT_LOGICAL: + if (p->value.logical) + fputs (".true.", dumpfile); + else + fputs (".false.", dumpfile); + break; + + case BT_REAL: + mpfr_out_str (dumpfile, 10, 0, p->value.real, GFC_RND_MODE); + if (p->ts.kind != gfc_default_real_kind) + fprintf (dumpfile, "_%d", p->ts.kind); + break; + + case BT_CHARACTER: + show_char_const (p->value.character.string, + p->value.character.length); + break; + + case BT_COMPLEX: + fputs ("(complex ", dumpfile); + + mpfr_out_str (dumpfile, 10, 0, mpc_realref (p->value.complex), + GFC_RND_MODE); + if (p->ts.kind != gfc_default_complex_kind) + fprintf (dumpfile, "_%d", p->ts.kind); + + fputc (' ', dumpfile); + + mpfr_out_str (dumpfile, 10, 0, mpc_imagref (p->value.complex), + GFC_RND_MODE); + if (p->ts.kind != gfc_default_complex_kind) + fprintf (dumpfile, "_%d", p->ts.kind); + + fputc (')', dumpfile); + break; + + case BT_BOZ: + if (p->boz.rdx == 2) + fputs ("b'", dumpfile); + else if (p->boz.rdx == 8) + fputs ("o'", dumpfile); + else + fputs ("z'", dumpfile); + fprintf (dumpfile, "%s'", p->boz.str); + break; + + case BT_HOLLERITH: + fprintf (dumpfile, HOST_WIDE_INT_PRINT_DEC "H", + p->representation.length); + c = p->representation.string; + for (i = 0; i < p->representation.length; i++, c++) + { + fputc (*c, dumpfile); + } + break; + + default: + fputs ("???", dumpfile); + break; + } + + if (p->representation.string) + { + fputs (" {", dumpfile); + c = p->representation.string; + for (i = 0; i < p->representation.length; i++, c++) + { + fprintf (dumpfile, "%.2x", (unsigned int) *c); + if (i < p->representation.length - 1) + fputc (',', dumpfile); + } + fputc ('}', dumpfile); + } + + break; + + case EXPR_VARIABLE: + if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name) + fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name); + fprintf (dumpfile, "%s", p->symtree->n.sym->name); + show_ref (p->ref); + break; + + case EXPR_OP: + fputc ('(', dumpfile); + switch (p->value.op.op) + { + case INTRINSIC_UPLUS: + fputs ("U+ ", dumpfile); + break; + case INTRINSIC_UMINUS: + fputs ("U- ", dumpfile); + break; + case INTRINSIC_PLUS: + fputs ("+ ", dumpfile); + break; + case INTRINSIC_MINUS: + fputs ("- ", dumpfile); + break; + case INTRINSIC_TIMES: + fputs ("* ", dumpfile); + break; + case INTRINSIC_DIVIDE: + fputs ("/ ", dumpfile); + break; + case INTRINSIC_POWER: + fputs ("** ", dumpfile); + break; + case INTRINSIC_CONCAT: + fputs ("// ", dumpfile); + break; + case INTRINSIC_AND: + fputs ("AND ", dumpfile); + break; + case INTRINSIC_OR: + fputs ("OR ", dumpfile); + break; + case INTRINSIC_EQV: + fputs ("EQV ", dumpfile); + break; + case INTRINSIC_NEQV: + fputs ("NEQV ", dumpfile); + break; + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + fputs ("== ", dumpfile); + break; + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + fputs ("/= ", dumpfile); + break; + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + fputs ("> ", dumpfile); + break; + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + fputs (">= ", dumpfile); + break; + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + fputs ("< ", dumpfile); + break; + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + fputs ("<= ", dumpfile); + break; + case INTRINSIC_NOT: + fputs ("NOT ", dumpfile); + break; + case INTRINSIC_PARENTHESES: + fputs ("parens ", dumpfile); + break; + + default: + gfc_internal_error + ("show_expr(): Bad intrinsic in expression"); + } + + show_expr (p->value.op.op1); + + if (p->value.op.op2) + { + fputc (' ', dumpfile); + show_expr (p->value.op.op2); + } + + fputc (')', dumpfile); + break; + + case EXPR_FUNCTION: + if (p->value.function.name == NULL) + { + fprintf (dumpfile, "%s", p->symtree->n.sym->name); + if (gfc_is_proc_ptr_comp (p)) + show_ref (p->ref); + fputc ('[', dumpfile); + show_actual_arglist (p->value.function.actual); + fputc (']', dumpfile); + } + else + { + fprintf (dumpfile, "%s", p->value.function.name); + if (gfc_is_proc_ptr_comp (p)) + show_ref (p->ref); + fputc ('[', dumpfile); + fputc ('[', dumpfile); + show_actual_arglist (p->value.function.actual); + fputc (']', dumpfile); + fputc (']', dumpfile); + } + + break; + + case EXPR_COMPCALL: + show_compcall (p); + break; + + default: + gfc_internal_error ("show_expr(): Don't know how to show expr"); + } +} + +/* Show symbol attributes. The flavor and intent are followed by + whatever single bit attributes are present. */ + +static void +show_attr (symbol_attribute *attr, const char * module) +{ + if (attr->flavor != FL_UNKNOWN) + { + if (attr->flavor == FL_DERIVED && attr->pdt_template) + fputs (" (PDT-TEMPLATE", dumpfile); + else + fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor)); + } + if (attr->access != ACCESS_UNKNOWN) + fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access)); + if (attr->proc != PROC_UNKNOWN) + fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc)); + if (attr->save != SAVE_NONE) + fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save)); + + if (attr->artificial) + fputs (" ARTIFICIAL", dumpfile); + if (attr->allocatable) + fputs (" ALLOCATABLE", dumpfile); + if (attr->asynchronous) + fputs (" ASYNCHRONOUS", dumpfile); + if (attr->codimension) + fputs (" CODIMENSION", dumpfile); + if (attr->dimension) + fputs (" DIMENSION", dumpfile); + if (attr->contiguous) + fputs (" CONTIGUOUS", dumpfile); + if (attr->external) + fputs (" EXTERNAL", dumpfile); + if (attr->intrinsic) + fputs (" INTRINSIC", dumpfile); + if (attr->optional) + fputs (" OPTIONAL", dumpfile); + if (attr->pdt_kind) + fputs (" KIND", dumpfile); + if (attr->pdt_len) + fputs (" LEN", dumpfile); + if (attr->pointer) + fputs (" POINTER", dumpfile); + if (attr->subref_array_pointer) + fputs (" SUBREF-ARRAY-POINTER", dumpfile); + if (attr->cray_pointer) + fputs (" CRAY-POINTER", dumpfile); + if (attr->cray_pointee) + fputs (" CRAY-POINTEE", dumpfile); + if (attr->is_protected) + fputs (" PROTECTED", dumpfile); + if (attr->value) + fputs (" VALUE", dumpfile); + if (attr->volatile_) + fputs (" VOLATILE", dumpfile); + if (attr->threadprivate) + fputs (" THREADPRIVATE", dumpfile); + if (attr->target) + fputs (" TARGET", dumpfile); + if (attr->dummy) + { + fputs (" DUMMY", dumpfile); + if (attr->intent != INTENT_UNKNOWN) + fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent)); + } + + if (attr->result) + fputs (" RESULT", dumpfile); + if (attr->entry) + fputs (" ENTRY", dumpfile); + if (attr->entry_master) + fputs (" ENTRY-MASTER", dumpfile); + if (attr->mixed_entry_master) + fputs (" MIXED-ENTRY-MASTER", dumpfile); + if (attr->is_bind_c) + fputs (" BIND(C)", dumpfile); + + if (attr->data) + fputs (" DATA", dumpfile); + if (attr->use_assoc) + { + fputs (" USE-ASSOC", dumpfile); + if (module != NULL) + fprintf (dumpfile, "(%s)", module); + } + + if (attr->in_namelist) + fputs (" IN-NAMELIST", dumpfile); + if (attr->in_common) + fputs (" IN-COMMON", dumpfile); + + if (attr->abstract) + fputs (" ABSTRACT", dumpfile); + if (attr->function) + fputs (" FUNCTION", dumpfile); + if (attr->subroutine) + fputs (" SUBROUTINE", dumpfile); + if (attr->implicit_type) + fputs (" IMPLICIT-TYPE", dumpfile); + + if (attr->sequence) + fputs (" SEQUENCE", dumpfile); + if (attr->alloc_comp) + fputs (" ALLOC-COMP", dumpfile); + if (attr->pointer_comp) + fputs (" POINTER-COMP", dumpfile); + if (attr->proc_pointer_comp) + fputs (" PROC-POINTER-COMP", dumpfile); + if (attr->private_comp) + fputs (" PRIVATE-COMP", dumpfile); + if (attr->zero_comp) + fputs (" ZERO-COMP", dumpfile); + if (attr->coarray_comp) + fputs (" COARRAY-COMP", dumpfile); + if (attr->lock_comp) + fputs (" LOCK-COMP", dumpfile); + if (attr->event_comp) + fputs (" EVENT-COMP", dumpfile); + if (attr->defined_assign_comp) + fputs (" DEFINED-ASSIGNED-COMP", dumpfile); + if (attr->unlimited_polymorphic) + fputs (" UNLIMITED-POLYMORPHIC", dumpfile); + if (attr->has_dtio_procs) + fputs (" HAS-DTIO-PROCS", dumpfile); + if (attr->caf_token) + fputs (" CAF-TOKEN", dumpfile); + if (attr->select_type_temporary) + fputs (" SELECT-TYPE-TEMPORARY", dumpfile); + if (attr->associate_var) + fputs (" ASSOCIATE-VAR", dumpfile); + if (attr->pdt_kind) + fputs (" PDT-KIND", dumpfile); + if (attr->pdt_len) + fputs (" PDT-LEN", dumpfile); + if (attr->pdt_type) + fputs (" PDT-TYPE", dumpfile); + if (attr->pdt_array) + fputs (" PDT-ARRAY", dumpfile); + if (attr->pdt_string) + fputs (" PDT-STRING", dumpfile); + if (attr->omp_udr_artificial_var) + fputs (" OMP-UDT-ARTIFICIAL-VAR", dumpfile); + if (attr->omp_declare_target) + fputs (" OMP-DECLARE-TARGET", dumpfile); + if (attr->omp_declare_target_link) + fputs (" OMP-DECLARE-TARGET-LINK", dumpfile); + if (attr->elemental) + fputs (" ELEMENTAL", dumpfile); + if (attr->pure) + fputs (" PURE", dumpfile); + if (attr->implicit_pure) + fputs (" IMPLICIT-PURE", dumpfile); + if (attr->recursive) + fputs (" RECURSIVE", dumpfile); + if (attr->unmaskable) + fputs (" UNMASKABKE", dumpfile); + if (attr->masked) + fputs (" MASKED", dumpfile); + if (attr->contained) + fputs (" CONTAINED", dumpfile); + if (attr->mod_proc) + fputs (" MOD-PROC", dumpfile); + if (attr->module_procedure) + fputs (" MODULE-PROCEDURE", dumpfile); + if (attr->public_used) + fputs (" PUBLIC_USED", dumpfile); + if (attr->array_outer_dependency) + fputs (" ARRAY-OUTER-DEPENDENCY", dumpfile); + if (attr->noreturn) + fputs (" NORETURN", dumpfile); + if (attr->always_explicit) + fputs (" ALWAYS-EXPLICIT", dumpfile); + if (attr->is_main_program) + fputs (" IS-MAIN-PROGRAM", dumpfile); + if (attr->oacc_routine_nohost) + fputs (" OACC-ROUTINE-NOHOST", dumpfile); + + /* FIXME: Still missing are oacc_routine_lop and ext_attr. */ + fputc (')', dumpfile); +} + + +/* Show components of a derived type. */ + +static void +show_components (gfc_symbol *sym) +{ + gfc_component *c; + + for (c = sym->components; c; c = c->next) + { + show_indent (); + fprintf (dumpfile, "(%s ", c->name); + show_typespec (&c->ts); + if (c->kind_expr) + { + fputs (" kind_expr: ", dumpfile); + show_expr (c->kind_expr); + } + if (c->param_list) + { + fputs ("PDT parameters", dumpfile); + show_actual_arglist (c->param_list); + } + + if (c->attr.allocatable) + fputs (" ALLOCATABLE", dumpfile); + if (c->attr.pdt_kind) + fputs (" KIND", dumpfile); + if (c->attr.pdt_len) + fputs (" LEN", dumpfile); + if (c->attr.pointer) + fputs (" POINTER", dumpfile); + if (c->attr.proc_pointer) + fputs (" PPC", dumpfile); + if (c->attr.dimension) + fputs (" DIMENSION", dumpfile); + fputc (' ', dumpfile); + show_array_spec (c->as); + if (c->attr.access) + fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access)); + fputc (')', dumpfile); + if (c->next != NULL) + fputc (' ', dumpfile); + } +} + + +/* Show the f2k_derived namespace with procedure bindings. */ + +static void +show_typebound_proc (gfc_typebound_proc* tb, const char* name) +{ + show_indent (); + + if (tb->is_generic) + fputs ("GENERIC", dumpfile); + else + { + fputs ("PROCEDURE, ", dumpfile); + if (tb->nopass) + fputs ("NOPASS", dumpfile); + else + { + if (tb->pass_arg) + fprintf (dumpfile, "PASS(%s)", tb->pass_arg); + else + fputs ("PASS", dumpfile); + } + if (tb->non_overridable) + fputs (", NON_OVERRIDABLE", dumpfile); + } + + if (tb->access == ACCESS_PUBLIC) + fputs (", PUBLIC", dumpfile); + else + fputs (", PRIVATE", dumpfile); + + fprintf (dumpfile, " :: %s => ", name); + + if (tb->is_generic) + { + gfc_tbp_generic* g; + for (g = tb->u.generic; g; g = g->next) + { + fputs (g->specific_st->name, dumpfile); + if (g->next) + fputs (", ", dumpfile); + } + } + else + fputs (tb->u.specific->n.sym->name, dumpfile); +} + +static void +show_typebound_symtree (gfc_symtree* st) +{ + gcc_assert (st->n.tb); + show_typebound_proc (st->n.tb, st->name); +} + +static void +show_f2k_derived (gfc_namespace* f2k) +{ + gfc_finalizer* f; + int op; + + show_indent (); + fputs ("Procedure bindings:", dumpfile); + ++show_level; + + /* Finalizer bindings. */ + for (f = f2k->finalizers; f; f = f->next) + { + show_indent (); + fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name); + } + + /* Type-bound procedures. */ + gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree); + + --show_level; + + show_indent (); + fputs ("Operator bindings:", dumpfile); + ++show_level; + + /* User-defined operators. */ + gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree); + + /* Intrinsic operators. */ + for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) + if (f2k->tb_op[op]) + show_typebound_proc (f2k->tb_op[op], + gfc_op2string ((gfc_intrinsic_op) op)); + + --show_level; +} + + +/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we + show the interface. Information needed to reconstruct the list of + specific interfaces associated with a generic symbol is done within + that symbol. */ + +static void +show_symbol (gfc_symbol *sym) +{ + gfc_formal_arglist *formal; + gfc_interface *intr; + int i,len; + + if (sym == NULL) + return; + + fprintf (dumpfile, "|| symbol: '%s' ", sym->name); + len = strlen (sym->name); + for (i=len; i<12; i++) + fputc(' ', dumpfile); + + if (sym->binding_label) + fprintf (dumpfile,"|| binding_label: '%s' ", sym->binding_label); + + ++show_level; + + show_indent (); + fputs ("type spec : ", dumpfile); + show_typespec (&sym->ts); + + show_indent (); + fputs ("attributes: ", dumpfile); + show_attr (&sym->attr, sym->module); + + if (sym->value) + { + show_indent (); + fputs ("value: ", dumpfile); + show_expr (sym->value); + } + + if (sym->ts.type != BT_CLASS && sym->as) + { + show_indent (); + fputs ("Array spec:", dumpfile); + show_array_spec (sym->as); + } + else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) + { + show_indent (); + fputs ("Array spec:", dumpfile); + show_array_spec (CLASS_DATA (sym)->as); + } + + if (sym->generic) + { + show_indent (); + fputs ("Generic interfaces:", dumpfile); + for (intr = sym->generic; intr; intr = intr->next) + fprintf (dumpfile, " %s", intr->sym->name); + } + + if (sym->result) + { + show_indent (); + fprintf (dumpfile, "result: %s", sym->result->name); + } + + if (sym->components) + { + show_indent (); + fputs ("components: ", dumpfile); + show_components (sym); + } + + if (sym->f2k_derived) + { + show_indent (); + if (sym->hash_value) + fprintf (dumpfile, "hash: %d", sym->hash_value); + show_f2k_derived (sym->f2k_derived); + } + + if (sym->formal) + { + show_indent (); + fputs ("Formal arglist:", dumpfile); + + for (formal = sym->formal; formal; formal = formal->next) + { + if (formal->sym != NULL) + fprintf (dumpfile, " %s", formal->sym->name); + else + fputs (" [Alt Return]", dumpfile); + } + } + + if (sym->formal_ns && (sym->formal_ns->proc_name != sym) + && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.entry) + { + show_indent (); + fputs ("Formal namespace", dumpfile); + show_namespace (sym->formal_ns); + } + + if (sym->attr.flavor == FL_VARIABLE + && sym->param_list) + { + show_indent (); + fputs ("PDT parameters", dumpfile); + show_actual_arglist (sym->param_list); + } + + if (sym->attr.flavor == FL_NAMELIST) + { + gfc_namelist *nl; + show_indent (); + fputs ("variables : ", dumpfile); + for (nl = sym->namelist; nl; nl = nl->next) + fprintf (dumpfile, " %s",nl->sym->name); + } + + --show_level; +} + + +/* Show a user-defined operator. Just prints an operator + and the name of the associated subroutine, really. */ + +static void +show_uop (gfc_user_op *uop) +{ + gfc_interface *intr; + + show_indent (); + fprintf (dumpfile, "%s:", uop->name); + + for (intr = uop->op; intr; intr = intr->next) + fprintf (dumpfile, " %s", intr->sym->name); +} + + +/* Workhorse function for traversing the user operator symtree. */ + +static void +traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *)) +{ + if (st == NULL) + return; + + (*func) (st->n.uop); + + traverse_uop (st->left, func); + traverse_uop (st->right, func); +} + + +/* Traverse the tree of user operator nodes. */ + +void +gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *)) +{ + traverse_uop (ns->uop_root, func); +} + + +/* Function to display a common block. */ + +static void +show_common (gfc_symtree *st) +{ + gfc_symbol *s; + + show_indent (); + fprintf (dumpfile, "common: /%s/ ", st->name); + + s = st->n.common->head; + while (s) + { + fprintf (dumpfile, "%s", s->name); + s = s->common_next; + if (s) + fputs (", ", dumpfile); + } + fputc ('\n', dumpfile); +} + + +/* Worker function to display the symbol tree. */ + +static void +show_symtree (gfc_symtree *st) +{ + int len, i; + + show_indent (); + + len = strlen(st->name); + fprintf (dumpfile, "symtree: '%s'", st->name); + + for (i=len; i<12; i++) + fputc(' ', dumpfile); + + if (st->ambiguous) + fputs( " Ambiguous", dumpfile); + + if (st->n.sym->ns != gfc_current_ns) + fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name, + st->n.sym->ns->proc_name->name); + else + show_symbol (st->n.sym); +} + + +/******************* Show gfc_code structures **************/ + + +/* Show a list of code structures. Mutually recursive with + show_code_node(). */ + +static void +show_code (int level, gfc_code *c) +{ + for (; c; c = c->next) + show_code_node (level, c); +} + +static void +show_iterator (gfc_namespace *ns) +{ + for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + { + gfc_constructor *c; + if (sym != ns->proc_name) + fputc (',', dumpfile); + fputs (sym->name, dumpfile); + fputc ('=', dumpfile); + c = gfc_constructor_first (sym->value->value.constructor); + show_expr (c->expr); + fputc (':', dumpfile); + c = gfc_constructor_next (c); + show_expr (c->expr); + c = gfc_constructor_next (c); + if (c) + { + fputc (':', dumpfile); + show_expr (c->expr); + } + } +} + +static void +show_omp_namelist (int list_type, gfc_omp_namelist *n) +{ + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + gfc_omp_namelist *n2 = n; + for (; n; n = n->next) + { + gfc_current_ns = ns_curr; + if (list_type == OMP_LIST_AFFINITY || list_type == OMP_LIST_DEPEND) + { + gfc_current_ns = n->u2.ns ? n->u2.ns : ns_curr; + if (n->u2.ns != ns_iter) + { + if (n != n2) + fputs (list_type == OMP_LIST_AFFINITY + ? ") AFFINITY(" : ") DEPEND(", dumpfile); + if (n->u2.ns) + { + fputs ("ITERATOR(", dumpfile); + show_iterator (n->u2.ns); + fputc (')', dumpfile); + fputc (list_type == OMP_LIST_AFFINITY ? ':' : ',', dumpfile); + } + } + ns_iter = n->u2.ns; + } + if (list_type == OMP_LIST_REDUCTION) + switch (n->u.reduction_op) + { + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_TIMES: + case OMP_REDUCTION_MINUS: + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + fprintf (dumpfile, "%s:", + gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op)); + break; + case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break; + case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break; + case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break; + case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break; + case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break; + case OMP_REDUCTION_USER: + if (n->u2.udr) + fprintf (dumpfile, "%s:", n->u2.udr->udr->name); + break; + default: break; + } + else if (list_type == OMP_LIST_DEPEND) + switch (n->u.depend_op) + { + case OMP_DEPEND_IN: fputs ("in:", dumpfile); break; + case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break; + case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break; + case OMP_DEPEND_DEPOBJ: fputs ("depobj:", dumpfile); break; + case OMP_DEPEND_MUTEXINOUTSET: + fputs ("mutexinoutset:", dumpfile); + break; + case OMP_DEPEND_SINK_FIRST: + fputs ("sink:", dumpfile); + while (1) + { + fprintf (dumpfile, "%s", n->sym->name); + if (n->expr) + { + fputc ('+', dumpfile); + show_expr (n->expr); + } + if (n->next == NULL) + break; + else if (n->next->u.depend_op != OMP_DEPEND_SINK) + { + fputs (") DEPEND(", dumpfile); + break; + } + fputc (',', dumpfile); + n = n->next; + } + continue; + default: break; + } + else if (list_type == OMP_LIST_MAP) + switch (n->u.map_op) + { + case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break; + case OMP_MAP_TO: fputs ("to:", dumpfile); break; + case OMP_MAP_FROM: fputs ("from:", dumpfile); break; + case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break; + default: break; + } + else if (list_type == OMP_LIST_LINEAR) + switch (n->u.linear_op) + { + case OMP_LINEAR_REF: fputs ("ref(", dumpfile); break; + case OMP_LINEAR_VAL: fputs ("val(", dumpfile); break; + case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break; + default: break; + } + fprintf (dumpfile, "%s", n->sym->name); + if (list_type == OMP_LIST_LINEAR && n->u.linear_op != OMP_LINEAR_DEFAULT) + fputc (')', dumpfile); + if (n->expr) + { + fputc (':', dumpfile); + show_expr (n->expr); + } + if (n->next) + fputc (',', dumpfile); + } + gfc_current_ns = ns_curr; +} + + +/* Show OpenMP or OpenACC clauses. */ + +static void +show_omp_clauses (gfc_omp_clauses *omp_clauses) +{ + int list_type, i; + + switch (omp_clauses->cancel) + { + case OMP_CANCEL_UNKNOWN: + break; + case OMP_CANCEL_PARALLEL: + fputs (" PARALLEL", dumpfile); + break; + case OMP_CANCEL_SECTIONS: + fputs (" SECTIONS", dumpfile); + break; + case OMP_CANCEL_DO: + fputs (" DO", dumpfile); + break; + case OMP_CANCEL_TASKGROUP: + fputs (" TASKGROUP", dumpfile); + break; + } + if (omp_clauses->if_expr) + { + fputs (" IF(", dumpfile); + show_expr (omp_clauses->if_expr); + fputc (')', dumpfile); + } + if (omp_clauses->final_expr) + { + fputs (" FINAL(", dumpfile); + show_expr (omp_clauses->final_expr); + fputc (')', dumpfile); + } + if (omp_clauses->num_threads) + { + fputs (" NUM_THREADS(", dumpfile); + show_expr (omp_clauses->num_threads); + fputc (')', dumpfile); + } + if (omp_clauses->async) + { + fputs (" ASYNC", dumpfile); + if (omp_clauses->async_expr) + { + fputc ('(', dumpfile); + show_expr (omp_clauses->async_expr); + fputc (')', dumpfile); + } + } + if (omp_clauses->num_gangs_expr) + { + fputs (" NUM_GANGS(", dumpfile); + show_expr (omp_clauses->num_gangs_expr); + fputc (')', dumpfile); + } + if (omp_clauses->num_workers_expr) + { + fputs (" NUM_WORKERS(", dumpfile); + show_expr (omp_clauses->num_workers_expr); + fputc (')', dumpfile); + } + if (omp_clauses->vector_length_expr) + { + fputs (" VECTOR_LENGTH(", dumpfile); + show_expr (omp_clauses->vector_length_expr); + fputc (')', dumpfile); + } + if (omp_clauses->gang) + { + fputs (" GANG", dumpfile); + if (omp_clauses->gang_num_expr || omp_clauses->gang_static_expr) + { + fputc ('(', dumpfile); + if (omp_clauses->gang_num_expr) + { + fprintf (dumpfile, "num:"); + show_expr (omp_clauses->gang_num_expr); + } + if (omp_clauses->gang_num_expr && omp_clauses->gang_static) + fputc (',', dumpfile); + if (omp_clauses->gang_static) + { + fprintf (dumpfile, "static:"); + if (omp_clauses->gang_static_expr) + show_expr (omp_clauses->gang_static_expr); + else + fputc ('*', dumpfile); + } + fputc (')', dumpfile); + } + } + if (omp_clauses->worker) + { + fputs (" WORKER", dumpfile); + if (omp_clauses->worker_expr) + { + fputc ('(', dumpfile); + show_expr (omp_clauses->worker_expr); + fputc (')', dumpfile); + } + } + if (omp_clauses->vector) + { + fputs (" VECTOR", dumpfile); + if (omp_clauses->vector_expr) + { + fputc ('(', dumpfile); + show_expr (omp_clauses->vector_expr); + fputc (')', dumpfile); + } + } + if (omp_clauses->sched_kind != OMP_SCHED_NONE) + { + const char *type; + switch (omp_clauses->sched_kind) + { + case OMP_SCHED_STATIC: type = "STATIC"; break; + case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break; + case OMP_SCHED_GUIDED: type = "GUIDED"; break; + case OMP_SCHED_RUNTIME: type = "RUNTIME"; break; + case OMP_SCHED_AUTO: type = "AUTO"; break; + default: + gcc_unreachable (); + } + fputs (" SCHEDULE (", dumpfile); + if (omp_clauses->sched_simd) + { + if (omp_clauses->sched_monotonic + || omp_clauses->sched_nonmonotonic) + fputs ("SIMD, ", dumpfile); + else + fputs ("SIMD: ", dumpfile); + } + if (omp_clauses->sched_monotonic) + fputs ("MONOTONIC: ", dumpfile); + else if (omp_clauses->sched_nonmonotonic) + fputs ("NONMONOTONIC: ", dumpfile); + fputs (type, dumpfile); + if (omp_clauses->chunk_size) + { + fputc (',', dumpfile); + show_expr (omp_clauses->chunk_size); + } + fputc (')', dumpfile); + } + if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN) + { + const char *type; + switch (omp_clauses->default_sharing) + { + case OMP_DEFAULT_NONE: type = "NONE"; break; + case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break; + case OMP_DEFAULT_SHARED: type = "SHARED"; break; + case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; + case OMP_DEFAULT_PRESENT: type = "PRESENT"; break; + default: + gcc_unreachable (); + } + fprintf (dumpfile, " DEFAULT(%s)", type); + } + if (omp_clauses->tile_list) + { + gfc_expr_list *list; + fputs (" TILE(", dumpfile); + for (list = omp_clauses->tile_list; list; list = list->next) + { + show_expr (list->expr); + if (list->next) + fputs (", ", dumpfile); + } + fputc (')', dumpfile); + } + if (omp_clauses->wait_list) + { + gfc_expr_list *list; + fputs (" WAIT(", dumpfile); + for (list = omp_clauses->wait_list; list; list = list->next) + { + show_expr (list->expr); + if (list->next) + fputs (", ", dumpfile); + } + fputc (')', dumpfile); + } + if (omp_clauses->seq) + fputs (" SEQ", dumpfile); + if (omp_clauses->independent) + fputs (" INDEPENDENT", dumpfile); + if (omp_clauses->order_concurrent) + { + fputs (" ORDER(", dumpfile); + if (omp_clauses->order_unconstrained) + fputs ("UNCONSTRAINED:", dumpfile); + else if (omp_clauses->order_reproducible) + fputs ("REPRODUCIBLE:", dumpfile); + fputs ("CONCURRENT)", dumpfile); + } + if (omp_clauses->ordered) + { + if (omp_clauses->orderedc) + fprintf (dumpfile, " ORDERED(%d)", omp_clauses->orderedc); + else + fputs (" ORDERED", dumpfile); + } + if (omp_clauses->untied) + fputs (" UNTIED", dumpfile); + if (omp_clauses->mergeable) + fputs (" MERGEABLE", dumpfile); + if (omp_clauses->collapse) + fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse); + for (list_type = 0; list_type < OMP_LIST_NUM; list_type++) + if (omp_clauses->lists[list_type] != NULL + && list_type != OMP_LIST_COPYPRIVATE) + { + const char *type = NULL; + switch (list_type) + { + case OMP_LIST_PRIVATE: type = "PRIVATE"; break; + case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break; + case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break; + case OMP_LIST_COPYPRIVATE: type = "COPYPRIVATE"; break; + case OMP_LIST_SHARED: type = "SHARED"; break; + case OMP_LIST_COPYIN: type = "COPYIN"; break; + case OMP_LIST_UNIFORM: type = "UNIFORM"; break; + case OMP_LIST_AFFINITY: type = "AFFINITY"; break; + case OMP_LIST_ALIGNED: type = "ALIGNED"; break; + case OMP_LIST_LINEAR: type = "LINEAR"; break; + case OMP_LIST_DEPEND: type = "DEPEND"; break; + case OMP_LIST_MAP: type = "MAP"; break; + case OMP_LIST_TO: type = "TO"; break; + case OMP_LIST_FROM: type = "FROM"; break; + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: type = "REDUCTION"; break; + case OMP_LIST_IN_REDUCTION: type = "IN_REDUCTION"; break; + case OMP_LIST_TASK_REDUCTION: type = "TASK_REDUCTION"; break; + case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break; + case OMP_LIST_LINK: type = "LINK"; break; + case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break; + case OMP_LIST_CACHE: type = "CACHE"; break; + case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break; + case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break; + case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break; + case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break; + case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break; + case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break; + case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break; + default: + gcc_unreachable (); + } + fprintf (dumpfile, " %s(", type); + if (list_type == OMP_LIST_REDUCTION_INSCAN) + fputs ("inscan, ", dumpfile); + if (list_type == OMP_LIST_REDUCTION_TASK) + fputs ("task, ", dumpfile); + show_omp_namelist (list_type, omp_clauses->lists[list_type]); + fputc (')', dumpfile); + } + if (omp_clauses->safelen_expr) + { + fputs (" SAFELEN(", dumpfile); + show_expr (omp_clauses->safelen_expr); + fputc (')', dumpfile); + } + if (omp_clauses->simdlen_expr) + { + fputs (" SIMDLEN(", dumpfile); + show_expr (omp_clauses->simdlen_expr); + fputc (')', dumpfile); + } + if (omp_clauses->inbranch) + fputs (" INBRANCH", dumpfile); + if (omp_clauses->notinbranch) + fputs (" NOTINBRANCH", dumpfile); + if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) + { + const char *type; + switch (omp_clauses->proc_bind) + { + case OMP_PROC_BIND_PRIMARY: type = "PRIMARY"; break; + case OMP_PROC_BIND_MASTER: type = "MASTER"; break; + case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break; + case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break; + default: + gcc_unreachable (); + } + fprintf (dumpfile, " PROC_BIND(%s)", type); + } + if (omp_clauses->bind != OMP_BIND_UNSET) + { + const char *type; + switch (omp_clauses->bind) + { + case OMP_BIND_TEAMS: type = "TEAMS"; break; + case OMP_BIND_PARALLEL: type = "PARALLEL"; break; + case OMP_BIND_THREAD: type = "THREAD"; break; + default: + gcc_unreachable (); + } + fprintf (dumpfile, " BIND(%s)", type); + } + if (omp_clauses->num_teams_upper) + { + fputs (" NUM_TEAMS(", dumpfile); + if (omp_clauses->num_teams_lower) + { + show_expr (omp_clauses->num_teams_lower); + fputc (':', dumpfile); + } + show_expr (omp_clauses->num_teams_upper); + fputc (')', dumpfile); + } + if (omp_clauses->device) + { + fputs (" DEVICE(", dumpfile); + if (omp_clauses->ancestor) + fputs ("ANCESTOR:", dumpfile); + show_expr (omp_clauses->device); + fputc (')', dumpfile); + } + if (omp_clauses->thread_limit) + { + fputs (" THREAD_LIMIT(", dumpfile); + show_expr (omp_clauses->thread_limit); + fputc (')', dumpfile); + } + if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE) + { + fputs (" DIST_SCHEDULE (STATIC", dumpfile); + if (omp_clauses->dist_chunk_size) + { + fputc (',', dumpfile); + show_expr (omp_clauses->dist_chunk_size); + } + fputc (')', dumpfile); + } + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) + { + const char *dfltmap; + if (omp_clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) + continue; + fputs (" DEFAULTMAP (", dumpfile); + switch (omp_clauses->defaultmap[i]) + { + case OMP_DEFAULTMAP_ALLOC: dfltmap = "ALLOC"; break; + case OMP_DEFAULTMAP_TO: dfltmap = "TO"; break; + case OMP_DEFAULTMAP_FROM: dfltmap = "FROM"; break; + case OMP_DEFAULTMAP_TOFROM: dfltmap = "TOFROM"; break; + case OMP_DEFAULTMAP_FIRSTPRIVATE: dfltmap = "FIRSTPRIVATE"; break; + case OMP_DEFAULTMAP_NONE: dfltmap = "NONE"; break; + case OMP_DEFAULTMAP_DEFAULT: dfltmap = "DEFAULT"; break; + case OMP_DEFAULTMAP_PRESENT: dfltmap = "PRESENT"; break; + default: gcc_unreachable (); + } + fputs (dfltmap, dumpfile); + if (i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED) + { + fputc (':', dumpfile); + switch ((enum gfc_omp_defaultmap_category) i) + { + case OMP_DEFAULTMAP_CAT_SCALAR: dfltmap = "SCALAR"; break; + case OMP_DEFAULTMAP_CAT_AGGREGATE: dfltmap = "AGGREGATE"; break; + case OMP_DEFAULTMAP_CAT_ALLOCATABLE: dfltmap = "ALLOCATABLE"; break; + case OMP_DEFAULTMAP_CAT_POINTER: dfltmap = "POINTER"; break; + default: gcc_unreachable (); + } + fputs (dfltmap, dumpfile); + } + fputc (')', dumpfile); + } + if (omp_clauses->weak) + fputs (" WEAK", dumpfile); + if (omp_clauses->compare) + fputs (" COMPARE", dumpfile); + if (omp_clauses->nogroup) + fputs (" NOGROUP", dumpfile); + if (omp_clauses->simd) + fputs (" SIMD", dumpfile); + if (omp_clauses->threads) + fputs (" THREADS", dumpfile); + if (omp_clauses->grainsize) + { + fputs (" GRAINSIZE(", dumpfile); + if (omp_clauses->grainsize_strict) + fputs ("strict: ", dumpfile); + show_expr (omp_clauses->grainsize); + fputc (')', dumpfile); + } + if (omp_clauses->filter) + { + fputs (" FILTER(", dumpfile); + show_expr (omp_clauses->filter); + fputc (')', dumpfile); + } + if (omp_clauses->hint) + { + fputs (" HINT(", dumpfile); + show_expr (omp_clauses->hint); + fputc (')', dumpfile); + } + if (omp_clauses->num_tasks) + { + fputs (" NUM_TASKS(", dumpfile); + if (omp_clauses->num_tasks_strict) + fputs ("strict: ", dumpfile); + show_expr (omp_clauses->num_tasks); + fputc (')', dumpfile); + } + if (omp_clauses->priority) + { + fputs (" PRIORITY(", dumpfile); + show_expr (omp_clauses->priority); + fputc (')', dumpfile); + } + if (omp_clauses->detach) + { + fputs (" DETACH(", dumpfile); + show_expr (omp_clauses->detach); + fputc (')', dumpfile); + } + for (i = 0; i < OMP_IF_LAST; i++) + if (omp_clauses->if_exprs[i]) + { + static const char *ifs[] = { + "CANCEL", + "PARALLEL", + "SIMD", + "TASK", + "TASKLOOP", + "TARGET", + "TARGET DATA", + "TARGET UPDATE", + "TARGET ENTER DATA", + "TARGET EXIT DATA" + }; + fputs (" IF(", dumpfile); + fputs (ifs[i], dumpfile); + fputs (": ", dumpfile); + show_expr (omp_clauses->if_exprs[i]); + fputc (')', dumpfile); + } + if (omp_clauses->destroy) + fputs (" DESTROY", dumpfile); + if (omp_clauses->depend_source) + fputs (" DEPEND(source)", dumpfile); + if (omp_clauses->capture) + fputs (" CAPTURE", dumpfile); + if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) + { + const char *deptype; + fputs (" UPDATE(", dumpfile); + switch (omp_clauses->depobj_update) + { + case OMP_DEPEND_IN: deptype = "IN"; break; + case OMP_DEPEND_OUT: deptype = "OUT"; break; + case OMP_DEPEND_INOUT: deptype = "INOUT"; break; + case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break; + default: gcc_unreachable (); + } + fputs (deptype, dumpfile); + fputc (')', dumpfile); + } + if (omp_clauses->atomic_op != GFC_OMP_ATOMIC_UNSET) + { + const char *atomic_op; + switch (omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) + { + case GFC_OMP_ATOMIC_READ: atomic_op = "READ"; break; + case GFC_OMP_ATOMIC_WRITE: atomic_op = "WRITE"; break; + case GFC_OMP_ATOMIC_UPDATE: atomic_op = "UPDATE"; break; + default: gcc_unreachable (); + } + fputc (' ', dumpfile); + fputs (atomic_op, dumpfile); + } + if (omp_clauses->memorder != OMP_MEMORDER_UNSET) + { + const char *memorder; + switch (omp_clauses->memorder) + { + case OMP_MEMORDER_ACQ_REL: memorder = "ACQ_REL"; break; + case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break; + case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break; + case OMP_MEMORDER_RELEASE: memorder = "RELEASE"; break; + case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break; + default: gcc_unreachable (); + } + fputc (' ', dumpfile); + fputs (memorder, dumpfile); + } + if (omp_clauses->fail != OMP_MEMORDER_UNSET) + { + const char *memorder; + switch (omp_clauses->fail) + { + case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break; + case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break; + case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break; + default: gcc_unreachable (); + } + fputs (" FAIL(", dumpfile); + fputs (memorder, dumpfile); + putc (')', dumpfile); + } + if (omp_clauses->at != OMP_AT_UNSET) + { + if (omp_clauses->at != OMP_AT_COMPILATION) + fputs (" AT (COMPILATION)", dumpfile); + else + fputs (" AT (EXECUTION)", dumpfile); + } + if (omp_clauses->severity != OMP_SEVERITY_UNSET) + { + if (omp_clauses->severity != OMP_SEVERITY_FATAL) + fputs (" SEVERITY (FATAL)", dumpfile); + else + fputs (" SEVERITY (WARNING)", dumpfile); + } + if (omp_clauses->message) + { + fputs (" ERROR (", dumpfile); + show_expr (omp_clauses->message); + fputc (')', dumpfile); + } +} + +/* Show a single OpenMP or OpenACC directive node and everything underneath it + if necessary. */ + +static void +show_omp_node (int level, gfc_code *c) +{ + gfc_omp_clauses *omp_clauses = NULL; + const char *name = NULL; + bool is_oacc = false; + + switch (c->op) + { + case EXEC_OACC_PARALLEL_LOOP: + name = "PARALLEL LOOP"; is_oacc = true; break; + case EXEC_OACC_PARALLEL: name = "PARALLEL"; is_oacc = true; break; + case EXEC_OACC_KERNELS_LOOP: name = "KERNELS LOOP"; is_oacc = true; break; + case EXEC_OACC_KERNELS: name = "KERNELS"; is_oacc = true; break; + case EXEC_OACC_SERIAL_LOOP: name = "SERIAL LOOP"; is_oacc = true; break; + case EXEC_OACC_SERIAL: name = "SERIAL"; is_oacc = true; break; + case EXEC_OACC_DATA: name = "DATA"; is_oacc = true; break; + case EXEC_OACC_HOST_DATA: name = "HOST_DATA"; is_oacc = true; break; + case EXEC_OACC_LOOP: name = "LOOP"; is_oacc = true; break; + case EXEC_OACC_UPDATE: name = "UPDATE"; is_oacc = true; break; + case EXEC_OACC_WAIT: name = "WAIT"; is_oacc = true; break; + case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break; + case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break; + case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break; + case EXEC_OMP_ATOMIC: name = "ATOMIC"; break; + case EXEC_OMP_BARRIER: name = "BARRIER"; break; + case EXEC_OMP_CANCEL: name = "CANCEL"; break; + case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break; + case EXEC_OMP_CRITICAL: name = "CRITICAL"; break; + case EXEC_OMP_DISTRIBUTE: name = "DISTRIBUTE"; break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + name = "DISTRIBUTE PARALLEL DO"; break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + name = "DISTRIBUTE PARALLEL DO SIMD"; break; + case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break; + case EXEC_OMP_DO: name = "DO"; break; + case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break; + case EXEC_OMP_ERROR: name = "ERROR"; break; + case EXEC_OMP_FLUSH: name = "FLUSH"; break; + case EXEC_OMP_LOOP: name = "LOOP"; break; + case EXEC_OMP_MASKED: name = "MASKED"; break; + case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break; + case EXEC_OMP_MASTER: name = "MASTER"; break; + case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break; + case EXEC_OMP_ORDERED: name = "ORDERED"; break; + case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break; + case EXEC_OMP_PARALLEL: name = "PARALLEL"; break; + case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break; + case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break; + case EXEC_OMP_PARALLEL_LOOP: name = "PARALLEL LOOP"; break; + case EXEC_OMP_PARALLEL_MASTER: name = "PARALLEL MASTER"; break; + case EXEC_OMP_PARALLEL_MASKED: name = "PARALLEL MASK"; break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + name = "PARALLEL MASK TASKLOOP"; break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + name = "PARALLEL MASK TASKLOOP SIMD"; break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + name = "PARALLEL MASTER TASKLOOP"; break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + name = "PARALLEL MASTER TASKLOOP SIMD"; break; + case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break; + case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break; + case EXEC_OMP_SCAN: name = "SCAN"; break; + case EXEC_OMP_SCOPE: name = "SCOPE"; break; + case EXEC_OMP_SECTIONS: name = "SECTIONS"; break; + case EXEC_OMP_SIMD: name = "SIMD"; break; + case EXEC_OMP_SINGLE: name = "SINGLE"; break; + case EXEC_OMP_TARGET: name = "TARGET"; break; + case EXEC_OMP_TARGET_DATA: name = "TARGET DATA"; break; + case EXEC_OMP_TARGET_ENTER_DATA: name = "TARGET ENTER DATA"; break; + case EXEC_OMP_TARGET_EXIT_DATA: name = "TARGET EXIT DATA"; break; + case EXEC_OMP_TARGET_PARALLEL: name = "TARGET PARALLEL"; break; + case EXEC_OMP_TARGET_PARALLEL_DO: name = "TARGET PARALLEL DO"; break; + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + name = "TARGET_PARALLEL_DO_SIMD"; break; + case EXEC_OMP_TARGET_PARALLEL_LOOP: name = "TARGET PARALLEL LOOP"; break; + case EXEC_OMP_TARGET_SIMD: name = "TARGET SIMD"; break; + case EXEC_OMP_TARGET_TEAMS: name = "TARGET TEAMS"; break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + name = "TARGET TEAMS DISTRIBUTE"; break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + name = "TARGET TEAMS DISTRIBUTE PARALLEL DO"; break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + name = "TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + name = "TARGET TEAMS DISTRIBUTE SIMD"; break; + case EXEC_OMP_TARGET_TEAMS_LOOP: name = "TARGET TEAMS LOOP"; break; + case EXEC_OMP_TARGET_UPDATE: name = "TARGET UPDATE"; break; + case EXEC_OMP_TASK: name = "TASK"; break; + case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break; + case EXEC_OMP_TASKLOOP: name = "TASKLOOP"; break; + case EXEC_OMP_TASKLOOP_SIMD: name = "TASKLOOP SIMD"; break; + case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break; + case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break; + case EXEC_OMP_TEAMS: name = "TEAMS"; break; + case EXEC_OMP_TEAMS_DISTRIBUTE: name = "TEAMS DISTRIBUTE"; break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + name = "TEAMS DISTRIBUTE PARALLEL DO"; break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + name = "TEAMS DISTRIBUTE PARALLEL DO SIMD"; break; + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: name = "TEAMS DISTRIBUTE SIMD"; break; + case EXEC_OMP_TEAMS_LOOP: name = "TEAMS LOOP"; break; + case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break; + default: + gcc_unreachable (); + } + fprintf (dumpfile, "!$%s %s", is_oacc ? "ACC" : "OMP", name); + switch (c->op) + { + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_LOOP: + case EXEC_OACC_UPDATE: + case EXEC_OACC_WAIT: + case EXEC_OACC_CACHE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OMP_CANCEL: + case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: + case EXEC_OMP_ORDERED: + case EXEC_OMP_MASKED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SIMD: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_WORKSHARE: + omp_clauses = c->ext.omp_clauses; + break; + case EXEC_OMP_CRITICAL: + omp_clauses = c->ext.omp_clauses; + if (omp_clauses) + fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); + break; + case EXEC_OMP_DEPOBJ: + omp_clauses = c->ext.omp_clauses; + if (omp_clauses) + { + fputc ('(', dumpfile); + show_expr (c->ext.omp_clauses->depobj); + fputc (')', dumpfile); + } + break; + case EXEC_OMP_FLUSH: + if (c->ext.omp_namelist) + { + fputs (" (", dumpfile); + show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist); + fputc (')', dumpfile); + } + return; + case EXEC_OMP_BARRIER: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + return; + case EXEC_OACC_ATOMIC: + case EXEC_OMP_ATOMIC: + omp_clauses = c->block ? c->block->ext.omp_clauses : NULL; + break; + default: + break; + } + if (omp_clauses) + show_omp_clauses (omp_clauses); + fputc ('\n', dumpfile); + + /* OpenMP and OpenACC executable directives don't have associated blocks. */ + if (c->op == EXEC_OACC_CACHE || c->op == EXEC_OACC_UPDATE + || c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA + || c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA + || c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN + || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR + || (c->op == EXEC_OMP_ORDERED && c->block == NULL)) + return; + if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS) + { + gfc_code *d = c->block; + while (d != NULL) + { + show_code (level + 1, d->next); + if (d->block == NULL) + break; + code_indent (level, 0); + fputs ("!$OMP SECTION\n", dumpfile); + d = d->block; + } + } + else + show_code (level + 1, c->block->next); + if (c->op == EXEC_OMP_ATOMIC) + return; + fputc ('\n', dumpfile); + code_indent (level, 0); + fprintf (dumpfile, "!$%s END %s", is_oacc ? "ACC" : "OMP", name); + if (omp_clauses != NULL) + { + if (omp_clauses->lists[OMP_LIST_COPYPRIVATE]) + { + fputs (" COPYPRIVATE(", dumpfile); + show_omp_namelist (OMP_LIST_COPYPRIVATE, + omp_clauses->lists[OMP_LIST_COPYPRIVATE]); + fputc (')', dumpfile); + } + else if (omp_clauses->nowait) + fputs (" NOWAIT", dumpfile); + } + else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_clauses) + fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); +} + + +/* Show a single code node and everything underneath it if necessary. */ + +static void +show_code_node (int level, gfc_code *c) +{ + gfc_forall_iterator *fa; + gfc_open *open; + gfc_case *cp; + gfc_alloc *a; + gfc_code *d; + gfc_close *close; + gfc_filepos *fp; + gfc_inquire *i; + gfc_dt *dt; + gfc_namespace *ns; + + if (c->here) + { + fputc ('\n', dumpfile); + code_indent (level, c->here); + } + else + show_indent (); + + switch (c->op) + { + case EXEC_END_PROCEDURE: + break; + + case EXEC_NOP: + fputs ("NOP", dumpfile); + break; + + case EXEC_CONTINUE: + fputs ("CONTINUE", dumpfile); + break; + + case EXEC_ENTRY: + fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name); + break; + + case EXEC_INIT_ASSIGN: + case EXEC_ASSIGN: + fputs ("ASSIGN ", dumpfile); + show_expr (c->expr1); + fputc (' ', dumpfile); + show_expr (c->expr2); + break; + + case EXEC_LABEL_ASSIGN: + fputs ("LABEL ASSIGN ", dumpfile); + show_expr (c->expr1); + fprintf (dumpfile, " %d", c->label1->value); + break; + + case EXEC_POINTER_ASSIGN: + fputs ("POINTER ASSIGN ", dumpfile); + show_expr (c->expr1); + fputc (' ', dumpfile); + show_expr (c->expr2); + break; + + case EXEC_GOTO: + fputs ("GOTO ", dumpfile); + if (c->label1) + fprintf (dumpfile, "%d", c->label1->value); + else + { + show_expr (c->expr1); + d = c->block; + if (d != NULL) + { + fputs (", (", dumpfile); + for (; d; d = d ->block) + { + code_indent (level, d->label1); + if (d->block != NULL) + fputc (',', dumpfile); + else + fputc (')', dumpfile); + } + } + } + break; + + case EXEC_CALL: + case EXEC_ASSIGN_CALL: + if (c->resolved_sym) + fprintf (dumpfile, "CALL %s ", c->resolved_sym->name); + else if (c->symtree) + fprintf (dumpfile, "CALL %s ", c->symtree->name); + else + fputs ("CALL ?? ", dumpfile); + + show_actual_arglist (c->ext.actual); + break; + + case EXEC_COMPCALL: + fputs ("CALL ", dumpfile); + show_compcall (c->expr1); + break; + + case EXEC_CALL_PPC: + fputs ("CALL ", dumpfile); + show_expr (c->expr1); + show_actual_arglist (c->ext.actual); + break; + + case EXEC_RETURN: + fputs ("RETURN ", dumpfile); + if (c->expr1) + show_expr (c->expr1); + break; + + case EXEC_PAUSE: + fputs ("PAUSE ", dumpfile); + + if (c->expr1 != NULL) + show_expr (c->expr1); + else + fprintf (dumpfile, "%d", c->ext.stop_code); + + break; + + case EXEC_ERROR_STOP: + fputs ("ERROR ", dumpfile); + /* Fall through. */ + + case EXEC_STOP: + fputs ("STOP ", dumpfile); + + if (c->expr1 != NULL) + show_expr (c->expr1); + else + fprintf (dumpfile, "%d", c->ext.stop_code); + + break; + + case EXEC_FAIL_IMAGE: + fputs ("FAIL IMAGE ", dumpfile); + break; + + case EXEC_CHANGE_TEAM: + fputs ("CHANGE TEAM", dumpfile); + break; + + case EXEC_END_TEAM: + fputs ("END TEAM", dumpfile); + break; + + case EXEC_FORM_TEAM: + fputs ("FORM TEAM", dumpfile); + break; + + case EXEC_SYNC_TEAM: + fputs ("SYNC TEAM", dumpfile); + break; + + case EXEC_SYNC_ALL: + fputs ("SYNC ALL ", dumpfile); + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + + case EXEC_SYNC_MEMORY: + fputs ("SYNC MEMORY ", dumpfile); + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + + case EXEC_SYNC_IMAGES: + fputs ("SYNC IMAGES image-set=", dumpfile); + if (c->expr1 != NULL) + show_expr (c->expr1); + else + fputs ("* ", dumpfile); + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + + case EXEC_EVENT_POST: + case EXEC_EVENT_WAIT: + if (c->op == EXEC_EVENT_POST) + fputs ("EVENT POST ", dumpfile); + else + fputs ("EVENT WAIT ", dumpfile); + + fputs ("event-variable=", dumpfile); + if (c->expr1 != NULL) + show_expr (c->expr1); + if (c->expr4 != NULL) + { + fputs (" until_count=", dumpfile); + show_expr (c->expr4); + } + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + + case EXEC_LOCK: + case EXEC_UNLOCK: + if (c->op == EXEC_LOCK) + fputs ("LOCK ", dumpfile); + else + fputs ("UNLOCK ", dumpfile); + + fputs ("lock-variable=", dumpfile); + if (c->expr1 != NULL) + show_expr (c->expr1); + if (c->expr4 != NULL) + { + fputs (" acquired_lock=", dumpfile); + show_expr (c->expr4); + } + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + + case EXEC_ARITHMETIC_IF: + fputs ("IF ", dumpfile); + show_expr (c->expr1); + fprintf (dumpfile, " %d, %d, %d", + c->label1->value, c->label2->value, c->label3->value); + break; + + case EXEC_IF: + d = c->block; + fputs ("IF ", dumpfile); + show_expr (d->expr1); + + ++show_level; + show_code (level + 1, d->next); + --show_level; + + d = d->block; + for (; d; d = d->block) + { + fputs("\n", dumpfile); + code_indent (level, 0); + if (d->expr1 == NULL) + fputs ("ELSE", dumpfile); + else + { + fputs ("ELSE IF ", dumpfile); + show_expr (d->expr1); + } + + ++show_level; + show_code (level + 1, d->next); + --show_level; + } + + if (c->label1) + code_indent (level, c->label1); + else + show_indent (); + + fputs ("ENDIF", dumpfile); + break; + + case EXEC_BLOCK: + { + const char* blocktype; + gfc_namespace *saved_ns; + gfc_association_list *alist; + + if (c->ext.block.assoc) + blocktype = "ASSOCIATE"; + else + blocktype = "BLOCK"; + show_indent (); + fprintf (dumpfile, "%s ", blocktype); + for (alist = c->ext.block.assoc; alist; alist = alist->next) + { + fprintf (dumpfile, " %s = ", alist->name); + show_expr (alist->target); + } + + ++show_level; + ns = c->ext.block.ns; + saved_ns = gfc_current_ns; + gfc_current_ns = ns; + gfc_traverse_symtree (ns->sym_root, show_symtree); + gfc_current_ns = saved_ns; + show_code (show_level, ns->code); + --show_level; + show_indent (); + fprintf (dumpfile, "END %s ", blocktype); + break; + } + + case EXEC_END_BLOCK: + /* Only come here when there is a label on an + END ASSOCIATE construct. */ + break; + + case EXEC_SELECT: + case EXEC_SELECT_TYPE: + case EXEC_SELECT_RANK: + d = c->block; + fputc ('\n', dumpfile); + code_indent (level, 0); + if (c->op == EXEC_SELECT_RANK) + fputs ("SELECT RANK ", dumpfile); + else if (c->op == EXEC_SELECT_TYPE) + fputs ("SELECT TYPE ", dumpfile); + else + fputs ("SELECT CASE ", dumpfile); + show_expr (c->expr1); + + for (; d; d = d->block) + { + fputc ('\n', dumpfile); + code_indent (level, 0); + fputs ("CASE ", dumpfile); + for (cp = d->ext.block.case_list; cp; cp = cp->next) + { + fputc ('(', dumpfile); + show_expr (cp->low); + fputc (' ', dumpfile); + show_expr (cp->high); + fputc (')', dumpfile); + fputc (' ', dumpfile); + } + + show_code (level + 1, d->next); + fputc ('\n', dumpfile); + } + + code_indent (level, c->label1); + fputs ("END SELECT", dumpfile); + break; + + case EXEC_WHERE: + fputs ("WHERE ", dumpfile); + + d = c->block; + show_expr (d->expr1); + fputc ('\n', dumpfile); + + show_code (level + 1, d->next); + + for (d = d->block; d; d = d->block) + { + code_indent (level, 0); + fputs ("ELSE WHERE ", dumpfile); + show_expr (d->expr1); + fputc ('\n', dumpfile); + show_code (level + 1, d->next); + } + + code_indent (level, 0); + fputs ("END WHERE", dumpfile); + break; + + + case EXEC_FORALL: + fputs ("FORALL ", dumpfile); + for (fa = c->ext.forall_iterator; fa; fa = fa->next) + { + show_expr (fa->var); + fputc (' ', dumpfile); + show_expr (fa->start); + fputc (':', dumpfile); + show_expr (fa->end); + fputc (':', dumpfile); + show_expr (fa->stride); + + if (fa->next != NULL) + fputc (',', dumpfile); + } + + if (c->expr1 != NULL) + { + fputc (',', dumpfile); + show_expr (c->expr1); + } + fputc ('\n', dumpfile); + + show_code (level + 1, c->block->next); + + code_indent (level, 0); + fputs ("END FORALL", dumpfile); + break; + + case EXEC_CRITICAL: + fputs ("CRITICAL\n", dumpfile); + show_code (level + 1, c->block->next); + code_indent (level, 0); + fputs ("END CRITICAL", dumpfile); + break; + + case EXEC_DO: + fputs ("DO ", dumpfile); + if (c->label1) + fprintf (dumpfile, " %-5d ", c->label1->value); + + show_expr (c->ext.iterator->var); + fputc ('=', dumpfile); + show_expr (c->ext.iterator->start); + fputc (' ', dumpfile); + show_expr (c->ext.iterator->end); + fputc (' ', dumpfile); + show_expr (c->ext.iterator->step); + + ++show_level; + show_code (level + 1, c->block->next); + --show_level; + + if (c->label1) + break; + + show_indent (); + fputs ("END DO", dumpfile); + break; + + case EXEC_DO_CONCURRENT: + fputs ("DO CONCURRENT ", dumpfile); + for (fa = c->ext.forall_iterator; fa; fa = fa->next) + { + show_expr (fa->var); + fputc (' ', dumpfile); + show_expr (fa->start); + fputc (':', dumpfile); + show_expr (fa->end); + fputc (':', dumpfile); + show_expr (fa->stride); + + if (fa->next != NULL) + fputc (',', dumpfile); + } + show_expr (c->expr1); + ++show_level; + + show_code (level + 1, c->block->next); + --show_level; + code_indent (level, c->label1); + show_indent (); + fputs ("END DO", dumpfile); + break; + + case EXEC_DO_WHILE: + fputs ("DO WHILE ", dumpfile); + show_expr (c->expr1); + fputc ('\n', dumpfile); + + show_code (level + 1, c->block->next); + + code_indent (level, c->label1); + fputs ("END DO", dumpfile); + break; + + case EXEC_CYCLE: + fputs ("CYCLE", dumpfile); + if (c->symtree) + fprintf (dumpfile, " %s", c->symtree->n.sym->name); + break; + + case EXEC_EXIT: + fputs ("EXIT", dumpfile); + if (c->symtree) + fprintf (dumpfile, " %s", c->symtree->n.sym->name); + break; + + case EXEC_ALLOCATE: + fputs ("ALLOCATE ", dumpfile); + if (c->expr1) + { + fputs (" STAT=", dumpfile); + show_expr (c->expr1); + } + + if (c->expr2) + { + fputs (" ERRMSG=", dumpfile); + show_expr (c->expr2); + } + + if (c->expr3) + { + if (c->expr3->mold) + fputs (" MOLD=", dumpfile); + else + fputs (" SOURCE=", dumpfile); + show_expr (c->expr3); + } + + for (a = c->ext.alloc.list; a; a = a->next) + { + fputc (' ', dumpfile); + show_expr (a->expr); + } + + break; + + case EXEC_DEALLOCATE: + fputs ("DEALLOCATE ", dumpfile); + if (c->expr1) + { + fputs (" STAT=", dumpfile); + show_expr (c->expr1); + } + + if (c->expr2) + { + fputs (" ERRMSG=", dumpfile); + show_expr (c->expr2); + } + + for (a = c->ext.alloc.list; a; a = a->next) + { + fputc (' ', dumpfile); + show_expr (a->expr); + } + + break; + + case EXEC_OPEN: + fputs ("OPEN", dumpfile); + open = c->ext.open; + + if (open->unit) + { + fputs (" UNIT=", dumpfile); + show_expr (open->unit); + } + if (open->iomsg) + { + fputs (" IOMSG=", dumpfile); + show_expr (open->iomsg); + } + if (open->iostat) + { + fputs (" IOSTAT=", dumpfile); + show_expr (open->iostat); + } + if (open->file) + { + fputs (" FILE=", dumpfile); + show_expr (open->file); + } + if (open->status) + { + fputs (" STATUS=", dumpfile); + show_expr (open->status); + } + if (open->access) + { + fputs (" ACCESS=", dumpfile); + show_expr (open->access); + } + if (open->form) + { + fputs (" FORM=", dumpfile); + show_expr (open->form); + } + if (open->recl) + { + fputs (" RECL=", dumpfile); + show_expr (open->recl); + } + if (open->blank) + { + fputs (" BLANK=", dumpfile); + show_expr (open->blank); + } + if (open->position) + { + fputs (" POSITION=", dumpfile); + show_expr (open->position); + } + if (open->action) + { + fputs (" ACTION=", dumpfile); + show_expr (open->action); + } + if (open->delim) + { + fputs (" DELIM=", dumpfile); + show_expr (open->delim); + } + if (open->pad) + { + fputs (" PAD=", dumpfile); + show_expr (open->pad); + } + if (open->decimal) + { + fputs (" DECIMAL=", dumpfile); + show_expr (open->decimal); + } + if (open->encoding) + { + fputs (" ENCODING=", dumpfile); + show_expr (open->encoding); + } + if (open->round) + { + fputs (" ROUND=", dumpfile); + show_expr (open->round); + } + if (open->sign) + { + fputs (" SIGN=", dumpfile); + show_expr (open->sign); + } + if (open->convert) + { + fputs (" CONVERT=", dumpfile); + show_expr (open->convert); + } + if (open->asynchronous) + { + fputs (" ASYNCHRONOUS=", dumpfile); + show_expr (open->asynchronous); + } + if (open->err != NULL) + fprintf (dumpfile, " ERR=%d", open->err->value); + + break; + + case EXEC_CLOSE: + fputs ("CLOSE", dumpfile); + close = c->ext.close; + + if (close->unit) + { + fputs (" UNIT=", dumpfile); + show_expr (close->unit); + } + if (close->iomsg) + { + fputs (" IOMSG=", dumpfile); + show_expr (close->iomsg); + } + if (close->iostat) + { + fputs (" IOSTAT=", dumpfile); + show_expr (close->iostat); + } + if (close->status) + { + fputs (" STATUS=", dumpfile); + show_expr (close->status); + } + if (close->err != NULL) + fprintf (dumpfile, " ERR=%d", close->err->value); + break; + + case EXEC_BACKSPACE: + fputs ("BACKSPACE", dumpfile); + goto show_filepos; + + case EXEC_ENDFILE: + fputs ("ENDFILE", dumpfile); + goto show_filepos; + + case EXEC_REWIND: + fputs ("REWIND", dumpfile); + goto show_filepos; + + case EXEC_FLUSH: + fputs ("FLUSH", dumpfile); + + show_filepos: + fp = c->ext.filepos; + + if (fp->unit) + { + fputs (" UNIT=", dumpfile); + show_expr (fp->unit); + } + if (fp->iomsg) + { + fputs (" IOMSG=", dumpfile); + show_expr (fp->iomsg); + } + if (fp->iostat) + { + fputs (" IOSTAT=", dumpfile); + show_expr (fp->iostat); + } + if (fp->err != NULL) + fprintf (dumpfile, " ERR=%d", fp->err->value); + break; + + case EXEC_INQUIRE: + fputs ("INQUIRE", dumpfile); + i = c->ext.inquire; + + if (i->unit) + { + fputs (" UNIT=", dumpfile); + show_expr (i->unit); + } + if (i->file) + { + fputs (" FILE=", dumpfile); + show_expr (i->file); + } + + if (i->iomsg) + { + fputs (" IOMSG=", dumpfile); + show_expr (i->iomsg); + } + if (i->iostat) + { + fputs (" IOSTAT=", dumpfile); + show_expr (i->iostat); + } + if (i->exist) + { + fputs (" EXIST=", dumpfile); + show_expr (i->exist); + } + if (i->opened) + { + fputs (" OPENED=", dumpfile); + show_expr (i->opened); + } + if (i->number) + { + fputs (" NUMBER=", dumpfile); + show_expr (i->number); + } + if (i->named) + { + fputs (" NAMED=", dumpfile); + show_expr (i->named); + } + if (i->name) + { + fputs (" NAME=", dumpfile); + show_expr (i->name); + } + if (i->access) + { + fputs (" ACCESS=", dumpfile); + show_expr (i->access); + } + if (i->sequential) + { + fputs (" SEQUENTIAL=", dumpfile); + show_expr (i->sequential); + } + + if (i->direct) + { + fputs (" DIRECT=", dumpfile); + show_expr (i->direct); + } + if (i->form) + { + fputs (" FORM=", dumpfile); + show_expr (i->form); + } + if (i->formatted) + { + fputs (" FORMATTED", dumpfile); + show_expr (i->formatted); + } + if (i->unformatted) + { + fputs (" UNFORMATTED=", dumpfile); + show_expr (i->unformatted); + } + if (i->recl) + { + fputs (" RECL=", dumpfile); + show_expr (i->recl); + } + if (i->nextrec) + { + fputs (" NEXTREC=", dumpfile); + show_expr (i->nextrec); + } + if (i->blank) + { + fputs (" BLANK=", dumpfile); + show_expr (i->blank); + } + if (i->position) + { + fputs (" POSITION=", dumpfile); + show_expr (i->position); + } + if (i->action) + { + fputs (" ACTION=", dumpfile); + show_expr (i->action); + } + if (i->read) + { + fputs (" READ=", dumpfile); + show_expr (i->read); + } + if (i->write) + { + fputs (" WRITE=", dumpfile); + show_expr (i->write); + } + if (i->readwrite) + { + fputs (" READWRITE=", dumpfile); + show_expr (i->readwrite); + } + if (i->delim) + { + fputs (" DELIM=", dumpfile); + show_expr (i->delim); + } + if (i->pad) + { + fputs (" PAD=", dumpfile); + show_expr (i->pad); + } + if (i->convert) + { + fputs (" CONVERT=", dumpfile); + show_expr (i->convert); + } + if (i->asynchronous) + { + fputs (" ASYNCHRONOUS=", dumpfile); + show_expr (i->asynchronous); + } + if (i->decimal) + { + fputs (" DECIMAL=", dumpfile); + show_expr (i->decimal); + } + if (i->encoding) + { + fputs (" ENCODING=", dumpfile); + show_expr (i->encoding); + } + if (i->pending) + { + fputs (" PENDING=", dumpfile); + show_expr (i->pending); + } + if (i->round) + { + fputs (" ROUND=", dumpfile); + show_expr (i->round); + } + if (i->sign) + { + fputs (" SIGN=", dumpfile); + show_expr (i->sign); + } + if (i->size) + { + fputs (" SIZE=", dumpfile); + show_expr (i->size); + } + if (i->id) + { + fputs (" ID=", dumpfile); + show_expr (i->id); + } + + if (i->err != NULL) + fprintf (dumpfile, " ERR=%d", i->err->value); + break; + + case EXEC_IOLENGTH: + fputs ("IOLENGTH ", dumpfile); + show_expr (c->expr1); + goto show_dt_code; + break; + + case EXEC_READ: + fputs ("READ", dumpfile); + goto show_dt; + + case EXEC_WRITE: + fputs ("WRITE", dumpfile); + + show_dt: + dt = c->ext.dt; + if (dt->io_unit) + { + fputs (" UNIT=", dumpfile); + show_expr (dt->io_unit); + } + + if (dt->format_expr) + { + fputs (" FMT=", dumpfile); + show_expr (dt->format_expr); + } + + if (dt->format_label != NULL) + fprintf (dumpfile, " FMT=%d", dt->format_label->value); + if (dt->namelist) + fprintf (dumpfile, " NML=%s", dt->namelist->name); + + if (dt->iomsg) + { + fputs (" IOMSG=", dumpfile); + show_expr (dt->iomsg); + } + if (dt->iostat) + { + fputs (" IOSTAT=", dumpfile); + show_expr (dt->iostat); + } + if (dt->size) + { + fputs (" SIZE=", dumpfile); + show_expr (dt->size); + } + if (dt->rec) + { + fputs (" REC=", dumpfile); + show_expr (dt->rec); + } + if (dt->advance) + { + fputs (" ADVANCE=", dumpfile); + show_expr (dt->advance); + } + if (dt->id) + { + fputs (" ID=", dumpfile); + show_expr (dt->id); + } + if (dt->pos) + { + fputs (" POS=", dumpfile); + show_expr (dt->pos); + } + if (dt->asynchronous) + { + fputs (" ASYNCHRONOUS=", dumpfile); + show_expr (dt->asynchronous); + } + if (dt->blank) + { + fputs (" BLANK=", dumpfile); + show_expr (dt->blank); + } + if (dt->decimal) + { + fputs (" DECIMAL=", dumpfile); + show_expr (dt->decimal); + } + if (dt->delim) + { + fputs (" DELIM=", dumpfile); + show_expr (dt->delim); + } + if (dt->pad) + { + fputs (" PAD=", dumpfile); + show_expr (dt->pad); + } + if (dt->round) + { + fputs (" ROUND=", dumpfile); + show_expr (dt->round); + } + if (dt->sign) + { + fputs (" SIGN=", dumpfile); + show_expr (dt->sign); + } + + show_dt_code: + for (c = c->block->next; c; c = c->next) + show_code_node (level + (c->next != NULL), c); + return; + + case EXEC_TRANSFER: + fputs ("TRANSFER ", dumpfile); + show_expr (c->expr1); + break; + + case EXEC_DT_END: + fputs ("DT_END", dumpfile); + dt = c->ext.dt; + + if (dt->err != NULL) + fprintf (dumpfile, " ERR=%d", dt->err->value); + if (dt->end != NULL) + fprintf (dumpfile, " END=%d", dt->end->value); + if (dt->eor != NULL) + fprintf (dumpfile, " EOR=%d", dt->eor->value); + break; + + case EXEC_WAIT: + fputs ("WAIT", dumpfile); + + if (c->ext.wait != NULL) + { + gfc_wait *wait = c->ext.wait; + if (wait->unit) + { + fputs (" UNIT=", dumpfile); + show_expr (wait->unit); + } + if (wait->iostat) + { + fputs (" IOSTAT=", dumpfile); + show_expr (wait->iostat); + } + if (wait->iomsg) + { + fputs (" IOMSG=", dumpfile); + show_expr (wait->iomsg); + } + if (wait->id) + { + fputs (" ID=", dumpfile); + show_expr (wait->id); + } + if (wait->err) + fprintf (dumpfile, " ERR=%d", wait->err->value); + if (wait->end) + fprintf (dumpfile, " END=%d", wait->end->value); + if (wait->eor) + fprintf (dumpfile, " EOR=%d", wait->eor->value); + } + break; + + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_LOOP: + case EXEC_OACC_UPDATE: + case EXEC_OACC_WAIT: + case EXEC_OACC_CACHE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OMP_ATOMIC: + case EXEC_OMP_CANCEL: + case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_BARRIER: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_FLUSH: + case EXEC_OMP_LOOP: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SIMD: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKGROUP: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_WORKSHARE: + show_omp_node (level, c); + break; + + default: + gfc_internal_error ("show_code_node(): Bad statement code"); + } +} + + +/* Show an equivalence chain. */ + +static void +show_equiv (gfc_equiv *eq) +{ + show_indent (); + fputs ("Equivalence: ", dumpfile); + while (eq) + { + show_expr (eq->expr); + eq = eq->eq; + if (eq) + fputs (", ", dumpfile); + } +} + + +/* Show a freakin' whole namespace. */ + +static void +show_namespace (gfc_namespace *ns) +{ + gfc_interface *intr; + gfc_namespace *save; + int op; + gfc_equiv *eq; + int i; + + gcc_assert (ns); + save = gfc_current_ns; + + show_indent (); + fputs ("Namespace:", dumpfile); + + i = 0; + do + { + int l = i; + while (i < GFC_LETTERS - 1 + && gfc_compare_types (&ns->default_type[i+1], + &ns->default_type[l])) + i++; + + if (i > l) + fprintf (dumpfile, " %c-%c: ", l+'A', i+'A'); + else + fprintf (dumpfile, " %c: ", l+'A'); + + show_typespec(&ns->default_type[l]); + i++; + } while (i < GFC_LETTERS); + + if (ns->proc_name != NULL) + { + show_indent (); + fprintf (dumpfile, "procedure name = %s", ns->proc_name->name); + } + + ++show_level; + gfc_current_ns = ns; + gfc_traverse_symtree (ns->common_root, show_common); + + gfc_traverse_symtree (ns->sym_root, show_symtree); + + for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) + { + /* User operator interfaces */ + intr = ns->op[op]; + if (intr == NULL) + continue; + + show_indent (); + fprintf (dumpfile, "Operator interfaces for %s:", + gfc_op2string ((gfc_intrinsic_op) op)); + + for (; intr; intr = intr->next) + fprintf (dumpfile, " %s", intr->sym->name); + } + + if (ns->uop_root != NULL) + { + show_indent (); + fputs ("User operators:\n", dumpfile); + gfc_traverse_user_op (ns, show_uop); + } + + for (eq = ns->equiv; eq; eq = eq->next) + show_equiv (eq); + + if (ns->oacc_declare) + { + struct gfc_oacc_declare *decl; + /* Dump !$ACC DECLARE clauses. */ + for (decl = ns->oacc_declare; decl; decl = decl->next) + { + show_indent (); + fprintf (dumpfile, "!$ACC DECLARE"); + show_omp_clauses (decl->clauses); + } + } + + fputc ('\n', dumpfile); + show_indent (); + fputs ("code:", dumpfile); + show_code (show_level, ns->code); + --show_level; + + for (ns = ns->contained; ns; ns = ns->sibling) + { + fputs ("\nCONTAINS\n", dumpfile); + ++show_level; + show_namespace (ns); + --show_level; + } + + fputc ('\n', dumpfile); + gfc_current_ns = save; +} + + +/* Main function for dumping a parse tree. */ + +void +gfc_dump_parse_tree (gfc_namespace *ns, FILE *file) +{ + dumpfile = file; + show_namespace (ns); +} + +/* This part writes BIND(C) definition for use in external C programs. */ + +static void write_interop_decl (gfc_symbol *); +static void write_proc (gfc_symbol *, bool); + +void +gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file) +{ + int error_count; + gfc_get_errors (NULL, &error_count); + if (error_count != 0) + return; + dumpfile = file; + gfc_traverse_ns (ns, write_interop_decl); +} + +/* Loop over all global symbols, writing out their declrations. */ + +void +gfc_dump_external_c_prototypes (FILE * file) +{ + dumpfile = file; + fprintf (dumpfile, + _("/* Prototypes for external procedures generated from %s\n" + " by GNU Fortran %s%s.\n\n" + " Use of this interface is discouraged, consider using the\n" + " BIND(C) feature of standard Fortran instead. */\n\n"), + gfc_source_file, pkgversion_string, version_string); + + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + { + gfc_symbol *sym = gfc_current_ns->proc_name; + + if (sym == NULL || sym->attr.flavor != FL_PROCEDURE + || sym->attr.is_bind_c) + continue; + + write_proc (sym, false); + } + return; +} + +enum type_return { T_OK=0, T_WARN, T_ERROR }; + +/* Return the name of the type for later output. Both function pointers and + void pointers will be mapped to void *. */ + +static enum type_return +get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, + const char **type_name, bool *asterisk, const char **post, + bool func_ret) +{ + static char post_buffer[40]; + enum type_return ret; + ret = T_ERROR; + + *pre = " "; + *asterisk = false; + *post = ""; + *type_name = ""; + if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX) + { + if (ts->is_c_interop && ts->interop_kind) + ret = T_OK; + else + ret = T_WARN; + + for (int i = 0; i < ISOCBINDING_NUMBER; i++) + { + if (c_interop_kinds_table[i].f90_type == ts->type + && c_interop_kinds_table[i].value == ts->kind) + { + *type_name = c_interop_kinds_table[i].name + 2; + if (strcmp (*type_name, "signed_char") == 0) + *type_name = "signed char"; + else if (strcmp (*type_name, "size_t") == 0) + *type_name = "ssize_t"; + else if (strcmp (*type_name, "float_complex") == 0) + *type_name = "__GFORTRAN_FLOAT_COMPLEX"; + else if (strcmp (*type_name, "double_complex") == 0) + *type_name = "__GFORTRAN_DOUBLE_COMPLEX"; + else if (strcmp (*type_name, "long_double_complex") == 0) + *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX"; + + break; + } + } + } + else if (ts->type == BT_LOGICAL) + { + if (ts->is_c_interop && ts->interop_kind) + { + *type_name = "_Bool"; + ret = T_OK; + } + else + { + /* Let's select an appropriate int, with a warning. */ + for (int i = 0; i < ISOCBINDING_NUMBER; i++) + { + if (c_interop_kinds_table[i].f90_type == BT_INTEGER + && c_interop_kinds_table[i].value == ts->kind) + { + *type_name = c_interop_kinds_table[i].name + 2; + ret = T_WARN; + } + } + } + } + else if (ts->type == BT_CHARACTER) + { + if (ts->is_c_interop) + { + *type_name = "char"; + ret = T_OK; + } + else + { + if (ts->kind == gfc_default_character_kind) + *type_name = "char"; + else + /* Let's select an appropriate int. */ + for (int i = 0; i < ISOCBINDING_NUMBER; i++) + { + if (c_interop_kinds_table[i].f90_type == BT_INTEGER + && c_interop_kinds_table[i].value == ts->kind) + { + *type_name = c_interop_kinds_table[i].name + 2; + break; + } + } + ret = T_WARN; + + } + } + else if (ts->type == BT_DERIVED) + { + if (ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING) + { + if (strcmp (ts->u.derived->name, "c_ptr") == 0) + *type_name = "void"; + else if (strcmp (ts->u.derived->name, "c_funptr") == 0) + { + *type_name = "int "; + if (func_ret) + { + *pre = "("; + *post = "())"; + } + else + { + *pre = "("; + *post = ")()"; + } + } + *asterisk = true; + ret = T_OK; + } + else + *type_name = ts->u.derived->name; + + ret = T_OK; + } + + if (ret != T_ERROR && as) + { + mpz_t sz; + bool size_ok; + size_ok = spec_size (as, &sz); + gcc_assert (size_ok == true); + gmp_snprintf (post_buffer, sizeof(post_buffer), "[%Zd]", sz); + *post = post_buffer; + mpz_clear (sz); + } + return ret; +} + +/* Write out a declaration. */ +static void +write_decl (gfc_typespec *ts, gfc_array_spec *as, const char *sym_name, + bool func_ret, locus *where, bool bind_c) +{ + const char *pre, *type_name, *post; + bool asterisk; + enum type_return rok; + + rok = get_c_type_name (ts, as, &pre, &type_name, &asterisk, &post, func_ret); + if (rok == T_ERROR) + { + gfc_error_now ("Cannot convert %qs to interoperable type at %L", + gfc_typename (ts), where); + fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */", + gfc_typename (ts)); + return; + } + fputs (type_name, dumpfile); + fputs (pre, dumpfile); + if (asterisk) + fputs ("*", dumpfile); + + fputs (sym_name, dumpfile); + fputs (post, dumpfile); + + if (rok == T_WARN && bind_c) + fprintf (dumpfile," /* WARNING: Converting '%s' to interoperable type */", + gfc_typename (ts)); +} + +/* Write out an interoperable type. It will be written as a typedef + for a struct. */ + +static void +write_type (gfc_symbol *sym) +{ + gfc_component *c; + + fprintf (dumpfile, "typedef struct %s {\n", sym->name); + for (c = sym->components; c; c = c->next) + { + fputs (" ", dumpfile); + write_decl (&(c->ts), c->as, c->name, false, &sym->declared_at, true); + fputs (";\n", dumpfile); + } + + fprintf (dumpfile, "} %s;\n", sym->name); +} + +/* Write out a variable. */ + +static void +write_variable (gfc_symbol *sym) +{ + const char *sym_name; + + gcc_assert (sym->attr.flavor == FL_VARIABLE); + + if (sym->binding_label) + sym_name = sym->binding_label; + else + sym_name = sym->name; + + fputs ("extern ", dumpfile); + write_decl (&(sym->ts), sym->as, sym_name, false, &sym->declared_at, true); + fputs (";\n", dumpfile); +} + + +/* Write out a procedure, including its arguments. */ +static void +write_proc (gfc_symbol *sym, bool bind_c) +{ + const char *pre, *type_name, *post; + bool asterisk; + enum type_return rok; + gfc_formal_arglist *f; + const char *sym_name; + const char *intent_in; + bool external_character; + + external_character = sym->ts.type == BT_CHARACTER && !bind_c; + + if (sym->binding_label) + sym_name = sym->binding_label; + else + sym_name = sym->name; + + if (sym->ts.type == BT_UNKNOWN || external_character) + { + fprintf (dumpfile, "void "); + fputs (sym_name, dumpfile); + } + else + write_decl (&(sym->ts), sym->as, sym_name, true, &sym->declared_at, bind_c); + + if (!bind_c) + fputs ("_", dumpfile); + + fputs (" (", dumpfile); + if (external_character) + { + fprintf (dumpfile, "char *result_%s, size_t result_%s_len", + sym_name, sym_name); + if (sym->formal) + fputs (", ", dumpfile); + } + + for (f = sym->formal; f; f = f->next) + { + gfc_symbol *s; + s = f->sym; + rok = get_c_type_name (&(s->ts), NULL, &pre, &type_name, &asterisk, + &post, false); + if (rok == T_ERROR) + { + gfc_error_now ("Cannot convert %qs to interoperable type at %L", + gfc_typename (&s->ts), &s->declared_at); + fprintf (dumpfile, "/* Cannot convert '%s' to interoperable type */", + gfc_typename (&s->ts)); + return; + } + + if (!s->attr.value) + asterisk = true; + + if (s->attr.intent == INTENT_IN && !s->attr.value) + intent_in = "const "; + else + intent_in = ""; + + fputs (intent_in, dumpfile); + fputs (type_name, dumpfile); + fputs (pre, dumpfile); + if (asterisk) + fputs ("*", dumpfile); + + fputs (s->name, dumpfile); + fputs (post, dumpfile); + if (bind_c && rok == T_WARN) + fputs(" /* WARNING: non-interoperable KIND */ ", dumpfile); + + if (f->next) + fputs(", ", dumpfile); + } + if (!bind_c) + for (f = sym->formal; f; f = f->next) + if (f->sym->ts.type == BT_CHARACTER) + fprintf (dumpfile, ", size_t %s_len", f->sym->name); + + fputs (");\n", dumpfile); +} + + +/* Write a C-interoperable declaration as a C prototype or extern + declaration. */ + +static void +write_interop_decl (gfc_symbol *sym) +{ + /* Only dump bind(c) entities. */ + if (!sym->attr.is_bind_c) + return; + + /* Don't dump our iso c module. */ + if (sym->from_intmod == INTMOD_ISO_C_BINDING) + return; + + if (sym->attr.flavor == FL_VARIABLE) + write_variable (sym); + else if (sym->attr.flavor == FL_DERIVED) + write_type (sym); + else if (sym->attr.flavor == FL_PROCEDURE) + write_proc (sym, true); +} + +/* This section deals with dumping the global symbol tree. */ + +/* Callback function for printing out the contents of the tree. */ + +static void +show_global_symbol (gfc_gsymbol *gsym, void *f_data) +{ + FILE *out; + out = (FILE *) f_data; + + if (gsym->name) + fprintf (out, "name=%s", gsym->name); + + if (gsym->sym_name) + fprintf (out, ", sym_name=%s", gsym->sym_name); + + if (gsym->mod_name) + fprintf (out, ", mod_name=%s", gsym->mod_name); + + if (gsym->binding_label) + fprintf (out, ", binding_label=%s", gsym->binding_label); + + fputc ('\n', out); +} + +/* Show all global symbols. */ + +void +gfc_dump_global_symbols (FILE *f) +{ + if (gfc_gsym_root == NULL) + fprintf (f, "empty\n"); + else + gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f); +} + +/* Show an array ref. */ + +void debug (gfc_array_ref *ar) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_array_ref (ar); + fputc ('\n', dumpfile); + dumpfile = tmp; +} diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c deleted file mode 100644 index e95c083..0000000 --- a/gcc/fortran/error.c +++ /dev/null @@ -1,1656 +0,0 @@ -/* Handle errors. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught & Niels Kristian Bech Jensen - -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 -. */ - -/* Handle the inevitable errors. A major catch here is that things - flagged as errors in one match subroutine can conceivably be legal - elsewhere. This means that error messages are recorded and saved - for possible use later. If a line does not match a legal - construction, then the saved error message is reported. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" - -#include "diagnostic.h" -#include "diagnostic-color.h" -#include "tree-diagnostic.h" /* tree_diagnostics_defaults */ - -static int suppress_errors = 0; - -static bool warnings_not_errors = false; - -static int terminal_width; - -/* True if the error/warnings should be buffered. */ -static bool buffered_p; - -static gfc_error_buffer error_buffer; -/* These are always buffered buffers (.flush_p == false) to be used by - the pretty-printer. */ -static output_buffer *pp_error_buffer, *pp_warning_buffer; -static int warningcount_buffered, werrorcount_buffered; - -/* Return true if there output_buffer is empty. */ - -static bool -gfc_output_buffer_empty_p (const output_buffer * buf) -{ - return output_buffer_last_position_in_text (buf) == NULL; -} - -/* Go one level deeper suppressing errors. */ - -void -gfc_push_suppress_errors (void) -{ - gcc_assert (suppress_errors >= 0); - ++suppress_errors; -} - -static void -gfc_error_opt (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0); - -static bool -gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0); - - -/* Leave one level of error suppressing. */ - -void -gfc_pop_suppress_errors (void) -{ - gcc_assert (suppress_errors > 0); - --suppress_errors; -} - - -/* Query whether errors are suppressed. */ - -bool -gfc_query_suppress_errors (void) -{ - return suppress_errors > 0; -} - - -/* Determine terminal width (for trimming source lines in output). */ - -static int -gfc_get_terminal_width (void) -{ - return isatty (STDERR_FILENO) ? get_terminal_width () : INT_MAX; -} - - -/* Per-file error initialization. */ - -void -gfc_error_init_1 (void) -{ - terminal_width = gfc_get_terminal_width (); - gfc_buffer_error (false); -} - - -/* Set the flag for buffering errors or not. */ - -void -gfc_buffer_error (bool flag) -{ - buffered_p = flag; -} - - -/* Add a single character to the error buffer or output depending on - buffered_p. */ - -static void -error_char (char) -{ - /* FIXME: Unused function to be removed in a subsequent patch. */ -} - - -/* Copy a string to wherever it needs to go. */ - -static void -error_string (const char *p) -{ - while (*p) - error_char (*p++); -} - - -/* Print a formatted integer to the error buffer or output. */ - -#define IBUF_LEN 60 - -static void -error_uinteger (unsigned long long int i) -{ - char *p, int_buf[IBUF_LEN]; - - p = int_buf + IBUF_LEN - 1; - *p-- = '\0'; - - if (i == 0) - *p-- = '0'; - - while (i > 0) - { - *p-- = i % 10 + '0'; - i = i / 10; - } - - error_string (p + 1); -} - -static void -error_integer (long long int i) -{ - unsigned long long int u; - - if (i < 0) - { - u = (unsigned long long int) -i; - error_char ('-'); - } - else - u = i; - - error_uinteger (u); -} - - -static void -error_hwuint (unsigned HOST_WIDE_INT i) -{ - char *p, int_buf[IBUF_LEN]; - - p = int_buf + IBUF_LEN - 1; - *p-- = '\0'; - - if (i == 0) - *p-- = '0'; - - while (i > 0) - { - *p-- = i % 10 + '0'; - i = i / 10; - } - - error_string (p + 1); -} - -static void -error_hwint (HOST_WIDE_INT i) -{ - unsigned HOST_WIDE_INT u; - - if (i < 0) - { - u = (unsigned HOST_WIDE_INT) -i; - error_char ('-'); - } - else - u = i; - - error_uinteger (u); -} - - -static size_t -gfc_widechar_display_length (gfc_char_t c) -{ - if (gfc_wide_is_printable (c) || c == '\t') - /* Printable ASCII character, or tabulation (output as a space). */ - return 1; - else if (c < ((gfc_char_t) 1 << 8)) - /* Displayed as \x?? */ - return 4; - else if (c < ((gfc_char_t) 1 << 16)) - /* Displayed as \u???? */ - return 6; - else - /* Displayed as \U???????? */ - return 10; -} - - -/* Length of the ASCII representation of the wide string, escaping wide - characters as print_wide_char_into_buffer() does. */ - -static size_t -gfc_wide_display_length (const gfc_char_t *str) -{ - size_t i, len; - - for (i = 0, len = 0; str[i]; i++) - len += gfc_widechar_display_length (str[i]); - - return len; -} - -static int -print_wide_char_into_buffer (gfc_char_t c, char *buf) -{ - static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6', - '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' }; - - if (gfc_wide_is_printable (c) || c == '\t') - { - buf[1] = '\0'; - /* Tabulation is output as a space. */ - buf[0] = (unsigned char) (c == '\t' ? ' ' : c); - return 1; - } - else if (c < ((gfc_char_t) 1 << 8)) - { - buf[4] = '\0'; - buf[3] = xdigit[c & 0x0F]; - c = c >> 4; - buf[2] = xdigit[c & 0x0F]; - - buf[1] = 'x'; - buf[0] = '\\'; - return 4; - } - else if (c < ((gfc_char_t) 1 << 16)) - { - buf[6] = '\0'; - buf[5] = xdigit[c & 0x0F]; - c = c >> 4; - buf[4] = xdigit[c & 0x0F]; - c = c >> 4; - buf[3] = xdigit[c & 0x0F]; - c = c >> 4; - buf[2] = xdigit[c & 0x0F]; - - buf[1] = 'u'; - buf[0] = '\\'; - return 6; - } - else - { - buf[10] = '\0'; - buf[9] = xdigit[c & 0x0F]; - c = c >> 4; - buf[8] = xdigit[c & 0x0F]; - c = c >> 4; - buf[7] = xdigit[c & 0x0F]; - c = c >> 4; - buf[6] = xdigit[c & 0x0F]; - c = c >> 4; - buf[5] = xdigit[c & 0x0F]; - c = c >> 4; - buf[4] = xdigit[c & 0x0F]; - c = c >> 4; - buf[3] = xdigit[c & 0x0F]; - c = c >> 4; - buf[2] = xdigit[c & 0x0F]; - - buf[1] = 'U'; - buf[0] = '\\'; - return 10; - } -} - -static char wide_char_print_buffer[11]; - -const char * -gfc_print_wide_char (gfc_char_t c) -{ - print_wide_char_into_buffer (c, wide_char_print_buffer); - return wide_char_print_buffer; -} - - -/* Show the file, where it was included, and the source line, give a - locus. Calls error_printf() recursively, but the recursion is at - most one level deep. */ - -static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); - -static void -show_locus (locus *loc, int c1, int c2) -{ - gfc_linebuf *lb; - gfc_file *f; - gfc_char_t *p; - int i, offset, cmax; - - /* TODO: Either limit the total length and number of included files - displayed or add buffering of arbitrary number of characters in - error messages. */ - - /* Write out the error header line, giving the source file and error - location (in GNU standard "[file]:[line].[column]:" format), - followed by an "included by" stack and a blank line. This header - format is matched by a testsuite parser defined in - lib/gfortran-dg.exp. */ - - lb = loc->lb; - f = lb->file; - - error_string (f->filename); - error_char (':'); - - error_integer (LOCATION_LINE (lb->location)); - - if ((c1 > 0) || (c2 > 0)) - error_char ('.'); - - if (c1 > 0) - error_integer (c1); - - if ((c1 > 0) && (c2 > 0)) - error_char ('-'); - - if (c2 > 0) - error_integer (c2); - - error_char (':'); - error_char ('\n'); - - for (;;) - { - i = f->inclusion_line; - - f = f->up; - if (f == NULL) break; - - error_printf (" Included at %s:%d:", f->filename, i); - } - - error_char ('\n'); - - /* Calculate an appropriate horizontal offset of the source line in - order to get the error locus within the visible portion of the - line. Note that if the margin of 5 here is changed, the - corresponding margin of 10 in show_loci should be changed. */ - - offset = 0; - - /* If the two loci would appear in the same column, we shift - '2' one column to the right, so as to print '12' rather than - just '1'. We do this here so it will be accounted for in the - margin calculations. */ - - if (c1 == c2) - c2 += 1; - - cmax = (c1 < c2) ? c2 : c1; - if (cmax > terminal_width - 5) - offset = cmax - terminal_width + 5; - - /* Show the line itself, taking care not to print more than what can - show up on the terminal. Tabs are converted to spaces, and - nonprintable characters are converted to a "\xNN" sequence. */ - - p = &(lb->line[offset]); - i = gfc_wide_display_length (p); - if (i > terminal_width) - i = terminal_width - 1; - - while (i > 0) - { - static char buffer[11]; - i -= print_wide_char_into_buffer (*p++, buffer); - error_string (buffer); - } - - error_char ('\n'); - - /* Show the '1' and/or '2' corresponding to the column of the error - locus. Note that a value of -1 for c1 or c2 will simply cause - the relevant number not to be printed. */ - - c1 -= offset; - c2 -= offset; - cmax -= offset; - - p = &(lb->line[offset]); - for (i = 0; i < cmax; i++) - { - int spaces, j; - spaces = gfc_widechar_display_length (*p++); - - if (i == c1) - error_char ('1'), spaces--; - else if (i == c2) - error_char ('2'), spaces--; - - for (j = 0; j < spaces; j++) - error_char (' '); - } - - if (i == c1) - error_char ('1'); - else if (i == c2) - error_char ('2'); - - error_char ('\n'); - -} - - -/* As part of printing an error, we show the source lines that caused - the problem. We show at least one, and possibly two loci; the two - loci may or may not be on the same source line. */ - -static void -show_loci (locus *l1, locus *l2) -{ - int m, c1, c2; - - if (l1 == NULL || l1->lb == NULL) - { - error_printf ("\n"); - return; - } - - /* While calculating parameters for printing the loci, we consider possible - reasons for printing one per line. If appropriate, print the loci - individually; otherwise we print them both on the same line. */ - - c1 = l1->nextc - l1->lb->line; - if (l2 == NULL) - { - show_locus (l1, c1, -1); - return; - } - - c2 = l2->nextc - l2->lb->line; - - if (c1 < c2) - m = c2 - c1; - else - m = c1 - c2; - - /* Note that the margin value of 10 here needs to be less than the - margin of 5 used in the calculation of offset in show_locus. */ - - if (l1->lb != l2->lb || m > terminal_width - 10) - { - show_locus (l1, c1, -1); - show_locus (l2, -1, c2); - return; - } - - show_locus (l1, c1, c2); - - return; -} - - -/* Workhorse for the error printing subroutines. This subroutine is - inspired by g77's error handling and is similar to printf() with - the following %-codes: - - %c Character, %d or %i Integer, %s String, %% Percent - %L Takes locus argument - %C Current locus (no argument) - - If a locus pointer is given, the actual source line is printed out - and the column is indicated. Since we want the error message at - the bottom of any source file information, we must scan the - argument list twice -- once to determine whether the loci are - present and record this for printing, and once to print the error - message after and loci have been printed. A maximum of two locus - arguments are permitted. - - This function is also called (recursively) by show_locus in the - case of included files; however, as show_locus does not resupply - any loci, the recursion is at most one level deep. */ - -#define MAX_ARGS 10 - -static void ATTRIBUTE_GCC_GFC(2,0) -error_print (const char *type, const char *format0, va_list argp) -{ - enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER, - TYPE_LONGINT, TYPE_ULONGINT, TYPE_LLONGINT, TYPE_ULLONGINT, - TYPE_HWINT, TYPE_HWUINT, TYPE_CHAR, TYPE_STRING, NOTYPE }; - struct - { - int type; - int pos; - union - { - int intval; - unsigned int uintval; - long int longintval; - unsigned long int ulongintval; - long long int llongintval; - unsigned long long int ullongintval; - HOST_WIDE_INT hwintval; - unsigned HOST_WIDE_INT hwuintval; - char charval; - const char * stringval; - } u; - } arg[MAX_ARGS], spec[MAX_ARGS]; - /* spec is the array of specifiers, in the same order as they - appear in the format string. arg is the array of arguments, - in the same order as they appear in the va_list. */ - - char c; - int i, n, have_l1, pos, maxpos; - locus *l1, *l2, *loc; - const char *format; - - loc = l1 = l2 = NULL; - - have_l1 = 0; - pos = -1; - maxpos = -1; - - n = 0; - format = format0; - - for (i = 0; i < MAX_ARGS; i++) - { - arg[i].type = NOTYPE; - spec[i].pos = -1; - } - - /* First parse the format string for position specifiers. */ - while (*format) - { - c = *format++; - if (c != '%') - continue; - - if (*format == '%') - { - format++; - continue; - } - - if (ISDIGIT (*format)) - { - /* This is a position specifier. For example, the number - 12 in the format string "%12$d", which specifies the third - argument of the va_list, formatted in %d format. - For details, see "man 3 printf". */ - pos = atoi(format) - 1; - gcc_assert (pos >= 0); - while (ISDIGIT(*format)) - format++; - gcc_assert (*format == '$'); - format++; - } - else - pos++; - - c = *format++; - - if (pos > maxpos) - maxpos = pos; - - switch (c) - { - case 'C': - arg[pos].type = TYPE_CURRENTLOC; - break; - - case 'L': - arg[pos].type = TYPE_LOCUS; - break; - - case 'd': - case 'i': - arg[pos].type = TYPE_INTEGER; - break; - - case 'u': - arg[pos].type = TYPE_UINTEGER; - break; - - case 'l': - c = *format++; - if (c == 'l') - { - c = *format++; - if (c == 'u') - arg[pos].type = TYPE_ULLONGINT; - else if (c == 'i' || c == 'd') - arg[pos].type = TYPE_LLONGINT; - else - gcc_unreachable (); - } - else if (c == 'u') - arg[pos].type = TYPE_ULONGINT; - else if (c == 'i' || c == 'd') - arg[pos].type = TYPE_LONGINT; - else - gcc_unreachable (); - break; - - case 'w': - c = *format++; - if (c == 'u') - arg[pos].type = TYPE_HWUINT; - else if (c == 'i' || c == 'd') - arg[pos].type = TYPE_HWINT; - else - gcc_unreachable (); - break; - - case 'c': - arg[pos].type = TYPE_CHAR; - break; - - case 's': - arg[pos].type = TYPE_STRING; - break; - - default: - gcc_unreachable (); - } - - spec[n++].pos = pos; - } - - /* Then convert the values for each %-style argument. */ - for (pos = 0; pos <= maxpos; pos++) - { - gcc_assert (arg[pos].type != NOTYPE); - switch (arg[pos].type) - { - case TYPE_CURRENTLOC: - loc = &gfc_current_locus; - /* Fall through. */ - - case TYPE_LOCUS: - if (arg[pos].type == TYPE_LOCUS) - loc = va_arg (argp, locus *); - - if (have_l1) - { - l2 = loc; - arg[pos].u.stringval = "(2)"; - /* Point %C first offending character not the last good one. */ - if (arg[pos].type == TYPE_CURRENTLOC && *l2->nextc != '\0') - l2->nextc++; - } - else - { - l1 = loc; - have_l1 = 1; - arg[pos].u.stringval = "(1)"; - /* Point %C first offending character not the last good one. */ - if (arg[pos].type == TYPE_CURRENTLOC && *l1->nextc != '\0') - l1->nextc++; - } - break; - - case TYPE_INTEGER: - arg[pos].u.intval = va_arg (argp, int); - break; - - case TYPE_UINTEGER: - arg[pos].u.uintval = va_arg (argp, unsigned int); - break; - - case TYPE_LONGINT: - arg[pos].u.longintval = va_arg (argp, long int); - break; - - case TYPE_ULONGINT: - arg[pos].u.ulongintval = va_arg (argp, unsigned long int); - break; - - case TYPE_LLONGINT: - arg[pos].u.llongintval = va_arg (argp, long long int); - break; - - case TYPE_ULLONGINT: - arg[pos].u.ullongintval = va_arg (argp, unsigned long long int); - break; - - case TYPE_HWINT: - arg[pos].u.hwintval = va_arg (argp, HOST_WIDE_INT); - break; - - case TYPE_HWUINT: - arg[pos].u.hwuintval = va_arg (argp, unsigned HOST_WIDE_INT); - break; - - case TYPE_CHAR: - arg[pos].u.charval = (char) va_arg (argp, int); - break; - - case TYPE_STRING: - arg[pos].u.stringval = (const char *) va_arg (argp, char *); - break; - - default: - gcc_unreachable (); - } - } - - for (n = 0; spec[n].pos >= 0; n++) - spec[n].u = arg[spec[n].pos].u; - - /* Show the current loci if we have to. */ - if (have_l1) - show_loci (l1, l2); - - if (*type) - { - error_string (type); - error_char (' '); - } - - have_l1 = 0; - format = format0; - n = 0; - - for (; *format; format++) - { - if (*format != '%') - { - error_char (*format); - continue; - } - - format++; - if (ISDIGIT (*format)) - { - /* This is a position specifier. See comment above. */ - while (ISDIGIT (*format)) - format++; - - /* Skip over the dollar sign. */ - format++; - } - - switch (*format) - { - case '%': - error_char ('%'); - break; - - case 'c': - error_char (spec[n++].u.charval); - break; - - case 's': - case 'C': /* Current locus */ - case 'L': /* Specified locus */ - error_string (spec[n++].u.stringval); - break; - - case 'd': - case 'i': - error_integer (spec[n++].u.intval); - break; - - case 'u': - error_uinteger (spec[n++].u.uintval); - break; - - case 'l': - format++; - if (*format == 'l') - { - format++; - if (*format == 'u') - error_uinteger (spec[n++].u.ullongintval); - else - error_integer (spec[n++].u.llongintval); - } - if (*format == 'u') - error_uinteger (spec[n++].u.ulongintval); - else - error_integer (spec[n++].u.longintval); - break; - - case 'w': - format++; - if (*format == 'u') - error_hwuint (spec[n++].u.hwintval); - else - error_hwint (spec[n++].u.hwuintval); - break; - } - } - - error_char ('\n'); -} - - -/* Wrapper for error_print(). */ - -static void -error_printf (const char *gmsgid, ...) -{ - va_list argp; - - va_start (argp, gmsgid); - error_print ("", _(gmsgid), argp); - va_end (argp); -} - - -/* Clear any output buffered in a pretty-print output_buffer. */ - -static void -gfc_clear_pp_buffer (output_buffer *this_buffer) -{ - pretty_printer *pp = global_dc->printer; - output_buffer *tmp_buffer = pp->buffer; - pp->buffer = this_buffer; - pp_clear_output_area (pp); - pp->buffer = tmp_buffer; - /* We need to reset last_location, otherwise we may skip caret lines - when we actually give a diagnostic. */ - global_dc->last_location = UNKNOWN_LOCATION; -} - -/* The currently-printing diagnostic, for use by gfc_format_decoder, - for colorizing %C and %L. */ - -static diagnostic_info *curr_diagnostic; - -/* A helper function to call diagnostic_report_diagnostic, while setting - curr_diagnostic for the duration of the call. */ - -static bool -gfc_report_diagnostic (diagnostic_info *diagnostic) -{ - gcc_assert (diagnostic != NULL); - curr_diagnostic = diagnostic; - bool ret = diagnostic_report_diagnostic (global_dc, diagnostic); - curr_diagnostic = NULL; - return ret; -} - -/* This is just a helper function to avoid duplicating the logic of - gfc_warning. */ - -static bool -gfc_warning (int opt, const char *gmsgid, va_list ap) -{ - va_list argp; - va_copy (argp, ap); - - diagnostic_info diagnostic; - rich_location rich_loc (line_table, UNKNOWN_LOCATION); - bool fatal_errors = global_dc->fatal_errors; - pretty_printer *pp = global_dc->printer; - output_buffer *tmp_buffer = pp->buffer; - - gfc_clear_pp_buffer (pp_warning_buffer); - - if (buffered_p) - { - pp->buffer = pp_warning_buffer; - global_dc->fatal_errors = false; - /* To prevent -fmax-errors= triggering. */ - --werrorcount; - } - - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_index = opt; - bool ret = gfc_report_diagnostic (&diagnostic); - - if (buffered_p) - { - pp->buffer = tmp_buffer; - global_dc->fatal_errors = fatal_errors; - - warningcount_buffered = 0; - werrorcount_buffered = 0; - /* Undo the above --werrorcount if not Werror, otherwise - werrorcount is correct already. */ - if (!ret) - ++werrorcount; - else if (diagnostic.kind == DK_ERROR) - ++werrorcount_buffered; - else - ++werrorcount, --warningcount, ++warningcount_buffered; - } - - va_end (argp); - return ret; -} - -/* Issue a warning. */ - -bool -gfc_warning (int opt, const char *gmsgid, ...) -{ - va_list argp; - - va_start (argp, gmsgid); - bool ret = gfc_warning (opt, gmsgid, argp); - va_end (argp); - return ret; -} - - -/* Whether, for a feature included in a given standard set (GFC_STD_*), - we should issue an error or a warning, or be quiet. */ - -notification -gfc_notification_std (int std) -{ - bool warning; - - warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings; - if ((gfc_option.allow_std & std) != 0 && !warning) - return SILENT; - - return warning ? WARNING : ERROR; -} - - -/* Return a string describing the nature of a standard violation - * and/or the relevant version of the standard. */ - -char const* -notify_std_msg(int std) -{ - - if (std & GFC_STD_F2018_DEL) - return _("Fortran 2018 deleted feature:"); - else if (std & GFC_STD_F2018_OBS) - return _("Fortran 2018 obsolescent feature:"); - else if (std & GFC_STD_F2018) - return _("Fortran 2018:"); - else if (std & GFC_STD_F2008_OBS) - return _("Fortran 2008 obsolescent feature:"); - else if (std & GFC_STD_F2008) - return "Fortran 2008:"; - else if (std & GFC_STD_F2003) - return "Fortran 2003:"; - else if (std & GFC_STD_GNU) - return _("GNU Extension:"); - else if (std & GFC_STD_LEGACY) - return _("Legacy Extension:"); - else if (std & GFC_STD_F95_OBS) - return _("Obsolescent feature:"); - else if (std & GFC_STD_F95_DEL) - return _("Deleted feature:"); - else - gcc_unreachable (); -} - - -/* Possibly issue a warning/error about use of a nonstandard (or deleted) - feature. An error/warning will be issued if the currently selected - standard does not contain the requested bits. Return false if - an error is generated. */ - -bool -gfc_notify_std (int std, const char *gmsgid, ...) -{ - va_list argp; - const char *msg, *msg2; - char *buffer; - - /* Determine whether an error or a warning is needed. */ - const int wstd = std & gfc_option.warn_std; /* Standard to warn about. */ - const int estd = std & ~gfc_option.allow_std; /* Standard to error about. */ - const bool warning = (wstd != 0) && !inhibit_warnings; - const bool error = (estd != 0); - - if (!error && !warning) - return true; - if (suppress_errors) - return !error; - - if (error) - msg = notify_std_msg (estd); - else - msg = notify_std_msg (wstd); - - msg2 = _(gmsgid); - buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2); - strcpy (buffer, msg); - strcat (buffer, " "); - strcat (buffer, msg2); - - va_start (argp, gmsgid); - if (error) - gfc_error_opt (0, buffer, argp); - else - gfc_warning (0, buffer, argp); - va_end (argp); - - if (error) - return false; - else - return (warning && !warnings_are_errors); -} - - -/* Called from output_format -- during diagnostic message processing - to handle Fortran specific format specifiers with the following meanings: - - %C Current locus (no argument) - %L Takes locus argument -*/ -static bool -gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec, - int precision, bool wide, bool set_locus, bool hash, - bool *quoted, const char **buffer_ptr) -{ - switch (*spec) - { - case 'C': - case 'L': - { - static const char *result[2] = { "(1)", "(2)" }; - locus *loc; - if (*spec == 'C') - loc = &gfc_current_locus; - else - loc = va_arg (*text->args_ptr, locus *); - gcc_assert (loc->nextc - loc->lb->line >= 0); - unsigned int offset = loc->nextc - loc->lb->line; - if (*spec == 'C' && *loc->nextc != '\0') - /* Point %C first offending character not the last good one. */ - offset++; - /* If location[0] != UNKNOWN_LOCATION means that we already - processed one of %C/%L. */ - int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1; - location_t src_loc - = linemap_position_for_loc_and_offset (line_table, - loc->lb->location, - offset); - text->set_location (loc_num, src_loc, SHOW_RANGE_WITH_CARET); - /* Colorize the markers to match the color choices of - diagnostic_show_locus (the initial location has a color given - by the "kind" of the diagnostic, the secondary location has - color "range1"). */ - gcc_assert (curr_diagnostic != NULL); - const char *color - = (loc_num - ? "range1" - : diagnostic_get_color_for_kind (curr_diagnostic->kind)); - pp_string (pp, colorize_start (pp_show_color (pp), color)); - pp_string (pp, result[loc_num]); - pp_string (pp, colorize_stop (pp_show_color (pp))); - return true; - } - default: - /* Fall through info the middle-end decoder, as e.g. stor-layout.c - etc. diagnostics can use the FE printer while the FE is still - active. */ - return default_tree_printer (pp, text, spec, precision, wide, - set_locus, hash, quoted, buffer_ptr); - } -} - -/* Return a malloc'd string describing the kind of diagnostic. The - caller is responsible for freeing the memory. */ -static char * -gfc_diagnostic_build_kind_prefix (diagnostic_context *context, - const diagnostic_info *diagnostic) -{ - static const char *const diagnostic_kind_text[] = { -#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T), -#include "gfc-diagnostic.def" -#undef DEFINE_DIAGNOSTIC_KIND - "must-not-happen" - }; - static const char *const diagnostic_kind_color[] = { -#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C), -#include "gfc-diagnostic.def" -#undef DEFINE_DIAGNOSTIC_KIND - NULL - }; - gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND); - const char *text = _(diagnostic_kind_text[diagnostic->kind]); - const char *text_cs = "", *text_ce = ""; - pretty_printer *pp = context->printer; - - if (diagnostic_kind_color[diagnostic->kind]) - { - text_cs = colorize_start (pp_show_color (pp), - diagnostic_kind_color[diagnostic->kind]); - text_ce = colorize_stop (pp_show_color (pp)); - } - return build_message_string ("%s%s:%s ", text_cs, text, text_ce); -} - -/* Return a malloc'd string describing a location. The caller is - responsible for freeing the memory. */ -static char * -gfc_diagnostic_build_locus_prefix (diagnostic_context *context, - expanded_location s) -{ - pretty_printer *pp = context->printer; - const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); - const char *locus_ce = colorize_stop (pp_show_color (pp)); - return (s.file == NULL - ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) - : !strcmp (s.file, N_("")) - ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce) - : context->show_column - ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line, - s.column, locus_ce) - : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce)); -} - -/* Return a malloc'd string describing two locations. The caller is - responsible for freeing the memory. */ -static char * -gfc_diagnostic_build_locus_prefix (diagnostic_context *context, - expanded_location s, expanded_location s2) -{ - pretty_printer *pp = context->printer; - const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); - const char *locus_ce = colorize_stop (pp_show_color (pp)); - - return (s.file == NULL - ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) - : !strcmp (s.file, N_("")) - ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce) - : context->show_column - ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line, - MIN (s.column, s2.column), - MAX (s.column, s2.column), locus_ce) - : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, - locus_ce)); -} - -/* This function prints the locus (file:line:column), the diagnostic kind - (Error, Warning) and (optionally) the relevant lines of code with - annotation lines with '1' and/or '2' below them. - - With -fdiagnostic-show-caret (the default) it prints: - - [locus of primary range]: - - some code - 1 - Error: Some error at (1) - - With -fno-diagnostic-show-caret or if the primary range is not - valid, it prints: - - [locus of primary range]: Error: Some error at (1) and (2) -*/ -static void -gfc_diagnostic_starter (diagnostic_context *context, - diagnostic_info *diagnostic) -{ - char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic); - - expanded_location s1 = diagnostic_expand_location (diagnostic); - expanded_location s2; - bool one_locus = diagnostic->richloc->get_num_locations () < 2; - bool same_locus = false; - - if (!one_locus) - { - s2 = diagnostic_expand_location (diagnostic, 1); - same_locus = diagnostic_same_line (context, s1, s2); - } - - char * locus_prefix = (one_locus || !same_locus) - ? gfc_diagnostic_build_locus_prefix (context, s1) - : gfc_diagnostic_build_locus_prefix (context, s1, s2); - - if (!context->show_caret - || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION - || diagnostic_location (diagnostic, 0) == context->last_location) - { - pp_set_prefix (context->printer, - concat (locus_prefix, " ", kind_prefix, NULL)); - free (locus_prefix); - - if (one_locus || same_locus) - { - free (kind_prefix); - return; - } - /* In this case, we print the previous locus and prefix as: - - [locus]:[prefix]: (1) - - and we flush with a new line before setting the new prefix. */ - pp_string (context->printer, "(1)"); - pp_newline (context->printer); - locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2); - pp_set_prefix (context->printer, - concat (locus_prefix, " ", kind_prefix, NULL)); - free (kind_prefix); - free (locus_prefix); - } - else - { - pp_verbatim (context->printer, "%s", locus_prefix); - free (locus_prefix); - /* Fortran uses an empty line between locus and caret line. */ - pp_newline (context->printer); - pp_set_prefix (context->printer, NULL); - pp_newline (context->printer); - diagnostic_show_locus (context, diagnostic->richloc, diagnostic->kind); - /* If the caret line was shown, the prefix does not contain the - locus. */ - pp_set_prefix (context->printer, kind_prefix); - } -} - -static void -gfc_diagnostic_start_span (diagnostic_context *context, - expanded_location exploc) -{ - char *locus_prefix; - locus_prefix = gfc_diagnostic_build_locus_prefix (context, exploc); - pp_verbatim (context->printer, "%s", locus_prefix); - free (locus_prefix); - pp_newline (context->printer); - /* Fortran uses an empty line between locus and caret line. */ - pp_newline (context->printer); -} - - -static void -gfc_diagnostic_finalizer (diagnostic_context *context, - diagnostic_info *diagnostic ATTRIBUTE_UNUSED, - diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED) -{ - pp_destroy_prefix (context->printer); - pp_newline_and_flush (context->printer); -} - -/* Immediate warning (i.e. do not buffer the warning) with an explicit - location. */ - -bool -gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) -{ - va_list argp; - diagnostic_info diagnostic; - rich_location rich_loc (line_table, loc); - bool ret; - - va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING); - diagnostic.option_index = opt; - ret = gfc_report_diagnostic (&diagnostic); - va_end (argp); - return ret; -} - -/* Immediate warning (i.e. do not buffer the warning). */ - -bool -gfc_warning_now (int opt, const char *gmsgid, ...) -{ - va_list argp; - diagnostic_info diagnostic; - rich_location rich_loc (line_table, UNKNOWN_LOCATION); - bool ret; - - va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_index = opt; - ret = gfc_report_diagnostic (&diagnostic); - va_end (argp); - return ret; -} - -/* Internal warning, do not buffer. */ - -bool -gfc_warning_internal (int opt, const char *gmsgid, ...) -{ - va_list argp; - diagnostic_info diagnostic; - rich_location rich_loc (line_table, UNKNOWN_LOCATION); - bool ret; - - va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_index = opt; - ret = gfc_report_diagnostic (&diagnostic); - va_end (argp); - return ret; -} - -/* Immediate error (i.e. do not buffer). */ - -void -gfc_error_now (const char *gmsgid, ...) -{ - va_list argp; - diagnostic_info diagnostic; - rich_location rich_loc (line_table, UNKNOWN_LOCATION); - - error_buffer.flag = true; - - va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR); - gfc_report_diagnostic (&diagnostic); - va_end (argp); -} - - -/* Fatal error, never returns. */ - -void -gfc_fatal_error (const char *gmsgid, ...) -{ - va_list argp; - diagnostic_info diagnostic; - rich_location rich_loc (line_table, UNKNOWN_LOCATION); - - va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL); - gfc_report_diagnostic (&diagnostic); - va_end (argp); - - gcc_unreachable (); -} - -/* Clear the warning flag. */ - -void -gfc_clear_warning (void) -{ - gfc_clear_pp_buffer (pp_warning_buffer); - warningcount_buffered = 0; - werrorcount_buffered = 0; -} - - -/* Check to see if any warnings have been saved. - If so, print the warning. */ - -void -gfc_warning_check (void) -{ - if (! gfc_output_buffer_empty_p (pp_warning_buffer)) - { - pretty_printer *pp = global_dc->printer; - output_buffer *tmp_buffer = pp->buffer; - pp->buffer = pp_warning_buffer; - pp_really_flush (pp); - warningcount += warningcount_buffered; - werrorcount += werrorcount_buffered; - gcc_assert (warningcount_buffered + werrorcount_buffered == 1); - pp->buffer = tmp_buffer; - diagnostic_action_after_output (global_dc, - warningcount_buffered - ? DK_WARNING : DK_ERROR); - diagnostic_check_max_errors (global_dc, true); - } -} - - -/* Issue an error. */ - -static void -gfc_error_opt (int opt, const char *gmsgid, va_list ap) -{ - va_list argp; - va_copy (argp, ap); - bool saved_abort_on_error = false; - - if (warnings_not_errors) - { - gfc_warning (opt, gmsgid, argp); - va_end (argp); - return; - } - - if (suppress_errors) - { - va_end (argp); - return; - } - - diagnostic_info diagnostic; - rich_location richloc (line_table, UNKNOWN_LOCATION); - bool fatal_errors = global_dc->fatal_errors; - pretty_printer *pp = global_dc->printer; - output_buffer *tmp_buffer = pp->buffer; - - gfc_clear_pp_buffer (pp_error_buffer); - - if (buffered_p) - { - /* To prevent -dH from triggering an abort on a buffered error, - save abort_on_error and restore it below. */ - saved_abort_on_error = global_dc->abort_on_error; - global_dc->abort_on_error = false; - pp->buffer = pp_error_buffer; - global_dc->fatal_errors = false; - /* To prevent -fmax-errors= triggering, we decrease it before - report_diagnostic increases it. */ - --errorcount; - } - - diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR); - gfc_report_diagnostic (&diagnostic); - - if (buffered_p) - { - pp->buffer = tmp_buffer; - global_dc->fatal_errors = fatal_errors; - global_dc->abort_on_error = saved_abort_on_error; - - } - - va_end (argp); -} - - -void -gfc_error_opt (int opt, const char *gmsgid, ...) -{ - va_list argp; - va_start (argp, gmsgid); - gfc_error_opt (opt, gmsgid, argp); - va_end (argp); -} - - -void -gfc_error (const char *gmsgid, ...) -{ - va_list argp; - va_start (argp, gmsgid); - gfc_error_opt (0, gmsgid, argp); - va_end (argp); -} - - -/* This shouldn't happen... but sometimes does. */ - -void -gfc_internal_error (const char *gmsgid, ...) -{ - int e, w; - va_list argp; - diagnostic_info diagnostic; - rich_location rich_loc (line_table, UNKNOWN_LOCATION); - - gfc_get_errors (&w, &e); - if (e > 0) - exit(EXIT_FAILURE); - - va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE); - gfc_report_diagnostic (&diagnostic); - va_end (argp); - - gcc_unreachable (); -} - - -/* Clear the error flag when we start to compile a source line. */ - -void -gfc_clear_error (void) -{ - error_buffer.flag = false; - warnings_not_errors = false; - gfc_clear_pp_buffer (pp_error_buffer); -} - - -/* Tests the state of error_flag. */ - -bool -gfc_error_flag_test (void) -{ - return error_buffer.flag - || !gfc_output_buffer_empty_p (pp_error_buffer); -} - - -/* Check to see if any errors have been saved. - If so, print the error. Returns the state of error_flag. */ - -bool -gfc_error_check (void) -{ - if (error_buffer.flag - || ! gfc_output_buffer_empty_p (pp_error_buffer)) - { - error_buffer.flag = false; - pretty_printer *pp = global_dc->printer; - output_buffer *tmp_buffer = pp->buffer; - pp->buffer = pp_error_buffer; - pp_really_flush (pp); - ++errorcount; - gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); - pp->buffer = tmp_buffer; - diagnostic_action_after_output (global_dc, DK_ERROR); - diagnostic_check_max_errors (global_dc, true); - return true; - } - - return false; -} - -/* Move the text buffered from FROM to TO, then clear - FROM. Independently if there was text in FROM, TO is also - cleared. */ - -static void -gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from, - gfc_error_buffer * buffer_to) -{ - output_buffer * from = &(buffer_from->buffer); - output_buffer * to = &(buffer_to->buffer); - - buffer_to->flag = buffer_from->flag; - buffer_from->flag = false; - - gfc_clear_pp_buffer (to); - /* We make sure this is always buffered. */ - to->flush_p = false; - - if (! gfc_output_buffer_empty_p (from)) - { - const char *str = output_buffer_formatted_text (from); - output_buffer_append_r (to, str, strlen (str)); - gfc_clear_pp_buffer (from); - } -} - -/* Save the existing error state. */ - -void -gfc_push_error (gfc_error_buffer *err) -{ - gfc_move_error_buffer_from_to (&error_buffer, err); -} - - -/* Restore a previous pushed error state. */ - -void -gfc_pop_error (gfc_error_buffer *err) -{ - gfc_move_error_buffer_from_to (err, &error_buffer); -} - - -/* Free a pushed error state, but keep the current error state. */ - -void -gfc_free_error (gfc_error_buffer *err) -{ - gfc_clear_pp_buffer (&(err->buffer)); -} - - -/* Report the number of warnings and errors that occurred to the caller. */ - -void -gfc_get_errors (int *w, int *e) -{ - if (w != NULL) - *w = warningcount + werrorcount; - if (e != NULL) - *e = errorcount + sorrycount + werrorcount; -} - - -/* Switch errors into warnings. */ - -void -gfc_errors_to_warnings (bool f) -{ - warnings_not_errors = f; -} - -void -gfc_diagnostics_init (void) -{ - diagnostic_starter (global_dc) = gfc_diagnostic_starter; - global_dc->start_span = gfc_diagnostic_start_span; - diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; - diagnostic_format_decoder (global_dc) = gfc_format_decoder; - global_dc->caret_chars[0] = '1'; - global_dc->caret_chars[1] = '2'; - pp_warning_buffer = new (XNEW (output_buffer)) output_buffer (); - pp_warning_buffer->flush_p = false; - /* pp_error_buffer is statically allocated. This simplifies memory - management when using gfc_push/pop_error. */ - pp_error_buffer = &(error_buffer.buffer); - pp_error_buffer->flush_p = false; -} - -void -gfc_diagnostics_finish (void) -{ - tree_diagnostics_defaults (global_dc); - /* We still want to use the gfc starter and finalizer, not the tree - defaults. */ - diagnostic_starter (global_dc) = gfc_diagnostic_starter; - diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; - global_dc->caret_chars[0] = '^'; - global_dc->caret_chars[1] = '^'; -} diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc new file mode 100644 index 0000000..e95c083 --- /dev/null +++ b/gcc/fortran/error.cc @@ -0,0 +1,1656 @@ +/* Handle errors. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught & Niels Kristian Bech Jensen + +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 +. */ + +/* Handle the inevitable errors. A major catch here is that things + flagged as errors in one match subroutine can conceivably be legal + elsewhere. This means that error messages are recorded and saved + for possible use later. If a line does not match a legal + construction, then the saved error message is reported. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" + +#include "diagnostic.h" +#include "diagnostic-color.h" +#include "tree-diagnostic.h" /* tree_diagnostics_defaults */ + +static int suppress_errors = 0; + +static bool warnings_not_errors = false; + +static int terminal_width; + +/* True if the error/warnings should be buffered. */ +static bool buffered_p; + +static gfc_error_buffer error_buffer; +/* These are always buffered buffers (.flush_p == false) to be used by + the pretty-printer. */ +static output_buffer *pp_error_buffer, *pp_warning_buffer; +static int warningcount_buffered, werrorcount_buffered; + +/* Return true if there output_buffer is empty. */ + +static bool +gfc_output_buffer_empty_p (const output_buffer * buf) +{ + return output_buffer_last_position_in_text (buf) == NULL; +} + +/* Go one level deeper suppressing errors. */ + +void +gfc_push_suppress_errors (void) +{ + gcc_assert (suppress_errors >= 0); + ++suppress_errors; +} + +static void +gfc_error_opt (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0); + +static bool +gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0); + + +/* Leave one level of error suppressing. */ + +void +gfc_pop_suppress_errors (void) +{ + gcc_assert (suppress_errors > 0); + --suppress_errors; +} + + +/* Query whether errors are suppressed. */ + +bool +gfc_query_suppress_errors (void) +{ + return suppress_errors > 0; +} + + +/* Determine terminal width (for trimming source lines in output). */ + +static int +gfc_get_terminal_width (void) +{ + return isatty (STDERR_FILENO) ? get_terminal_width () : INT_MAX; +} + + +/* Per-file error initialization. */ + +void +gfc_error_init_1 (void) +{ + terminal_width = gfc_get_terminal_width (); + gfc_buffer_error (false); +} + + +/* Set the flag for buffering errors or not. */ + +void +gfc_buffer_error (bool flag) +{ + buffered_p = flag; +} + + +/* Add a single character to the error buffer or output depending on + buffered_p. */ + +static void +error_char (char) +{ + /* FIXME: Unused function to be removed in a subsequent patch. */ +} + + +/* Copy a string to wherever it needs to go. */ + +static void +error_string (const char *p) +{ + while (*p) + error_char (*p++); +} + + +/* Print a formatted integer to the error buffer or output. */ + +#define IBUF_LEN 60 + +static void +error_uinteger (unsigned long long int i) +{ + char *p, int_buf[IBUF_LEN]; + + p = int_buf + IBUF_LEN - 1; + *p-- = '\0'; + + if (i == 0) + *p-- = '0'; + + while (i > 0) + { + *p-- = i % 10 + '0'; + i = i / 10; + } + + error_string (p + 1); +} + +static void +error_integer (long long int i) +{ + unsigned long long int u; + + if (i < 0) + { + u = (unsigned long long int) -i; + error_char ('-'); + } + else + u = i; + + error_uinteger (u); +} + + +static void +error_hwuint (unsigned HOST_WIDE_INT i) +{ + char *p, int_buf[IBUF_LEN]; + + p = int_buf + IBUF_LEN - 1; + *p-- = '\0'; + + if (i == 0) + *p-- = '0'; + + while (i > 0) + { + *p-- = i % 10 + '0'; + i = i / 10; + } + + error_string (p + 1); +} + +static void +error_hwint (HOST_WIDE_INT i) +{ + unsigned HOST_WIDE_INT u; + + if (i < 0) + { + u = (unsigned HOST_WIDE_INT) -i; + error_char ('-'); + } + else + u = i; + + error_uinteger (u); +} + + +static size_t +gfc_widechar_display_length (gfc_char_t c) +{ + if (gfc_wide_is_printable (c) || c == '\t') + /* Printable ASCII character, or tabulation (output as a space). */ + return 1; + else if (c < ((gfc_char_t) 1 << 8)) + /* Displayed as \x?? */ + return 4; + else if (c < ((gfc_char_t) 1 << 16)) + /* Displayed as \u???? */ + return 6; + else + /* Displayed as \U???????? */ + return 10; +} + + +/* Length of the ASCII representation of the wide string, escaping wide + characters as print_wide_char_into_buffer() does. */ + +static size_t +gfc_wide_display_length (const gfc_char_t *str) +{ + size_t i, len; + + for (i = 0, len = 0; str[i]; i++) + len += gfc_widechar_display_length (str[i]); + + return len; +} + +static int +print_wide_char_into_buffer (gfc_char_t c, char *buf) +{ + static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6', + '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' }; + + if (gfc_wide_is_printable (c) || c == '\t') + { + buf[1] = '\0'; + /* Tabulation is output as a space. */ + buf[0] = (unsigned char) (c == '\t' ? ' ' : c); + return 1; + } + else if (c < ((gfc_char_t) 1 << 8)) + { + buf[4] = '\0'; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = 'x'; + buf[0] = '\\'; + return 4; + } + else if (c < ((gfc_char_t) 1 << 16)) + { + buf[6] = '\0'; + buf[5] = xdigit[c & 0x0F]; + c = c >> 4; + buf[4] = xdigit[c & 0x0F]; + c = c >> 4; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = 'u'; + buf[0] = '\\'; + return 6; + } + else + { + buf[10] = '\0'; + buf[9] = xdigit[c & 0x0F]; + c = c >> 4; + buf[8] = xdigit[c & 0x0F]; + c = c >> 4; + buf[7] = xdigit[c & 0x0F]; + c = c >> 4; + buf[6] = xdigit[c & 0x0F]; + c = c >> 4; + buf[5] = xdigit[c & 0x0F]; + c = c >> 4; + buf[4] = xdigit[c & 0x0F]; + c = c >> 4; + buf[3] = xdigit[c & 0x0F]; + c = c >> 4; + buf[2] = xdigit[c & 0x0F]; + + buf[1] = 'U'; + buf[0] = '\\'; + return 10; + } +} + +static char wide_char_print_buffer[11]; + +const char * +gfc_print_wide_char (gfc_char_t c) +{ + print_wide_char_into_buffer (c, wide_char_print_buffer); + return wide_char_print_buffer; +} + + +/* Show the file, where it was included, and the source line, give a + locus. Calls error_printf() recursively, but the recursion is at + most one level deep. */ + +static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); + +static void +show_locus (locus *loc, int c1, int c2) +{ + gfc_linebuf *lb; + gfc_file *f; + gfc_char_t *p; + int i, offset, cmax; + + /* TODO: Either limit the total length and number of included files + displayed or add buffering of arbitrary number of characters in + error messages. */ + + /* Write out the error header line, giving the source file and error + location (in GNU standard "[file]:[line].[column]:" format), + followed by an "included by" stack and a blank line. This header + format is matched by a testsuite parser defined in + lib/gfortran-dg.exp. */ + + lb = loc->lb; + f = lb->file; + + error_string (f->filename); + error_char (':'); + + error_integer (LOCATION_LINE (lb->location)); + + if ((c1 > 0) || (c2 > 0)) + error_char ('.'); + + if (c1 > 0) + error_integer (c1); + + if ((c1 > 0) && (c2 > 0)) + error_char ('-'); + + if (c2 > 0) + error_integer (c2); + + error_char (':'); + error_char ('\n'); + + for (;;) + { + i = f->inclusion_line; + + f = f->up; + if (f == NULL) break; + + error_printf (" Included at %s:%d:", f->filename, i); + } + + error_char ('\n'); + + /* Calculate an appropriate horizontal offset of the source line in + order to get the error locus within the visible portion of the + line. Note that if the margin of 5 here is changed, the + corresponding margin of 10 in show_loci should be changed. */ + + offset = 0; + + /* If the two loci would appear in the same column, we shift + '2' one column to the right, so as to print '12' rather than + just '1'. We do this here so it will be accounted for in the + margin calculations. */ + + if (c1 == c2) + c2 += 1; + + cmax = (c1 < c2) ? c2 : c1; + if (cmax > terminal_width - 5) + offset = cmax - terminal_width + 5; + + /* Show the line itself, taking care not to print more than what can + show up on the terminal. Tabs are converted to spaces, and + nonprintable characters are converted to a "\xNN" sequence. */ + + p = &(lb->line[offset]); + i = gfc_wide_display_length (p); + if (i > terminal_width) + i = terminal_width - 1; + + while (i > 0) + { + static char buffer[11]; + i -= print_wide_char_into_buffer (*p++, buffer); + error_string (buffer); + } + + error_char ('\n'); + + /* Show the '1' and/or '2' corresponding to the column of the error + locus. Note that a value of -1 for c1 or c2 will simply cause + the relevant number not to be printed. */ + + c1 -= offset; + c2 -= offset; + cmax -= offset; + + p = &(lb->line[offset]); + for (i = 0; i < cmax; i++) + { + int spaces, j; + spaces = gfc_widechar_display_length (*p++); + + if (i == c1) + error_char ('1'), spaces--; + else if (i == c2) + error_char ('2'), spaces--; + + for (j = 0; j < spaces; j++) + error_char (' '); + } + + if (i == c1) + error_char ('1'); + else if (i == c2) + error_char ('2'); + + error_char ('\n'); + +} + + +/* As part of printing an error, we show the source lines that caused + the problem. We show at least one, and possibly two loci; the two + loci may or may not be on the same source line. */ + +static void +show_loci (locus *l1, locus *l2) +{ + int m, c1, c2; + + if (l1 == NULL || l1->lb == NULL) + { + error_printf ("\n"); + return; + } + + /* While calculating parameters for printing the loci, we consider possible + reasons for printing one per line. If appropriate, print the loci + individually; otherwise we print them both on the same line. */ + + c1 = l1->nextc - l1->lb->line; + if (l2 == NULL) + { + show_locus (l1, c1, -1); + return; + } + + c2 = l2->nextc - l2->lb->line; + + if (c1 < c2) + m = c2 - c1; + else + m = c1 - c2; + + /* Note that the margin value of 10 here needs to be less than the + margin of 5 used in the calculation of offset in show_locus. */ + + if (l1->lb != l2->lb || m > terminal_width - 10) + { + show_locus (l1, c1, -1); + show_locus (l2, -1, c2); + return; + } + + show_locus (l1, c1, c2); + + return; +} + + +/* Workhorse for the error printing subroutines. This subroutine is + inspired by g77's error handling and is similar to printf() with + the following %-codes: + + %c Character, %d or %i Integer, %s String, %% Percent + %L Takes locus argument + %C Current locus (no argument) + + If a locus pointer is given, the actual source line is printed out + and the column is indicated. Since we want the error message at + the bottom of any source file information, we must scan the + argument list twice -- once to determine whether the loci are + present and record this for printing, and once to print the error + message after and loci have been printed. A maximum of two locus + arguments are permitted. + + This function is also called (recursively) by show_locus in the + case of included files; however, as show_locus does not resupply + any loci, the recursion is at most one level deep. */ + +#define MAX_ARGS 10 + +static void ATTRIBUTE_GCC_GFC(2,0) +error_print (const char *type, const char *format0, va_list argp) +{ + enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER, + TYPE_LONGINT, TYPE_ULONGINT, TYPE_LLONGINT, TYPE_ULLONGINT, + TYPE_HWINT, TYPE_HWUINT, TYPE_CHAR, TYPE_STRING, NOTYPE }; + struct + { + int type; + int pos; + union + { + int intval; + unsigned int uintval; + long int longintval; + unsigned long int ulongintval; + long long int llongintval; + unsigned long long int ullongintval; + HOST_WIDE_INT hwintval; + unsigned HOST_WIDE_INT hwuintval; + char charval; + const char * stringval; + } u; + } arg[MAX_ARGS], spec[MAX_ARGS]; + /* spec is the array of specifiers, in the same order as they + appear in the format string. arg is the array of arguments, + in the same order as they appear in the va_list. */ + + char c; + int i, n, have_l1, pos, maxpos; + locus *l1, *l2, *loc; + const char *format; + + loc = l1 = l2 = NULL; + + have_l1 = 0; + pos = -1; + maxpos = -1; + + n = 0; + format = format0; + + for (i = 0; i < MAX_ARGS; i++) + { + arg[i].type = NOTYPE; + spec[i].pos = -1; + } + + /* First parse the format string for position specifiers. */ + while (*format) + { + c = *format++; + if (c != '%') + continue; + + if (*format == '%') + { + format++; + continue; + } + + if (ISDIGIT (*format)) + { + /* This is a position specifier. For example, the number + 12 in the format string "%12$d", which specifies the third + argument of the va_list, formatted in %d format. + For details, see "man 3 printf". */ + pos = atoi(format) - 1; + gcc_assert (pos >= 0); + while (ISDIGIT(*format)) + format++; + gcc_assert (*format == '$'); + format++; + } + else + pos++; + + c = *format++; + + if (pos > maxpos) + maxpos = pos; + + switch (c) + { + case 'C': + arg[pos].type = TYPE_CURRENTLOC; + break; + + case 'L': + arg[pos].type = TYPE_LOCUS; + break; + + case 'd': + case 'i': + arg[pos].type = TYPE_INTEGER; + break; + + case 'u': + arg[pos].type = TYPE_UINTEGER; + break; + + case 'l': + c = *format++; + if (c == 'l') + { + c = *format++; + if (c == 'u') + arg[pos].type = TYPE_ULLONGINT; + else if (c == 'i' || c == 'd') + arg[pos].type = TYPE_LLONGINT; + else + gcc_unreachable (); + } + else if (c == 'u') + arg[pos].type = TYPE_ULONGINT; + else if (c == 'i' || c == 'd') + arg[pos].type = TYPE_LONGINT; + else + gcc_unreachable (); + break; + + case 'w': + c = *format++; + if (c == 'u') + arg[pos].type = TYPE_HWUINT; + else if (c == 'i' || c == 'd') + arg[pos].type = TYPE_HWINT; + else + gcc_unreachable (); + break; + + case 'c': + arg[pos].type = TYPE_CHAR; + break; + + case 's': + arg[pos].type = TYPE_STRING; + break; + + default: + gcc_unreachable (); + } + + spec[n++].pos = pos; + } + + /* Then convert the values for each %-style argument. */ + for (pos = 0; pos <= maxpos; pos++) + { + gcc_assert (arg[pos].type != NOTYPE); + switch (arg[pos].type) + { + case TYPE_CURRENTLOC: + loc = &gfc_current_locus; + /* Fall through. */ + + case TYPE_LOCUS: + if (arg[pos].type == TYPE_LOCUS) + loc = va_arg (argp, locus *); + + if (have_l1) + { + l2 = loc; + arg[pos].u.stringval = "(2)"; + /* Point %C first offending character not the last good one. */ + if (arg[pos].type == TYPE_CURRENTLOC && *l2->nextc != '\0') + l2->nextc++; + } + else + { + l1 = loc; + have_l1 = 1; + arg[pos].u.stringval = "(1)"; + /* Point %C first offending character not the last good one. */ + if (arg[pos].type == TYPE_CURRENTLOC && *l1->nextc != '\0') + l1->nextc++; + } + break; + + case TYPE_INTEGER: + arg[pos].u.intval = va_arg (argp, int); + break; + + case TYPE_UINTEGER: + arg[pos].u.uintval = va_arg (argp, unsigned int); + break; + + case TYPE_LONGINT: + arg[pos].u.longintval = va_arg (argp, long int); + break; + + case TYPE_ULONGINT: + arg[pos].u.ulongintval = va_arg (argp, unsigned long int); + break; + + case TYPE_LLONGINT: + arg[pos].u.llongintval = va_arg (argp, long long int); + break; + + case TYPE_ULLONGINT: + arg[pos].u.ullongintval = va_arg (argp, unsigned long long int); + break; + + case TYPE_HWINT: + arg[pos].u.hwintval = va_arg (argp, HOST_WIDE_INT); + break; + + case TYPE_HWUINT: + arg[pos].u.hwuintval = va_arg (argp, unsigned HOST_WIDE_INT); + break; + + case TYPE_CHAR: + arg[pos].u.charval = (char) va_arg (argp, int); + break; + + case TYPE_STRING: + arg[pos].u.stringval = (const char *) va_arg (argp, char *); + break; + + default: + gcc_unreachable (); + } + } + + for (n = 0; spec[n].pos >= 0; n++) + spec[n].u = arg[spec[n].pos].u; + + /* Show the current loci if we have to. */ + if (have_l1) + show_loci (l1, l2); + + if (*type) + { + error_string (type); + error_char (' '); + } + + have_l1 = 0; + format = format0; + n = 0; + + for (; *format; format++) + { + if (*format != '%') + { + error_char (*format); + continue; + } + + format++; + if (ISDIGIT (*format)) + { + /* This is a position specifier. See comment above. */ + while (ISDIGIT (*format)) + format++; + + /* Skip over the dollar sign. */ + format++; + } + + switch (*format) + { + case '%': + error_char ('%'); + break; + + case 'c': + error_char (spec[n++].u.charval); + break; + + case 's': + case 'C': /* Current locus */ + case 'L': /* Specified locus */ + error_string (spec[n++].u.stringval); + break; + + case 'd': + case 'i': + error_integer (spec[n++].u.intval); + break; + + case 'u': + error_uinteger (spec[n++].u.uintval); + break; + + case 'l': + format++; + if (*format == 'l') + { + format++; + if (*format == 'u') + error_uinteger (spec[n++].u.ullongintval); + else + error_integer (spec[n++].u.llongintval); + } + if (*format == 'u') + error_uinteger (spec[n++].u.ulongintval); + else + error_integer (spec[n++].u.longintval); + break; + + case 'w': + format++; + if (*format == 'u') + error_hwuint (spec[n++].u.hwintval); + else + error_hwint (spec[n++].u.hwuintval); + break; + } + } + + error_char ('\n'); +} + + +/* Wrapper for error_print(). */ + +static void +error_printf (const char *gmsgid, ...) +{ + va_list argp; + + va_start (argp, gmsgid); + error_print ("", _(gmsgid), argp); + va_end (argp); +} + + +/* Clear any output buffered in a pretty-print output_buffer. */ + +static void +gfc_clear_pp_buffer (output_buffer *this_buffer) +{ + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + pp->buffer = this_buffer; + pp_clear_output_area (pp); + pp->buffer = tmp_buffer; + /* We need to reset last_location, otherwise we may skip caret lines + when we actually give a diagnostic. */ + global_dc->last_location = UNKNOWN_LOCATION; +} + +/* The currently-printing diagnostic, for use by gfc_format_decoder, + for colorizing %C and %L. */ + +static diagnostic_info *curr_diagnostic; + +/* A helper function to call diagnostic_report_diagnostic, while setting + curr_diagnostic for the duration of the call. */ + +static bool +gfc_report_diagnostic (diagnostic_info *diagnostic) +{ + gcc_assert (diagnostic != NULL); + curr_diagnostic = diagnostic; + bool ret = diagnostic_report_diagnostic (global_dc, diagnostic); + curr_diagnostic = NULL; + return ret; +} + +/* This is just a helper function to avoid duplicating the logic of + gfc_warning. */ + +static bool +gfc_warning (int opt, const char *gmsgid, va_list ap) +{ + va_list argp; + va_copy (argp, ap); + + diagnostic_info diagnostic; + rich_location rich_loc (line_table, UNKNOWN_LOCATION); + bool fatal_errors = global_dc->fatal_errors; + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + + gfc_clear_pp_buffer (pp_warning_buffer); + + if (buffered_p) + { + pp->buffer = pp_warning_buffer; + global_dc->fatal_errors = false; + /* To prevent -fmax-errors= triggering. */ + --werrorcount; + } + + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + DK_WARNING); + diagnostic.option_index = opt; + bool ret = gfc_report_diagnostic (&diagnostic); + + if (buffered_p) + { + pp->buffer = tmp_buffer; + global_dc->fatal_errors = fatal_errors; + + warningcount_buffered = 0; + werrorcount_buffered = 0; + /* Undo the above --werrorcount if not Werror, otherwise + werrorcount is correct already. */ + if (!ret) + ++werrorcount; + else if (diagnostic.kind == DK_ERROR) + ++werrorcount_buffered; + else + ++werrorcount, --warningcount, ++warningcount_buffered; + } + + va_end (argp); + return ret; +} + +/* Issue a warning. */ + +bool +gfc_warning (int opt, const char *gmsgid, ...) +{ + va_list argp; + + va_start (argp, gmsgid); + bool ret = gfc_warning (opt, gmsgid, argp); + va_end (argp); + return ret; +} + + +/* Whether, for a feature included in a given standard set (GFC_STD_*), + we should issue an error or a warning, or be quiet. */ + +notification +gfc_notification_std (int std) +{ + bool warning; + + warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings; + if ((gfc_option.allow_std & std) != 0 && !warning) + return SILENT; + + return warning ? WARNING : ERROR; +} + + +/* Return a string describing the nature of a standard violation + * and/or the relevant version of the standard. */ + +char const* +notify_std_msg(int std) +{ + + if (std & GFC_STD_F2018_DEL) + return _("Fortran 2018 deleted feature:"); + else if (std & GFC_STD_F2018_OBS) + return _("Fortran 2018 obsolescent feature:"); + else if (std & GFC_STD_F2018) + return _("Fortran 2018:"); + else if (std & GFC_STD_F2008_OBS) + return _("Fortran 2008 obsolescent feature:"); + else if (std & GFC_STD_F2008) + return "Fortran 2008:"; + else if (std & GFC_STD_F2003) + return "Fortran 2003:"; + else if (std & GFC_STD_GNU) + return _("GNU Extension:"); + else if (std & GFC_STD_LEGACY) + return _("Legacy Extension:"); + else if (std & GFC_STD_F95_OBS) + return _("Obsolescent feature:"); + else if (std & GFC_STD_F95_DEL) + return _("Deleted feature:"); + else + gcc_unreachable (); +} + + +/* Possibly issue a warning/error about use of a nonstandard (or deleted) + feature. An error/warning will be issued if the currently selected + standard does not contain the requested bits. Return false if + an error is generated. */ + +bool +gfc_notify_std (int std, const char *gmsgid, ...) +{ + va_list argp; + const char *msg, *msg2; + char *buffer; + + /* Determine whether an error or a warning is needed. */ + const int wstd = std & gfc_option.warn_std; /* Standard to warn about. */ + const int estd = std & ~gfc_option.allow_std; /* Standard to error about. */ + const bool warning = (wstd != 0) && !inhibit_warnings; + const bool error = (estd != 0); + + if (!error && !warning) + return true; + if (suppress_errors) + return !error; + + if (error) + msg = notify_std_msg (estd); + else + msg = notify_std_msg (wstd); + + msg2 = _(gmsgid); + buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2); + strcpy (buffer, msg); + strcat (buffer, " "); + strcat (buffer, msg2); + + va_start (argp, gmsgid); + if (error) + gfc_error_opt (0, buffer, argp); + else + gfc_warning (0, buffer, argp); + va_end (argp); + + if (error) + return false; + else + return (warning && !warnings_are_errors); +} + + +/* Called from output_format -- during diagnostic message processing + to handle Fortran specific format specifiers with the following meanings: + + %C Current locus (no argument) + %L Takes locus argument +*/ +static bool +gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec, + int precision, bool wide, bool set_locus, bool hash, + bool *quoted, const char **buffer_ptr) +{ + switch (*spec) + { + case 'C': + case 'L': + { + static const char *result[2] = { "(1)", "(2)" }; + locus *loc; + if (*spec == 'C') + loc = &gfc_current_locus; + else + loc = va_arg (*text->args_ptr, locus *); + gcc_assert (loc->nextc - loc->lb->line >= 0); + unsigned int offset = loc->nextc - loc->lb->line; + if (*spec == 'C' && *loc->nextc != '\0') + /* Point %C first offending character not the last good one. */ + offset++; + /* If location[0] != UNKNOWN_LOCATION means that we already + processed one of %C/%L. */ + int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1; + location_t src_loc + = linemap_position_for_loc_and_offset (line_table, + loc->lb->location, + offset); + text->set_location (loc_num, src_loc, SHOW_RANGE_WITH_CARET); + /* Colorize the markers to match the color choices of + diagnostic_show_locus (the initial location has a color given + by the "kind" of the diagnostic, the secondary location has + color "range1"). */ + gcc_assert (curr_diagnostic != NULL); + const char *color + = (loc_num + ? "range1" + : diagnostic_get_color_for_kind (curr_diagnostic->kind)); + pp_string (pp, colorize_start (pp_show_color (pp), color)); + pp_string (pp, result[loc_num]); + pp_string (pp, colorize_stop (pp_show_color (pp))); + return true; + } + default: + /* Fall through info the middle-end decoder, as e.g. stor-layout.c + etc. diagnostics can use the FE printer while the FE is still + active. */ + return default_tree_printer (pp, text, spec, precision, wide, + set_locus, hash, quoted, buffer_ptr); + } +} + +/* Return a malloc'd string describing the kind of diagnostic. The + caller is responsible for freeing the memory. */ +static char * +gfc_diagnostic_build_kind_prefix (diagnostic_context *context, + const diagnostic_info *diagnostic) +{ + static const char *const diagnostic_kind_text[] = { +#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T), +#include "gfc-diagnostic.def" +#undef DEFINE_DIAGNOSTIC_KIND + "must-not-happen" + }; + static const char *const diagnostic_kind_color[] = { +#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C), +#include "gfc-diagnostic.def" +#undef DEFINE_DIAGNOSTIC_KIND + NULL + }; + gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND); + const char *text = _(diagnostic_kind_text[diagnostic->kind]); + const char *text_cs = "", *text_ce = ""; + pretty_printer *pp = context->printer; + + if (diagnostic_kind_color[diagnostic->kind]) + { + text_cs = colorize_start (pp_show_color (pp), + diagnostic_kind_color[diagnostic->kind]); + text_ce = colorize_stop (pp_show_color (pp)); + } + return build_message_string ("%s%s:%s ", text_cs, text, text_ce); +} + +/* Return a malloc'd string describing a location. The caller is + responsible for freeing the memory. */ +static char * +gfc_diagnostic_build_locus_prefix (diagnostic_context *context, + expanded_location s) +{ + pretty_printer *pp = context->printer; + const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); + const char *locus_ce = colorize_stop (pp_show_color (pp)); + return (s.file == NULL + ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) + : !strcmp (s.file, N_("")) + ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce) + : context->show_column + ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line, + s.column, locus_ce) + : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce)); +} + +/* Return a malloc'd string describing two locations. The caller is + responsible for freeing the memory. */ +static char * +gfc_diagnostic_build_locus_prefix (diagnostic_context *context, + expanded_location s, expanded_location s2) +{ + pretty_printer *pp = context->printer; + const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); + const char *locus_ce = colorize_stop (pp_show_color (pp)); + + return (s.file == NULL + ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) + : !strcmp (s.file, N_("")) + ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce) + : context->show_column + ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line, + MIN (s.column, s2.column), + MAX (s.column, s2.column), locus_ce) + : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, + locus_ce)); +} + +/* This function prints the locus (file:line:column), the diagnostic kind + (Error, Warning) and (optionally) the relevant lines of code with + annotation lines with '1' and/or '2' below them. + + With -fdiagnostic-show-caret (the default) it prints: + + [locus of primary range]: + + some code + 1 + Error: Some error at (1) + + With -fno-diagnostic-show-caret or if the primary range is not + valid, it prints: + + [locus of primary range]: Error: Some error at (1) and (2) +*/ +static void +gfc_diagnostic_starter (diagnostic_context *context, + diagnostic_info *diagnostic) +{ + char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic); + + expanded_location s1 = diagnostic_expand_location (diagnostic); + expanded_location s2; + bool one_locus = diagnostic->richloc->get_num_locations () < 2; + bool same_locus = false; + + if (!one_locus) + { + s2 = diagnostic_expand_location (diagnostic, 1); + same_locus = diagnostic_same_line (context, s1, s2); + } + + char * locus_prefix = (one_locus || !same_locus) + ? gfc_diagnostic_build_locus_prefix (context, s1) + : gfc_diagnostic_build_locus_prefix (context, s1, s2); + + if (!context->show_caret + || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION + || diagnostic_location (diagnostic, 0) == context->last_location) + { + pp_set_prefix (context->printer, + concat (locus_prefix, " ", kind_prefix, NULL)); + free (locus_prefix); + + if (one_locus || same_locus) + { + free (kind_prefix); + return; + } + /* In this case, we print the previous locus and prefix as: + + [locus]:[prefix]: (1) + + and we flush with a new line before setting the new prefix. */ + pp_string (context->printer, "(1)"); + pp_newline (context->printer); + locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2); + pp_set_prefix (context->printer, + concat (locus_prefix, " ", kind_prefix, NULL)); + free (kind_prefix); + free (locus_prefix); + } + else + { + pp_verbatim (context->printer, "%s", locus_prefix); + free (locus_prefix); + /* Fortran uses an empty line between locus and caret line. */ + pp_newline (context->printer); + pp_set_prefix (context->printer, NULL); + pp_newline (context->printer); + diagnostic_show_locus (context, diagnostic->richloc, diagnostic->kind); + /* If the caret line was shown, the prefix does not contain the + locus. */ + pp_set_prefix (context->printer, kind_prefix); + } +} + +static void +gfc_diagnostic_start_span (diagnostic_context *context, + expanded_location exploc) +{ + char *locus_prefix; + locus_prefix = gfc_diagnostic_build_locus_prefix (context, exploc); + pp_verbatim (context->printer, "%s", locus_prefix); + free (locus_prefix); + pp_newline (context->printer); + /* Fortran uses an empty line between locus and caret line. */ + pp_newline (context->printer); +} + + +static void +gfc_diagnostic_finalizer (diagnostic_context *context, + diagnostic_info *diagnostic ATTRIBUTE_UNUSED, + diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED) +{ + pp_destroy_prefix (context->printer); + pp_newline_and_flush (context->printer); +} + +/* Immediate warning (i.e. do not buffer the warning) with an explicit + location. */ + +bool +gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) +{ + va_list argp; + diagnostic_info diagnostic; + rich_location rich_loc (line_table, loc); + bool ret; + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING); + diagnostic.option_index = opt; + ret = gfc_report_diagnostic (&diagnostic); + va_end (argp); + return ret; +} + +/* Immediate warning (i.e. do not buffer the warning). */ + +bool +gfc_warning_now (int opt, const char *gmsgid, ...) +{ + va_list argp; + diagnostic_info diagnostic; + rich_location rich_loc (line_table, UNKNOWN_LOCATION); + bool ret; + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + DK_WARNING); + diagnostic.option_index = opt; + ret = gfc_report_diagnostic (&diagnostic); + va_end (argp); + return ret; +} + +/* Internal warning, do not buffer. */ + +bool +gfc_warning_internal (int opt, const char *gmsgid, ...) +{ + va_list argp; + diagnostic_info diagnostic; + rich_location rich_loc (line_table, UNKNOWN_LOCATION); + bool ret; + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + DK_WARNING); + diagnostic.option_index = opt; + ret = gfc_report_diagnostic (&diagnostic); + va_end (argp); + return ret; +} + +/* Immediate error (i.e. do not buffer). */ + +void +gfc_error_now (const char *gmsgid, ...) +{ + va_list argp; + diagnostic_info diagnostic; + rich_location rich_loc (line_table, UNKNOWN_LOCATION); + + error_buffer.flag = true; + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR); + gfc_report_diagnostic (&diagnostic); + va_end (argp); +} + + +/* Fatal error, never returns. */ + +void +gfc_fatal_error (const char *gmsgid, ...) +{ + va_list argp; + diagnostic_info diagnostic; + rich_location rich_loc (line_table, UNKNOWN_LOCATION); + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL); + gfc_report_diagnostic (&diagnostic); + va_end (argp); + + gcc_unreachable (); +} + +/* Clear the warning flag. */ + +void +gfc_clear_warning (void) +{ + gfc_clear_pp_buffer (pp_warning_buffer); + warningcount_buffered = 0; + werrorcount_buffered = 0; +} + + +/* Check to see if any warnings have been saved. + If so, print the warning. */ + +void +gfc_warning_check (void) +{ + if (! gfc_output_buffer_empty_p (pp_warning_buffer)) + { + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + pp->buffer = pp_warning_buffer; + pp_really_flush (pp); + warningcount += warningcount_buffered; + werrorcount += werrorcount_buffered; + gcc_assert (warningcount_buffered + werrorcount_buffered == 1); + pp->buffer = tmp_buffer; + diagnostic_action_after_output (global_dc, + warningcount_buffered + ? DK_WARNING : DK_ERROR); + diagnostic_check_max_errors (global_dc, true); + } +} + + +/* Issue an error. */ + +static void +gfc_error_opt (int opt, const char *gmsgid, va_list ap) +{ + va_list argp; + va_copy (argp, ap); + bool saved_abort_on_error = false; + + if (warnings_not_errors) + { + gfc_warning (opt, gmsgid, argp); + va_end (argp); + return; + } + + if (suppress_errors) + { + va_end (argp); + return; + } + + diagnostic_info diagnostic; + rich_location richloc (line_table, UNKNOWN_LOCATION); + bool fatal_errors = global_dc->fatal_errors; + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + + gfc_clear_pp_buffer (pp_error_buffer); + + if (buffered_p) + { + /* To prevent -dH from triggering an abort on a buffered error, + save abort_on_error and restore it below. */ + saved_abort_on_error = global_dc->abort_on_error; + global_dc->abort_on_error = false; + pp->buffer = pp_error_buffer; + global_dc->fatal_errors = false; + /* To prevent -fmax-errors= triggering, we decrease it before + report_diagnostic increases it. */ + --errorcount; + } + + diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR); + gfc_report_diagnostic (&diagnostic); + + if (buffered_p) + { + pp->buffer = tmp_buffer; + global_dc->fatal_errors = fatal_errors; + global_dc->abort_on_error = saved_abort_on_error; + + } + + va_end (argp); +} + + +void +gfc_error_opt (int opt, const char *gmsgid, ...) +{ + va_list argp; + va_start (argp, gmsgid); + gfc_error_opt (opt, gmsgid, argp); + va_end (argp); +} + + +void +gfc_error (const char *gmsgid, ...) +{ + va_list argp; + va_start (argp, gmsgid); + gfc_error_opt (0, gmsgid, argp); + va_end (argp); +} + + +/* This shouldn't happen... but sometimes does. */ + +void +gfc_internal_error (const char *gmsgid, ...) +{ + int e, w; + va_list argp; + diagnostic_info diagnostic; + rich_location rich_loc (line_table, UNKNOWN_LOCATION); + + gfc_get_errors (&w, &e); + if (e > 0) + exit(EXIT_FAILURE); + + va_start (argp, gmsgid); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE); + gfc_report_diagnostic (&diagnostic); + va_end (argp); + + gcc_unreachable (); +} + + +/* Clear the error flag when we start to compile a source line. */ + +void +gfc_clear_error (void) +{ + error_buffer.flag = false; + warnings_not_errors = false; + gfc_clear_pp_buffer (pp_error_buffer); +} + + +/* Tests the state of error_flag. */ + +bool +gfc_error_flag_test (void) +{ + return error_buffer.flag + || !gfc_output_buffer_empty_p (pp_error_buffer); +} + + +/* Check to see if any errors have been saved. + If so, print the error. Returns the state of error_flag. */ + +bool +gfc_error_check (void) +{ + if (error_buffer.flag + || ! gfc_output_buffer_empty_p (pp_error_buffer)) + { + error_buffer.flag = false; + pretty_printer *pp = global_dc->printer; + output_buffer *tmp_buffer = pp->buffer; + pp->buffer = pp_error_buffer; + pp_really_flush (pp); + ++errorcount; + gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); + pp->buffer = tmp_buffer; + diagnostic_action_after_output (global_dc, DK_ERROR); + diagnostic_check_max_errors (global_dc, true); + return true; + } + + return false; +} + +/* Move the text buffered from FROM to TO, then clear + FROM. Independently if there was text in FROM, TO is also + cleared. */ + +static void +gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from, + gfc_error_buffer * buffer_to) +{ + output_buffer * from = &(buffer_from->buffer); + output_buffer * to = &(buffer_to->buffer); + + buffer_to->flag = buffer_from->flag; + buffer_from->flag = false; + + gfc_clear_pp_buffer (to); + /* We make sure this is always buffered. */ + to->flush_p = false; + + if (! gfc_output_buffer_empty_p (from)) + { + const char *str = output_buffer_formatted_text (from); + output_buffer_append_r (to, str, strlen (str)); + gfc_clear_pp_buffer (from); + } +} + +/* Save the existing error state. */ + +void +gfc_push_error (gfc_error_buffer *err) +{ + gfc_move_error_buffer_from_to (&error_buffer, err); +} + + +/* Restore a previous pushed error state. */ + +void +gfc_pop_error (gfc_error_buffer *err) +{ + gfc_move_error_buffer_from_to (err, &error_buffer); +} + + +/* Free a pushed error state, but keep the current error state. */ + +void +gfc_free_error (gfc_error_buffer *err) +{ + gfc_clear_pp_buffer (&(err->buffer)); +} + + +/* Report the number of warnings and errors that occurred to the caller. */ + +void +gfc_get_errors (int *w, int *e) +{ + if (w != NULL) + *w = warningcount + werrorcount; + if (e != NULL) + *e = errorcount + sorrycount + werrorcount; +} + + +/* Switch errors into warnings. */ + +void +gfc_errors_to_warnings (bool f) +{ + warnings_not_errors = f; +} + +void +gfc_diagnostics_init (void) +{ + diagnostic_starter (global_dc) = gfc_diagnostic_starter; + global_dc->start_span = gfc_diagnostic_start_span; + diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; + diagnostic_format_decoder (global_dc) = gfc_format_decoder; + global_dc->caret_chars[0] = '1'; + global_dc->caret_chars[1] = '2'; + pp_warning_buffer = new (XNEW (output_buffer)) output_buffer (); + pp_warning_buffer->flush_p = false; + /* pp_error_buffer is statically allocated. This simplifies memory + management when using gfc_push/pop_error. */ + pp_error_buffer = &(error_buffer.buffer); + pp_error_buffer->flush_p = false; +} + +void +gfc_diagnostics_finish (void) +{ + tree_diagnostics_defaults (global_dc); + /* We still want to use the gfc starter and finalizer, not the tree + defaults. */ + diagnostic_starter (global_dc) = gfc_diagnostic_starter; + diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; + global_dc->caret_chars[0] = '^'; + global_dc->caret_chars[1] = '^'; +} diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c deleted file mode 100644 index 20b88a8..0000000 --- a/gcc/fortran/expr.c +++ /dev/null @@ -1,6507 +0,0 @@ -/* Routines for manipulation of expression nodes. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "arith.h" -#include "match.h" -#include "target-memory.h" /* for gfc_convert_boz */ -#include "constructor.h" -#include "tree.h" - - -/* The following set of functions provide access to gfc_expr* of - various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. - - There are two functions available elsewhere that provide - slightly different flavours of variables. Namely: - expr.c (gfc_get_variable_expr) - symbol.c (gfc_lval_expr_from_sym) - TODO: Merge these functions, if possible. */ - -/* Get a new expression node. */ - -gfc_expr * -gfc_get_expr (void) -{ - gfc_expr *e; - - e = XCNEW (gfc_expr); - gfc_clear_ts (&e->ts); - e->shape = NULL; - e->ref = NULL; - e->symtree = NULL; - return e; -} - - -/* Get a new expression node that is an array constructor - of given type and kind. */ - -gfc_expr * -gfc_get_array_expr (bt type, int kind, locus *where) -{ - gfc_expr *e; - - e = gfc_get_expr (); - e->expr_type = EXPR_ARRAY; - e->value.constructor = NULL; - e->rank = 1; - e->shape = NULL; - - e->ts.type = type; - e->ts.kind = kind; - if (where) - e->where = *where; - - return e; -} - - -/* Get a new expression node that is the NULL expression. */ - -gfc_expr * -gfc_get_null_expr (locus *where) -{ - gfc_expr *e; - - e = gfc_get_expr (); - e->expr_type = EXPR_NULL; - e->ts.type = BT_UNKNOWN; - - if (where) - e->where = *where; - - return e; -} - - -/* Get a new expression node that is an operator expression node. */ - -gfc_expr * -gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, - gfc_expr *op1, gfc_expr *op2) -{ - gfc_expr *e; - - e = gfc_get_expr (); - e->expr_type = EXPR_OP; - e->value.op.op = op; - e->value.op.op1 = op1; - e->value.op.op2 = op2; - - if (where) - e->where = *where; - - return e; -} - - -/* Get a new expression node that is an structure constructor - of given type and kind. */ - -gfc_expr * -gfc_get_structure_constructor_expr (bt type, int kind, locus *where) -{ - gfc_expr *e; - - e = gfc_get_expr (); - e->expr_type = EXPR_STRUCTURE; - e->value.constructor = NULL; - - e->ts.type = type; - e->ts.kind = kind; - if (where) - e->where = *where; - - return e; -} - - -/* Get a new expression node that is an constant of given type and kind. */ - -gfc_expr * -gfc_get_constant_expr (bt type, int kind, locus *where) -{ - gfc_expr *e; - - if (!where) - gfc_internal_error ("gfc_get_constant_expr(): locus % cannot be " - "NULL"); - - e = gfc_get_expr (); - - e->expr_type = EXPR_CONSTANT; - e->ts.type = type; - e->ts.kind = kind; - e->where = *where; - - switch (type) - { - case BT_INTEGER: - mpz_init (e->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (kind); - mpfr_init (e->value.real); - break; - - case BT_COMPLEX: - gfc_set_model_kind (kind); - mpc_init2 (e->value.complex, mpfr_get_default_prec()); - break; - - default: - break; - } - - return e; -} - - -/* Get a new expression node that is an string constant. - If no string is passed, a string of len is allocated, - blanked and null-terminated. */ - -gfc_expr * -gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len) -{ - gfc_expr *e; - gfc_char_t *dest; - - if (!src) - { - dest = gfc_get_wide_string (len + 1); - gfc_wide_memset (dest, ' ', len); - dest[len] = '\0'; - } - else - dest = gfc_char_to_widechar (src); - - e = gfc_get_constant_expr (BT_CHARACTER, kind, - where ? where : &gfc_current_locus); - e->value.character.string = dest; - e->value.character.length = len; - - return e; -} - - -/* Get a new expression node that is an integer constant. */ - -gfc_expr * -gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value) -{ - gfc_expr *p; - p = gfc_get_constant_expr (BT_INTEGER, kind, - where ? where : &gfc_current_locus); - - const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT); - wi::to_mpz (w, p->value.integer, SIGNED); - - return p; -} - - -/* Get a new expression node that is a logical constant. */ - -gfc_expr * -gfc_get_logical_expr (int kind, locus *where, bool value) -{ - gfc_expr *p; - p = gfc_get_constant_expr (BT_LOGICAL, kind, - where ? where : &gfc_current_locus); - - p->value.logical = value; - - return p; -} - - -gfc_expr * -gfc_get_iokind_expr (locus *where, io_kind k) -{ - gfc_expr *e; - - /* Set the types to something compatible with iokind. This is needed to - get through gfc_free_expr later since iokind really has no Basic Type, - BT, of its own. */ - - e = gfc_get_expr (); - e->expr_type = EXPR_CONSTANT; - e->ts.type = BT_LOGICAL; - e->value.iokind = k; - e->where = *where; - - return e; -} - - -/* Given an expression pointer, return a copy of the expression. This - subroutine is recursive. */ - -gfc_expr * -gfc_copy_expr (gfc_expr *p) -{ - gfc_expr *q; - gfc_char_t *s; - char *c; - - if (p == NULL) - return NULL; - - q = gfc_get_expr (); - *q = *p; - - switch (q->expr_type) - { - case EXPR_SUBSTRING: - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - break; - - case EXPR_CONSTANT: - /* Copy target representation, if it exists. */ - if (p->representation.string) - { - c = XCNEWVEC (char, p->representation.length + 1); - q->representation.string = c; - memcpy (c, p->representation.string, (p->representation.length + 1)); - } - - /* Copy the values of any pointer components of p->value. */ - switch (q->ts.type) - { - case BT_INTEGER: - mpz_init_set (q->value.integer, p->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (q->ts.kind); - mpfr_init (q->value.real); - mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (q->ts.kind); - mpc_init2 (q->value.complex, mpfr_get_default_prec()); - mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); - break; - - case BT_CHARACTER: - if (p->representation.string) - q->value.character.string - = gfc_char_to_widechar (q->representation.string); - else - { - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - - /* This is the case for the C_NULL_CHAR named constant. */ - if (p->value.character.length == 0 - && (p->ts.is_c_interop || p->ts.is_iso_c)) - { - *s = '\0'; - /* Need to set the length to 1 to make sure the NUL - terminator is copied. */ - q->value.character.length = 1; - } - else - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - } - break; - - case BT_HOLLERITH: - case BT_LOGICAL: - case_bt_struct: - case BT_CLASS: - case BT_ASSUMED: - break; /* Already done. */ - - case BT_BOZ: - q->boz.len = p->boz.len; - q->boz.rdx = p->boz.rdx; - q->boz.str = XCNEWVEC (char, q->boz.len + 1); - strncpy (q->boz.str, p->boz.str, p->boz.len); - break; - - case BT_PROCEDURE: - case BT_VOID: - /* Should never be reached. */ - case BT_UNKNOWN: - gfc_internal_error ("gfc_copy_expr(): Bad expr node"); - /* Not reached. */ - } - - break; - - case EXPR_OP: - switch (q->value.op.op) - { - case INTRINSIC_NOT: - case INTRINSIC_PARENTHESES: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - break; - - default: /* Binary operators. */ - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - q->value.op.op2 = gfc_copy_expr (p->value.op.op2); - break; - } - - break; - - case EXPR_FUNCTION: - q->value.function.actual = - gfc_copy_actual_arglist (p->value.function.actual); - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - q->value.compcall.actual = - gfc_copy_actual_arglist (p->value.compcall.actual); - q->value.compcall.tbp = p->value.compcall.tbp; - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - q->value.constructor = gfc_constructor_copy (p->value.constructor); - break; - - case EXPR_VARIABLE: - case EXPR_NULL: - break; - - case EXPR_UNKNOWN: - gcc_unreachable (); - } - - q->shape = gfc_copy_shape (p->shape, p->rank); - - q->ref = gfc_copy_ref (p->ref); - - if (p->param_list) - q->param_list = gfc_copy_actual_arglist (p->param_list); - - return q; -} - - -void -gfc_clear_shape (mpz_t *shape, int rank) -{ - int i; - - for (i = 0; i < rank; i++) - mpz_clear (shape[i]); -} - - -void -gfc_free_shape (mpz_t **shape, int rank) -{ - if (*shape == NULL) - return; - - gfc_clear_shape (*shape, rank); - free (*shape); - *shape = NULL; -} - - -/* Workhorse function for gfc_free_expr() that frees everything - beneath an expression node, but not the node itself. This is - useful when we want to simplify a node and replace it with - something else or the expression node belongs to another structure. */ - -static void -free_expr0 (gfc_expr *e) -{ - switch (e->expr_type) - { - case EXPR_CONSTANT: - /* Free any parts of the value that need freeing. */ - switch (e->ts.type) - { - case BT_INTEGER: - mpz_clear (e->value.integer); - break; - - case BT_REAL: - mpfr_clear (e->value.real); - break; - - case BT_CHARACTER: - free (e->value.character.string); - break; - - case BT_COMPLEX: - mpc_clear (e->value.complex); - break; - - default: - break; - } - - /* Free the representation. */ - free (e->representation.string); - - break; - - case EXPR_OP: - if (e->value.op.op1 != NULL) - gfc_free_expr (e->value.op.op1); - if (e->value.op.op2 != NULL) - gfc_free_expr (e->value.op.op2); - break; - - case EXPR_FUNCTION: - gfc_free_actual_arglist (e->value.function.actual); - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - gfc_free_actual_arglist (e->value.compcall.actual); - break; - - case EXPR_VARIABLE: - break; - - case EXPR_ARRAY: - case EXPR_STRUCTURE: - gfc_constructor_free (e->value.constructor); - break; - - case EXPR_SUBSTRING: - free (e->value.character.string); - break; - - case EXPR_NULL: - break; - - default: - gfc_internal_error ("free_expr0(): Bad expr type"); - } - - /* Free a shape array. */ - gfc_free_shape (&e->shape, e->rank); - - gfc_free_ref_list (e->ref); - - gfc_free_actual_arglist (e->param_list); - - memset (e, '\0', sizeof (gfc_expr)); -} - - -/* Free an expression node and everything beneath it. */ - -void -gfc_free_expr (gfc_expr *e) -{ - if (e == NULL) - return; - free_expr0 (e); - free (e); -} - - -/* Free an argument list and everything below it. */ - -void -gfc_free_actual_arglist (gfc_actual_arglist *a1) -{ - gfc_actual_arglist *a2; - - while (a1) - { - a2 = a1->next; - if (a1->expr) - gfc_free_expr (a1->expr); - free (a1); - a1 = a2; - } -} - - -/* Copy an arglist structure and all of the arguments. */ - -gfc_actual_arglist * -gfc_copy_actual_arglist (gfc_actual_arglist *p) -{ - gfc_actual_arglist *head, *tail, *new_arg; - - head = tail = NULL; - - for (; p; p = p->next) - { - new_arg = gfc_get_actual_arglist (); - *new_arg = *p; - - new_arg->expr = gfc_copy_expr (p->expr); - new_arg->next = NULL; - - if (head == NULL) - head = new_arg; - else - tail->next = new_arg; - - tail = new_arg; - } - - return head; -} - - -/* Free a list of reference structures. */ - -void -gfc_free_ref_list (gfc_ref *p) -{ - gfc_ref *q; - int i; - - for (; p; p = q) - { - q = p->next; - - switch (p->type) - { - case REF_ARRAY: - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) - { - gfc_free_expr (p->u.ar.start[i]); - gfc_free_expr (p->u.ar.end[i]); - gfc_free_expr (p->u.ar.stride[i]); - } - - break; - - case REF_SUBSTRING: - gfc_free_expr (p->u.ss.start); - gfc_free_expr (p->u.ss.end); - break; - - case REF_COMPONENT: - case REF_INQUIRY: - break; - } - - free (p); - } -} - - -/* Graft the *src expression onto the *dest subexpression. */ - -void -gfc_replace_expr (gfc_expr *dest, gfc_expr *src) -{ - free_expr0 (dest); - *dest = *src; - free (src); -} - - -/* Try to extract an integer constant from the passed expression node. - Return true if some error occurred, false on success. If REPORT_ERROR - is non-zero, emit error, for positive REPORT_ERROR using gfc_error, - for negative using gfc_error_now. */ - -bool -gfc_extract_int (gfc_expr *expr, int *result, int report_error) -{ - gfc_ref *ref; - - /* A KIND component is a parameter too. The expression for it - is stored in the initializer and should be consistent with - the tests below. */ - if (gfc_expr_attr(expr).pdt_kind) - { - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->u.c.component->attr.pdt_kind) - expr = ref->u.c.component->initializer; - } - } - - if (expr->expr_type != EXPR_CONSTANT) - { - if (report_error > 0) - gfc_error ("Constant expression required at %C"); - else if (report_error < 0) - gfc_error_now ("Constant expression required at %C"); - return true; - } - - if (expr->ts.type != BT_INTEGER) - { - if (report_error > 0) - gfc_error ("Integer expression required at %C"); - else if (report_error < 0) - gfc_error_now ("Integer expression required at %C"); - return true; - } - - if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) - || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) - { - if (report_error > 0) - gfc_error ("Integer value too large in expression at %C"); - else if (report_error < 0) - gfc_error_now ("Integer value too large in expression at %C"); - return true; - } - - *result = (int) mpz_get_si (expr->value.integer); - - return false; -} - - -/* Same as gfc_extract_int, but use a HWI. */ - -bool -gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error) -{ - gfc_ref *ref; - - /* A KIND component is a parameter too. The expression for it is - stored in the initializer and should be consistent with the tests - below. */ - if (gfc_expr_attr(expr).pdt_kind) - { - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->u.c.component->attr.pdt_kind) - expr = ref->u.c.component->initializer; - } - } - - if (expr->expr_type != EXPR_CONSTANT) - { - if (report_error > 0) - gfc_error ("Constant expression required at %C"); - else if (report_error < 0) - gfc_error_now ("Constant expression required at %C"); - return true; - } - - if (expr->ts.type != BT_INTEGER) - { - if (report_error > 0) - gfc_error ("Integer expression required at %C"); - else if (report_error < 0) - gfc_error_now ("Integer expression required at %C"); - return true; - } - - /* Use long_long_integer_type_node to determine when to saturate. */ - const wide_int val = wi::from_mpz (long_long_integer_type_node, - expr->value.integer, false); - - if (!wi::fits_shwi_p (val)) - { - if (report_error > 0) - gfc_error ("Integer value too large in expression at %C"); - else if (report_error < 0) - gfc_error_now ("Integer value too large in expression at %C"); - return true; - } - - *result = val.to_shwi (); - - return false; -} - - -/* Recursively copy a list of reference structures. */ - -gfc_ref * -gfc_copy_ref (gfc_ref *src) -{ - gfc_array_ref *ar; - gfc_ref *dest; - - if (src == NULL) - return NULL; - - dest = gfc_get_ref (); - dest->type = src->type; - - switch (src->type) - { - case REF_ARRAY: - ar = gfc_copy_array_ref (&src->u.ar); - dest->u.ar = *ar; - free (ar); - break; - - case REF_COMPONENT: - dest->u.c = src->u.c; - break; - - case REF_INQUIRY: - dest->u.i = src->u.i; - break; - - case REF_SUBSTRING: - dest->u.ss = src->u.ss; - dest->u.ss.start = gfc_copy_expr (src->u.ss.start); - dest->u.ss.end = gfc_copy_expr (src->u.ss.end); - break; - } - - dest->next = gfc_copy_ref (src->next); - - return dest; -} - - -/* Detect whether an expression has any vector index array references. */ - -int -gfc_has_vector_index (gfc_expr *e) -{ - gfc_ref *ref; - int i; - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY) - for (i = 0; i < ref->u.ar.dimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) - return 1; - return 0; -} - - -/* Copy a shape array. */ - -mpz_t * -gfc_copy_shape (mpz_t *shape, int rank) -{ - mpz_t *new_shape; - int n; - - if (shape == NULL) - return NULL; - - new_shape = gfc_get_shape (rank); - - for (n = 0; n < rank; n++) - mpz_init_set (new_shape[n], shape[n]); - - return new_shape; -} - - -/* Copy a shape array excluding dimension N, where N is an integer - constant expression. Dimensions are numbered in Fortran style -- - starting with ONE. - - So, if the original shape array contains R elements - { s1 ... sN-1 sN sN+1 ... sR-1 sR} - the result contains R-1 elements: - { s1 ... sN-1 sN+1 ... sR-1} - - If anything goes wrong -- N is not a constant, its value is out - of range -- or anything else, just returns NULL. */ - -mpz_t * -gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) -{ - mpz_t *new_shape, *s; - int i, n; - - if (shape == NULL - || rank <= 1 - || dim == NULL - || dim->expr_type != EXPR_CONSTANT - || dim->ts.type != BT_INTEGER) - return NULL; - - n = mpz_get_si (dim->value.integer); - n--; /* Convert to zero based index. */ - if (n < 0 || n >= rank) - return NULL; - - s = new_shape = gfc_get_shape (rank - 1); - - for (i = 0; i < rank; i++) - { - if (i == n) - continue; - mpz_init_set (*s, shape[i]); - s++; - } - - return new_shape; -} - - -/* Return the maximum kind of two expressions. In general, higher - kind numbers mean more precision for numeric types. */ - -int -gfc_kind_max (gfc_expr *e1, gfc_expr *e2) -{ - return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; -} - - -/* Returns nonzero if the type is numeric, zero otherwise. */ - -static int -numeric_type (bt type) -{ - return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; -} - - -/* Returns nonzero if the typespec is a numeric type, zero otherwise. */ - -int -gfc_numeric_ts (gfc_typespec *ts) -{ - return numeric_type (ts->type); -} - - -/* Return an expression node with an optional argument list attached. - A variable number of gfc_expr pointers are strung together in an - argument list with a NULL pointer terminating the list. */ - -gfc_expr * -gfc_build_conversion (gfc_expr *e) -{ - gfc_expr *p; - - p = gfc_get_expr (); - p->expr_type = EXPR_FUNCTION; - p->symtree = NULL; - p->value.function.actual = gfc_get_actual_arglist (); - p->value.function.actual->expr = e; - - return p; -} - - -/* Given an expression node with some sort of numeric binary - expression, insert type conversions required to make the operands - have the same type. Conversion warnings are disabled if wconversion - is set to 0. - - The exception is that the operands of an exponential don't have to - have the same type. If possible, the base is promoted to the type - of the exponent. For example, 1**2.3 becomes 1.0**2.3, but - 1.0**2 stays as it is. */ - -void -gfc_type_convert_binary (gfc_expr *e, int wconversion) -{ - gfc_expr *op1, *op2; - - op1 = e->value.op.op1; - op2 = e->value.op.op2; - - if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) - { - gfc_clear_ts (&e->ts); - return; - } - - /* Kind conversions of same type. */ - if (op1->ts.type == op2->ts.type) - { - if (op1->ts.kind == op2->ts.kind) - { - /* No type conversions. */ - e->ts = op1->ts; - goto done; - } - - if (op1->ts.kind > op2->ts.kind) - gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); - else - gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); - - e->ts = op1->ts; - goto done; - } - - /* Integer combined with real or complex. */ - if (op2->ts.type == BT_INTEGER) - { - e->ts = op1->ts; - - /* Special case for ** operator. */ - if (e->value.op.op == INTRINSIC_POWER) - goto done; - - gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); - goto done; - } - - if (op1->ts.type == BT_INTEGER) - { - e->ts = op2->ts; - gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); - goto done; - } - - /* Real combined with complex. */ - e->ts.type = BT_COMPLEX; - if (op1->ts.kind > op2->ts.kind) - e->ts.kind = op1->ts.kind; - else - e->ts.kind = op2->ts.kind; - if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) - gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); - if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) - gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); - -done: - return; -} - - -/* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in - constant expressions, except TRANSFER (c.f. item (8)), which would need - separate treatment. */ - -static bool -is_non_constant_intrinsic (gfc_expr *e) -{ - if (e->expr_type == EXPR_FUNCTION - && e->value.function.isym) - { - switch (e->value.function.isym->id) - { - case GFC_ISYM_COMMAND_ARGUMENT_COUNT: - case GFC_ISYM_GET_TEAM: - case GFC_ISYM_NULL: - case GFC_ISYM_NUM_IMAGES: - case GFC_ISYM_TEAM_NUMBER: - case GFC_ISYM_THIS_IMAGE: - return true; - - default: - return false; - } - } - return false; -} - - -/* Determine if an expression is constant in the sense of F08:7.1.12. - * This function expects that the expression has already been simplified. */ - -bool -gfc_is_constant_expr (gfc_expr *e) -{ - gfc_constructor *c; - gfc_actual_arglist *arg; - - if (e == NULL) - return true; - - switch (e->expr_type) - { - case EXPR_OP: - return (gfc_is_constant_expr (e->value.op.op1) - && (e->value.op.op2 == NULL - || gfc_is_constant_expr (e->value.op.op2))); - - case EXPR_VARIABLE: - /* The only context in which this can occur is in a parameterized - derived type declaration, so returning true is OK. */ - if (e->symtree->n.sym->attr.pdt_len - || e->symtree->n.sym->attr.pdt_kind) - return true; - return false; - - case EXPR_FUNCTION: - case EXPR_PPC: - case EXPR_COMPCALL: - gcc_assert (e->symtree || e->value.function.esym - || e->value.function.isym); - - /* Check for intrinsics excluded in constant expressions. */ - if (e->value.function.isym && is_non_constant_intrinsic (e)) - return false; - - /* Call to intrinsic with at least one argument. */ - if (e->value.function.isym && e->value.function.actual) - { - for (arg = e->value.function.actual; arg; arg = arg->next) - if (!gfc_is_constant_expr (arg->expr)) - return false; - } - - if (e->value.function.isym - && (e->value.function.isym->elemental - || e->value.function.isym->pure - || e->value.function.isym->inquiry - || e->value.function.isym->transformational)) - return true; - - return false; - - case EXPR_CONSTANT: - case EXPR_NULL: - return true; - - case EXPR_SUBSTRING: - return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) - && gfc_is_constant_expr (e->ref->u.ss.end)); - - case EXPR_ARRAY: - case EXPR_STRUCTURE: - c = gfc_constructor_first (e->value.constructor); - if ((e->expr_type == EXPR_ARRAY) && c && c->iterator) - return gfc_constant_ac (e); - - for (; c; c = gfc_constructor_next (c)) - if (!gfc_is_constant_expr (c->expr)) - return false; - - return true; - - - default: - gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); - return false; - } -} - - -/* Is true if the expression or symbol is a passed CFI descriptor. */ -bool -is_CFI_desc (gfc_symbol *sym, gfc_expr *e) -{ - if (sym == NULL - && e && e->expr_type == EXPR_VARIABLE) - sym = e->symtree->n.sym; - - if (sym && sym->attr.dummy - && sym->ns->proc_name->attr.is_bind_c - && (sym->attr.pointer - || sym->attr.allocatable - || (sym->attr.dimension - && (sym->as->type == AS_ASSUMED_SHAPE - || sym->as->type == AS_ASSUMED_RANK)) - || (sym->ts.type == BT_CHARACTER - && (!sym->ts.u.cl || !sym->ts.u.cl->length)))) - return true; - -return false; -} - - -/* Is true if an array reference is followed by a component or substring - reference. */ -bool -is_subref_array (gfc_expr * e) -{ - gfc_ref * ref; - bool seen_array; - gfc_symbol *sym; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - sym = e->symtree->n.sym; - - if (sym->attr.subref_array_pointer) - return true; - - seen_array = false; - - for (ref = e->ref; ref; ref = ref->next) - { - /* If we haven't seen the array reference and this is an intrinsic, - what follows cannot be a subreference array, unless there is a - substring reference. */ - if (!seen_array && ref->type == REF_COMPONENT - && ref->u.c.component->ts.type != BT_CHARACTER - && ref->u.c.component->ts.type != BT_CLASS - && !gfc_bt_struct (ref->u.c.component->ts.type)) - return false; - - if (ref->type == REF_ARRAY - && ref->u.ar.type != AR_ELEMENT) - seen_array = true; - - if (seen_array - && ref->type != REF_ARRAY) - return seen_array; - } - - if (sym->ts.type == BT_CLASS - && sym->attr.dummy - && CLASS_DATA (sym)->attr.dimension - && CLASS_DATA (sym)->attr.class_pointer) - return true; - - return false; -} - - -/* Try to collapse intrinsic expressions. */ - -static bool -simplify_intrinsic_op (gfc_expr *p, int type) -{ - gfc_intrinsic_op op; - gfc_expr *op1, *op2, *result; - - if (p->value.op.op == INTRINSIC_USER) - return true; - - op1 = p->value.op.op1; - op2 = p->value.op.op2; - op = p->value.op.op; - - if (!gfc_simplify_expr (op1, type)) - return false; - if (!gfc_simplify_expr (op2, type)) - return false; - - if (!gfc_is_constant_expr (op1) - || (op2 != NULL && !gfc_is_constant_expr (op2))) - return true; - - /* Rip p apart. */ - p->value.op.op1 = NULL; - p->value.op.op2 = NULL; - - switch (op) - { - case INTRINSIC_PARENTHESES: - result = gfc_parentheses (op1); - break; - - case INTRINSIC_UPLUS: - result = gfc_uplus (op1); - break; - - case INTRINSIC_UMINUS: - result = gfc_uminus (op1); - break; - - case INTRINSIC_PLUS: - result = gfc_add (op1, op2); - break; - - case INTRINSIC_MINUS: - result = gfc_subtract (op1, op2); - break; - - case INTRINSIC_TIMES: - result = gfc_multiply (op1, op2); - break; - - case INTRINSIC_DIVIDE: - result = gfc_divide (op1, op2); - break; - - case INTRINSIC_POWER: - result = gfc_power (op1, op2); - break; - - case INTRINSIC_CONCAT: - result = gfc_concat (op1, op2); - break; - - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - result = gfc_eq (op1, op2, op); - break; - - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - result = gfc_ne (op1, op2, op); - break; - - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - result = gfc_gt (op1, op2, op); - break; - - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - result = gfc_ge (op1, op2, op); - break; - - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - result = gfc_lt (op1, op2, op); - break; - - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - result = gfc_le (op1, op2, op); - break; - - case INTRINSIC_NOT: - result = gfc_not (op1); - break; - - case INTRINSIC_AND: - result = gfc_and (op1, op2); - break; - - case INTRINSIC_OR: - result = gfc_or (op1, op2); - break; - - case INTRINSIC_EQV: - result = gfc_eqv (op1, op2); - break; - - case INTRINSIC_NEQV: - result = gfc_neqv (op1, op2); - break; - - default: - gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); - } - - if (result == NULL) - { - gfc_free_expr (op1); - gfc_free_expr (op2); - return false; - } - - result->rank = p->rank; - result->where = p->where; - gfc_replace_expr (p, result); - - return true; -} - - -/* Subroutine to simplify constructor expressions. Mutually recursive - with gfc_simplify_expr(). */ - -static bool -simplify_constructor (gfc_constructor_base base, int type) -{ - gfc_constructor *c; - gfc_expr *p; - - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - if (c->iterator - && (!gfc_simplify_expr(c->iterator->start, type) - || !gfc_simplify_expr (c->iterator->end, type) - || !gfc_simplify_expr (c->iterator->step, type))) - return false; - - if (c->expr) - { - /* Try and simplify a copy. Replace the original if successful - but keep going through the constructor at all costs. Not - doing so can make a dog's dinner of complicated things. */ - p = gfc_copy_expr (c->expr); - - if (!gfc_simplify_expr (p, type)) - { - gfc_free_expr (p); - continue; - } - - gfc_replace_expr (c->expr, p); - } - } - - return true; -} - - -/* Pull a single array element out of an array constructor. */ - -static bool -find_array_element (gfc_constructor_base base, gfc_array_ref *ar, - gfc_constructor **rval) -{ - unsigned long nelemen; - int i; - mpz_t delta; - mpz_t offset; - mpz_t span; - mpz_t tmp; - gfc_constructor *cons; - gfc_expr *e; - bool t; - - t = true; - e = NULL; - - mpz_init_set_ui (offset, 0); - mpz_init (delta); - mpz_init (tmp); - mpz_init_set_ui (span, 1); - for (i = 0; i < ar->dimen; i++) - { - if (!gfc_reduce_init_expr (ar->as->lower[i]) - || !gfc_reduce_init_expr (ar->as->upper[i]) - || ar->as->upper[i]->expr_type != EXPR_CONSTANT - || ar->as->lower[i]->expr_type != EXPR_CONSTANT) - { - t = false; - cons = NULL; - goto depart; - } - - e = ar->start[i]; - if (e->expr_type != EXPR_CONSTANT) - { - cons = NULL; - goto depart; - } - - /* Check the bounds. */ - if ((ar->as->upper[i] - && mpz_cmp (e->value.integer, - ar->as->upper[i]->value.integer) > 0) - || (mpz_cmp (e->value.integer, - ar->as->lower[i]->value.integer) < 0)) - { - gfc_error ("Index in dimension %d is out of bounds " - "at %L", i + 1, &ar->c_where[i]); - cons = NULL; - t = false; - goto depart; - } - - mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); - mpz_mul (delta, delta, span); - mpz_add (offset, offset, delta); - - mpz_set_ui (tmp, 1); - mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); - mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); - mpz_mul (span, span, tmp); - } - - for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); - cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) - { - if (cons->iterator) - { - cons = NULL; - goto depart; - } - } - -depart: - mpz_clear (delta); - mpz_clear (offset); - mpz_clear (span); - mpz_clear (tmp); - *rval = cons; - return t; -} - - -/* Find a component of a structure constructor. */ - -static gfc_constructor * -find_component_ref (gfc_constructor_base base, gfc_ref *ref) -{ - gfc_component *pick = ref->u.c.component; - gfc_constructor *c = gfc_constructor_first (base); - - gfc_symbol *dt = ref->u.c.sym; - int ext = dt->attr.extension; - - /* For extended types, check if the desired component is in one of the - * parent types. */ - while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, - pick->name, true, true, NULL)) - { - dt = dt->components->ts.u.derived; - c = gfc_constructor_first (c->expr->value.constructor); - ext--; - } - - gfc_component *comp = dt->components; - while (comp != pick) - { - comp = comp->next; - c = gfc_constructor_next (c); - } - - return c; -} - - -/* Replace an expression with the contents of a constructor, removing - the subobject reference in the process. */ - -static void -remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) -{ - gfc_expr *e; - - if (cons) - { - e = cons->expr; - cons->expr = NULL; - } - else - e = gfc_copy_expr (p); - e->ref = p->ref->next; - p->ref->next = NULL; - gfc_replace_expr (p, e); -} - - -/* Pull an array section out of an array constructor. */ - -static bool -find_array_section (gfc_expr *expr, gfc_ref *ref) -{ - int idx; - int rank; - int d; - int shape_i; - int limit; - long unsigned one = 1; - bool incr_ctr; - mpz_t start[GFC_MAX_DIMENSIONS]; - mpz_t end[GFC_MAX_DIMENSIONS]; - mpz_t stride[GFC_MAX_DIMENSIONS]; - mpz_t delta[GFC_MAX_DIMENSIONS]; - mpz_t ctr[GFC_MAX_DIMENSIONS]; - mpz_t delta_mpz; - mpz_t tmp_mpz; - mpz_t nelts; - mpz_t ptr; - gfc_constructor_base base; - gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; - gfc_expr *begin; - gfc_expr *finish; - gfc_expr *step; - gfc_expr *upper; - gfc_expr *lower; - bool t; - - t = true; - - base = expr->value.constructor; - expr->value.constructor = NULL; - - rank = ref->u.ar.as->rank; - - if (expr->shape == NULL) - expr->shape = gfc_get_shape (rank); - - mpz_init_set_ui (delta_mpz, one); - mpz_init_set_ui (nelts, one); - mpz_init (tmp_mpz); - - /* Do the initialization now, so that we can cleanup without - keeping track of where we were. */ - for (d = 0; d < rank; d++) - { - mpz_init (delta[d]); - mpz_init (start[d]); - mpz_init (end[d]); - mpz_init (ctr[d]); - mpz_init (stride[d]); - vecsub[d] = NULL; - } - - /* Build the counters to clock through the array reference. */ - shape_i = 0; - for (d = 0; d < rank; d++) - { - /* Make this stretch of code easier on the eye! */ - begin = ref->u.ar.start[d]; - finish = ref->u.ar.end[d]; - step = ref->u.ar.stride[d]; - lower = ref->u.ar.as->lower[d]; - upper = ref->u.ar.as->upper[d]; - - if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ - { - gfc_constructor *ci; - gcc_assert (begin); - - if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) - { - t = false; - goto cleanup; - } - - gcc_assert (begin->rank == 1); - /* Zero-sized arrays have no shape and no elements, stop early. */ - if (!begin->shape) - { - mpz_init_set_ui (nelts, 0); - break; - } - - vecsub[d] = gfc_constructor_first (begin->value.constructor); - mpz_set (ctr[d], vecsub[d]->expr->value.integer); - mpz_mul (nelts, nelts, begin->shape[0]); - mpz_set (expr->shape[shape_i++], begin->shape[0]); - - /* Check bounds. */ - for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) - { - if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 - || mpz_cmp (ci->expr->value.integer, - lower->value.integer) < 0) - { - gfc_error ("index in dimension %d is out of bounds " - "at %L", d + 1, &ref->u.ar.c_where[d]); - t = false; - goto cleanup; - } - } - } - else - { - if ((begin && begin->expr_type != EXPR_CONSTANT) - || (finish && finish->expr_type != EXPR_CONSTANT) - || (step && step->expr_type != EXPR_CONSTANT)) - { - t = false; - goto cleanup; - } - - /* Obtain the stride. */ - if (step) - mpz_set (stride[d], step->value.integer); - else - mpz_set_ui (stride[d], one); - - if (mpz_cmp_ui (stride[d], 0) == 0) - mpz_set_ui (stride[d], one); - - /* Obtain the start value for the index. */ - if (begin) - mpz_set (start[d], begin->value.integer); - else - mpz_set (start[d], lower->value.integer); - - mpz_set (ctr[d], start[d]); - - /* Obtain the end value for the index. */ - if (finish) - mpz_set (end[d], finish->value.integer); - else - mpz_set (end[d], upper->value.integer); - - /* Separate 'if' because elements sometimes arrive with - non-null end. */ - if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) - mpz_set (end [d], begin->value.integer); - - /* Check the bounds. */ - if (mpz_cmp (ctr[d], upper->value.integer) > 0 - || mpz_cmp (end[d], upper->value.integer) > 0 - || mpz_cmp (ctr[d], lower->value.integer) < 0 - || mpz_cmp (end[d], lower->value.integer) < 0) - { - gfc_error ("index in dimension %d is out of bounds " - "at %L", d + 1, &ref->u.ar.c_where[d]); - t = false; - goto cleanup; - } - - /* Calculate the number of elements and the shape. */ - mpz_set (tmp_mpz, stride[d]); - mpz_add (tmp_mpz, end[d], tmp_mpz); - mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); - mpz_div (tmp_mpz, tmp_mpz, stride[d]); - mpz_mul (nelts, nelts, tmp_mpz); - - /* An element reference reduces the rank of the expression; don't - add anything to the shape array. */ - if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) - mpz_set (expr->shape[shape_i++], tmp_mpz); - } - - /* Calculate the 'stride' (=delta) for conversion of the - counter values into the index along the constructor. */ - mpz_set (delta[d], delta_mpz); - mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); - mpz_add_ui (tmp_mpz, tmp_mpz, one); - mpz_mul (delta_mpz, delta_mpz, tmp_mpz); - } - - mpz_init (ptr); - cons = gfc_constructor_first (base); - - /* Now clock through the array reference, calculating the index in - the source constructor and transferring the elements to the new - constructor. */ - for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) - { - mpz_init_set_ui (ptr, 0); - - incr_ctr = true; - for (d = 0; d < rank; d++) - { - mpz_set (tmp_mpz, ctr[d]); - mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); - mpz_mul (tmp_mpz, tmp_mpz, delta[d]); - mpz_add (ptr, ptr, tmp_mpz); - - if (!incr_ctr) continue; - - if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ - { - gcc_assert(vecsub[d]); - - if (!gfc_constructor_next (vecsub[d])) - vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); - else - { - vecsub[d] = gfc_constructor_next (vecsub[d]); - incr_ctr = false; - } - mpz_set (ctr[d], vecsub[d]->expr->value.integer); - } - else - { - mpz_add (ctr[d], ctr[d], stride[d]); - - if (mpz_cmp_ui (stride[d], 0) > 0 - ? mpz_cmp (ctr[d], end[d]) > 0 - : mpz_cmp (ctr[d], end[d]) < 0) - mpz_set (ctr[d], start[d]); - else - incr_ctr = false; - } - } - - limit = mpz_get_ui (ptr); - if (limit >= flag_max_array_constructor) - { - gfc_error ("The number of elements in the array constructor " - "at %L requires an increase of the allowed %d " - "upper limit. See %<-fmax-array-constructor%> " - "option", &expr->where, flag_max_array_constructor); - return false; - } - - cons = gfc_constructor_lookup (base, limit); - gcc_assert (cons); - gfc_constructor_append_expr (&expr->value.constructor, - gfc_copy_expr (cons->expr), NULL); - } - - mpz_clear (ptr); - -cleanup: - - mpz_clear (delta_mpz); - mpz_clear (tmp_mpz); - mpz_clear (nelts); - for (d = 0; d < rank; d++) - { - mpz_clear (delta[d]); - mpz_clear (start[d]); - mpz_clear (end[d]); - mpz_clear (ctr[d]); - mpz_clear (stride[d]); - } - gfc_constructor_free (base); - return t; -} - -/* Pull a substring out of an expression. */ - -static bool -find_substring_ref (gfc_expr *p, gfc_expr **newp) -{ - gfc_charlen_t end; - gfc_charlen_t start; - gfc_charlen_t length; - gfc_char_t *chr; - - if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT - || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) - return false; - - *newp = gfc_copy_expr (p); - free ((*newp)->value.character.string); - - end = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.end->value.integer); - start = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.start->value.integer); - if (end >= start) - length = end - start + 1; - else - length = 0; - - chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); - (*newp)->value.character.length = length; - memcpy (chr, &p->value.character.string[start - 1], - length * sizeof (gfc_char_t)); - chr[length] = '\0'; - return true; -} - - -/* Pull an inquiry result out of an expression. */ - -static bool -find_inquiry_ref (gfc_expr *p, gfc_expr **newp) -{ - gfc_ref *ref; - gfc_ref *inquiry = NULL; - gfc_expr *tmp; - - tmp = gfc_copy_expr (p); - - if (tmp->ref && tmp->ref->type == REF_INQUIRY) - { - inquiry = tmp->ref; - tmp->ref = NULL; - } - else - { - for (ref = tmp->ref; ref; ref = ref->next) - if (ref->next && ref->next->type == REF_INQUIRY) - { - inquiry = ref->next; - ref->next = NULL; - } - } - - if (!inquiry) - { - gfc_free_expr (tmp); - return false; - } - - gfc_resolve_expr (tmp); - - /* In principle there can be more than one inquiry reference. */ - for (; inquiry; inquiry = inquiry->next) - { - switch (inquiry->u.i) - { - case INQUIRY_LEN: - if (tmp->ts.type != BT_CHARACTER) - goto cleanup; - - if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) - goto cleanup; - - if (tmp->ts.u.cl->length - && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) - *newp = gfc_copy_expr (tmp->ts.u.cl->length); - else if (tmp->expr_type == EXPR_CONSTANT) - *newp = gfc_get_int_expr (gfc_default_integer_kind, - NULL, tmp->value.character.length); - else - goto cleanup; - - break; - - case INQUIRY_KIND: - if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS) - goto cleanup; - - if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) - goto cleanup; - - *newp = gfc_get_int_expr (gfc_default_integer_kind, - NULL, tmp->ts.kind); - break; - - case INQUIRY_RE: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) - goto cleanup; - - if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) - goto cleanup; - - *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); - mpfr_set ((*newp)->value.real, - mpc_realref (tmp->value.complex), GFC_RND_MODE); - break; - - case INQUIRY_IM: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) - goto cleanup; - - if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) - goto cleanup; - - *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); - mpfr_set ((*newp)->value.real, - mpc_imagref (tmp->value.complex), GFC_RND_MODE); - break; - } - tmp = gfc_copy_expr (*newp); - } - - if (!(*newp)) - goto cleanup; - else if ((*newp)->expr_type != EXPR_CONSTANT) - { - gfc_free_expr (*newp); - goto cleanup; - } - - gfc_free_expr (tmp); - return true; - -cleanup: - gfc_free_expr (tmp); - return false; -} - - - -/* Simplify a subobject reference of a constructor. This occurs when - parameter variable values are substituted. */ - -static bool -simplify_const_ref (gfc_expr *p) -{ - gfc_constructor *cons, *c; - gfc_expr *newp = NULL; - gfc_ref *last_ref; - - while (p->ref) - { - switch (p->ref->type) - { - case REF_ARRAY: - switch (p->ref->u.ar.type) - { - case AR_ELEMENT: - /* , parameter :: x() = scalar_expr - will generate this. */ - if (p->expr_type != EXPR_ARRAY) - { - remove_subobject_ref (p, NULL); - break; - } - if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) - return false; - - if (!cons) - return true; - - remove_subobject_ref (p, cons); - break; - - case AR_SECTION: - if (!find_array_section (p, p->ref)) - return false; - p->ref->u.ar.type = AR_FULL; - - /* Fall through. */ - - case AR_FULL: - if (p->ref->next != NULL - && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type))) - { - for (c = gfc_constructor_first (p->value.constructor); - c; c = gfc_constructor_next (c)) - { - c->expr->ref = gfc_copy_ref (p->ref->next); - if (!simplify_const_ref (c->expr)) - return false; - } - - if (gfc_bt_struct (p->ts.type) - && p->ref->next - && (c = gfc_constructor_first (p->value.constructor))) - { - /* There may have been component references. */ - p->ts = c->expr->ts; - } - - last_ref = p->ref; - for (; last_ref->next; last_ref = last_ref->next) {}; - - if (p->ts.type == BT_CHARACTER - && last_ref->type == REF_SUBSTRING) - { - /* If this is a CHARACTER array and we possibly took - a substring out of it, update the type-spec's - character length according to the first element - (as all should have the same length). */ - gfc_charlen_t string_len; - if ((c = gfc_constructor_first (p->value.constructor))) - { - const gfc_expr* first = c->expr; - gcc_assert (first->expr_type == EXPR_CONSTANT); - gcc_assert (first->ts.type == BT_CHARACTER); - string_len = first->value.character.length; - } - else - string_len = 0; - - if (!p->ts.u.cl) - { - if (p->symtree) - p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, - NULL); - else - p->ts.u.cl = gfc_new_charlen (gfc_current_ns, - NULL); - } - else - gfc_free_expr (p->ts.u.cl->length); - - p->ts.u.cl->length - = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, string_len); - } - } - gfc_free_ref_list (p->ref); - p->ref = NULL; - break; - - default: - return true; - } - - break; - - case REF_COMPONENT: - cons = find_component_ref (p->value.constructor, p->ref); - remove_subobject_ref (p, cons); - break; - - case REF_INQUIRY: - if (!find_inquiry_ref (p, &newp)) - return false; - - gfc_replace_expr (p, newp); - gfc_free_ref_list (p->ref); - p->ref = NULL; - break; - - case REF_SUBSTRING: - if (!find_substring_ref (p, &newp)) - return false; - - gfc_replace_expr (p, newp); - gfc_free_ref_list (p->ref); - p->ref = NULL; - break; - } - } - - return true; -} - - -/* Simplify a chain of references. */ - -static bool -simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p) -{ - int n; - gfc_expr *newp; - - for (; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - for (n = 0; n < ref->u.ar.dimen; n++) - { - if (!gfc_simplify_expr (ref->u.ar.start[n], type)) - return false; - if (!gfc_simplify_expr (ref->u.ar.end[n], type)) - return false; - if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) - return false; - } - break; - - case REF_SUBSTRING: - if (!gfc_simplify_expr (ref->u.ss.start, type)) - return false; - if (!gfc_simplify_expr (ref->u.ss.end, type)) - return false; - break; - - case REF_INQUIRY: - if (!find_inquiry_ref (*p, &newp)) - return false; - - gfc_replace_expr (*p, newp); - gfc_free_ref_list ((*p)->ref); - (*p)->ref = NULL; - return true; - - default: - break; - } - } - return true; -} - - -/* Try to substitute the value of a parameter variable. */ - -static bool -simplify_parameter_variable (gfc_expr *p, int type) -{ - gfc_expr *e; - bool t; - - /* Set rank and check array ref; as resolve_variable calls - gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */ - if (!gfc_resolve_ref (p)) - { - gfc_error_check (); - return false; - } - gfc_expression_rank (p); - - /* Is this an inquiry? */ - bool inquiry = false; - gfc_ref* ref = p->ref; - while (ref) - { - if (ref->type == REF_INQUIRY) - break; - ref = ref->next; - } - if (ref && ref->type == REF_INQUIRY) - inquiry = ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND; - - if (gfc_is_size_zero_array (p)) - { - if (p->expr_type == EXPR_ARRAY) - return true; - - e = gfc_get_expr (); - e->expr_type = EXPR_ARRAY; - e->ts = p->ts; - e->rank = p->rank; - e->value.constructor = NULL; - e->shape = gfc_copy_shape (p->shape, p->rank); - e->where = p->where; - /* If %kind and %len are not used then we're done, otherwise - drop through for simplification. */ - if (!inquiry) - { - gfc_replace_expr (p, e); - return true; - } - } - else - { - e = gfc_copy_expr (p->symtree->n.sym->value); - if (e == NULL) - return false; - - gfc_free_shape (&e->shape, e->rank); - e->shape = gfc_copy_shape (p->shape, p->rank); - e->rank = p->rank; - - if (e->ts.type == BT_CHARACTER && p->ts.u.cl) - e->ts = p->ts; - } - - if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL) - e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl); - - /* Do not copy subobject refs for constant. */ - if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) - e->ref = gfc_copy_ref (p->ref); - t = gfc_simplify_expr (e, type); - e->where = p->where; - - /* Only use the simplification if it eliminated all subobject references. */ - if (t && !e->ref) - gfc_replace_expr (p, e); - else - gfc_free_expr (e); - - return t; -} - - -static bool -scalarize_intrinsic_call (gfc_expr *, bool init_flag); - -/* Given an expression, simplify it by collapsing constant - expressions. Most simplification takes place when the expression - tree is being constructed. If an intrinsic function is simplified - at some point, we get called again to collapse the result against - other constants. - - We work by recursively simplifying expression nodes, simplifying - intrinsic functions where possible, which can lead to further - constant collapsing. If an operator has constant operand(s), we - rip the expression apart, and rebuild it, hoping that it becomes - something simpler. - - The expression type is defined for: - 0 Basic expression parsing - 1 Simplifying array constructors -- will substitute - iterator values. - Returns false on error, true otherwise. - NOTE: Will return true even if the expression cannot be simplified. */ - -bool -gfc_simplify_expr (gfc_expr *p, int type) -{ - gfc_actual_arglist *ap; - gfc_intrinsic_sym* isym = NULL; - - - if (p == NULL) - return true; - - switch (p->expr_type) - { - case EXPR_CONSTANT: - if (p->ref && p->ref->type == REF_INQUIRY) - simplify_ref_chain (p->ref, type, &p); - break; - case EXPR_NULL: - break; - - case EXPR_FUNCTION: - // For array-bound functions, we don't need to optimize - // the 'array' argument. In particular, if the argument - // is a PARAMETER, simplifying might convert an EXPR_VARIABLE - // into an EXPR_ARRAY; the latter has lbound = 1, the former - // can have any lbound. - ap = p->value.function.actual; - if (p->value.function.isym && - (p->value.function.isym->id == GFC_ISYM_LBOUND - || p->value.function.isym->id == GFC_ISYM_UBOUND - || p->value.function.isym->id == GFC_ISYM_LCOBOUND - || p->value.function.isym->id == GFC_ISYM_UCOBOUND - || p->value.function.isym->id == GFC_ISYM_SHAPE)) - ap = ap->next; - - for ( ; ap; ap = ap->next) - if (!gfc_simplify_expr (ap->expr, type)) - return false; - - if (p->value.function.isym != NULL - && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) - return false; - - if (p->symtree && (p->value.function.isym || p->ts.type == BT_UNKNOWN)) - { - isym = gfc_find_function (p->symtree->n.sym->name); - if (isym && isym->elemental) - scalarize_intrinsic_call (p, false); - } - - break; - - case EXPR_SUBSTRING: - if (!simplify_ref_chain (p->ref, type, &p)) - return false; - - if (gfc_is_constant_expr (p)) - { - gfc_char_t *s; - HOST_WIDE_INT start, end; - - start = 0; - if (p->ref && p->ref->u.ss.start) - { - gfc_extract_hwi (p->ref->u.ss.start, &start); - start--; /* Convert from one-based to zero-based. */ - } - - end = p->value.character.length; - if (p->ref && p->ref->u.ss.end) - gfc_extract_hwi (p->ref->u.ss.end, &end); - - if (end < start) - end = start; - - s = gfc_get_wide_string (end - start + 2); - memcpy (s, p->value.character.string + start, - (end - start) * sizeof (gfc_char_t)); - s[end - start + 1] = '\0'; /* TODO: C-style string. */ - free (p->value.character.string); - p->value.character.string = s; - p->value.character.length = end - start; - p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, - p->value.character.length); - gfc_free_ref_list (p->ref); - p->ref = NULL; - p->expr_type = EXPR_CONSTANT; - } - break; - - case EXPR_OP: - if (!simplify_intrinsic_op (p, type)) - return false; - break; - - case EXPR_VARIABLE: - /* Only substitute array parameter variables if we are in an - initialization expression, or we want a subsection. */ - if (p->symtree->n.sym->attr.flavor == FL_PARAMETER - && (gfc_init_expr_flag || p->ref - || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) - { - if (!simplify_parameter_variable (p, type)) - return false; - break; - } - - if (type == 1) - { - gfc_simplify_iterator_var (p); - } - - /* Simplify subcomponent references. */ - if (!simplify_ref_chain (p->ref, type, &p)) - return false; - - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - if (!simplify_ref_chain (p->ref, type, &p)) - return false; - - /* If the following conditions hold, we found something like kind type - inquiry of the form a(2)%kind while simplify the ref chain. */ - if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape) - return true; - - if (!simplify_constructor (p->value.constructor, type)) - return false; - - if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY - && p->ref->u.ar.type == AR_FULL) - gfc_expand_constructor (p, false); - - if (!simplify_const_ref (p)) - return false; - - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - break; - - case EXPR_UNKNOWN: - gcc_unreachable (); - } - - return true; -} - - -/* Try simplification of an expression via gfc_simplify_expr. - When an error occurs (arithmetic or otherwise), roll back. */ - -bool -gfc_try_simplify_expr (gfc_expr *e, int type) -{ - gfc_expr *n; - bool t, saved_div0; - - if (e == NULL || e->expr_type == EXPR_CONSTANT) - return true; - - saved_div0 = gfc_seen_div0; - gfc_seen_div0 = false; - n = gfc_copy_expr (e); - t = gfc_simplify_expr (n, type) && !gfc_seen_div0; - if (t) - gfc_replace_expr (e, n); - else - gfc_free_expr (n); - gfc_seen_div0 = saved_div0; - return t; -} - - -/* Returns the type of an expression with the exception that iterator - variables are automatically integers no matter what else they may - be declared as. */ - -static bt -et0 (gfc_expr *e) -{ - if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) - return BT_INTEGER; - - return e->ts.type; -} - - -/* Scalarize an expression for an elemental intrinsic call. */ - -static bool -scalarize_intrinsic_call (gfc_expr *e, bool init_flag) -{ - gfc_actual_arglist *a, *b; - gfc_constructor_base ctor; - gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */ - gfc_constructor *ci, *new_ctor; - gfc_expr *expr, *old, *p; - int n, i, rank[5], array_arg; - - if (e == NULL) - return false; - - a = e->value.function.actual; - for (; a; a = a->next) - if (a->expr && !gfc_is_constant_expr (a->expr)) - return false; - - /* Find which, if any, arguments are arrays. Assume that the old - expression carries the type information and that the first arg - that is an array expression carries all the shape information.*/ - n = array_arg = 0; - a = e->value.function.actual; - for (; a; a = a->next) - { - n++; - if (!a->expr || a->expr->expr_type != EXPR_ARRAY) - continue; - array_arg = n; - expr = gfc_copy_expr (a->expr); - break; - } - - if (!array_arg) - return false; - - old = gfc_copy_expr (e); - - gfc_constructor_free (expr->value.constructor); - expr->value.constructor = NULL; - expr->ts = old->ts; - expr->where = old->where; - expr->expr_type = EXPR_ARRAY; - - /* Copy the array argument constructors into an array, with nulls - for the scalars. */ - n = 0; - a = old->value.function.actual; - for (; a; a = a->next) - { - /* Check that this is OK for an initialization expression. */ - if (a->expr && init_flag && !gfc_check_init_expr (a->expr)) - goto cleanup; - - rank[n] = 0; - if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) - { - rank[n] = a->expr->rank; - ctor = a->expr->symtree->n.sym->value->value.constructor; - args[n] = gfc_constructor_first (ctor); - } - else if (a->expr && a->expr->expr_type == EXPR_ARRAY) - { - if (a->expr->rank) - rank[n] = a->expr->rank; - else - rank[n] = 1; - ctor = gfc_constructor_copy (a->expr->value.constructor); - args[n] = gfc_constructor_first (ctor); - } - else - args[n] = NULL; - - n++; - } - - /* Using the array argument as the master, step through the array - calling the function for each element and advancing the array - constructors together. */ - for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) - { - new_ctor = gfc_constructor_append_expr (&expr->value.constructor, - gfc_copy_expr (old), NULL); - - gfc_free_actual_arglist (new_ctor->expr->value.function.actual); - a = NULL; - b = old->value.function.actual; - for (i = 0; i < n; i++) - { - if (a == NULL) - new_ctor->expr->value.function.actual - = a = gfc_get_actual_arglist (); - else - { - a->next = gfc_get_actual_arglist (); - a = a->next; - } - - if (args[i]) - a->expr = gfc_copy_expr (args[i]->expr); - else - a->expr = gfc_copy_expr (b->expr); - - b = b->next; - } - - /* Simplify the function calls. If the simplification fails, the - error will be flagged up down-stream or the library will deal - with it. */ - p = gfc_copy_expr (new_ctor->expr); - - if (!gfc_simplify_expr (p, init_flag)) - gfc_free_expr (p); - else - gfc_replace_expr (new_ctor->expr, p); - - for (i = 0; i < n; i++) - if (args[i]) - args[i] = gfc_constructor_next (args[i]); - - for (i = 1; i < n; i++) - if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) - || (args[i] == NULL && args[array_arg - 1] != NULL))) - goto compliance; - } - - free_expr0 (e); - *e = *expr; - /* Free "expr" but not the pointers it contains. */ - free (expr); - gfc_free_expr (old); - return true; - -compliance: - gfc_error_now ("elemental function arguments at %C are not compliant"); - -cleanup: - gfc_free_expr (expr); - gfc_free_expr (old); - return false; -} - - -static bool -check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) -{ - gfc_expr *op1 = e->value.op.op1; - gfc_expr *op2 = e->value.op.op2; - - if (!(*check_function)(op1)) - return false; - - switch (e->value.op.op) - { - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - if (!numeric_type (et0 (op1))) - goto not_numeric; - break; - - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - if (!(*check_function)(op2)) - return false; - - if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) - && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) - { - gfc_error ("Numeric or CHARACTER operands are required in " - "expression at %L", &e->where); - return false; - } - break; - - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: - if (!(*check_function)(op2)) - return false; - - if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) - goto not_numeric; - - break; - - case INTRINSIC_CONCAT: - if (!(*check_function)(op2)) - return false; - - if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) - { - gfc_error ("Concatenation operator in expression at %L " - "must have two CHARACTER operands", &op1->where); - return false; - } - - if (op1->ts.kind != op2->ts.kind) - { - gfc_error ("Concat operator at %L must concatenate strings of the " - "same kind", &e->where); - return false; - } - - break; - - case INTRINSIC_NOT: - if (et0 (op1) != BT_LOGICAL) - { - gfc_error (".NOT. operator in expression at %L must have a LOGICAL " - "operand", &op1->where); - return false; - } - - break; - - case INTRINSIC_AND: - case INTRINSIC_OR: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: - if (!(*check_function)(op2)) - return false; - - if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) - { - gfc_error ("LOGICAL operands are required in expression at %L", - &e->where); - return false; - } - - break; - - case INTRINSIC_PARENTHESES: - break; - - default: - gfc_error ("Only intrinsic operators can be used in expression at %L", - &e->where); - return false; - } - - return true; - -not_numeric: - gfc_error ("Numeric operands are required in expression at %L", &e->where); - - return false; -} - -/* F2003, 7.1.7 (3): In init expression, allocatable components - must not be data-initialized. */ -static bool -check_alloc_comp_init (gfc_expr *e) -{ - gfc_component *comp; - gfc_constructor *ctor; - - gcc_assert (e->expr_type == EXPR_STRUCTURE); - gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS); - - for (comp = e->ts.u.derived->components, - ctor = gfc_constructor_first (e->value.constructor); - comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) - { - if (comp->attr.allocatable && ctor->expr - && ctor->expr->expr_type != EXPR_NULL) - { - gfc_error ("Invalid initialization expression for ALLOCATABLE " - "component %qs in structure constructor at %L", - comp->name, &ctor->expr->where); - return false; - } - } - - return true; -} - -static match -check_init_expr_arguments (gfc_expr *e) -{ - gfc_actual_arglist *ap; - - for (ap = e->value.function.actual; ap; ap = ap->next) - if (!gfc_check_init_expr (ap->expr)) - return MATCH_ERROR; - - return MATCH_YES; -} - -static bool check_restricted (gfc_expr *); - -/* F95, 7.1.6.1, Initialization expressions, (7) - F2003, 7.1.7 Initialization expression, (8) - F2008, 7.1.12 Constant expression, (4) */ - -static match -check_inquiry (gfc_expr *e, int not_restricted) -{ - const char *name; - const char *const *functions; - - static const char *const inquiry_func_f95[] = { - "lbound", "shape", "size", "ubound", - "bit_size", "len", "kind", - "digits", "epsilon", "huge", "maxexponent", "minexponent", - "precision", "radix", "range", "tiny", - NULL - }; - - static const char *const inquiry_func_f2003[] = { - "lbound", "shape", "size", "ubound", - "bit_size", "len", "kind", - "digits", "epsilon", "huge", "maxexponent", "minexponent", - "precision", "radix", "range", "tiny", - "new_line", NULL - }; - - /* std=f2008+ or -std=gnu */ - static const char *const inquiry_func_gnu[] = { - "lbound", "shape", "size", "ubound", - "bit_size", "len", "kind", - "digits", "epsilon", "huge", "maxexponent", "minexponent", - "precision", "radix", "range", "tiny", - "new_line", "storage_size", NULL - }; - - int i = 0; - gfc_actual_arglist *ap; - gfc_symbol *sym; - gfc_symbol *asym; - - if (!e->value.function.isym - || !e->value.function.isym->inquiry) - return MATCH_NO; - - /* An undeclared parameter will get us here (PR25018). */ - if (e->symtree == NULL) - return MATCH_NO; - - sym = e->symtree->n.sym; - - if (sym->from_intmod) - { - if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV - && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS - && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) - return MATCH_NO; - - if (sym->from_intmod == INTMOD_ISO_C_BINDING - && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) - return MATCH_NO; - } - else - { - name = sym->name; - - functions = inquiry_func_gnu; - if (gfc_option.warn_std & GFC_STD_F2003) - functions = inquiry_func_f2003; - if (gfc_option.warn_std & GFC_STD_F95) - functions = inquiry_func_f95; - - for (i = 0; functions[i]; i++) - if (strcmp (functions[i], name) == 0) - break; - - if (functions[i] == NULL) - return MATCH_ERROR; - } - - /* At this point we have an inquiry function with a variable argument. The - type of the variable might be undefined, but we need it now, because the - arguments of these functions are not allowed to be undefined. */ - - for (ap = e->value.function.actual; ap; ap = ap->next) - { - if (!ap->expr) - continue; - - asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL; - - if (ap->expr->ts.type == BT_UNKNOWN) - { - if (asym && asym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (asym, 0, gfc_current_ns)) - return MATCH_NO; - - ap->expr->ts = asym->ts; - } - - if (asym && asym->assoc && asym->assoc->target - && asym->assoc->target->expr_type == EXPR_CONSTANT) - { - gfc_free_expr (ap->expr); - ap->expr = gfc_copy_expr (asym->assoc->target); - } - - /* Assumed character length will not reduce to a constant expression - with LEN, as required by the standard. */ - if (i == 5 && not_restricted && asym - && asym->ts.type == BT_CHARACTER - && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL) - || asym->ts.deferred)) - { - gfc_error ("Assumed or deferred character length variable %qs " - "in constant expression at %L", - asym->name, &ap->expr->where); - return MATCH_ERROR; - } - else if (not_restricted && !gfc_check_init_expr (ap->expr)) - return MATCH_ERROR; - - if (not_restricted == 0 - && ap->expr->expr_type != EXPR_VARIABLE - && !check_restricted (ap->expr)) - return MATCH_ERROR; - - if (not_restricted == 0 - && ap->expr->expr_type == EXPR_VARIABLE - && asym->attr.dummy && asym->attr.optional) - return MATCH_NO; - } - - return MATCH_YES; -} - - -/* F95, 7.1.6.1, Initialization expressions, (5) - F2003, 7.1.7 Initialization expression, (5) */ - -static match -check_transformational (gfc_expr *e) -{ - static const char * const trans_func_f95[] = { - "repeat", "reshape", "selected_int_kind", - "selected_real_kind", "transfer", "trim", NULL - }; - - static const char * const trans_func_f2003[] = { - "all", "any", "count", "dot_product", "matmul", "null", "pack", - "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", - "selected_real_kind", "spread", "sum", "transfer", "transpose", - "trim", "unpack", NULL - }; - - static const char * const trans_func_f2008[] = { - "all", "any", "count", "dot_product", "matmul", "null", "pack", - "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", - "selected_real_kind", "spread", "sum", "transfer", "transpose", - "trim", "unpack", "findloc", NULL - }; - - int i; - const char *name; - const char *const *functions; - - if (!e->value.function.isym - || !e->value.function.isym->transformational) - return MATCH_NO; - - name = e->symtree->n.sym->name; - - if (gfc_option.allow_std & GFC_STD_F2008) - functions = trans_func_f2008; - else if (gfc_option.allow_std & GFC_STD_F2003) - functions = trans_func_f2003; - else - functions = trans_func_f95; - - /* NULL() is dealt with below. */ - if (strcmp ("null", name) == 0) - return MATCH_NO; - - for (i = 0; functions[i]; i++) - if (strcmp (functions[i], name) == 0) - break; - - if (functions[i] == NULL) - { - gfc_error ("transformational intrinsic %qs at %L is not permitted " - "in an initialization expression", name, &e->where); - return MATCH_ERROR; - } - - return check_init_expr_arguments (e); -} - - -/* F95, 7.1.6.1, Initialization expressions, (6) - F2003, 7.1.7 Initialization expression, (6) */ - -static match -check_null (gfc_expr *e) -{ - if (strcmp ("null", e->symtree->n.sym->name) != 0) - return MATCH_NO; - - return check_init_expr_arguments (e); -} - - -static match -check_elemental (gfc_expr *e) -{ - if (!e->value.function.isym - || !e->value.function.isym->elemental) - return MATCH_NO; - - if (e->ts.type != BT_INTEGER - && e->ts.type != BT_CHARACTER - && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " - "initialization expression at %L", &e->where)) - return MATCH_ERROR; - - return check_init_expr_arguments (e); -} - - -static match -check_conversion (gfc_expr *e) -{ - if (!e->value.function.isym - || !e->value.function.isym->conversion) - return MATCH_NO; - - return check_init_expr_arguments (e); -} - - -/* Verify that an expression is an initialization expression. A side - effect is that the expression tree is reduced to a single constant - node if all goes well. This would normally happen when the - expression is constructed but function references are assumed to be - intrinsics in the context of initialization expressions. If - false is returned an error message has been generated. */ - -bool -gfc_check_init_expr (gfc_expr *e) -{ - match m; - bool t; - - if (e == NULL) - return true; - - switch (e->expr_type) - { - case EXPR_OP: - t = check_intrinsic_op (e, gfc_check_init_expr); - if (t) - t = gfc_simplify_expr (e, 0); - - break; - - case EXPR_FUNCTION: - t = false; - - { - bool conversion; - gfc_intrinsic_sym* isym = NULL; - gfc_symbol* sym = e->symtree->n.sym; - - /* Simplify here the intrinsics from the IEEE_ARITHMETIC and - IEEE_EXCEPTIONS modules. */ - int mod = sym->from_intmod; - if (mod == INTMOD_NONE && sym->generic) - mod = sym->generic->sym->from_intmod; - if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS) - { - gfc_expr *new_expr = gfc_simplify_ieee_functions (e); - if (new_expr) - { - gfc_replace_expr (e, new_expr); - t = true; - break; - } - } - - /* If a conversion function, e.g., __convert_i8_i4, was inserted - into an array constructor, we need to skip the error check here. - Conversion errors are caught below in scalarize_intrinsic_call. */ - conversion = e->value.function.isym - && (e->value.function.isym->conversion == 1); - - if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) - || (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO)) - { - gfc_error ("Function %qs in initialization expression at %L " - "must be an intrinsic function", - e->symtree->n.sym->name, &e->where); - break; - } - - if ((m = check_conversion (e)) == MATCH_NO - && (m = check_inquiry (e, 1)) == MATCH_NO - && (m = check_null (e)) == MATCH_NO - && (m = check_transformational (e)) == MATCH_NO - && (m = check_elemental (e)) == MATCH_NO) - { - gfc_error ("Intrinsic function %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - m = MATCH_ERROR; - } - - if (m == MATCH_ERROR) - return false; - - /* Try to scalarize an elemental intrinsic function that has an - array argument. */ - isym = gfc_find_function (e->symtree->n.sym->name); - if (isym && isym->elemental - && (t = scalarize_intrinsic_call (e, true))) - break; - } - - if (m == MATCH_YES) - t = gfc_simplify_expr (e, 0); - - break; - - case EXPR_VARIABLE: - t = true; - - /* This occurs when parsing pdt templates. */ - if (gfc_expr_attr (e).pdt_kind) - break; - - if (gfc_check_iter_variable (e)) - break; - - if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) - { - /* A PARAMETER shall not be used to define itself, i.e. - REAL, PARAMETER :: x = transfer(0, x) - is invalid. */ - if (!e->symtree->n.sym->value) - { - gfc_error ("PARAMETER %qs is used at %L before its definition " - "is complete", e->symtree->n.sym->name, &e->where); - t = false; - } - else - t = simplify_parameter_variable (e, 0); - - break; - } - - if (gfc_in_match_data ()) - break; - - t = false; - - if (e->symtree->n.sym->as) - { - switch (e->symtree->n.sym->as->type) - { - case AS_ASSUMED_SIZE: - gfc_error ("Assumed size array %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - break; - - case AS_ASSUMED_SHAPE: - gfc_error ("Assumed shape array %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - break; - - case AS_DEFERRED: - if (!e->symtree->n.sym->attr.allocatable - && !e->symtree->n.sym->attr.pointer - && e->symtree->n.sym->attr.dummy) - gfc_error ("Assumed-shape array %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - else - gfc_error ("Deferred array %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - break; - - case AS_EXPLICIT: - gfc_error ("Array %qs at %L is a variable, which does " - "not reduce to a constant expression", - e->symtree->n.sym->name, &e->where); - break; - - case AS_ASSUMED_RANK: - gfc_error ("Assumed-rank array %qs at %L is not permitted " - "in an initialization expression", - e->symtree->n.sym->name, &e->where); - break; - - default: - gcc_unreachable(); - } - } - else - gfc_error ("Parameter %qs at %L has not been declared or is " - "a variable, which does not reduce to a constant " - "expression", e->symtree->name, &e->where); - - break; - - case EXPR_CONSTANT: - case EXPR_NULL: - t = true; - break; - - case EXPR_SUBSTRING: - if (e->ref) - { - t = gfc_check_init_expr (e->ref->u.ss.start); - if (!t) - break; - - t = gfc_check_init_expr (e->ref->u.ss.end); - if (t) - t = gfc_simplify_expr (e, 0); - } - else - t = false; - break; - - case EXPR_STRUCTURE: - t = e->ts.is_iso_c ? true : false; - if (t) - break; - - t = check_alloc_comp_init (e); - if (!t) - break; - - t = gfc_check_constructor (e, gfc_check_init_expr); - if (!t) - break; - - break; - - case EXPR_ARRAY: - t = gfc_check_constructor (e, gfc_check_init_expr); - if (!t) - break; - - t = gfc_expand_constructor (e, true); - if (!t) - break; - - t = gfc_check_constructor_type (e); - break; - - default: - gfc_internal_error ("check_init_expr(): Unknown expression type"); - } - - return t; -} - -/* Reduces a general expression to an initialization expression (a constant). - This used to be part of gfc_match_init_expr. - Note that this function doesn't free the given expression on false. */ - -bool -gfc_reduce_init_expr (gfc_expr *expr) -{ - bool t; - - gfc_init_expr_flag = true; - t = gfc_resolve_expr (expr); - if (t) - t = gfc_check_init_expr (expr); - gfc_init_expr_flag = false; - - if (!t || !expr) - return false; - - if (expr->expr_type == EXPR_ARRAY) - { - if (!gfc_check_constructor_type (expr)) - return false; - if (!gfc_expand_constructor (expr, true)) - return false; - } - - return true; -} - - -/* Match an initialization expression. We work by first matching an - expression, then reducing it to a constant. */ - -match -gfc_match_init_expr (gfc_expr **result) -{ - gfc_expr *expr; - match m; - bool t; - - expr = NULL; - - gfc_init_expr_flag = true; - - m = gfc_match_expr (&expr); - if (m != MATCH_YES) - { - gfc_init_expr_flag = false; - return m; - } - - if (gfc_derived_parameter_expr (expr)) - { - *result = expr; - gfc_init_expr_flag = false; - return m; - } - - t = gfc_reduce_init_expr (expr); - if (!t) - { - gfc_free_expr (expr); - gfc_init_expr_flag = false; - return MATCH_ERROR; - } - - *result = expr; - gfc_init_expr_flag = false; - - return MATCH_YES; -} - - -/* Given an actual argument list, test to see that each argument is a - restricted expression and optionally if the expression type is - integer or character. */ - -static bool -restricted_args (gfc_actual_arglist *a) -{ - for (; a; a = a->next) - { - if (!check_restricted (a->expr)) - return false; - } - - return true; -} - - -/************* Restricted/specification expressions *************/ - - -/* Make sure a non-intrinsic function is a specification function, - * see F08:7.1.11.5. */ - -static bool -external_spec_function (gfc_expr *e) -{ - gfc_symbol *f; - - f = e->value.function.esym; - - /* IEEE functions allowed are "a reference to a transformational function - from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and - "inquiry function from the intrinsic modules IEEE_ARITHMETIC and - IEEE_EXCEPTIONS". */ - if (f->from_intmod == INTMOD_IEEE_ARITHMETIC - || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) - { - if (!strcmp (f->name, "ieee_selected_real_kind") - || !strcmp (f->name, "ieee_support_rounding") - || !strcmp (f->name, "ieee_support_flag") - || !strcmp (f->name, "ieee_support_halting") - || !strcmp (f->name, "ieee_support_datatype") - || !strcmp (f->name, "ieee_support_denormal") - || !strcmp (f->name, "ieee_support_subnormal") - || !strcmp (f->name, "ieee_support_divide") - || !strcmp (f->name, "ieee_support_inf") - || !strcmp (f->name, "ieee_support_io") - || !strcmp (f->name, "ieee_support_nan") - || !strcmp (f->name, "ieee_support_sqrt") - || !strcmp (f->name, "ieee_support_standard") - || !strcmp (f->name, "ieee_support_underflow_control")) - goto function_allowed; - } - - if (f->attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Specification function %qs at %L cannot be a statement " - "function", f->name, &e->where); - return false; - } - - if (f->attr.proc == PROC_INTERNAL) - { - gfc_error ("Specification function %qs at %L cannot be an internal " - "function", f->name, &e->where); - return false; - } - - if (!f->attr.pure && !f->attr.elemental) - { - gfc_error ("Specification function %qs at %L must be PURE", f->name, - &e->where); - return false; - } - - /* F08:7.1.11.6. */ - if (f->attr.recursive - && !gfc_notify_std (GFC_STD_F2003, - "Specification function %qs " - "at %L cannot be RECURSIVE", f->name, &e->where)) - return false; - -function_allowed: - return restricted_args (e->value.function.actual); -} - - -/* Check to see that a function reference to an intrinsic is a - restricted expression. */ - -static bool -restricted_intrinsic (gfc_expr *e) -{ - /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ - if (check_inquiry (e, 0) == MATCH_YES) - return true; - - return restricted_args (e->value.function.actual); -} - - -/* Check the expressions of an actual arglist. Used by check_restricted. */ - -static bool -check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) -{ - for (; arg; arg = arg->next) - if (!checker (arg->expr)) - return false; - - return true; -} - - -/* Check the subscription expressions of a reference chain with a checking - function; used by check_restricted. */ - -static bool -check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) -{ - int dim; - - if (!ref) - return true; - - switch (ref->type) - { - case REF_ARRAY: - for (dim = 0; dim < ref->u.ar.dimen; ++dim) - { - if (!checker (ref->u.ar.start[dim])) - return false; - if (!checker (ref->u.ar.end[dim])) - return false; - if (!checker (ref->u.ar.stride[dim])) - return false; - } - break; - - case REF_COMPONENT: - /* Nothing needed, just proceed to next reference. */ - break; - - case REF_SUBSTRING: - if (!checker (ref->u.ss.start)) - return false; - if (!checker (ref->u.ss.end)) - return false; - break; - - default: - gcc_unreachable (); - break; - } - - return check_references (ref->next, checker); -} - -/* Return true if ns is a parent of the current ns. */ - -static bool -is_parent_of_current_ns (gfc_namespace *ns) -{ - gfc_namespace *p; - for (p = gfc_current_ns->parent; p; p = p->parent) - if (ns == p) - return true; - - return false; -} - -/* Verify that an expression is a restricted expression. Like its - cousin check_init_expr(), an error message is generated if we - return false. */ - -static bool -check_restricted (gfc_expr *e) -{ - gfc_symbol* sym; - bool t; - - if (e == NULL) - return true; - - switch (e->expr_type) - { - case EXPR_OP: - t = check_intrinsic_op (e, check_restricted); - if (t) - t = gfc_simplify_expr (e, 0); - - break; - - case EXPR_FUNCTION: - if (e->value.function.esym) - { - t = check_arglist (e->value.function.actual, &check_restricted); - if (t) - t = external_spec_function (e); - } - else - { - if (e->value.function.isym && e->value.function.isym->inquiry) - t = true; - else - t = check_arglist (e->value.function.actual, &check_restricted); - - if (t) - t = restricted_intrinsic (e); - } - break; - - case EXPR_VARIABLE: - sym = e->symtree->n.sym; - t = false; - - /* If a dummy argument appears in a context that is valid for a - restricted expression in an elemental procedure, it will have - already been simplified away once we get here. Therefore we - don't need to jump through hoops to distinguish valid from - invalid cases. Allowed in F2008 and F2018. */ - if (gfc_notification_std (GFC_STD_F2008) - && sym->attr.dummy && sym->ns == gfc_current_ns - && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) - { - gfc_error_now ("Dummy argument %qs not " - "allowed in expression at %L", - sym->name, &e->where); - break; - } - - if (sym->attr.optional) - { - gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", - sym->name, &e->where); - break; - } - - if (sym->attr.intent == INTENT_OUT) - { - gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", - sym->name, &e->where); - break; - } - - /* Check reference chain if any. */ - if (!check_references (e->ref, &check_restricted)) - break; - - /* gfc_is_formal_arg broadcasts that a formal argument list is being - processed in resolve.c(resolve_formal_arglist). This is done so - that host associated dummy array indices are accepted (PR23446). - This mechanism also does the same for the specification expressions - of array-valued functions. */ - if (e->error - || sym->attr.in_common - || sym->attr.use_assoc - || sym->attr.dummy - || sym->attr.implied_index - || sym->attr.flavor == FL_PARAMETER - || is_parent_of_current_ns (sym->ns) - || (sym->ns->proc_name != NULL - && sym->ns->proc_name->attr.flavor == FL_MODULE) - || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) - { - t = true; - break; - } - - gfc_error ("Variable %qs cannot appear in the expression at %L", - sym->name, &e->where); - /* Prevent a repetition of the error. */ - e->error = 1; - break; - - case EXPR_NULL: - case EXPR_CONSTANT: - t = true; - break; - - case EXPR_SUBSTRING: - t = gfc_specification_expr (e->ref->u.ss.start); - if (!t) - break; - - t = gfc_specification_expr (e->ref->u.ss.end); - if (t) - t = gfc_simplify_expr (e, 0); - - break; - - case EXPR_STRUCTURE: - t = gfc_check_constructor (e, check_restricted); - break; - - case EXPR_ARRAY: - t = gfc_check_constructor (e, check_restricted); - break; - - default: - gfc_internal_error ("check_restricted(): Unknown expression type"); - } - - return t; -} - - -/* Check to see that an expression is a specification expression. If - we return false, an error has been generated. */ - -bool -gfc_specification_expr (gfc_expr *e) -{ - gfc_component *comp; - - if (e == NULL) - return true; - - if (e->ts.type != BT_INTEGER) - { - gfc_error ("Expression at %L must be of INTEGER type, found %s", - &e->where, gfc_basic_typename (e->ts.type)); - return false; - } - - comp = gfc_get_proc_ptr_comp (e); - if (e->expr_type == EXPR_FUNCTION - && !e->value.function.isym - && !e->value.function.esym - && !gfc_pure (e->symtree->n.sym) - && (!comp || !comp->attr.pure)) - { - gfc_error ("Function %qs at %L must be PURE", - e->symtree->n.sym->name, &e->where); - /* Prevent repeat error messages. */ - e->symtree->n.sym->attr.pure = 1; - return false; - } - - if (e->rank != 0) - { - gfc_error ("Expression at %L must be scalar", &e->where); - return false; - } - - if (!gfc_simplify_expr (e, 0)) - return false; - - return check_restricted (e); -} - - -/************** Expression conformance checks. *************/ - -/* Given two expressions, make sure that the arrays are conformable. */ - -bool -gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) -{ - int op1_flag, op2_flag, d; - mpz_t op1_size, op2_size; - bool t; - - va_list argp; - char buffer[240]; - - if (op1->rank == 0 || op2->rank == 0) - return true; - - va_start (argp, optype_msgid); - d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp); - va_end (argp); - if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */ - gfc_internal_error ("optype_msgid overflow: %d", d); - - if (op1->rank != op2->rank) - { - gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), - op1->rank, op2->rank, &op1->where); - return false; - } - - t = true; - - for (d = 0; d < op1->rank; d++) - { - op1_flag = gfc_array_dimen_size(op1, d, &op1_size); - op2_flag = gfc_array_dimen_size(op2, d, &op2_size); - - if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) - { - gfc_error ("Different shape for %s at %L on dimension %d " - "(%d and %d)", _(buffer), &op1->where, d + 1, - (int) mpz_get_si (op1_size), - (int) mpz_get_si (op2_size)); - - t = false; - } - - if (op1_flag) - mpz_clear (op1_size); - if (op2_flag) - mpz_clear (op2_size); - - if (!t) - return false; - } - - return true; -} - - -/* Given an assignable expression and an arbitrary expression, make - sure that the assignment can take place. Only add a call to the intrinsic - conversion routines, when allow_convert is set. When this assign is a - coarray call, then the convert is done by the coarray routine implictly and - adding the intrinsic conversion would do harm in most cases. */ - -bool -gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, - bool allow_convert) -{ - gfc_symbol *sym; - gfc_ref *ref; - int has_pointer; - - sym = lvalue->symtree->n.sym; - - /* See if this is the component or subcomponent of a pointer and guard - against assignment to LEN or KIND part-refs. */ - has_pointer = sym->attr.pointer; - for (ref = lvalue->ref; ref; ref = ref->next) - { - if (!has_pointer && ref->type == REF_COMPONENT - && ref->u.c.component->attr.pointer) - has_pointer = 1; - else if (ref->type == REF_INQUIRY - && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) - { - gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " - "allowed", &lvalue->where); - return false; - } - } - - /* 12.5.2.2, Note 12.26: The result variable is very similar to any other - variable local to a function subprogram. Its existence begins when - execution of the function is initiated and ends when execution of the - function is terminated... - Therefore, the left hand side is no longer a variable, when it is: */ - if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION - && !sym->attr.external) - { - bool bad_proc; - bad_proc = false; - - /* (i) Use associated; */ - if (sym->attr.use_assoc) - bad_proc = true; - - /* (ii) The assignment is in the main program; or */ - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.is_main_program) - bad_proc = true; - - /* (iii) A module or internal procedure... */ - if (gfc_current_ns->proc_name - && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL - || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) - && gfc_current_ns->parent - && (!(gfc_current_ns->parent->proc_name->attr.function - || gfc_current_ns->parent->proc_name->attr.subroutine) - || gfc_current_ns->parent->proc_name->attr.is_main_program)) - { - /* ... that is not a function... */ - if (gfc_current_ns->proc_name - && !gfc_current_ns->proc_name->attr.function) - bad_proc = true; - - /* ... or is not an entry and has a different name. */ - if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) - bad_proc = true; - } - - /* (iv) Host associated and not the function symbol or the - parent result. This picks up sibling references, which - cannot be entries. */ - if (!sym->attr.entry - && sym->ns == gfc_current_ns->parent - && sym != gfc_current_ns->proc_name - && sym != gfc_current_ns->parent->proc_name->result) - bad_proc = true; - - if (bad_proc) - { - gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); - return false; - } - } - else - { - /* Reject assigning to an external symbol. For initializers, this - was already done before, in resolve_fl_procedure. */ - if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external - && sym->attr.proc != PROC_MODULE && !rvalue->error) - { - gfc_error ("Illegal assignment to external procedure at %L", - &lvalue->where); - return false; - } - } - - if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) - { - gfc_error ("Incompatible ranks %d and %d in assignment at %L", - lvalue->rank, rvalue->rank, &lvalue->where); - return false; - } - - if (lvalue->ts.type == BT_UNKNOWN) - { - gfc_error ("Variable type is UNKNOWN in assignment at %L", - &lvalue->where); - return false; - } - - if (rvalue->expr_type == EXPR_NULL) - { - if (has_pointer && (ref == NULL || ref->next == NULL) - && lvalue->symtree->n.sym->attr.data) - return true; - else - { - gfc_error ("NULL appears on right-hand side in assignment at %L", - &rvalue->where); - return false; - } - } - - /* This is possibly a typo: x = f() instead of x => f(). */ - if (warn_surprising - && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) - gfc_warning (OPT_Wsurprising, - "POINTER-valued function appears on right-hand side of " - "assignment at %L", &rvalue->where); - - /* Check size of array assignments. */ - if (lvalue->rank != 0 && rvalue->rank != 0 - && !gfc_check_conformance (lvalue, rvalue, _("array assignment"))) - return false; - - /* Handle the case of a BOZ literal on the RHS. */ - if (rvalue->ts.type == BT_BOZ) - { - if (lvalue->symtree->n.sym->attr.data) - { - if (lvalue->ts.type == BT_INTEGER - && gfc_boz2int (rvalue, lvalue->ts.kind)) - return true; - - if (lvalue->ts.type == BT_REAL - && gfc_boz2real (rvalue, lvalue->ts.kind)) - { - if (gfc_invalid_boz ("BOZ literal constant near %L cannot " - "be assigned to a REAL variable", - &rvalue->where)) - return false; - return true; - } - } - - if (!lvalue->symtree->n.sym->attr.data - && gfc_invalid_boz ("BOZ literal constant at %L is neither a " - "data-stmt-constant nor an actual argument to " - "INT, REAL, DBLE, or CMPLX intrinsic function", - &rvalue->where)) - return false; - - if (lvalue->ts.type == BT_INTEGER - && gfc_boz2int (rvalue, lvalue->ts.kind)) - return true; - - if (lvalue->ts.type == BT_REAL - && gfc_boz2real (rvalue, lvalue->ts.kind)) - return true; - - gfc_error ("BOZ literal constant near %L cannot be assigned to a " - "%qs variable", &rvalue->where, gfc_typename (lvalue)); - return false; - } - - if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) - { - gfc_error ("The assignment to a KIND or LEN component of a " - "parameterized type at %L is not allowed", - &lvalue->where); - return false; - } - - if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) - return true; - - /* Only DATA Statements come here. */ - if (!conform) - { - locus *where; - - /* Numeric can be converted to any other numeric. And Hollerith can be - converted to any other type. */ - if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) - || rvalue->ts.type == BT_HOLLERITH) - return true; - - if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts) - || lvalue->ts.type == BT_LOGICAL) - && rvalue->ts.type == BT_CHARACTER - && rvalue->ts.kind == gfc_default_character_kind) - return true; - - if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) - return true; - - where = lvalue->where.lb ? &lvalue->where : &rvalue->where; - gfc_error ("Incompatible types in DATA statement at %L; attempted " - "conversion of %s to %s", where, - gfc_typename (rvalue), gfc_typename (lvalue)); - - return false; - } - - /* Assignment is the only case where character variables of different - kind values can be converted into one another. */ - if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) - { - if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) - return gfc_convert_chartype (rvalue, &lvalue->ts); - else - return true; - } - - if (!allow_convert) - return true; - - return gfc_convert_type (rvalue, &lvalue->ts, 1); -} - - -/* Check that a pointer assignment is OK. We first check lvalue, and - we only check rvalue if it's not an assignment to NULL() or a - NULLIFY statement. */ - -bool -gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, - bool suppress_type_test, bool is_init_expr) -{ - symbol_attribute attr, lhs_attr; - gfc_ref *ref; - bool is_pure, is_implicit_pure, rank_remap; - int proc_pointer; - bool same_rank; - - if (!lvalue->symtree) - return false; - - lhs_attr = gfc_expr_attr (lvalue); - if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) - { - gfc_error ("Pointer assignment target is not a POINTER at %L", - &lvalue->where); - return false; - } - - if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc - && !lhs_attr.proc_pointer) - { - gfc_error ("%qs in the pointer assignment at %L cannot be an " - "l-value since it is a procedure", - lvalue->symtree->n.sym->name, &lvalue->where); - return false; - } - - proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; - - rank_remap = false; - same_rank = lvalue->rank == rvalue->rank; - for (ref = lvalue->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT) - proc_pointer = ref->u.c.component->attr.proc_pointer; - - if (ref->type == REF_ARRAY && ref->next == NULL) - { - int dim; - - if (ref->u.ar.type == AR_FULL) - break; - - if (ref->u.ar.type != AR_SECTION) - { - gfc_error ("Expected bounds specification for %qs at %L", - lvalue->symtree->n.sym->name, &lvalue->where); - return false; - } - - if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " - "for %qs in pointer assignment at %L", - lvalue->symtree->n.sym->name, &lvalue->where)) - return false; - - /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment): - * - * (C1017) If bounds-spec-list is specified, the number of - * bounds-specs shall equal the rank of data-pointer-object. - * - * If bounds-spec-list appears, it specifies the lower bounds. - * - * (C1018) If bounds-remapping-list is specified, the number of - * bounds-remappings shall equal the rank of data-pointer-object. - * - * If bounds-remapping-list appears, it specifies the upper and - * lower bounds of each dimension of the pointer; the pointer target - * shall be simply contiguous or of rank one. - * - * (C1019) If bounds-remapping-list is not specified, the ranks of - * data-pointer-object and data-target shall be the same. - * - * Thus when bounds are given, all lbounds are necessary and either - * all or none of the upper bounds; no strides are allowed. If the - * upper bounds are present, we may do rank remapping. */ - for (dim = 0; dim < ref->u.ar.dimen; ++dim) - { - if (ref->u.ar.stride[dim]) - { - gfc_error ("Stride must not be present at %L", - &lvalue->where); - return false; - } - if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim])) - { - gfc_error ("Rank remapping requires a " - "list of % " - "specifications at %L", &lvalue->where); - return false; - } - if (!ref->u.ar.start[dim] - || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) - { - gfc_error ("Expected list of % or " - "list of % " - "specifications at %L", &lvalue->where); - return false; - } - - if (dim == 0) - rank_remap = (ref->u.ar.end[dim] != NULL); - else - { - if ((rank_remap && !ref->u.ar.end[dim])) - { - gfc_error ("Rank remapping requires a " - "list of % " - "specifications at %L", &lvalue->where); - return false; - } - if (!rank_remap && ref->u.ar.end[dim]) - { - gfc_error ("Expected list of % or " - "list of % " - "specifications at %L", &lvalue->where); - return false; - } - } - } - } - } - - is_pure = gfc_pure (NULL); - is_implicit_pure = gfc_implicit_pure (NULL); - - /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, - kind, etc for lvalue and rvalue must match, and rvalue must be a - pure variable if we're in a pure function. */ - if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) - return true; - - /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ - if (lvalue->expr_type == EXPR_VARIABLE - && gfc_is_coindexed (lvalue)) - { - gfc_ref *ref; - for (ref = lvalue->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen) - { - gfc_error ("Pointer object at %L shall not have a coindex", - &lvalue->where); - return false; - } - } - - /* Checks on rvalue for procedure pointer assignments. */ - if (proc_pointer) - { - char err[200]; - gfc_symbol *s1,*s2; - gfc_component *comp1, *comp2; - const char *name; - - attr = gfc_expr_attr (rvalue); - if (!((rvalue->expr_type == EXPR_NULL) - || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) - || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) - || (rvalue->expr_type == EXPR_VARIABLE - && attr.flavor == FL_PROCEDURE))) - { - gfc_error ("Invalid procedure pointer assignment at %L", - &rvalue->where); - return false; - } - - if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) - { - /* Check for intrinsics. */ - gfc_symbol *sym = rvalue->symtree->n.sym; - if (!sym->attr.intrinsic - && (gfc_is_intrinsic (sym, 0, sym->declared_at) - || gfc_is_intrinsic (sym, 1, sym->declared_at))) - { - sym->attr.intrinsic = 1; - gfc_resolve_intrinsic (sym, &rvalue->where); - attr = gfc_expr_attr (rvalue); - } - /* Check for result of embracing function. */ - if (sym->attr.function && sym->result == sym) - { - gfc_namespace *ns; - - for (ns = gfc_current_ns; ns; ns = ns->parent) - if (sym == ns->proc_name) - { - gfc_error ("Function result %qs is invalid as proc-target " - "in procedure pointer assignment at %L", - sym->name, &rvalue->where); - return false; - } - } - } - if (attr.abstract) - { - gfc_error ("Abstract interface %qs is invalid " - "in procedure pointer assignment at %L", - rvalue->symtree->name, &rvalue->where); - return false; - } - /* Check for F08:C729. */ - if (attr.flavor == FL_PROCEDURE) - { - if (attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Statement function %qs is invalid " - "in procedure pointer assignment at %L", - rvalue->symtree->name, &rvalue->where); - return false; - } - if (attr.proc == PROC_INTERNAL && - !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs " - "is invalid in procedure pointer assignment " - "at %L", rvalue->symtree->name, &rvalue->where)) - return false; - if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, - attr.subroutine) == 0) - { - gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " - "assignment", rvalue->symtree->name, &rvalue->where); - return false; - } - } - /* Check for F08:C730. */ - if (attr.elemental && !attr.intrinsic) - { - gfc_error ("Nonintrinsic elemental procedure %qs is invalid " - "in procedure pointer assignment at %L", - rvalue->symtree->name, &rvalue->where); - return false; - } - - /* Ensure that the calling convention is the same. As other attributes - such as DLLEXPORT may differ, one explicitly only tests for the - calling conventions. */ - if (rvalue->expr_type == EXPR_VARIABLE - && lvalue->symtree->n.sym->attr.ext_attr - != rvalue->symtree->n.sym->attr.ext_attr) - { - symbol_attribute calls; - - calls.ext_attr = 0; - gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); - gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); - gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); - - if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) - != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) - { - gfc_error ("Mismatch in the procedure pointer assignment " - "at %L: mismatch in the calling convention", - &rvalue->where); - return false; - } - } - - comp1 = gfc_get_proc_ptr_comp (lvalue); - if (comp1) - s1 = comp1->ts.interface; - else - { - s1 = lvalue->symtree->n.sym; - if (s1->ts.interface) - s1 = s1->ts.interface; - } - - comp2 = gfc_get_proc_ptr_comp (rvalue); - if (comp2) - { - if (rvalue->expr_type == EXPR_FUNCTION) - { - s2 = comp2->ts.interface->result; - name = s2->name; - } - else - { - s2 = comp2->ts.interface; - name = comp2->name; - } - } - else if (rvalue->expr_type == EXPR_FUNCTION) - { - if (rvalue->value.function.esym) - s2 = rvalue->value.function.esym->result; - else - s2 = rvalue->symtree->n.sym->result; - - name = s2->name; - } - else - { - s2 = rvalue->symtree->n.sym; - name = s2->name; - } - - if (s2 && s2->attr.proc_pointer && s2->ts.interface) - s2 = s2->ts.interface; - - /* Special check for the case of absent interface on the lvalue. - * All other interface checks are done below. */ - if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) - { - gfc_error ("Interface mismatch in procedure pointer assignment " - "at %L: %qs is not a subroutine", &rvalue->where, name); - return false; - } - - /* F08:7.2.2.4 (4) */ - if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) - { - if (comp1 && !s1) - { - gfc_error ("Explicit interface required for component %qs at %L: %s", - comp1->name, &lvalue->where, err); - return false; - } - else if (s1->attr.if_source == IFSRC_UNKNOWN) - { - gfc_error ("Explicit interface required for %qs at %L: %s", - s1->name, &lvalue->where, err); - return false; - } - } - if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) - { - if (comp2 && !s2) - { - gfc_error ("Explicit interface required for component %qs at %L: %s", - comp2->name, &rvalue->where, err); - return false; - } - else if (s2->attr.if_source == IFSRC_UNKNOWN) - { - gfc_error ("Explicit interface required for %qs at %L: %s", - s2->name, &rvalue->where, err); - return false; - } - } - - if (s1 == s2 || !s1 || !s2) - return true; - - if (!gfc_compare_interfaces (s1, s2, name, 0, 1, - err, sizeof(err), NULL, NULL)) - { - gfc_error ("Interface mismatch in procedure pointer assignment " - "at %L: %s", &rvalue->where, err); - return false; - } - - /* Check F2008Cor2, C729. */ - if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN - && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) - { - gfc_error ("Procedure pointer target %qs at %L must be either an " - "intrinsic, host or use associated, referenced or have " - "the EXTERNAL attribute", s2->name, &rvalue->where); - return false; - } - - return true; - } - else - { - /* A non-proc pointer cannot point to a constant. */ - if (rvalue->expr_type == EXPR_CONSTANT) - { - gfc_error_now ("Pointer assignment target cannot be a constant at %L", - &rvalue->where); - return false; - } - } - - if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) - { - /* Check for F03:C717. */ - if (UNLIMITED_POLY (rvalue) - && !(UNLIMITED_POLY (lvalue) - || (lvalue->ts.type == BT_DERIVED - && (lvalue->ts.u.derived->attr.is_bind_c - || lvalue->ts.u.derived->attr.sequence)))) - gfc_error ("Data-pointer-object at %L must be unlimited " - "polymorphic, or of a type with the BIND or SEQUENCE " - "attribute, to be compatible with an unlimited " - "polymorphic target", &lvalue->where); - else if (!suppress_type_test) - gfc_error ("Different types in pointer assignment at %L; " - "attempted assignment of %s to %s", &lvalue->where, - gfc_typename (rvalue), gfc_typename (lvalue)); - return false; - } - - if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) - { - gfc_error ("Different kind type parameters in pointer " - "assignment at %L", &lvalue->where); - return false; - } - - if (lvalue->rank != rvalue->rank && !rank_remap) - { - gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); - return false; - } - - /* Make sure the vtab is present. */ - if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)) - gfc_find_vtab (&rvalue->ts); - - /* Check rank remapping. */ - if (rank_remap) - { - mpz_t lsize, rsize; - - /* If this can be determined, check that the target must be at least as - large as the pointer assigned to it is. */ - if (gfc_array_size (lvalue, &lsize) - && gfc_array_size (rvalue, &rsize) - && mpz_cmp (rsize, lsize) < 0) - { - gfc_error ("Rank remapping target is smaller than size of the" - " pointer (%ld < %ld) at %L", - mpz_get_si (rsize), mpz_get_si (lsize), - &lvalue->where); - return false; - } - - /* The target must be either rank one or it must be simply contiguous - and F2008 must be allowed. */ - if (rvalue->rank != 1) - { - if (!gfc_is_simply_contiguous (rvalue, true, false)) - { - gfc_error ("Rank remapping target must be rank 1 or" - " simply contiguous at %L", &rvalue->where); - return false; - } - if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " - "rank 1 at %L", &rvalue->where)) - return false; - } - } - - /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ - if (rvalue->expr_type == EXPR_NULL) - return true; - - if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) - lvalue->symtree->n.sym->attr.subref_array_pointer = 1; - - attr = gfc_expr_attr (rvalue); - - if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) - { - /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call - to caf_get. Map this to the same error message as below when it is - still a variable expression. */ - if (rvalue->value.function.isym - && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) - /* The test above might need to be extend when F08, Note 5.4 has to be - interpreted in the way that target and pointer with the same coindex - are allowed. */ - gfc_error ("Data target at %L shall not have a coindex", - &rvalue->where); - else - gfc_error ("Target expression in pointer assignment " - "at %L must deliver a pointer result", - &rvalue->where); - return false; - } - - if (is_init_expr) - { - gfc_symbol *sym; - bool target; - gfc_ref *ref; - - if (gfc_is_size_zero_array (rvalue)) - { - gfc_error ("Zero-sized array detected at %L where an entity with " - "the TARGET attribute is expected", &rvalue->where); - return false; - } - else if (!rvalue->symtree) - { - gfc_error ("Pointer assignment target in initialization expression " - "does not have the TARGET attribute at %L", - &rvalue->where); - return false; - } - - sym = rvalue->symtree->n.sym; - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok) - target = CLASS_DATA (sym)->attr.target; - else - target = sym->attr.target; - - if (!target && !proc_pointer) - { - gfc_error ("Pointer assignment target in initialization expression " - "does not have the TARGET attribute at %L", - &rvalue->where); - return false; - } - - for (ref = rvalue->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - for (int n = 0; n < ref->u.ar.dimen; n++) - if (!gfc_is_constant_expr (ref->u.ar.start[n]) - || !gfc_is_constant_expr (ref->u.ar.end[n]) - || !gfc_is_constant_expr (ref->u.ar.stride[n])) - { - gfc_error ("Every subscript of target specification " - "at %L must be a constant expression", - &ref->u.ar.where); - return false; - } - break; - - case REF_SUBSTRING: - if (!gfc_is_constant_expr (ref->u.ss.start) - || !gfc_is_constant_expr (ref->u.ss.end)) - { - gfc_error ("Substring starting and ending points of target " - "specification at %L must be constant expressions", - &ref->u.ss.start->where); - return false; - } - break; - - default: - break; - } - } - } - else - { - if (!attr.target && !attr.pointer) - { - gfc_error ("Pointer assignment target is neither TARGET " - "nor POINTER at %L", &rvalue->where); - return false; - } - } - - if (lvalue->ts.type == BT_CHARACTER) - { - bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); - if (!t) - return false; - } - - if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) - { - gfc_error ("Bad target in pointer assignment in PURE " - "procedure at %L", &rvalue->where); - } - - if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) - gfc_unset_implicit_pure (gfc_current_ns->proc_name); - - if (gfc_has_vector_index (rvalue)) - { - gfc_error ("Pointer assignment with vector subscript " - "on rhs at %L", &rvalue->where); - return false; - } - - if (attr.is_protected && attr.use_assoc - && !(attr.pointer || attr.proc_pointer)) - { - gfc_error ("Pointer assignment target has PROTECTED " - "attribute at %L", &rvalue->where); - return false; - } - - /* F2008, C725. For PURE also C1283. */ - if (rvalue->expr_type == EXPR_VARIABLE - && gfc_is_coindexed (rvalue)) - { - gfc_ref *ref; - for (ref = rvalue->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen) - { - gfc_error ("Data target at %L shall not have a coindex", - &rvalue->where); - return false; - } - } - - /* Warn for assignments of contiguous pointers to targets which is not - contiguous. Be lenient in the definition of what counts as - contiguous. */ - - if (lhs_attr.contiguous - && lhs_attr.dimension > 0) - { - if (gfc_is_not_contiguous (rvalue)) - { - gfc_error ("Assignment to contiguous pointer from " - "non-contiguous target at %L", &rvalue->where); - return false; - } - if (!gfc_is_simply_contiguous (rvalue, false, true)) - gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from " - "non-contiguous target at %L", &rvalue->where); - } - - /* Warn if it is the LHS pointer may lives longer than the RHS target. */ - if (warn_target_lifetime - && rvalue->expr_type == EXPR_VARIABLE - && !rvalue->symtree->n.sym->attr.save - && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer - && !rvalue->symtree->n.sym->attr.host_assoc - && !rvalue->symtree->n.sym->attr.in_common - && !rvalue->symtree->n.sym->attr.use_assoc - && !rvalue->symtree->n.sym->attr.dummy) - { - bool warn; - gfc_namespace *ns; - - warn = lvalue->symtree->n.sym->attr.dummy - || lvalue->symtree->n.sym->attr.result - || lvalue->symtree->n.sym->attr.function - || (lvalue->symtree->n.sym->attr.host_assoc - && lvalue->symtree->n.sym->ns - != rvalue->symtree->n.sym->ns) - || lvalue->symtree->n.sym->attr.use_assoc - || lvalue->symtree->n.sym->attr.in_common; - - if (rvalue->symtree->n.sym->ns->proc_name - && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE - && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) - for (ns = rvalue->symtree->n.sym->ns; - ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; - ns = ns->parent) - if (ns->parent == lvalue->symtree->n.sym->ns) - { - warn = true; - break; - } - - if (warn) - gfc_warning (OPT_Wtarget_lifetime, - "Pointer at %L in pointer assignment might outlive the " - "pointer target", &lvalue->where); - } - - return true; -} - - -/* Relative of gfc_check_assign() except that the lvalue is a single - symbol. Used for initialization assignments. */ - -bool -gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) -{ - gfc_expr lvalue; - bool r; - bool pointer, proc_pointer; - - memset (&lvalue, '\0', sizeof (gfc_expr)); - - lvalue.expr_type = EXPR_VARIABLE; - lvalue.ts = sym->ts; - if (sym->as) - lvalue.rank = sym->as->rank; - lvalue.symtree = XCNEW (gfc_symtree); - lvalue.symtree->n.sym = sym; - lvalue.where = sym->declared_at; - - if (comp) - { - lvalue.ref = gfc_get_ref (); - lvalue.ref->type = REF_COMPONENT; - lvalue.ref->u.c.component = comp; - lvalue.ref->u.c.sym = sym; - lvalue.ts = comp->ts; - lvalue.rank = comp->as ? comp->as->rank : 0; - lvalue.where = comp->loc; - pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) - ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; - proc_pointer = comp->attr.proc_pointer; - } - else - { - pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) - ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; - proc_pointer = sym->attr.proc_pointer; - } - - if (pointer || proc_pointer) - r = gfc_check_pointer_assign (&lvalue, rvalue, false, true); - else - { - /* If a conversion function, e.g., __convert_i8_i4, was inserted - into an array constructor, we should check if it can be reduced - as an initialization expression. */ - if (rvalue->expr_type == EXPR_FUNCTION - && rvalue->value.function.isym - && (rvalue->value.function.isym->conversion == 1)) - gfc_check_init_expr (rvalue); - - r = gfc_check_assign (&lvalue, rvalue, 1); - } - - free (lvalue.symtree); - free (lvalue.ref); - - if (!r) - return r; - - if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer) - { - /* F08:C461. Additional checks for pointer initialization. */ - symbol_attribute attr; - attr = gfc_expr_attr (rvalue); - if (attr.allocatable) - { - gfc_error ("Pointer initialization target at %L " - "must not be ALLOCATABLE", &rvalue->where); - return false; - } - if (!attr.target || attr.pointer) - { - gfc_error ("Pointer initialization target at %L " - "must have the TARGET attribute", &rvalue->where); - return false; - } - - if (!attr.save && rvalue->expr_type == EXPR_VARIABLE - && rvalue->symtree->n.sym->ns->proc_name - && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) - { - rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; - attr.save = SAVE_IMPLICIT; - } - - if (!attr.save) - { - gfc_error ("Pointer initialization target at %L " - "must have the SAVE attribute", &rvalue->where); - return false; - } - } - - if (proc_pointer && rvalue->expr_type != EXPR_NULL) - { - /* F08:C1220. Additional checks for procedure pointer initialization. */ - symbol_attribute attr = gfc_expr_attr (rvalue); - if (attr.proc_pointer) - { - gfc_error ("Procedure pointer initialization target at %L " - "may not be a procedure pointer", &rvalue->where); - return false; - } - if (attr.proc == PROC_INTERNAL) - { - gfc_error ("Internal procedure %qs is invalid in " - "procedure pointer initialization at %L", - rvalue->symtree->name, &rvalue->where); - return false; - } - if (attr.dummy) - { - gfc_error ("Dummy procedure %qs is invalid in " - "procedure pointer initialization at %L", - rvalue->symtree->name, &rvalue->where); - return false; - } - } - - return true; -} - -/* Build an initializer for a local integer, real, complex, logical, or - character variable, based on the command line flags finit-local-zero, - finit-integer=, finit-real=, finit-logical=, and finit-character=. - With force, an initializer is ALWAYS generated. */ - -static gfc_expr * -gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) -{ - gfc_expr *init_expr; - - /* Try to build an initializer expression. */ - init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); - - /* If we want to force generation, make sure we default to zero. */ - gfc_init_local_real init_real = flag_init_real; - int init_logical = gfc_option.flag_init_logical; - if (force) - { - if (init_real == GFC_INIT_REAL_OFF) - init_real = GFC_INIT_REAL_ZERO; - if (init_logical == GFC_INIT_LOGICAL_OFF) - init_logical = GFC_INIT_LOGICAL_FALSE; - } - - /* We will only initialize integers, reals, complex, logicals, and - characters, and only if the corresponding command-line flags - were set. Otherwise, we free init_expr and return null. */ - switch (ts->type) - { - case BT_INTEGER: - if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) - mpz_set_si (init_expr->value.integer, - gfc_option.flag_init_integer_value); - else - { - gfc_free_expr (init_expr); - init_expr = NULL; - } - break; - - case BT_REAL: - switch (init_real) - { - case GFC_INIT_REAL_SNAN: - init_expr->is_snan = 1; - /* Fall through. */ - case GFC_INIT_REAL_NAN: - mpfr_set_nan (init_expr->value.real); - break; - - case GFC_INIT_REAL_INF: - mpfr_set_inf (init_expr->value.real, 1); - break; - - case GFC_INIT_REAL_NEG_INF: - mpfr_set_inf (init_expr->value.real, -1); - break; - - case GFC_INIT_REAL_ZERO: - mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE); - break; - - default: - gfc_free_expr (init_expr); - init_expr = NULL; - break; - } - break; - - case BT_COMPLEX: - switch (init_real) - { - case GFC_INIT_REAL_SNAN: - init_expr->is_snan = 1; - /* Fall through. */ - case GFC_INIT_REAL_NAN: - mpfr_set_nan (mpc_realref (init_expr->value.complex)); - mpfr_set_nan (mpc_imagref (init_expr->value.complex)); - break; - - case GFC_INIT_REAL_INF: - mpfr_set_inf (mpc_realref (init_expr->value.complex), 1); - mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1); - break; - - case GFC_INIT_REAL_NEG_INF: - mpfr_set_inf (mpc_realref (init_expr->value.complex), -1); - mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1); - break; - - case GFC_INIT_REAL_ZERO: - mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); - break; - - default: - gfc_free_expr (init_expr); - init_expr = NULL; - break; - } - break; - - case BT_LOGICAL: - if (init_logical == GFC_INIT_LOGICAL_FALSE) - init_expr->value.logical = 0; - else if (init_logical == GFC_INIT_LOGICAL_TRUE) - init_expr->value.logical = 1; - else - { - gfc_free_expr (init_expr); - init_expr = NULL; - } - break; - - case BT_CHARACTER: - /* For characters, the length must be constant in order to - create a default initializer. */ - if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) - && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT) - { - HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); - init_expr->value.character.length = char_len; - init_expr->value.character.string = gfc_get_wide_string (char_len+1); - for (size_t i = 0; i < (size_t) char_len; i++) - init_expr->value.character.string[i] - = (unsigned char) gfc_option.flag_init_character_value; - } - else - { - gfc_free_expr (init_expr); - init_expr = NULL; - } - if (!init_expr - && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) - && ts->u.cl->length && flag_max_stack_var_size != 0) - { - gfc_actual_arglist *arg; - init_expr = gfc_get_expr (); - init_expr->where = *where; - init_expr->ts = *ts; - init_expr->expr_type = EXPR_FUNCTION; - init_expr->value.function.isym = - gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); - init_expr->value.function.name = "repeat"; - arg = gfc_get_actual_arglist (); - arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1); - arg->expr->value.character.string[0] = - gfc_option.flag_init_character_value; - arg->next = gfc_get_actual_arglist (); - arg->next->expr = gfc_copy_expr (ts->u.cl->length); - init_expr->value.function.actual = arg; - } - break; - - default: - gfc_free_expr (init_expr); - init_expr = NULL; - } - - return init_expr; -} - -/* Invoke gfc_build_init_expr to create an initializer expression, but do not - * require that an expression be built. */ - -gfc_expr * -gfc_build_default_init_expr (gfc_typespec *ts, locus *where) -{ - return gfc_build_init_expr (ts, where, false); -} - -/* Apply an initialization expression to a typespec. Can be used for symbols or - components. Similar to add_init_expr_to_sym in decl.c; could probably be - combined with some effort. */ - -void -gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) -{ - if (ts->type == BT_CHARACTER && !attr->pointer && init - && ts->u.cl - && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT - && ts->u.cl->length->ts.type == BT_INTEGER) - { - HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); - - if (init->expr_type == EXPR_CONSTANT) - gfc_set_constant_character_len (len, init, -1); - else if (init - && init->ts.type == BT_CHARACTER - && init->ts.u.cl && init->ts.u.cl->length - && mpz_cmp (ts->u.cl->length->value.integer, - init->ts.u.cl->length->value.integer)) - { - gfc_constructor *ctor; - ctor = gfc_constructor_first (init->value.constructor); - - if (ctor) - { - bool has_ts = (init->ts.u.cl - && init->ts.u.cl->length_from_typespec); - - /* Remember the length of the first element for checking - that all elements *in the constructor* have the same - length. This need not be the length of the LHS! */ - gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); - gcc_assert (ctor->expr->ts.type == BT_CHARACTER); - gfc_charlen_t first_len = ctor->expr->value.character.length; - - for ( ; ctor; ctor = gfc_constructor_next (ctor)) - if (ctor->expr->expr_type == EXPR_CONSTANT) - { - gfc_set_constant_character_len (len, ctor->expr, - has_ts ? -1 : first_len); - if (!ctor->expr->ts.u.cl) - ctor->expr->ts.u.cl - = gfc_new_charlen (gfc_current_ns, ts->u.cl); - else - ctor->expr->ts.u.cl->length - = gfc_copy_expr (ts->u.cl->length); - } - } - } - } -} - - -/* Check whether an expression is a structure constructor and whether it has - other values than NULL. */ - -static bool -is_non_empty_structure_constructor (gfc_expr * e) -{ - if (e->expr_type != EXPR_STRUCTURE) - return false; - - gfc_constructor *cons = gfc_constructor_first (e->value.constructor); - while (cons) - { - if (!cons->expr || cons->expr->expr_type != EXPR_NULL) - return true; - cons = gfc_constructor_next (cons); - } - return false; -} - - -/* Check for default initializer; sym->value is not enough - as it is also set for EXPR_NULL of allocatables. */ - -bool -gfc_has_default_initializer (gfc_symbol *der) -{ - gfc_component *c; - - gcc_assert (gfc_fl_struct (der->attr.flavor)); - for (c = der->components; c; c = c->next) - if (gfc_bt_struct (c->ts.type)) - { - if (!c->attr.pointer && !c->attr.proc_pointer - && !(c->attr.allocatable && der == c->ts.u.derived) - && ((c->initializer - && is_non_empty_structure_constructor (c->initializer)) - || gfc_has_default_initializer (c->ts.u.derived))) - return true; - if (c->attr.pointer && c->initializer) - return true; - } - else - { - if (c->initializer) - return true; - } - - return false; -} - - -/* - Generate an initializer expression which initializes the entirety of a union. - A normal structure constructor is insufficient without undue effort, because - components of maps may be oddly aligned/overlapped. (For example if a - character is initialized from one map overtop a real from the other, only one - byte of the real is actually initialized.) Unfortunately we don't know the - size of the union right now, so we can't generate a proper initializer, but - we use a NULL expr as a placeholder and do the right thing later in - gfc_trans_subcomponent_assign. - */ -static gfc_expr * -generate_union_initializer (gfc_component *un) -{ - if (un == NULL || un->ts.type != BT_UNION) - return NULL; - - gfc_expr *placeholder = gfc_get_null_expr (&un->loc); - placeholder->ts = un->ts; - return placeholder; -} - - -/* Get the user-specified initializer for a union, if any. This means the user - has said to initialize component(s) of a map. For simplicity's sake we - only allow the user to initialize the first map. We don't have to worry - about overlapping initializers as they are released early in resolution (see - resolve_fl_struct). */ - -static gfc_expr * -get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) -{ - gfc_component *map; - gfc_expr *init=NULL; - - if (!union_type || union_type->attr.flavor != FL_UNION) - return NULL; - - for (map = union_type->components; map; map = map->next) - { - if (gfc_has_default_initializer (map->ts.u.derived)) - { - init = gfc_default_initializer (&map->ts); - if (map_p) - *map_p = map; - break; - } - } - - if (map_p && !init) - *map_p = NULL; - - return init; -} - -static bool -class_allocatable (gfc_component *comp) -{ - return comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.allocatable; -} - -static bool -class_pointer (gfc_component *comp) -{ - return comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.pointer; -} - -static bool -comp_allocatable (gfc_component *comp) -{ - return comp->attr.allocatable || class_allocatable (comp); -} - -static bool -comp_pointer (gfc_component *comp) -{ - return comp->attr.pointer - || comp->attr.proc_pointer - || comp->attr.class_pointer - || class_pointer (comp); -} - -/* Fetch or generate an initializer for the given component. - Only generate an initializer if generate is true. */ - -static gfc_expr * -component_initializer (gfc_component *c, bool generate) -{ - gfc_expr *init = NULL; - - /* Allocatable components always get EXPR_NULL. - Pointer components are only initialized when generating, and only if they - do not already have an initializer. */ - if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer)) - { - init = gfc_get_null_expr (&c->loc); - init->ts = c->ts; - return init; - } - - /* See if we can find the initializer immediately. */ - if (c->initializer || !generate) - return c->initializer; - - /* Recursively handle derived type components. */ - else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - init = gfc_generate_initializer (&c->ts, true); - - else if (c->ts.type == BT_UNION && c->ts.u.derived->components) - { - gfc_component *map = NULL; - gfc_constructor *ctor; - gfc_expr *user_init; - - /* If we don't have a user initializer and we aren't generating one, this - union has no initializer. */ - user_init = get_union_initializer (c->ts.u.derived, &map); - if (!user_init && !generate) - return NULL; - - /* Otherwise use a structure constructor. */ - init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, - &c->loc); - init->ts = c->ts; - - /* If we are to generate an initializer for the union, add a constructor - which initializes the whole union first. */ - if (generate) - { - ctor = gfc_constructor_get (); - ctor->expr = generate_union_initializer (c); - gfc_constructor_append (&init->value.constructor, ctor); - } - - /* If we found an initializer in one of our maps, apply it. Note this - is applied _after_ the entire-union initializer above if any. */ - if (user_init) - { - ctor = gfc_constructor_get (); - ctor->expr = user_init; - ctor->n.component = map; - gfc_constructor_append (&init->value.constructor, ctor); - } - } - - /* Treat simple components like locals. */ - else - { - /* We MUST give an initializer, so force generation. */ - init = gfc_build_init_expr (&c->ts, &c->loc, true); - gfc_apply_init (&c->ts, &c->attr, init); - } - - return init; -} - - -/* Get an expression for a default initializer of a derived type. */ - -gfc_expr * -gfc_default_initializer (gfc_typespec *ts) -{ - return gfc_generate_initializer (ts, false); -} - -/* Generate an initializer expression for an iso_c_binding type - such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */ - -static gfc_expr * -generate_isocbinding_initializer (gfc_symbol *derived) -{ - /* The initializers have already been built into the c_null_[fun]ptr symbols - from gen_special_c_interop_ptr. */ - gfc_symtree *npsym = NULL; - if (0 == strcmp (derived->name, "c_ptr")) - gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym); - else if (0 == strcmp (derived->name, "c_funptr")) - gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym); - else - gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding" - " type, expected % or %"); - if (npsym) - { - gfc_expr *init = gfc_copy_expr (npsym->n.sym->value); - init->symtree = npsym; - init->ts.is_iso_c = true; - return init; - } - - return NULL; -} - -/* Get or generate an expression for a default initializer of a derived type. - If -finit-derived is specified, generate default initialization expressions - for components that lack them when generate is set. */ - -gfc_expr * -gfc_generate_initializer (gfc_typespec *ts, bool generate) -{ - gfc_expr *init, *tmp; - gfc_component *comp; - - generate = flag_init_derived && generate; - - if (ts->u.derived->ts.is_iso_c && generate) - return generate_isocbinding_initializer (ts->u.derived); - - /* See if we have a default initializer in this, but not in nested - types (otherwise we could use gfc_has_default_initializer()). - We don't need to check if we are going to generate them. */ - comp = ts->u.derived->components; - if (!generate) - { - for (; comp; comp = comp->next) - if (comp->initializer || comp_allocatable (comp)) - break; - } - - if (!comp) - return NULL; - - init = gfc_get_structure_constructor_expr (ts->type, ts->kind, - &ts->u.derived->declared_at); - init->ts = *ts; - - for (comp = ts->u.derived->components; comp; comp = comp->next) - { - gfc_constructor *ctor = gfc_constructor_get(); - - /* Fetch or generate an initializer for the component. */ - tmp = component_initializer (comp, generate); - if (tmp) - { - /* Save the component ref for STRUCTUREs and UNIONs. */ - if (ts->u.derived->attr.flavor == FL_STRUCT - || ts->u.derived->attr.flavor == FL_UNION) - ctor->n.component = comp; - - /* If the initializer was not generated, we need a copy. */ - ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; - if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind) - && !comp->attr.pointer && !comp->attr.proc_pointer) - { - bool val; - val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); - if (val == false) - return NULL; - } - } - - gfc_constructor_append (&init->value.constructor, ctor); - } - - return init; -} - - -/* Given a symbol, create an expression node with that symbol as a - variable. If the symbol is array valued, setup a reference of the - whole array. */ - -gfc_expr * -gfc_get_variable_expr (gfc_symtree *var) -{ - gfc_expr *e; - - e = gfc_get_expr (); - e->expr_type = EXPR_VARIABLE; - e->symtree = var; - e->ts = var->n.sym->ts; - - if (var->n.sym->attr.flavor != FL_PROCEDURE - && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) - || (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived - && CLASS_DATA (var->n.sym) - && CLASS_DATA (var->n.sym)->as))) - { - e->rank = var->n.sym->ts.type == BT_CLASS - ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; - e->ref = gfc_get_ref (); - e->ref->type = REF_ARRAY; - e->ref->u.ar.type = AR_FULL; - e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS - ? CLASS_DATA (var->n.sym)->as - : var->n.sym->as); - } - - return e; -} - - -/* Adds a full array reference to an expression, as needed. */ - -void -gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) -{ - gfc_ref *ref; - for (ref = e->ref; ref; ref = ref->next) - if (!ref->next) - break; - if (ref) - { - ref->next = gfc_get_ref (); - ref = ref->next; - } - else - { - e->ref = gfc_get_ref (); - ref = e->ref; - } - ref->type = REF_ARRAY; - ref->u.ar.type = AR_FULL; - ref->u.ar.dimen = e->rank; - ref->u.ar.where = e->where; - ref->u.ar.as = as; -} - - -gfc_expr * -gfc_lval_expr_from_sym (gfc_symbol *sym) -{ - gfc_expr *lval; - gfc_array_spec *as; - lval = gfc_get_expr (); - lval->expr_type = EXPR_VARIABLE; - lval->where = sym->declared_at; - lval->ts = sym->ts; - lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); - - /* It will always be a full array. */ - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; - lval->rank = as ? as->rank : 0; - if (lval->rank) - gfc_add_full_array_ref (lval, as); - return lval; -} - - -/* Returns the array_spec of a full array expression. A NULL is - returned otherwise. */ -gfc_array_spec * -gfc_get_full_arrayspec_from_expr (gfc_expr *expr) -{ - gfc_array_spec *as; - gfc_ref *ref; - - if (expr->rank == 0) - return NULL; - - /* Follow any component references. */ - if (expr->expr_type == EXPR_VARIABLE - || expr->expr_type == EXPR_CONSTANT) - { - if (expr->symtree) - as = expr->symtree->n.sym->as; - else - as = NULL; - - for (ref = expr->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_COMPONENT: - as = ref->u.c.component->as; - continue; - - case REF_SUBSTRING: - case REF_INQUIRY: - continue; - - case REF_ARRAY: - { - switch (ref->u.ar.type) - { - case AR_ELEMENT: - case AR_SECTION: - case AR_UNKNOWN: - as = NULL; - continue; - - case AR_FULL: - break; - } - break; - } - } - } - } - else - as = NULL; - - return as; -} - - -/* General expression traversal function. */ - -bool -gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, - bool (*func)(gfc_expr *, gfc_symbol *, int*), - int f) -{ - gfc_array_ref ar; - gfc_ref *ref; - gfc_actual_arglist *args; - gfc_constructor *c; - int i; - - if (!expr) - return false; - - if ((*func) (expr, sym, &f)) - return true; - - if (expr->ts.type == BT_CHARACTER - && expr->ts.u.cl - && expr->ts.u.cl->length - && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT - && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) - return true; - - switch (expr->expr_type) - { - case EXPR_PPC: - case EXPR_COMPCALL: - case EXPR_FUNCTION: - for (args = expr->value.function.actual; args; args = args->next) - { - if (gfc_traverse_expr (args->expr, sym, func, f)) - return true; - } - break; - - case EXPR_VARIABLE: - case EXPR_CONSTANT: - case EXPR_NULL: - case EXPR_SUBSTRING: - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c)) - { - if (gfc_traverse_expr (c->expr, sym, func, f)) - return true; - if (c->iterator) - { - if (gfc_traverse_expr (c->iterator->var, sym, func, f)) - return true; - if (gfc_traverse_expr (c->iterator->start, sym, func, f)) - return true; - if (gfc_traverse_expr (c->iterator->end, sym, func, f)) - return true; - if (gfc_traverse_expr (c->iterator->step, sym, func, f)) - return true; - } - } - break; - - case EXPR_OP: - if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) - return true; - if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) - return true; - break; - - default: - gcc_unreachable (); - break; - } - - ref = expr->ref; - while (ref != NULL) - { - switch (ref->type) - { - case REF_ARRAY: - ar = ref->u.ar; - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) - { - if (gfc_traverse_expr (ar.start[i], sym, func, f)) - return true; - if (gfc_traverse_expr (ar.end[i], sym, func, f)) - return true; - if (gfc_traverse_expr (ar.stride[i], sym, func, f)) - return true; - } - break; - - case REF_SUBSTRING: - if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) - return true; - if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) - return true; - break; - - case REF_COMPONENT: - if (ref->u.c.component->ts.type == BT_CHARACTER - && ref->u.c.component->ts.u.cl - && ref->u.c.component->ts.u.cl->length - && ref->u.c.component->ts.u.cl->length->expr_type - != EXPR_CONSTANT - && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, - sym, func, f)) - return true; - - if (ref->u.c.component->as) - for (i = 0; i < ref->u.c.component->as->rank - + ref->u.c.component->as->corank; i++) - { - if (gfc_traverse_expr (ref->u.c.component->as->lower[i], - sym, func, f)) - return true; - if (gfc_traverse_expr (ref->u.c.component->as->upper[i], - sym, func, f)) - return true; - } - break; - - case REF_INQUIRY: - return true; - - default: - gcc_unreachable (); - } - ref = ref->next; - } - return false; -} - -/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ - -static bool -expr_set_symbols_referenced (gfc_expr *expr, - gfc_symbol *sym ATTRIBUTE_UNUSED, - int *f ATTRIBUTE_UNUSED) -{ - if (expr->expr_type != EXPR_VARIABLE) - return false; - gfc_set_sym_referenced (expr->symtree->n.sym); - return false; -} - -void -gfc_expr_set_symbols_referenced (gfc_expr *expr) -{ - gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); -} - - -/* Determine if an expression is a procedure pointer component and return - the component in that case. Otherwise return NULL. */ - -gfc_component * -gfc_get_proc_ptr_comp (gfc_expr *expr) -{ - gfc_ref *ref; - - if (!expr || !expr->ref) - return NULL; - - ref = expr->ref; - while (ref->next) - ref = ref->next; - - if (ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer) - return ref->u.c.component; - - return NULL; -} - - -/* Determine if an expression is a procedure pointer component. */ - -bool -gfc_is_proc_ptr_comp (gfc_expr *expr) -{ - return (gfc_get_proc_ptr_comp (expr) != NULL); -} - - -/* Determine if an expression is a function with an allocatable class scalar - result. */ -bool -gfc_is_alloc_class_scalar_function (gfc_expr *expr) -{ - if (expr->expr_type == EXPR_FUNCTION - && expr->value.function.esym - && expr->value.function.esym->result - && expr->value.function.esym->result->ts.type == BT_CLASS - && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension - && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) - return true; - - return false; -} - - -/* Determine if an expression is a function with an allocatable class array - result. */ -bool -gfc_is_class_array_function (gfc_expr *expr) -{ - if (expr->expr_type == EXPR_FUNCTION - && expr->value.function.esym - && expr->value.function.esym->result - && expr->value.function.esym->result->ts.type == BT_CLASS - && CLASS_DATA (expr->value.function.esym->result)->attr.dimension - && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable - || CLASS_DATA (expr->value.function.esym->result)->attr.pointer)) - return true; - - return false; -} - - -/* Walk an expression tree and check each variable encountered for being typed. - If strict is not set, a top-level variable is tolerated untyped in -std=gnu - mode as is a basic arithmetic expression using those; this is for things in - legacy-code like: - - INTEGER :: arr(n), n - INTEGER :: arr(n + 1), n - - The namespace is needed for IMPLICIT typing. */ - -static gfc_namespace* check_typed_ns; - -static bool -expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, - int* f ATTRIBUTE_UNUSED) -{ - bool t; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - gcc_assert (e->symtree); - t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, - true, e->where); - - return (!t); -} - -bool -gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) -{ - bool error_found; - - /* If this is a top-level variable or EXPR_OP, do the check with strict given - to us. */ - if (!strict) - { - if (e->expr_type == EXPR_VARIABLE && !e->ref) - return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); - - if (e->expr_type == EXPR_OP) - { - bool t = true; - - gcc_assert (e->value.op.op1); - t = gfc_expr_check_typed (e->value.op.op1, ns, strict); - - if (t && e->value.op.op2) - t = gfc_expr_check_typed (e->value.op.op2, ns, strict); - - return t; - } - } - - /* Otherwise, walk the expression and do it strictly. */ - check_typed_ns = ns; - error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); - - return error_found ? false : true; -} - - -/* This function returns true if it contains any references to PDT KIND - or LEN parameters. */ - -static bool -derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, - int* f ATTRIBUTE_UNUSED) -{ - if (e->expr_type != EXPR_VARIABLE) - return false; - - gcc_assert (e->symtree); - if (e->symtree->n.sym->attr.pdt_kind - || e->symtree->n.sym->attr.pdt_len) - return true; - - return false; -} - - -bool -gfc_derived_parameter_expr (gfc_expr *e) -{ - return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0); -} - - -/* This function returns the overall type of a type parameter spec list. - If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the - parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned - unless derived is not NULL. In this latter case, all the LEN parameters - must be either assumed or deferred for the return argument to be set to - anything other than SPEC_EXPLICIT. */ - -gfc_param_spec_type -gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) -{ - gfc_param_spec_type res = SPEC_EXPLICIT; - gfc_component *c; - bool seen_assumed = false; - bool seen_deferred = false; - - if (derived == NULL) - { - for (; param_list; param_list = param_list->next) - if (param_list->spec_type == SPEC_ASSUMED - || param_list->spec_type == SPEC_DEFERRED) - return param_list->spec_type; - } - else - { - for (; param_list; param_list = param_list->next) - { - c = gfc_find_component (derived, param_list->name, - true, true, NULL); - gcc_assert (c != NULL); - if (c->attr.pdt_kind) - continue; - else if (param_list->spec_type == SPEC_EXPLICIT) - return SPEC_EXPLICIT; - seen_assumed = param_list->spec_type == SPEC_ASSUMED; - seen_deferred = param_list->spec_type == SPEC_DEFERRED; - if (seen_assumed && seen_deferred) - return SPEC_EXPLICIT; - } - res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; - } - return res; -} - - -bool -gfc_ref_this_image (gfc_ref *ref) -{ - int n; - - gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); - - for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) - if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) - return false; - - return true; -} - -gfc_expr * -gfc_find_team_co (gfc_expr *e) -{ - gfc_ref *ref; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return ref->u.ar.team; - - if (e->value.function.actual->expr) - for (ref = e->value.function.actual->expr->ref; ref; - ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return ref->u.ar.team; - - return NULL; -} - -gfc_expr * -gfc_find_stat_co (gfc_expr *e) -{ - gfc_ref *ref; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return ref->u.ar.stat; - - if (e->value.function.actual->expr) - for (ref = e->value.function.actual->expr->ref; ref; - ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return ref->u.ar.stat; - - return NULL; -} - -bool -gfc_is_coindexed (gfc_expr *e) -{ - gfc_ref *ref; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - return !gfc_ref_this_image (ref); - - return false; -} - - -/* Coarrays are variables with a corank but not being coindexed. However, also - the following is a coarray: A subobject of a coarray is a coarray if it does - not have any cosubscripts, vector subscripts, allocatable component - selection, or pointer component selection. (F2008, 2.4.7) */ - -bool -gfc_is_coarray (gfc_expr *e) -{ - gfc_ref *ref; - gfc_symbol *sym; - gfc_component *comp; - bool coindexed; - bool coarray; - int i; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - coindexed = false; - sym = e->symtree->n.sym; - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok) - coarray = CLASS_DATA (sym)->attr.codimension; - else - coarray = sym->attr.codimension; - - for (ref = e->ref; ref; ref = ref->next) - switch (ref->type) - { - case REF_COMPONENT: - comp = ref->u.c.component; - if (comp->ts.type == BT_CLASS && comp->attr.class_ok - && (CLASS_DATA (comp)->attr.class_pointer - || CLASS_DATA (comp)->attr.allocatable)) - { - coindexed = false; - coarray = CLASS_DATA (comp)->attr.codimension; - } - else if (comp->attr.pointer || comp->attr.allocatable) - { - coindexed = false; - coarray = comp->attr.codimension; - } - break; - - case REF_ARRAY: - if (!coarray) - break; - - if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) - { - coindexed = true; - break; - } - - for (i = 0; i < ref->u.ar.dimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) - { - coarray = false; - break; - } - break; - - case REF_SUBSTRING: - case REF_INQUIRY: - break; - } - - return coarray && !coindexed; -} - - -int -gfc_get_corank (gfc_expr *e) -{ - int corank; - gfc_ref *ref; - - if (!gfc_is_coarray (e)) - return 0; - - if (e->ts.type == BT_CLASS && e->ts.u.derived->components) - corank = e->ts.u.derived->components->as - ? e->ts.u.derived->components->as->corank : 0; - else - corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; - - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY) - corank = ref->u.ar.as->corank; - gcc_assert (ref->type != REF_SUBSTRING); - } - - return corank; -} - - -/* Check whether the expression has an ultimate allocatable component. - Being itself allocatable does not count. */ -bool -gfc_has_ultimate_allocatable (gfc_expr *e) -{ - gfc_ref *ref, *last = NULL; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - last = ref; - - if (last && last->u.c.component->ts.type == BT_CLASS) - return CLASS_DATA (last->u.c.component)->attr.alloc_comp; - else if (last && last->u.c.component->ts.type == BT_DERIVED) - return last->u.c.component->ts.u.derived->attr.alloc_comp; - else if (last) - return false; - - if (e->ts.type == BT_CLASS) - return CLASS_DATA (e)->attr.alloc_comp; - else if (e->ts.type == BT_DERIVED) - return e->ts.u.derived->attr.alloc_comp; - else - return false; -} - - -/* Check whether the expression has an pointer component. - Being itself a pointer does not count. */ -bool -gfc_has_ultimate_pointer (gfc_expr *e) -{ - gfc_ref *ref, *last = NULL; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - last = ref; - - if (last && last->u.c.component->ts.type == BT_CLASS) - return CLASS_DATA (last->u.c.component)->attr.pointer_comp; - else if (last && last->u.c.component->ts.type == BT_DERIVED) - return last->u.c.component->ts.u.derived->attr.pointer_comp; - else if (last) - return false; - - if (e->ts.type == BT_CLASS) - return CLASS_DATA (e)->attr.pointer_comp; - else if (e->ts.type == BT_DERIVED) - return e->ts.u.derived->attr.pointer_comp; - else - return false; -} - - -/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. - Note: A scalar is not regarded as "simply contiguous" by the standard. - if bool is not strict, some further checks are done - for instance, - a "(::1)" is accepted. */ - -bool -gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) -{ - bool colon; - int i; - gfc_array_ref *ar = NULL; - gfc_ref *ref, *part_ref = NULL; - gfc_symbol *sym; - - if (expr->expr_type == EXPR_ARRAY) - return true; - - if (expr->expr_type == EXPR_FUNCTION) - { - if (expr->value.function.isym) - /* TRANSPOSE is the only intrinsic that may return a - non-contiguous array. It's treated as a special case in - gfc_conv_expr_descriptor too. */ - return (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE); - else if (expr->value.function.esym) - /* Only a pointer to an array without the contiguous attribute - can be non-contiguous as a result value. */ - return (expr->value.function.esym->result->attr.contiguous - || !expr->value.function.esym->result->attr.pointer); - else - { - /* Type-bound procedures. */ - gfc_symbol *s = expr->symtree->n.sym; - if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED) - return false; - - gfc_ref *rc = NULL; - for (gfc_ref *r = expr->ref; r; r = r->next) - if (r->type == REF_COMPONENT) - rc = r; - - if (rc == NULL || rc->u.c.component == NULL - || rc->u.c.component->ts.interface == NULL) - return false; - - return rc->u.c.component->ts.interface->attr.contiguous; - } - } - else if (expr->expr_type != EXPR_VARIABLE) - return false; - - if (!permit_element && expr->rank == 0) - return false; - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ar) - return false; /* Array shall be last part-ref. */ - - if (ref->type == REF_COMPONENT) - part_ref = ref; - else if (ref->type == REF_SUBSTRING) - return false; - else if (ref->type == REF_INQUIRY) - return false; - else if (ref->u.ar.type != AR_ELEMENT) - ar = &ref->u.ar; - } - - sym = expr->symtree->n.sym; - if (expr->ts.type != BT_CLASS - && ((part_ref - && !part_ref->u.c.component->attr.contiguous - && part_ref->u.c.component->attr.pointer) - || (!part_ref - && !sym->attr.contiguous - && (sym->attr.pointer - || (sym->as && sym->as->type == AS_ASSUMED_RANK) - || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))) - return false; - - if (!ar || ar->type == AR_FULL) - return true; - - gcc_assert (ar->type == AR_SECTION); - - /* Check for simply contiguous array */ - colon = true; - for (i = 0; i < ar->dimen; i++) - { - if (ar->dimen_type[i] == DIMEN_VECTOR) - return false; - - if (ar->dimen_type[i] == DIMEN_ELEMENT) - { - colon = false; - continue; - } - - gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); - - - /* If the previous section was not contiguous, that's an error, - unless we have effective only one element and checking is not - strict. */ - if (!colon && (strict || !ar->start[i] || !ar->end[i] - || ar->start[i]->expr_type != EXPR_CONSTANT - || ar->end[i]->expr_type != EXPR_CONSTANT - || mpz_cmp (ar->start[i]->value.integer, - ar->end[i]->value.integer) != 0)) - return false; - - /* Following the standard, "(::1)" or - if known at compile time - - "(lbound:ubound)" are not simply contiguous; if strict - is false, they are regarded as simply contiguous. */ - if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT - || ar->stride[i]->ts.type != BT_INTEGER - || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) - return false; - - if (ar->start[i] - && (strict || ar->start[i]->expr_type != EXPR_CONSTANT - || !ar->as->lower[i] - || ar->as->lower[i]->expr_type != EXPR_CONSTANT - || mpz_cmp (ar->start[i]->value.integer, - ar->as->lower[i]->value.integer) != 0)) - colon = false; - - if (ar->end[i] - && (strict || ar->end[i]->expr_type != EXPR_CONSTANT - || !ar->as->upper[i] - || ar->as->upper[i]->expr_type != EXPR_CONSTANT - || mpz_cmp (ar->end[i]->value.integer, - ar->as->upper[i]->value.integer) != 0)) - colon = false; - } - - return true; -} - -/* Return true if the expression is guaranteed to be non-contiguous, - false if we cannot prove anything. It is probably best to call - this after gfc_is_simply_contiguous. If neither of them returns - true, we cannot say (at compile-time). */ - -bool -gfc_is_not_contiguous (gfc_expr *array) -{ - int i; - gfc_array_ref *ar = NULL; - gfc_ref *ref; - bool previous_incomplete; - - for (ref = array->ref; ref; ref = ref->next) - { - /* Array-ref shall be last ref. */ - - if (ar && ar->type != AR_ELEMENT) - return true; - - if (ref->type == REF_ARRAY) - ar = &ref->u.ar; - } - - if (ar == NULL || ar->type != AR_SECTION) - return false; - - previous_incomplete = false; - - /* Check if we can prove that the array is not contiguous. */ - - for (i = 0; i < ar->dimen; i++) - { - mpz_t arr_size, ref_size; - - if (gfc_ref_dimen_size (ar, i, &ref_size, NULL)) - { - if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size)) - { - /* a(2:4,2:) is known to be non-contiguous, but - a(2:4,i:i) can be contiguous. */ - mpz_add_ui (arr_size, arr_size, 1L); - if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0) - { - mpz_clear (arr_size); - mpz_clear (ref_size); - return true; - } - else if (mpz_cmp (arr_size, ref_size) != 0) - previous_incomplete = true; - - mpz_clear (arr_size); - } - - /* Check for a(::2), i.e. where the stride is not unity. - This is only done if there is more than one element in - the reference along this dimension. */ - - if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION - && ar->dimen_type[i] == DIMEN_RANGE - && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT - && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0) - { - mpz_clear (ref_size); - return true; - } - - mpz_clear (ref_size); - } - } - /* We didn't find anything definitive. */ - return false; -} - -/* Build call to an intrinsic procedure. The number of arguments has to be - passed (rather than ending the list with a NULL value) because we may - want to add arguments but with a NULL-expression. */ - -gfc_expr* -gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, - locus where, unsigned numarg, ...) -{ - gfc_expr* result; - gfc_actual_arglist* atail; - gfc_intrinsic_sym* isym; - va_list ap; - unsigned i; - const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); - - isym = gfc_intrinsic_function_by_id (id); - gcc_assert (isym); - - result = gfc_get_expr (); - result->expr_type = EXPR_FUNCTION; - result->ts = isym->ts; - result->where = where; - result->value.function.name = mangled_name; - result->value.function.isym = isym; - - gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); - gfc_commit_symbol (result->symtree->n.sym); - gcc_assert (result->symtree - && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE - || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); - result->symtree->n.sym->intmod_sym_id = id; - result->symtree->n.sym->attr.flavor = FL_PROCEDURE; - result->symtree->n.sym->attr.intrinsic = 1; - result->symtree->n.sym->attr.artificial = 1; - - va_start (ap, numarg); - atail = NULL; - for (i = 0; i < numarg; ++i) - { - if (atail) - { - atail->next = gfc_get_actual_arglist (); - atail = atail->next; - } - else - atail = result->value.function.actual = gfc_get_actual_arglist (); - - atail->expr = va_arg (ap, gfc_expr*); - } - va_end (ap); - - return result; -} - - -/* Check if an expression may appear in a variable definition context - (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). - This is called from the various places when resolving - the pieces that make up such a context. - If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do - variables), some checks are not performed. - - Optionally, a possible error message can be suppressed if context is NULL - and just the return status (true / false) be requested. */ - -bool -gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, - bool own_scope, const char* context) -{ - gfc_symbol* sym = NULL; - bool is_pointer; - bool check_intentin; - bool ptr_component; - symbol_attribute attr; - gfc_ref* ref; - int i; - - if (e->expr_type == EXPR_VARIABLE) - { - gcc_assert (e->symtree); - sym = e->symtree->n.sym; - } - else if (e->expr_type == EXPR_FUNCTION) - { - gcc_assert (e->symtree); - sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; - } - - attr = gfc_expr_attr (e); - if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) - { - if (!(gfc_option.allow_std & GFC_STD_F2008)) - { - if (context) - gfc_error ("Fortran 2008: Pointer functions in variable definition" - " context (%s) at %L", context, &e->where); - return false; - } - } - else if (e->expr_type != EXPR_VARIABLE) - { - if (context) - gfc_error ("Non-variable expression in variable definition context (%s)" - " at %L", context, &e->where); - return false; - } - - if (!pointer && sym->attr.flavor == FL_PARAMETER) - { - if (context) - gfc_error ("Named constant %qs in variable definition context (%s)" - " at %L", sym->name, context, &e->where); - return false; - } - if (!pointer && sym->attr.flavor != FL_VARIABLE - && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) - && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer) - && !(sym->attr.flavor == FL_PROCEDURE - && sym->attr.function && sym->attr.pointer)) - { - if (context) - gfc_error ("%qs in variable definition context (%s) at %L is not" - " a variable", sym->name, context, &e->where); - return false; - } - - /* Find out whether the expr is a pointer; this also means following - component references to the last one. */ - is_pointer = (attr.pointer || attr.proc_pointer); - if (pointer && !is_pointer) - { - if (context) - gfc_error ("Non-POINTER in pointer association context (%s)" - " at %L", context, &e->where); - return false; - } - - if (e->ts.type == BT_DERIVED - && e->ts.u.derived == NULL) - { - if (context) - gfc_error ("Type inaccessible in variable definition context (%s) " - "at %L", context, &e->where); - return false; - } - - /* F2008, C1303. */ - if (!alloc_obj - && (attr.lock_comp - || (e->ts.type == BT_DERIVED - && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) - { - if (context) - gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", - context, &e->where); - return false; - } - - /* TS18508, C702/C203. */ - if (!alloc_obj - && (attr.lock_comp - || (e->ts.type == BT_DERIVED - && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) - { - if (context) - gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", - context, &e->where); - return false; - } - - /* INTENT(IN) dummy argument. Check this, unless the object itself is the - component of sub-component of a pointer; we need to distinguish - assignment to a pointer component from pointer-assignment to a pointer - component. Note that (normal) assignment to procedure pointers is not - possible. */ - check_intentin = !own_scope; - ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived - && CLASS_DATA (sym)) - ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; - for (ref = e->ref; ref && check_intentin; ref = ref->next) - { - if (ptr_component && ref->type == REF_COMPONENT) - check_intentin = false; - if (ref->type == REF_COMPONENT) - { - gfc_component *comp = ref->u.c.component; - ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok) - ? CLASS_DATA (comp)->attr.class_pointer - : comp->attr.pointer; - if (ptr_component && !pointer) - check_intentin = false; - } - if (ref->type == REF_INQUIRY - && (ref->u.i == INQUIRY_KIND || ref->u.i == INQUIRY_LEN)) - { - if (context) - gfc_error ("%qs parameter inquiry for %qs in " - "variable definition context (%s) at %L", - ref->u.i == INQUIRY_KIND ? "KIND" : "LEN", - sym->name, context, &e->where); - return false; - } - } - - if (check_intentin - && (sym->attr.intent == INTENT_IN - || (sym->attr.select_type_temporary && sym->assoc - && sym->assoc->target && sym->assoc->target->symtree - && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN))) - { - if (pointer && is_pointer) - { - if (context) - gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" - " association context (%s) at %L", - sym->name, context, &e->where); - return false; - } - if (!pointer && !is_pointer && !sym->attr.pointer) - { - const char *name = sym->attr.select_type_temporary - ? sym->assoc->target->symtree->name : sym->name; - if (context) - gfc_error ("Dummy argument %qs with INTENT(IN) in variable" - " definition context (%s) at %L", - name, context, &e->where); - return false; - } - } - - /* PROTECTED and use-associated. */ - if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) - { - if (pointer && is_pointer) - { - if (context) - gfc_error ("Variable %qs is PROTECTED and cannot appear in a" - " pointer association context (%s) at %L", - sym->name, context, &e->where); - return false; - } - if (!pointer && !is_pointer) - { - if (context) - gfc_error ("Variable %qs is PROTECTED and cannot appear in a" - " variable definition context (%s) at %L", - sym->name, context, &e->where); - return false; - } - } - - /* Variable not assignable from a PURE procedure but appears in - variable definition context. */ - own_scope = own_scope - || (sym->attr.result && sym->ns->proc_name - && sym == sym->ns->proc_name->result); - if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) - { - if (context) - gfc_error ("Variable %qs cannot appear in a variable definition" - " context (%s) at %L in PURE procedure", - sym->name, context, &e->where); - return false; - } - - if (!pointer && context && gfc_implicit_pure (NULL) - && gfc_impure_variable (sym)) - { - gfc_namespace *ns; - gfc_symbol *sym; - - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - sym = ns->proc_name; - if (sym == NULL) - break; - if (sym->attr.flavor == FL_PROCEDURE) - { - sym->attr.implicit_pure = 0; - break; - } - } - } - /* Check variable definition context for associate-names. */ - if (!pointer && sym->assoc && !sym->attr.select_rank_temporary) - { - const char* name; - gfc_association_list* assoc; - - gcc_assert (sym->assoc->target); - - /* If this is a SELECT TYPE temporary (the association is used internally - for SELECT TYPE), silently go over to the target. */ - if (sym->attr.select_type_temporary) - { - gfc_expr* t = sym->assoc->target; - - gcc_assert (t->expr_type == EXPR_VARIABLE); - name = t->symtree->name; - - if (t->symtree->n.sym->assoc) - assoc = t->symtree->n.sym->assoc; - else - assoc = sym->assoc; - } - else - { - name = sym->name; - assoc = sym->assoc; - } - gcc_assert (name && assoc); - - /* Is association to a valid variable? */ - if (!assoc->variable) - { - if (context) - { - if (assoc->target->expr_type == EXPR_VARIABLE) - gfc_error ("%qs at %L associated to vector-indexed target" - " cannot be used in a variable definition" - " context (%s)", - name, &e->where, context); - else - gfc_error ("%qs at %L associated to expression" - " cannot be used in a variable definition" - " context (%s)", - name, &e->where, context); - } - return false; - } - - /* Target must be allowed to appear in a variable definition context. */ - if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) - { - if (context) - gfc_error ("Associate-name %qs cannot appear in a variable" - " definition context (%s) at %L because its target" - " at %L cannot, either", - name, context, &e->where, - &assoc->target->where); - return false; - } - } - - /* Check for same value in vector expression subscript. */ - - if (e->rank > 0) - for (ref = e->ref; ref != NULL; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) - for (i = 0; i < GFC_MAX_DIMENSIONS - && ref->u.ar.dimen_type[i] != 0; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) - { - gfc_expr *arr = ref->u.ar.start[i]; - if (arr->expr_type == EXPR_ARRAY) - { - gfc_constructor *c, *n; - gfc_expr *ec, *en; - - for (c = gfc_constructor_first (arr->value.constructor); - c != NULL; c = gfc_constructor_next (c)) - { - if (c == NULL || c->iterator != NULL) - continue; - - ec = c->expr; - - for (n = gfc_constructor_next (c); n != NULL; - n = gfc_constructor_next (n)) - { - if (n->iterator != NULL) - continue; - - en = n->expr; - if (gfc_dep_compare_expr (ec, en) == 0) - { - if (context) - gfc_error_now ("Elements with the same value " - "at %L and %L in vector " - "subscript in a variable " - "definition context (%s)", - &(ec->where), &(en->where), - context); - return false; - } - } - } - } - } - - return true; -} diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc new file mode 100644 index 0000000..20b88a8 --- /dev/null +++ b/gcc/fortran/expr.cc @@ -0,0 +1,6507 @@ +/* Routines for manipulation of expression nodes. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "arith.h" +#include "match.h" +#include "target-memory.h" /* for gfc_convert_boz */ +#include "constructor.h" +#include "tree.h" + + +/* The following set of functions provide access to gfc_expr* of + various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. + + There are two functions available elsewhere that provide + slightly different flavours of variables. Namely: + expr.c (gfc_get_variable_expr) + symbol.c (gfc_lval_expr_from_sym) + TODO: Merge these functions, if possible. */ + +/* Get a new expression node. */ + +gfc_expr * +gfc_get_expr (void) +{ + gfc_expr *e; + + e = XCNEW (gfc_expr); + gfc_clear_ts (&e->ts); + e->shape = NULL; + e->ref = NULL; + e->symtree = NULL; + return e; +} + + +/* Get a new expression node that is an array constructor + of given type and kind. */ + +gfc_expr * +gfc_get_array_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->value.constructor = NULL; + e->rank = 1; + e->shape = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is the NULL expression. */ + +gfc_expr * +gfc_get_null_expr (locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; + + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an operator expression node. */ + +gfc_expr * +gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, + gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_OP; + e->value.op.op = op; + e->value.op.op1 = op1; + e->value.op.op2 = op2; + + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an structure constructor + of given type and kind. */ + +gfc_expr * +gfc_get_structure_constructor_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_STRUCTURE; + e->value.constructor = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an constant of given type and kind. */ + +gfc_expr * +gfc_get_constant_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + if (!where) + gfc_internal_error ("gfc_get_constant_expr(): locus % cannot be " + "NULL"); + + e = gfc_get_expr (); + + e->expr_type = EXPR_CONSTANT; + e->ts.type = type; + e->ts.kind = kind; + e->where = *where; + + switch (type) + { + case BT_INTEGER: + mpz_init (e->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (kind); + mpfr_init (e->value.real); + break; + + case BT_COMPLEX: + gfc_set_model_kind (kind); + mpc_init2 (e->value.complex, mpfr_get_default_prec()); + break; + + default: + break; + } + + return e; +} + + +/* Get a new expression node that is an string constant. + If no string is passed, a string of len is allocated, + blanked and null-terminated. */ + +gfc_expr * +gfc_get_character_expr (int kind, locus *where, const char *src, gfc_charlen_t len) +{ + gfc_expr *e; + gfc_char_t *dest; + + if (!src) + { + dest = gfc_get_wide_string (len + 1); + gfc_wide_memset (dest, ' ', len); + dest[len] = '\0'; + } + else + dest = gfc_char_to_widechar (src); + + e = gfc_get_constant_expr (BT_CHARACTER, kind, + where ? where : &gfc_current_locus); + e->value.character.string = dest; + e->value.character.length = len; + + return e; +} + + +/* Get a new expression node that is an integer constant. */ + +gfc_expr * +gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_INTEGER, kind, + where ? where : &gfc_current_locus); + + const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT); + wi::to_mpz (w, p->value.integer, SIGNED); + + return p; +} + + +/* Get a new expression node that is a logical constant. */ + +gfc_expr * +gfc_get_logical_expr (int kind, locus *where, bool value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_LOGICAL, kind, + where ? where : &gfc_current_locus); + + p->value.logical = value; + + return p; +} + + +gfc_expr * +gfc_get_iokind_expr (locus *where, io_kind k) +{ + gfc_expr *e; + + /* Set the types to something compatible with iokind. This is needed to + get through gfc_free_expr later since iokind really has no Basic Type, + BT, of its own. */ + + e = gfc_get_expr (); + e->expr_type = EXPR_CONSTANT; + e->ts.type = BT_LOGICAL; + e->value.iokind = k; + e->where = *where; + + return e; +} + + +/* Given an expression pointer, return a copy of the expression. This + subroutine is recursive. */ + +gfc_expr * +gfc_copy_expr (gfc_expr *p) +{ + gfc_expr *q; + gfc_char_t *s; + char *c; + + if (p == NULL) + return NULL; + + q = gfc_get_expr (); + *q = *p; + + switch (q->expr_type) + { + case EXPR_SUBSTRING: + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + break; + + case EXPR_CONSTANT: + /* Copy target representation, if it exists. */ + if (p->representation.string) + { + c = XCNEWVEC (char, p->representation.length + 1); + q->representation.string = c; + memcpy (c, p->representation.string, (p->representation.length + 1)); + } + + /* Copy the values of any pointer components of p->value. */ + switch (q->ts.type) + { + case BT_INTEGER: + mpz_init_set (q->value.integer, p->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (q->ts.kind); + mpfr_init (q->value.real); + mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (q->ts.kind); + mpc_init2 (q->value.complex, mpfr_get_default_prec()); + mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); + break; + + case BT_CHARACTER: + if (p->representation.string) + q->value.character.string + = gfc_char_to_widechar (q->representation.string); + else + { + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + + /* This is the case for the C_NULL_CHAR named constant. */ + if (p->value.character.length == 0 + && (p->ts.is_c_interop || p->ts.is_iso_c)) + { + *s = '\0'; + /* Need to set the length to 1 to make sure the NUL + terminator is copied. */ + q->value.character.length = 1; + } + else + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + } + break; + + case BT_HOLLERITH: + case BT_LOGICAL: + case_bt_struct: + case BT_CLASS: + case BT_ASSUMED: + break; /* Already done. */ + + case BT_BOZ: + q->boz.len = p->boz.len; + q->boz.rdx = p->boz.rdx; + q->boz.str = XCNEWVEC (char, q->boz.len + 1); + strncpy (q->boz.str, p->boz.str, p->boz.len); + break; + + case BT_PROCEDURE: + case BT_VOID: + /* Should never be reached. */ + case BT_UNKNOWN: + gfc_internal_error ("gfc_copy_expr(): Bad expr node"); + /* Not reached. */ + } + + break; + + case EXPR_OP: + switch (q->value.op.op) + { + case INTRINSIC_NOT: + case INTRINSIC_PARENTHESES: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + break; + + default: /* Binary operators. */ + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + q->value.op.op2 = gfc_copy_expr (p->value.op.op2); + break; + } + + break; + + case EXPR_FUNCTION: + q->value.function.actual = + gfc_copy_actual_arglist (p->value.function.actual); + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + q->value.compcall.actual = + gfc_copy_actual_arglist (p->value.compcall.actual); + q->value.compcall.tbp = p->value.compcall.tbp; + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + q->value.constructor = gfc_constructor_copy (p->value.constructor); + break; + + case EXPR_VARIABLE: + case EXPR_NULL: + break; + + case EXPR_UNKNOWN: + gcc_unreachable (); + } + + q->shape = gfc_copy_shape (p->shape, p->rank); + + q->ref = gfc_copy_ref (p->ref); + + if (p->param_list) + q->param_list = gfc_copy_actual_arglist (p->param_list); + + return q; +} + + +void +gfc_clear_shape (mpz_t *shape, int rank) +{ + int i; + + for (i = 0; i < rank; i++) + mpz_clear (shape[i]); +} + + +void +gfc_free_shape (mpz_t **shape, int rank) +{ + if (*shape == NULL) + return; + + gfc_clear_shape (*shape, rank); + free (*shape); + *shape = NULL; +} + + +/* Workhorse function for gfc_free_expr() that frees everything + beneath an expression node, but not the node itself. This is + useful when we want to simplify a node and replace it with + something else or the expression node belongs to another structure. */ + +static void +free_expr0 (gfc_expr *e) +{ + switch (e->expr_type) + { + case EXPR_CONSTANT: + /* Free any parts of the value that need freeing. */ + switch (e->ts.type) + { + case BT_INTEGER: + mpz_clear (e->value.integer); + break; + + case BT_REAL: + mpfr_clear (e->value.real); + break; + + case BT_CHARACTER: + free (e->value.character.string); + break; + + case BT_COMPLEX: + mpc_clear (e->value.complex); + break; + + default: + break; + } + + /* Free the representation. */ + free (e->representation.string); + + break; + + case EXPR_OP: + if (e->value.op.op1 != NULL) + gfc_free_expr (e->value.op.op1); + if (e->value.op.op2 != NULL) + gfc_free_expr (e->value.op.op2); + break; + + case EXPR_FUNCTION: + gfc_free_actual_arglist (e->value.function.actual); + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + gfc_free_actual_arglist (e->value.compcall.actual); + break; + + case EXPR_VARIABLE: + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + gfc_constructor_free (e->value.constructor); + break; + + case EXPR_SUBSTRING: + free (e->value.character.string); + break; + + case EXPR_NULL: + break; + + default: + gfc_internal_error ("free_expr0(): Bad expr type"); + } + + /* Free a shape array. */ + gfc_free_shape (&e->shape, e->rank); + + gfc_free_ref_list (e->ref); + + gfc_free_actual_arglist (e->param_list); + + memset (e, '\0', sizeof (gfc_expr)); +} + + +/* Free an expression node and everything beneath it. */ + +void +gfc_free_expr (gfc_expr *e) +{ + if (e == NULL) + return; + free_expr0 (e); + free (e); +} + + +/* Free an argument list and everything below it. */ + +void +gfc_free_actual_arglist (gfc_actual_arglist *a1) +{ + gfc_actual_arglist *a2; + + while (a1) + { + a2 = a1->next; + if (a1->expr) + gfc_free_expr (a1->expr); + free (a1); + a1 = a2; + } +} + + +/* Copy an arglist structure and all of the arguments. */ + +gfc_actual_arglist * +gfc_copy_actual_arglist (gfc_actual_arglist *p) +{ + gfc_actual_arglist *head, *tail, *new_arg; + + head = tail = NULL; + + for (; p; p = p->next) + { + new_arg = gfc_get_actual_arglist (); + *new_arg = *p; + + new_arg->expr = gfc_copy_expr (p->expr); + new_arg->next = NULL; + + if (head == NULL) + head = new_arg; + else + tail->next = new_arg; + + tail = new_arg; + } + + return head; +} + + +/* Free a list of reference structures. */ + +void +gfc_free_ref_list (gfc_ref *p) +{ + gfc_ref *q; + int i; + + for (; p; p = q) + { + q = p->next; + + switch (p->type) + { + case REF_ARRAY: + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + gfc_free_expr (p->u.ar.start[i]); + gfc_free_expr (p->u.ar.end[i]); + gfc_free_expr (p->u.ar.stride[i]); + } + + break; + + case REF_SUBSTRING: + gfc_free_expr (p->u.ss.start); + gfc_free_expr (p->u.ss.end); + break; + + case REF_COMPONENT: + case REF_INQUIRY: + break; + } + + free (p); + } +} + + +/* Graft the *src expression onto the *dest subexpression. */ + +void +gfc_replace_expr (gfc_expr *dest, gfc_expr *src) +{ + free_expr0 (dest); + *dest = *src; + free (src); +} + + +/* Try to extract an integer constant from the passed expression node. + Return true if some error occurred, false on success. If REPORT_ERROR + is non-zero, emit error, for positive REPORT_ERROR using gfc_error, + for negative using gfc_error_now. */ + +bool +gfc_extract_int (gfc_expr *expr, int *result, int report_error) +{ + gfc_ref *ref; + + /* A KIND component is a parameter too. The expression for it + is stored in the initializer and should be consistent with + the tests below. */ + if (gfc_expr_attr(expr).pdt_kind) + { + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->u.c.component->attr.pdt_kind) + expr = ref->u.c.component->initializer; + } + } + + if (expr->expr_type != EXPR_CONSTANT) + { + if (report_error > 0) + gfc_error ("Constant expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Constant expression required at %C"); + return true; + } + + if (expr->ts.type != BT_INTEGER) + { + if (report_error > 0) + gfc_error ("Integer expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Integer expression required at %C"); + return true; + } + + if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) + || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) + { + if (report_error > 0) + gfc_error ("Integer value too large in expression at %C"); + else if (report_error < 0) + gfc_error_now ("Integer value too large in expression at %C"); + return true; + } + + *result = (int) mpz_get_si (expr->value.integer); + + return false; +} + + +/* Same as gfc_extract_int, but use a HWI. */ + +bool +gfc_extract_hwi (gfc_expr *expr, HOST_WIDE_INT *result, int report_error) +{ + gfc_ref *ref; + + /* A KIND component is a parameter too. The expression for it is + stored in the initializer and should be consistent with the tests + below. */ + if (gfc_expr_attr(expr).pdt_kind) + { + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->u.c.component->attr.pdt_kind) + expr = ref->u.c.component->initializer; + } + } + + if (expr->expr_type != EXPR_CONSTANT) + { + if (report_error > 0) + gfc_error ("Constant expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Constant expression required at %C"); + return true; + } + + if (expr->ts.type != BT_INTEGER) + { + if (report_error > 0) + gfc_error ("Integer expression required at %C"); + else if (report_error < 0) + gfc_error_now ("Integer expression required at %C"); + return true; + } + + /* Use long_long_integer_type_node to determine when to saturate. */ + const wide_int val = wi::from_mpz (long_long_integer_type_node, + expr->value.integer, false); + + if (!wi::fits_shwi_p (val)) + { + if (report_error > 0) + gfc_error ("Integer value too large in expression at %C"); + else if (report_error < 0) + gfc_error_now ("Integer value too large in expression at %C"); + return true; + } + + *result = val.to_shwi (); + + return false; +} + + +/* Recursively copy a list of reference structures. */ + +gfc_ref * +gfc_copy_ref (gfc_ref *src) +{ + gfc_array_ref *ar; + gfc_ref *dest; + + if (src == NULL) + return NULL; + + dest = gfc_get_ref (); + dest->type = src->type; + + switch (src->type) + { + case REF_ARRAY: + ar = gfc_copy_array_ref (&src->u.ar); + dest->u.ar = *ar; + free (ar); + break; + + case REF_COMPONENT: + dest->u.c = src->u.c; + break; + + case REF_INQUIRY: + dest->u.i = src->u.i; + break; + + case REF_SUBSTRING: + dest->u.ss = src->u.ss; + dest->u.ss.start = gfc_copy_expr (src->u.ss.start); + dest->u.ss.end = gfc_copy_expr (src->u.ss.end); + break; + } + + dest->next = gfc_copy_ref (src->next); + + return dest; +} + + +/* Detect whether an expression has any vector index array references. */ + +int +gfc_has_vector_index (gfc_expr *e) +{ + gfc_ref *ref; + int i; + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + for (i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + return 1; + return 0; +} + + +/* Copy a shape array. */ + +mpz_t * +gfc_copy_shape (mpz_t *shape, int rank) +{ + mpz_t *new_shape; + int n; + + if (shape == NULL) + return NULL; + + new_shape = gfc_get_shape (rank); + + for (n = 0; n < rank; n++) + mpz_init_set (new_shape[n], shape[n]); + + return new_shape; +} + + +/* Copy a shape array excluding dimension N, where N is an integer + constant expression. Dimensions are numbered in Fortran style -- + starting with ONE. + + So, if the original shape array contains R elements + { s1 ... sN-1 sN sN+1 ... sR-1 sR} + the result contains R-1 elements: + { s1 ... sN-1 sN+1 ... sR-1} + + If anything goes wrong -- N is not a constant, its value is out + of range -- or anything else, just returns NULL. */ + +mpz_t * +gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) +{ + mpz_t *new_shape, *s; + int i, n; + + if (shape == NULL + || rank <= 1 + || dim == NULL + || dim->expr_type != EXPR_CONSTANT + || dim->ts.type != BT_INTEGER) + return NULL; + + n = mpz_get_si (dim->value.integer); + n--; /* Convert to zero based index. */ + if (n < 0 || n >= rank) + return NULL; + + s = new_shape = gfc_get_shape (rank - 1); + + for (i = 0; i < rank; i++) + { + if (i == n) + continue; + mpz_init_set (*s, shape[i]); + s++; + } + + return new_shape; +} + + +/* Return the maximum kind of two expressions. In general, higher + kind numbers mean more precision for numeric types. */ + +int +gfc_kind_max (gfc_expr *e1, gfc_expr *e2) +{ + return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; +} + + +/* Returns nonzero if the type is numeric, zero otherwise. */ + +static int +numeric_type (bt type) +{ + return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; +} + + +/* Returns nonzero if the typespec is a numeric type, zero otherwise. */ + +int +gfc_numeric_ts (gfc_typespec *ts) +{ + return numeric_type (ts->type); +} + + +/* Return an expression node with an optional argument list attached. + A variable number of gfc_expr pointers are strung together in an + argument list with a NULL pointer terminating the list. */ + +gfc_expr * +gfc_build_conversion (gfc_expr *e) +{ + gfc_expr *p; + + p = gfc_get_expr (); + p->expr_type = EXPR_FUNCTION; + p->symtree = NULL; + p->value.function.actual = gfc_get_actual_arglist (); + p->value.function.actual->expr = e; + + return p; +} + + +/* Given an expression node with some sort of numeric binary + expression, insert type conversions required to make the operands + have the same type. Conversion warnings are disabled if wconversion + is set to 0. + + The exception is that the operands of an exponential don't have to + have the same type. If possible, the base is promoted to the type + of the exponent. For example, 1**2.3 becomes 1.0**2.3, but + 1.0**2 stays as it is. */ + +void +gfc_type_convert_binary (gfc_expr *e, int wconversion) +{ + gfc_expr *op1, *op2; + + op1 = e->value.op.op1; + op2 = e->value.op.op2; + + if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) + { + gfc_clear_ts (&e->ts); + return; + } + + /* Kind conversions of same type. */ + if (op1->ts.type == op2->ts.type) + { + if (op1->ts.kind == op2->ts.kind) + { + /* No type conversions. */ + e->ts = op1->ts; + goto done; + } + + if (op1->ts.kind > op2->ts.kind) + gfc_convert_type_warn (op2, &op1->ts, 2, wconversion); + else + gfc_convert_type_warn (op1, &op2->ts, 2, wconversion); + + e->ts = op1->ts; + goto done; + } + + /* Integer combined with real or complex. */ + if (op2->ts.type == BT_INTEGER) + { + e->ts = op1->ts; + + /* Special case for ** operator. */ + if (e->value.op.op == INTRINSIC_POWER) + goto done; + + gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); + goto done; + } + + if (op1->ts.type == BT_INTEGER) + { + e->ts = op2->ts; + gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); + goto done; + } + + /* Real combined with complex. */ + e->ts.type = BT_COMPLEX; + if (op1->ts.kind > op2->ts.kind) + e->ts.kind = op1->ts.kind; + else + e->ts.kind = op2->ts.kind; + if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) + gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion); + if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) + gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion); + +done: + return; +} + + +/* Standard intrinsics listed under F2018:10.1.12 (6), which are excluded in + constant expressions, except TRANSFER (c.f. item (8)), which would need + separate treatment. */ + +static bool +is_non_constant_intrinsic (gfc_expr *e) +{ + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym) + { + switch (e->value.function.isym->id) + { + case GFC_ISYM_COMMAND_ARGUMENT_COUNT: + case GFC_ISYM_GET_TEAM: + case GFC_ISYM_NULL: + case GFC_ISYM_NUM_IMAGES: + case GFC_ISYM_TEAM_NUMBER: + case GFC_ISYM_THIS_IMAGE: + return true; + + default: + return false; + } + } + return false; +} + + +/* Determine if an expression is constant in the sense of F08:7.1.12. + * This function expects that the expression has already been simplified. */ + +bool +gfc_is_constant_expr (gfc_expr *e) +{ + gfc_constructor *c; + gfc_actual_arglist *arg; + + if (e == NULL) + return true; + + switch (e->expr_type) + { + case EXPR_OP: + return (gfc_is_constant_expr (e->value.op.op1) + && (e->value.op.op2 == NULL + || gfc_is_constant_expr (e->value.op.op2))); + + case EXPR_VARIABLE: + /* The only context in which this can occur is in a parameterized + derived type declaration, so returning true is OK. */ + if (e->symtree->n.sym->attr.pdt_len + || e->symtree->n.sym->attr.pdt_kind) + return true; + return false; + + case EXPR_FUNCTION: + case EXPR_PPC: + case EXPR_COMPCALL: + gcc_assert (e->symtree || e->value.function.esym + || e->value.function.isym); + + /* Check for intrinsics excluded in constant expressions. */ + if (e->value.function.isym && is_non_constant_intrinsic (e)) + return false; + + /* Call to intrinsic with at least one argument. */ + if (e->value.function.isym && e->value.function.actual) + { + for (arg = e->value.function.actual; arg; arg = arg->next) + if (!gfc_is_constant_expr (arg->expr)) + return false; + } + + if (e->value.function.isym + && (e->value.function.isym->elemental + || e->value.function.isym->pure + || e->value.function.isym->inquiry + || e->value.function.isym->transformational)) + return true; + + return false; + + case EXPR_CONSTANT: + case EXPR_NULL: + return true; + + case EXPR_SUBSTRING: + return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) + && gfc_is_constant_expr (e->ref->u.ss.end)); + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + c = gfc_constructor_first (e->value.constructor); + if ((e->expr_type == EXPR_ARRAY) && c && c->iterator) + return gfc_constant_ac (e); + + for (; c; c = gfc_constructor_next (c)) + if (!gfc_is_constant_expr (c->expr)) + return false; + + return true; + + + default: + gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); + return false; + } +} + + +/* Is true if the expression or symbol is a passed CFI descriptor. */ +bool +is_CFI_desc (gfc_symbol *sym, gfc_expr *e) +{ + if (sym == NULL + && e && e->expr_type == EXPR_VARIABLE) + sym = e->symtree->n.sym; + + if (sym && sym->attr.dummy + && sym->ns->proc_name->attr.is_bind_c + && (sym->attr.pointer + || sym->attr.allocatable + || (sym->attr.dimension + && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK)) + || (sym->ts.type == BT_CHARACTER + && (!sym->ts.u.cl || !sym->ts.u.cl->length)))) + return true; + +return false; +} + + +/* Is true if an array reference is followed by a component or substring + reference. */ +bool +is_subref_array (gfc_expr * e) +{ + gfc_ref * ref; + bool seen_array; + gfc_symbol *sym; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + sym = e->symtree->n.sym; + + if (sym->attr.subref_array_pointer) + return true; + + seen_array = false; + + for (ref = e->ref; ref; ref = ref->next) + { + /* If we haven't seen the array reference and this is an intrinsic, + what follows cannot be a subreference array, unless there is a + substring reference. */ + if (!seen_array && ref->type == REF_COMPONENT + && ref->u.c.component->ts.type != BT_CHARACTER + && ref->u.c.component->ts.type != BT_CLASS + && !gfc_bt_struct (ref->u.c.component->ts.type)) + return false; + + if (ref->type == REF_ARRAY + && ref->u.ar.type != AR_ELEMENT) + seen_array = true; + + if (seen_array + && ref->type != REF_ARRAY) + return seen_array; + } + + if (sym->ts.type == BT_CLASS + && sym->attr.dummy + && CLASS_DATA (sym)->attr.dimension + && CLASS_DATA (sym)->attr.class_pointer) + return true; + + return false; +} + + +/* Try to collapse intrinsic expressions. */ + +static bool +simplify_intrinsic_op (gfc_expr *p, int type) +{ + gfc_intrinsic_op op; + gfc_expr *op1, *op2, *result; + + if (p->value.op.op == INTRINSIC_USER) + return true; + + op1 = p->value.op.op1; + op2 = p->value.op.op2; + op = p->value.op.op; + + if (!gfc_simplify_expr (op1, type)) + return false; + if (!gfc_simplify_expr (op2, type)) + return false; + + if (!gfc_is_constant_expr (op1) + || (op2 != NULL && !gfc_is_constant_expr (op2))) + return true; + + /* Rip p apart. */ + p->value.op.op1 = NULL; + p->value.op.op2 = NULL; + + switch (op) + { + case INTRINSIC_PARENTHESES: + result = gfc_parentheses (op1); + break; + + case INTRINSIC_UPLUS: + result = gfc_uplus (op1); + break; + + case INTRINSIC_UMINUS: + result = gfc_uminus (op1); + break; + + case INTRINSIC_PLUS: + result = gfc_add (op1, op2); + break; + + case INTRINSIC_MINUS: + result = gfc_subtract (op1, op2); + break; + + case INTRINSIC_TIMES: + result = gfc_multiply (op1, op2); + break; + + case INTRINSIC_DIVIDE: + result = gfc_divide (op1, op2); + break; + + case INTRINSIC_POWER: + result = gfc_power (op1, op2); + break; + + case INTRINSIC_CONCAT: + result = gfc_concat (op1, op2); + break; + + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + result = gfc_eq (op1, op2, op); + break; + + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + result = gfc_ne (op1, op2, op); + break; + + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + result = gfc_gt (op1, op2, op); + break; + + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + result = gfc_ge (op1, op2, op); + break; + + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + result = gfc_lt (op1, op2, op); + break; + + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + result = gfc_le (op1, op2, op); + break; + + case INTRINSIC_NOT: + result = gfc_not (op1); + break; + + case INTRINSIC_AND: + result = gfc_and (op1, op2); + break; + + case INTRINSIC_OR: + result = gfc_or (op1, op2); + break; + + case INTRINSIC_EQV: + result = gfc_eqv (op1, op2); + break; + + case INTRINSIC_NEQV: + result = gfc_neqv (op1, op2); + break; + + default: + gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); + } + + if (result == NULL) + { + gfc_free_expr (op1); + gfc_free_expr (op2); + return false; + } + + result->rank = p->rank; + result->where = p->where; + gfc_replace_expr (p, result); + + return true; +} + + +/* Subroutine to simplify constructor expressions. Mutually recursive + with gfc_simplify_expr(). */ + +static bool +simplify_constructor (gfc_constructor_base base, int type) +{ + gfc_constructor *c; + gfc_expr *p; + + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + if (c->iterator + && (!gfc_simplify_expr(c->iterator->start, type) + || !gfc_simplify_expr (c->iterator->end, type) + || !gfc_simplify_expr (c->iterator->step, type))) + return false; + + if (c->expr) + { + /* Try and simplify a copy. Replace the original if successful + but keep going through the constructor at all costs. Not + doing so can make a dog's dinner of complicated things. */ + p = gfc_copy_expr (c->expr); + + if (!gfc_simplify_expr (p, type)) + { + gfc_free_expr (p); + continue; + } + + gfc_replace_expr (c->expr, p); + } + } + + return true; +} + + +/* Pull a single array element out of an array constructor. */ + +static bool +find_array_element (gfc_constructor_base base, gfc_array_ref *ar, + gfc_constructor **rval) +{ + unsigned long nelemen; + int i; + mpz_t delta; + mpz_t offset; + mpz_t span; + mpz_t tmp; + gfc_constructor *cons; + gfc_expr *e; + bool t; + + t = true; + e = NULL; + + mpz_init_set_ui (offset, 0); + mpz_init (delta); + mpz_init (tmp); + mpz_init_set_ui (span, 1); + for (i = 0; i < ar->dimen; i++) + { + if (!gfc_reduce_init_expr (ar->as->lower[i]) + || !gfc_reduce_init_expr (ar->as->upper[i]) + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || ar->as->lower[i]->expr_type != EXPR_CONSTANT) + { + t = false; + cons = NULL; + goto depart; + } + + e = ar->start[i]; + if (e->expr_type != EXPR_CONSTANT) + { + cons = NULL; + goto depart; + } + + /* Check the bounds. */ + if ((ar->as->upper[i] + && mpz_cmp (e->value.integer, + ar->as->upper[i]->value.integer) > 0) + || (mpz_cmp (e->value.integer, + ar->as->lower[i]->value.integer) < 0)) + { + gfc_error ("Index in dimension %d is out of bounds " + "at %L", i + 1, &ar->c_where[i]); + cons = NULL; + t = false; + goto depart; + } + + mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); + mpz_mul (delta, delta, span); + mpz_add (offset, offset, delta); + + mpz_set_ui (tmp, 1); + mpz_add (tmp, tmp, ar->as->upper[i]->value.integer); + mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); + mpz_mul (span, span, tmp); + } + + for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); + cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) + { + if (cons->iterator) + { + cons = NULL; + goto depart; + } + } + +depart: + mpz_clear (delta); + mpz_clear (offset); + mpz_clear (span); + mpz_clear (tmp); + *rval = cons; + return t; +} + + +/* Find a component of a structure constructor. */ + +static gfc_constructor * +find_component_ref (gfc_constructor_base base, gfc_ref *ref) +{ + gfc_component *pick = ref->u.c.component; + gfc_constructor *c = gfc_constructor_first (base); + + gfc_symbol *dt = ref->u.c.sym; + int ext = dt->attr.extension; + + /* For extended types, check if the desired component is in one of the + * parent types. */ + while (ext > 0 && gfc_find_component (dt->components->ts.u.derived, + pick->name, true, true, NULL)) + { + dt = dt->components->ts.u.derived; + c = gfc_constructor_first (c->expr->value.constructor); + ext--; + } + + gfc_component *comp = dt->components; + while (comp != pick) + { + comp = comp->next; + c = gfc_constructor_next (c); + } + + return c; +} + + +/* Replace an expression with the contents of a constructor, removing + the subobject reference in the process. */ + +static void +remove_subobject_ref (gfc_expr *p, gfc_constructor *cons) +{ + gfc_expr *e; + + if (cons) + { + e = cons->expr; + cons->expr = NULL; + } + else + e = gfc_copy_expr (p); + e->ref = p->ref->next; + p->ref->next = NULL; + gfc_replace_expr (p, e); +} + + +/* Pull an array section out of an array constructor. */ + +static bool +find_array_section (gfc_expr *expr, gfc_ref *ref) +{ + int idx; + int rank; + int d; + int shape_i; + int limit; + long unsigned one = 1; + bool incr_ctr; + mpz_t start[GFC_MAX_DIMENSIONS]; + mpz_t end[GFC_MAX_DIMENSIONS]; + mpz_t stride[GFC_MAX_DIMENSIONS]; + mpz_t delta[GFC_MAX_DIMENSIONS]; + mpz_t ctr[GFC_MAX_DIMENSIONS]; + mpz_t delta_mpz; + mpz_t tmp_mpz; + mpz_t nelts; + mpz_t ptr; + gfc_constructor_base base; + gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; + gfc_expr *begin; + gfc_expr *finish; + gfc_expr *step; + gfc_expr *upper; + gfc_expr *lower; + bool t; + + t = true; + + base = expr->value.constructor; + expr->value.constructor = NULL; + + rank = ref->u.ar.as->rank; + + if (expr->shape == NULL) + expr->shape = gfc_get_shape (rank); + + mpz_init_set_ui (delta_mpz, one); + mpz_init_set_ui (nelts, one); + mpz_init (tmp_mpz); + + /* Do the initialization now, so that we can cleanup without + keeping track of where we were. */ + for (d = 0; d < rank; d++) + { + mpz_init (delta[d]); + mpz_init (start[d]); + mpz_init (end[d]); + mpz_init (ctr[d]); + mpz_init (stride[d]); + vecsub[d] = NULL; + } + + /* Build the counters to clock through the array reference. */ + shape_i = 0; + for (d = 0; d < rank; d++) + { + /* Make this stretch of code easier on the eye! */ + begin = ref->u.ar.start[d]; + finish = ref->u.ar.end[d]; + step = ref->u.ar.stride[d]; + lower = ref->u.ar.as->lower[d]; + upper = ref->u.ar.as->upper[d]; + + if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ + { + gfc_constructor *ci; + gcc_assert (begin); + + if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) + { + t = false; + goto cleanup; + } + + gcc_assert (begin->rank == 1); + /* Zero-sized arrays have no shape and no elements, stop early. */ + if (!begin->shape) + { + mpz_init_set_ui (nelts, 0); + break; + } + + vecsub[d] = gfc_constructor_first (begin->value.constructor); + mpz_set (ctr[d], vecsub[d]->expr->value.integer); + mpz_mul (nelts, nelts, begin->shape[0]); + mpz_set (expr->shape[shape_i++], begin->shape[0]); + + /* Check bounds. */ + for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) + { + if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 + || mpz_cmp (ci->expr->value.integer, + lower->value.integer) < 0) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", d + 1, &ref->u.ar.c_where[d]); + t = false; + goto cleanup; + } + } + } + else + { + if ((begin && begin->expr_type != EXPR_CONSTANT) + || (finish && finish->expr_type != EXPR_CONSTANT) + || (step && step->expr_type != EXPR_CONSTANT)) + { + t = false; + goto cleanup; + } + + /* Obtain the stride. */ + if (step) + mpz_set (stride[d], step->value.integer); + else + mpz_set_ui (stride[d], one); + + if (mpz_cmp_ui (stride[d], 0) == 0) + mpz_set_ui (stride[d], one); + + /* Obtain the start value for the index. */ + if (begin) + mpz_set (start[d], begin->value.integer); + else + mpz_set (start[d], lower->value.integer); + + mpz_set (ctr[d], start[d]); + + /* Obtain the end value for the index. */ + if (finish) + mpz_set (end[d], finish->value.integer); + else + mpz_set (end[d], upper->value.integer); + + /* Separate 'if' because elements sometimes arrive with + non-null end. */ + if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) + mpz_set (end [d], begin->value.integer); + + /* Check the bounds. */ + if (mpz_cmp (ctr[d], upper->value.integer) > 0 + || mpz_cmp (end[d], upper->value.integer) > 0 + || mpz_cmp (ctr[d], lower->value.integer) < 0 + || mpz_cmp (end[d], lower->value.integer) < 0) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", d + 1, &ref->u.ar.c_where[d]); + t = false; + goto cleanup; + } + + /* Calculate the number of elements and the shape. */ + mpz_set (tmp_mpz, stride[d]); + mpz_add (tmp_mpz, end[d], tmp_mpz); + mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); + mpz_div (tmp_mpz, tmp_mpz, stride[d]); + mpz_mul (nelts, nelts, tmp_mpz); + + /* An element reference reduces the rank of the expression; don't + add anything to the shape array. */ + if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) + mpz_set (expr->shape[shape_i++], tmp_mpz); + } + + /* Calculate the 'stride' (=delta) for conversion of the + counter values into the index along the constructor. */ + mpz_set (delta[d], delta_mpz); + mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); + mpz_add_ui (tmp_mpz, tmp_mpz, one); + mpz_mul (delta_mpz, delta_mpz, tmp_mpz); + } + + mpz_init (ptr); + cons = gfc_constructor_first (base); + + /* Now clock through the array reference, calculating the index in + the source constructor and transferring the elements to the new + constructor. */ + for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) + { + mpz_init_set_ui (ptr, 0); + + incr_ctr = true; + for (d = 0; d < rank; d++) + { + mpz_set (tmp_mpz, ctr[d]); + mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer); + mpz_mul (tmp_mpz, tmp_mpz, delta[d]); + mpz_add (ptr, ptr, tmp_mpz); + + if (!incr_ctr) continue; + + if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ + { + gcc_assert(vecsub[d]); + + if (!gfc_constructor_next (vecsub[d])) + vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); + else + { + vecsub[d] = gfc_constructor_next (vecsub[d]); + incr_ctr = false; + } + mpz_set (ctr[d], vecsub[d]->expr->value.integer); + } + else + { + mpz_add (ctr[d], ctr[d], stride[d]); + + if (mpz_cmp_ui (stride[d], 0) > 0 + ? mpz_cmp (ctr[d], end[d]) > 0 + : mpz_cmp (ctr[d], end[d]) < 0) + mpz_set (ctr[d], start[d]); + else + incr_ctr = false; + } + } + + limit = mpz_get_ui (ptr); + if (limit >= flag_max_array_constructor) + { + gfc_error ("The number of elements in the array constructor " + "at %L requires an increase of the allowed %d " + "upper limit. See %<-fmax-array-constructor%> " + "option", &expr->where, flag_max_array_constructor); + return false; + } + + cons = gfc_constructor_lookup (base, limit); + gcc_assert (cons); + gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (cons->expr), NULL); + } + + mpz_clear (ptr); + +cleanup: + + mpz_clear (delta_mpz); + mpz_clear (tmp_mpz); + mpz_clear (nelts); + for (d = 0; d < rank; d++) + { + mpz_clear (delta[d]); + mpz_clear (start[d]); + mpz_clear (end[d]); + mpz_clear (ctr[d]); + mpz_clear (stride[d]); + } + gfc_constructor_free (base); + return t; +} + +/* Pull a substring out of an expression. */ + +static bool +find_substring_ref (gfc_expr *p, gfc_expr **newp) +{ + gfc_charlen_t end; + gfc_charlen_t start; + gfc_charlen_t length; + gfc_char_t *chr; + + if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT + || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) + return false; + + *newp = gfc_copy_expr (p); + free ((*newp)->value.character.string); + + end = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.end->value.integer); + start = (gfc_charlen_t) mpz_get_si (p->ref->u.ss.start->value.integer); + if (end >= start) + length = end - start + 1; + else + length = 0; + + chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1); + (*newp)->value.character.length = length; + memcpy (chr, &p->value.character.string[start - 1], + length * sizeof (gfc_char_t)); + chr[length] = '\0'; + return true; +} + + +/* Pull an inquiry result out of an expression. */ + +static bool +find_inquiry_ref (gfc_expr *p, gfc_expr **newp) +{ + gfc_ref *ref; + gfc_ref *inquiry = NULL; + gfc_expr *tmp; + + tmp = gfc_copy_expr (p); + + if (tmp->ref && tmp->ref->type == REF_INQUIRY) + { + inquiry = tmp->ref; + tmp->ref = NULL; + } + else + { + for (ref = tmp->ref; ref; ref = ref->next) + if (ref->next && ref->next->type == REF_INQUIRY) + { + inquiry = ref->next; + ref->next = NULL; + } + } + + if (!inquiry) + { + gfc_free_expr (tmp); + return false; + } + + gfc_resolve_expr (tmp); + + /* In principle there can be more than one inquiry reference. */ + for (; inquiry; inquiry = inquiry->next) + { + switch (inquiry->u.i) + { + case INQUIRY_LEN: + if (tmp->ts.type != BT_CHARACTER) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) + goto cleanup; + + if (tmp->ts.u.cl->length + && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) + *newp = gfc_copy_expr (tmp->ts.u.cl->length); + else if (tmp->expr_type == EXPR_CONSTANT) + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp->value.character.length); + else + goto cleanup; + + break; + + case INQUIRY_KIND: + if (tmp->ts.type == BT_DERIVED || tmp->ts.type == BT_CLASS) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) + goto cleanup; + + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp->ts.kind); + break; + + case INQUIRY_RE: + if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) + goto cleanup; + + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); + mpfr_set ((*newp)->value.real, + mpc_realref (tmp->value.complex), GFC_RND_MODE); + break; + + case INQUIRY_IM: + if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) + goto cleanup; + + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); + mpfr_set ((*newp)->value.real, + mpc_imagref (tmp->value.complex), GFC_RND_MODE); + break; + } + tmp = gfc_copy_expr (*newp); + } + + if (!(*newp)) + goto cleanup; + else if ((*newp)->expr_type != EXPR_CONSTANT) + { + gfc_free_expr (*newp); + goto cleanup; + } + + gfc_free_expr (tmp); + return true; + +cleanup: + gfc_free_expr (tmp); + return false; +} + + + +/* Simplify a subobject reference of a constructor. This occurs when + parameter variable values are substituted. */ + +static bool +simplify_const_ref (gfc_expr *p) +{ + gfc_constructor *cons, *c; + gfc_expr *newp = NULL; + gfc_ref *last_ref; + + while (p->ref) + { + switch (p->ref->type) + { + case REF_ARRAY: + switch (p->ref->u.ar.type) + { + case AR_ELEMENT: + /* , parameter :: x() = scalar_expr + will generate this. */ + if (p->expr_type != EXPR_ARRAY) + { + remove_subobject_ref (p, NULL); + break; + } + if (!find_array_element (p->value.constructor, &p->ref->u.ar, &cons)) + return false; + + if (!cons) + return true; + + remove_subobject_ref (p, cons); + break; + + case AR_SECTION: + if (!find_array_section (p, p->ref)) + return false; + p->ref->u.ar.type = AR_FULL; + + /* Fall through. */ + + case AR_FULL: + if (p->ref->next != NULL + && (p->ts.type == BT_CHARACTER || gfc_bt_struct (p->ts.type))) + { + for (c = gfc_constructor_first (p->value.constructor); + c; c = gfc_constructor_next (c)) + { + c->expr->ref = gfc_copy_ref (p->ref->next); + if (!simplify_const_ref (c->expr)) + return false; + } + + if (gfc_bt_struct (p->ts.type) + && p->ref->next + && (c = gfc_constructor_first (p->value.constructor))) + { + /* There may have been component references. */ + p->ts = c->expr->ts; + } + + last_ref = p->ref; + for (; last_ref->next; last_ref = last_ref->next) {}; + + if (p->ts.type == BT_CHARACTER + && last_ref->type == REF_SUBSTRING) + { + /* If this is a CHARACTER array and we possibly took + a substring out of it, update the type-spec's + character length according to the first element + (as all should have the same length). */ + gfc_charlen_t string_len; + if ((c = gfc_constructor_first (p->value.constructor))) + { + const gfc_expr* first = c->expr; + gcc_assert (first->expr_type == EXPR_CONSTANT); + gcc_assert (first->ts.type == BT_CHARACTER); + string_len = first->value.character.length; + } + else + string_len = 0; + + if (!p->ts.u.cl) + { + if (p->symtree) + p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns, + NULL); + else + p->ts.u.cl = gfc_new_charlen (gfc_current_ns, + NULL); + } + else + gfc_free_expr (p->ts.u.cl->length); + + p->ts.u.cl->length + = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, string_len); + } + } + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + + default: + return true; + } + + break; + + case REF_COMPONENT: + cons = find_component_ref (p->value.constructor, p->ref); + remove_subobject_ref (p, cons); + break; + + case REF_INQUIRY: + if (!find_inquiry_ref (p, &newp)) + return false; + + gfc_replace_expr (p, newp); + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + + case REF_SUBSTRING: + if (!find_substring_ref (p, &newp)) + return false; + + gfc_replace_expr (p, newp); + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + } + } + + return true; +} + + +/* Simplify a chain of references. */ + +static bool +simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p) +{ + int n; + gfc_expr *newp; + + for (; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + for (n = 0; n < ref->u.ar.dimen; n++) + { + if (!gfc_simplify_expr (ref->u.ar.start[n], type)) + return false; + if (!gfc_simplify_expr (ref->u.ar.end[n], type)) + return false; + if (!gfc_simplify_expr (ref->u.ar.stride[n], type)) + return false; + } + break; + + case REF_SUBSTRING: + if (!gfc_simplify_expr (ref->u.ss.start, type)) + return false; + if (!gfc_simplify_expr (ref->u.ss.end, type)) + return false; + break; + + case REF_INQUIRY: + if (!find_inquiry_ref (*p, &newp)) + return false; + + gfc_replace_expr (*p, newp); + gfc_free_ref_list ((*p)->ref); + (*p)->ref = NULL; + return true; + + default: + break; + } + } + return true; +} + + +/* Try to substitute the value of a parameter variable. */ + +static bool +simplify_parameter_variable (gfc_expr *p, int type) +{ + gfc_expr *e; + bool t; + + /* Set rank and check array ref; as resolve_variable calls + gfc_simplify_expr, call gfc_resolve_ref + gfc_expression_rank instead. */ + if (!gfc_resolve_ref (p)) + { + gfc_error_check (); + return false; + } + gfc_expression_rank (p); + + /* Is this an inquiry? */ + bool inquiry = false; + gfc_ref* ref = p->ref; + while (ref) + { + if (ref->type == REF_INQUIRY) + break; + ref = ref->next; + } + if (ref && ref->type == REF_INQUIRY) + inquiry = ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND; + + if (gfc_is_size_zero_array (p)) + { + if (p->expr_type == EXPR_ARRAY) + return true; + + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->ts = p->ts; + e->rank = p->rank; + e->value.constructor = NULL; + e->shape = gfc_copy_shape (p->shape, p->rank); + e->where = p->where; + /* If %kind and %len are not used then we're done, otherwise + drop through for simplification. */ + if (!inquiry) + { + gfc_replace_expr (p, e); + return true; + } + } + else + { + e = gfc_copy_expr (p->symtree->n.sym->value); + if (e == NULL) + return false; + + gfc_free_shape (&e->shape, e->rank); + e->shape = gfc_copy_shape (p->shape, p->rank); + e->rank = p->rank; + + if (e->ts.type == BT_CHARACTER && p->ts.u.cl) + e->ts = p->ts; + } + + if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL) + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl); + + /* Do not copy subobject refs for constant. */ + if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) + e->ref = gfc_copy_ref (p->ref); + t = gfc_simplify_expr (e, type); + e->where = p->where; + + /* Only use the simplification if it eliminated all subobject references. */ + if (t && !e->ref) + gfc_replace_expr (p, e); + else + gfc_free_expr (e); + + return t; +} + + +static bool +scalarize_intrinsic_call (gfc_expr *, bool init_flag); + +/* Given an expression, simplify it by collapsing constant + expressions. Most simplification takes place when the expression + tree is being constructed. If an intrinsic function is simplified + at some point, we get called again to collapse the result against + other constants. + + We work by recursively simplifying expression nodes, simplifying + intrinsic functions where possible, which can lead to further + constant collapsing. If an operator has constant operand(s), we + rip the expression apart, and rebuild it, hoping that it becomes + something simpler. + + The expression type is defined for: + 0 Basic expression parsing + 1 Simplifying array constructors -- will substitute + iterator values. + Returns false on error, true otherwise. + NOTE: Will return true even if the expression cannot be simplified. */ + +bool +gfc_simplify_expr (gfc_expr *p, int type) +{ + gfc_actual_arglist *ap; + gfc_intrinsic_sym* isym = NULL; + + + if (p == NULL) + return true; + + switch (p->expr_type) + { + case EXPR_CONSTANT: + if (p->ref && p->ref->type == REF_INQUIRY) + simplify_ref_chain (p->ref, type, &p); + break; + case EXPR_NULL: + break; + + case EXPR_FUNCTION: + // For array-bound functions, we don't need to optimize + // the 'array' argument. In particular, if the argument + // is a PARAMETER, simplifying might convert an EXPR_VARIABLE + // into an EXPR_ARRAY; the latter has lbound = 1, the former + // can have any lbound. + ap = p->value.function.actual; + if (p->value.function.isym && + (p->value.function.isym->id == GFC_ISYM_LBOUND + || p->value.function.isym->id == GFC_ISYM_UBOUND + || p->value.function.isym->id == GFC_ISYM_LCOBOUND + || p->value.function.isym->id == GFC_ISYM_UCOBOUND + || p->value.function.isym->id == GFC_ISYM_SHAPE)) + ap = ap->next; + + for ( ; ap; ap = ap->next) + if (!gfc_simplify_expr (ap->expr, type)) + return false; + + if (p->value.function.isym != NULL + && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) + return false; + + if (p->symtree && (p->value.function.isym || p->ts.type == BT_UNKNOWN)) + { + isym = gfc_find_function (p->symtree->n.sym->name); + if (isym && isym->elemental) + scalarize_intrinsic_call (p, false); + } + + break; + + case EXPR_SUBSTRING: + if (!simplify_ref_chain (p->ref, type, &p)) + return false; + + if (gfc_is_constant_expr (p)) + { + gfc_char_t *s; + HOST_WIDE_INT start, end; + + start = 0; + if (p->ref && p->ref->u.ss.start) + { + gfc_extract_hwi (p->ref->u.ss.start, &start); + start--; /* Convert from one-based to zero-based. */ + } + + end = p->value.character.length; + if (p->ref && p->ref->u.ss.end) + gfc_extract_hwi (p->ref->u.ss.end, &end); + + if (end < start) + end = start; + + s = gfc_get_wide_string (end - start + 2); + memcpy (s, p->value.character.string + start, + (end - start) * sizeof (gfc_char_t)); + s[end - start + 1] = '\0'; /* TODO: C-style string. */ + free (p->value.character.string); + p->value.character.string = s; + p->value.character.length = end - start; + p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + p->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, + p->value.character.length); + gfc_free_ref_list (p->ref); + p->ref = NULL; + p->expr_type = EXPR_CONSTANT; + } + break; + + case EXPR_OP: + if (!simplify_intrinsic_op (p, type)) + return false; + break; + + case EXPR_VARIABLE: + /* Only substitute array parameter variables if we are in an + initialization expression, or we want a subsection. */ + if (p->symtree->n.sym->attr.flavor == FL_PARAMETER + && (gfc_init_expr_flag || p->ref + || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) + { + if (!simplify_parameter_variable (p, type)) + return false; + break; + } + + if (type == 1) + { + gfc_simplify_iterator_var (p); + } + + /* Simplify subcomponent references. */ + if (!simplify_ref_chain (p->ref, type, &p)) + return false; + + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + if (!simplify_ref_chain (p->ref, type, &p)) + return false; + + /* If the following conditions hold, we found something like kind type + inquiry of the form a(2)%kind while simplify the ref chain. */ + if (p->expr_type == EXPR_CONSTANT && !p->ref && !p->rank && !p->shape) + return true; + + if (!simplify_constructor (p->value.constructor, type)) + return false; + + if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY + && p->ref->u.ar.type == AR_FULL) + gfc_expand_constructor (p, false); + + if (!simplify_const_ref (p)) + return false; + + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + break; + + case EXPR_UNKNOWN: + gcc_unreachable (); + } + + return true; +} + + +/* Try simplification of an expression via gfc_simplify_expr. + When an error occurs (arithmetic or otherwise), roll back. */ + +bool +gfc_try_simplify_expr (gfc_expr *e, int type) +{ + gfc_expr *n; + bool t, saved_div0; + + if (e == NULL || e->expr_type == EXPR_CONSTANT) + return true; + + saved_div0 = gfc_seen_div0; + gfc_seen_div0 = false; + n = gfc_copy_expr (e); + t = gfc_simplify_expr (n, type) && !gfc_seen_div0; + if (t) + gfc_replace_expr (e, n); + else + gfc_free_expr (n); + gfc_seen_div0 = saved_div0; + return t; +} + + +/* Returns the type of an expression with the exception that iterator + variables are automatically integers no matter what else they may + be declared as. */ + +static bt +et0 (gfc_expr *e) +{ + if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e)) + return BT_INTEGER; + + return e->ts.type; +} + + +/* Scalarize an expression for an elemental intrinsic call. */ + +static bool +scalarize_intrinsic_call (gfc_expr *e, bool init_flag) +{ + gfc_actual_arglist *a, *b; + gfc_constructor_base ctor; + gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */ + gfc_constructor *ci, *new_ctor; + gfc_expr *expr, *old, *p; + int n, i, rank[5], array_arg; + + if (e == NULL) + return false; + + a = e->value.function.actual; + for (; a; a = a->next) + if (a->expr && !gfc_is_constant_expr (a->expr)) + return false; + + /* Find which, if any, arguments are arrays. Assume that the old + expression carries the type information and that the first arg + that is an array expression carries all the shape information.*/ + n = array_arg = 0; + a = e->value.function.actual; + for (; a; a = a->next) + { + n++; + if (!a->expr || a->expr->expr_type != EXPR_ARRAY) + continue; + array_arg = n; + expr = gfc_copy_expr (a->expr); + break; + } + + if (!array_arg) + return false; + + old = gfc_copy_expr (e); + + gfc_constructor_free (expr->value.constructor); + expr->value.constructor = NULL; + expr->ts = old->ts; + expr->where = old->where; + expr->expr_type = EXPR_ARRAY; + + /* Copy the array argument constructors into an array, with nulls + for the scalars. */ + n = 0; + a = old->value.function.actual; + for (; a; a = a->next) + { + /* Check that this is OK for an initialization expression. */ + if (a->expr && init_flag && !gfc_check_init_expr (a->expr)) + goto cleanup; + + rank[n] = 0; + if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE) + { + rank[n] = a->expr->rank; + ctor = a->expr->symtree->n.sym->value->value.constructor; + args[n] = gfc_constructor_first (ctor); + } + else if (a->expr && a->expr->expr_type == EXPR_ARRAY) + { + if (a->expr->rank) + rank[n] = a->expr->rank; + else + rank[n] = 1; + ctor = gfc_constructor_copy (a->expr->value.constructor); + args[n] = gfc_constructor_first (ctor); + } + else + args[n] = NULL; + + n++; + } + + /* Using the array argument as the master, step through the array + calling the function for each element and advancing the array + constructors together. */ + for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) + { + new_ctor = gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (old), NULL); + + gfc_free_actual_arglist (new_ctor->expr->value.function.actual); + a = NULL; + b = old->value.function.actual; + for (i = 0; i < n; i++) + { + if (a == NULL) + new_ctor->expr->value.function.actual + = a = gfc_get_actual_arglist (); + else + { + a->next = gfc_get_actual_arglist (); + a = a->next; + } + + if (args[i]) + a->expr = gfc_copy_expr (args[i]->expr); + else + a->expr = gfc_copy_expr (b->expr); + + b = b->next; + } + + /* Simplify the function calls. If the simplification fails, the + error will be flagged up down-stream or the library will deal + with it. */ + p = gfc_copy_expr (new_ctor->expr); + + if (!gfc_simplify_expr (p, init_flag)) + gfc_free_expr (p); + else + gfc_replace_expr (new_ctor->expr, p); + + for (i = 0; i < n; i++) + if (args[i]) + args[i] = gfc_constructor_next (args[i]); + + for (i = 1; i < n; i++) + if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) + || (args[i] == NULL && args[array_arg - 1] != NULL))) + goto compliance; + } + + free_expr0 (e); + *e = *expr; + /* Free "expr" but not the pointers it contains. */ + free (expr); + gfc_free_expr (old); + return true; + +compliance: + gfc_error_now ("elemental function arguments at %C are not compliant"); + +cleanup: + gfc_free_expr (expr); + gfc_free_expr (old); + return false; +} + + +static bool +check_intrinsic_op (gfc_expr *e, bool (*check_function) (gfc_expr *)) +{ + gfc_expr *op1 = e->value.op.op1; + gfc_expr *op2 = e->value.op.op2; + + if (!(*check_function)(op1)) + return false; + + switch (e->value.op.op) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + if (!numeric_type (et0 (op1))) + goto not_numeric; + break; + + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + if (!(*check_function)(op2)) + return false; + + if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER) + && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2)))) + { + gfc_error ("Numeric or CHARACTER operands are required in " + "expression at %L", &e->where); + return false; + } + break; + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if (!(*check_function)(op2)) + return false; + + if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2))) + goto not_numeric; + + break; + + case INTRINSIC_CONCAT: + if (!(*check_function)(op2)) + return false; + + if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER) + { + gfc_error ("Concatenation operator in expression at %L " + "must have two CHARACTER operands", &op1->where); + return false; + } + + if (op1->ts.kind != op2->ts.kind) + { + gfc_error ("Concat operator at %L must concatenate strings of the " + "same kind", &e->where); + return false; + } + + break; + + case INTRINSIC_NOT: + if (et0 (op1) != BT_LOGICAL) + { + gfc_error (".NOT. operator in expression at %L must have a LOGICAL " + "operand", &op1->where); + return false; + } + + break; + + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + if (!(*check_function)(op2)) + return false; + + if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL) + { + gfc_error ("LOGICAL operands are required in expression at %L", + &e->where); + return false; + } + + break; + + case INTRINSIC_PARENTHESES: + break; + + default: + gfc_error ("Only intrinsic operators can be used in expression at %L", + &e->where); + return false; + } + + return true; + +not_numeric: + gfc_error ("Numeric operands are required in expression at %L", &e->where); + + return false; +} + +/* F2003, 7.1.7 (3): In init expression, allocatable components + must not be data-initialized. */ +static bool +check_alloc_comp_init (gfc_expr *e) +{ + gfc_component *comp; + gfc_constructor *ctor; + + gcc_assert (e->expr_type == EXPR_STRUCTURE); + gcc_assert (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS); + + for (comp = e->ts.u.derived->components, + ctor = gfc_constructor_first (e->value.constructor); + comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) + { + if (comp->attr.allocatable && ctor->expr + && ctor->expr->expr_type != EXPR_NULL) + { + gfc_error ("Invalid initialization expression for ALLOCATABLE " + "component %qs in structure constructor at %L", + comp->name, &ctor->expr->where); + return false; + } + } + + return true; +} + +static match +check_init_expr_arguments (gfc_expr *e) +{ + gfc_actual_arglist *ap; + + for (ap = e->value.function.actual; ap; ap = ap->next) + if (!gfc_check_init_expr (ap->expr)) + return MATCH_ERROR; + + return MATCH_YES; +} + +static bool check_restricted (gfc_expr *); + +/* F95, 7.1.6.1, Initialization expressions, (7) + F2003, 7.1.7 Initialization expression, (8) + F2008, 7.1.12 Constant expression, (4) */ + +static match +check_inquiry (gfc_expr *e, int not_restricted) +{ + const char *name; + const char *const *functions; + + static const char *const inquiry_func_f95[] = { + "lbound", "shape", "size", "ubound", + "bit_size", "len", "kind", + "digits", "epsilon", "huge", "maxexponent", "minexponent", + "precision", "radix", "range", "tiny", + NULL + }; + + static const char *const inquiry_func_f2003[] = { + "lbound", "shape", "size", "ubound", + "bit_size", "len", "kind", + "digits", "epsilon", "huge", "maxexponent", "minexponent", + "precision", "radix", "range", "tiny", + "new_line", NULL + }; + + /* std=f2008+ or -std=gnu */ + static const char *const inquiry_func_gnu[] = { + "lbound", "shape", "size", "ubound", + "bit_size", "len", "kind", + "digits", "epsilon", "huge", "maxexponent", "minexponent", + "precision", "radix", "range", "tiny", + "new_line", "storage_size", NULL + }; + + int i = 0; + gfc_actual_arglist *ap; + gfc_symbol *sym; + gfc_symbol *asym; + + if (!e->value.function.isym + || !e->value.function.isym->inquiry) + return MATCH_NO; + + /* An undeclared parameter will get us here (PR25018). */ + if (e->symtree == NULL) + return MATCH_NO; + + sym = e->symtree->n.sym; + + if (sym->from_intmod) + { + if (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS + && sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION) + return MATCH_NO; + + if (sym->from_intmod == INTMOD_ISO_C_BINDING + && sym->intmod_sym_id != ISOCBINDING_C_SIZEOF) + return MATCH_NO; + } + else + { + name = sym->name; + + functions = inquiry_func_gnu; + if (gfc_option.warn_std & GFC_STD_F2003) + functions = inquiry_func_f2003; + if (gfc_option.warn_std & GFC_STD_F95) + functions = inquiry_func_f95; + + for (i = 0; functions[i]; i++) + if (strcmp (functions[i], name) == 0) + break; + + if (functions[i] == NULL) + return MATCH_ERROR; + } + + /* At this point we have an inquiry function with a variable argument. The + type of the variable might be undefined, but we need it now, because the + arguments of these functions are not allowed to be undefined. */ + + for (ap = e->value.function.actual; ap; ap = ap->next) + { + if (!ap->expr) + continue; + + asym = ap->expr->symtree ? ap->expr->symtree->n.sym : NULL; + + if (ap->expr->ts.type == BT_UNKNOWN) + { + if (asym && asym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (asym, 0, gfc_current_ns)) + return MATCH_NO; + + ap->expr->ts = asym->ts; + } + + if (asym && asym->assoc && asym->assoc->target + && asym->assoc->target->expr_type == EXPR_CONSTANT) + { + gfc_free_expr (ap->expr); + ap->expr = gfc_copy_expr (asym->assoc->target); + } + + /* Assumed character length will not reduce to a constant expression + with LEN, as required by the standard. */ + if (i == 5 && not_restricted && asym + && asym->ts.type == BT_CHARACTER + && ((asym->ts.u.cl && asym->ts.u.cl->length == NULL) + || asym->ts.deferred)) + { + gfc_error ("Assumed or deferred character length variable %qs " + "in constant expression at %L", + asym->name, &ap->expr->where); + return MATCH_ERROR; + } + else if (not_restricted && !gfc_check_init_expr (ap->expr)) + return MATCH_ERROR; + + if (not_restricted == 0 + && ap->expr->expr_type != EXPR_VARIABLE + && !check_restricted (ap->expr)) + return MATCH_ERROR; + + if (not_restricted == 0 + && ap->expr->expr_type == EXPR_VARIABLE + && asym->attr.dummy && asym->attr.optional) + return MATCH_NO; + } + + return MATCH_YES; +} + + +/* F95, 7.1.6.1, Initialization expressions, (5) + F2003, 7.1.7 Initialization expression, (5) */ + +static match +check_transformational (gfc_expr *e) +{ + static const char * const trans_func_f95[] = { + "repeat", "reshape", "selected_int_kind", + "selected_real_kind", "transfer", "trim", NULL + }; + + static const char * const trans_func_f2003[] = { + "all", "any", "count", "dot_product", "matmul", "null", "pack", + "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", + "selected_real_kind", "spread", "sum", "transfer", "transpose", + "trim", "unpack", NULL + }; + + static const char * const trans_func_f2008[] = { + "all", "any", "count", "dot_product", "matmul", "null", "pack", + "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind", + "selected_real_kind", "spread", "sum", "transfer", "transpose", + "trim", "unpack", "findloc", NULL + }; + + int i; + const char *name; + const char *const *functions; + + if (!e->value.function.isym + || !e->value.function.isym->transformational) + return MATCH_NO; + + name = e->symtree->n.sym->name; + + if (gfc_option.allow_std & GFC_STD_F2008) + functions = trans_func_f2008; + else if (gfc_option.allow_std & GFC_STD_F2003) + functions = trans_func_f2003; + else + functions = trans_func_f95; + + /* NULL() is dealt with below. */ + if (strcmp ("null", name) == 0) + return MATCH_NO; + + for (i = 0; functions[i]; i++) + if (strcmp (functions[i], name) == 0) + break; + + if (functions[i] == NULL) + { + gfc_error ("transformational intrinsic %qs at %L is not permitted " + "in an initialization expression", name, &e->where); + return MATCH_ERROR; + } + + return check_init_expr_arguments (e); +} + + +/* F95, 7.1.6.1, Initialization expressions, (6) + F2003, 7.1.7 Initialization expression, (6) */ + +static match +check_null (gfc_expr *e) +{ + if (strcmp ("null", e->symtree->n.sym->name) != 0) + return MATCH_NO; + + return check_init_expr_arguments (e); +} + + +static match +check_elemental (gfc_expr *e) +{ + if (!e->value.function.isym + || !e->value.function.isym->elemental) + return MATCH_NO; + + if (e->ts.type != BT_INTEGER + && e->ts.type != BT_CHARACTER + && !gfc_notify_std (GFC_STD_F2003, "Evaluation of nonstandard " + "initialization expression at %L", &e->where)) + return MATCH_ERROR; + + return check_init_expr_arguments (e); +} + + +static match +check_conversion (gfc_expr *e) +{ + if (!e->value.function.isym + || !e->value.function.isym->conversion) + return MATCH_NO; + + return check_init_expr_arguments (e); +} + + +/* Verify that an expression is an initialization expression. A side + effect is that the expression tree is reduced to a single constant + node if all goes well. This would normally happen when the + expression is constructed but function references are assumed to be + intrinsics in the context of initialization expressions. If + false is returned an error message has been generated. */ + +bool +gfc_check_init_expr (gfc_expr *e) +{ + match m; + bool t; + + if (e == NULL) + return true; + + switch (e->expr_type) + { + case EXPR_OP: + t = check_intrinsic_op (e, gfc_check_init_expr); + if (t) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_FUNCTION: + t = false; + + { + bool conversion; + gfc_intrinsic_sym* isym = NULL; + gfc_symbol* sym = e->symtree->n.sym; + + /* Simplify here the intrinsics from the IEEE_ARITHMETIC and + IEEE_EXCEPTIONS modules. */ + int mod = sym->from_intmod; + if (mod == INTMOD_NONE && sym->generic) + mod = sym->generic->sym->from_intmod; + if (mod == INTMOD_IEEE_ARITHMETIC || mod == INTMOD_IEEE_EXCEPTIONS) + { + gfc_expr *new_expr = gfc_simplify_ieee_functions (e); + if (new_expr) + { + gfc_replace_expr (e, new_expr); + t = true; + break; + } + } + + /* If a conversion function, e.g., __convert_i8_i4, was inserted + into an array constructor, we need to skip the error check here. + Conversion errors are caught below in scalarize_intrinsic_call. */ + conversion = e->value.function.isym + && (e->value.function.isym->conversion == 1); + + if (!conversion && (!gfc_is_intrinsic (sym, 0, e->where) + || (m = gfc_intrinsic_func_interface (e, 0)) == MATCH_NO)) + { + gfc_error ("Function %qs in initialization expression at %L " + "must be an intrinsic function", + e->symtree->n.sym->name, &e->where); + break; + } + + if ((m = check_conversion (e)) == MATCH_NO + && (m = check_inquiry (e, 1)) == MATCH_NO + && (m = check_null (e)) == MATCH_NO + && (m = check_transformational (e)) == MATCH_NO + && (m = check_elemental (e)) == MATCH_NO) + { + gfc_error ("Intrinsic function %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + m = MATCH_ERROR; + } + + if (m == MATCH_ERROR) + return false; + + /* Try to scalarize an elemental intrinsic function that has an + array argument. */ + isym = gfc_find_function (e->symtree->n.sym->name); + if (isym && isym->elemental + && (t = scalarize_intrinsic_call (e, true))) + break; + } + + if (m == MATCH_YES) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_VARIABLE: + t = true; + + /* This occurs when parsing pdt templates. */ + if (gfc_expr_attr (e).pdt_kind) + break; + + if (gfc_check_iter_variable (e)) + break; + + if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) + { + /* A PARAMETER shall not be used to define itself, i.e. + REAL, PARAMETER :: x = transfer(0, x) + is invalid. */ + if (!e->symtree->n.sym->value) + { + gfc_error ("PARAMETER %qs is used at %L before its definition " + "is complete", e->symtree->n.sym->name, &e->where); + t = false; + } + else + t = simplify_parameter_variable (e, 0); + + break; + } + + if (gfc_in_match_data ()) + break; + + t = false; + + if (e->symtree->n.sym->as) + { + switch (e->symtree->n.sym->as->type) + { + case AS_ASSUMED_SIZE: + gfc_error ("Assumed size array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + break; + + case AS_ASSUMED_SHAPE: + gfc_error ("Assumed shape array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + break; + + case AS_DEFERRED: + if (!e->symtree->n.sym->attr.allocatable + && !e->symtree->n.sym->attr.pointer + && e->symtree->n.sym->attr.dummy) + gfc_error ("Assumed-shape array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + else + gfc_error ("Deferred array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + break; + + case AS_EXPLICIT: + gfc_error ("Array %qs at %L is a variable, which does " + "not reduce to a constant expression", + e->symtree->n.sym->name, &e->where); + break; + + case AS_ASSUMED_RANK: + gfc_error ("Assumed-rank array %qs at %L is not permitted " + "in an initialization expression", + e->symtree->n.sym->name, &e->where); + break; + + default: + gcc_unreachable(); + } + } + else + gfc_error ("Parameter %qs at %L has not been declared or is " + "a variable, which does not reduce to a constant " + "expression", e->symtree->name, &e->where); + + break; + + case EXPR_CONSTANT: + case EXPR_NULL: + t = true; + break; + + case EXPR_SUBSTRING: + if (e->ref) + { + t = gfc_check_init_expr (e->ref->u.ss.start); + if (!t) + break; + + t = gfc_check_init_expr (e->ref->u.ss.end); + if (t) + t = gfc_simplify_expr (e, 0); + } + else + t = false; + break; + + case EXPR_STRUCTURE: + t = e->ts.is_iso_c ? true : false; + if (t) + break; + + t = check_alloc_comp_init (e); + if (!t) + break; + + t = gfc_check_constructor (e, gfc_check_init_expr); + if (!t) + break; + + break; + + case EXPR_ARRAY: + t = gfc_check_constructor (e, gfc_check_init_expr); + if (!t) + break; + + t = gfc_expand_constructor (e, true); + if (!t) + break; + + t = gfc_check_constructor_type (e); + break; + + default: + gfc_internal_error ("check_init_expr(): Unknown expression type"); + } + + return t; +} + +/* Reduces a general expression to an initialization expression (a constant). + This used to be part of gfc_match_init_expr. + Note that this function doesn't free the given expression on false. */ + +bool +gfc_reduce_init_expr (gfc_expr *expr) +{ + bool t; + + gfc_init_expr_flag = true; + t = gfc_resolve_expr (expr); + if (t) + t = gfc_check_init_expr (expr); + gfc_init_expr_flag = false; + + if (!t || !expr) + return false; + + if (expr->expr_type == EXPR_ARRAY) + { + if (!gfc_check_constructor_type (expr)) + return false; + if (!gfc_expand_constructor (expr, true)) + return false; + } + + return true; +} + + +/* Match an initialization expression. We work by first matching an + expression, then reducing it to a constant. */ + +match +gfc_match_init_expr (gfc_expr **result) +{ + gfc_expr *expr; + match m; + bool t; + + expr = NULL; + + gfc_init_expr_flag = true; + + m = gfc_match_expr (&expr); + if (m != MATCH_YES) + { + gfc_init_expr_flag = false; + return m; + } + + if (gfc_derived_parameter_expr (expr)) + { + *result = expr; + gfc_init_expr_flag = false; + return m; + } + + t = gfc_reduce_init_expr (expr); + if (!t) + { + gfc_free_expr (expr); + gfc_init_expr_flag = false; + return MATCH_ERROR; + } + + *result = expr; + gfc_init_expr_flag = false; + + return MATCH_YES; +} + + +/* Given an actual argument list, test to see that each argument is a + restricted expression and optionally if the expression type is + integer or character. */ + +static bool +restricted_args (gfc_actual_arglist *a) +{ + for (; a; a = a->next) + { + if (!check_restricted (a->expr)) + return false; + } + + return true; +} + + +/************* Restricted/specification expressions *************/ + + +/* Make sure a non-intrinsic function is a specification function, + * see F08:7.1.11.5. */ + +static bool +external_spec_function (gfc_expr *e) +{ + gfc_symbol *f; + + f = e->value.function.esym; + + /* IEEE functions allowed are "a reference to a transformational function + from the intrinsic module IEEE_ARITHMETIC or IEEE_EXCEPTIONS", and + "inquiry function from the intrinsic modules IEEE_ARITHMETIC and + IEEE_EXCEPTIONS". */ + if (f->from_intmod == INTMOD_IEEE_ARITHMETIC + || f->from_intmod == INTMOD_IEEE_EXCEPTIONS) + { + if (!strcmp (f->name, "ieee_selected_real_kind") + || !strcmp (f->name, "ieee_support_rounding") + || !strcmp (f->name, "ieee_support_flag") + || !strcmp (f->name, "ieee_support_halting") + || !strcmp (f->name, "ieee_support_datatype") + || !strcmp (f->name, "ieee_support_denormal") + || !strcmp (f->name, "ieee_support_subnormal") + || !strcmp (f->name, "ieee_support_divide") + || !strcmp (f->name, "ieee_support_inf") + || !strcmp (f->name, "ieee_support_io") + || !strcmp (f->name, "ieee_support_nan") + || !strcmp (f->name, "ieee_support_sqrt") + || !strcmp (f->name, "ieee_support_standard") + || !strcmp (f->name, "ieee_support_underflow_control")) + goto function_allowed; + } + + if (f->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Specification function %qs at %L cannot be a statement " + "function", f->name, &e->where); + return false; + } + + if (f->attr.proc == PROC_INTERNAL) + { + gfc_error ("Specification function %qs at %L cannot be an internal " + "function", f->name, &e->where); + return false; + } + + if (!f->attr.pure && !f->attr.elemental) + { + gfc_error ("Specification function %qs at %L must be PURE", f->name, + &e->where); + return false; + } + + /* F08:7.1.11.6. */ + if (f->attr.recursive + && !gfc_notify_std (GFC_STD_F2003, + "Specification function %qs " + "at %L cannot be RECURSIVE", f->name, &e->where)) + return false; + +function_allowed: + return restricted_args (e->value.function.actual); +} + + +/* Check to see that a function reference to an intrinsic is a + restricted expression. */ + +static bool +restricted_intrinsic (gfc_expr *e) +{ + /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */ + if (check_inquiry (e, 0) == MATCH_YES) + return true; + + return restricted_args (e->value.function.actual); +} + + +/* Check the expressions of an actual arglist. Used by check_restricted. */ + +static bool +check_arglist (gfc_actual_arglist* arg, bool (*checker) (gfc_expr*)) +{ + for (; arg; arg = arg->next) + if (!checker (arg->expr)) + return false; + + return true; +} + + +/* Check the subscription expressions of a reference chain with a checking + function; used by check_restricted. */ + +static bool +check_references (gfc_ref* ref, bool (*checker) (gfc_expr*)) +{ + int dim; + + if (!ref) + return true; + + switch (ref->type) + { + case REF_ARRAY: + for (dim = 0; dim < ref->u.ar.dimen; ++dim) + { + if (!checker (ref->u.ar.start[dim])) + return false; + if (!checker (ref->u.ar.end[dim])) + return false; + if (!checker (ref->u.ar.stride[dim])) + return false; + } + break; + + case REF_COMPONENT: + /* Nothing needed, just proceed to next reference. */ + break; + + case REF_SUBSTRING: + if (!checker (ref->u.ss.start)) + return false; + if (!checker (ref->u.ss.end)) + return false; + break; + + default: + gcc_unreachable (); + break; + } + + return check_references (ref->next, checker); +} + +/* Return true if ns is a parent of the current ns. */ + +static bool +is_parent_of_current_ns (gfc_namespace *ns) +{ + gfc_namespace *p; + for (p = gfc_current_ns->parent; p; p = p->parent) + if (ns == p) + return true; + + return false; +} + +/* Verify that an expression is a restricted expression. Like its + cousin check_init_expr(), an error message is generated if we + return false. */ + +static bool +check_restricted (gfc_expr *e) +{ + gfc_symbol* sym; + bool t; + + if (e == NULL) + return true; + + switch (e->expr_type) + { + case EXPR_OP: + t = check_intrinsic_op (e, check_restricted); + if (t) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_FUNCTION: + if (e->value.function.esym) + { + t = check_arglist (e->value.function.actual, &check_restricted); + if (t) + t = external_spec_function (e); + } + else + { + if (e->value.function.isym && e->value.function.isym->inquiry) + t = true; + else + t = check_arglist (e->value.function.actual, &check_restricted); + + if (t) + t = restricted_intrinsic (e); + } + break; + + case EXPR_VARIABLE: + sym = e->symtree->n.sym; + t = false; + + /* If a dummy argument appears in a context that is valid for a + restricted expression in an elemental procedure, it will have + already been simplified away once we get here. Therefore we + don't need to jump through hoops to distinguish valid from + invalid cases. Allowed in F2008 and F2018. */ + if (gfc_notification_std (GFC_STD_F2008) + && sym->attr.dummy && sym->ns == gfc_current_ns + && sym->ns->proc_name && sym->ns->proc_name->attr.elemental) + { + gfc_error_now ("Dummy argument %qs not " + "allowed in expression at %L", + sym->name, &e->where); + break; + } + + if (sym->attr.optional) + { + gfc_error ("Dummy argument %qs at %L cannot be OPTIONAL", + sym->name, &e->where); + break; + } + + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Dummy argument %qs at %L cannot be INTENT(OUT)", + sym->name, &e->where); + break; + } + + /* Check reference chain if any. */ + if (!check_references (e->ref, &check_restricted)) + break; + + /* gfc_is_formal_arg broadcasts that a formal argument list is being + processed in resolve.c(resolve_formal_arglist). This is done so + that host associated dummy array indices are accepted (PR23446). + This mechanism also does the same for the specification expressions + of array-valued functions. */ + if (e->error + || sym->attr.in_common + || sym->attr.use_assoc + || sym->attr.dummy + || sym->attr.implied_index + || sym->attr.flavor == FL_PARAMETER + || is_parent_of_current_ns (sym->ns) + || (sym->ns->proc_name != NULL + && sym->ns->proc_name->attr.flavor == FL_MODULE) + || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) + { + t = true; + break; + } + + gfc_error ("Variable %qs cannot appear in the expression at %L", + sym->name, &e->where); + /* Prevent a repetition of the error. */ + e->error = 1; + break; + + case EXPR_NULL: + case EXPR_CONSTANT: + t = true; + break; + + case EXPR_SUBSTRING: + t = gfc_specification_expr (e->ref->u.ss.start); + if (!t) + break; + + t = gfc_specification_expr (e->ref->u.ss.end); + if (t) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_STRUCTURE: + t = gfc_check_constructor (e, check_restricted); + break; + + case EXPR_ARRAY: + t = gfc_check_constructor (e, check_restricted); + break; + + default: + gfc_internal_error ("check_restricted(): Unknown expression type"); + } + + return t; +} + + +/* Check to see that an expression is a specification expression. If + we return false, an error has been generated. */ + +bool +gfc_specification_expr (gfc_expr *e) +{ + gfc_component *comp; + + if (e == NULL) + return true; + + if (e->ts.type != BT_INTEGER) + { + gfc_error ("Expression at %L must be of INTEGER type, found %s", + &e->where, gfc_basic_typename (e->ts.type)); + return false; + } + + comp = gfc_get_proc_ptr_comp (e); + if (e->expr_type == EXPR_FUNCTION + && !e->value.function.isym + && !e->value.function.esym + && !gfc_pure (e->symtree->n.sym) + && (!comp || !comp->attr.pure)) + { + gfc_error ("Function %qs at %L must be PURE", + e->symtree->n.sym->name, &e->where); + /* Prevent repeat error messages. */ + e->symtree->n.sym->attr.pure = 1; + return false; + } + + if (e->rank != 0) + { + gfc_error ("Expression at %L must be scalar", &e->where); + return false; + } + + if (!gfc_simplify_expr (e, 0)) + return false; + + return check_restricted (e); +} + + +/************** Expression conformance checks. *************/ + +/* Given two expressions, make sure that the arrays are conformable. */ + +bool +gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...) +{ + int op1_flag, op2_flag, d; + mpz_t op1_size, op2_size; + bool t; + + va_list argp; + char buffer[240]; + + if (op1->rank == 0 || op2->rank == 0) + return true; + + va_start (argp, optype_msgid); + d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp); + va_end (argp); + if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */ + gfc_internal_error ("optype_msgid overflow: %d", d); + + if (op1->rank != op2->rank) + { + gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer), + op1->rank, op2->rank, &op1->where); + return false; + } + + t = true; + + for (d = 0; d < op1->rank; d++) + { + op1_flag = gfc_array_dimen_size(op1, d, &op1_size); + op2_flag = gfc_array_dimen_size(op2, d, &op2_size); + + if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) + { + gfc_error ("Different shape for %s at %L on dimension %d " + "(%d and %d)", _(buffer), &op1->where, d + 1, + (int) mpz_get_si (op1_size), + (int) mpz_get_si (op2_size)); + + t = false; + } + + if (op1_flag) + mpz_clear (op1_size); + if (op2_flag) + mpz_clear (op2_size); + + if (!t) + return false; + } + + return true; +} + + +/* Given an assignable expression and an arbitrary expression, make + sure that the assignment can take place. Only add a call to the intrinsic + conversion routines, when allow_convert is set. When this assign is a + coarray call, then the convert is done by the coarray routine implictly and + adding the intrinsic conversion would do harm in most cases. */ + +bool +gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, + bool allow_convert) +{ + gfc_symbol *sym; + gfc_ref *ref; + int has_pointer; + + sym = lvalue->symtree->n.sym; + + /* See if this is the component or subcomponent of a pointer and guard + against assignment to LEN or KIND part-refs. */ + has_pointer = sym->attr.pointer; + for (ref = lvalue->ref; ref; ref = ref->next) + { + if (!has_pointer && ref->type == REF_COMPONENT + && ref->u.c.component->attr.pointer) + has_pointer = 1; + else if (ref->type == REF_INQUIRY + && (ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND)) + { + gfc_error ("Assignment to a LEN or KIND part_ref at %L is not " + "allowed", &lvalue->where); + return false; + } + } + + /* 12.5.2.2, Note 12.26: The result variable is very similar to any other + variable local to a function subprogram. Its existence begins when + execution of the function is initiated and ends when execution of the + function is terminated... + Therefore, the left hand side is no longer a variable, when it is: */ + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.external) + { + bool bad_proc; + bad_proc = false; + + /* (i) Use associated; */ + if (sym->attr.use_assoc) + bad_proc = true; + + /* (ii) The assignment is in the main program; or */ + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.is_main_program) + bad_proc = true; + + /* (iii) A module or internal procedure... */ + if (gfc_current_ns->proc_name + && (gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL + || gfc_current_ns->proc_name->attr.proc == PROC_MODULE) + && gfc_current_ns->parent + && (!(gfc_current_ns->parent->proc_name->attr.function + || gfc_current_ns->parent->proc_name->attr.subroutine) + || gfc_current_ns->parent->proc_name->attr.is_main_program)) + { + /* ... that is not a function... */ + if (gfc_current_ns->proc_name + && !gfc_current_ns->proc_name->attr.function) + bad_proc = true; + + /* ... or is not an entry and has a different name. */ + if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name) + bad_proc = true; + } + + /* (iv) Host associated and not the function symbol or the + parent result. This picks up sibling references, which + cannot be entries. */ + if (!sym->attr.entry + && sym->ns == gfc_current_ns->parent + && sym != gfc_current_ns->proc_name + && sym != gfc_current_ns->parent->proc_name->result) + bad_proc = true; + + if (bad_proc) + { + gfc_error ("%qs at %L is not a VALUE", sym->name, &lvalue->where); + return false; + } + } + else + { + /* Reject assigning to an external symbol. For initializers, this + was already done before, in resolve_fl_procedure. */ + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external + && sym->attr.proc != PROC_MODULE && !rvalue->error) + { + gfc_error ("Illegal assignment to external procedure at %L", + &lvalue->where); + return false; + } + } + + if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) + { + gfc_error ("Incompatible ranks %d and %d in assignment at %L", + lvalue->rank, rvalue->rank, &lvalue->where); + return false; + } + + if (lvalue->ts.type == BT_UNKNOWN) + { + gfc_error ("Variable type is UNKNOWN in assignment at %L", + &lvalue->where); + return false; + } + + if (rvalue->expr_type == EXPR_NULL) + { + if (has_pointer && (ref == NULL || ref->next == NULL) + && lvalue->symtree->n.sym->attr.data) + return true; + else + { + gfc_error ("NULL appears on right-hand side in assignment at %L", + &rvalue->where); + return false; + } + } + + /* This is possibly a typo: x = f() instead of x => f(). */ + if (warn_surprising + && rvalue->expr_type == EXPR_FUNCTION && gfc_expr_attr (rvalue).pointer) + gfc_warning (OPT_Wsurprising, + "POINTER-valued function appears on right-hand side of " + "assignment at %L", &rvalue->where); + + /* Check size of array assignments. */ + if (lvalue->rank != 0 && rvalue->rank != 0 + && !gfc_check_conformance (lvalue, rvalue, _("array assignment"))) + return false; + + /* Handle the case of a BOZ literal on the RHS. */ + if (rvalue->ts.type == BT_BOZ) + { + if (lvalue->symtree->n.sym->attr.data) + { + if (lvalue->ts.type == BT_INTEGER + && gfc_boz2int (rvalue, lvalue->ts.kind)) + return true; + + if (lvalue->ts.type == BT_REAL + && gfc_boz2real (rvalue, lvalue->ts.kind)) + { + if (gfc_invalid_boz ("BOZ literal constant near %L cannot " + "be assigned to a REAL variable", + &rvalue->where)) + return false; + return true; + } + } + + if (!lvalue->symtree->n.sym->attr.data + && gfc_invalid_boz ("BOZ literal constant at %L is neither a " + "data-stmt-constant nor an actual argument to " + "INT, REAL, DBLE, or CMPLX intrinsic function", + &rvalue->where)) + return false; + + if (lvalue->ts.type == BT_INTEGER + && gfc_boz2int (rvalue, lvalue->ts.kind)) + return true; + + if (lvalue->ts.type == BT_REAL + && gfc_boz2real (rvalue, lvalue->ts.kind)) + return true; + + gfc_error ("BOZ literal constant near %L cannot be assigned to a " + "%qs variable", &rvalue->where, gfc_typename (lvalue)); + return false; + } + + if (gfc_expr_attr (lvalue).pdt_kind || gfc_expr_attr (lvalue).pdt_len) + { + gfc_error ("The assignment to a KIND or LEN component of a " + "parameterized type at %L is not allowed", + &lvalue->where); + return false; + } + + if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) + return true; + + /* Only DATA Statements come here. */ + if (!conform) + { + locus *where; + + /* Numeric can be converted to any other numeric. And Hollerith can be + converted to any other type. */ + if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) + || rvalue->ts.type == BT_HOLLERITH) + return true; + + if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts) + || lvalue->ts.type == BT_LOGICAL) + && rvalue->ts.type == BT_CHARACTER + && rvalue->ts.kind == gfc_default_character_kind) + return true; + + if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) + return true; + + where = lvalue->where.lb ? &lvalue->where : &rvalue->where; + gfc_error ("Incompatible types in DATA statement at %L; attempted " + "conversion of %s to %s", where, + gfc_typename (rvalue), gfc_typename (lvalue)); + + return false; + } + + /* Assignment is the only case where character variables of different + kind values can be converted into one another. */ + if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER) + { + if (lvalue->ts.kind != rvalue->ts.kind && allow_convert) + return gfc_convert_chartype (rvalue, &lvalue->ts); + else + return true; + } + + if (!allow_convert) + return true; + + return gfc_convert_type (rvalue, &lvalue->ts, 1); +} + + +/* Check that a pointer assignment is OK. We first check lvalue, and + we only check rvalue if it's not an assignment to NULL() or a + NULLIFY statement. */ + +bool +gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, + bool suppress_type_test, bool is_init_expr) +{ + symbol_attribute attr, lhs_attr; + gfc_ref *ref; + bool is_pure, is_implicit_pure, rank_remap; + int proc_pointer; + bool same_rank; + + if (!lvalue->symtree) + return false; + + lhs_attr = gfc_expr_attr (lvalue); + if (lvalue->ts.type == BT_UNKNOWN && !lhs_attr.proc_pointer) + { + gfc_error ("Pointer assignment target is not a POINTER at %L", + &lvalue->where); + return false; + } + + if (lhs_attr.flavor == FL_PROCEDURE && lhs_attr.use_assoc + && !lhs_attr.proc_pointer) + { + gfc_error ("%qs in the pointer assignment at %L cannot be an " + "l-value since it is a procedure", + lvalue->symtree->n.sym->name, &lvalue->where); + return false; + } + + proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer; + + rank_remap = false; + same_rank = lvalue->rank == rvalue->rank; + for (ref = lvalue->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + proc_pointer = ref->u.c.component->attr.proc_pointer; + + if (ref->type == REF_ARRAY && ref->next == NULL) + { + int dim; + + if (ref->u.ar.type == AR_FULL) + break; + + if (ref->u.ar.type != AR_SECTION) + { + gfc_error ("Expected bounds specification for %qs at %L", + lvalue->symtree->n.sym->name, &lvalue->where); + return false; + } + + if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification " + "for %qs in pointer assignment at %L", + lvalue->symtree->n.sym->name, &lvalue->where)) + return false; + + /* Fortran standard (e.g. F2018, 10.2.2 Pointer assignment): + * + * (C1017) If bounds-spec-list is specified, the number of + * bounds-specs shall equal the rank of data-pointer-object. + * + * If bounds-spec-list appears, it specifies the lower bounds. + * + * (C1018) If bounds-remapping-list is specified, the number of + * bounds-remappings shall equal the rank of data-pointer-object. + * + * If bounds-remapping-list appears, it specifies the upper and + * lower bounds of each dimension of the pointer; the pointer target + * shall be simply contiguous or of rank one. + * + * (C1019) If bounds-remapping-list is not specified, the ranks of + * data-pointer-object and data-target shall be the same. + * + * Thus when bounds are given, all lbounds are necessary and either + * all or none of the upper bounds; no strides are allowed. If the + * upper bounds are present, we may do rank remapping. */ + for (dim = 0; dim < ref->u.ar.dimen; ++dim) + { + if (ref->u.ar.stride[dim]) + { + gfc_error ("Stride must not be present at %L", + &lvalue->where); + return false; + } + if (!same_rank && (!ref->u.ar.start[dim] ||!ref->u.ar.end[dim])) + { + gfc_error ("Rank remapping requires a " + "list of % " + "specifications at %L", &lvalue->where); + return false; + } + if (!ref->u.ar.start[dim] + || ref->u.ar.dimen_type[dim] != DIMEN_RANGE) + { + gfc_error ("Expected list of % or " + "list of % " + "specifications at %L", &lvalue->where); + return false; + } + + if (dim == 0) + rank_remap = (ref->u.ar.end[dim] != NULL); + else + { + if ((rank_remap && !ref->u.ar.end[dim])) + { + gfc_error ("Rank remapping requires a " + "list of % " + "specifications at %L", &lvalue->where); + return false; + } + if (!rank_remap && ref->u.ar.end[dim]) + { + gfc_error ("Expected list of % or " + "list of % " + "specifications at %L", &lvalue->where); + return false; + } + } + } + } + } + + is_pure = gfc_pure (NULL); + is_implicit_pure = gfc_implicit_pure (NULL); + + /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, + kind, etc for lvalue and rvalue must match, and rvalue must be a + pure variable if we're in a pure function. */ + if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) + return true; + + /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ + if (lvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (lvalue)) + { + gfc_ref *ref; + for (ref = lvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Pointer object at %L shall not have a coindex", + &lvalue->where); + return false; + } + } + + /* Checks on rvalue for procedure pointer assignments. */ + if (proc_pointer) + { + char err[200]; + gfc_symbol *s1,*s2; + gfc_component *comp1, *comp2; + const char *name; + + attr = gfc_expr_attr (rvalue); + if (!((rvalue->expr_type == EXPR_NULL) + || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE + && attr.flavor == FL_PROCEDURE))) + { + gfc_error ("Invalid procedure pointer assignment at %L", + &rvalue->where); + return false; + } + + if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) + { + /* Check for intrinsics. */ + gfc_symbol *sym = rvalue->symtree->n.sym; + if (!sym->attr.intrinsic + && (gfc_is_intrinsic (sym, 0, sym->declared_at) + || gfc_is_intrinsic (sym, 1, sym->declared_at))) + { + sym->attr.intrinsic = 1; + gfc_resolve_intrinsic (sym, &rvalue->where); + attr = gfc_expr_attr (rvalue); + } + /* Check for result of embracing function. */ + if (sym->attr.function && sym->result == sym) + { + gfc_namespace *ns; + + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (sym == ns->proc_name) + { + gfc_error ("Function result %qs is invalid as proc-target " + "in procedure pointer assignment at %L", + sym->name, &rvalue->where); + return false; + } + } + } + if (attr.abstract) + { + gfc_error ("Abstract interface %qs is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + /* Check for F08:C729. */ + if (attr.flavor == FL_PROCEDURE) + { + if (attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Statement function %qs is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + if (attr.proc == PROC_INTERNAL && + !gfc_notify_std(GFC_STD_F2008, "Internal procedure %qs " + "is invalid in procedure pointer assignment " + "at %L", rvalue->symtree->name, &rvalue->where)) + return false; + if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, + attr.subroutine) == 0) + { + gfc_error ("Intrinsic %qs at %L is invalid in procedure pointer " + "assignment", rvalue->symtree->name, &rvalue->where); + return false; + } + } + /* Check for F08:C730. */ + if (attr.elemental && !attr.intrinsic) + { + gfc_error ("Nonintrinsic elemental procedure %qs is invalid " + "in procedure pointer assignment at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + + /* Ensure that the calling convention is the same. As other attributes + such as DLLEXPORT may differ, one explicitly only tests for the + calling conventions. */ + if (rvalue->expr_type == EXPR_VARIABLE + && lvalue->symtree->n.sym->attr.ext_attr + != rvalue->symtree->n.sym->attr.ext_attr) + { + symbol_attribute calls; + + calls.ext_attr = 0; + gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL); + gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL); + gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL); + + if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr) + != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr)) + { + gfc_error ("Mismatch in the procedure pointer assignment " + "at %L: mismatch in the calling convention", + &rvalue->where); + return false; + } + } + + comp1 = gfc_get_proc_ptr_comp (lvalue); + if (comp1) + s1 = comp1->ts.interface; + else + { + s1 = lvalue->symtree->n.sym; + if (s1->ts.interface) + s1 = s1->ts.interface; + } + + comp2 = gfc_get_proc_ptr_comp (rvalue); + if (comp2) + { + if (rvalue->expr_type == EXPR_FUNCTION) + { + s2 = comp2->ts.interface->result; + name = s2->name; + } + else + { + s2 = comp2->ts.interface; + name = comp2->name; + } + } + else if (rvalue->expr_type == EXPR_FUNCTION) + { + if (rvalue->value.function.esym) + s2 = rvalue->value.function.esym->result; + else + s2 = rvalue->symtree->n.sym->result; + + name = s2->name; + } + else + { + s2 = rvalue->symtree->n.sym; + name = s2->name; + } + + if (s2 && s2->attr.proc_pointer && s2->ts.interface) + s2 = s2->ts.interface; + + /* Special check for the case of absent interface on the lvalue. + * All other interface checks are done below. */ + if (!s1 && comp1 && comp1->attr.subroutine && s2 && s2->attr.function) + { + gfc_error ("Interface mismatch in procedure pointer assignment " + "at %L: %qs is not a subroutine", &rvalue->where, name); + return false; + } + + /* F08:7.2.2.4 (4) */ + if (s2 && gfc_explicit_interface_required (s2, err, sizeof(err))) + { + if (comp1 && !s1) + { + gfc_error ("Explicit interface required for component %qs at %L: %s", + comp1->name, &lvalue->where, err); + return false; + } + else if (s1->attr.if_source == IFSRC_UNKNOWN) + { + gfc_error ("Explicit interface required for %qs at %L: %s", + s1->name, &lvalue->where, err); + return false; + } + } + if (s1 && gfc_explicit_interface_required (s1, err, sizeof(err))) + { + if (comp2 && !s2) + { + gfc_error ("Explicit interface required for component %qs at %L: %s", + comp2->name, &rvalue->where, err); + return false; + } + else if (s2->attr.if_source == IFSRC_UNKNOWN) + { + gfc_error ("Explicit interface required for %qs at %L: %s", + s2->name, &rvalue->where, err); + return false; + } + } + + if (s1 == s2 || !s1 || !s2) + return true; + + if (!gfc_compare_interfaces (s1, s2, name, 0, 1, + err, sizeof(err), NULL, NULL)) + { + gfc_error ("Interface mismatch in procedure pointer assignment " + "at %L: %s", &rvalue->where, err); + return false; + } + + /* Check F2008Cor2, C729. */ + if (!s2->attr.intrinsic && s2->attr.if_source == IFSRC_UNKNOWN + && !s2->attr.external && !s2->attr.subroutine && !s2->attr.function) + { + gfc_error ("Procedure pointer target %qs at %L must be either an " + "intrinsic, host or use associated, referenced or have " + "the EXTERNAL attribute", s2->name, &rvalue->where); + return false; + } + + return true; + } + else + { + /* A non-proc pointer cannot point to a constant. */ + if (rvalue->expr_type == EXPR_CONSTANT) + { + gfc_error_now ("Pointer assignment target cannot be a constant at %L", + &rvalue->where); + return false; + } + } + + if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) + { + /* Check for F03:C717. */ + if (UNLIMITED_POLY (rvalue) + && !(UNLIMITED_POLY (lvalue) + || (lvalue->ts.type == BT_DERIVED + && (lvalue->ts.u.derived->attr.is_bind_c + || lvalue->ts.u.derived->attr.sequence)))) + gfc_error ("Data-pointer-object at %L must be unlimited " + "polymorphic, or of a type with the BIND or SEQUENCE " + "attribute, to be compatible with an unlimited " + "polymorphic target", &lvalue->where); + else if (!suppress_type_test) + gfc_error ("Different types in pointer assignment at %L; " + "attempted assignment of %s to %s", &lvalue->where, + gfc_typename (rvalue), gfc_typename (lvalue)); + return false; + } + + if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind) + { + gfc_error ("Different kind type parameters in pointer " + "assignment at %L", &lvalue->where); + return false; + } + + if (lvalue->rank != rvalue->rank && !rank_remap) + { + gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); + return false; + } + + /* Make sure the vtab is present. */ + if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue)) + gfc_find_vtab (&rvalue->ts); + + /* Check rank remapping. */ + if (rank_remap) + { + mpz_t lsize, rsize; + + /* If this can be determined, check that the target must be at least as + large as the pointer assigned to it is. */ + if (gfc_array_size (lvalue, &lsize) + && gfc_array_size (rvalue, &rsize) + && mpz_cmp (rsize, lsize) < 0) + { + gfc_error ("Rank remapping target is smaller than size of the" + " pointer (%ld < %ld) at %L", + mpz_get_si (rsize), mpz_get_si (lsize), + &lvalue->where); + return false; + } + + /* The target must be either rank one or it must be simply contiguous + and F2008 must be allowed. */ + if (rvalue->rank != 1) + { + if (!gfc_is_simply_contiguous (rvalue, true, false)) + { + gfc_error ("Rank remapping target must be rank 1 or" + " simply contiguous at %L", &rvalue->where); + return false; + } + if (!gfc_notify_std (GFC_STD_F2008, "Rank remapping target is not " + "rank 1 at %L", &rvalue->where)) + return false; + } + } + + /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */ + if (rvalue->expr_type == EXPR_NULL) + return true; + + if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue)) + lvalue->symtree->n.sym->attr.subref_array_pointer = 1; + + attr = gfc_expr_attr (rvalue); + + if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) + { + /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call + to caf_get. Map this to the same error message as below when it is + still a variable expression. */ + if (rvalue->value.function.isym + && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET) + /* The test above might need to be extend when F08, Note 5.4 has to be + interpreted in the way that target and pointer with the same coindex + are allowed. */ + gfc_error ("Data target at %L shall not have a coindex", + &rvalue->where); + else + gfc_error ("Target expression in pointer assignment " + "at %L must deliver a pointer result", + &rvalue->where); + return false; + } + + if (is_init_expr) + { + gfc_symbol *sym; + bool target; + gfc_ref *ref; + + if (gfc_is_size_zero_array (rvalue)) + { + gfc_error ("Zero-sized array detected at %L where an entity with " + "the TARGET attribute is expected", &rvalue->where); + return false; + } + else if (!rvalue->symtree) + { + gfc_error ("Pointer assignment target in initialization expression " + "does not have the TARGET attribute at %L", + &rvalue->where); + return false; + } + + sym = rvalue->symtree->n.sym; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + target = CLASS_DATA (sym)->attr.target; + else + target = sym->attr.target; + + if (!target && !proc_pointer) + { + gfc_error ("Pointer assignment target in initialization expression " + "does not have the TARGET attribute at %L", + &rvalue->where); + return false; + } + + for (ref = rvalue->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + for (int n = 0; n < ref->u.ar.dimen; n++) + if (!gfc_is_constant_expr (ref->u.ar.start[n]) + || !gfc_is_constant_expr (ref->u.ar.end[n]) + || !gfc_is_constant_expr (ref->u.ar.stride[n])) + { + gfc_error ("Every subscript of target specification " + "at %L must be a constant expression", + &ref->u.ar.where); + return false; + } + break; + + case REF_SUBSTRING: + if (!gfc_is_constant_expr (ref->u.ss.start) + || !gfc_is_constant_expr (ref->u.ss.end)) + { + gfc_error ("Substring starting and ending points of target " + "specification at %L must be constant expressions", + &ref->u.ss.start->where); + return false; + } + break; + + default: + break; + } + } + } + else + { + if (!attr.target && !attr.pointer) + { + gfc_error ("Pointer assignment target is neither TARGET " + "nor POINTER at %L", &rvalue->where); + return false; + } + } + + if (lvalue->ts.type == BT_CHARACTER) + { + bool t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment"); + if (!t) + return false; + } + + if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) + { + gfc_error ("Bad target in pointer assignment in PURE " + "procedure at %L", &rvalue->where); + } + + if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym)) + gfc_unset_implicit_pure (gfc_current_ns->proc_name); + + if (gfc_has_vector_index (rvalue)) + { + gfc_error ("Pointer assignment with vector subscript " + "on rhs at %L", &rvalue->where); + return false; + } + + if (attr.is_protected && attr.use_assoc + && !(attr.pointer || attr.proc_pointer)) + { + gfc_error ("Pointer assignment target has PROTECTED " + "attribute at %L", &rvalue->where); + return false; + } + + /* F2008, C725. For PURE also C1283. */ + if (rvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (rvalue)) + { + gfc_ref *ref; + for (ref = rvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Data target at %L shall not have a coindex", + &rvalue->where); + return false; + } + } + + /* Warn for assignments of contiguous pointers to targets which is not + contiguous. Be lenient in the definition of what counts as + contiguous. */ + + if (lhs_attr.contiguous + && lhs_attr.dimension > 0) + { + if (gfc_is_not_contiguous (rvalue)) + { + gfc_error ("Assignment to contiguous pointer from " + "non-contiguous target at %L", &rvalue->where); + return false; + } + if (!gfc_is_simply_contiguous (rvalue, false, true)) + gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from " + "non-contiguous target at %L", &rvalue->where); + } + + /* Warn if it is the LHS pointer may lives longer than the RHS target. */ + if (warn_target_lifetime + && rvalue->expr_type == EXPR_VARIABLE + && !rvalue->symtree->n.sym->attr.save + && !rvalue->symtree->n.sym->attr.pointer && !attr.pointer + && !rvalue->symtree->n.sym->attr.host_assoc + && !rvalue->symtree->n.sym->attr.in_common + && !rvalue->symtree->n.sym->attr.use_assoc + && !rvalue->symtree->n.sym->attr.dummy) + { + bool warn; + gfc_namespace *ns; + + warn = lvalue->symtree->n.sym->attr.dummy + || lvalue->symtree->n.sym->attr.result + || lvalue->symtree->n.sym->attr.function + || (lvalue->symtree->n.sym->attr.host_assoc + && lvalue->symtree->n.sym->ns + != rvalue->symtree->n.sym->ns) + || lvalue->symtree->n.sym->attr.use_assoc + || lvalue->symtree->n.sym->attr.in_common; + + if (rvalue->symtree->n.sym->ns->proc_name + && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE + && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) + for (ns = rvalue->symtree->n.sym->ns; + ns && ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; + ns = ns->parent) + if (ns->parent == lvalue->symtree->n.sym->ns) + { + warn = true; + break; + } + + if (warn) + gfc_warning (OPT_Wtarget_lifetime, + "Pointer at %L in pointer assignment might outlive the " + "pointer target", &lvalue->where); + } + + return true; +} + + +/* Relative of gfc_check_assign() except that the lvalue is a single + symbol. Used for initialization assignments. */ + +bool +gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) +{ + gfc_expr lvalue; + bool r; + bool pointer, proc_pointer; + + memset (&lvalue, '\0', sizeof (gfc_expr)); + + lvalue.expr_type = EXPR_VARIABLE; + lvalue.ts = sym->ts; + if (sym->as) + lvalue.rank = sym->as->rank; + lvalue.symtree = XCNEW (gfc_symtree); + lvalue.symtree->n.sym = sym; + lvalue.where = sym->declared_at; + + if (comp) + { + lvalue.ref = gfc_get_ref (); + lvalue.ref->type = REF_COMPONENT; + lvalue.ref->u.c.component = comp; + lvalue.ref->u.c.sym = sym; + lvalue.ts = comp->ts; + lvalue.rank = comp->as ? comp->as->rank : 0; + lvalue.where = comp->loc; + pointer = comp->ts.type == BT_CLASS && CLASS_DATA (comp) + ? CLASS_DATA (comp)->attr.class_pointer : comp->attr.pointer; + proc_pointer = comp->attr.proc_pointer; + } + else + { + pointer = sym->ts.type == BT_CLASS && CLASS_DATA (sym) + ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; + proc_pointer = sym->attr.proc_pointer; + } + + if (pointer || proc_pointer) + r = gfc_check_pointer_assign (&lvalue, rvalue, false, true); + else + { + /* If a conversion function, e.g., __convert_i8_i4, was inserted + into an array constructor, we should check if it can be reduced + as an initialization expression. */ + if (rvalue->expr_type == EXPR_FUNCTION + && rvalue->value.function.isym + && (rvalue->value.function.isym->conversion == 1)) + gfc_check_init_expr (rvalue); + + r = gfc_check_assign (&lvalue, rvalue, 1); + } + + free (lvalue.symtree); + free (lvalue.ref); + + if (!r) + return r; + + if (pointer && rvalue->expr_type != EXPR_NULL && !proc_pointer) + { + /* F08:C461. Additional checks for pointer initialization. */ + symbol_attribute attr; + attr = gfc_expr_attr (rvalue); + if (attr.allocatable) + { + gfc_error ("Pointer initialization target at %L " + "must not be ALLOCATABLE", &rvalue->where); + return false; + } + if (!attr.target || attr.pointer) + { + gfc_error ("Pointer initialization target at %L " + "must have the TARGET attribute", &rvalue->where); + return false; + } + + if (!attr.save && rvalue->expr_type == EXPR_VARIABLE + && rvalue->symtree->n.sym->ns->proc_name + && rvalue->symtree->n.sym->ns->proc_name->attr.is_main_program) + { + rvalue->symtree->n.sym->ns->proc_name->attr.save = SAVE_IMPLICIT; + attr.save = SAVE_IMPLICIT; + } + + if (!attr.save) + { + gfc_error ("Pointer initialization target at %L " + "must have the SAVE attribute", &rvalue->where); + return false; + } + } + + if (proc_pointer && rvalue->expr_type != EXPR_NULL) + { + /* F08:C1220. Additional checks for procedure pointer initialization. */ + symbol_attribute attr = gfc_expr_attr (rvalue); + if (attr.proc_pointer) + { + gfc_error ("Procedure pointer initialization target at %L " + "may not be a procedure pointer", &rvalue->where); + return false; + } + if (attr.proc == PROC_INTERNAL) + { + gfc_error ("Internal procedure %qs is invalid in " + "procedure pointer initialization at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + if (attr.dummy) + { + gfc_error ("Dummy procedure %qs is invalid in " + "procedure pointer initialization at %L", + rvalue->symtree->name, &rvalue->where); + return false; + } + } + + return true; +} + +/* Build an initializer for a local integer, real, complex, logical, or + character variable, based on the command line flags finit-local-zero, + finit-integer=, finit-real=, finit-logical=, and finit-character=. + With force, an initializer is ALWAYS generated. */ + +static gfc_expr * +gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) +{ + gfc_expr *init_expr; + + /* Try to build an initializer expression. */ + init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); + + /* If we want to force generation, make sure we default to zero. */ + gfc_init_local_real init_real = flag_init_real; + int init_logical = gfc_option.flag_init_logical; + if (force) + { + if (init_real == GFC_INIT_REAL_OFF) + init_real = GFC_INIT_REAL_ZERO; + if (init_logical == GFC_INIT_LOGICAL_OFF) + init_logical = GFC_INIT_LOGICAL_FALSE; + } + + /* We will only initialize integers, reals, complex, logicals, and + characters, and only if the corresponding command-line flags + were set. Otherwise, we free init_expr and return null. */ + switch (ts->type) + { + case BT_INTEGER: + if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) + mpz_set_si (init_expr->value.integer, + gfc_option.flag_init_integer_value); + else + { + gfc_free_expr (init_expr); + init_expr = NULL; + } + break; + + case BT_REAL: + switch (init_real) + { + case GFC_INIT_REAL_SNAN: + init_expr->is_snan = 1; + /* Fall through. */ + case GFC_INIT_REAL_NAN: + mpfr_set_nan (init_expr->value.real); + break; + + case GFC_INIT_REAL_INF: + mpfr_set_inf (init_expr->value.real, 1); + break; + + case GFC_INIT_REAL_NEG_INF: + mpfr_set_inf (init_expr->value.real, -1); + break; + + case GFC_INIT_REAL_ZERO: + mpfr_set_ui (init_expr->value.real, 0.0, GFC_RND_MODE); + break; + + default: + gfc_free_expr (init_expr); + init_expr = NULL; + break; + } + break; + + case BT_COMPLEX: + switch (init_real) + { + case GFC_INIT_REAL_SNAN: + init_expr->is_snan = 1; + /* Fall through. */ + case GFC_INIT_REAL_NAN: + mpfr_set_nan (mpc_realref (init_expr->value.complex)); + mpfr_set_nan (mpc_imagref (init_expr->value.complex)); + break; + + case GFC_INIT_REAL_INF: + mpfr_set_inf (mpc_realref (init_expr->value.complex), 1); + mpfr_set_inf (mpc_imagref (init_expr->value.complex), 1); + break; + + case GFC_INIT_REAL_NEG_INF: + mpfr_set_inf (mpc_realref (init_expr->value.complex), -1); + mpfr_set_inf (mpc_imagref (init_expr->value.complex), -1); + break; + + case GFC_INIT_REAL_ZERO: + mpc_set_ui (init_expr->value.complex, 0, GFC_MPC_RND_MODE); + break; + + default: + gfc_free_expr (init_expr); + init_expr = NULL; + break; + } + break; + + case BT_LOGICAL: + if (init_logical == GFC_INIT_LOGICAL_FALSE) + init_expr->value.logical = 0; + else if (init_logical == GFC_INIT_LOGICAL_TRUE) + init_expr->value.logical = 1; + else + { + gfc_free_expr (init_expr); + init_expr = NULL; + } + break; + + case BT_CHARACTER: + /* For characters, the length must be constant in order to + create a default initializer. */ + if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + { + HOST_WIDE_INT char_len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); + init_expr->value.character.length = char_len; + init_expr->value.character.string = gfc_get_wide_string (char_len+1); + for (size_t i = 0; i < (size_t) char_len; i++) + init_expr->value.character.string[i] + = (unsigned char) gfc_option.flag_init_character_value; + } + else + { + gfc_free_expr (init_expr); + init_expr = NULL; + } + if (!init_expr + && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) + && ts->u.cl->length && flag_max_stack_var_size != 0) + { + gfc_actual_arglist *arg; + init_expr = gfc_get_expr (); + init_expr->where = *where; + init_expr->ts = *ts; + init_expr->expr_type = EXPR_FUNCTION; + init_expr->value.function.isym = + gfc_intrinsic_function_by_id (GFC_ISYM_REPEAT); + init_expr->value.function.name = "repeat"; + arg = gfc_get_actual_arglist (); + arg->expr = gfc_get_character_expr (ts->kind, where, NULL, 1); + arg->expr->value.character.string[0] = + gfc_option.flag_init_character_value; + arg->next = gfc_get_actual_arglist (); + arg->next->expr = gfc_copy_expr (ts->u.cl->length); + init_expr->value.function.actual = arg; + } + break; + + default: + gfc_free_expr (init_expr); + init_expr = NULL; + } + + return init_expr; +} + +/* Invoke gfc_build_init_expr to create an initializer expression, but do not + * require that an expression be built. */ + +gfc_expr * +gfc_build_default_init_expr (gfc_typespec *ts, locus *where) +{ + return gfc_build_init_expr (ts, where, false); +} + +/* Apply an initialization expression to a typespec. Can be used for symbols or + components. Similar to add_init_expr_to_sym in decl.c; could probably be + combined with some effort. */ + +void +gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) +{ + if (ts->type == BT_CHARACTER && !attr->pointer && init + && ts->u.cl + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && ts->u.cl->length->ts.type == BT_INTEGER) + { + HOST_WIDE_INT len = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); + + if (init->expr_type == EXPR_CONSTANT) + gfc_set_constant_character_len (len, init, -1); + else if (init + && init->ts.type == BT_CHARACTER + && init->ts.u.cl && init->ts.u.cl->length + && mpz_cmp (ts->u.cl->length->value.integer, + init->ts.u.cl->length->value.integer)) + { + gfc_constructor *ctor; + ctor = gfc_constructor_first (init->value.constructor); + + if (ctor) + { + bool has_ts = (init->ts.u.cl + && init->ts.u.cl->length_from_typespec); + + /* Remember the length of the first element for checking + that all elements *in the constructor* have the same + length. This need not be the length of the LHS! */ + gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); + gcc_assert (ctor->expr->ts.type == BT_CHARACTER); + gfc_charlen_t first_len = ctor->expr->value.character.length; + + for ( ; ctor; ctor = gfc_constructor_next (ctor)) + if (ctor->expr->expr_type == EXPR_CONSTANT) + { + gfc_set_constant_character_len (len, ctor->expr, + has_ts ? -1 : first_len); + if (!ctor->expr->ts.u.cl) + ctor->expr->ts.u.cl + = gfc_new_charlen (gfc_current_ns, ts->u.cl); + else + ctor->expr->ts.u.cl->length + = gfc_copy_expr (ts->u.cl->length); + } + } + } + } +} + + +/* Check whether an expression is a structure constructor and whether it has + other values than NULL. */ + +static bool +is_non_empty_structure_constructor (gfc_expr * e) +{ + if (e->expr_type != EXPR_STRUCTURE) + return false; + + gfc_constructor *cons = gfc_constructor_first (e->value.constructor); + while (cons) + { + if (!cons->expr || cons->expr->expr_type != EXPR_NULL) + return true; + cons = gfc_constructor_next (cons); + } + return false; +} + + +/* Check for default initializer; sym->value is not enough + as it is also set for EXPR_NULL of allocatables. */ + +bool +gfc_has_default_initializer (gfc_symbol *der) +{ + gfc_component *c; + + gcc_assert (gfc_fl_struct (der->attr.flavor)); + for (c = der->components; c; c = c->next) + if (gfc_bt_struct (c->ts.type)) + { + if (!c->attr.pointer && !c->attr.proc_pointer + && !(c->attr.allocatable && der == c->ts.u.derived) + && ((c->initializer + && is_non_empty_structure_constructor (c->initializer)) + || gfc_has_default_initializer (c->ts.u.derived))) + return true; + if (c->attr.pointer && c->initializer) + return true; + } + else + { + if (c->initializer) + return true; + } + + return false; +} + + +/* + Generate an initializer expression which initializes the entirety of a union. + A normal structure constructor is insufficient without undue effort, because + components of maps may be oddly aligned/overlapped. (For example if a + character is initialized from one map overtop a real from the other, only one + byte of the real is actually initialized.) Unfortunately we don't know the + size of the union right now, so we can't generate a proper initializer, but + we use a NULL expr as a placeholder and do the right thing later in + gfc_trans_subcomponent_assign. + */ +static gfc_expr * +generate_union_initializer (gfc_component *un) +{ + if (un == NULL || un->ts.type != BT_UNION) + return NULL; + + gfc_expr *placeholder = gfc_get_null_expr (&un->loc); + placeholder->ts = un->ts; + return placeholder; +} + + +/* Get the user-specified initializer for a union, if any. This means the user + has said to initialize component(s) of a map. For simplicity's sake we + only allow the user to initialize the first map. We don't have to worry + about overlapping initializers as they are released early in resolution (see + resolve_fl_struct). */ + +static gfc_expr * +get_union_initializer (gfc_symbol *union_type, gfc_component **map_p) +{ + gfc_component *map; + gfc_expr *init=NULL; + + if (!union_type || union_type->attr.flavor != FL_UNION) + return NULL; + + for (map = union_type->components; map; map = map->next) + { + if (gfc_has_default_initializer (map->ts.u.derived)) + { + init = gfc_default_initializer (&map->ts); + if (map_p) + *map_p = map; + break; + } + } + + if (map_p && !init) + *map_p = NULL; + + return init; +} + +static bool +class_allocatable (gfc_component *comp) +{ + return comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable; +} + +static bool +class_pointer (gfc_component *comp) +{ + return comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.pointer; +} + +static bool +comp_allocatable (gfc_component *comp) +{ + return comp->attr.allocatable || class_allocatable (comp); +} + +static bool +comp_pointer (gfc_component *comp) +{ + return comp->attr.pointer + || comp->attr.proc_pointer + || comp->attr.class_pointer + || class_pointer (comp); +} + +/* Fetch or generate an initializer for the given component. + Only generate an initializer if generate is true. */ + +static gfc_expr * +component_initializer (gfc_component *c, bool generate) +{ + gfc_expr *init = NULL; + + /* Allocatable components always get EXPR_NULL. + Pointer components are only initialized when generating, and only if they + do not already have an initializer. */ + if (comp_allocatable (c) || (generate && comp_pointer (c) && !c->initializer)) + { + init = gfc_get_null_expr (&c->loc); + init->ts = c->ts; + return init; + } + + /* See if we can find the initializer immediately. */ + if (c->initializer || !generate) + return c->initializer; + + /* Recursively handle derived type components. */ + else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + init = gfc_generate_initializer (&c->ts, true); + + else if (c->ts.type == BT_UNION && c->ts.u.derived->components) + { + gfc_component *map = NULL; + gfc_constructor *ctor; + gfc_expr *user_init; + + /* If we don't have a user initializer and we aren't generating one, this + union has no initializer. */ + user_init = get_union_initializer (c->ts.u.derived, &map); + if (!user_init && !generate) + return NULL; + + /* Otherwise use a structure constructor. */ + init = gfc_get_structure_constructor_expr (c->ts.type, c->ts.kind, + &c->loc); + init->ts = c->ts; + + /* If we are to generate an initializer for the union, add a constructor + which initializes the whole union first. */ + if (generate) + { + ctor = gfc_constructor_get (); + ctor->expr = generate_union_initializer (c); + gfc_constructor_append (&init->value.constructor, ctor); + } + + /* If we found an initializer in one of our maps, apply it. Note this + is applied _after_ the entire-union initializer above if any. */ + if (user_init) + { + ctor = gfc_constructor_get (); + ctor->expr = user_init; + ctor->n.component = map; + gfc_constructor_append (&init->value.constructor, ctor); + } + } + + /* Treat simple components like locals. */ + else + { + /* We MUST give an initializer, so force generation. */ + init = gfc_build_init_expr (&c->ts, &c->loc, true); + gfc_apply_init (&c->ts, &c->attr, init); + } + + return init; +} + + +/* Get an expression for a default initializer of a derived type. */ + +gfc_expr * +gfc_default_initializer (gfc_typespec *ts) +{ + return gfc_generate_initializer (ts, false); +} + +/* Generate an initializer expression for an iso_c_binding type + such as c_[fun]ptr. The appropriate initializer is c_null_[fun]ptr. */ + +static gfc_expr * +generate_isocbinding_initializer (gfc_symbol *derived) +{ + /* The initializers have already been built into the c_null_[fun]ptr symbols + from gen_special_c_interop_ptr. */ + gfc_symtree *npsym = NULL; + if (0 == strcmp (derived->name, "c_ptr")) + gfc_find_sym_tree ("c_null_ptr", gfc_current_ns, true, &npsym); + else if (0 == strcmp (derived->name, "c_funptr")) + gfc_find_sym_tree ("c_null_funptr", gfc_current_ns, true, &npsym); + else + gfc_internal_error ("generate_isocbinding_initializer(): bad iso_c_binding" + " type, expected % or %"); + if (npsym) + { + gfc_expr *init = gfc_copy_expr (npsym->n.sym->value); + init->symtree = npsym; + init->ts.is_iso_c = true; + return init; + } + + return NULL; +} + +/* Get or generate an expression for a default initializer of a derived type. + If -finit-derived is specified, generate default initialization expressions + for components that lack them when generate is set. */ + +gfc_expr * +gfc_generate_initializer (gfc_typespec *ts, bool generate) +{ + gfc_expr *init, *tmp; + gfc_component *comp; + + generate = flag_init_derived && generate; + + if (ts->u.derived->ts.is_iso_c && generate) + return generate_isocbinding_initializer (ts->u.derived); + + /* See if we have a default initializer in this, but not in nested + types (otherwise we could use gfc_has_default_initializer()). + We don't need to check if we are going to generate them. */ + comp = ts->u.derived->components; + if (!generate) + { + for (; comp; comp = comp->next) + if (comp->initializer || comp_allocatable (comp)) + break; + } + + if (!comp) + return NULL; + + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); + init->ts = *ts; + + for (comp = ts->u.derived->components; comp; comp = comp->next) + { + gfc_constructor *ctor = gfc_constructor_get(); + + /* Fetch or generate an initializer for the component. */ + tmp = component_initializer (comp, generate); + if (tmp) + { + /* Save the component ref for STRUCTUREs and UNIONs. */ + if (ts->u.derived->attr.flavor == FL_STRUCT + || ts->u.derived->attr.flavor == FL_UNION) + ctor->n.component = comp; + + /* If the initializer was not generated, we need a copy. */ + ctor->expr = comp->initializer ? gfc_copy_expr (tmp) : tmp; + if ((comp->ts.type != tmp->ts.type || comp->ts.kind != tmp->ts.kind) + && !comp->attr.pointer && !comp->attr.proc_pointer) + { + bool val; + val = gfc_convert_type_warn (ctor->expr, &comp->ts, 1, false); + if (val == false) + return NULL; + } + } + + gfc_constructor_append (&init->value.constructor, ctor); + } + + return init; +} + + +/* Given a symbol, create an expression node with that symbol as a + variable. If the symbol is array valued, setup a reference of the + whole array. */ + +gfc_expr * +gfc_get_variable_expr (gfc_symtree *var) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + e->symtree = var; + e->ts = var->n.sym->ts; + + if (var->n.sym->attr.flavor != FL_PROCEDURE + && ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) + || (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived + && CLASS_DATA (var->n.sym) + && CLASS_DATA (var->n.sym)->as))) + { + e->rank = var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; + e->ref = gfc_get_ref (); + e->ref->type = REF_ARRAY; + e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.as = gfc_copy_array_spec (var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as + : var->n.sym->as); + } + + return e; +} + + +/* Adds a full array reference to an expression, as needed. */ + +void +gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) +{ + gfc_ref *ref; + for (ref = e->ref; ref; ref = ref->next) + if (!ref->next) + break; + if (ref) + { + ref->next = gfc_get_ref (); + ref = ref->next; + } + else + { + e->ref = gfc_get_ref (); + ref = e->ref; + } + ref->type = REF_ARRAY; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = e->rank; + ref->u.ar.where = e->where; + ref->u.ar.as = as; +} + + +gfc_expr * +gfc_lval_expr_from_sym (gfc_symbol *sym) +{ + gfc_expr *lval; + gfc_array_spec *as; + lval = gfc_get_expr (); + lval->expr_type = EXPR_VARIABLE; + lval->where = sym->declared_at; + lval->ts = sym->ts; + lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); + + /* It will always be a full array. */ + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + lval->rank = as ? as->rank : 0; + if (lval->rank) + gfc_add_full_array_ref (lval, as); + return lval; +} + + +/* Returns the array_spec of a full array expression. A NULL is + returned otherwise. */ +gfc_array_spec * +gfc_get_full_arrayspec_from_expr (gfc_expr *expr) +{ + gfc_array_spec *as; + gfc_ref *ref; + + if (expr->rank == 0) + return NULL; + + /* Follow any component references. */ + if (expr->expr_type == EXPR_VARIABLE + || expr->expr_type == EXPR_CONSTANT) + { + if (expr->symtree) + as = expr->symtree->n.sym->as; + else + as = NULL; + + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + case REF_INQUIRY: + continue; + + case REF_ARRAY: + { + switch (ref->u.ar.type) + { + case AR_ELEMENT: + case AR_SECTION: + case AR_UNKNOWN: + as = NULL; + continue; + + case AR_FULL: + break; + } + break; + } + } + } + } + else + as = NULL; + + return as; +} + + +/* General expression traversal function. */ + +bool +gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, + bool (*func)(gfc_expr *, gfc_symbol *, int*), + int f) +{ + gfc_array_ref ar; + gfc_ref *ref; + gfc_actual_arglist *args; + gfc_constructor *c; + int i; + + if (!expr) + return false; + + if ((*func) (expr, sym, &f)) + return true; + + if (expr->ts.type == BT_CHARACTER + && expr->ts.u.cl + && expr->ts.u.cl->length + && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT + && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f)) + return true; + + switch (expr->expr_type) + { + case EXPR_PPC: + case EXPR_COMPCALL: + case EXPR_FUNCTION: + for (args = expr->value.function.actual; args; args = args->next) + { + if (gfc_traverse_expr (args->expr, sym, func, f)) + return true; + } + break; + + case EXPR_VARIABLE: + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_SUBSTRING: + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + { + if (gfc_traverse_expr (c->expr, sym, func, f)) + return true; + if (c->iterator) + { + if (gfc_traverse_expr (c->iterator->var, sym, func, f)) + return true; + if (gfc_traverse_expr (c->iterator->start, sym, func, f)) + return true; + if (gfc_traverse_expr (c->iterator->end, sym, func, f)) + return true; + if (gfc_traverse_expr (c->iterator->step, sym, func, f)) + return true; + } + } + break; + + case EXPR_OP: + if (gfc_traverse_expr (expr->value.op.op1, sym, func, f)) + return true; + if (gfc_traverse_expr (expr->value.op.op2, sym, func, f)) + return true; + break; + + default: + gcc_unreachable (); + break; + } + + ref = expr->ref; + while (ref != NULL) + { + switch (ref->type) + { + case REF_ARRAY: + ar = ref->u.ar; + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + if (gfc_traverse_expr (ar.start[i], sym, func, f)) + return true; + if (gfc_traverse_expr (ar.end[i], sym, func, f)) + return true; + if (gfc_traverse_expr (ar.stride[i], sym, func, f)) + return true; + } + break; + + case REF_SUBSTRING: + if (gfc_traverse_expr (ref->u.ss.start, sym, func, f)) + return true; + if (gfc_traverse_expr (ref->u.ss.end, sym, func, f)) + return true; + break; + + case REF_COMPONENT: + if (ref->u.c.component->ts.type == BT_CHARACTER + && ref->u.c.component->ts.u.cl + && ref->u.c.component->ts.u.cl->length + && ref->u.c.component->ts.u.cl->length->expr_type + != EXPR_CONSTANT + && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length, + sym, func, f)) + return true; + + if (ref->u.c.component->as) + for (i = 0; i < ref->u.c.component->as->rank + + ref->u.c.component->as->corank; i++) + { + if (gfc_traverse_expr (ref->u.c.component->as->lower[i], + sym, func, f)) + return true; + if (gfc_traverse_expr (ref->u.c.component->as->upper[i], + sym, func, f)) + return true; + } + break; + + case REF_INQUIRY: + return true; + + default: + gcc_unreachable (); + } + ref = ref->next; + } + return false; +} + +/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ + +static bool +expr_set_symbols_referenced (gfc_expr *expr, + gfc_symbol *sym ATTRIBUTE_UNUSED, + int *f ATTRIBUTE_UNUSED) +{ + if (expr->expr_type != EXPR_VARIABLE) + return false; + gfc_set_sym_referenced (expr->symtree->n.sym); + return false; +} + +void +gfc_expr_set_symbols_referenced (gfc_expr *expr) +{ + gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); +} + + +/* Determine if an expression is a procedure pointer component and return + the component in that case. Otherwise return NULL. */ + +gfc_component * +gfc_get_proc_ptr_comp (gfc_expr *expr) +{ + gfc_ref *ref; + + if (!expr || !expr->ref) + return NULL; + + ref = expr->ref; + while (ref->next) + ref = ref->next; + + if (ref->type == REF_COMPONENT + && ref->u.c.component->attr.proc_pointer) + return ref->u.c.component; + + return NULL; +} + + +/* Determine if an expression is a procedure pointer component. */ + +bool +gfc_is_proc_ptr_comp (gfc_expr *expr) +{ + return (gfc_get_proc_ptr_comp (expr) != NULL); +} + + +/* Determine if an expression is a function with an allocatable class scalar + result. */ +bool +gfc_is_alloc_class_scalar_function (gfc_expr *expr) +{ + if (expr->expr_type == EXPR_FUNCTION + && expr->value.function.esym + && expr->value.function.esym->result + && expr->value.function.esym->result->ts.type == BT_CLASS + && !CLASS_DATA (expr->value.function.esym->result)->attr.dimension + && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable) + return true; + + return false; +} + + +/* Determine if an expression is a function with an allocatable class array + result. */ +bool +gfc_is_class_array_function (gfc_expr *expr) +{ + if (expr->expr_type == EXPR_FUNCTION + && expr->value.function.esym + && expr->value.function.esym->result + && expr->value.function.esym->result->ts.type == BT_CLASS + && CLASS_DATA (expr->value.function.esym->result)->attr.dimension + && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable + || CLASS_DATA (expr->value.function.esym->result)->attr.pointer)) + return true; + + return false; +} + + +/* Walk an expression tree and check each variable encountered for being typed. + If strict is not set, a top-level variable is tolerated untyped in -std=gnu + mode as is a basic arithmetic expression using those; this is for things in + legacy-code like: + + INTEGER :: arr(n), n + INTEGER :: arr(n + 1), n + + The namespace is needed for IMPLICIT typing. */ + +static gfc_namespace* check_typed_ns; + +static bool +expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, + int* f ATTRIBUTE_UNUSED) +{ + bool t; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + gcc_assert (e->symtree); + t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns, + true, e->where); + + return (!t); +} + +bool +gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict) +{ + bool error_found; + + /* If this is a top-level variable or EXPR_OP, do the check with strict given + to us. */ + if (!strict) + { + if (e->expr_type == EXPR_VARIABLE && !e->ref) + return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where); + + if (e->expr_type == EXPR_OP) + { + bool t = true; + + gcc_assert (e->value.op.op1); + t = gfc_expr_check_typed (e->value.op.op1, ns, strict); + + if (t && e->value.op.op2) + t = gfc_expr_check_typed (e->value.op.op2, ns, strict); + + return t; + } + } + + /* Otherwise, walk the expression and do it strictly. */ + check_typed_ns = ns; + error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0); + + return error_found ? false : true; +} + + +/* This function returns true if it contains any references to PDT KIND + or LEN parameters. */ + +static bool +derived_parameter_expr (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, + int* f ATTRIBUTE_UNUSED) +{ + if (e->expr_type != EXPR_VARIABLE) + return false; + + gcc_assert (e->symtree); + if (e->symtree->n.sym->attr.pdt_kind + || e->symtree->n.sym->attr.pdt_len) + return true; + + return false; +} + + +bool +gfc_derived_parameter_expr (gfc_expr *e) +{ + return gfc_traverse_expr (e, NULL, &derived_parameter_expr, 0); +} + + +/* This function returns the overall type of a type parameter spec list. + If all the specs are explicit, SPEC_EXPLICIT is returned. If any of the + parameters are assumed/deferred then SPEC_ASSUMED/DEFERRED is returned + unless derived is not NULL. In this latter case, all the LEN parameters + must be either assumed or deferred for the return argument to be set to + anything other than SPEC_EXPLICIT. */ + +gfc_param_spec_type +gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) +{ + gfc_param_spec_type res = SPEC_EXPLICIT; + gfc_component *c; + bool seen_assumed = false; + bool seen_deferred = false; + + if (derived == NULL) + { + for (; param_list; param_list = param_list->next) + if (param_list->spec_type == SPEC_ASSUMED + || param_list->spec_type == SPEC_DEFERRED) + return param_list->spec_type; + } + else + { + for (; param_list; param_list = param_list->next) + { + c = gfc_find_component (derived, param_list->name, + true, true, NULL); + gcc_assert (c != NULL); + if (c->attr.pdt_kind) + continue; + else if (param_list->spec_type == SPEC_EXPLICIT) + return SPEC_EXPLICIT; + seen_assumed = param_list->spec_type == SPEC_ASSUMED; + seen_deferred = param_list->spec_type == SPEC_DEFERRED; + if (seen_assumed && seen_deferred) + return SPEC_EXPLICIT; + } + res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; + } + return res; +} + + +bool +gfc_ref_this_image (gfc_ref *ref) +{ + int n; + + gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0); + + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + return false; + + return true; +} + +gfc_expr * +gfc_find_team_co (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.team; + + if (e->value.function.actual->expr) + for (ref = e->value.function.actual->expr->ref; ref; + ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.team; + + return NULL; +} + +gfc_expr * +gfc_find_stat_co (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.stat; + + if (e->value.function.actual->expr) + for (ref = e->value.function.actual->expr->ref; ref; + ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.stat; + + return NULL; +} + +bool +gfc_is_coindexed (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return !gfc_ref_this_image (ref); + + return false; +} + + +/* Coarrays are variables with a corank but not being coindexed. However, also + the following is a coarray: A subobject of a coarray is a coarray if it does + not have any cosubscripts, vector subscripts, allocatable component + selection, or pointer component selection. (F2008, 2.4.7) */ + +bool +gfc_is_coarray (gfc_expr *e) +{ + gfc_ref *ref; + gfc_symbol *sym; + gfc_component *comp; + bool coindexed; + bool coarray; + int i; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + coindexed = false; + sym = e->symtree->n.sym; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + coarray = CLASS_DATA (sym)->attr.codimension; + else + coarray = sym->attr.codimension; + + for (ref = e->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_COMPONENT: + comp = ref->u.c.component; + if (comp->ts.type == BT_CLASS && comp->attr.class_ok + && (CLASS_DATA (comp)->attr.class_pointer + || CLASS_DATA (comp)->attr.allocatable)) + { + coindexed = false; + coarray = CLASS_DATA (comp)->attr.codimension; + } + else if (comp->attr.pointer || comp->attr.allocatable) + { + coindexed = false; + coarray = comp->attr.codimension; + } + break; + + case REF_ARRAY: + if (!coarray) + break; + + if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref)) + { + coindexed = true; + break; + } + + for (i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + { + coarray = false; + break; + } + break; + + case REF_SUBSTRING: + case REF_INQUIRY: + break; + } + + return coarray && !coindexed; +} + + +int +gfc_get_corank (gfc_expr *e) +{ + int corank; + gfc_ref *ref; + + if (!gfc_is_coarray (e)) + return 0; + + if (e->ts.type == BT_CLASS && e->ts.u.derived->components) + corank = e->ts.u.derived->components->as + ? e->ts.u.derived->components->as->corank : 0; + else + corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + corank = ref->u.ar.as->corank; + gcc_assert (ref->type != REF_SUBSTRING); + } + + return corank; +} + + +/* Check whether the expression has an ultimate allocatable component. + Being itself allocatable does not count. */ +bool +gfc_has_ultimate_allocatable (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return CLASS_DATA (last->u.c.component)->attr.alloc_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.alloc_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return CLASS_DATA (e)->attr.alloc_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.alloc_comp; + else + return false; +} + + +/* Check whether the expression has an pointer component. + Being itself a pointer does not count. */ +bool +gfc_has_ultimate_pointer (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return CLASS_DATA (last->u.c.component)->attr.pointer_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.pointer_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return CLASS_DATA (e)->attr.pointer_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.pointer_comp; + else + return false; +} + + +/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. + Note: A scalar is not regarded as "simply contiguous" by the standard. + if bool is not strict, some further checks are done - for instance, + a "(::1)" is accepted. */ + +bool +gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) +{ + bool colon; + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref, *part_ref = NULL; + gfc_symbol *sym; + + if (expr->expr_type == EXPR_ARRAY) + return true; + + if (expr->expr_type == EXPR_FUNCTION) + { + if (expr->value.function.isym) + /* TRANSPOSE is the only intrinsic that may return a + non-contiguous array. It's treated as a special case in + gfc_conv_expr_descriptor too. */ + return (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE); + else if (expr->value.function.esym) + /* Only a pointer to an array without the contiguous attribute + can be non-contiguous as a result value. */ + return (expr->value.function.esym->result->attr.contiguous + || !expr->value.function.esym->result->attr.pointer); + else + { + /* Type-bound procedures. */ + gfc_symbol *s = expr->symtree->n.sym; + if (s->ts.type != BT_CLASS && s->ts.type != BT_DERIVED) + return false; + + gfc_ref *rc = NULL; + for (gfc_ref *r = expr->ref; r; r = r->next) + if (r->type == REF_COMPONENT) + rc = r; + + if (rc == NULL || rc->u.c.component == NULL + || rc->u.c.component->ts.interface == NULL) + return false; + + return rc->u.c.component->ts.interface->attr.contiguous; + } + } + else if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (!permit_element && expr->rank == 0) + return false; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ar) + return false; /* Array shall be last part-ref. */ + + if (ref->type == REF_COMPONENT) + part_ref = ref; + else if (ref->type == REF_SUBSTRING) + return false; + else if (ref->type == REF_INQUIRY) + return false; + else if (ref->u.ar.type != AR_ELEMENT) + ar = &ref->u.ar; + } + + sym = expr->symtree->n.sym; + if (expr->ts.type != BT_CLASS + && ((part_ref + && !part_ref->u.c.component->attr.contiguous + && part_ref->u.c.component->attr.pointer) + || (!part_ref + && !sym->attr.contiguous + && (sym->attr.pointer + || (sym->as && sym->as->type == AS_ASSUMED_RANK) + || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))) + return false; + + if (!ar || ar->type == AR_FULL) + return true; + + gcc_assert (ar->type == AR_SECTION); + + /* Check for simply contiguous array */ + colon = true; + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_VECTOR) + return false; + + if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + colon = false; + continue; + } + + gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); + + + /* If the previous section was not contiguous, that's an error, + unless we have effective only one element and checking is not + strict. */ + if (!colon && (strict || !ar->start[i] || !ar->end[i] + || ar->start[i]->expr_type != EXPR_CONSTANT + || ar->end[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->end[i]->value.integer) != 0)) + return false; + + /* Following the standard, "(::1)" or - if known at compile time - + "(lbound:ubound)" are not simply contiguous; if strict + is false, they are regarded as simply contiguous. */ + if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT + || ar->stride[i]->ts.type != BT_INTEGER + || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) + return false; + + if (ar->start[i] + && (strict || ar->start[i]->expr_type != EXPR_CONSTANT + || !ar->as->lower[i] + || ar->as->lower[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->as->lower[i]->value.integer) != 0)) + colon = false; + + if (ar->end[i] + && (strict || ar->end[i]->expr_type != EXPR_CONSTANT + || !ar->as->upper[i] + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->end[i]->value.integer, + ar->as->upper[i]->value.integer) != 0)) + colon = false; + } + + return true; +} + +/* Return true if the expression is guaranteed to be non-contiguous, + false if we cannot prove anything. It is probably best to call + this after gfc_is_simply_contiguous. If neither of them returns + true, we cannot say (at compile-time). */ + +bool +gfc_is_not_contiguous (gfc_expr *array) +{ + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref; + bool previous_incomplete; + + for (ref = array->ref; ref; ref = ref->next) + { + /* Array-ref shall be last ref. */ + + if (ar && ar->type != AR_ELEMENT) + return true; + + if (ref->type == REF_ARRAY) + ar = &ref->u.ar; + } + + if (ar == NULL || ar->type != AR_SECTION) + return false; + + previous_incomplete = false; + + /* Check if we can prove that the array is not contiguous. */ + + for (i = 0; i < ar->dimen; i++) + { + mpz_t arr_size, ref_size; + + if (gfc_ref_dimen_size (ar, i, &ref_size, NULL)) + { + if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size)) + { + /* a(2:4,2:) is known to be non-contiguous, but + a(2:4,i:i) can be contiguous. */ + mpz_add_ui (arr_size, arr_size, 1L); + if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0) + { + mpz_clear (arr_size); + mpz_clear (ref_size); + return true; + } + else if (mpz_cmp (arr_size, ref_size) != 0) + previous_incomplete = true; + + mpz_clear (arr_size); + } + + /* Check for a(::2), i.e. where the stride is not unity. + This is only done if there is more than one element in + the reference along this dimension. */ + + if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION + && ar->dimen_type[i] == DIMEN_RANGE + && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT + && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0) + { + mpz_clear (ref_size); + return true; + } + + mpz_clear (ref_size); + } + } + /* We didn't find anything definitive. */ + return false; +} + +/* Build call to an intrinsic procedure. The number of arguments has to be + passed (rather than ending the list with a NULL value) because we may + want to add arguments but with a NULL-expression. */ + +gfc_expr* +gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name, + locus where, unsigned numarg, ...) +{ + gfc_expr* result; + gfc_actual_arglist* atail; + gfc_intrinsic_sym* isym; + va_list ap; + unsigned i; + const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name); + + isym = gfc_intrinsic_function_by_id (id); + gcc_assert (isym); + + result = gfc_get_expr (); + result->expr_type = EXPR_FUNCTION; + result->ts = isym->ts; + result->where = where; + result->value.function.name = mangled_name; + result->value.function.isym = isym; + + gfc_get_sym_tree (mangled_name, ns, &result->symtree, false); + gfc_commit_symbol (result->symtree->n.sym); + gcc_assert (result->symtree + && (result->symtree->n.sym->attr.flavor == FL_PROCEDURE + || result->symtree->n.sym->attr.flavor == FL_UNKNOWN)); + result->symtree->n.sym->intmod_sym_id = id; + result->symtree->n.sym->attr.flavor = FL_PROCEDURE; + result->symtree->n.sym->attr.intrinsic = 1; + result->symtree->n.sym->attr.artificial = 1; + + va_start (ap, numarg); + atail = NULL; + for (i = 0; i < numarg; ++i) + { + if (atail) + { + atail->next = gfc_get_actual_arglist (); + atail = atail->next; + } + else + atail = result->value.function.actual = gfc_get_actual_arglist (); + + atail->expr = va_arg (ap, gfc_expr*); + } + va_end (ap); + + return result; +} + + +/* Check if an expression may appear in a variable definition context + (F2008, 16.6.7) or pointer association context (F2008, 16.6.8). + This is called from the various places when resolving + the pieces that make up such a context. + If own_scope is true (applies to, e.g., ac-implied-do/data-implied-do + variables), some checks are not performed. + + Optionally, a possible error message can be suppressed if context is NULL + and just the return status (true / false) be requested. */ + +bool +gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, + bool own_scope, const char* context) +{ + gfc_symbol* sym = NULL; + bool is_pointer; + bool check_intentin; + bool ptr_component; + symbol_attribute attr; + gfc_ref* ref; + int i; + + if (e->expr_type == EXPR_VARIABLE) + { + gcc_assert (e->symtree); + sym = e->symtree->n.sym; + } + else if (e->expr_type == EXPR_FUNCTION) + { + gcc_assert (e->symtree); + sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym; + } + + attr = gfc_expr_attr (e); + if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer) + { + if (!(gfc_option.allow_std & GFC_STD_F2008)) + { + if (context) + gfc_error ("Fortran 2008: Pointer functions in variable definition" + " context (%s) at %L", context, &e->where); + return false; + } + } + else if (e->expr_type != EXPR_VARIABLE) + { + if (context) + gfc_error ("Non-variable expression in variable definition context (%s)" + " at %L", context, &e->where); + return false; + } + + if (!pointer && sym->attr.flavor == FL_PARAMETER) + { + if (context) + gfc_error ("Named constant %qs in variable definition context (%s)" + " at %L", sym->name, context, &e->where); + return false; + } + if (!pointer && sym->attr.flavor != FL_VARIABLE + && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer) + && !(sym->attr.flavor == FL_PROCEDURE + && sym->attr.function && sym->attr.pointer)) + { + if (context) + gfc_error ("%qs in variable definition context (%s) at %L is not" + " a variable", sym->name, context, &e->where); + return false; + } + + /* Find out whether the expr is a pointer; this also means following + component references to the last one. */ + is_pointer = (attr.pointer || attr.proc_pointer); + if (pointer && !is_pointer) + { + if (context) + gfc_error ("Non-POINTER in pointer association context (%s)" + " at %L", context, &e->where); + return false; + } + + if (e->ts.type == BT_DERIVED + && e->ts.u.derived == NULL) + { + if (context) + gfc_error ("Type inaccessible in variable definition context (%s) " + "at %L", context, &e->where); + return false; + } + + /* F2008, C1303. */ + if (!alloc_obj + && (attr.lock_comp + || (e->ts.type == BT_DERIVED + && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))) + { + if (context) + gfc_error ("LOCK_TYPE in variable definition context (%s) at %L", + context, &e->where); + return false; + } + + /* TS18508, C702/C203. */ + if (!alloc_obj + && (attr.lock_comp + || (e->ts.type == BT_DERIVED + && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) + { + if (context) + gfc_error ("LOCK_EVENT in variable definition context (%s) at %L", + context, &e->where); + return false; + } + + /* INTENT(IN) dummy argument. Check this, unless the object itself is the + component of sub-component of a pointer; we need to distinguish + assignment to a pointer component from pointer-assignment to a pointer + component. Note that (normal) assignment to procedure pointers is not + possible. */ + check_intentin = !own_scope; + ptr_component = (sym->ts.type == BT_CLASS && sym->ts.u.derived + && CLASS_DATA (sym)) + ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; + for (ref = e->ref; ref && check_intentin; ref = ref->next) + { + if (ptr_component && ref->type == REF_COMPONENT) + check_intentin = false; + if (ref->type == REF_COMPONENT) + { + gfc_component *comp = ref->u.c.component; + ptr_component = (comp->ts.type == BT_CLASS && comp->attr.class_ok) + ? CLASS_DATA (comp)->attr.class_pointer + : comp->attr.pointer; + if (ptr_component && !pointer) + check_intentin = false; + } + if (ref->type == REF_INQUIRY + && (ref->u.i == INQUIRY_KIND || ref->u.i == INQUIRY_LEN)) + { + if (context) + gfc_error ("%qs parameter inquiry for %qs in " + "variable definition context (%s) at %L", + ref->u.i == INQUIRY_KIND ? "KIND" : "LEN", + sym->name, context, &e->where); + return false; + } + } + + if (check_intentin + && (sym->attr.intent == INTENT_IN + || (sym->attr.select_type_temporary && sym->assoc + && sym->assoc->target && sym->assoc->target->symtree + && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN))) + { + if (pointer && is_pointer) + { + if (context) + gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" + " association context (%s) at %L", + sym->name, context, &e->where); + return false; + } + if (!pointer && !is_pointer && !sym->attr.pointer) + { + const char *name = sym->attr.select_type_temporary + ? sym->assoc->target->symtree->name : sym->name; + if (context) + gfc_error ("Dummy argument %qs with INTENT(IN) in variable" + " definition context (%s) at %L", + name, context, &e->where); + return false; + } + } + + /* PROTECTED and use-associated. */ + if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin) + { + if (pointer && is_pointer) + { + if (context) + gfc_error ("Variable %qs is PROTECTED and cannot appear in a" + " pointer association context (%s) at %L", + sym->name, context, &e->where); + return false; + } + if (!pointer && !is_pointer) + { + if (context) + gfc_error ("Variable %qs is PROTECTED and cannot appear in a" + " variable definition context (%s) at %L", + sym->name, context, &e->where); + return false; + } + } + + /* Variable not assignable from a PURE procedure but appears in + variable definition context. */ + own_scope = own_scope + || (sym->attr.result && sym->ns->proc_name + && sym == sym->ns->proc_name->result); + if (!pointer && !own_scope && gfc_pure (NULL) && gfc_impure_variable (sym)) + { + if (context) + gfc_error ("Variable %qs cannot appear in a variable definition" + " context (%s) at %L in PURE procedure", + sym->name, context, &e->where); + return false; + } + + if (!pointer && context && gfc_implicit_pure (NULL) + && gfc_impure_variable (sym)) + { + gfc_namespace *ns; + gfc_symbol *sym; + + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + break; + if (sym->attr.flavor == FL_PROCEDURE) + { + sym->attr.implicit_pure = 0; + break; + } + } + } + /* Check variable definition context for associate-names. */ + if (!pointer && sym->assoc && !sym->attr.select_rank_temporary) + { + const char* name; + gfc_association_list* assoc; + + gcc_assert (sym->assoc->target); + + /* If this is a SELECT TYPE temporary (the association is used internally + for SELECT TYPE), silently go over to the target. */ + if (sym->attr.select_type_temporary) + { + gfc_expr* t = sym->assoc->target; + + gcc_assert (t->expr_type == EXPR_VARIABLE); + name = t->symtree->name; + + if (t->symtree->n.sym->assoc) + assoc = t->symtree->n.sym->assoc; + else + assoc = sym->assoc; + } + else + { + name = sym->name; + assoc = sym->assoc; + } + gcc_assert (name && assoc); + + /* Is association to a valid variable? */ + if (!assoc->variable) + { + if (context) + { + if (assoc->target->expr_type == EXPR_VARIABLE) + gfc_error ("%qs at %L associated to vector-indexed target" + " cannot be used in a variable definition" + " context (%s)", + name, &e->where, context); + else + gfc_error ("%qs at %L associated to expression" + " cannot be used in a variable definition" + " context (%s)", + name, &e->where, context); + } + return false; + } + + /* Target must be allowed to appear in a variable definition context. */ + if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) + { + if (context) + gfc_error ("Associate-name %qs cannot appear in a variable" + " definition context (%s) at %L because its target" + " at %L cannot, either", + name, context, &e->where, + &assoc->target->where); + return false; + } + } + + /* Check for same value in vector expression subscript. */ + + if (e->rank > 0) + for (ref = e->ref; ref != NULL; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) + for (i = 0; i < GFC_MAX_DIMENSIONS + && ref->u.ar.dimen_type[i] != 0; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + { + gfc_expr *arr = ref->u.ar.start[i]; + if (arr->expr_type == EXPR_ARRAY) + { + gfc_constructor *c, *n; + gfc_expr *ec, *en; + + for (c = gfc_constructor_first (arr->value.constructor); + c != NULL; c = gfc_constructor_next (c)) + { + if (c == NULL || c->iterator != NULL) + continue; + + ec = c->expr; + + for (n = gfc_constructor_next (c); n != NULL; + n = gfc_constructor_next (n)) + { + if (n->iterator != NULL) + continue; + + en = n->expr; + if (gfc_dep_compare_expr (ec, en) == 0) + { + if (context) + gfc_error_now ("Elements with the same value " + "at %L and %L in vector " + "subscript in a variable " + "definition context (%s)", + &(ec->where), &(en->where), + context); + return false; + } + } + } + } + } + + return true; +} diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c deleted file mode 100644 index 1c2fe05..0000000 --- a/gcc/fortran/f95-lang.c +++ /dev/null @@ -1,1306 +0,0 @@ -/* gfortran backend interface - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Paul Brook. - -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 -. */ - -/* f95-lang.c-- GCC backend interface stuff */ - -/* declare required prototypes: */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "target.h" -#include "function.h" -#include "tree.h" -#include "gfortran.h" -#include "trans.h" -#include "stringpool.h" -#include "diagnostic.h" /* For errorcount/warningcount */ -#include "langhooks.h" -#include "langhooks-def.h" -#include "toplev.h" -#include "debug.h" -#include "cpp.h" -#include "trans-types.h" -#include "trans-const.h" - -/* Language-dependent contents of an identifier. */ - -struct GTY(()) -lang_identifier { - struct tree_identifier common; -}; - -/* The resulting tree type. */ - -union GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), - chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL"))) -lang_tree_node { - union tree_node GTY((tag ("0"), - desc ("tree_node_structure (&%h)"))) generic; - struct lang_identifier GTY((tag ("1"))) identifier; -}; - -/* Save and restore the variables in this file and elsewhere - that keep track of the progress of compilation of the current function. - Used for nested functions. */ - -struct GTY(()) -language_function { - /* struct gfc_language_function base; */ - struct binding_level *binding_level; -}; - -static void gfc_init_decl_processing (void); -static void gfc_init_builtin_functions (void); -static bool global_bindings_p (void); - -/* Each front end provides its own. */ -static bool gfc_init (void); -static void gfc_finish (void); -static void gfc_be_parse_file (void); -static void gfc_init_ts (void); -static tree gfc_builtin_function (tree); - -/* Handle an "omp declare target" attribute; arguments as in - struct attribute_spec.handler. */ -static tree -gfc_handle_omp_declare_target_attribute (tree *, tree, tree, int, bool *) -{ - return NULL_TREE; -} - -/* Table of valid Fortran attributes. */ -static const struct attribute_spec gfc_attribute_table[] = -{ - /* { name, min_len, max_len, decl_req, type_req, fn_type_req, - affects_type_identity, handler, exclude } */ - { "omp declare target", 0, -1, true, false, false, false, - gfc_handle_omp_declare_target_attribute, NULL }, - { "omp declare target link", 0, 0, true, false, false, false, - gfc_handle_omp_declare_target_attribute, NULL }, - { "oacc function", 0, -1, true, false, false, false, - gfc_handle_omp_declare_target_attribute, NULL }, - { NULL, 0, 0, false, false, false, false, NULL, NULL } -}; - -#undef LANG_HOOKS_NAME -#undef LANG_HOOKS_INIT -#undef LANG_HOOKS_FINISH -#undef LANG_HOOKS_OPTION_LANG_MASK -#undef LANG_HOOKS_INIT_OPTIONS_STRUCT -#undef LANG_HOOKS_INIT_OPTIONS -#undef LANG_HOOKS_HANDLE_OPTION -#undef LANG_HOOKS_POST_OPTIONS -#undef LANG_HOOKS_PARSE_FILE -#undef LANG_HOOKS_MARK_ADDRESSABLE -#undef LANG_HOOKS_TYPE_FOR_MODE -#undef LANG_HOOKS_TYPE_FOR_SIZE -#undef LANG_HOOKS_INIT_TS -#undef LANG_HOOKS_OMP_ARRAY_DATA -#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR -#undef LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT -#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE -#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING -#undef LANG_HOOKS_OMP_PREDETERMINED_MAPPING -#undef LANG_HOOKS_OMP_REPORT_DECL -#undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR -#undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR -#undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP -#undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR -#undef LANG_HOOKS_OMP_CLAUSE_DTOR -#undef LANG_HOOKS_OMP_FINISH_CLAUSE -#undef LANG_HOOKS_OMP_ALLOCATABLE_P -#undef LANG_HOOKS_OMP_SCALAR_TARGET_P -#undef LANG_HOOKS_OMP_SCALAR_P -#undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR -#undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE -#undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF -#undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES -#undef LANG_HOOKS_BUILTIN_FUNCTION -#undef LANG_HOOKS_BUILTIN_FUNCTION -#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO -#undef LANG_HOOKS_ATTRIBUTE_TABLE - -/* Define lang hooks. */ -#define LANG_HOOKS_NAME "GNU Fortran" -#define LANG_HOOKS_INIT gfc_init -#define LANG_HOOKS_FINISH gfc_finish -#define LANG_HOOKS_OPTION_LANG_MASK gfc_option_lang_mask -#define LANG_HOOKS_INIT_OPTIONS_STRUCT gfc_init_options_struct -#define LANG_HOOKS_INIT_OPTIONS gfc_init_options -#define LANG_HOOKS_HANDLE_OPTION gfc_handle_option -#define LANG_HOOKS_POST_OPTIONS gfc_post_options -#define LANG_HOOKS_PARSE_FILE gfc_be_parse_file -#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode -#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size -#define LANG_HOOKS_INIT_TS gfc_init_ts -#define LANG_HOOKS_OMP_ARRAY_DATA gfc_omp_array_data -#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr -#define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT gfc_omp_check_optional_argument -#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference -#define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing -#define LANG_HOOKS_OMP_PREDETERMINED_MAPPING gfc_omp_predetermined_mapping -#define LANG_HOOKS_OMP_REPORT_DECL gfc_omp_report_decl -#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor -#define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor -#define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP gfc_omp_clause_assign_op -#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor -#define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor -#define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause -#define LANG_HOOKS_OMP_ALLOCATABLE_P gfc_omp_allocatable_p -#define LANG_HOOKS_OMP_SCALAR_P gfc_omp_scalar_p -#define LANG_HOOKS_OMP_SCALAR_TARGET_P gfc_omp_scalar_target_p -#define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr -#define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause -#define LANG_HOOKS_OMP_PRIVATE_OUTER_REF gfc_omp_private_outer_ref -#define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \ - gfc_omp_firstprivatize_type_sizes -#define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function -#define LANG_HOOKS_GET_ARRAY_DESCR_INFO gfc_get_array_descr_info -#define LANG_HOOKS_ATTRIBUTE_TABLE gfc_attribute_table - -struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; - -#define NULL_BINDING_LEVEL (struct binding_level *) NULL - -/* A chain of binding_level structures awaiting reuse. */ - -static GTY(()) struct binding_level *free_binding_level; - -/* True means we've initialized exception handling. */ -static bool gfc_eh_initialized_p; - -/* The current translation unit. */ -static GTY(()) tree current_translation_unit; - - -static void -gfc_create_decls (void) -{ - /* GCC builtins. */ - gfc_init_builtin_functions (); - - /* Runtime/IO library functions. */ - gfc_build_builtin_function_decls (); - - gfc_init_constants (); - - /* Build our translation-unit decl. */ - current_translation_unit - = build_translation_unit_decl (get_identifier (main_input_filename)); - debug_hooks->register_main_translation_unit (current_translation_unit); -} - - -static void -gfc_be_parse_file (void) -{ - gfc_create_decls (); - gfc_parse_file (); - gfc_generate_constructors (); - - /* Clear the binding level stack. */ - while (!global_bindings_p ()) - poplevel (0, 0); - - /* Finalize all of the globals. - - Emulated tls lowering needs to see all TLS variables before we - call finalize_compilation_unit. The C/C++ front ends manage this - by calling decl_rest_of_compilation on each global and static - variable as they are seen. The Fortran front end waits until - here. */ - for (tree decl = getdecls (); decl ; decl = DECL_CHAIN (decl)) - rest_of_decl_compilation (decl, true, true); - - /* Switch to the default tree diagnostics here, because there may be - diagnostics before gfc_finish(). */ - gfc_diagnostics_finish (); - - global_decl_processing (); -} - - -/* Initialize everything. */ - -static bool -gfc_init (void) -{ - if (!gfc_cpp_enabled ()) - { - linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1); - linemap_add (line_table, LC_RENAME, false, "", 0); - } - else - gfc_cpp_init_0 (); - - gfc_init_decl_processing (); - gfc_static_ctors = NULL_TREE; - - if (gfc_cpp_enabled ()) - gfc_cpp_init (); - - gfc_init_1 (); - - /* Calls exit in case of a fail. */ - gfc_new_file (); - - if (flag_preprocess_only) - return false; - - return true; -} - - -static void -gfc_finish (void) -{ - gfc_cpp_done (); - gfc_done_1 (); - gfc_release_include_path (); - return; -} - -/* These functions and variables deal with binding contours. We only - need these functions for the list of PARM_DECLs, but we leave the - functions more general; these are a simplified version of the - functions from GNAT. */ - -/* For each binding contour we allocate a binding_level structure which - records the entities defined or declared in that contour. Contours - include: - - the global one - one for each subprogram definition - one for each compound statement (declare block) - - Binding contours are used to create GCC tree BLOCK nodes. */ - -struct GTY(()) -binding_level { - /* A chain of ..._DECL nodes for all variables, constants, functions, - parameters and type declarations. These ..._DECL nodes are chained - through the DECL_CHAIN field. */ - tree names; - /* For each level (except the global one), a chain of BLOCK nodes for all - the levels that were entered and exited one level down from this one. */ - tree blocks; - /* The binding level containing this one (the enclosing binding level). */ - struct binding_level *level_chain; - /* True if nreverse has been already called on names; if false, names - are ordered from newest declaration to oldest one. */ - bool reversed; -}; - -/* The binding level currently in effect. */ -static GTY(()) struct binding_level *current_binding_level = NULL; - -/* The outermost binding level. This binding level is created when the - compiler is started and it will exist through the entire compilation. */ -static GTY(()) struct binding_level *global_binding_level; - -/* Binding level structures are initialized by copying this one. */ -static struct binding_level clear_binding_level = { NULL, NULL, NULL, false }; - - -/* Return true if we are in the global binding level. */ - -bool -global_bindings_p (void) -{ - return current_binding_level == global_binding_level; -} - -tree -getdecls (void) -{ - if (!current_binding_level->reversed) - { - current_binding_level->reversed = true; - current_binding_level->names = nreverse (current_binding_level->names); - } - return current_binding_level->names; -} - -/* Enter a new binding level. */ - -void -pushlevel (void) -{ - struct binding_level *newlevel = ggc_alloc (); - - *newlevel = clear_binding_level; - - /* Add this level to the front of the chain (stack) of levels that are - active. */ - newlevel->level_chain = current_binding_level; - current_binding_level = newlevel; -} - -/* Exit a binding level. - Pop the level off, and restore the state of the identifier-decl mappings - that were in effect when this level was entered. - - If KEEP is nonzero, this level had explicit declarations, so - and create a "block" (a BLOCK node) for the level - to record its declarations and subblocks for symbol table output. - - If FUNCTIONBODY is nonzero, this level is the body of a function, - so create a block as if KEEP were set and also clear out all - label names. */ - -tree -poplevel (int keep, int functionbody) -{ - /* Points to a BLOCK tree node. This is the BLOCK node constructed for the - binding level that we are about to exit and which is returned by this - routine. */ - tree block_node = NULL_TREE; - tree decl_chain = getdecls (); - tree subblock_chain = current_binding_level->blocks; - tree subblock_node; - - /* If there were any declarations in the current binding level, or if this - binding level is a function body, or if there are any nested blocks then - create a BLOCK node to record them for the life of this function. */ - if (keep || functionbody) - block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0); - - /* Record the BLOCK node just built as the subblock its enclosing scope. */ - for (subblock_node = subblock_chain; subblock_node; - subblock_node = BLOCK_CHAIN (subblock_node)) - BLOCK_SUPERCONTEXT (subblock_node) = block_node; - - /* Clear out the meanings of the local variables of this level. */ - - for (subblock_node = decl_chain; subblock_node; - subblock_node = DECL_CHAIN (subblock_node)) - if (DECL_NAME (subblock_node) != 0) - /* If the identifier was used or addressed via a local extern decl, - don't forget that fact. */ - if (DECL_EXTERNAL (subblock_node)) - { - if (TREE_USED (subblock_node)) - TREE_USED (DECL_NAME (subblock_node)) = 1; - if (TREE_ADDRESSABLE (subblock_node)) - TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1; - } - - /* Pop the current level. */ - current_binding_level = current_binding_level->level_chain; - - if (functionbody) - /* This is the top level block of a function. */ - DECL_INITIAL (current_function_decl) = block_node; - else if (current_binding_level == global_binding_level) - /* When using gfc_start_block/gfc_finish_block from middle-end hooks, - don't add newly created BLOCKs as subblocks of global_binding_level. */ - ; - else if (block_node) - { - current_binding_level->blocks - = block_chainon (current_binding_level->blocks, block_node); - } - - /* If we did not make a block for the level just exited, any blocks made for - inner levels (since they cannot be recorded as subblocks in that level) - must be carried forward so they will later become subblocks of something - else. */ - else if (subblock_chain) - current_binding_level->blocks - = block_chainon (current_binding_level->blocks, subblock_chain); - if (block_node) - TREE_USED (block_node) = 1; - - return block_node; -} - - -/* Records a ..._DECL node DECL as belonging to the current lexical scope. - Returns the ..._DECL node. */ - -tree -pushdecl (tree decl) -{ - if (global_bindings_p ()) - DECL_CONTEXT (decl) = current_translation_unit; - else - { - /* External objects aren't nested. For debug info insert a copy - of the decl into the binding level. */ - if (DECL_EXTERNAL (decl)) - { - tree orig = decl; - decl = copy_node (decl); - DECL_CONTEXT (orig) = NULL_TREE; - } - DECL_CONTEXT (decl) = current_function_decl; - } - - /* Put the declaration on the list. */ - DECL_CHAIN (decl) = current_binding_level->names; - current_binding_level->names = decl; - - /* For the declaration of a type, set its name if it is not already set. */ - - if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0) - { - if (DECL_SOURCE_LINE (decl) == 0) - TYPE_NAME (TREE_TYPE (decl)) = decl; - else - TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl); - } - - return decl; -} - - -/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL. */ - -tree -pushdecl_top_level (tree x) -{ - tree t; - struct binding_level *b = current_binding_level; - - current_binding_level = global_binding_level; - t = pushdecl (x); - current_binding_level = b; - return t; -} - -#ifndef CHAR_TYPE_SIZE -#define CHAR_TYPE_SIZE BITS_PER_UNIT -#endif - -#ifndef INT_TYPE_SIZE -#define INT_TYPE_SIZE BITS_PER_WORD -#endif - -#undef SIZE_TYPE -#define SIZE_TYPE "long unsigned int" - -/* Create tree nodes for the basic scalar types of Fortran 95, - and some nodes representing standard constants (0, 1, (void *) 0). - Initialize the global binding level. - Make definitions for built-in primitive functions. */ -static void -gfc_init_decl_processing (void) -{ - current_function_decl = NULL; - current_binding_level = NULL_BINDING_LEVEL; - free_binding_level = NULL_BINDING_LEVEL; - - /* Make the binding_level structure for global names. We move all - variables that are in a COMMON block to this binding level. */ - pushlevel (); - global_binding_level = current_binding_level; - - /* Build common tree nodes. char_type_node is unsigned because we - only use it for actual characters, not for INTEGER(1). */ - build_common_tree_nodes (false); - - void_list_node = build_tree_list (NULL_TREE, void_type_node); - - /* Set up F95 type nodes. */ - gfc_init_kinds (); - gfc_init_types (); - gfc_init_c_interop_kinds (); -} - - -/* Builtin function initialization. */ - -static tree -gfc_builtin_function (tree decl) -{ - pushdecl (decl); - return decl; -} - -/* So far we need just these 10 attribute types. */ -#define ATTR_NULL 0 -#define ATTR_LEAF_LIST (ECF_LEAF) -#define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF) -#define ATTR_NOTHROW_LEAF_MALLOC_LIST (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC) -#define ATTR_CONST_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_CONST) -#define ATTR_PURE_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_PURE) -#define ATTR_NOTHROW_LIST (ECF_NOTHROW) -#define ATTR_CONST_NOTHROW_LIST (ECF_NOTHROW | ECF_CONST) -#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST \ - (ECF_NOTHROW) -#define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ - (ECF_COLD | ECF_NORETURN | \ - ECF_NOTHROW | ECF_LEAF) - -static void -gfc_define_builtin (const char *name, tree type, enum built_in_function code, - const char *library_name, int attr) -{ - tree decl; - - decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL, - library_name, NULL_TREE); - set_call_expr_flags (decl, attr); - - set_builtin_decl (code, decl, true); -} - - -#define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \ - gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \ - BUILT_IN_ ## code ## L, name "l", \ - ATTR_CONST_NOTHROW_LEAF_LIST); \ - gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \ - BUILT_IN_ ## code, name, \ - ATTR_CONST_NOTHROW_LEAF_LIST); \ - gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \ - BUILT_IN_ ## code ## F, name "f", \ - ATTR_CONST_NOTHROW_LEAF_LIST); - -#define DEFINE_MATH_BUILTIN(code, name, argtype) \ - DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) - -#define DEFINE_MATH_BUILTIN_C(code, name, argtype) \ - DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \ - DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c) - - -/* Create function types for builtin functions. */ - -static void -build_builtin_fntypes (tree *fntype, tree type) -{ - /* type (*) (type) */ - fntype[0] = build_function_type_list (type, type, NULL_TREE); - /* type (*) (type, type) */ - fntype[1] = build_function_type_list (type, type, type, NULL_TREE); - /* type (*) (type, int) */ - fntype[2] = build_function_type_list (type, - type, integer_type_node, NULL_TREE); - /* type (*) (void) */ - fntype[3] = build_function_type_list (type, NULL_TREE); - /* type (*) (type, &int) */ - fntype[4] = build_function_type_list (type, type, - build_pointer_type (integer_type_node), - NULL_TREE); - /* type (*) (int, type) */ - fntype[5] = build_function_type_list (type, - integer_type_node, type, NULL_TREE); -} - - -static tree -builtin_type_for_size (int size, bool unsignedp) -{ - tree type = gfc_type_for_size (size, unsignedp); - return type ? type : error_mark_node; -} - -/* Initialization of builtin function nodes. */ - -static void -gfc_init_builtin_functions (void) -{ - enum builtin_type - { -#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, -#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, -#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, -#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, -#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, -#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, -#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, -#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6) NAME, -#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7) NAME, -#define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7, ARG8) NAME, -#define DEF_FUNCTION_TYPE_9(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7, ARG8, ARG9) NAME, -#define DEF_FUNCTION_TYPE_10(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7, ARG8, ARG9, ARG10) NAME, -#define DEF_FUNCTION_TYPE_11(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) NAME, -#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, -#define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, -#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, -#define DEF_FUNCTION_TYPE_VAR_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6) NAME, -#define DEF_FUNCTION_TYPE_VAR_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7) NAME, -#define DEF_POINTER_TYPE(NAME, TYPE) NAME, -#include "types.def" -#undef DEF_PRIMITIVE_TYPE -#undef DEF_FUNCTION_TYPE_0 -#undef DEF_FUNCTION_TYPE_1 -#undef DEF_FUNCTION_TYPE_2 -#undef DEF_FUNCTION_TYPE_3 -#undef DEF_FUNCTION_TYPE_4 -#undef DEF_FUNCTION_TYPE_5 -#undef DEF_FUNCTION_TYPE_6 -#undef DEF_FUNCTION_TYPE_7 -#undef DEF_FUNCTION_TYPE_8 -#undef DEF_FUNCTION_TYPE_9 -#undef DEF_FUNCTION_TYPE_10 -#undef DEF_FUNCTION_TYPE_11 -#undef DEF_FUNCTION_TYPE_VAR_0 -#undef DEF_FUNCTION_TYPE_VAR_1 -#undef DEF_FUNCTION_TYPE_VAR_2 -#undef DEF_FUNCTION_TYPE_VAR_6 -#undef DEF_FUNCTION_TYPE_VAR_7 -#undef DEF_POINTER_TYPE - BT_LAST - }; - - tree mfunc_float[6]; - tree mfunc_double[6]; - tree mfunc_longdouble[6]; - tree mfunc_cfloat[6]; - tree mfunc_cdouble[6]; - tree mfunc_clongdouble[6]; - tree func_cfloat_float, func_float_cfloat; - tree func_cdouble_double, func_double_cdouble; - tree func_clongdouble_longdouble, func_longdouble_clongdouble; - tree func_float_floatp_floatp; - tree func_double_doublep_doublep; - tree func_longdouble_longdoublep_longdoublep; - tree ftype, ptype; - tree builtin_types[(int) BT_LAST + 1]; - - int attr; - - build_builtin_fntypes (mfunc_float, float_type_node); - build_builtin_fntypes (mfunc_double, double_type_node); - build_builtin_fntypes (mfunc_longdouble, long_double_type_node); - build_builtin_fntypes (mfunc_cfloat, complex_float_type_node); - build_builtin_fntypes (mfunc_cdouble, complex_double_type_node); - build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node); - - func_cfloat_float = build_function_type_list (float_type_node, - complex_float_type_node, - NULL_TREE); - - func_float_cfloat = build_function_type_list (complex_float_type_node, - float_type_node, NULL_TREE); - - func_cdouble_double = build_function_type_list (double_type_node, - complex_double_type_node, - NULL_TREE); - - func_double_cdouble = build_function_type_list (complex_double_type_node, - double_type_node, NULL_TREE); - - func_clongdouble_longdouble = - build_function_type_list (long_double_type_node, - complex_long_double_type_node, NULL_TREE); - - func_longdouble_clongdouble = - build_function_type_list (complex_long_double_type_node, - long_double_type_node, NULL_TREE); - - ptype = build_pointer_type (float_type_node); - func_float_floatp_floatp = - build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); - - ptype = build_pointer_type (double_type_node); - func_double_doublep_doublep = - build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); - - ptype = build_pointer_type (long_double_type_node); - func_longdouble_longdoublep_longdoublep = - build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); - -/* Non-math builtins are defined manually, so they're not included here. */ -#define OTHER_BUILTIN(ID,NAME,TYPE,CONST) - -#include "mathbuiltins.def" - - gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0], - BUILT_IN_ROUNDL, "roundl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_round", mfunc_double[0], - BUILT_IN_ROUND, "round", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_roundf", mfunc_float[0], - BUILT_IN_ROUNDF, "roundf", ATTR_CONST_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0], - BUILT_IN_TRUNCL, "truncl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_trunc", mfunc_double[0], - BUILT_IN_TRUNC, "trunc", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_truncf", mfunc_float[0], - BUILT_IN_TRUNCF, "truncf", ATTR_CONST_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble, - BUILT_IN_CABSL, "cabsl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cabs", func_cdouble_double, - BUILT_IN_CABS, "cabs", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cabsf", func_cfloat_float, - BUILT_IN_CABSF, "cabsf", ATTR_CONST_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1], - BUILT_IN_COPYSIGNL, "copysignl", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_copysign", mfunc_double[1], - BUILT_IN_COPYSIGN, "copysign", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], - BUILT_IN_COPYSIGNF, "copysignf", - ATTR_CONST_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__builtin_nextafterl", mfunc_longdouble[1], - BUILT_IN_NEXTAFTERL, "nextafterl", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_nextafter", mfunc_double[1], - BUILT_IN_NEXTAFTER, "nextafter", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_nextafterf", mfunc_float[1], - BUILT_IN_NEXTAFTERF, "nextafterf", - ATTR_CONST_NOTHROW_LEAF_LIST); - - /* Some built-ins depend on rounding mode. Depending on compilation options, they - will be "pure" or "const". */ - attr = flag_rounding_math ? ATTR_PURE_NOTHROW_LEAF_LIST : ATTR_CONST_NOTHROW_LEAF_LIST; - - gfc_define_builtin ("__builtin_rintl", mfunc_longdouble[0], - BUILT_IN_RINTL, "rintl", attr); - gfc_define_builtin ("__builtin_rint", mfunc_double[0], - BUILT_IN_RINT, "rint", attr); - gfc_define_builtin ("__builtin_rintf", mfunc_float[0], - BUILT_IN_RINTF, "rintf", attr); - - gfc_define_builtin ("__builtin_remainderl", mfunc_longdouble[1], - BUILT_IN_REMAINDERL, "remainderl", attr); - gfc_define_builtin ("__builtin_remainder", mfunc_double[1], - BUILT_IN_REMAINDER, "remainder", attr); - gfc_define_builtin ("__builtin_remainderf", mfunc_float[1], - BUILT_IN_REMAINDERF, "remainderf", attr); - - gfc_define_builtin ("__builtin_logbl", mfunc_longdouble[0], - BUILT_IN_LOGBL, "logbl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_logb", mfunc_double[0], - BUILT_IN_LOGB, "logb", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_logbf", mfunc_float[0], - BUILT_IN_LOGBF, "logbf", ATTR_CONST_NOTHROW_LEAF_LIST); - - - gfc_define_builtin ("__builtin_frexpl", mfunc_longdouble[4], - BUILT_IN_FREXPL, "frexpl", ATTR_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_frexp", mfunc_double[4], - BUILT_IN_FREXP, "frexp", ATTR_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_frexpf", mfunc_float[4], - BUILT_IN_FREXPF, "frexpf", ATTR_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__builtin_fabsl", mfunc_longdouble[0], - BUILT_IN_FABSL, "fabsl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_fabs", mfunc_double[0], - BUILT_IN_FABS, "fabs", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_fabsf", mfunc_float[0], - BUILT_IN_FABSF, "fabsf", ATTR_CONST_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__builtin_scalbnl", mfunc_longdouble[2], - BUILT_IN_SCALBNL, "scalbnl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_scalbn", mfunc_double[2], - BUILT_IN_SCALBN, "scalbn", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_scalbnf", mfunc_float[2], - BUILT_IN_SCALBNF, "scalbnf", ATTR_CONST_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1], - BUILT_IN_FMODL, "fmodl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_fmod", mfunc_double[1], - BUILT_IN_FMOD, "fmod", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], - BUILT_IN_FMODF, "fmodf", ATTR_CONST_NOTHROW_LEAF_LIST); - - /* iround{f,,l}, lround{f,,l} and llround{f,,l} */ - ftype = build_function_type_list (integer_type_node, - float_type_node, NULL_TREE); - gfc_define_builtin("__builtin_iroundf", ftype, BUILT_IN_IROUNDF, - "iroundf", ATTR_CONST_NOTHROW_LEAF_LIST); - ftype = build_function_type_list (long_integer_type_node, - float_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_lroundf", ftype, BUILT_IN_LROUNDF, - "lroundf", ATTR_CONST_NOTHROW_LEAF_LIST); - ftype = build_function_type_list (long_long_integer_type_node, - float_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_llroundf", ftype, BUILT_IN_LLROUNDF, - "llroundf", ATTR_CONST_NOTHROW_LEAF_LIST); - - ftype = build_function_type_list (integer_type_node, - double_type_node, NULL_TREE); - gfc_define_builtin("__builtin_iround", ftype, BUILT_IN_IROUND, - "iround", ATTR_CONST_NOTHROW_LEAF_LIST); - ftype = build_function_type_list (long_integer_type_node, - double_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_lround", ftype, BUILT_IN_LROUND, - "lround", ATTR_CONST_NOTHROW_LEAF_LIST); - ftype = build_function_type_list (long_long_integer_type_node, - double_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_llround", ftype, BUILT_IN_LLROUND, - "llround", ATTR_CONST_NOTHROW_LEAF_LIST); - - ftype = build_function_type_list (integer_type_node, - long_double_type_node, NULL_TREE); - gfc_define_builtin("__builtin_iroundl", ftype, BUILT_IN_IROUNDL, - "iroundl", ATTR_CONST_NOTHROW_LEAF_LIST); - ftype = build_function_type_list (long_integer_type_node, - long_double_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_lroundl", ftype, BUILT_IN_LROUNDL, - "lroundl", ATTR_CONST_NOTHROW_LEAF_LIST); - ftype = build_function_type_list (long_long_integer_type_node, - long_double_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_llroundl", ftype, BUILT_IN_LLROUNDL, - "llroundl", ATTR_CONST_NOTHROW_LEAF_LIST); - - /* These are used to implement the ** operator. */ - gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1], - BUILT_IN_POWL, "powl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_pow", mfunc_double[1], - BUILT_IN_POW, "pow", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_powf", mfunc_float[1], - BUILT_IN_POWF, "powf", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cpowl", mfunc_clongdouble[1], - BUILT_IN_CPOWL, "cpowl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cpow", mfunc_cdouble[1], - BUILT_IN_CPOW, "cpow", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cpowf", mfunc_cfloat[1], - BUILT_IN_CPOWF, "cpowf", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_powil", mfunc_longdouble[2], - BUILT_IN_POWIL, "powil", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_powi", mfunc_double[2], - BUILT_IN_POWI, "powi", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_powif", mfunc_float[2], - BUILT_IN_POWIF, "powif", ATTR_CONST_NOTHROW_LEAF_LIST); - - - if (targetm.libc_has_function (function_c99_math_complex, NULL_TREE)) - { - gfc_define_builtin ("__builtin_cbrtl", mfunc_longdouble[0], - BUILT_IN_CBRTL, "cbrtl", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cbrt", mfunc_double[0], - BUILT_IN_CBRT, "cbrt", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cbrtf", mfunc_float[0], - BUILT_IN_CBRTF, "cbrtf", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cexpil", func_longdouble_clongdouble, - BUILT_IN_CEXPIL, "cexpil", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cexpi", func_double_cdouble, - BUILT_IN_CEXPI, "cexpi", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_cexpif", func_float_cfloat, - BUILT_IN_CEXPIF, "cexpif", - ATTR_CONST_NOTHROW_LEAF_LIST); - } - - if (targetm.libc_has_function (function_sincos, NULL_TREE)) - { - gfc_define_builtin ("__builtin_sincosl", - func_longdouble_longdoublep_longdoublep, - BUILT_IN_SINCOSL, "sincosl", ATTR_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_sincos", func_double_doublep_doublep, - BUILT_IN_SINCOS, "sincos", ATTR_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_sincosf", func_float_floatp_floatp, - BUILT_IN_SINCOSF, "sincosf", ATTR_NOTHROW_LEAF_LIST); - } - - /* For LEADZ, TRAILZ, POPCNT and POPPAR. */ - ftype = build_function_type_list (integer_type_node, - unsigned_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, - "__builtin_clz", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ, - "__builtin_ctz", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_parity", ftype, BUILT_IN_PARITY, - "__builtin_parity", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_popcount", ftype, BUILT_IN_POPCOUNT, - "__builtin_popcount", ATTR_CONST_NOTHROW_LEAF_LIST); - - ftype = build_function_type_list (integer_type_node, - long_unsigned_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, - "__builtin_clzl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL, - "__builtin_ctzl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_parityl", ftype, BUILT_IN_PARITYL, - "__builtin_parityl", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_popcountl", ftype, BUILT_IN_POPCOUNTL, - "__builtin_popcountl", ATTR_CONST_NOTHROW_LEAF_LIST); - - ftype = build_function_type_list (integer_type_node, - long_long_unsigned_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, - "__builtin_clzll", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL, - "__builtin_ctzll", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_parityll", ftype, BUILT_IN_PARITYLL, - "__builtin_parityll", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_popcountll", ftype, BUILT_IN_POPCOUNTLL, - "__builtin_popcountll", ATTR_CONST_NOTHROW_LEAF_LIST); - - /* Other builtin functions we use. */ - - ftype = build_function_type_list (long_integer_type_node, - long_integer_type_node, - long_integer_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, - "__builtin_expect", ATTR_CONST_NOTHROW_LEAF_LIST); - - ftype = build_function_type_list (void_type_node, - pvoid_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE, - "free", ATTR_NOTHROW_LEAF_LIST); - - ftype = build_function_type_list (pvoid_type_node, - size_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_malloc", ftype, BUILT_IN_MALLOC, - "malloc", ATTR_NOTHROW_LEAF_MALLOC_LIST); - - ftype = build_function_type_list (pvoid_type_node, size_type_node, - size_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_calloc", ftype, BUILT_IN_CALLOC, - "calloc", ATTR_NOTHROW_LEAF_MALLOC_LIST); - DECL_IS_MALLOC (builtin_decl_explicit (BUILT_IN_CALLOC)) = 1; - - ftype = build_function_type_list (pvoid_type_node, - size_type_node, pvoid_type_node, - NULL_TREE); - gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC, - "realloc", ATTR_NOTHROW_LEAF_LIST); - - /* Type-generic floating-point classification built-ins. */ - - ftype = build_function_type (integer_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_isfinite", ftype, BUILT_IN_ISFINITE, - "__builtin_isfinite", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_isinf", ftype, BUILT_IN_ISINF, - "__builtin_isinf", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_isinf_sign", ftype, BUILT_IN_ISINF_SIGN, - "__builtin_isinf_sign", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN, - "__builtin_isnan", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_isnormal", ftype, BUILT_IN_ISNORMAL, - "__builtin_isnormal", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_signbit", ftype, BUILT_IN_SIGNBIT, - "__builtin_signbit", ATTR_CONST_NOTHROW_LEAF_LIST); - - ftype = build_function_type (integer_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_isless", ftype, BUILT_IN_ISLESS, - "__builtin_isless", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_islessequal", ftype, BUILT_IN_ISLESSEQUAL, - "__builtin_islessequal", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_islessgreater", ftype, BUILT_IN_ISLESSGREATER, - "__builtin_islessgreater", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_isgreater", ftype, BUILT_IN_ISGREATER, - "__builtin_isgreater", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_isgreaterequal", ftype, - BUILT_IN_ISGREATEREQUAL, "__builtin_isgreaterequal", - ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__builtin_isunordered", ftype, BUILT_IN_ISUNORDERED, - "__builtin_isunordered", ATTR_CONST_NOTHROW_LEAF_LIST); - - -#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ - builtin_types[(int) ENUM] = VALUE; -#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - builtin_types[(int) ARG7], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7, ARG8) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - builtin_types[(int) ARG7], \ - builtin_types[(int) ARG8], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_9(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7, ARG8, ARG9) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - builtin_types[(int) ARG7], \ - builtin_types[(int) ARG8], \ - builtin_types[(int) ARG9], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_10(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, \ - ARG5, ARG6, ARG7, ARG8, ARG9, ARG10) \ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - builtin_types[(int) ARG7], \ - builtin_types[(int) ARG8], \ - builtin_types[(int) ARG9], \ - builtin_types[(int) ARG10], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_11(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, \ - ARG5, ARG6, ARG7, ARG8, ARG9, ARG10, ARG11)\ - builtin_types[(int) ENUM] \ - = build_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - builtin_types[(int) ARG7], \ - builtin_types[(int) ARG8], \ - builtin_types[(int) ARG9], \ - builtin_types[(int) ARG10], \ - builtin_types[(int) ARG11], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ - builtin_types[(int) ENUM] \ - = build_varargs_function_type_list (builtin_types[(int) RETURN], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ - builtin_types[(int) ENUM] \ - = build_varargs_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \ - builtin_types[(int) ENUM] \ - = build_varargs_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_VAR_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6) \ - builtin_types[(int) ENUM] \ - = build_varargs_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - NULL_TREE); -#define DEF_FUNCTION_TYPE_VAR_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ - ARG6, ARG7) \ - builtin_types[(int) ENUM] \ - = build_varargs_function_type_list (builtin_types[(int) RETURN], \ - builtin_types[(int) ARG1], \ - builtin_types[(int) ARG2], \ - builtin_types[(int) ARG3], \ - builtin_types[(int) ARG4], \ - builtin_types[(int) ARG5], \ - builtin_types[(int) ARG6], \ - builtin_types[(int) ARG7], \ - NULL_TREE); -#define DEF_POINTER_TYPE(ENUM, TYPE) \ - builtin_types[(int) ENUM] \ - = build_pointer_type (builtin_types[(int) TYPE]); -#include "types.def" -#undef DEF_PRIMITIVE_TYPE -#undef DEF_FUNCTION_TYPE_0 -#undef DEF_FUNCTION_TYPE_1 -#undef DEF_FUNCTION_TYPE_2 -#undef DEF_FUNCTION_TYPE_3 -#undef DEF_FUNCTION_TYPE_4 -#undef DEF_FUNCTION_TYPE_5 -#undef DEF_FUNCTION_TYPE_6 -#undef DEF_FUNCTION_TYPE_7 -#undef DEF_FUNCTION_TYPE_8 -#undef DEF_FUNCTION_TYPE_10 -#undef DEF_FUNCTION_TYPE_VAR_0 -#undef DEF_FUNCTION_TYPE_VAR_1 -#undef DEF_FUNCTION_TYPE_VAR_2 -#undef DEF_FUNCTION_TYPE_VAR_6 -#undef DEF_FUNCTION_TYPE_VAR_7 -#undef DEF_POINTER_TYPE - builtin_types[(int) BT_LAST] = NULL_TREE; - - /* Initialize synchronization builtins. */ -#undef DEF_SYNC_BUILTIN -#define DEF_SYNC_BUILTIN(code, name, type, attr) \ - gfc_define_builtin (name, builtin_types[type], code, name, \ - attr); -#include "../sync-builtins.def" -#undef DEF_SYNC_BUILTIN - - if (flag_openacc) - { -#undef DEF_GOACC_BUILTIN -#define DEF_GOACC_BUILTIN(code, name, type, attr) \ - gfc_define_builtin ("__builtin_" name, builtin_types[type], \ - code, name, attr); -#undef DEF_GOACC_BUILTIN_COMPILER -#define DEF_GOACC_BUILTIN_COMPILER(code, name, type, attr) \ - gfc_define_builtin (name, builtin_types[type], code, name, attr); -#undef DEF_GOACC_BUILTIN_ONLY -#define DEF_GOACC_BUILTIN_ONLY(code, name, type, attr) \ - gfc_define_builtin ("__builtin_" name, builtin_types[type], code, NULL, \ - attr); -#undef DEF_GOMP_BUILTIN -#define DEF_GOMP_BUILTIN(code, name, type, attr) /* ignore */ -#include "../omp-builtins.def" -#undef DEF_GOACC_BUILTIN -#undef DEF_GOACC_BUILTIN_COMPILER -#undef DEF_GOMP_BUILTIN - } - - if (flag_openmp || flag_openmp_simd || flag_tree_parallelize_loops) - { -#undef DEF_GOACC_BUILTIN -#define DEF_GOACC_BUILTIN(code, name, type, attr) /* ignore */ -#undef DEF_GOACC_BUILTIN_COMPILER -#define DEF_GOACC_BUILTIN_COMPILER(code, name, type, attr) /* ignore */ -#undef DEF_GOMP_BUILTIN -#define DEF_GOMP_BUILTIN(code, name, type, attr) \ - gfc_define_builtin ("__builtin_" name, builtin_types[type], \ - code, name, attr); -#include "../omp-builtins.def" -#undef DEF_GOACC_BUILTIN -#undef DEF_GOACC_BUILTIN_COMPILER -#undef DEF_GOMP_BUILTIN - tree gomp_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); - tree two = build_int_cst (integer_type_node, 2); - DECL_ATTRIBUTES (gomp_alloc) - = tree_cons (get_identifier ("warn_unused_result"), NULL_TREE, - tree_cons (get_identifier ("alloc_size"), - build_tree_list (NULL_TREE, two), - DECL_ATTRIBUTES (gomp_alloc))); - } - - gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID], - BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST); - TREE_THIS_VOLATILE (builtin_decl_explicit (BUILT_IN_TRAP)) = 1; - - ftype = build_varargs_function_type_list (ptr_type_node, const_ptr_type_node, - size_type_node, NULL_TREE); - gfc_define_builtin ("__builtin_assume_aligned", ftype, - BUILT_IN_ASSUME_ALIGNED, - "__builtin_assume_aligned", - ATTR_CONST_NOTHROW_LEAF_LIST); - - gfc_define_builtin ("__emutls_get_address", - builtin_types[BT_FN_PTR_PTR], - BUILT_IN_EMUTLS_GET_ADDRESS, - "__emutls_get_address", ATTR_CONST_NOTHROW_LEAF_LIST); - gfc_define_builtin ("__emutls_register_common", - builtin_types[BT_FN_VOID_PTR_WORD_WORD_PTR], - BUILT_IN_EMUTLS_REGISTER_COMMON, - "__emutls_register_common", ATTR_NOTHROW_LEAF_LIST); - - build_common_builtin_nodes (); - targetm.init_builtins (); -} - -#undef DEFINE_MATH_BUILTIN_C -#undef DEFINE_MATH_BUILTIN - -static void -gfc_init_ts (void) -{ - tree_contains_struct[NAMESPACE_DECL][TS_DECL_NON_COMMON] = 1; - tree_contains_struct[NAMESPACE_DECL][TS_DECL_WITH_VIS] = 1; - tree_contains_struct[NAMESPACE_DECL][TS_DECL_WRTL] = 1; - tree_contains_struct[NAMESPACE_DECL][TS_DECL_COMMON] = 1; - tree_contains_struct[NAMESPACE_DECL][TS_DECL_MINIMAL] = 1; -} - -void -gfc_maybe_initialize_eh (void) -{ - if (!flag_exceptions || gfc_eh_initialized_p) - return; - - gfc_eh_initialized_p = true; - using_eh_for_cleanups (); -} - - -#include "gt-fortran-f95-lang.h" -#include "gtype-fortran.h" diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc new file mode 100644 index 0000000..1c2fe05 --- /dev/null +++ b/gcc/fortran/f95-lang.cc @@ -0,0 +1,1306 @@ +/* gfortran backend interface + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Paul Brook. + +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 +. */ + +/* f95-lang.c-- GCC backend interface stuff */ + +/* declare required prototypes: */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "target.h" +#include "function.h" +#include "tree.h" +#include "gfortran.h" +#include "trans.h" +#include "stringpool.h" +#include "diagnostic.h" /* For errorcount/warningcount */ +#include "langhooks.h" +#include "langhooks-def.h" +#include "toplev.h" +#include "debug.h" +#include "cpp.h" +#include "trans-types.h" +#include "trans-const.h" + +/* Language-dependent contents of an identifier. */ + +struct GTY(()) +lang_identifier { + struct tree_identifier common; +}; + +/* The resulting tree type. */ + +union GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), + chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN (&%h.generic)) : NULL"))) +lang_tree_node { + union tree_node GTY((tag ("0"), + desc ("tree_node_structure (&%h)"))) generic; + struct lang_identifier GTY((tag ("1"))) identifier; +}; + +/* Save and restore the variables in this file and elsewhere + that keep track of the progress of compilation of the current function. + Used for nested functions. */ + +struct GTY(()) +language_function { + /* struct gfc_language_function base; */ + struct binding_level *binding_level; +}; + +static void gfc_init_decl_processing (void); +static void gfc_init_builtin_functions (void); +static bool global_bindings_p (void); + +/* Each front end provides its own. */ +static bool gfc_init (void); +static void gfc_finish (void); +static void gfc_be_parse_file (void); +static void gfc_init_ts (void); +static tree gfc_builtin_function (tree); + +/* Handle an "omp declare target" attribute; arguments as in + struct attribute_spec.handler. */ +static tree +gfc_handle_omp_declare_target_attribute (tree *, tree, tree, int, bool *) +{ + return NULL_TREE; +} + +/* Table of valid Fortran attributes. */ +static const struct attribute_spec gfc_attribute_table[] = +{ + /* { name, min_len, max_len, decl_req, type_req, fn_type_req, + affects_type_identity, handler, exclude } */ + { "omp declare target", 0, -1, true, false, false, false, + gfc_handle_omp_declare_target_attribute, NULL }, + { "omp declare target link", 0, 0, true, false, false, false, + gfc_handle_omp_declare_target_attribute, NULL }, + { "oacc function", 0, -1, true, false, false, false, + gfc_handle_omp_declare_target_attribute, NULL }, + { NULL, 0, 0, false, false, false, false, NULL, NULL } +}; + +#undef LANG_HOOKS_NAME +#undef LANG_HOOKS_INIT +#undef LANG_HOOKS_FINISH +#undef LANG_HOOKS_OPTION_LANG_MASK +#undef LANG_HOOKS_INIT_OPTIONS_STRUCT +#undef LANG_HOOKS_INIT_OPTIONS +#undef LANG_HOOKS_HANDLE_OPTION +#undef LANG_HOOKS_POST_OPTIONS +#undef LANG_HOOKS_PARSE_FILE +#undef LANG_HOOKS_MARK_ADDRESSABLE +#undef LANG_HOOKS_TYPE_FOR_MODE +#undef LANG_HOOKS_TYPE_FOR_SIZE +#undef LANG_HOOKS_INIT_TS +#undef LANG_HOOKS_OMP_ARRAY_DATA +#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR +#undef LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT +#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE +#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING +#undef LANG_HOOKS_OMP_PREDETERMINED_MAPPING +#undef LANG_HOOKS_OMP_REPORT_DECL +#undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR +#undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR +#undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP +#undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR +#undef LANG_HOOKS_OMP_CLAUSE_DTOR +#undef LANG_HOOKS_OMP_FINISH_CLAUSE +#undef LANG_HOOKS_OMP_ALLOCATABLE_P +#undef LANG_HOOKS_OMP_SCALAR_TARGET_P +#undef LANG_HOOKS_OMP_SCALAR_P +#undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR +#undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE +#undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF +#undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES +#undef LANG_HOOKS_BUILTIN_FUNCTION +#undef LANG_HOOKS_BUILTIN_FUNCTION +#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO +#undef LANG_HOOKS_ATTRIBUTE_TABLE + +/* Define lang hooks. */ +#define LANG_HOOKS_NAME "GNU Fortran" +#define LANG_HOOKS_INIT gfc_init +#define LANG_HOOKS_FINISH gfc_finish +#define LANG_HOOKS_OPTION_LANG_MASK gfc_option_lang_mask +#define LANG_HOOKS_INIT_OPTIONS_STRUCT gfc_init_options_struct +#define LANG_HOOKS_INIT_OPTIONS gfc_init_options +#define LANG_HOOKS_HANDLE_OPTION gfc_handle_option +#define LANG_HOOKS_POST_OPTIONS gfc_post_options +#define LANG_HOOKS_PARSE_FILE gfc_be_parse_file +#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode +#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size +#define LANG_HOOKS_INIT_TS gfc_init_ts +#define LANG_HOOKS_OMP_ARRAY_DATA gfc_omp_array_data +#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr +#define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT gfc_omp_check_optional_argument +#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference +#define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing +#define LANG_HOOKS_OMP_PREDETERMINED_MAPPING gfc_omp_predetermined_mapping +#define LANG_HOOKS_OMP_REPORT_DECL gfc_omp_report_decl +#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor +#define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor +#define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP gfc_omp_clause_assign_op +#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor +#define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor +#define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause +#define LANG_HOOKS_OMP_ALLOCATABLE_P gfc_omp_allocatable_p +#define LANG_HOOKS_OMP_SCALAR_P gfc_omp_scalar_p +#define LANG_HOOKS_OMP_SCALAR_TARGET_P gfc_omp_scalar_target_p +#define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr +#define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause +#define LANG_HOOKS_OMP_PRIVATE_OUTER_REF gfc_omp_private_outer_ref +#define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \ + gfc_omp_firstprivatize_type_sizes +#define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function +#define LANG_HOOKS_GET_ARRAY_DESCR_INFO gfc_get_array_descr_info +#define LANG_HOOKS_ATTRIBUTE_TABLE gfc_attribute_table + +struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; + +#define NULL_BINDING_LEVEL (struct binding_level *) NULL + +/* A chain of binding_level structures awaiting reuse. */ + +static GTY(()) struct binding_level *free_binding_level; + +/* True means we've initialized exception handling. */ +static bool gfc_eh_initialized_p; + +/* The current translation unit. */ +static GTY(()) tree current_translation_unit; + + +static void +gfc_create_decls (void) +{ + /* GCC builtins. */ + gfc_init_builtin_functions (); + + /* Runtime/IO library functions. */ + gfc_build_builtin_function_decls (); + + gfc_init_constants (); + + /* Build our translation-unit decl. */ + current_translation_unit + = build_translation_unit_decl (get_identifier (main_input_filename)); + debug_hooks->register_main_translation_unit (current_translation_unit); +} + + +static void +gfc_be_parse_file (void) +{ + gfc_create_decls (); + gfc_parse_file (); + gfc_generate_constructors (); + + /* Clear the binding level stack. */ + while (!global_bindings_p ()) + poplevel (0, 0); + + /* Finalize all of the globals. + + Emulated tls lowering needs to see all TLS variables before we + call finalize_compilation_unit. The C/C++ front ends manage this + by calling decl_rest_of_compilation on each global and static + variable as they are seen. The Fortran front end waits until + here. */ + for (tree decl = getdecls (); decl ; decl = DECL_CHAIN (decl)) + rest_of_decl_compilation (decl, true, true); + + /* Switch to the default tree diagnostics here, because there may be + diagnostics before gfc_finish(). */ + gfc_diagnostics_finish (); + + global_decl_processing (); +} + + +/* Initialize everything. */ + +static bool +gfc_init (void) +{ + if (!gfc_cpp_enabled ()) + { + linemap_add (line_table, LC_ENTER, false, gfc_source_file, 1); + linemap_add (line_table, LC_RENAME, false, "", 0); + } + else + gfc_cpp_init_0 (); + + gfc_init_decl_processing (); + gfc_static_ctors = NULL_TREE; + + if (gfc_cpp_enabled ()) + gfc_cpp_init (); + + gfc_init_1 (); + + /* Calls exit in case of a fail. */ + gfc_new_file (); + + if (flag_preprocess_only) + return false; + + return true; +} + + +static void +gfc_finish (void) +{ + gfc_cpp_done (); + gfc_done_1 (); + gfc_release_include_path (); + return; +} + +/* These functions and variables deal with binding contours. We only + need these functions for the list of PARM_DECLs, but we leave the + functions more general; these are a simplified version of the + functions from GNAT. */ + +/* For each binding contour we allocate a binding_level structure which + records the entities defined or declared in that contour. Contours + include: + + the global one + one for each subprogram definition + one for each compound statement (declare block) + + Binding contours are used to create GCC tree BLOCK nodes. */ + +struct GTY(()) +binding_level { + /* A chain of ..._DECL nodes for all variables, constants, functions, + parameters and type declarations. These ..._DECL nodes are chained + through the DECL_CHAIN field. */ + tree names; + /* For each level (except the global one), a chain of BLOCK nodes for all + the levels that were entered and exited one level down from this one. */ + tree blocks; + /* The binding level containing this one (the enclosing binding level). */ + struct binding_level *level_chain; + /* True if nreverse has been already called on names; if false, names + are ordered from newest declaration to oldest one. */ + bool reversed; +}; + +/* The binding level currently in effect. */ +static GTY(()) struct binding_level *current_binding_level = NULL; + +/* The outermost binding level. This binding level is created when the + compiler is started and it will exist through the entire compilation. */ +static GTY(()) struct binding_level *global_binding_level; + +/* Binding level structures are initialized by copying this one. */ +static struct binding_level clear_binding_level = { NULL, NULL, NULL, false }; + + +/* Return true if we are in the global binding level. */ + +bool +global_bindings_p (void) +{ + return current_binding_level == global_binding_level; +} + +tree +getdecls (void) +{ + if (!current_binding_level->reversed) + { + current_binding_level->reversed = true; + current_binding_level->names = nreverse (current_binding_level->names); + } + return current_binding_level->names; +} + +/* Enter a new binding level. */ + +void +pushlevel (void) +{ + struct binding_level *newlevel = ggc_alloc (); + + *newlevel = clear_binding_level; + + /* Add this level to the front of the chain (stack) of levels that are + active. */ + newlevel->level_chain = current_binding_level; + current_binding_level = newlevel; +} + +/* Exit a binding level. + Pop the level off, and restore the state of the identifier-decl mappings + that were in effect when this level was entered. + + If KEEP is nonzero, this level had explicit declarations, so + and create a "block" (a BLOCK node) for the level + to record its declarations and subblocks for symbol table output. + + If FUNCTIONBODY is nonzero, this level is the body of a function, + so create a block as if KEEP were set and also clear out all + label names. */ + +tree +poplevel (int keep, int functionbody) +{ + /* Points to a BLOCK tree node. This is the BLOCK node constructed for the + binding level that we are about to exit and which is returned by this + routine. */ + tree block_node = NULL_TREE; + tree decl_chain = getdecls (); + tree subblock_chain = current_binding_level->blocks; + tree subblock_node; + + /* If there were any declarations in the current binding level, or if this + binding level is a function body, or if there are any nested blocks then + create a BLOCK node to record them for the life of this function. */ + if (keep || functionbody) + block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0); + + /* Record the BLOCK node just built as the subblock its enclosing scope. */ + for (subblock_node = subblock_chain; subblock_node; + subblock_node = BLOCK_CHAIN (subblock_node)) + BLOCK_SUPERCONTEXT (subblock_node) = block_node; + + /* Clear out the meanings of the local variables of this level. */ + + for (subblock_node = decl_chain; subblock_node; + subblock_node = DECL_CHAIN (subblock_node)) + if (DECL_NAME (subblock_node) != 0) + /* If the identifier was used or addressed via a local extern decl, + don't forget that fact. */ + if (DECL_EXTERNAL (subblock_node)) + { + if (TREE_USED (subblock_node)) + TREE_USED (DECL_NAME (subblock_node)) = 1; + if (TREE_ADDRESSABLE (subblock_node)) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1; + } + + /* Pop the current level. */ + current_binding_level = current_binding_level->level_chain; + + if (functionbody) + /* This is the top level block of a function. */ + DECL_INITIAL (current_function_decl) = block_node; + else if (current_binding_level == global_binding_level) + /* When using gfc_start_block/gfc_finish_block from middle-end hooks, + don't add newly created BLOCKs as subblocks of global_binding_level. */ + ; + else if (block_node) + { + current_binding_level->blocks + = block_chainon (current_binding_level->blocks, block_node); + } + + /* If we did not make a block for the level just exited, any blocks made for + inner levels (since they cannot be recorded as subblocks in that level) + must be carried forward so they will later become subblocks of something + else. */ + else if (subblock_chain) + current_binding_level->blocks + = block_chainon (current_binding_level->blocks, subblock_chain); + if (block_node) + TREE_USED (block_node) = 1; + + return block_node; +} + + +/* Records a ..._DECL node DECL as belonging to the current lexical scope. + Returns the ..._DECL node. */ + +tree +pushdecl (tree decl) +{ + if (global_bindings_p ()) + DECL_CONTEXT (decl) = current_translation_unit; + else + { + /* External objects aren't nested. For debug info insert a copy + of the decl into the binding level. */ + if (DECL_EXTERNAL (decl)) + { + tree orig = decl; + decl = copy_node (decl); + DECL_CONTEXT (orig) = NULL_TREE; + } + DECL_CONTEXT (decl) = current_function_decl; + } + + /* Put the declaration on the list. */ + DECL_CHAIN (decl) = current_binding_level->names; + current_binding_level->names = decl; + + /* For the declaration of a type, set its name if it is not already set. */ + + if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0) + { + if (DECL_SOURCE_LINE (decl) == 0) + TYPE_NAME (TREE_TYPE (decl)) = decl; + else + TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl); + } + + return decl; +} + + +/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL. */ + +tree +pushdecl_top_level (tree x) +{ + tree t; + struct binding_level *b = current_binding_level; + + current_binding_level = global_binding_level; + t = pushdecl (x); + current_binding_level = b; + return t; +} + +#ifndef CHAR_TYPE_SIZE +#define CHAR_TYPE_SIZE BITS_PER_UNIT +#endif + +#ifndef INT_TYPE_SIZE +#define INT_TYPE_SIZE BITS_PER_WORD +#endif + +#undef SIZE_TYPE +#define SIZE_TYPE "long unsigned int" + +/* Create tree nodes for the basic scalar types of Fortran 95, + and some nodes representing standard constants (0, 1, (void *) 0). + Initialize the global binding level. + Make definitions for built-in primitive functions. */ +static void +gfc_init_decl_processing (void) +{ + current_function_decl = NULL; + current_binding_level = NULL_BINDING_LEVEL; + free_binding_level = NULL_BINDING_LEVEL; + + /* Make the binding_level structure for global names. We move all + variables that are in a COMMON block to this binding level. */ + pushlevel (); + global_binding_level = current_binding_level; + + /* Build common tree nodes. char_type_node is unsigned because we + only use it for actual characters, not for INTEGER(1). */ + build_common_tree_nodes (false); + + void_list_node = build_tree_list (NULL_TREE, void_type_node); + + /* Set up F95 type nodes. */ + gfc_init_kinds (); + gfc_init_types (); + gfc_init_c_interop_kinds (); +} + + +/* Builtin function initialization. */ + +static tree +gfc_builtin_function (tree decl) +{ + pushdecl (decl); + return decl; +} + +/* So far we need just these 10 attribute types. */ +#define ATTR_NULL 0 +#define ATTR_LEAF_LIST (ECF_LEAF) +#define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF) +#define ATTR_NOTHROW_LEAF_MALLOC_LIST (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC) +#define ATTR_CONST_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_CONST) +#define ATTR_PURE_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF | ECF_PURE) +#define ATTR_NOTHROW_LIST (ECF_NOTHROW) +#define ATTR_CONST_NOTHROW_LIST (ECF_NOTHROW | ECF_CONST) +#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST \ + (ECF_NOTHROW) +#define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ + (ECF_COLD | ECF_NORETURN | \ + ECF_NOTHROW | ECF_LEAF) + +static void +gfc_define_builtin (const char *name, tree type, enum built_in_function code, + const char *library_name, int attr) +{ + tree decl; + + decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL, + library_name, NULL_TREE); + set_call_expr_flags (decl, attr); + + set_builtin_decl (code, decl, true); +} + + +#define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \ + gfc_define_builtin ("__builtin_" name "l", tbase##longdouble[argtype], \ + BUILT_IN_ ## code ## L, name "l", \ + ATTR_CONST_NOTHROW_LEAF_LIST); \ + gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \ + BUILT_IN_ ## code, name, \ + ATTR_CONST_NOTHROW_LEAF_LIST); \ + gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \ + BUILT_IN_ ## code ## F, name "f", \ + ATTR_CONST_NOTHROW_LEAF_LIST); + +#define DEFINE_MATH_BUILTIN(code, name, argtype) \ + DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) + +#define DEFINE_MATH_BUILTIN_C(code, name, argtype) \ + DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_) \ + DO_DEFINE_MATH_BUILTIN (C##code, "c" name, argtype, mfunc_c) + + +/* Create function types for builtin functions. */ + +static void +build_builtin_fntypes (tree *fntype, tree type) +{ + /* type (*) (type) */ + fntype[0] = build_function_type_list (type, type, NULL_TREE); + /* type (*) (type, type) */ + fntype[1] = build_function_type_list (type, type, type, NULL_TREE); + /* type (*) (type, int) */ + fntype[2] = build_function_type_list (type, + type, integer_type_node, NULL_TREE); + /* type (*) (void) */ + fntype[3] = build_function_type_list (type, NULL_TREE); + /* type (*) (type, &int) */ + fntype[4] = build_function_type_list (type, type, + build_pointer_type (integer_type_node), + NULL_TREE); + /* type (*) (int, type) */ + fntype[5] = build_function_type_list (type, + integer_type_node, type, NULL_TREE); +} + + +static tree +builtin_type_for_size (int size, bool unsignedp) +{ + tree type = gfc_type_for_size (size, unsignedp); + return type ? type : error_mark_node; +} + +/* Initialization of builtin function nodes. */ + +static void +gfc_init_builtin_functions (void) +{ + enum builtin_type + { +#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, +#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, +#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, +#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, +#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, +#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, +#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, +#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) NAME, +#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) NAME, +#define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8) NAME, +#define DEF_FUNCTION_TYPE_9(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9) NAME, +#define DEF_FUNCTION_TYPE_10(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9, ARG10) NAME, +#define DEF_FUNCTION_TYPE_11(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) NAME, +#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, +#define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, +#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, +#define DEF_FUNCTION_TYPE_VAR_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) NAME, +#define DEF_FUNCTION_TYPE_VAR_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) NAME, +#define DEF_POINTER_TYPE(NAME, TYPE) NAME, +#include "types.def" +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_0 +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_7 +#undef DEF_FUNCTION_TYPE_8 +#undef DEF_FUNCTION_TYPE_9 +#undef DEF_FUNCTION_TYPE_10 +#undef DEF_FUNCTION_TYPE_11 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_FUNCTION_TYPE_VAR_1 +#undef DEF_FUNCTION_TYPE_VAR_2 +#undef DEF_FUNCTION_TYPE_VAR_6 +#undef DEF_FUNCTION_TYPE_VAR_7 +#undef DEF_POINTER_TYPE + BT_LAST + }; + + tree mfunc_float[6]; + tree mfunc_double[6]; + tree mfunc_longdouble[6]; + tree mfunc_cfloat[6]; + tree mfunc_cdouble[6]; + tree mfunc_clongdouble[6]; + tree func_cfloat_float, func_float_cfloat; + tree func_cdouble_double, func_double_cdouble; + tree func_clongdouble_longdouble, func_longdouble_clongdouble; + tree func_float_floatp_floatp; + tree func_double_doublep_doublep; + tree func_longdouble_longdoublep_longdoublep; + tree ftype, ptype; + tree builtin_types[(int) BT_LAST + 1]; + + int attr; + + build_builtin_fntypes (mfunc_float, float_type_node); + build_builtin_fntypes (mfunc_double, double_type_node); + build_builtin_fntypes (mfunc_longdouble, long_double_type_node); + build_builtin_fntypes (mfunc_cfloat, complex_float_type_node); + build_builtin_fntypes (mfunc_cdouble, complex_double_type_node); + build_builtin_fntypes (mfunc_clongdouble, complex_long_double_type_node); + + func_cfloat_float = build_function_type_list (float_type_node, + complex_float_type_node, + NULL_TREE); + + func_float_cfloat = build_function_type_list (complex_float_type_node, + float_type_node, NULL_TREE); + + func_cdouble_double = build_function_type_list (double_type_node, + complex_double_type_node, + NULL_TREE); + + func_double_cdouble = build_function_type_list (complex_double_type_node, + double_type_node, NULL_TREE); + + func_clongdouble_longdouble = + build_function_type_list (long_double_type_node, + complex_long_double_type_node, NULL_TREE); + + func_longdouble_clongdouble = + build_function_type_list (complex_long_double_type_node, + long_double_type_node, NULL_TREE); + + ptype = build_pointer_type (float_type_node); + func_float_floatp_floatp = + build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); + + ptype = build_pointer_type (double_type_node); + func_double_doublep_doublep = + build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); + + ptype = build_pointer_type (long_double_type_node); + func_longdouble_longdoublep_longdoublep = + build_function_type_list (void_type_node, ptype, ptype, NULL_TREE); + +/* Non-math builtins are defined manually, so they're not included here. */ +#define OTHER_BUILTIN(ID,NAME,TYPE,CONST) + +#include "mathbuiltins.def" + + gfc_define_builtin ("__builtin_roundl", mfunc_longdouble[0], + BUILT_IN_ROUNDL, "roundl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_round", mfunc_double[0], + BUILT_IN_ROUND, "round", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_roundf", mfunc_float[0], + BUILT_IN_ROUNDF, "roundf", ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_truncl", mfunc_longdouble[0], + BUILT_IN_TRUNCL, "truncl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_trunc", mfunc_double[0], + BUILT_IN_TRUNC, "trunc", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_truncf", mfunc_float[0], + BUILT_IN_TRUNCF, "truncf", ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_cabsl", func_clongdouble_longdouble, + BUILT_IN_CABSL, "cabsl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cabs", func_cdouble_double, + BUILT_IN_CABS, "cabs", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cabsf", func_cfloat_float, + BUILT_IN_CABSF, "cabsf", ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_copysignl", mfunc_longdouble[1], + BUILT_IN_COPYSIGNL, "copysignl", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_copysign", mfunc_double[1], + BUILT_IN_COPYSIGN, "copysign", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_copysignf", mfunc_float[1], + BUILT_IN_COPYSIGNF, "copysignf", + ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_nextafterl", mfunc_longdouble[1], + BUILT_IN_NEXTAFTERL, "nextafterl", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_nextafter", mfunc_double[1], + BUILT_IN_NEXTAFTER, "nextafter", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_nextafterf", mfunc_float[1], + BUILT_IN_NEXTAFTERF, "nextafterf", + ATTR_CONST_NOTHROW_LEAF_LIST); + + /* Some built-ins depend on rounding mode. Depending on compilation options, they + will be "pure" or "const". */ + attr = flag_rounding_math ? ATTR_PURE_NOTHROW_LEAF_LIST : ATTR_CONST_NOTHROW_LEAF_LIST; + + gfc_define_builtin ("__builtin_rintl", mfunc_longdouble[0], + BUILT_IN_RINTL, "rintl", attr); + gfc_define_builtin ("__builtin_rint", mfunc_double[0], + BUILT_IN_RINT, "rint", attr); + gfc_define_builtin ("__builtin_rintf", mfunc_float[0], + BUILT_IN_RINTF, "rintf", attr); + + gfc_define_builtin ("__builtin_remainderl", mfunc_longdouble[1], + BUILT_IN_REMAINDERL, "remainderl", attr); + gfc_define_builtin ("__builtin_remainder", mfunc_double[1], + BUILT_IN_REMAINDER, "remainder", attr); + gfc_define_builtin ("__builtin_remainderf", mfunc_float[1], + BUILT_IN_REMAINDERF, "remainderf", attr); + + gfc_define_builtin ("__builtin_logbl", mfunc_longdouble[0], + BUILT_IN_LOGBL, "logbl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_logb", mfunc_double[0], + BUILT_IN_LOGB, "logb", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_logbf", mfunc_float[0], + BUILT_IN_LOGBF, "logbf", ATTR_CONST_NOTHROW_LEAF_LIST); + + + gfc_define_builtin ("__builtin_frexpl", mfunc_longdouble[4], + BUILT_IN_FREXPL, "frexpl", ATTR_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_frexp", mfunc_double[4], + BUILT_IN_FREXP, "frexp", ATTR_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_frexpf", mfunc_float[4], + BUILT_IN_FREXPF, "frexpf", ATTR_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_fabsl", mfunc_longdouble[0], + BUILT_IN_FABSL, "fabsl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fabs", mfunc_double[0], + BUILT_IN_FABS, "fabs", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fabsf", mfunc_float[0], + BUILT_IN_FABSF, "fabsf", ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_scalbnl", mfunc_longdouble[2], + BUILT_IN_SCALBNL, "scalbnl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_scalbn", mfunc_double[2], + BUILT_IN_SCALBN, "scalbn", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_scalbnf", mfunc_float[2], + BUILT_IN_SCALBNF, "scalbnf", ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1], + BUILT_IN_FMODL, "fmodl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fmod", mfunc_double[1], + BUILT_IN_FMOD, "fmod", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fmodf", mfunc_float[1], + BUILT_IN_FMODF, "fmodf", ATTR_CONST_NOTHROW_LEAF_LIST); + + /* iround{f,,l}, lround{f,,l} and llround{f,,l} */ + ftype = build_function_type_list (integer_type_node, + float_type_node, NULL_TREE); + gfc_define_builtin("__builtin_iroundf", ftype, BUILT_IN_IROUNDF, + "iroundf", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (long_integer_type_node, + float_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_lroundf", ftype, BUILT_IN_LROUNDF, + "lroundf", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (long_long_integer_type_node, + float_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_llroundf", ftype, BUILT_IN_LLROUNDF, + "llroundf", ATTR_CONST_NOTHROW_LEAF_LIST); + + ftype = build_function_type_list (integer_type_node, + double_type_node, NULL_TREE); + gfc_define_builtin("__builtin_iround", ftype, BUILT_IN_IROUND, + "iround", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (long_integer_type_node, + double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_lround", ftype, BUILT_IN_LROUND, + "lround", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (long_long_integer_type_node, + double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_llround", ftype, BUILT_IN_LLROUND, + "llround", ATTR_CONST_NOTHROW_LEAF_LIST); + + ftype = build_function_type_list (integer_type_node, + long_double_type_node, NULL_TREE); + gfc_define_builtin("__builtin_iroundl", ftype, BUILT_IN_IROUNDL, + "iroundl", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (long_integer_type_node, + long_double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_lroundl", ftype, BUILT_IN_LROUNDL, + "lroundl", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (long_long_integer_type_node, + long_double_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_llroundl", ftype, BUILT_IN_LLROUNDL, + "llroundl", ATTR_CONST_NOTHROW_LEAF_LIST); + + /* These are used to implement the ** operator. */ + gfc_define_builtin ("__builtin_powl", mfunc_longdouble[1], + BUILT_IN_POWL, "powl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_pow", mfunc_double[1], + BUILT_IN_POW, "pow", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_powf", mfunc_float[1], + BUILT_IN_POWF, "powf", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cpowl", mfunc_clongdouble[1], + BUILT_IN_CPOWL, "cpowl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cpow", mfunc_cdouble[1], + BUILT_IN_CPOW, "cpow", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cpowf", mfunc_cfloat[1], + BUILT_IN_CPOWF, "cpowf", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_powil", mfunc_longdouble[2], + BUILT_IN_POWIL, "powil", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_powi", mfunc_double[2], + BUILT_IN_POWI, "powi", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_powif", mfunc_float[2], + BUILT_IN_POWIF, "powif", ATTR_CONST_NOTHROW_LEAF_LIST); + + + if (targetm.libc_has_function (function_c99_math_complex, NULL_TREE)) + { + gfc_define_builtin ("__builtin_cbrtl", mfunc_longdouble[0], + BUILT_IN_CBRTL, "cbrtl", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cbrt", mfunc_double[0], + BUILT_IN_CBRT, "cbrt", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cbrtf", mfunc_float[0], + BUILT_IN_CBRTF, "cbrtf", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cexpil", func_longdouble_clongdouble, + BUILT_IN_CEXPIL, "cexpil", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cexpi", func_double_cdouble, + BUILT_IN_CEXPI, "cexpi", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_cexpif", func_float_cfloat, + BUILT_IN_CEXPIF, "cexpif", + ATTR_CONST_NOTHROW_LEAF_LIST); + } + + if (targetm.libc_has_function (function_sincos, NULL_TREE)) + { + gfc_define_builtin ("__builtin_sincosl", + func_longdouble_longdoublep_longdoublep, + BUILT_IN_SINCOSL, "sincosl", ATTR_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_sincos", func_double_doublep_doublep, + BUILT_IN_SINCOS, "sincos", ATTR_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_sincosf", func_float_floatp_floatp, + BUILT_IN_SINCOSF, "sincosf", ATTR_NOTHROW_LEAF_LIST); + } + + /* For LEADZ, TRAILZ, POPCNT and POPPAR. */ + ftype = build_function_type_list (integer_type_node, + unsigned_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, + "__builtin_clz", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ, + "__builtin_ctz", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_parity", ftype, BUILT_IN_PARITY, + "__builtin_parity", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_popcount", ftype, BUILT_IN_POPCOUNT, + "__builtin_popcount", ATTR_CONST_NOTHROW_LEAF_LIST); + + ftype = build_function_type_list (integer_type_node, + long_unsigned_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, + "__builtin_clzl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL, + "__builtin_ctzl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_parityl", ftype, BUILT_IN_PARITYL, + "__builtin_parityl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_popcountl", ftype, BUILT_IN_POPCOUNTL, + "__builtin_popcountl", ATTR_CONST_NOTHROW_LEAF_LIST); + + ftype = build_function_type_list (integer_type_node, + long_long_unsigned_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, + "__builtin_clzll", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL, + "__builtin_ctzll", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_parityll", ftype, BUILT_IN_PARITYLL, + "__builtin_parityll", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_popcountll", ftype, BUILT_IN_POPCOUNTLL, + "__builtin_popcountll", ATTR_CONST_NOTHROW_LEAF_LIST); + + /* Other builtin functions we use. */ + + ftype = build_function_type_list (long_integer_type_node, + long_integer_type_node, + long_integer_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, + "__builtin_expect", ATTR_CONST_NOTHROW_LEAF_LIST); + + ftype = build_function_type_list (void_type_node, + pvoid_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_free", ftype, BUILT_IN_FREE, + "free", ATTR_NOTHROW_LEAF_LIST); + + ftype = build_function_type_list (pvoid_type_node, + size_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_malloc", ftype, BUILT_IN_MALLOC, + "malloc", ATTR_NOTHROW_LEAF_MALLOC_LIST); + + ftype = build_function_type_list (pvoid_type_node, size_type_node, + size_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_calloc", ftype, BUILT_IN_CALLOC, + "calloc", ATTR_NOTHROW_LEAF_MALLOC_LIST); + DECL_IS_MALLOC (builtin_decl_explicit (BUILT_IN_CALLOC)) = 1; + + ftype = build_function_type_list (pvoid_type_node, + size_type_node, pvoid_type_node, + NULL_TREE); + gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC, + "realloc", ATTR_NOTHROW_LEAF_LIST); + + /* Type-generic floating-point classification built-ins. */ + + ftype = build_function_type (integer_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_isfinite", ftype, BUILT_IN_ISFINITE, + "__builtin_isfinite", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_isinf", ftype, BUILT_IN_ISINF, + "__builtin_isinf", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_isinf_sign", ftype, BUILT_IN_ISINF_SIGN, + "__builtin_isinf_sign", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN, + "__builtin_isnan", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_isnormal", ftype, BUILT_IN_ISNORMAL, + "__builtin_isnormal", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_signbit", ftype, BUILT_IN_SIGNBIT, + "__builtin_signbit", ATTR_CONST_NOTHROW_LEAF_LIST); + + ftype = build_function_type (integer_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_isless", ftype, BUILT_IN_ISLESS, + "__builtin_isless", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_islessequal", ftype, BUILT_IN_ISLESSEQUAL, + "__builtin_islessequal", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_islessgreater", ftype, BUILT_IN_ISLESSGREATER, + "__builtin_islessgreater", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_isgreater", ftype, BUILT_IN_ISGREATER, + "__builtin_isgreater", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_isgreaterequal", ftype, + BUILT_IN_ISGREATEREQUAL, "__builtin_isgreaterequal", + ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_isunordered", ftype, BUILT_IN_ISUNORDERED, + "__builtin_isunordered", ATTR_CONST_NOTHROW_LEAF_LIST); + + +#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ + builtin_types[(int) ENUM] = VALUE; +#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + builtin_types[(int) ARG7], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + builtin_types[(int) ARG7], \ + builtin_types[(int) ARG8], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_9(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7, ARG8, ARG9) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + builtin_types[(int) ARG7], \ + builtin_types[(int) ARG8], \ + builtin_types[(int) ARG9], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_10(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, \ + ARG5, ARG6, ARG7, ARG8, ARG9, ARG10) \ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + builtin_types[(int) ARG7], \ + builtin_types[(int) ARG8], \ + builtin_types[(int) ARG9], \ + builtin_types[(int) ARG10], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_11(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, \ + ARG5, ARG6, ARG7, ARG8, ARG9, ARG10, ARG11)\ + builtin_types[(int) ENUM] \ + = build_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + builtin_types[(int) ARG7], \ + builtin_types[(int) ARG8], \ + builtin_types[(int) ARG9], \ + builtin_types[(int) ARG10], \ + builtin_types[(int) ARG11], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ + builtin_types[(int) ENUM] \ + = build_varargs_function_type_list (builtin_types[(int) RETURN], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ + builtin_types[(int) ENUM] \ + = build_varargs_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \ + builtin_types[(int) ENUM] \ + = build_varargs_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_VAR_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6) \ + builtin_types[(int) ENUM] \ + = build_varargs_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + NULL_TREE); +#define DEF_FUNCTION_TYPE_VAR_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ + ARG6, ARG7) \ + builtin_types[(int) ENUM] \ + = build_varargs_function_type_list (builtin_types[(int) RETURN], \ + builtin_types[(int) ARG1], \ + builtin_types[(int) ARG2], \ + builtin_types[(int) ARG3], \ + builtin_types[(int) ARG4], \ + builtin_types[(int) ARG5], \ + builtin_types[(int) ARG6], \ + builtin_types[(int) ARG7], \ + NULL_TREE); +#define DEF_POINTER_TYPE(ENUM, TYPE) \ + builtin_types[(int) ENUM] \ + = build_pointer_type (builtin_types[(int) TYPE]); +#include "types.def" +#undef DEF_PRIMITIVE_TYPE +#undef DEF_FUNCTION_TYPE_0 +#undef DEF_FUNCTION_TYPE_1 +#undef DEF_FUNCTION_TYPE_2 +#undef DEF_FUNCTION_TYPE_3 +#undef DEF_FUNCTION_TYPE_4 +#undef DEF_FUNCTION_TYPE_5 +#undef DEF_FUNCTION_TYPE_6 +#undef DEF_FUNCTION_TYPE_7 +#undef DEF_FUNCTION_TYPE_8 +#undef DEF_FUNCTION_TYPE_10 +#undef DEF_FUNCTION_TYPE_VAR_0 +#undef DEF_FUNCTION_TYPE_VAR_1 +#undef DEF_FUNCTION_TYPE_VAR_2 +#undef DEF_FUNCTION_TYPE_VAR_6 +#undef DEF_FUNCTION_TYPE_VAR_7 +#undef DEF_POINTER_TYPE + builtin_types[(int) BT_LAST] = NULL_TREE; + + /* Initialize synchronization builtins. */ +#undef DEF_SYNC_BUILTIN +#define DEF_SYNC_BUILTIN(code, name, type, attr) \ + gfc_define_builtin (name, builtin_types[type], code, name, \ + attr); +#include "../sync-builtins.def" +#undef DEF_SYNC_BUILTIN + + if (flag_openacc) + { +#undef DEF_GOACC_BUILTIN +#define DEF_GOACC_BUILTIN(code, name, type, attr) \ + gfc_define_builtin ("__builtin_" name, builtin_types[type], \ + code, name, attr); +#undef DEF_GOACC_BUILTIN_COMPILER +#define DEF_GOACC_BUILTIN_COMPILER(code, name, type, attr) \ + gfc_define_builtin (name, builtin_types[type], code, name, attr); +#undef DEF_GOACC_BUILTIN_ONLY +#define DEF_GOACC_BUILTIN_ONLY(code, name, type, attr) \ + gfc_define_builtin ("__builtin_" name, builtin_types[type], code, NULL, \ + attr); +#undef DEF_GOMP_BUILTIN +#define DEF_GOMP_BUILTIN(code, name, type, attr) /* ignore */ +#include "../omp-builtins.def" +#undef DEF_GOACC_BUILTIN +#undef DEF_GOACC_BUILTIN_COMPILER +#undef DEF_GOMP_BUILTIN + } + + if (flag_openmp || flag_openmp_simd || flag_tree_parallelize_loops) + { +#undef DEF_GOACC_BUILTIN +#define DEF_GOACC_BUILTIN(code, name, type, attr) /* ignore */ +#undef DEF_GOACC_BUILTIN_COMPILER +#define DEF_GOACC_BUILTIN_COMPILER(code, name, type, attr) /* ignore */ +#undef DEF_GOMP_BUILTIN +#define DEF_GOMP_BUILTIN(code, name, type, attr) \ + gfc_define_builtin ("__builtin_" name, builtin_types[type], \ + code, name, attr); +#include "../omp-builtins.def" +#undef DEF_GOACC_BUILTIN +#undef DEF_GOACC_BUILTIN_COMPILER +#undef DEF_GOMP_BUILTIN + tree gomp_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); + tree two = build_int_cst (integer_type_node, 2); + DECL_ATTRIBUTES (gomp_alloc) + = tree_cons (get_identifier ("warn_unused_result"), NULL_TREE, + tree_cons (get_identifier ("alloc_size"), + build_tree_list (NULL_TREE, two), + DECL_ATTRIBUTES (gomp_alloc))); + } + + gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID], + BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST); + TREE_THIS_VOLATILE (builtin_decl_explicit (BUILT_IN_TRAP)) = 1; + + ftype = build_varargs_function_type_list (ptr_type_node, const_ptr_type_node, + size_type_node, NULL_TREE); + gfc_define_builtin ("__builtin_assume_aligned", ftype, + BUILT_IN_ASSUME_ALIGNED, + "__builtin_assume_aligned", + ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__emutls_get_address", + builtin_types[BT_FN_PTR_PTR], + BUILT_IN_EMUTLS_GET_ADDRESS, + "__emutls_get_address", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__emutls_register_common", + builtin_types[BT_FN_VOID_PTR_WORD_WORD_PTR], + BUILT_IN_EMUTLS_REGISTER_COMMON, + "__emutls_register_common", ATTR_NOTHROW_LEAF_LIST); + + build_common_builtin_nodes (); + targetm.init_builtins (); +} + +#undef DEFINE_MATH_BUILTIN_C +#undef DEFINE_MATH_BUILTIN + +static void +gfc_init_ts (void) +{ + tree_contains_struct[NAMESPACE_DECL][TS_DECL_NON_COMMON] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_WITH_VIS] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_WRTL] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_COMMON] = 1; + tree_contains_struct[NAMESPACE_DECL][TS_DECL_MINIMAL] = 1; +} + +void +gfc_maybe_initialize_eh (void) +{ + if (!flag_exceptions || gfc_eh_initialized_p) + return; + + gfc_eh_initialized_p = true; + using_eh_for_cleanups (); +} + + +#include "gt-fortran-f95-lang.h" +#include "gtype-fortran.h" diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c deleted file mode 100644 index 22f1bb5..0000000 --- a/gcc/fortran/frontend-passes.c +++ /dev/null @@ -1,5951 +0,0 @@ -/* Pass manager for Fortran front end. - Copyright (C) 2010-2022 Free Software Foundation, Inc. - Contributed by Thomas König. - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "dependency.h" -#include "constructor.h" -#include "intrinsic.h" - -/* Forward declarations. */ - -static void strip_function_call (gfc_expr *); -static void optimize_namespace (gfc_namespace *); -static void optimize_assignment (gfc_code *); -static bool optimize_op (gfc_expr *); -static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op); -static bool optimize_trim (gfc_expr *); -static bool optimize_lexical_comparison (gfc_expr *); -static void optimize_minmaxloc (gfc_expr **); -static bool is_empty_string (gfc_expr *e); -static void doloop_warn (gfc_namespace *); -static int do_intent (gfc_expr **); -static int do_subscript (gfc_expr **); -static void optimize_reduction (gfc_namespace *); -static int callback_reduction (gfc_expr **, int *, void *); -static void realloc_strings (gfc_namespace *); -static gfc_expr *create_var (gfc_expr *, const char *vname=NULL); -static int matmul_to_var_expr (gfc_expr **, int *, void *); -static int matmul_to_var_code (gfc_code **, int *, void *); -static int inline_matmul_assign (gfc_code **, int *, void *); -static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, - locus *, gfc_namespace *, - char *vname=NULL); -static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *, - bool *); -static int call_external_blas (gfc_code **, int *, void *); -static int matmul_temp_args (gfc_code **, int *,void *data); -static int index_interchange (gfc_code **, int*, void *); -static bool is_fe_temp (gfc_expr *e); - -#ifdef CHECKING_P -static void check_locus (gfc_namespace *); -#endif - -/* How deep we are inside an argument list. */ - -static int count_arglist; - -/* Vector of gfc_expr ** we operate on. */ - -static vec expr_array; - -/* Pointer to the gfc_code we currently work on - to be able to insert - a block before the statement. */ - -static gfc_code **current_code; - -/* Pointer to the block to be inserted, and the statement we are - changing within the block. */ - -static gfc_code *inserted_block, **changed_statement; - -/* The namespace we are currently dealing with. */ - -static gfc_namespace *current_ns; - -/* If we are within any forall loop. */ - -static int forall_level; - -/* Keep track of whether we are within an OMP workshare. */ - -static bool in_omp_workshare; - -/* Keep track of whether we are within an OMP atomic. */ - -static bool in_omp_atomic; - -/* Keep track of whether we are within a WHERE statement. */ - -static bool in_where; - -/* Keep track of iterators for array constructors. */ - -static int iterator_level; - -/* Keep track of DO loop levels. */ - -typedef struct { - gfc_code *c; - int branch_level; - bool seen_goto; -} do_t; - -static vec doloop_list; -static int doloop_level; - -/* Keep track of if and select case levels. */ - -static int if_level; -static int select_level; - -/* Vector of gfc_expr * to keep track of DO loops. */ - -struct my_struct *evec; - -/* Keep track of association lists. */ - -static bool in_assoc_list; - -/* Counter for temporary variables. */ - -static int var_num = 1; - -/* What sort of matrix we are dealing with when inlining MATMUL. */ - -enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T }; - -/* Keep track of the number of expressions we have inserted so far - using create_var. */ - -int n_vars; - -/* Entry point - run all passes for a namespace. */ - -void -gfc_run_passes (gfc_namespace *ns) -{ - - /* Warn about dubious DO loops where the index might - change. */ - - doloop_level = 0; - if_level = 0; - select_level = 0; - doloop_warn (ns); - doloop_list.release (); - int w, e; - -#ifdef CHECKING_P - check_locus (ns); -#endif - - gfc_get_errors (&w, &e); - if (e > 0) - return; - - if (flag_frontend_optimize || flag_frontend_loop_interchange) - optimize_namespace (ns); - - if (flag_frontend_optimize) - { - optimize_reduction (ns); - if (flag_dump_fortran_optimized) - gfc_dump_parse_tree (ns, stdout); - - expr_array.release (); - } - - if (flag_realloc_lhs) - realloc_strings (ns); -} - -#ifdef CHECKING_P - -/* Callback function: Warn if there is no location information in a - statement. */ - -static int -check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - current_code = c; - if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL))) - gfc_warning_internal (0, "Inconsistent internal state: " - "No location in statement"); - - return 0; -} - - -/* Callback function: Warn if there is no location information in an - expression. */ - -static int -check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - - if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL))) - gfc_warning_internal (0, "Inconsistent internal state: " - "No location in expression near %L", - &((*current_code)->loc)); - return 0; -} - -/* Run check for missing location information. */ - -static void -check_locus (gfc_namespace *ns) -{ - gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL); - - for (ns = ns->contained; ns; ns = ns->sibling) - { - if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - check_locus (ns); - } -} - -#endif - -/* Callback for each gfc_code node invoked from check_realloc_strings. - For an allocatable LHS string which also appears as a variable on - the RHS, replace - - a = a(x:y) - - with - - tmp = a(x:y) - a = tmp - */ - -static int -realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_expr *expr1, *expr2; - gfc_code *co = *c; - gfc_expr *n; - gfc_ref *ref; - bool found_substr; - - if (co->op != EXEC_ASSIGN) - return 0; - - expr1 = co->expr1; - if (expr1->ts.type != BT_CHARACTER - || !gfc_expr_attr(expr1).allocatable - || !expr1->ts.deferred) - return 0; - - if (is_fe_temp (expr1)) - return 0; - - expr2 = gfc_discard_nops (co->expr2); - - if (expr2->expr_type == EXPR_VARIABLE) - { - found_substr = false; - for (ref = expr2->ref; ref; ref = ref->next) - { - if (ref->type == REF_SUBSTRING) - { - found_substr = true; - break; - } - } - if (!found_substr) - return 0; - } - else if (expr2->expr_type != EXPR_ARRAY - && (expr2->expr_type != EXPR_OP - || expr2->value.op.op != INTRINSIC_CONCAT)) - return 0; - - if (!gfc_check_dependency (expr1, expr2, true)) - return 0; - - /* gfc_check_dependency doesn't always pick up identical expressions. - However, eliminating the above sends the compiler into an infinite - loop on valid expressions. Without this check, the gimplifier emits - an ICE for a = a, where a is deferred character length. */ - if (!gfc_dep_compare_expr (expr1, expr2)) - return 0; - - current_code = c; - inserted_block = NULL; - changed_statement = NULL; - n = create_var (expr2, "realloc_string"); - co->expr2 = n; - return 0; -} - -/* Callback for each gfc_code node invoked through gfc_code_walker - from optimize_namespace. */ - -static int -optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - - gfc_exec_op op; - - op = (*c)->op; - - if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL - || op == EXEC_CALL_PPC) - count_arglist = 1; - else - count_arglist = 0; - - current_code = c; - inserted_block = NULL; - changed_statement = NULL; - - if (op == EXEC_ASSIGN) - optimize_assignment (*c); - return 0; -} - -/* Callback for each gfc_expr node invoked through gfc_code_walker - from optimize_namespace. */ - -static int -optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - bool function_expr; - - if ((*e)->expr_type == EXPR_FUNCTION) - { - count_arglist ++; - function_expr = true; - } - else - function_expr = false; - - if (optimize_trim (*e)) - gfc_simplify_expr (*e, 0); - - if (optimize_lexical_comparison (*e)) - gfc_simplify_expr (*e, 0); - - if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) - gfc_simplify_expr (*e, 0); - - if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym) - switch ((*e)->value.function.isym->id) - { - case GFC_ISYM_MINLOC: - case GFC_ISYM_MAXLOC: - optimize_minmaxloc (e); - break; - default: - break; - } - - if (function_expr) - count_arglist --; - - return 0; -} - -/* Auxiliary function to handle the arguments to reduction intrinsics. If the - function is a scalar, just copy it; otherwise returns the new element, the - old one can be freed. */ - -static gfc_expr * -copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn) -{ - gfc_expr *fcn, *e = c->expr; - - fcn = gfc_copy_expr (e); - if (c->iterator) - { - gfc_constructor_base newbase; - gfc_expr *new_expr; - gfc_constructor *new_c; - - newbase = NULL; - new_expr = gfc_get_expr (); - new_expr->expr_type = EXPR_ARRAY; - new_expr->ts = e->ts; - new_expr->where = e->where; - new_expr->rank = 1; - new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where)); - new_c->iterator = c->iterator; - new_expr->value.constructor = newbase; - c->iterator = NULL; - - fcn = new_expr; - } - - if (fcn->rank != 0) - { - gfc_isym_id id = fn->value.function.isym->id; - - if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) - fcn = gfc_build_intrinsic_call (current_ns, id, - fn->value.function.isym->name, - fn->where, 3, fcn, NULL, NULL); - else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL) - fcn = gfc_build_intrinsic_call (current_ns, id, - fn->value.function.isym->name, - fn->where, 2, fcn, NULL); - else - gfc_internal_error ("Illegal id in copy_walk_reduction_arg"); - - fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; - } - - return fcn; -} - -/* Callback function for optimzation of reductions to scalars. Transform ANY - ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT - correspondingly. Handly only the simple cases without MASK and DIM. */ - -static int -callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_expr *fn, *arg; - gfc_intrinsic_op op; - gfc_isym_id id; - gfc_actual_arglist *a; - gfc_actual_arglist *dim; - gfc_constructor *c; - gfc_expr *res, *new_expr; - gfc_actual_arglist *mask; - - fn = *e; - - if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION - || fn->value.function.isym == NULL) - return 0; - - id = fn->value.function.isym->id; - - if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT - && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL) - return 0; - - a = fn->value.function.actual; - - /* Don't handle MASK or DIM. */ - - dim = a->next; - - if (dim->expr != NULL) - return 0; - - if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) - { - mask = dim->next; - if ( mask->expr != NULL) - return 0; - } - - arg = a->expr; - - if (arg->expr_type != EXPR_ARRAY) - return 0; - - switch (id) - { - case GFC_ISYM_SUM: - op = INTRINSIC_PLUS; - break; - - case GFC_ISYM_PRODUCT: - op = INTRINSIC_TIMES; - break; - - case GFC_ISYM_ANY: - op = INTRINSIC_OR; - break; - - case GFC_ISYM_ALL: - op = INTRINSIC_AND; - break; - - default: - return 0; - } - - c = gfc_constructor_first (arg->value.constructor); - - /* Don't do any simplififcation if we have - - no element in the constructor or - - only have a single element in the array which contains an - iterator. */ - - if (c == NULL) - return 0; - - res = copy_walk_reduction_arg (c, fn); - - c = gfc_constructor_next (c); - while (c) - { - new_expr = gfc_get_expr (); - new_expr->ts = fn->ts; - new_expr->expr_type = EXPR_OP; - new_expr->rank = fn->rank; - new_expr->where = fn->where; - new_expr->value.op.op = op; - new_expr->value.op.op1 = res; - new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn); - res = new_expr; - c = gfc_constructor_next (c); - } - - gfc_simplify_expr (res, 0); - *e = res; - gfc_free_expr (fn); - - return 0; -} - -/* Callback function for common function elimination, called from cfe_expr_0. - Put all eligible function expressions into expr_array. */ - -static int -cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - - if ((*e)->expr_type != EXPR_FUNCTION) - return 0; - - /* We don't do character functions with unknown charlens. */ - if ((*e)->ts.type == BT_CHARACTER - && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL - || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) - return 0; - - /* We don't do function elimination within FORALL statements, it can - lead to wrong-code in certain circumstances. */ - - if (forall_level > 0) - return 0; - - /* Function elimination inside an iterator could lead to functions which - depend on iterator variables being moved outside. FIXME: We should check - if the functions do indeed depend on the iterator variable. */ - - if (iterator_level > 0) - return 0; - - /* If we don't know the shape at compile time, we create an allocatable - temporary variable to hold the intermediate result, but only if - allocation on assignment is active. */ - - if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs) - return 0; - - /* Skip the test for pure functions if -faggressive-function-elimination - is specified. */ - if ((*e)->value.function.esym) - { - /* Don't create an array temporary for elemental functions. */ - if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0) - return 0; - - /* Only eliminate potentially impure functions if the - user specifically requested it. */ - if (!flag_aggressive_function_elimination - && !(*e)->value.function.esym->attr.pure - && !(*e)->value.function.esym->attr.implicit_pure) - return 0; - } - - if ((*e)->value.function.isym) - { - /* Conversions are handled on the fly by the middle end, - transpose during trans-* stages and TRANSFER by the middle end. */ - if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION - || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER - || gfc_inline_intrinsic_function_p (*e)) - return 0; - - /* Don't create an array temporary for elemental functions, - as this would be wasteful of memory. - FIXME: Create a scalar temporary during scalarization. */ - if ((*e)->value.function.isym->elemental && (*e)->rank > 0) - return 0; - - if (!(*e)->value.function.isym->pure) - return 0; - } - - expr_array.safe_push (e); - return 0; -} - -/* Auxiliary function to check if an expression is a temporary created by - create var. */ - -static bool -is_fe_temp (gfc_expr *e) -{ - if (e->expr_type != EXPR_VARIABLE) - return false; - - return e->symtree->n.sym->attr.fe_temp; -} - -/* Determine the length of a string, if it can be evaluated as a constant - expression. Return a newly allocated gfc_expr or NULL on failure. - If the user specified a substring which is potentially longer than - the string itself, the string will be padded with spaces, which - is harmless. */ - -static gfc_expr * -constant_string_length (gfc_expr *e) -{ - - gfc_expr *length; - gfc_ref *ref; - gfc_expr *res; - mpz_t value; - - if (e->ts.u.cl) - { - length = e->ts.u.cl->length; - if (length && length->expr_type == EXPR_CONSTANT) - return gfc_copy_expr(length); - } - - /* See if there is a substring. If it has a constant length, return - that and NULL otherwise. */ - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_SUBSTRING) - { - if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value)) - { - res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, - &e->where); - - mpz_add_ui (res->value.integer, value, 1); - mpz_clear (value); - return res; - } - else - return NULL; - } - } - - /* Return length of char symbol, if constant. */ - if (e->symtree && e->symtree->n.sym->ts.u.cl - && e->symtree->n.sym->ts.u.cl->length - && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) - return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length); - - return NULL; - -} - -/* Insert a block at the current position unless it has already - been inserted; in this case use the one already there. */ - -static gfc_namespace* -insert_block () -{ - gfc_namespace *ns; - - /* If the block hasn't already been created, do so. */ - if (inserted_block == NULL) - { - inserted_block = XCNEW (gfc_code); - inserted_block->op = EXEC_BLOCK; - inserted_block->loc = (*current_code)->loc; - ns = gfc_build_block_ns (current_ns); - inserted_block->ext.block.ns = ns; - inserted_block->ext.block.assoc = NULL; - - ns->code = *current_code; - - /* If the statement has a label, make sure it is transferred to - the newly created block. */ - - if ((*current_code)->here) - { - inserted_block->here = (*current_code)->here; - (*current_code)->here = NULL; - } - - inserted_block->next = (*current_code)->next; - changed_statement = &(inserted_block->ext.block.ns->code); - (*current_code)->next = NULL; - /* Insert the BLOCK at the right position. */ - *current_code = inserted_block; - ns->parent = current_ns; - } - else - ns = inserted_block->ext.block.ns; - - return ns; -} - - -/* Insert a call to the intrinsic len. Use a different name for - the symbol tree so we don't run into trouble when the user has - renamed len for some reason. */ - -static gfc_expr* -get_len_call (gfc_expr *str) -{ - gfc_expr *fcn; - gfc_actual_arglist *actual_arglist; - - fcn = gfc_get_expr (); - fcn->expr_type = EXPR_FUNCTION; - fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN); - actual_arglist = gfc_get_actual_arglist (); - actual_arglist->expr = str; - - fcn->value.function.actual = actual_arglist; - fcn->where = str->where; - fcn->ts.type = BT_INTEGER; - fcn->ts.kind = gfc_charlen_int_kind; - - gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false); - fcn->symtree->n.sym->ts = fcn->ts; - fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; - fcn->symtree->n.sym->attr.function = 1; - fcn->symtree->n.sym->attr.elemental = 1; - fcn->symtree->n.sym->attr.referenced = 1; - fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; - gfc_commit_symbol (fcn->symtree->n.sym); - - return fcn; -} - - -/* Returns a new expression (a variable) to be used in place of the old one, - with an optional assignment statement before the current statement to set - the value of the variable. Creates a new BLOCK for the statement if that - hasn't already been done and puts the statement, plus the newly created - variables, in that block. Special cases: If the expression is constant or - a temporary which has already been created, just copy it. */ - -static gfc_expr* -create_var (gfc_expr * e, const char *vname) -{ - char name[GFC_MAX_SYMBOL_LEN +1]; - gfc_symtree *symtree; - gfc_symbol *symbol; - gfc_expr *result; - gfc_code *n; - gfc_namespace *ns; - int i; - bool deferred; - - if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e)) - return gfc_copy_expr (e); - - /* Creation of an array of unknown size requires realloc on assignment. - If that is not possible, just return NULL. */ - if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL) - return NULL; - - ns = insert_block (); - - if (vname) - snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname); - else - snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++); - - if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) - gcc_unreachable (); - - symbol = symtree->n.sym; - symbol->ts = e->ts; - - if (e->rank > 0) - { - symbol->as = gfc_get_array_spec (); - symbol->as->rank = e->rank; - - if (e->shape == NULL) - { - /* We don't know the shape at compile time, so we use an - allocatable. */ - symbol->as->type = AS_DEFERRED; - symbol->attr.allocatable = 1; - } - else - { - symbol->as->type = AS_EXPLICIT; - /* Copy the shape. */ - for (i=0; irank; i++) - { - gfc_expr *p, *q; - - p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &(e->where)); - mpz_set_si (p->value.integer, 1); - symbol->as->lower[i] = p; - - q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, - &(e->where)); - mpz_set (q->value.integer, e->shape[i]); - symbol->as->upper[i] = q; - } - } - } - - deferred = 0; - if (e->ts.type == BT_CHARACTER) - { - gfc_expr *length; - - symbol->ts.u.cl = gfc_new_charlen (ns, NULL); - length = constant_string_length (e); - if (length) - symbol->ts.u.cl->length = length; - else if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->ts.type == BT_CHARACTER - && e->ts.u.cl->length) - symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e)); - else - { - symbol->attr.allocatable = 1; - symbol->ts.u.cl->length = NULL; - symbol->ts.deferred = 1; - deferred = 1; - } - } - - symbol->attr.flavor = FL_VARIABLE; - symbol->attr.referenced = 1; - symbol->attr.dimension = e->rank > 0; - symbol->attr.fe_temp = 1; - gfc_commit_symbol (symbol); - - result = gfc_get_expr (); - result->expr_type = EXPR_VARIABLE; - result->ts = symbol->ts; - result->ts.deferred = deferred; - result->rank = e->rank; - result->shape = gfc_copy_shape (e->shape, e->rank); - result->symtree = symtree; - result->where = e->where; - if (e->rank > 0) - { - result->ref = gfc_get_ref (); - result->ref->type = REF_ARRAY; - result->ref->u.ar.type = AR_FULL; - result->ref->u.ar.where = e->where; - result->ref->u.ar.dimen = e->rank; - result->ref->u.ar.as = symbol->ts.type == BT_CLASS - ? CLASS_DATA (symbol)->as : symbol->as; - if (warn_array_temporaries) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", &(e->where)); - } - - /* Generate the new assignment. */ - n = XCNEW (gfc_code); - n->op = EXEC_ASSIGN; - n->loc = (*current_code)->loc; - n->next = *changed_statement; - n->expr1 = gfc_copy_expr (result); - n->expr2 = e; - *changed_statement = n; - n_vars ++; - - return result; -} - -/* Warn about function elimination. */ - -static void -do_warn_function_elimination (gfc_expr *e) -{ - const char *name; - if (e->expr_type == EXPR_FUNCTION - && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e)) - { - if (name) - gfc_warning (OPT_Wfunction_elimination, - "Removing call to impure function %qs at %L", name, - &(e->where)); - else - gfc_warning (OPT_Wfunction_elimination, - "Removing call to impure function at %L", - &(e->where)); - } -} - - -/* Callback function for the code walker for doing common function - elimination. This builds up the list of functions in the expression - and goes through them to detect duplicates, which it then replaces - by variables. */ - -static int -cfe_expr_0 (gfc_expr **e, int *walk_subtrees, - void *data ATTRIBUTE_UNUSED) -{ - int i,j; - gfc_expr *newvar; - gfc_expr **ei, **ej; - - /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */ - - if (in_omp_workshare || in_omp_atomic || in_assoc_list) - { - *walk_subtrees = 0; - return 0; - } - - expr_array.release (); - - gfc_expr_walker (e, cfe_register_funcs, NULL); - - /* Walk through all the functions. */ - - FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1) - { - /* Skip if the function has been replaced by a variable already. */ - if ((*ei)->expr_type == EXPR_VARIABLE) - continue; - - newvar = NULL; - for (j=0; j0) - b = sum(foo(a) + foo(a)) - END WHERE - - with - - WHERE (a > 0) - tmp = foo(a) - b = sum(tmp + tmp) - END WHERE -*/ - - if ((*c)->op == EXEC_WHERE) - { - *walk_subtrees = 0; - return 0; - } - - - return 0; -} - -/* Dummy function for expression call back, for use when we - really don't want to do any walking. */ - -static int -dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees, - void *data ATTRIBUTE_UNUSED) -{ - *walk_subtrees = 0; - return 0; -} - -/* Dummy function for code callback, for use when we really - don't want to do anything. */ -int -gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED, - int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - return 0; -} - -/* Code callback function for converting - do while(a) - end do - into the equivalent - do - if (.not. a) exit - end do - This is because common function elimination would otherwise place the - temporary variables outside the loop. */ - -static int -convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code *co = *c; - gfc_code *c_if1, *c_if2, *c_exit; - gfc_code *loopblock; - gfc_expr *e_not, *e_cond; - - if (co->op != EXEC_DO_WHILE) - return 0; - - if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT) - return 0; - - e_cond = co->expr1; - - /* Generate the condition of the if statement, which is .not. the original - statement. */ - e_not = gfc_get_expr (); - e_not->ts = e_cond->ts; - e_not->where = e_cond->where; - e_not->expr_type = EXPR_OP; - e_not->value.op.op = INTRINSIC_NOT; - e_not->value.op.op1 = e_cond; - - /* Generate the EXIT statement. */ - c_exit = XCNEW (gfc_code); - c_exit->op = EXEC_EXIT; - c_exit->ext.which_construct = co; - c_exit->loc = co->loc; - - /* Generate the IF statement. */ - c_if2 = XCNEW (gfc_code); - c_if2->op = EXEC_IF; - c_if2->expr1 = e_not; - c_if2->next = c_exit; - c_if2->loc = co->loc; - - /* ... plus the one to chain it to. */ - c_if1 = XCNEW (gfc_code); - c_if1->op = EXEC_IF; - c_if1->block = c_if2; - c_if1->loc = co->loc; - - /* Make the DO WHILE loop into a DO block by replacing the condition - with a true constant. */ - co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true); - - /* Hang the generated if statement into the loop body. */ - - loopblock = co->block->next; - co->block->next = c_if1; - c_if1->next = loopblock; - - return 0; -} - -/* Code callback function for converting - if (a) then - ... - else if (b) then - end if - - into - if (a) then - else - if (b) then - end if - end if - - because otherwise common function elimination would place the BLOCKs - into the wrong place. */ - -static int -convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code *co = *c; - gfc_code *c_if1, *c_if2, *else_stmt; - - if (co->op != EXEC_IF) - return 0; - - /* This loop starts out with the first ELSE statement. */ - else_stmt = co->block->block; - - while (else_stmt != NULL) - { - gfc_code *next_else; - - /* If there is no condition, we're done. */ - if (else_stmt->expr1 == NULL) - break; - - next_else = else_stmt->block; - - /* Generate the new IF statement. */ - c_if2 = XCNEW (gfc_code); - c_if2->op = EXEC_IF; - c_if2->expr1 = else_stmt->expr1; - c_if2->next = else_stmt->next; - c_if2->loc = else_stmt->loc; - c_if2->block = next_else; - - /* ... plus the one to chain it to. */ - c_if1 = XCNEW (gfc_code); - c_if1->op = EXEC_IF; - c_if1->block = c_if2; - c_if1->loc = else_stmt->loc; - - /* Insert the new IF after the ELSE. */ - else_stmt->expr1 = NULL; - else_stmt->next = c_if1; - else_stmt->block = NULL; - - else_stmt = next_else; - } - /* Don't walk subtrees. */ - return 0; -} - -/* Callback function to var_in_expr - return true if expr1 and - expr2 are identical variables. */ -static int -var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - gfc_expr *expr1 = (gfc_expr *) data; - gfc_expr *expr2 = *e; - - if (expr2->expr_type != EXPR_VARIABLE) - return 0; - - return expr1->symtree->n.sym == expr2->symtree->n.sym; -} - -/* Return true if expr1 is found in expr2. */ - -static bool -var_in_expr (gfc_expr *expr1, gfc_expr *expr2) -{ - gcc_assert (expr1->expr_type == EXPR_VARIABLE); - - return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1); -} - -struct do_stack -{ - struct do_stack *prev; - gfc_iterator *iter; - gfc_code *code; -} *stack_top; - -/* Recursively traverse the block of a WRITE or READ statement, and maybe - optimize by replacing do loops with their analog array slices. For - example: - - write (*,*) (a(i), i=1,4) - - is replaced with - - write (*,*) a(1:4:1) . */ - -static bool -traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev) -{ - gfc_code *curr; - gfc_expr *new_e, *expr, *start; - gfc_ref *ref; - struct do_stack ds_push; - int i, future_rank = 0; - gfc_iterator *iters[GFC_MAX_DIMENSIONS]; - gfc_expr *e; - - /* Find the first transfer/do statement. */ - for (curr = code; curr; curr = curr->next) - { - if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER) - break; - } - - /* Ensure it is the only transfer/do statement because cases like - - write (*,*) (a(i), b(i), i=1,4) - - cannot be optimized. */ - - if (!curr || curr->next) - return false; - - if (curr->op == EXEC_DO) - { - if (curr->ext.iterator->var->ref) - return false; - ds_push.prev = stack_top; - ds_push.iter = curr->ext.iterator; - ds_push.code = curr; - stack_top = &ds_push; - if (traverse_io_block (curr->block->next, has_reached, prev)) - { - if (curr != stack_top->code && !*has_reached) - { - curr->block->next = NULL; - gfc_free_statements (curr); - } - else - *has_reached = true; - return true; - } - return false; - } - - gcc_assert (curr->op == EXEC_TRANSFER); - - e = curr->expr1; - ref = e->ref; - if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next) - return false; - - /* Find the iterators belonging to each variable and check conditions. */ - for (i = 0; i < ref->u.ar.dimen; i++) - { - if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref - || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) - return false; - - start = ref->u.ar.start[i]; - gfc_simplify_expr (start, 0); - switch (start->expr_type) - { - case EXPR_VARIABLE: - - /* write (*,*) (a(i), i=a%b,1) not handled yet. */ - if (start->ref) - return false; - - /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */ - if (!stack_top || !stack_top->iter - || stack_top->iter->var->symtree != start->symtree) - { - /* Check for (a(i,i), i=1,3). */ - int j; - - for (j=0; jvar->symtree == start->symtree) - return false; - - iters[i] = NULL; - } - else - { - iters[i] = stack_top->iter; - stack_top = stack_top->prev; - future_rank++; - } - break; - case EXPR_CONSTANT: - iters[i] = NULL; - break; - case EXPR_OP: - switch (start->value.op.op) - { - case INTRINSIC_PLUS: - case INTRINSIC_TIMES: - if (start->value.op.op1->expr_type != EXPR_VARIABLE) - std::swap (start->value.op.op1, start->value.op.op2); - gcc_fallthrough (); - case INTRINSIC_MINUS: - if (start->value.op.op1->expr_type!= EXPR_VARIABLE - || start->value.op.op2->expr_type != EXPR_CONSTANT - || start->value.op.op1->ref) - return false; - if (!stack_top || !stack_top->iter - || stack_top->iter->var->symtree - != start->value.op.op1->symtree) - return false; - iters[i] = stack_top->iter; - stack_top = stack_top->prev; - break; - default: - return false; - } - future_rank++; - break; - default: - return false; - } - } - - /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */ - for (int i = 1; i < ref->u.ar.dimen; i++) - { - if (iters[i]) - { - gfc_expr *var = iters[i]->var; - for (int j = i - 1; j < i; j++) - { - if (iters[j] - && (var_in_expr (var, iters[j]->start) - || var_in_expr (var, iters[j]->end) - || var_in_expr (var, iters[j]->step))) - return false; - } - } - } - - /* Create new expr. */ - new_e = gfc_copy_expr (curr->expr1); - new_e->expr_type = EXPR_VARIABLE; - new_e->rank = future_rank; - if (curr->expr1->shape) - new_e->shape = gfc_get_shape (new_e->rank); - - /* Assign new starts, ends and strides if necessary. */ - for (i = 0; i < ref->u.ar.dimen; i++) - { - if (!iters[i]) - continue; - start = ref->u.ar.start[i]; - switch (start->expr_type) - { - case EXPR_CONSTANT: - gfc_internal_error ("bad expression"); - break; - case EXPR_VARIABLE: - new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; - new_e->ref->u.ar.type = AR_SECTION; - gfc_free_expr (new_e->ref->u.ar.start[i]); - new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start); - new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end); - new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); - break; - case EXPR_OP: - new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; - new_e->ref->u.ar.type = AR_SECTION; - gfc_free_expr (new_e->ref->u.ar.start[i]); - expr = gfc_copy_expr (start); - expr->value.op.op1 = gfc_copy_expr (iters[i]->start); - new_e->ref->u.ar.start[i] = expr; - gfc_simplify_expr (new_e->ref->u.ar.start[i], 0); - expr = gfc_copy_expr (start); - expr->value.op.op1 = gfc_copy_expr (iters[i]->end); - new_e->ref->u.ar.end[i] = expr; - gfc_simplify_expr (new_e->ref->u.ar.end[i], 0); - switch (start->value.op.op) - { - case INTRINSIC_MINUS: - case INTRINSIC_PLUS: - new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); - break; - case INTRINSIC_TIMES: - expr = gfc_copy_expr (start); - expr->value.op.op1 = gfc_copy_expr (iters[i]->step); - new_e->ref->u.ar.stride[i] = expr; - gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0); - break; - default: - gfc_internal_error ("bad op"); - } - break; - default: - gfc_internal_error ("bad expression"); - } - } - curr->expr1 = new_e; - - /* Insert modified statement. Check whether the statement needs to be - inserted at the lowest level. */ - if (!stack_top->iter) - { - if (prev) - { - curr->next = prev->next->next; - prev->next = curr; - } - else - { - curr->next = stack_top->code->block->next->next->next; - stack_top->code->block->next = curr; - } - } - else - stack_top->code->block->next = curr; - return true; -} - -/* Function for the gfc_code_walker. If code is a READ or WRITE statement, it - tries to optimize its block. */ - -static int -simplify_io_impl_do (gfc_code **code, int *walk_subtrees, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code **curr, *prev = NULL; - struct do_stack write, first; - bool b = false; - *walk_subtrees = 1; - if (!(*code)->block - || ((*code)->block->op != EXEC_WRITE - && (*code)->block->op != EXEC_READ)) - return 0; - - *walk_subtrees = 0; - write.prev = NULL; - write.iter = NULL; - write.code = *code; - - for (curr = &(*code)->block; *curr; curr = &(*curr)->next) - { - if ((*curr)->op == EXEC_DO) - { - first.prev = &write; - first.iter = (*curr)->ext.iterator; - first.code = *curr; - stack_top = &first; - traverse_io_block ((*curr)->block->next, &b, prev); - stack_top = NULL; - } - prev = *curr; - } - return 0; -} - -/* Optimize a namespace, including all contained namespaces. - flag_frontend_optimize and flag_fronend_loop_interchange are - handled separately. */ - -static void -optimize_namespace (gfc_namespace *ns) -{ - gfc_namespace *saved_ns = gfc_current_ns; - current_ns = ns; - gfc_current_ns = ns; - forall_level = 0; - iterator_level = 0; - in_assoc_list = false; - in_omp_workshare = false; - in_omp_atomic = false; - - if (flag_frontend_optimize) - { - gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL); - gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); - gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); - gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); - gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); - if (flag_inline_matmul_limit != 0 || flag_external_blas) - { - bool found; - do - { - found = false; - gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr, - (void *) &found); - } - while (found); - - gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback, - NULL); - } - - if (flag_external_blas) - gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback, - NULL); - - if (flag_inline_matmul_limit != 0) - gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback, - NULL); - } - - if (flag_frontend_loop_interchange) - gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback, - NULL); - - /* BLOCKs are handled in the expression walker below. */ - for (ns = ns->contained; ns; ns = ns->sibling) - { - if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - optimize_namespace (ns); - } - gfc_current_ns = saved_ns; -} - -/* Handle dependencies for allocatable strings which potentially redefine - themselves in an assignment. */ - -static void -realloc_strings (gfc_namespace *ns) -{ - current_ns = ns; - gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL); - - for (ns = ns->contained; ns; ns = ns->sibling) - { - if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - realloc_strings (ns); - } - -} - -static void -optimize_reduction (gfc_namespace *ns) -{ - current_ns = ns; - gfc_code_walker (&ns->code, gfc_dummy_code_callback, - callback_reduction, NULL); - -/* BLOCKs are handled in the expression walker below. */ - for (ns = ns->contained; ns; ns = ns->sibling) - { - if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - optimize_reduction (ns); - } -} - -/* Replace code like - a = matmul(b,c) + d - with - a = matmul(b,c) ; a = a + d - where the array function is not elemental and not allocatable - and does not depend on the left-hand side. -*/ - -static bool -optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) -{ - gfc_expr *e; - - if (!*rhs) - return false; - - e = *rhs; - if (e->expr_type == EXPR_OP) - { - switch (e->value.op.op) - { - /* Unary operators and exponentiation: Only look at a single - operand. */ - case INTRINSIC_NOT: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - case INTRINSIC_PARENTHESES: - case INTRINSIC_POWER: - if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op)) - return true; - break; - - case INTRINSIC_CONCAT: - /* Do not do string concatenations. */ - break; - - default: - /* Binary operators. */ - if (optimize_binop_array_assignment (c, &e->value.op.op1, true)) - return true; - - if (optimize_binop_array_assignment (c, &e->value.op.op2, true)) - return true; - - break; - } - } - else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 - && ! (e->value.function.esym - && (e->value.function.esym->attr.elemental - || e->value.function.esym->attr.allocatable - || e->value.function.esym->ts.type != c->expr1->ts.type - || e->value.function.esym->ts.kind != c->expr1->ts.kind)) - && ! (e->value.function.isym - && (e->value.function.isym->elemental - || e->ts.type != c->expr1->ts.type - || e->ts.kind != c->expr1->ts.kind)) - && ! gfc_inline_intrinsic_function_p (e)) - { - - gfc_code *n; - gfc_expr *new_expr; - - /* Insert a new assignment statement after the current one. */ - n = XCNEW (gfc_code); - n->op = EXEC_ASSIGN; - n->loc = c->loc; - n->next = c->next; - c->next = n; - - n->expr1 = gfc_copy_expr (c->expr1); - n->expr2 = c->expr2; - new_expr = gfc_copy_expr (c->expr1); - c->expr2 = e; - *rhs = new_expr; - - return true; - - } - - /* Nothing to optimize. */ - return false; -} - -/* Remove unneeded TRIMs at the end of expressions. */ - -static bool -remove_trim (gfc_expr *rhs) -{ - bool ret; - - ret = false; - if (!rhs) - return ret; - - /* Check for a // b // trim(c). Looping is probably not - necessary because the parser usually generates - (// (// a b ) trim(c) ) , but better safe than sorry. */ - - while (rhs->expr_type == EXPR_OP - && rhs->value.op.op == INTRINSIC_CONCAT) - rhs = rhs->value.op.op2; - - while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym - && rhs->value.function.isym->id == GFC_ISYM_TRIM) - { - strip_function_call (rhs); - /* Recursive call to catch silly stuff like trim ( a // trim(b)). */ - remove_trim (rhs); - ret = true; - } - - return ret; -} - -/* Optimizations for an assignment. */ - -static void -optimize_assignment (gfc_code * c) -{ - gfc_expr *lhs, *rhs; - - lhs = c->expr1; - rhs = c->expr2; - - if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred) - { - /* Optimize a = trim(b) to a = b. */ - remove_trim (rhs); - - /* Replace a = ' ' by a = '' to optimize away a memcpy. */ - if (is_empty_string (rhs)) - rhs->value.character.length = 0; - } - - if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0) - optimize_binop_array_assignment (c, &rhs, false); -} - - -/* Remove an unneeded function call, modifying the expression. - This replaces the function call with the value of its - first argument. The rest of the argument list is freed. */ - -static void -strip_function_call (gfc_expr *e) -{ - gfc_expr *e1; - gfc_actual_arglist *a; - - a = e->value.function.actual; - - /* We should have at least one argument. */ - gcc_assert (a->expr != NULL); - - e1 = a->expr; - - /* Free the remaining arglist, if any. */ - if (a->next) - gfc_free_actual_arglist (a->next); - - /* Graft the argument expression onto the original function. */ - *e = *e1; - free (e1); - -} - -/* Optimization of lexical comparison functions. */ - -static bool -optimize_lexical_comparison (gfc_expr *e) -{ - if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL) - return false; - - switch (e->value.function.isym->id) - { - case GFC_ISYM_LLE: - return optimize_comparison (e, INTRINSIC_LE); - - case GFC_ISYM_LGE: - return optimize_comparison (e, INTRINSIC_GE); - - case GFC_ISYM_LGT: - return optimize_comparison (e, INTRINSIC_GT); - - case GFC_ISYM_LLT: - return optimize_comparison (e, INTRINSIC_LT); - - default: - break; - } - return false; -} - -/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not - do CHARACTER because of possible pessimization involving character - lengths. */ - -static bool -combine_array_constructor (gfc_expr *e) -{ - - gfc_expr *op1, *op2; - gfc_expr *scalar; - gfc_expr *new_expr; - gfc_constructor *c, *new_c; - gfc_constructor_base oldbase, newbase; - bool scalar_first; - int n_elem; - bool all_const; - - /* Array constructors have rank one. */ - if (e->rank != 1) - return false; - - /* Don't try to combine association lists, this makes no sense - and leads to an ICE. */ - if (in_assoc_list) - return false; - - /* With FORALL, the BLOCKS created by create_var will cause an ICE. */ - if (forall_level > 0) - return false; - - /* Inside an iterator, things can get hairy; we are likely to create - an invalid temporary variable. */ - if (iterator_level > 0) - return false; - - /* WHERE also doesn't work. */ - if (in_where > 0) - return false; - - op1 = e->value.op.op1; - op2 = e->value.op.op2; - - if (!op1 || !op2) - return false; - - if (op1->expr_type == EXPR_ARRAY && op2->rank == 0) - scalar_first = false; - else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0) - { - scalar_first = true; - op1 = e->value.op.op2; - op2 = e->value.op.op1; - } - else - return false; - - if (op2->ts.type == BT_CHARACTER) - return false; - - /* This might be an expanded constructor with very many constant values. If - we perform the operation here, we might end up with a long compile time - and actually longer execution time, so a length bound is in order here. - If the constructor constains something which is not a constant, it did - not come from an expansion, so leave it alone. */ - -#define CONSTR_LEN_MAX 4 - - oldbase = op1->value.constructor; - - n_elem = 0; - all_const = true; - for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c)) - { - if (c->expr->expr_type != EXPR_CONSTANT) - { - all_const = false; - break; - } - n_elem += 1; - } - - if (all_const && n_elem > CONSTR_LEN_MAX) - return false; - -#undef CONSTR_LEN_MAX - - newbase = NULL; - e->expr_type = EXPR_ARRAY; - - scalar = create_var (gfc_copy_expr (op2), "constr"); - - for (c = gfc_constructor_first (oldbase); c; - c = gfc_constructor_next (c)) - { - new_expr = gfc_get_expr (); - new_expr->ts = e->ts; - new_expr->expr_type = EXPR_OP; - new_expr->rank = c->expr->rank; - new_expr->where = c->expr->where; - new_expr->value.op.op = e->value.op.op; - - if (scalar_first) - { - new_expr->value.op.op1 = gfc_copy_expr (scalar); - new_expr->value.op.op2 = gfc_copy_expr (c->expr); - } - else - { - new_expr->value.op.op1 = gfc_copy_expr (c->expr); - new_expr->value.op.op2 = gfc_copy_expr (scalar); - } - - new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where)); - new_c->iterator = c->iterator; - c->iterator = NULL; - } - - gfc_free_expr (op1); - gfc_free_expr (op2); - gfc_free_expr (scalar); - - e->value.constructor = newbase; - return true; -} - -/* Recursive optimization of operators. */ - -static bool -optimize_op (gfc_expr *e) -{ - bool changed; - - gfc_intrinsic_op op = e->value.op.op; - - changed = false; - - /* Only use new-style comparisons. */ - switch(op) - { - case INTRINSIC_EQ_OS: - op = INTRINSIC_EQ; - break; - - case INTRINSIC_GE_OS: - op = INTRINSIC_GE; - break; - - case INTRINSIC_LE_OS: - op = INTRINSIC_LE; - break; - - case INTRINSIC_NE_OS: - op = INTRINSIC_NE; - break; - - case INTRINSIC_GT_OS: - op = INTRINSIC_GT; - break; - - case INTRINSIC_LT_OS: - op = INTRINSIC_LT; - break; - - default: - break; - } - - switch (op) - { - case INTRINSIC_EQ: - case INTRINSIC_GE: - case INTRINSIC_LE: - case INTRINSIC_NE: - case INTRINSIC_GT: - case INTRINSIC_LT: - changed = optimize_comparison (e, op); - - gcc_fallthrough (); - /* Look at array constructors. */ - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - return combine_array_constructor (e) || changed; - - default: - break; - } - - return false; -} - - -/* Return true if a constant string contains only blanks. */ - -static bool -is_empty_string (gfc_expr *e) -{ - int i; - - if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) - return false; - - for (i=0; i < e->value.character.length; i++) - { - if (e->value.character.string[i] != ' ') - return false; - } - - return true; -} - - -/* Insert a call to the intrinsic len_trim. Use a different name for - the symbol tree so we don't run into trouble when the user has - renamed len_trim for some reason. */ - -static gfc_expr* -get_len_trim_call (gfc_expr *str, int kind) -{ - gfc_expr *fcn; - gfc_actual_arglist *actual_arglist, *next; - - fcn = gfc_get_expr (); - fcn->expr_type = EXPR_FUNCTION; - fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); - actual_arglist = gfc_get_actual_arglist (); - actual_arglist->expr = str; - next = gfc_get_actual_arglist (); - next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind); - actual_arglist->next = next; - - fcn->value.function.actual = actual_arglist; - fcn->where = str->where; - fcn->ts.type = BT_INTEGER; - fcn->ts.kind = gfc_charlen_int_kind; - - gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false); - fcn->symtree->n.sym->ts = fcn->ts; - fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; - fcn->symtree->n.sym->attr.function = 1; - fcn->symtree->n.sym->attr.elemental = 1; - fcn->symtree->n.sym->attr.referenced = 1; - fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; - gfc_commit_symbol (fcn->symtree->n.sym); - - return fcn; -} - - -/* Optimize expressions for equality. */ - -static bool -optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) -{ - gfc_expr *op1, *op2; - bool change; - int eq; - bool result; - gfc_actual_arglist *firstarg, *secondarg; - - if (e->expr_type == EXPR_OP) - { - firstarg = NULL; - secondarg = NULL; - op1 = e->value.op.op1; - op2 = e->value.op.op2; - } - else if (e->expr_type == EXPR_FUNCTION) - { - /* One of the lexical comparison functions. */ - firstarg = e->value.function.actual; - secondarg = firstarg->next; - op1 = firstarg->expr; - op2 = secondarg->expr; - } - else - gcc_unreachable (); - - /* Strip off unneeded TRIM calls from string comparisons. */ - - change = remove_trim (op1); - - if (remove_trim (op2)) - change = true; - - /* An expression of type EXPR_CONSTANT is only valid for scalars. */ - /* TODO: A scalar constant may be acceptable in some cases (the scalarizer - handles them well). However, there are also cases that need a non-scalar - argument. For example the any intrinsic. See PR 45380. */ - if (e->rank > 0) - return change; - - /* Replace a == '' with len_trim(a) == 0 and a /= '' with - len_trim(a) != 0 */ - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER - && (op == INTRINSIC_EQ || op == INTRINSIC_NE)) - { - bool empty_op1, empty_op2; - empty_op1 = is_empty_string (op1); - empty_op2 = is_empty_string (op2); - - if (empty_op1 || empty_op2) - { - gfc_expr *fcn; - gfc_expr *zero; - gfc_expr *str; - - /* This can only happen when an error for comparing - characters of different kinds has already been issued. */ - if (empty_op1 && empty_op2) - return false; - - zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0); - str = empty_op1 ? op2 : op1; - - fcn = get_len_trim_call (str, gfc_charlen_int_kind); - - - if (empty_op1) - gfc_free_expr (op1); - else - gfc_free_expr (op2); - - op1 = fcn; - op2 = zero; - e->value.op.op1 = fcn; - e->value.op.op2 = zero; - } - } - - - /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ - - if (flag_finite_math_only - || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL - && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX)) - { - eq = gfc_dep_compare_expr (op1, op2); - if (eq <= -2) - { - /* Replace A // B < A // C with B < C, and A // B < C // B - with A < C. */ - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER - && op1->expr_type == EXPR_OP - && op1->value.op.op == INTRINSIC_CONCAT - && op2->expr_type == EXPR_OP - && op2->value.op.op == INTRINSIC_CONCAT) - { - gfc_expr *op1_left = op1->value.op.op1; - gfc_expr *op2_left = op2->value.op.op1; - gfc_expr *op1_right = op1->value.op.op2; - gfc_expr *op2_right = op2->value.op.op2; - - if (gfc_dep_compare_expr (op1_left, op2_left) == 0) - { - /* Watch out for 'A ' // x vs. 'A' // x. */ - - if (op1_left->expr_type == EXPR_CONSTANT - && op2_left->expr_type == EXPR_CONSTANT - && op1_left->value.character.length - != op2_left->value.character.length) - return change; - else - { - free (op1_left); - free (op2_left); - if (firstarg) - { - firstarg->expr = op1_right; - secondarg->expr = op2_right; - } - else - { - e->value.op.op1 = op1_right; - e->value.op.op2 = op2_right; - } - optimize_comparison (e, op); - return true; - } - } - if (gfc_dep_compare_expr (op1_right, op2_right) == 0) - { - free (op1_right); - free (op2_right); - if (firstarg) - { - firstarg->expr = op1_left; - secondarg->expr = op2_left; - } - else - { - e->value.op.op1 = op1_left; - e->value.op.op2 = op2_left; - } - - optimize_comparison (e, op); - return true; - } - } - } - else - { - /* eq can only be -1, 0 or 1 at this point. */ - switch (op) - { - case INTRINSIC_EQ: - result = eq == 0; - break; - - case INTRINSIC_GE: - result = eq >= 0; - break; - - case INTRINSIC_LE: - result = eq <= 0; - break; - - case INTRINSIC_NE: - result = eq != 0; - break; - - case INTRINSIC_GT: - result = eq > 0; - break; - - case INTRINSIC_LT: - result = eq < 0; - break; - - default: - gfc_internal_error ("illegal OP in optimize_comparison"); - break; - } - - /* Replace the expression by a constant expression. The typespec - and where remains the way it is. */ - free (op1); - free (op2); - e->expr_type = EXPR_CONSTANT; - e->value.logical = result; - return true; - } - } - - return change; -} - -/* Optimize a trim function by replacing it with an equivalent substring - involving a call to len_trim. This only works for expressions where - variables are trimmed. Return true if anything was modified. */ - -static bool -optimize_trim (gfc_expr *e) -{ - gfc_expr *a; - gfc_ref *ref; - gfc_expr *fcn; - gfc_ref **rr = NULL; - - /* Don't do this optimization within an argument list, because - otherwise aliasing issues may occur. */ - - if (count_arglist != 1) - return false; - - if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION - || e->value.function.isym == NULL - || e->value.function.isym->id != GFC_ISYM_TRIM) - return false; - - a = e->value.function.actual->expr; - - if (a->expr_type != EXPR_VARIABLE) - return false; - - /* This would pessimize the idiom a = trim(a) for reallocatable strings. */ - - if (a->symtree->n.sym->attr.allocatable) - return false; - - /* Follow all references to find the correct place to put the newly - created reference. FIXME: Also handle substring references and - array references. Array references cause strange regressions at - the moment. */ - - if (a->ref) - { - for (rr = &(a->ref); *rr; rr = &((*rr)->next)) - { - if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY) - return false; - } - } - - strip_function_call (e); - - if (e->ref == NULL) - rr = &(e->ref); - - /* Create the reference. */ - - ref = gfc_get_ref (); - ref->type = REF_SUBSTRING; - - /* Set the start of the reference. */ - - ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); - - /* Build the function call to len_trim(x, gfc_default_integer_kind). */ - - fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind); - - /* Set the end of the reference to the call to len_trim. */ - - ref->u.ss.end = fcn; - gcc_assert (rr != NULL && *rr == NULL); - *rr = ref; - return true; -} - -/* Optimize minloc(b), where b is rank 1 array, into - (/ minloc(b, dim=1) /), and similarly for maxloc, - as the latter forms are expanded inline. */ - -static void -optimize_minmaxloc (gfc_expr **e) -{ - gfc_expr *fn = *e; - gfc_actual_arglist *a; - char *name, *p; - - if (fn->rank != 1 - || fn->value.function.actual == NULL - || fn->value.function.actual->expr == NULL - || fn->value.function.actual->expr->rank != 1) - return; - - *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); - (*e)->shape = fn->shape; - fn->rank = 0; - fn->shape = NULL; - gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where); - - name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1); - strcpy (name, fn->value.function.name); - p = strstr (name, "loc0"); - p[3] = '1'; - fn->value.function.name = gfc_get_string ("%s", name); - if (fn->value.function.actual->next) - { - a = fn->value.function.actual->next; - gcc_assert (a->expr == NULL); - } - else - { - a = gfc_get_actual_arglist (); - fn->value.function.actual->next = a; - } - a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &fn->where); - mpz_set_ui (a->expr->value.integer, 1); -} - -/* Data package to hand down for DO loop checks in a contained - procedure. */ -typedef struct contained_info -{ - gfc_symbol *do_var; - gfc_symbol *procedure; - locus where_do; -} contained_info; - -static enum gfc_exec_op last_io_op; - -/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a - contained function call. */ - -static int -doloop_contained_function_call (gfc_expr **e, - int *walk_subtrees ATTRIBUTE_UNUSED, void *data) -{ - gfc_expr *expr = *e; - gfc_formal_arglist *f; - gfc_actual_arglist *a; - gfc_symbol *sym, *do_var; - contained_info *info; - - if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym - || expr->value.function.esym == NULL) - return 0; - - sym = expr->value.function.esym; - f = gfc_sym_get_dummy_args (sym); - if (f == NULL) - return 0; - - info = (contained_info *) data; - do_var = info->do_var; - a = expr->value.function.actual; - - while (a && f) - { - if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) - { - if (f->sym->attr.intent == INTENT_OUT) - { - gfc_error_now ("Index variable %qs set to undefined as " - "INTENT(OUT) argument at %L in procedure %qs " - "called from within DO loop at %L", do_var->name, - &a->expr->where, info->procedure->name, - &info->where_do); - return 1; - } - else if (f->sym->attr.intent == INTENT_INOUT) - { - gfc_error_now ("Index variable %qs not definable as " - "INTENT(INOUT) argument at %L in procedure %qs " - "called from within DO loop at %L", do_var->name, - &a->expr->where, info->procedure->name, - &info->where_do); - return 1; - } - } - a = a->next; - f = f->next; - } - return 0; -} - -/* Callback function that goes through the code in a contained - procedure to make sure it does not change a variable in a DO - loop. */ - -static int -doloop_contained_procedure_code (gfc_code **c, - int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - gfc_code *co = *c; - contained_info *info = (contained_info *) data; - gfc_symbol *do_var = info->do_var; - const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs " - "called from within DO loop at %L"); - static enum gfc_exec_op saved_io_op; - - switch (co->op) - { - case EXEC_ASSIGN: - if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var) - gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name, - &info->where_do); - break; - - case EXEC_DO: - if (co->ext.iterator && co->ext.iterator->var - && co->ext.iterator->var->symtree->n.sym == do_var) - gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name, - &info->where_do); - break; - - case EXEC_READ: - case EXEC_WRITE: - case EXEC_INQUIRE: - case EXEC_IOLENGTH: - saved_io_op = last_io_op; - last_io_op = co->op; - break; - - case EXEC_OPEN: - if (co->ext.open && co->ext.open->iostat - && co->ext.open->iostat->symtree->n.sym == do_var) - gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where, - info->procedure->name, &info->where_do); - break; - - case EXEC_CLOSE: - if (co->ext.close && co->ext.close->iostat - && co->ext.close->iostat->symtree->n.sym == do_var) - gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where, - info->procedure->name, &info->where_do); - break; - - case EXEC_TRANSFER: - switch (last_io_op) - { - - case EXEC_INQUIRE: -#define CHECK_INQ(a) do { if (co->ext.inquire && \ - co->ext.inquire->a && \ - co->ext.inquire->a->symtree->n.sym == do_var) \ - gfc_error_now (errmsg, do_var->name, \ - &co->ext.inquire->a->where, \ - info->procedure->name, \ - &info->where_do); \ - } while (0) - - CHECK_INQ(iostat); - CHECK_INQ(number); - CHECK_INQ(position); - CHECK_INQ(recl); - CHECK_INQ(position); - CHECK_INQ(iolength); - CHECK_INQ(strm_pos); - break; -#undef CHECK_INQ - - case EXEC_READ: - if (co->expr1 && co->expr1->symtree - && co->expr1->symtree->n.sym == do_var) - gfc_error_now (errmsg, do_var->name, &co->expr1->where, - info->procedure->name, &info->where_do); - - /* Fallthrough. */ - - case EXEC_WRITE: - if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree - && co->ext.dt->iostat->symtree->n.sym == do_var) - gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where, - info->procedure->name, &info->where_do); - break; - - case EXEC_IOLENGTH: - if (co->expr1 && co->expr1->symtree - && co->expr1->symtree->n.sym == do_var) - gfc_error_now (errmsg, do_var->name, &co->expr1->where, - info->procedure->name, &info->where_do); - break; - - default: - gcc_unreachable (); - } - break; - - case EXEC_DT_END: - last_io_op = saved_io_op; - break; - - case EXEC_CALL: - gfc_formal_arglist *f; - gfc_actual_arglist *a; - - f = gfc_sym_get_dummy_args (co->resolved_sym); - if (f == NULL) - break; - a = co->ext.actual; - /* Slightly different error message here. If there is an error, - return 1 to avoid an infinite loop. */ - while (a && f) - { - if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) - { - if (f->sym->attr.intent == INTENT_OUT) - { - gfc_error_now ("Index variable %qs set to undefined as " - "INTENT(OUT) argument at %L in subroutine %qs " - "called from within DO loop at %L", - do_var->name, &a->expr->where, - info->procedure->name, &info->where_do); - return 1; - } - else if (f->sym->attr.intent == INTENT_INOUT) - { - gfc_error_now ("Index variable %qs not definable as " - "INTENT(INOUT) argument at %L in subroutine %qs " - "called from within DO loop at %L", do_var->name, - &a->expr->where, info->procedure->name, - &info->where_do); - return 1; - } - } - a = a->next; - f = f->next; - } - break; - default: - break; - } - return 0; -} - -/* Callback function for code checking that we do not pass a DO variable to an - INTENT(OUT) or INTENT(INOUT) dummy variable. */ - -static int -doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code *co; - int i; - gfc_formal_arglist *f; - gfc_actual_arglist *a; - gfc_code *cl; - do_t loop, *lp; - bool seen_goto; - - co = *c; - - /* If the doloop_list grew, we have to truncate it here. */ - - if ((unsigned) doloop_level < doloop_list.length()) - doloop_list.truncate (doloop_level); - - seen_goto = false; - switch (co->op) - { - case EXEC_DO: - - if (co->ext.iterator && co->ext.iterator->var) - loop.c = co; - else - loop.c = NULL; - - loop.branch_level = if_level + select_level; - loop.seen_goto = false; - doloop_list.safe_push (loop); - break; - - /* If anything could transfer control away from a suspicious - subscript, make sure to set seen_goto in the current DO loop - (if any). */ - case EXEC_GOTO: - case EXEC_EXIT: - case EXEC_STOP: - case EXEC_ERROR_STOP: - case EXEC_CYCLE: - seen_goto = true; - break; - - case EXEC_OPEN: - if (co->ext.open->err) - seen_goto = true; - break; - - case EXEC_CLOSE: - if (co->ext.close->err) - seen_goto = true; - break; - - case EXEC_BACKSPACE: - case EXEC_ENDFILE: - case EXEC_REWIND: - case EXEC_FLUSH: - - if (co->ext.filepos->err) - seen_goto = true; - break; - - case EXEC_INQUIRE: - if (co->ext.filepos->err) - seen_goto = true; - break; - - case EXEC_READ: - case EXEC_WRITE: - if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor) - seen_goto = true; - break; - - case EXEC_WAIT: - if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor) - loop.seen_goto = true; - break; - - case EXEC_CALL: - if (co->resolved_sym == NULL) - break; - - /* Test if somebody stealthily changes the DO variable from - under us by changing it in a host-associated procedure. */ - if (co->resolved_sym->attr.contained) - { - FOR_EACH_VEC_ELT (doloop_list, i, lp) - { - gfc_symbol *sym = co->resolved_sym; - contained_info info; - gfc_namespace *ns; - - cl = lp->c; - info.do_var = cl->ext.iterator->var->symtree->n.sym; - info.procedure = co->resolved_sym; /* sym? */ - info.where_do = co->loc; - /* Look contained procedures under the namespace of the - variable. */ - for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) - if (ns->proc_name && ns->proc_name == sym) - gfc_code_walker (&ns->code, doloop_contained_procedure_code, - doloop_contained_function_call, &info); - } - } - - f = gfc_sym_get_dummy_args (co->resolved_sym); - - /* Withot a formal arglist, there is only unknown INTENT, - which we don't check for. */ - if (f == NULL) - break; - - a = co->ext.actual; - - while (a && f) - { - FOR_EACH_VEC_ELT (doloop_list, i, lp) - { - gfc_symbol *do_sym; - cl = lp->c; - - if (cl == NULL) - break; - - do_sym = cl->ext.iterator->var->symtree->n.sym; - - if (a->expr && a->expr->symtree && f->sym - && a->expr->symtree->n.sym == do_sym) - { - if (f->sym->attr.intent == INTENT_OUT) - gfc_error_now ("Variable %qs at %L set to undefined " - "value inside loop beginning at %L as " - "INTENT(OUT) argument to subroutine %qs", - do_sym->name, &a->expr->where, - &(doloop_list[i].c->loc), - co->symtree->n.sym->name); - else if (f->sym->attr.intent == INTENT_INOUT) - gfc_error_now ("Variable %qs at %L not definable inside " - "loop beginning at %L as INTENT(INOUT) " - "argument to subroutine %qs", - do_sym->name, &a->expr->where, - &(doloop_list[i].c->loc), - co->symtree->n.sym->name); - } - } - a = a->next; - f = f->next; - } - - break; - - default: - break; - } - if (seen_goto && doloop_level > 0) - doloop_list[doloop_level-1].seen_goto = true; - - return 0; -} - -/* Callback function to warn about different things within DO loops. */ - -static int -do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - do_t *last; - - if (doloop_list.length () == 0) - return 0; - - if ((*e)->expr_type == EXPR_FUNCTION) - do_intent (e); - - last = &doloop_list.last(); - if (last->seen_goto && !warn_do_subscript) - return 0; - - if ((*e)->expr_type == EXPR_VARIABLE) - do_subscript (e); - - return 0; -} - -typedef struct -{ - gfc_symbol *sym; - mpz_t val; -} insert_index_t; - -/* Callback function - if the expression is the variable in data->sym, - replace it with a constant from data->val. */ - -static int -callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - insert_index_t *d; - gfc_expr *ex, *n; - - ex = (*e); - if (ex->expr_type != EXPR_VARIABLE) - return 0; - - d = (insert_index_t *) data; - if (ex->symtree->n.sym != d->sym) - return 0; - - n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where); - mpz_set (n->value.integer, d->val); - - gfc_free_expr (ex); - *e = n; - return 0; -} - -/* In the expression e, replace occurrences of the variable sym with - val. If this results in a constant expression, return true and - return the value in ret. Return false if the expression already - is a constant. Caller has to clear ret in that case. */ - -static bool -insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret) -{ - gfc_expr *n; - insert_index_t data; - bool rc; - - if (e->expr_type == EXPR_CONSTANT) - return false; - - n = gfc_copy_expr (e); - data.sym = sym; - mpz_init_set (data.val, val); - gfc_expr_walker (&n, callback_insert_index, (void *) &data); - - /* Suppress errors here - we could get errors here such as an - out of bounds access for arrays, see PR 90563. */ - gfc_push_suppress_errors (); - gfc_simplify_expr (n, 0); - gfc_pop_suppress_errors (); - - if (n->expr_type == EXPR_CONSTANT) - { - rc = true; - mpz_init_set (ret, n->value.integer); - } - else - rc = false; - - mpz_clear (data.val); - gfc_free_expr (n); - return rc; - -} - -/* Check array subscripts for possible out-of-bounds accesses in DO - loops with constant bounds. */ - -static int -do_subscript (gfc_expr **e) -{ - gfc_expr *v; - gfc_array_ref *ar; - gfc_ref *ref; - int i,j; - gfc_code *dl; - do_t *lp; - - v = *e; - /* Constants are already checked. */ - if (v->expr_type == EXPR_CONSTANT) - return 0; - - /* Wrong warnings will be generated in an associate list. */ - if (in_assoc_list) - return 0; - - /* We already warned about this. */ - if (v->do_not_warn) - return 0; - - v->do_not_warn = 1; - - for (ref = v->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) - { - ar = & ref->u.ar; - FOR_EACH_VEC_ELT (doloop_list, j, lp) - { - gfc_symbol *do_sym; - mpz_t do_start, do_step, do_end; - bool have_do_start, have_do_end; - bool error_not_proven; - int warn; - int sgn; - - dl = lp->c; - if (dl == NULL) - break; - - /* If we are within a branch, or a goto or equivalent - was seen in the DO loop before, then we cannot prove that - this expression is actually evaluated. Don't do anything - unless we want to see it all. */ - error_not_proven = lp->seen_goto - || lp->branch_level < if_level + select_level; - - if (error_not_proven && !warn_do_subscript) - break; - - if (error_not_proven) - warn = OPT_Wdo_subscript; - else - warn = 0; - - do_sym = dl->ext.iterator->var->symtree->n.sym; - if (do_sym->ts.type != BT_INTEGER) - continue; - - /* If we do not know about the stepsize, the loop may be zero trip. - Do not warn in this case. */ - - if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT) - { - sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0); - /* This can happen, but then the error has been - reported previously. */ - if (sgn == 0) - continue; - - mpz_init_set (do_step, dl->ext.iterator->step->value.integer); - } - - else - continue; - - if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT) - { - have_do_start = true; - mpz_init_set (do_start, dl->ext.iterator->start->value.integer); - } - else - have_do_start = false; - - if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT) - { - have_do_end = true; - mpz_init_set (do_end, dl->ext.iterator->end->value.integer); - } - else - have_do_end = false; - - if (!have_do_start && !have_do_end) - return 0; - - /* No warning inside a zero-trip loop. */ - if (have_do_start && have_do_end) - { - int cmp; - - cmp = mpz_cmp (do_end, do_start); - if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)) - break; - } - - /* May have to correct the end value if the step does not equal - one. */ - if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0) - { - mpz_t diff, rem; - - mpz_init (diff); - mpz_init (rem); - mpz_sub (diff, do_end, do_start); - mpz_tdiv_r (rem, diff, do_step); - mpz_sub (do_end, do_end, rem); - mpz_clear (diff); - mpz_clear (rem); - } - - for (i = 0; i< ar->dimen; i++) - { - mpz_t val; - if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start - && insert_index (ar->start[i], do_sym, do_start, val)) - { - if (ar->as->lower[i] - && ar->as->lower[i]->expr_type == EXPR_CONSTANT - && ar->as->lower[i]->ts.type == BT_INTEGER - && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) - gfc_warning (warn, "Array reference at %L out of bounds " - "(%ld < %ld) in loop beginning at %L", - &ar->start[i]->where, mpz_get_si (val), - mpz_get_si (ar->as->lower[i]->value.integer), - &doloop_list[j].c->loc); - - if (ar->as->upper[i] - && ar->as->upper[i]->expr_type == EXPR_CONSTANT - && ar->as->upper[i]->ts.type == BT_INTEGER - && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) - gfc_warning (warn, "Array reference at %L out of bounds " - "(%ld > %ld) in loop beginning at %L", - &ar->start[i]->where, mpz_get_si (val), - mpz_get_si (ar->as->upper[i]->value.integer), - &doloop_list[j].c->loc); - - mpz_clear (val); - } - - if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end - && insert_index (ar->start[i], do_sym, do_end, val)) - { - if (ar->as->lower[i] - && ar->as->lower[i]->expr_type == EXPR_CONSTANT - && ar->as->lower[i]->ts.type == BT_INTEGER - && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) - gfc_warning (warn, "Array reference at %L out of bounds " - "(%ld < %ld) in loop beginning at %L", - &ar->start[i]->where, mpz_get_si (val), - mpz_get_si (ar->as->lower[i]->value.integer), - &doloop_list[j].c->loc); - - if (ar->as->upper[i] - && ar->as->upper[i]->expr_type == EXPR_CONSTANT - && ar->as->upper[i]->ts.type == BT_INTEGER - && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) - gfc_warning (warn, "Array reference at %L out of bounds " - "(%ld > %ld) in loop beginning at %L", - &ar->start[i]->where, mpz_get_si (val), - mpz_get_si (ar->as->upper[i]->value.integer), - &doloop_list[j].c->loc); - - mpz_clear (val); - } - } - } - } - } - return 0; -} -/* Function for functions checking that we do not pass a DO variable - to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ - -static int -do_intent (gfc_expr **e) -{ - gfc_formal_arglist *f; - gfc_actual_arglist *a; - gfc_expr *expr; - gfc_code *dl; - do_t *lp; - int i; - gfc_symbol *sym; - - expr = *e; - if (expr->expr_type != EXPR_FUNCTION) - return 0; - - /* Intrinsic functions don't modify their arguments. */ - - if (expr->value.function.isym) - return 0; - - sym = expr->value.function.esym; - if (sym == NULL) - return 0; - - if (sym->attr.contained) - { - FOR_EACH_VEC_ELT (doloop_list, i, lp) - { - contained_info info; - gfc_namespace *ns; - - dl = lp->c; - info.do_var = dl->ext.iterator->var->symtree->n.sym; - info.procedure = sym; - info.where_do = expr->where; - /* Look contained procedures under the namespace of the - variable. */ - for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) - if (ns->proc_name && ns->proc_name == sym) - gfc_code_walker (&ns->code, doloop_contained_procedure_code, - dummy_expr_callback, &info); - } - } - - f = gfc_sym_get_dummy_args (sym); - - /* Without a formal arglist, there is only unknown INTENT, - which we don't check for. */ - if (f == NULL) - return 0; - - a = expr->value.function.actual; - - while (a && f) - { - FOR_EACH_VEC_ELT (doloop_list, i, lp) - { - gfc_symbol *do_sym; - dl = lp->c; - if (dl == NULL) - break; - - do_sym = dl->ext.iterator->var->symtree->n.sym; - - if (a->expr && a->expr->symtree - && a->expr->symtree->n.sym == do_sym) - { - if (f->sym->attr.intent == INTENT_OUT) - gfc_error_now ("Variable %qs at %L set to undefined value " - "inside loop beginning at %L as INTENT(OUT) " - "argument to function %qs", do_sym->name, - &a->expr->where, &doloop_list[i].c->loc, - expr->symtree->n.sym->name); - else if (f->sym->attr.intent == INTENT_INOUT) - gfc_error_now ("Variable %qs at %L not definable inside loop" - " beginning at %L as INTENT(INOUT) argument to" - " function %qs", do_sym->name, - &a->expr->where, &doloop_list[i].c->loc, - expr->symtree->n.sym->name); - } - } - a = a->next; - f = f->next; - } - - return 0; -} - -static void -doloop_warn (gfc_namespace *ns) -{ - gfc_code_walker (&ns->code, doloop_code, do_function, NULL); - - for (ns = ns->contained; ns; ns = ns->sibling) - { - if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - doloop_warn (ns); - } -} - -/* This selction deals with inlining calls to MATMUL. */ - -/* Replace calls to matmul outside of straight assignments with a temporary - variable so that later inlining will work. */ - -static int -matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - gfc_expr *e, *n; - bool *found = (bool *) data; - - e = *ep; - - if (e->expr_type != EXPR_FUNCTION - || e->value.function.isym == NULL - || e->value.function.isym->id != GFC_ISYM_MATMUL) - return 0; - - if (forall_level > 0 || iterator_level > 0 || in_omp_workshare - || in_omp_atomic || in_where || in_assoc_list) - return 0; - - /* Check if this is already in the form c = matmul(a,b). */ - - if ((*current_code)->expr2 == e) - return 0; - - n = create_var (e, "matmul"); - - /* If create_var is unable to create a variable (for example if - -fno-realloc-lhs is in force with a variable that does not have bounds - known at compile-time), just return. */ - - if (n == NULL) - return 0; - - *ep = n; - *found = true; - return 0; -} - -/* Set current_code and associated variables so that matmul_to_var_expr can - work. */ - -static int -matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - if (current_code != c) - { - current_code = c; - inserted_block = NULL; - changed_statement = NULL; - } - - return 0; -} - - -/* Take a statement of the shape c = matmul(a,b) and create temporaries - for a and b if there is a dependency between the arguments and the - result variable or if a or b are the result of calculations that cannot - be handled by the inliner. */ - -static int -matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_expr *expr1, *expr2; - gfc_code *co; - gfc_actual_arglist *a, *b; - bool a_tmp, b_tmp; - gfc_expr *matrix_a, *matrix_b; - bool conjg_a, conjg_b, transpose_a, transpose_b; - - co = *c; - - if (co->op != EXEC_ASSIGN) - return 0; - - if (forall_level > 0 || iterator_level > 0 || in_omp_workshare - || in_omp_atomic || in_where) - return 0; - - /* This has some duplication with inline_matmul_assign. This - is because the creation of temporary variables could still fail, - and inline_matmul_assign still needs to be able to handle these - cases. */ - expr1 = co->expr1; - expr2 = co->expr2; - - if (expr2->expr_type != EXPR_FUNCTION - || expr2->value.function.isym == NULL - || expr2->value.function.isym->id != GFC_ISYM_MATMUL) - return 0; - - a_tmp = false; - a = expr2->value.function.actual; - matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); - if (matrix_a != NULL) - { - if (matrix_a->expr_type == EXPR_VARIABLE - && (gfc_check_dependency (matrix_a, expr1, true) - || gfc_has_dimen_vector_ref (matrix_a))) - a_tmp = true; - } - else - a_tmp = true; - - b_tmp = false; - b = a->next; - matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); - if (matrix_b != NULL) - { - if (matrix_b->expr_type == EXPR_VARIABLE - && (gfc_check_dependency (matrix_b, expr1, true) - || gfc_has_dimen_vector_ref (matrix_b))) - b_tmp = true; - } - else - b_tmp = true; - - if (!a_tmp && !b_tmp) - return 0; - - current_code = c; - inserted_block = NULL; - changed_statement = NULL; - if (a_tmp) - { - gfc_expr *at; - at = create_var (a->expr,"mma"); - if (at) - a->expr = at; - } - if (b_tmp) - { - gfc_expr *bt; - bt = create_var (b->expr,"mmb"); - if (bt) - b->expr = bt; - } - return 0; -} - -/* Auxiliary function to build and simplify an array inquiry function. - dim is zero-based. */ - -static gfc_expr * -get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0) -{ - gfc_expr *fcn; - gfc_expr *dim_arg, *kind; - const char *name; - gfc_expr *ec; - - switch (id) - { - case GFC_ISYM_LBOUND: - name = "_gfortran_lbound"; - break; - - case GFC_ISYM_UBOUND: - name = "_gfortran_ubound"; - break; - - case GFC_ISYM_SIZE: - name = "_gfortran_size"; - break; - - default: - gcc_unreachable (); - } - - dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim); - if (okind != 0) - kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, - okind); - else - kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, - gfc_index_integer_kind); - - ec = gfc_copy_expr (e); - - /* No bounds checking, this will be done before the loops if -fcheck=bounds - is in effect. */ - ec->no_bounds_check = 1; - fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3, - ec, dim_arg, kind); - gfc_simplify_expr (fcn, 0); - fcn->no_bounds_check = 1; - return fcn; -} - -/* Builds a logical expression. */ - -static gfc_expr* -build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) -{ - gfc_typespec ts; - gfc_expr *res; - - ts.type = BT_LOGICAL; - ts.kind = gfc_default_logical_kind; - res = gfc_get_expr (); - res->where = e1->where; - res->expr_type = EXPR_OP; - res->value.op.op = op; - res->value.op.op1 = e1; - res->value.op.op2 = e2; - res->ts = ts; - - return res; -} - - -/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes - compatible typespecs. */ - -static gfc_expr * -get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) -{ - gfc_expr *res; - - res = gfc_get_expr (); - res->ts = e1->ts; - res->where = e1->where; - res->expr_type = EXPR_OP; - res->value.op.op = op; - res->value.op.op1 = e1; - res->value.op.op2 = e2; - gfc_simplify_expr (res, 0); - return res; -} - -/* Generate the IF statement for a runtime check if we want to do inlining or - not - putting in the code for both branches and putting it into the syntax - tree is the caller's responsibility. For fixed array sizes, this should be - removed by DCE. Only called for rank-two matrices A and B. */ - -static gfc_code * -inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a) -{ - gfc_expr *inline_limit; - gfc_code *if_1, *if_2, *else_2; - gfc_expr *b2, *a2, *a1, *m1, *m2; - gfc_typespec ts; - gfc_expr *cond; - - gcc_assert (rank_a == 1 || rank_a == 2); - - /* Calculation is done in real to avoid integer overflow. */ - - inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind, - &a->where); - mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE); - - /* Set the limit according to the rank. */ - mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1, - GFC_RND_MODE); - - a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1); - - /* For a_rank = 1, must use one as the size of a along the second - dimension as to avoid too much code duplication. */ - - if (rank_a == 2) - a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2); - else - a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1); - - b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2); - - gfc_clear_ts (&ts); - ts.type = BT_REAL; - ts.kind = gfc_default_real_kind; - gfc_convert_type_warn (a1, &ts, 2, 0); - gfc_convert_type_warn (a2, &ts, 2, 0); - gfc_convert_type_warn (b2, &ts, 2, 0); - - m1 = get_operand (INTRINSIC_TIMES, a1, a2); - m2 = get_operand (INTRINSIC_TIMES, m1, b2); - - cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit); - gfc_simplify_expr (cond, 0); - - else_2 = XCNEW (gfc_code); - else_2->op = EXEC_IF; - else_2->loc = a->where; - - if_2 = XCNEW (gfc_code); - if_2->op = EXEC_IF; - if_2->expr1 = cond; - if_2->loc = a->where; - if_2->block = else_2; - - if_1 = XCNEW (gfc_code); - if_1->op = EXEC_IF; - if_1->block = if_2; - if_1->loc = a->where; - - return if_1; -} - - -/* Insert code to issue a runtime error if the expressions are not equal. */ - -static gfc_code * -runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg) -{ - gfc_expr *cond; - gfc_code *if_1, *if_2; - gfc_code *c; - gfc_actual_arglist *a1, *a2, *a3; - - gcc_assert (e1->where.lb); - /* Build the call to runtime_error. */ - c = XCNEW (gfc_code); - c->op = EXEC_CALL; - c->loc = e1->where; - - /* Get a null-terminated message string. */ - - a1 = gfc_get_actual_arglist (); - a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where, - msg, strlen(msg)+1); - c->ext.actual = a1; - - /* Pass the value of the first expression. */ - a2 = gfc_get_actual_arglist (); - a2->expr = gfc_copy_expr (e1); - a1->next = a2; - - /* Pass the value of the second expression. */ - a3 = gfc_get_actual_arglist (); - a3->expr = gfc_copy_expr (e2); - a2->next = a3; - - gfc_check_fe_runtime_error (c->ext.actual); - gfc_resolve_fe_runtime_error (c); - - if_2 = XCNEW (gfc_code); - if_2->op = EXEC_IF; - if_2->loc = e1->where; - if_2->next = c; - - if_1 = XCNEW (gfc_code); - if_1->op = EXEC_IF; - if_1->block = if_2; - if_1->loc = e1->where; - - cond = build_logical_expr (INTRINSIC_NE, e1, e2); - gfc_simplify_expr (cond, 0); - if_2->expr1 = cond; - - return if_1; -} - -/* Handle matrix reallocation. Caller is responsible to insert into - the code tree. - - For the two-dimensional case, build - - if (allocated(c)) then - if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then - deallocate(c) - allocate (c(size(a,1), size(b,2))) - end if - else - allocate (c(size(a,1),size(b,2))) - end if - - and for the other cases correspondingly. -*/ - -static gfc_code * -matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, - enum matrix_case m_case) -{ - - gfc_expr *allocated, *alloc_expr; - gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2; - gfc_code *else_alloc; - gfc_code *deallocate, *allocate1, *allocate_else; - gfc_array_ref *ar; - gfc_expr *cond, *ne1, *ne2; - - if (warn_realloc_lhs) - gfc_warning (OPT_Wrealloc_lhs, - "Code for reallocating the allocatable array at %L will " - "be added", &c->where); - - alloc_expr = gfc_copy_expr (c); - - ar = gfc_find_array_ref (alloc_expr); - gcc_assert (ar && ar->type == AR_FULL); - - /* c comes in as a full ref. Change it into a copy and make it into an - element ref so it has the right form for ALLOCATE. In the same - switch statement, also generate the size comparison for the secod IF - statement. */ - - ar->type = AR_ELEMENT; - - switch (m_case) - { - case A2B2: - ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); - ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); - ne1 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 1), - get_array_inq_function (GFC_ISYM_SIZE, a, 1)); - ne2 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 2), - get_array_inq_function (GFC_ISYM_SIZE, b, 2)); - cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); - break; - - case A2B2T: - ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); - ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); - - ne1 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 1), - get_array_inq_function (GFC_ISYM_SIZE, a, 1)); - ne2 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 2), - get_array_inq_function (GFC_ISYM_SIZE, b, 1)); - cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); - break; - - case A2TB2: - - ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); - ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); - - ne1 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 1), - get_array_inq_function (GFC_ISYM_SIZE, a, 2)); - ne2 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 2), - get_array_inq_function (GFC_ISYM_SIZE, b, 2)); - cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); - break; - - case A2B1: - ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); - cond = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 1), - get_array_inq_function (GFC_ISYM_SIZE, a, 2)); - break; - - case A1B2: - ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); - cond = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 1), - get_array_inq_function (GFC_ISYM_SIZE, b, 2)); - break; - - case A2TB2T: - /* This can only happen for BLAS, we do not handle that case in - inline mamtul. */ - ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); - ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); - - ne1 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 1), - get_array_inq_function (GFC_ISYM_SIZE, a, 2)); - ne2 = build_logical_expr (INTRINSIC_NE, - get_array_inq_function (GFC_ISYM_SIZE, c, 2), - get_array_inq_function (GFC_ISYM_SIZE, b, 1)); - - cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); - break; - - default: - gcc_unreachable(); - - } - - gfc_simplify_expr (cond, 0); - - /* We need two identical allocate statements in two - branches of the IF statement. */ - - allocate1 = XCNEW (gfc_code); - allocate1->op = EXEC_ALLOCATE; - allocate1->ext.alloc.list = gfc_get_alloc (); - allocate1->loc = c->where; - allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr); - - allocate_else = XCNEW (gfc_code); - allocate_else->op = EXEC_ALLOCATE; - allocate_else->ext.alloc.list = gfc_get_alloc (); - allocate_else->loc = c->where; - allocate_else->ext.alloc.list->expr = alloc_expr; - - allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED, - "_gfortran_allocated", c->where, - 1, gfc_copy_expr (c)); - - deallocate = XCNEW (gfc_code); - deallocate->op = EXEC_DEALLOCATE; - deallocate->ext.alloc.list = gfc_get_alloc (); - deallocate->ext.alloc.list->expr = gfc_copy_expr (c); - deallocate->next = allocate1; - deallocate->loc = c->where; - - if_size_2 = XCNEW (gfc_code); - if_size_2->op = EXEC_IF; - if_size_2->expr1 = cond; - if_size_2->loc = c->where; - if_size_2->next = deallocate; - - if_size_1 = XCNEW (gfc_code); - if_size_1->op = EXEC_IF; - if_size_1->block = if_size_2; - if_size_1->loc = c->where; - - else_alloc = XCNEW (gfc_code); - else_alloc->op = EXEC_IF; - else_alloc->loc = c->where; - else_alloc->next = allocate_else; - - if_alloc_2 = XCNEW (gfc_code); - if_alloc_2->op = EXEC_IF; - if_alloc_2->expr1 = allocated; - if_alloc_2->loc = c->where; - if_alloc_2->next = if_size_1; - if_alloc_2->block = else_alloc; - - if_alloc_1 = XCNEW (gfc_code); - if_alloc_1->op = EXEC_IF; - if_alloc_1->block = if_alloc_2; - if_alloc_1->loc = c->where; - - return if_alloc_1; -} - -/* Callback function for has_function_or_op. */ - -static int -is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - if ((*e) == 0) - return 0; - else - return (*e)->expr_type == EXPR_FUNCTION - || (*e)->expr_type == EXPR_OP; -} - -/* Returns true if the expression contains a function. */ - -static bool -has_function_or_op (gfc_expr **e) -{ - if (e == NULL) - return false; - else - return gfc_expr_walker (e, is_function_or_op, NULL); -} - -/* Freeze (assign to a temporary variable) a single expression. */ - -static void -freeze_expr (gfc_expr **ep) -{ - gfc_expr *ne; - if (has_function_or_op (ep)) - { - ne = create_var (*ep, "freeze"); - *ep = ne; - } -} - -/* Go through an expression's references and assign them to temporary - variables if they contain functions. This is usually done prior to - front-end scalarization to avoid multiple invocations of functions. */ - -static void -freeze_references (gfc_expr *e) -{ - gfc_ref *r; - gfc_array_ref *ar; - int i; - - for (r=e->ref; r; r=r->next) - { - if (r->type == REF_SUBSTRING) - { - if (r->u.ss.start != NULL) - freeze_expr (&r->u.ss.start); - - if (r->u.ss.end != NULL) - freeze_expr (&r->u.ss.end); - } - else if (r->type == REF_ARRAY) - { - ar = &r->u.ar; - switch (ar->type) - { - case AR_FULL: - break; - - case AR_SECTION: - for (i=0; idimen; i++) - { - if (ar->dimen_type[i] == DIMEN_RANGE) - { - freeze_expr (&ar->start[i]); - freeze_expr (&ar->end[i]); - freeze_expr (&ar->stride[i]); - } - else if (ar->dimen_type[i] == DIMEN_ELEMENT) - { - freeze_expr (&ar->start[i]); - } - } - break; - - case AR_ELEMENT: - for (i=0; idimen; i++) - freeze_expr (&ar->start[i]); - break; - - default: - break; - } - } - } -} - -/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */ - -static gfc_expr * -convert_to_index_kind (gfc_expr *e) -{ - gfc_expr *res; - - gcc_assert (e != NULL); - - res = gfc_copy_expr (e); - - gcc_assert (e->ts.type == BT_INTEGER); - - if (res->ts.kind != gfc_index_integer_kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = gfc_index_integer_kind; - - gfc_convert_type_warn (e, &ts, 2, 0); - } - - return res; -} - -/* Function to create a DO loop including creation of the - iteration variable. gfc_expr are copied.*/ - -static gfc_code * -create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where, - gfc_namespace *ns, char *vname) -{ - - char name[GFC_MAX_SYMBOL_LEN +1]; - gfc_symtree *symtree; - gfc_symbol *symbol; - gfc_expr *i; - gfc_code *n, *n2; - - /* Create an expression for the iteration variable. */ - if (vname) - sprintf (name, "__var_%d_do_%s", var_num++, vname); - else - sprintf (name, "__var_%d_do", var_num++); - - - if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) - gcc_unreachable (); - - /* Create the loop variable. */ - - symbol = symtree->n.sym; - symbol->ts.type = BT_INTEGER; - symbol->ts.kind = gfc_index_integer_kind; - symbol->attr.flavor = FL_VARIABLE; - symbol->attr.referenced = 1; - symbol->attr.dimension = 0; - symbol->attr.fe_temp = 1; - gfc_commit_symbol (symbol); - - i = gfc_get_expr (); - i->expr_type = EXPR_VARIABLE; - i->ts = symbol->ts; - i->rank = 0; - i->where = *where; - i->symtree = symtree; - - /* ... and the nested DO statements. */ - n = XCNEW (gfc_code); - n->op = EXEC_DO; - n->loc = *where; - n->ext.iterator = gfc_get_iterator (); - n->ext.iterator->var = i; - n->ext.iterator->start = convert_to_index_kind (start); - n->ext.iterator->end = convert_to_index_kind (end); - if (step) - n->ext.iterator->step = convert_to_index_kind (step); - else - n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind, - where, 1); - - n2 = XCNEW (gfc_code); - n2->op = EXEC_DO; - n2->loc = *where; - n2->next = NULL; - n->block = n2; - return n; -} - -/* Get the upper bound of the DO loops for matmul along a dimension. This - is one-based. */ - -static gfc_expr* -get_size_m1 (gfc_expr *e, int dimen) -{ - mpz_t size; - gfc_expr *res; - - if (gfc_array_dimen_size (e, dimen - 1, &size)) - { - res = gfc_get_constant_expr (BT_INTEGER, - gfc_index_integer_kind, &e->where); - mpz_sub_ui (res->value.integer, size, 1); - mpz_clear (size); - } - else - { - res = get_operand (INTRINSIC_MINUS, - get_array_inq_function (GFC_ISYM_SIZE, e, dimen), - gfc_get_int_expr (gfc_index_integer_kind, - &e->where, 1)); - gfc_simplify_expr (res, 0); - } - - return res; -} - -/* Function to return a scalarized expression. It is assumed that indices are - zero based to make generation of DO loops easier. A zero as index will - access the first element along a dimension. Single element references will - be skipped. A NULL as an expression will be replaced by a full reference. - This assumes that the index loops have gfc_index_integer_kind, and that all - references have been frozen. */ - -static gfc_expr* -scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) -{ - gfc_array_ref *ar; - int i; - int rank; - gfc_expr *e; - int i_index; - bool was_fullref; - - e = gfc_copy_expr(e_in); - - rank = e->rank; - - ar = gfc_find_array_ref (e); - - /* We scalarize count_index variables, reducing the rank by count_index. */ - - e->rank = rank - count_index; - - was_fullref = ar->type == AR_FULL; - - if (e->rank == 0) - ar->type = AR_ELEMENT; - else - ar->type = AR_SECTION; - - /* Loop over the indices. For each index, create the expression - index * stride + lbound(e, dim). */ - - i_index = 0; - for (i=0; i < ar->dimen; i++) - { - if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE) - { - if (index[i_index] != NULL) - { - gfc_expr *lbound, *nindex; - gfc_expr *loopvar; - - loopvar = gfc_copy_expr (index[i_index]); - - if (ar->stride[i]) - { - gfc_expr *tmp; - - tmp = gfc_copy_expr(ar->stride[i]); - if (tmp->ts.kind != gfc_index_integer_kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = gfc_index_integer_kind; - gfc_convert_type (tmp, &ts, 2); - } - nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp); - } - else - nindex = loopvar; - - /* Calculate the lower bound of the expression. */ - if (ar->start[i]) - { - lbound = gfc_copy_expr (ar->start[i]); - if (lbound->ts.kind != gfc_index_integer_kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = gfc_index_integer_kind; - gfc_convert_type (lbound, &ts, 2); - - } - } - else - { - gfc_expr *lbound_e; - gfc_ref *ref; - - lbound_e = gfc_copy_expr (e_in); - - for (ref = lbound_e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY - && (ref->u.ar.type == AR_FULL - || ref->u.ar.type == AR_SECTION)) - break; - - if (ref->next) - { - gfc_free_ref_list (ref->next); - ref->next = NULL; - } - - if (!was_fullref) - { - /* Look at full individual sections, like a(:). The first index - is the lbound of a full ref. */ - int j; - gfc_array_ref *ar; - int to; - - ar = &ref->u.ar; - - /* For assumed size, we need to keep around the final - reference in order not to get an error on resolution - below, and we cannot use AR_FULL. */ - - if (ar->as->type == AS_ASSUMED_SIZE) - { - ar->type = AR_SECTION; - to = ar->dimen - 1; - } - else - { - to = ar->dimen; - ar->type = AR_FULL; - } - - for (j = 0; j < to; j++) - { - gfc_free_expr (ar->start[j]); - ar->start[j] = NULL; - gfc_free_expr (ar->end[j]); - ar->end[j] = NULL; - gfc_free_expr (ar->stride[j]); - ar->stride[j] = NULL; - } - - /* We have to get rid of the shape, if there is one. Do - so by freeing it and calling gfc_resolve to rebuild - it, if necessary. */ - - if (lbound_e->shape) - gfc_free_shape (&(lbound_e->shape), lbound_e->rank); - - lbound_e->rank = ar->dimen; - gfc_resolve_expr (lbound_e); - } - lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e, - i + 1); - gfc_free_expr (lbound_e); - } - - ar->dimen_type[i] = DIMEN_ELEMENT; - - gfc_free_expr (ar->start[i]); - ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound); - - gfc_free_expr (ar->end[i]); - ar->end[i] = NULL; - gfc_free_expr (ar->stride[i]); - ar->stride[i] = NULL; - gfc_simplify_expr (ar->start[i], 0); - } - else if (was_fullref) - { - gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented"); - } - i_index ++; - } - } - - /* Bounds checking will be done before the loops if -fcheck=bounds - is in effect. */ - e->no_bounds_check = 1; - return e; -} - -/* Helper function to check for a dimen vector as subscript. */ - -bool -gfc_has_dimen_vector_ref (gfc_expr *e) -{ - gfc_array_ref *ar; - int i; - - ar = gfc_find_array_ref (e); - gcc_assert (ar); - if (ar->type == AR_FULL) - return false; - - for (i=0; idimen; i++) - if (ar->dimen_type[i] == DIMEN_VECTOR) - return true; - - return false; -} - -/* If handed an expression of the form - - TRANSPOSE(CONJG(A)) - - check if A can be handled by matmul and return if there is an uneven number - of CONJG calls. Return a pointer to the array when everything is OK, NULL - otherwise. The caller has to check for the correct rank. */ - -static gfc_expr* -check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose) -{ - *conjg = false; - *transpose = false; - - do - { - if (e->expr_type == EXPR_VARIABLE) - { - gcc_assert (e->rank == 1 || e->rank == 2); - return e; - } - else if (e->expr_type == EXPR_FUNCTION) - { - if (e->value.function.isym == NULL) - return NULL; - - if (e->value.function.isym->id == GFC_ISYM_CONJG) - *conjg = !*conjg; - else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE) - *transpose = !*transpose; - else return NULL; - } - else - return NULL; - - e = e->value.function.actual->expr; - } - while(1); - - return NULL; -} - -/* Macros for unified error messages. */ - -#define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \ - "dimension 1: is %ld, should be %ld") - -#define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \ - "(%ld/%ld)") - -#define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \ - "(%ld/%ld)") - - -/* Inline assignments of the form c = matmul(a,b). - Handle only the cases currently where b and c are rank-two arrays. - - This basically translates the code to - - BLOCK - integer i,j,k - c = 0 - do j=0, size(b,2)-1 - do k=0, size(a, 2)-1 - do i=0, size(a, 1)-1 - c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) = - c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) + - a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) * - b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2)) - end do - end do - end do - END BLOCK - -*/ - -static int -inline_matmul_assign (gfc_code **c, int *walk_subtrees, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code *co = *c; - gfc_expr *expr1, *expr2; - gfc_expr *matrix_a, *matrix_b; - gfc_actual_arglist *a, *b; - gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul; - gfc_expr *zero_e; - gfc_expr *u1, *u2, *u3; - gfc_expr *list[2]; - gfc_expr *ascalar, *bscalar, *cscalar; - gfc_expr *mult; - gfc_expr *var_1, *var_2, *var_3; - gfc_expr *zero; - gfc_namespace *ns; - gfc_intrinsic_op op_times, op_plus; - enum matrix_case m_case; - int i; - gfc_code *if_limit = NULL; - gfc_code **next_code_point; - bool conjg_a, conjg_b, transpose_a, transpose_b; - bool realloc_c; - - if (co->op != EXEC_ASSIGN) - return 0; - - if (in_where || in_assoc_list) - return 0; - - /* The BLOCKS generated for the temporary variables and FORALL don't - mix. */ - if (forall_level > 0) - return 0; - - /* For now don't do anything in OpenMP workshare, it confuses - its translation, which expects only the allowed statements in there. - We should figure out how to parallelize this eventually. */ - if (in_omp_workshare || in_omp_atomic) - return 0; - - expr1 = co->expr1; - expr2 = co->expr2; - if (expr2->expr_type != EXPR_FUNCTION - || expr2->value.function.isym == NULL - || expr2->value.function.isym->id != GFC_ISYM_MATMUL) - return 0; - - current_code = c; - inserted_block = NULL; - changed_statement = NULL; - - a = expr2->value.function.actual; - matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); - if (matrix_a == NULL) - return 0; - - b = a->next; - matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); - if (matrix_b == NULL) - return 0; - - if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a) - || gfc_has_dimen_vector_ref (matrix_b)) - return 0; - - /* We do not handle data dependencies yet. */ - if (gfc_check_dependency (expr1, matrix_a, true) - || gfc_check_dependency (expr1, matrix_b, true)) - return 0; - - m_case = none; - if (matrix_a->rank == 2) - { - if (transpose_a) - { - if (matrix_b->rank == 2 && !transpose_b) - m_case = A2TB2; - } - else - { - if (matrix_b->rank == 1) - m_case = A2B1; - else /* matrix_b->rank == 2 */ - { - if (transpose_b) - m_case = A2B2T; - else - m_case = A2B2; - } - } - } - else /* matrix_a->rank == 1 */ - { - if (matrix_b->rank == 2) - { - if (!transpose_b) - m_case = A1B2; - } - } - - if (m_case == none) - return 0; - - /* We only handle assignment to numeric or logical variables. */ - switch(expr1->ts.type) - { - case BT_INTEGER: - case BT_LOGICAL: - case BT_REAL: - case BT_COMPLEX: - break; - - default: - return 0; - } - - ns = insert_block (); - - /* Assign the type of the zero expression for initializing the resulting - array, and the expression (+ and * for real, integer and complex; - .and. and .or for logical. */ - - switch(expr1->ts.type) - { - case BT_INTEGER: - zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0); - op_times = INTRINSIC_TIMES; - op_plus = INTRINSIC_PLUS; - break; - - case BT_LOGICAL: - op_times = INTRINSIC_AND; - op_plus = INTRINSIC_OR; - zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where, - 0); - break; - case BT_REAL: - zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind, - &expr1->where); - mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE); - op_times = INTRINSIC_TIMES; - op_plus = INTRINSIC_PLUS; - break; - - case BT_COMPLEX: - zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind, - &expr1->where); - mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE); - op_times = INTRINSIC_TIMES; - op_plus = INTRINSIC_PLUS; - - break; - - default: - gcc_unreachable(); - } - - current_code = &ns->code; - - /* Freeze the references, keeping track of how many temporary variables were - created. */ - n_vars = 0; - freeze_references (matrix_a); - freeze_references (matrix_b); - freeze_references (expr1); - - if (n_vars == 0) - next_code_point = current_code; - else - { - next_code_point = &ns->code; - for (i=0; inext; - } - - /* Take care of the inline flag. If the limit check evaluates to a - constant, dead code elimination will eliminate the unneeded branch. */ - - if (flag_inline_matmul_limit > 0 - && (matrix_a->rank == 1 || matrix_a->rank == 2) - && matrix_b->rank == 2) - { - if_limit = inline_limit_check (matrix_a, matrix_b, - flag_inline_matmul_limit, - matrix_a->rank); - - /* Insert the original statement into the else branch. */ - if_limit->block->block->next = co; - co->next = NULL; - - /* ... and the new ones go into the original one. */ - *next_code_point = if_limit; - next_code_point = &if_limit->block->next; - } - - zero_e->no_bounds_check = 1; - - assign_zero = XCNEW (gfc_code); - assign_zero->op = EXEC_ASSIGN; - assign_zero->loc = co->loc; - assign_zero->expr1 = gfc_copy_expr (expr1); - assign_zero->expr1->no_bounds_check = 1; - assign_zero->expr2 = zero_e; - - realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); - - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - gfc_code *test; - gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; - - switch (m_case) - { - case A2B1: - - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - test = runtime_error_ne (b1, a2, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (c1, a1, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - case A1B2: - - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (b1, a1, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - test = runtime_error_ne (c1, b2, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - case A2B2: - - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - test = runtime_error_ne (b1, a2, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (c1, a1, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - test = runtime_error_ne (c2, b2, C_ERROR_2); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - case A2B2T: - - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - /* matrix_b is transposed, hence dimension 1 for the error message. */ - test = runtime_error_ne (b2, a2, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (c1, a1, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - test = runtime_error_ne (c2, b1, C_ERROR_2); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - case A2TB2: - - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (b1, a1, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - test = runtime_error_ne (c1, a2, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - test = runtime_error_ne (c2, b2, C_ERROR_2); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - default: - gcc_unreachable (); - } - } - - /* Handle the reallocation, if needed. */ - - if (realloc_c) - { - gfc_code *lhs_alloc; - - lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); - - *next_code_point = lhs_alloc; - next_code_point = &lhs_alloc->next; - - } - - *next_code_point = assign_zero; - - zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0); - - assign_matmul = XCNEW (gfc_code); - assign_matmul->op = EXEC_ASSIGN; - assign_matmul->loc = co->loc; - - /* Get the bounds for the loops, create them and create the scalarized - expressions. */ - - switch (m_case) - { - case A2B2: - - u1 = get_size_m1 (matrix_b, 2); - u2 = get_size_m1 (matrix_a, 2); - u3 = get_size_m1 (matrix_a, 1); - - do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); - do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); - do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); - - do_1->block->next = do_2; - do_2->block->next = do_3; - do_3->block->next = assign_matmul; - - var_1 = do_1->ext.iterator->var; - var_2 = do_2->ext.iterator->var; - var_3 = do_3->ext.iterator->var; - - list[0] = var_3; - list[1] = var_1; - cscalar = scalarized_expr (co->expr1, list, 2); - - list[0] = var_3; - list[1] = var_2; - ascalar = scalarized_expr (matrix_a, list, 2); - - list[0] = var_2; - list[1] = var_1; - bscalar = scalarized_expr (matrix_b, list, 2); - - break; - - case A2B2T: - - u1 = get_size_m1 (matrix_b, 1); - u2 = get_size_m1 (matrix_a, 2); - u3 = get_size_m1 (matrix_a, 1); - - do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); - do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); - do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); - - do_1->block->next = do_2; - do_2->block->next = do_3; - do_3->block->next = assign_matmul; - - var_1 = do_1->ext.iterator->var; - var_2 = do_2->ext.iterator->var; - var_3 = do_3->ext.iterator->var; - - list[0] = var_3; - list[1] = var_1; - cscalar = scalarized_expr (co->expr1, list, 2); - - list[0] = var_3; - list[1] = var_2; - ascalar = scalarized_expr (matrix_a, list, 2); - - list[0] = var_1; - list[1] = var_2; - bscalar = scalarized_expr (matrix_b, list, 2); - - break; - - case A2TB2: - - u1 = get_size_m1 (matrix_a, 2); - u2 = get_size_m1 (matrix_b, 2); - u3 = get_size_m1 (matrix_a, 1); - - do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); - do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); - do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); - - do_1->block->next = do_2; - do_2->block->next = do_3; - do_3->block->next = assign_matmul; - - var_1 = do_1->ext.iterator->var; - var_2 = do_2->ext.iterator->var; - var_3 = do_3->ext.iterator->var; - - list[0] = var_1; - list[1] = var_2; - cscalar = scalarized_expr (co->expr1, list, 2); - - list[0] = var_3; - list[1] = var_1; - ascalar = scalarized_expr (matrix_a, list, 2); - - list[0] = var_3; - list[1] = var_2; - bscalar = scalarized_expr (matrix_b, list, 2); - - break; - - case A2B1: - u1 = get_size_m1 (matrix_b, 1); - u2 = get_size_m1 (matrix_a, 1); - - do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); - do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); - - do_1->block->next = do_2; - do_2->block->next = assign_matmul; - - var_1 = do_1->ext.iterator->var; - var_2 = do_2->ext.iterator->var; - - list[0] = var_2; - cscalar = scalarized_expr (co->expr1, list, 1); - - list[0] = var_2; - list[1] = var_1; - ascalar = scalarized_expr (matrix_a, list, 2); - - list[0] = var_1; - bscalar = scalarized_expr (matrix_b, list, 1); - - break; - - case A1B2: - u1 = get_size_m1 (matrix_b, 2); - u2 = get_size_m1 (matrix_a, 1); - - do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); - do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); - - do_1->block->next = do_2; - do_2->block->next = assign_matmul; - - var_1 = do_1->ext.iterator->var; - var_2 = do_2->ext.iterator->var; - - list[0] = var_1; - cscalar = scalarized_expr (co->expr1, list, 1); - - list[0] = var_2; - ascalar = scalarized_expr (matrix_a, list, 1); - - list[0] = var_2; - list[1] = var_1; - bscalar = scalarized_expr (matrix_b, list, 2); - - break; - - default: - gcc_unreachable(); - } - - /* Build the conjg call around the variables. Set the typespec manually - because gfc_build_intrinsic_call sometimes gets this wrong. */ - if (conjg_a) - { - gfc_typespec ts; - ts = matrix_a->ts; - ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", - matrix_a->where, 1, ascalar); - ascalar->ts = ts; - } - - if (conjg_b) - { - gfc_typespec ts; - ts = matrix_b->ts; - bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", - matrix_b->where, 1, bscalar); - bscalar->ts = ts; - } - /* First loop comes after the zero assignment. */ - assign_zero->next = do_1; - - /* Build the assignment expression in the loop. */ - assign_matmul->expr1 = gfc_copy_expr (cscalar); - - mult = get_operand (op_times, ascalar, bscalar); - assign_matmul->expr2 = get_operand (op_plus, cscalar, mult); - - /* If we don't want to keep the original statement around in - the else branch, we can free it. */ - - if (if_limit == NULL) - gfc_free_statements(co); - else - co->next = NULL; - - gfc_free_expr (zero); - *walk_subtrees = 0; - return 0; -} - -/* Change matmul function calls in the form of - - c = matmul(a,b) - - to the corresponding call to a BLAS routine, if applicable. */ - -static int -call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code *co, *co_next; - gfc_expr *expr1, *expr2; - gfc_expr *matrix_a, *matrix_b; - gfc_code *if_limit = NULL; - gfc_actual_arglist *a, *b; - bool conjg_a, conjg_b, transpose_a, transpose_b; - gfc_code *call; - const char *blas_name; - const char *transa, *transb; - gfc_expr *c1, *c2, *b1; - gfc_actual_arglist *actual, *next; - bt type; - int kind; - enum matrix_case m_case; - bool realloc_c; - gfc_code **next_code_point; - - /* Many of the tests for inline matmul also apply here. */ - - co = *c; - - if (co->op != EXEC_ASSIGN) - return 0; - - if (in_where || in_assoc_list) - return 0; - - /* The BLOCKS generated for the temporary variables and FORALL don't - mix. */ - if (forall_level > 0) - return 0; - - /* For now don't do anything in OpenMP workshare, it confuses - its translation, which expects only the allowed statements in there. */ - - if (in_omp_workshare || in_omp_atomic) - return 0; - - expr1 = co->expr1; - expr2 = co->expr2; - if (expr2->expr_type != EXPR_FUNCTION - || expr2->value.function.isym == NULL - || expr2->value.function.isym->id != GFC_ISYM_MATMUL) - return 0; - - type = expr2->ts.type; - kind = expr2->ts.kind; - - /* Guard against recursion. */ - - if (expr2->external_blas) - return 0; - - if (type != expr1->ts.type || kind != expr1->ts.kind) - return 0; - - if (type == BT_REAL) - { - if (kind == 4) - blas_name = "sgemm"; - else if (kind == 8) - blas_name = "dgemm"; - else - return 0; - } - else if (type == BT_COMPLEX) - { - if (kind == 4) - blas_name = "cgemm"; - else if (kind == 8) - blas_name = "zgemm"; - else - return 0; - } - else - return 0; - - a = expr2->value.function.actual; - if (a->expr->rank != 2) - return 0; - - b = a->next; - if (b->expr->rank != 2) - return 0; - - matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); - if (matrix_a == NULL) - return 0; - - if (transpose_a) - { - if (conjg_a) - transa = "C"; - else - transa = "T"; - } - else - transa = "N"; - - matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); - if (matrix_b == NULL) - return 0; - - if (transpose_b) - { - if (conjg_b) - transb = "C"; - else - transb = "T"; - } - else - transb = "N"; - - if (transpose_a) - { - if (transpose_b) - m_case = A2TB2T; - else - m_case = A2TB2; - } - else - { - if (transpose_b) - m_case = A2B2T; - else - m_case = A2B2; - } - - current_code = c; - inserted_block = NULL; - changed_statement = NULL; - - expr2->external_blas = 1; - - /* We do not handle data dependencies yet. */ - if (gfc_check_dependency (expr1, matrix_a, true) - || gfc_check_dependency (expr1, matrix_b, true)) - return 0; - - /* Generate the if statement and hang it into the tree. */ - if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2); - co_next = co->next; - (*current_code) = if_limit; - co->next = NULL; - if_limit->block->next = co; - - call = XCNEW (gfc_code); - call->loc = co->loc; - - /* Bounds checking - a bit simpler than for inlining since we only - have to take care of two-dimensional arrays here. */ - - realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); - next_code_point = &(if_limit->block->block->next); - - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - gfc_code *test; - // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; - gfc_expr *c1, *a1, *c2, *b2, *a2; - switch (m_case) - { - case A2B2: - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - test = runtime_error_ne (b1, a2, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (c1, a1, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - test = runtime_error_ne (c2, b2, C_ERROR_2); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - case A2B2T: - - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - /* matrix_b is transposed, hence dimension 1 for the error message. */ - test = runtime_error_ne (b2, a2, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (c1, a1, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - test = runtime_error_ne (c2, b1, C_ERROR_2); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - case A2TB2: - - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (b1, a1, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - test = runtime_error_ne (c1, a2, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - test = runtime_error_ne (c2, b2, C_ERROR_2); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - case A2TB2T: - b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); - a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); - test = runtime_error_ne (b2, a1, B_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - if (!realloc_c) - { - c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); - a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); - test = runtime_error_ne (c1, a2, C_ERROR_1); - *next_code_point = test; - next_code_point = &test->next; - - c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); - b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); - test = runtime_error_ne (c2, b1, C_ERROR_2); - *next_code_point = test; - next_code_point = &test->next; - } - break; - - default: - gcc_unreachable (); - } - } - - /* Handle the reallocation, if needed. */ - - if (realloc_c) - { - gfc_code *lhs_alloc; - - lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); - *next_code_point = lhs_alloc; - next_code_point = &lhs_alloc->next; - } - - *next_code_point = call; - if_limit->next = co_next; - - /* Set up the BLAS call. */ - - call->op = EXEC_CALL; - - gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true); - call->symtree->n.sym->attr.subroutine = 1; - call->symtree->n.sym->attr.procedure = 1; - call->symtree->n.sym->attr.flavor = FL_PROCEDURE; - call->resolved_sym = call->symtree->n.sym; - gfc_commit_symbol (call->resolved_sym); - - /* Argument TRANSA. */ - next = gfc_get_actual_arglist (); - next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, - transa, 1); - - call->ext.actual = next; - - /* Argument TRANSB. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, - transb, 1); - actual->next = next; - - c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1, - gfc_integer_4_kind); - c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2, - gfc_integer_4_kind); - - b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1, - gfc_integer_4_kind); - - /* Argument M. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = c1; - actual->next = next; - - /* Argument N. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = c2; - actual->next = next; - - /* Argument K. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = b1; - actual->next = next; - - /* Argument ALPHA - set to one. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = gfc_get_constant_expr (type, kind, &co->loc); - if (type == BT_REAL) - mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE); - else - mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE); - actual->next = next; - - /* Argument A. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = gfc_copy_expr (matrix_a); - actual->next = next; - - /* Argument LDA. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a), - 1, gfc_integer_4_kind); - actual->next = next; - - /* Argument B. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = gfc_copy_expr (matrix_b); - actual->next = next; - - /* Argument LDB. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b), - 1, gfc_integer_4_kind); - actual->next = next; - - /* Argument BETA - set to zero. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = gfc_get_constant_expr (type, kind, &co->loc); - if (type == BT_REAL) - mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE); - else - mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE); - actual->next = next; - - /* Argument C. */ - - actual = next; - next = gfc_get_actual_arglist (); - next->expr = gfc_copy_expr (expr1); - actual->next = next; - - /* Argument LDC. */ - actual = next; - next = gfc_get_actual_arglist (); - next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1), - 1, gfc_integer_4_kind); - actual->next = next; - - return 0; -} - - -/* Code for index interchange for loops which are grouped together in DO - CONCURRENT or FORALL statements. This is currently only applied if the - iterations are grouped together in a single statement. - - For this transformation, it is assumed that memory access in strides is - expensive, and that loops which access later indices (which access memory - in bigger strides) should be moved to the first loops. - - For this, a loop over all the statements is executed, counting the times - that the loop iteration values are accessed in each index. The loop - indices are then sorted to minimize access to later indices from inner - loops. */ - -/* Type for holding index information. */ - -typedef struct { - gfc_symbol *sym; - gfc_forall_iterator *fa; - int num; - int n[GFC_MAX_DIMENSIONS]; -} ind_type; - -/* Callback function to determine if an expression is the - corresponding variable. */ - -static int -has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data) -{ - gfc_expr *expr = *e; - gfc_symbol *sym; - - if (expr->expr_type != EXPR_VARIABLE) - return 0; - - sym = (gfc_symbol *) data; - return sym == expr->symtree->n.sym; -} - -/* Callback function to calculate the cost of a certain index. */ - -static int -index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - ind_type *ind; - gfc_expr *expr; - gfc_array_ref *ar; - gfc_ref *ref; - int i,j; - - expr = *e; - if (expr->expr_type != EXPR_VARIABLE) - return 0; - - ar = NULL; - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY) - { - ar = &ref->u.ar; - break; - } - } - if (ar == NULL || ar->type != AR_ELEMENT) - return 0; - - ind = (ind_type *) data; - for (i = 0; i < ar->dimen; i++) - { - for (j=0; ind[j].sym != NULL; j++) - { - if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym))) - ind[j].n[i]++; - } - } - return 0; -} - -/* Callback function for qsort, to sort the loop indices. */ - -static int -loop_comp (const void *e1, const void *e2) -{ - const ind_type *i1 = (const ind_type *) e1; - const ind_type *i2 = (const ind_type *) e2; - int i; - - for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--) - { - if (i1->n[i] != i2->n[i]) - return i1->n[i] - i2->n[i]; - } - /* All other things being equal, let's not change the ordering. */ - return i2->num - i1->num; -} - -/* Main function to do the index interchange. */ - -static int -index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code *co; - co = *c; - int n_iter; - gfc_forall_iterator *fa; - ind_type *ind; - int i, j; - - if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT) - return 0; - - n_iter = 0; - for (fa = co->ext.forall_iterator; fa; fa = fa->next) - n_iter ++; - - /* Nothing to reorder. */ - if (n_iter < 2) - return 0; - - ind = XALLOCAVEC (ind_type, n_iter + 1); - - i = 0; - for (fa = co->ext.forall_iterator; fa; fa = fa->next) - { - ind[i].sym = fa->var->symtree->n.sym; - ind[i].fa = fa; - for (j=0; jext.forall_iterator = fa = ind[0].fa; - for (i=1; inext = ind[i].fa; - fa = fa->next; - } - fa->next = NULL; - - if (flag_warn_frontend_loop_interchange) - { - for (i=1; i ind[i].num) - { - gfc_warning (OPT_Wfrontend_loop_interchange, - "Interchanging loops at %L", &co->loc); - break; - } - } - } - - return 0; -} - -#define WALK_SUBEXPR(NODE) \ - do \ - { \ - result = gfc_expr_walker (&(NODE), exprfn, data); \ - if (result) \ - return result; \ - } \ - while (0) -#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue - -/* Walk expression *E, calling EXPRFN on each expression in it. */ - -int -gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) -{ - while (*e) - { - int walk_subtrees = 1; - gfc_actual_arglist *a; - gfc_ref *r; - gfc_constructor *c; - - int result = exprfn (e, &walk_subtrees, data); - if (result) - return result; - if (walk_subtrees) - switch ((*e)->expr_type) - { - case EXPR_OP: - WALK_SUBEXPR ((*e)->value.op.op1); - WALK_SUBEXPR_TAIL ((*e)->value.op.op2); - /* No fallthru because of the tail recursion above. */ - case EXPR_FUNCTION: - for (a = (*e)->value.function.actual; a; a = a->next) - WALK_SUBEXPR (a->expr); - break; - case EXPR_COMPCALL: - case EXPR_PPC: - WALK_SUBEXPR ((*e)->value.compcall.base_object); - for (a = (*e)->value.compcall.actual; a; a = a->next) - WALK_SUBEXPR (a->expr); - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - for (c = gfc_constructor_first ((*e)->value.constructor); c; - c = gfc_constructor_next (c)) - { - if (c->iterator == NULL) - WALK_SUBEXPR (c->expr); - else - { - iterator_level ++; - WALK_SUBEXPR (c->expr); - iterator_level --; - WALK_SUBEXPR (c->iterator->var); - WALK_SUBEXPR (c->iterator->start); - WALK_SUBEXPR (c->iterator->end); - WALK_SUBEXPR (c->iterator->step); - } - } - - if ((*e)->expr_type != EXPR_ARRAY) - break; - - /* Fall through to the variable case in order to walk the - reference. */ - gcc_fallthrough (); - - case EXPR_SUBSTRING: - case EXPR_VARIABLE: - for (r = (*e)->ref; r; r = r->next) - { - gfc_array_ref *ar; - int i; - - switch (r->type) - { - case REF_ARRAY: - ar = &r->u.ar; - if (ar->type == AR_SECTION || ar->type == AR_ELEMENT) - { - for (i=0; i< ar->dimen; i++) - { - WALK_SUBEXPR (ar->start[i]); - WALK_SUBEXPR (ar->end[i]); - WALK_SUBEXPR (ar->stride[i]); - } - } - - break; - - case REF_SUBSTRING: - WALK_SUBEXPR (r->u.ss.start); - WALK_SUBEXPR (r->u.ss.end); - break; - - case REF_COMPONENT: - case REF_INQUIRY: - break; - } - } - - default: - break; - } - return 0; - } - return 0; -} - -#define WALK_SUBCODE(NODE) \ - do \ - { \ - result = gfc_code_walker (&(NODE), codefn, exprfn, data); \ - if (result) \ - return result; \ - } \ - while (0) - -/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN - on each expression in it. If any of the hooks returns non-zero, that - value is immediately returned. If the hook sets *WALK_SUBTREES to 0, - no subcodes or subexpressions are traversed. */ - -int -gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, - void *data) -{ - for (; *c; c = &(*c)->next) - { - int walk_subtrees = 1; - int result = codefn (c, &walk_subtrees, data); - if (result) - return result; - - if (walk_subtrees) - { - gfc_code *b; - gfc_actual_arglist *a; - gfc_code *co; - gfc_association_list *alist; - bool saved_in_omp_workshare; - bool saved_in_omp_atomic; - bool saved_in_where; - - /* There might be statement insertions before the current code, - which must not affect the expression walker. */ - - co = *c; - saved_in_omp_workshare = in_omp_workshare; - saved_in_omp_atomic = in_omp_atomic; - saved_in_where = in_where; - - switch (co->op) - { - - case EXEC_BLOCK: - WALK_SUBCODE (co->ext.block.ns->code); - if (co->ext.block.assoc) - { - bool saved_in_assoc_list = in_assoc_list; - - in_assoc_list = true; - for (alist = co->ext.block.assoc; alist; alist = alist->next) - WALK_SUBEXPR (alist->target); - - in_assoc_list = saved_in_assoc_list; - } - - break; - - case EXEC_DO: - doloop_level ++; - WALK_SUBEXPR (co->ext.iterator->var); - WALK_SUBEXPR (co->ext.iterator->start); - WALK_SUBEXPR (co->ext.iterator->end); - WALK_SUBEXPR (co->ext.iterator->step); - break; - - case EXEC_IF: - if_level ++; - break; - - case EXEC_WHERE: - in_where = true; - break; - - case EXEC_CALL: - case EXEC_ASSIGN_CALL: - for (a = co->ext.actual; a; a = a->next) - WALK_SUBEXPR (a->expr); - break; - - case EXEC_CALL_PPC: - WALK_SUBEXPR (co->expr1); - for (a = co->ext.actual; a; a = a->next) - WALK_SUBEXPR (a->expr); - break; - - case EXEC_SELECT: - WALK_SUBEXPR (co->expr1); - select_level ++; - for (b = co->block; b; b = b->block) - { - gfc_case *cp; - for (cp = b->ext.block.case_list; cp; cp = cp->next) - { - WALK_SUBEXPR (cp->low); - WALK_SUBEXPR (cp->high); - } - WALK_SUBCODE (b->next); - } - continue; - - case EXEC_ALLOCATE: - case EXEC_DEALLOCATE: - { - gfc_alloc *a; - for (a = co->ext.alloc.list; a; a = a->next) - WALK_SUBEXPR (a->expr); - break; - } - - case EXEC_FORALL: - case EXEC_DO_CONCURRENT: - { - gfc_forall_iterator *fa; - for (fa = co->ext.forall_iterator; fa; fa = fa->next) - { - WALK_SUBEXPR (fa->var); - WALK_SUBEXPR (fa->start); - WALK_SUBEXPR (fa->end); - WALK_SUBEXPR (fa->stride); - } - if (co->op == EXEC_FORALL) - forall_level ++; - break; - } - - case EXEC_OPEN: - WALK_SUBEXPR (co->ext.open->unit); - WALK_SUBEXPR (co->ext.open->file); - WALK_SUBEXPR (co->ext.open->status); - WALK_SUBEXPR (co->ext.open->access); - WALK_SUBEXPR (co->ext.open->form); - WALK_SUBEXPR (co->ext.open->recl); - WALK_SUBEXPR (co->ext.open->blank); - WALK_SUBEXPR (co->ext.open->position); - WALK_SUBEXPR (co->ext.open->action); - WALK_SUBEXPR (co->ext.open->delim); - WALK_SUBEXPR (co->ext.open->pad); - WALK_SUBEXPR (co->ext.open->iostat); - WALK_SUBEXPR (co->ext.open->iomsg); - WALK_SUBEXPR (co->ext.open->convert); - WALK_SUBEXPR (co->ext.open->decimal); - WALK_SUBEXPR (co->ext.open->encoding); - WALK_SUBEXPR (co->ext.open->round); - WALK_SUBEXPR (co->ext.open->sign); - WALK_SUBEXPR (co->ext.open->asynchronous); - WALK_SUBEXPR (co->ext.open->id); - WALK_SUBEXPR (co->ext.open->newunit); - WALK_SUBEXPR (co->ext.open->share); - WALK_SUBEXPR (co->ext.open->cc); - break; - - case EXEC_CLOSE: - WALK_SUBEXPR (co->ext.close->unit); - WALK_SUBEXPR (co->ext.close->status); - WALK_SUBEXPR (co->ext.close->iostat); - WALK_SUBEXPR (co->ext.close->iomsg); - break; - - case EXEC_BACKSPACE: - case EXEC_ENDFILE: - case EXEC_REWIND: - case EXEC_FLUSH: - WALK_SUBEXPR (co->ext.filepos->unit); - WALK_SUBEXPR (co->ext.filepos->iostat); - WALK_SUBEXPR (co->ext.filepos->iomsg); - break; - - case EXEC_INQUIRE: - WALK_SUBEXPR (co->ext.inquire->unit); - WALK_SUBEXPR (co->ext.inquire->file); - WALK_SUBEXPR (co->ext.inquire->iomsg); - WALK_SUBEXPR (co->ext.inquire->iostat); - WALK_SUBEXPR (co->ext.inquire->exist); - WALK_SUBEXPR (co->ext.inquire->opened); - WALK_SUBEXPR (co->ext.inquire->number); - WALK_SUBEXPR (co->ext.inquire->named); - WALK_SUBEXPR (co->ext.inquire->name); - WALK_SUBEXPR (co->ext.inquire->access); - WALK_SUBEXPR (co->ext.inquire->sequential); - WALK_SUBEXPR (co->ext.inquire->direct); - WALK_SUBEXPR (co->ext.inquire->form); - WALK_SUBEXPR (co->ext.inquire->formatted); - WALK_SUBEXPR (co->ext.inquire->unformatted); - WALK_SUBEXPR (co->ext.inquire->recl); - WALK_SUBEXPR (co->ext.inquire->nextrec); - WALK_SUBEXPR (co->ext.inquire->blank); - WALK_SUBEXPR (co->ext.inquire->position); - WALK_SUBEXPR (co->ext.inquire->action); - WALK_SUBEXPR (co->ext.inquire->read); - WALK_SUBEXPR (co->ext.inquire->write); - WALK_SUBEXPR (co->ext.inquire->readwrite); - WALK_SUBEXPR (co->ext.inquire->delim); - WALK_SUBEXPR (co->ext.inquire->encoding); - WALK_SUBEXPR (co->ext.inquire->pad); - WALK_SUBEXPR (co->ext.inquire->iolength); - WALK_SUBEXPR (co->ext.inquire->convert); - WALK_SUBEXPR (co->ext.inquire->strm_pos); - WALK_SUBEXPR (co->ext.inquire->asynchronous); - WALK_SUBEXPR (co->ext.inquire->decimal); - WALK_SUBEXPR (co->ext.inquire->pending); - WALK_SUBEXPR (co->ext.inquire->id); - WALK_SUBEXPR (co->ext.inquire->sign); - WALK_SUBEXPR (co->ext.inquire->size); - WALK_SUBEXPR (co->ext.inquire->round); - break; - - case EXEC_WAIT: - WALK_SUBEXPR (co->ext.wait->unit); - WALK_SUBEXPR (co->ext.wait->iostat); - WALK_SUBEXPR (co->ext.wait->iomsg); - WALK_SUBEXPR (co->ext.wait->id); - break; - - case EXEC_READ: - case EXEC_WRITE: - WALK_SUBEXPR (co->ext.dt->io_unit); - WALK_SUBEXPR (co->ext.dt->format_expr); - WALK_SUBEXPR (co->ext.dt->rec); - WALK_SUBEXPR (co->ext.dt->advance); - WALK_SUBEXPR (co->ext.dt->iostat); - WALK_SUBEXPR (co->ext.dt->size); - WALK_SUBEXPR (co->ext.dt->iomsg); - WALK_SUBEXPR (co->ext.dt->id); - WALK_SUBEXPR (co->ext.dt->pos); - WALK_SUBEXPR (co->ext.dt->asynchronous); - WALK_SUBEXPR (co->ext.dt->blank); - WALK_SUBEXPR (co->ext.dt->decimal); - WALK_SUBEXPR (co->ext.dt->delim); - WALK_SUBEXPR (co->ext.dt->pad); - WALK_SUBEXPR (co->ext.dt->round); - WALK_SUBEXPR (co->ext.dt->sign); - WALK_SUBEXPR (co->ext.dt->extra_comma); - break; - - case EXEC_OACC_ATOMIC: - case EXEC_OMP_ATOMIC: - in_omp_atomic = true; - break; - - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - - in_omp_workshare = false; - - /* This goto serves as a shortcut to avoid code - duplication or a larger if or switch statement. */ - goto check_omp_clauses; - - case EXEC_OMP_WORKSHARE: - case EXEC_OMP_PARALLEL_WORKSHARE: - - in_omp_workshare = true; - - /* Fall through */ - - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_LOOP: - case EXEC_OMP_ORDERED: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SINGLE: - case EXEC_OMP_END_SINGLE: - case EXEC_OMP_SIMD: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - - /* Come to this label only from the - EXEC_OMP_PARALLEL_* cases above. */ - - check_omp_clauses: - - if (co->ext.omp_clauses) - { - gfc_omp_namelist *n; - static int list_types[] - = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND, - OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM }; - size_t idx; - WALK_SUBEXPR (co->ext.omp_clauses->if_expr); - WALK_SUBEXPR (co->ext.omp_clauses->final_expr); - WALK_SUBEXPR (co->ext.omp_clauses->num_threads); - WALK_SUBEXPR (co->ext.omp_clauses->chunk_size); - WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr); - WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr); - WALK_SUBEXPR (co->ext.omp_clauses->num_teams_lower); - WALK_SUBEXPR (co->ext.omp_clauses->num_teams_upper); - WALK_SUBEXPR (co->ext.omp_clauses->device); - WALK_SUBEXPR (co->ext.omp_clauses->thread_limit); - WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size); - WALK_SUBEXPR (co->ext.omp_clauses->grainsize); - WALK_SUBEXPR (co->ext.omp_clauses->hint); - WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); - WALK_SUBEXPR (co->ext.omp_clauses->priority); - WALK_SUBEXPR (co->ext.omp_clauses->detach); - for (idx = 0; idx < OMP_IF_LAST; idx++) - WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]); - for (idx = 0; - idx < sizeof (list_types) / sizeof (list_types[0]); - idx++) - for (n = co->ext.omp_clauses->lists[list_types[idx]]; - n; n = n->next) - WALK_SUBEXPR (n->expr); - } - break; - default: - break; - } - - WALK_SUBEXPR (co->expr1); - WALK_SUBEXPR (co->expr2); - WALK_SUBEXPR (co->expr3); - WALK_SUBEXPR (co->expr4); - for (b = co->block; b; b = b->block) - { - WALK_SUBEXPR (b->expr1); - WALK_SUBEXPR (b->expr2); - WALK_SUBCODE (b->next); - } - - if (co->op == EXEC_FORALL) - forall_level --; - - if (co->op == EXEC_DO) - doloop_level --; - - if (co->op == EXEC_IF) - if_level --; - - if (co->op == EXEC_SELECT) - select_level --; - - in_omp_workshare = saved_in_omp_workshare; - in_omp_atomic = saved_in_omp_atomic; - in_where = saved_in_where; - } - } - return 0; -} - -/* As a post-resolution step, check that all global symbols which are - not declared in the source file match in their call signatures. - We do this by looping over the code (and expressions). The first call - we happen to find is assumed to be canonical. */ - - -/* Common tests for argument checking for both functions and subroutines. */ - -static int -check_externals_procedure (gfc_symbol *sym, locus *loc, - gfc_actual_arglist *actual) -{ - gfc_gsymbol *gsym; - gfc_symbol *def_sym = NULL; - - if (sym == NULL || sym->attr.is_bind_c) - return 0; - - if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) - return 0; - - if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) - return 0; - - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); - if (gsym == NULL) - return 0; - - if (gsym->ns) - gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); - - if (def_sym) - { - gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc); - return 0; - } - - /* First time we have seen this procedure called. Let's create an - "interface" from the call and put it into a new namespace. */ - gfc_namespace *save_ns; - gfc_symbol *new_sym; - - gsym->where = *loc; - save_ns = gfc_current_ns; - gsym->ns = gfc_get_namespace (gfc_current_ns, 0); - gsym->ns->proc_name = sym; - - gfc_get_symbol (sym->name, gsym->ns, &new_sym); - gcc_assert (new_sym); - new_sym->attr = sym->attr; - new_sym->attr.if_source = IFSRC_DECL; - gfc_current_ns = gsym->ns; - - gfc_get_formal_from_actual_arglist (new_sym, actual); - new_sym->declared_at = *loc; - gfc_current_ns = save_ns; - - return 0; - -} - -/* Callback for calls of external routines. */ - -static int -check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_code *co = *c; - gfc_symbol *sym; - locus *loc; - gfc_actual_arglist *actual; - - if (co->op != EXEC_CALL) - return 0; - - sym = co->resolved_sym; - loc = &co->loc; - actual = co->ext.actual; - - return check_externals_procedure (sym, loc, actual); - -} - -/* Callback for external functions. */ - -static int -check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data ATTRIBUTE_UNUSED) -{ - gfc_expr *e = *ep; - gfc_symbol *sym; - locus *loc; - gfc_actual_arglist *actual; - - if (e->expr_type != EXPR_FUNCTION) - return 0; - - sym = e->value.function.esym; - if (sym == NULL) - return 0; - - loc = &e->where; - actual = e->value.function.actual; - - return check_externals_procedure (sym, loc, actual); -} - -/* Function to check if any interface clashes with a global - identifier, to be invoked via gfc_traverse_ns. */ - -static void -check_against_globals (gfc_symbol *sym) -{ - gfc_gsymbol *gsym; - gfc_symbol *def_sym = NULL; - const char *sym_name; - char buf [200]; - - if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE - || sym->attr.generic || sym->error) - return; - - if (sym->binding_label) - sym_name = sym->binding_label; - else - sym_name = sym->name; - - gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name); - if (gsym && gsym->ns) - gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); - - if (!def_sym || def_sym->error || def_sym->attr.generic) - return; - - buf[0] = 0; - gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf), - NULL, NULL, NULL); - if (buf[0] != 0) - { - gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at, - &sym->declared_at); - sym->error = 1; - def_sym->error = 1; - } - -} - -/* Do the code-walkling part for gfc_check_externals. */ - -static void -gfc_check_externals0 (gfc_namespace *ns) -{ - gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); - - for (ns = ns->contained; ns; ns = ns->sibling) - { - if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - gfc_check_externals0 (ns); - } - -} - -/* Called routine. */ - -void -gfc_check_externals (gfc_namespace *ns) -{ - gfc_clear_error (); - - /* Turn errors into warnings if the user indicated this. */ - - if (!pedantic && flag_allow_argument_mismatch) - gfc_errors_to_warnings (true); - - gfc_check_externals0 (ns); - gfc_traverse_ns (ns, check_against_globals); - - gfc_errors_to_warnings (false); -} - -/* Callback function. If there is a call to a subroutine which is - neither pure nor implicit_pure, unset the implicit_pure flag for - the caller and return -1. */ - -static int -implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, - void *sym_data) -{ - gfc_code *co = *c; - gfc_symbol *caller_sym; - symbol_attribute *a; - - if (co->op != EXEC_CALL || co->resolved_sym == NULL) - return 0; - - a = &co->resolved_sym->attr; - if (a->intrinsic || a->pure || a->implicit_pure) - return 0; - - caller_sym = (gfc_symbol *) sym_data; - gfc_unset_implicit_pure (caller_sym); - return 1; -} - -/* Callback function. If there is a call to a function which is - neither pure nor implicit_pure, unset the implicit_pure flag for - the caller and return 1. */ - -static int -implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data) -{ - gfc_expr *expr = *e; - gfc_symbol *caller_sym; - gfc_symbol *sym; - symbol_attribute *a; - - if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym) - return 0; - - sym = expr->symtree->n.sym; - a = &sym->attr; - if (a->pure || a->implicit_pure) - return 0; - - caller_sym = (gfc_symbol *) sym_data; - gfc_unset_implicit_pure (caller_sym); - return 1; -} - -/* Go through all procedures in the namespace and unset the - implicit_pure attribute for any procedure that calls something not - pure or implicit pure. */ - -bool -gfc_fix_implicit_pure (gfc_namespace *ns) -{ - bool changed = false; - gfc_symbol *proc = ns->proc_name; - - if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure - && ns->code - && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr, - (void *) ns->proc_name)) - changed = true; - - for (ns = ns->contained; ns; ns = ns->sibling) - { - if (gfc_fix_implicit_pure (ns)) - changed = true; - } - - return changed; -} diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc new file mode 100644 index 0000000..22f1bb5 --- /dev/null +++ b/gcc/fortran/frontend-passes.cc @@ -0,0 +1,5951 @@ +/* Pass manager for Fortran front end. + Copyright (C) 2010-2022 Free Software Foundation, Inc. + Contributed by Thomas König. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "dependency.h" +#include "constructor.h" +#include "intrinsic.h" + +/* Forward declarations. */ + +static void strip_function_call (gfc_expr *); +static void optimize_namespace (gfc_namespace *); +static void optimize_assignment (gfc_code *); +static bool optimize_op (gfc_expr *); +static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op); +static bool optimize_trim (gfc_expr *); +static bool optimize_lexical_comparison (gfc_expr *); +static void optimize_minmaxloc (gfc_expr **); +static bool is_empty_string (gfc_expr *e); +static void doloop_warn (gfc_namespace *); +static int do_intent (gfc_expr **); +static int do_subscript (gfc_expr **); +static void optimize_reduction (gfc_namespace *); +static int callback_reduction (gfc_expr **, int *, void *); +static void realloc_strings (gfc_namespace *); +static gfc_expr *create_var (gfc_expr *, const char *vname=NULL); +static int matmul_to_var_expr (gfc_expr **, int *, void *); +static int matmul_to_var_code (gfc_code **, int *, void *); +static int inline_matmul_assign (gfc_code **, int *, void *); +static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, + locus *, gfc_namespace *, + char *vname=NULL); +static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *, + bool *); +static int call_external_blas (gfc_code **, int *, void *); +static int matmul_temp_args (gfc_code **, int *,void *data); +static int index_interchange (gfc_code **, int*, void *); +static bool is_fe_temp (gfc_expr *e); + +#ifdef CHECKING_P +static void check_locus (gfc_namespace *); +#endif + +/* How deep we are inside an argument list. */ + +static int count_arglist; + +/* Vector of gfc_expr ** we operate on. */ + +static vec expr_array; + +/* Pointer to the gfc_code we currently work on - to be able to insert + a block before the statement. */ + +static gfc_code **current_code; + +/* Pointer to the block to be inserted, and the statement we are + changing within the block. */ + +static gfc_code *inserted_block, **changed_statement; + +/* The namespace we are currently dealing with. */ + +static gfc_namespace *current_ns; + +/* If we are within any forall loop. */ + +static int forall_level; + +/* Keep track of whether we are within an OMP workshare. */ + +static bool in_omp_workshare; + +/* Keep track of whether we are within an OMP atomic. */ + +static bool in_omp_atomic; + +/* Keep track of whether we are within a WHERE statement. */ + +static bool in_where; + +/* Keep track of iterators for array constructors. */ + +static int iterator_level; + +/* Keep track of DO loop levels. */ + +typedef struct { + gfc_code *c; + int branch_level; + bool seen_goto; +} do_t; + +static vec doloop_list; +static int doloop_level; + +/* Keep track of if and select case levels. */ + +static int if_level; +static int select_level; + +/* Vector of gfc_expr * to keep track of DO loops. */ + +struct my_struct *evec; + +/* Keep track of association lists. */ + +static bool in_assoc_list; + +/* Counter for temporary variables. */ + +static int var_num = 1; + +/* What sort of matrix we are dealing with when inlining MATMUL. */ + +enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T }; + +/* Keep track of the number of expressions we have inserted so far + using create_var. */ + +int n_vars; + +/* Entry point - run all passes for a namespace. */ + +void +gfc_run_passes (gfc_namespace *ns) +{ + + /* Warn about dubious DO loops where the index might + change. */ + + doloop_level = 0; + if_level = 0; + select_level = 0; + doloop_warn (ns); + doloop_list.release (); + int w, e; + +#ifdef CHECKING_P + check_locus (ns); +#endif + + gfc_get_errors (&w, &e); + if (e > 0) + return; + + if (flag_frontend_optimize || flag_frontend_loop_interchange) + optimize_namespace (ns); + + if (flag_frontend_optimize) + { + optimize_reduction (ns); + if (flag_dump_fortran_optimized) + gfc_dump_parse_tree (ns, stdout); + + expr_array.release (); + } + + if (flag_realloc_lhs) + realloc_strings (ns); +} + +#ifdef CHECKING_P + +/* Callback function: Warn if there is no location information in a + statement. */ + +static int +check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + current_code = c; + if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL))) + gfc_warning_internal (0, "Inconsistent internal state: " + "No location in statement"); + + return 0; +} + + +/* Callback function: Warn if there is no location information in an + expression. */ + +static int +check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + + if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL))) + gfc_warning_internal (0, "Inconsistent internal state: " + "No location in expression near %L", + &((*current_code)->loc)); + return 0; +} + +/* Run check for missing location information. */ + +static void +check_locus (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + check_locus (ns); + } +} + +#endif + +/* Callback for each gfc_code node invoked from check_realloc_strings. + For an allocatable LHS string which also appears as a variable on + the RHS, replace + + a = a(x:y) + + with + + tmp = a(x:y) + a = tmp + */ + +static int +realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_expr *expr1, *expr2; + gfc_code *co = *c; + gfc_expr *n; + gfc_ref *ref; + bool found_substr; + + if (co->op != EXEC_ASSIGN) + return 0; + + expr1 = co->expr1; + if (expr1->ts.type != BT_CHARACTER + || !gfc_expr_attr(expr1).allocatable + || !expr1->ts.deferred) + return 0; + + if (is_fe_temp (expr1)) + return 0; + + expr2 = gfc_discard_nops (co->expr2); + + if (expr2->expr_type == EXPR_VARIABLE) + { + found_substr = false; + for (ref = expr2->ref; ref; ref = ref->next) + { + if (ref->type == REF_SUBSTRING) + { + found_substr = true; + break; + } + } + if (!found_substr) + return 0; + } + else if (expr2->expr_type != EXPR_ARRAY + && (expr2->expr_type != EXPR_OP + || expr2->value.op.op != INTRINSIC_CONCAT)) + return 0; + + if (!gfc_check_dependency (expr1, expr2, true)) + return 0; + + /* gfc_check_dependency doesn't always pick up identical expressions. + However, eliminating the above sends the compiler into an infinite + loop on valid expressions. Without this check, the gimplifier emits + an ICE for a = a, where a is deferred character length. */ + if (!gfc_dep_compare_expr (expr1, expr2)) + return 0; + + current_code = c; + inserted_block = NULL; + changed_statement = NULL; + n = create_var (expr2, "realloc_string"); + co->expr2 = n; + return 0; +} + +/* Callback for each gfc_code node invoked through gfc_code_walker + from optimize_namespace. */ + +static int +optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + + gfc_exec_op op; + + op = (*c)->op; + + if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL + || op == EXEC_CALL_PPC) + count_arglist = 1; + else + count_arglist = 0; + + current_code = c; + inserted_block = NULL; + changed_statement = NULL; + + if (op == EXEC_ASSIGN) + optimize_assignment (*c); + return 0; +} + +/* Callback for each gfc_expr node invoked through gfc_code_walker + from optimize_namespace. */ + +static int +optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + bool function_expr; + + if ((*e)->expr_type == EXPR_FUNCTION) + { + count_arglist ++; + function_expr = true; + } + else + function_expr = false; + + if (optimize_trim (*e)) + gfc_simplify_expr (*e, 0); + + if (optimize_lexical_comparison (*e)) + gfc_simplify_expr (*e, 0); + + if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) + gfc_simplify_expr (*e, 0); + + if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym) + switch ((*e)->value.function.isym->id) + { + case GFC_ISYM_MINLOC: + case GFC_ISYM_MAXLOC: + optimize_minmaxloc (e); + break; + default: + break; + } + + if (function_expr) + count_arglist --; + + return 0; +} + +/* Auxiliary function to handle the arguments to reduction intrinsics. If the + function is a scalar, just copy it; otherwise returns the new element, the + old one can be freed. */ + +static gfc_expr * +copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn) +{ + gfc_expr *fcn, *e = c->expr; + + fcn = gfc_copy_expr (e); + if (c->iterator) + { + gfc_constructor_base newbase; + gfc_expr *new_expr; + gfc_constructor *new_c; + + newbase = NULL; + new_expr = gfc_get_expr (); + new_expr->expr_type = EXPR_ARRAY; + new_expr->ts = e->ts; + new_expr->where = e->where; + new_expr->rank = 1; + new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where)); + new_c->iterator = c->iterator; + new_expr->value.constructor = newbase; + c->iterator = NULL; + + fcn = new_expr; + } + + if (fcn->rank != 0) + { + gfc_isym_id id = fn->value.function.isym->id; + + if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) + fcn = gfc_build_intrinsic_call (current_ns, id, + fn->value.function.isym->name, + fn->where, 3, fcn, NULL, NULL); + else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL) + fcn = gfc_build_intrinsic_call (current_ns, id, + fn->value.function.isym->name, + fn->where, 2, fcn, NULL); + else + gfc_internal_error ("Illegal id in copy_walk_reduction_arg"); + + fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; + } + + return fcn; +} + +/* Callback function for optimzation of reductions to scalars. Transform ANY + ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT + correspondingly. Handly only the simple cases without MASK and DIM. */ + +static int +callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_expr *fn, *arg; + gfc_intrinsic_op op; + gfc_isym_id id; + gfc_actual_arglist *a; + gfc_actual_arglist *dim; + gfc_constructor *c; + gfc_expr *res, *new_expr; + gfc_actual_arglist *mask; + + fn = *e; + + if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION + || fn->value.function.isym == NULL) + return 0; + + id = fn->value.function.isym->id; + + if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT + && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL) + return 0; + + a = fn->value.function.actual; + + /* Don't handle MASK or DIM. */ + + dim = a->next; + + if (dim->expr != NULL) + return 0; + + if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) + { + mask = dim->next; + if ( mask->expr != NULL) + return 0; + } + + arg = a->expr; + + if (arg->expr_type != EXPR_ARRAY) + return 0; + + switch (id) + { + case GFC_ISYM_SUM: + op = INTRINSIC_PLUS; + break; + + case GFC_ISYM_PRODUCT: + op = INTRINSIC_TIMES; + break; + + case GFC_ISYM_ANY: + op = INTRINSIC_OR; + break; + + case GFC_ISYM_ALL: + op = INTRINSIC_AND; + break; + + default: + return 0; + } + + c = gfc_constructor_first (arg->value.constructor); + + /* Don't do any simplififcation if we have + - no element in the constructor or + - only have a single element in the array which contains an + iterator. */ + + if (c == NULL) + return 0; + + res = copy_walk_reduction_arg (c, fn); + + c = gfc_constructor_next (c); + while (c) + { + new_expr = gfc_get_expr (); + new_expr->ts = fn->ts; + new_expr->expr_type = EXPR_OP; + new_expr->rank = fn->rank; + new_expr->where = fn->where; + new_expr->value.op.op = op; + new_expr->value.op.op1 = res; + new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn); + res = new_expr; + c = gfc_constructor_next (c); + } + + gfc_simplify_expr (res, 0); + *e = res; + gfc_free_expr (fn); + + return 0; +} + +/* Callback function for common function elimination, called from cfe_expr_0. + Put all eligible function expressions into expr_array. */ + +static int +cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + + if ((*e)->expr_type != EXPR_FUNCTION) + return 0; + + /* We don't do character functions with unknown charlens. */ + if ((*e)->ts.type == BT_CHARACTER + && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL + || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) + return 0; + + /* We don't do function elimination within FORALL statements, it can + lead to wrong-code in certain circumstances. */ + + if (forall_level > 0) + return 0; + + /* Function elimination inside an iterator could lead to functions which + depend on iterator variables being moved outside. FIXME: We should check + if the functions do indeed depend on the iterator variable. */ + + if (iterator_level > 0) + return 0; + + /* If we don't know the shape at compile time, we create an allocatable + temporary variable to hold the intermediate result, but only if + allocation on assignment is active. */ + + if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs) + return 0; + + /* Skip the test for pure functions if -faggressive-function-elimination + is specified. */ + if ((*e)->value.function.esym) + { + /* Don't create an array temporary for elemental functions. */ + if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0) + return 0; + + /* Only eliminate potentially impure functions if the + user specifically requested it. */ + if (!flag_aggressive_function_elimination + && !(*e)->value.function.esym->attr.pure + && !(*e)->value.function.esym->attr.implicit_pure) + return 0; + } + + if ((*e)->value.function.isym) + { + /* Conversions are handled on the fly by the middle end, + transpose during trans-* stages and TRANSFER by the middle end. */ + if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION + || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER + || gfc_inline_intrinsic_function_p (*e)) + return 0; + + /* Don't create an array temporary for elemental functions, + as this would be wasteful of memory. + FIXME: Create a scalar temporary during scalarization. */ + if ((*e)->value.function.isym->elemental && (*e)->rank > 0) + return 0; + + if (!(*e)->value.function.isym->pure) + return 0; + } + + expr_array.safe_push (e); + return 0; +} + +/* Auxiliary function to check if an expression is a temporary created by + create var. */ + +static bool +is_fe_temp (gfc_expr *e) +{ + if (e->expr_type != EXPR_VARIABLE) + return false; + + return e->symtree->n.sym->attr.fe_temp; +} + +/* Determine the length of a string, if it can be evaluated as a constant + expression. Return a newly allocated gfc_expr or NULL on failure. + If the user specified a substring which is potentially longer than + the string itself, the string will be padded with spaces, which + is harmless. */ + +static gfc_expr * +constant_string_length (gfc_expr *e) +{ + + gfc_expr *length; + gfc_ref *ref; + gfc_expr *res; + mpz_t value; + + if (e->ts.u.cl) + { + length = e->ts.u.cl->length; + if (length && length->expr_type == EXPR_CONSTANT) + return gfc_copy_expr(length); + } + + /* See if there is a substring. If it has a constant length, return + that and NULL otherwise. */ + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_SUBSTRING) + { + if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value)) + { + res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, + &e->where); + + mpz_add_ui (res->value.integer, value, 1); + mpz_clear (value); + return res; + } + else + return NULL; + } + } + + /* Return length of char symbol, if constant. */ + if (e->symtree && e->symtree->n.sym->ts.u.cl + && e->symtree->n.sym->ts.u.cl->length + && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) + return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length); + + return NULL; + +} + +/* Insert a block at the current position unless it has already + been inserted; in this case use the one already there. */ + +static gfc_namespace* +insert_block () +{ + gfc_namespace *ns; + + /* If the block hasn't already been created, do so. */ + if (inserted_block == NULL) + { + inserted_block = XCNEW (gfc_code); + inserted_block->op = EXEC_BLOCK; + inserted_block->loc = (*current_code)->loc; + ns = gfc_build_block_ns (current_ns); + inserted_block->ext.block.ns = ns; + inserted_block->ext.block.assoc = NULL; + + ns->code = *current_code; + + /* If the statement has a label, make sure it is transferred to + the newly created block. */ + + if ((*current_code)->here) + { + inserted_block->here = (*current_code)->here; + (*current_code)->here = NULL; + } + + inserted_block->next = (*current_code)->next; + changed_statement = &(inserted_block->ext.block.ns->code); + (*current_code)->next = NULL; + /* Insert the BLOCK at the right position. */ + *current_code = inserted_block; + ns->parent = current_ns; + } + else + ns = inserted_block->ext.block.ns; + + return ns; +} + + +/* Insert a call to the intrinsic len. Use a different name for + the symbol tree so we don't run into trouble when the user has + renamed len for some reason. */ + +static gfc_expr* +get_len_call (gfc_expr *str) +{ + gfc_expr *fcn; + gfc_actual_arglist *actual_arglist; + + fcn = gfc_get_expr (); + fcn->expr_type = EXPR_FUNCTION; + fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN); + actual_arglist = gfc_get_actual_arglist (); + actual_arglist->expr = str; + + fcn->value.function.actual = actual_arglist; + fcn->where = str->where; + fcn->ts.type = BT_INTEGER; + fcn->ts.kind = gfc_charlen_int_kind; + + gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false); + fcn->symtree->n.sym->ts = fcn->ts; + fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; + fcn->symtree->n.sym->attr.function = 1; + fcn->symtree->n.sym->attr.elemental = 1; + fcn->symtree->n.sym->attr.referenced = 1; + fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; + gfc_commit_symbol (fcn->symtree->n.sym); + + return fcn; +} + + +/* Returns a new expression (a variable) to be used in place of the old one, + with an optional assignment statement before the current statement to set + the value of the variable. Creates a new BLOCK for the statement if that + hasn't already been done and puts the statement, plus the newly created + variables, in that block. Special cases: If the expression is constant or + a temporary which has already been created, just copy it. */ + +static gfc_expr* +create_var (gfc_expr * e, const char *vname) +{ + char name[GFC_MAX_SYMBOL_LEN +1]; + gfc_symtree *symtree; + gfc_symbol *symbol; + gfc_expr *result; + gfc_code *n; + gfc_namespace *ns; + int i; + bool deferred; + + if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e)) + return gfc_copy_expr (e); + + /* Creation of an array of unknown size requires realloc on assignment. + If that is not possible, just return NULL. */ + if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL) + return NULL; + + ns = insert_block (); + + if (vname) + snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname); + else + snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++); + + if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) + gcc_unreachable (); + + symbol = symtree->n.sym; + symbol->ts = e->ts; + + if (e->rank > 0) + { + symbol->as = gfc_get_array_spec (); + symbol->as->rank = e->rank; + + if (e->shape == NULL) + { + /* We don't know the shape at compile time, so we use an + allocatable. */ + symbol->as->type = AS_DEFERRED; + symbol->attr.allocatable = 1; + } + else + { + symbol->as->type = AS_EXPLICIT; + /* Copy the shape. */ + for (i=0; irank; i++) + { + gfc_expr *p, *q; + + p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &(e->where)); + mpz_set_si (p->value.integer, 1); + symbol->as->lower[i] = p; + + q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &(e->where)); + mpz_set (q->value.integer, e->shape[i]); + symbol->as->upper[i] = q; + } + } + } + + deferred = 0; + if (e->ts.type == BT_CHARACTER) + { + gfc_expr *length; + + symbol->ts.u.cl = gfc_new_charlen (ns, NULL); + length = constant_string_length (e); + if (length) + symbol->ts.u.cl->length = length; + else if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->ts.type == BT_CHARACTER + && e->ts.u.cl->length) + symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e)); + else + { + symbol->attr.allocatable = 1; + symbol->ts.u.cl->length = NULL; + symbol->ts.deferred = 1; + deferred = 1; + } + } + + symbol->attr.flavor = FL_VARIABLE; + symbol->attr.referenced = 1; + symbol->attr.dimension = e->rank > 0; + symbol->attr.fe_temp = 1; + gfc_commit_symbol (symbol); + + result = gfc_get_expr (); + result->expr_type = EXPR_VARIABLE; + result->ts = symbol->ts; + result->ts.deferred = deferred; + result->rank = e->rank; + result->shape = gfc_copy_shape (e->shape, e->rank); + result->symtree = symtree; + result->where = e->where; + if (e->rank > 0) + { + result->ref = gfc_get_ref (); + result->ref->type = REF_ARRAY; + result->ref->u.ar.type = AR_FULL; + result->ref->u.ar.where = e->where; + result->ref->u.ar.dimen = e->rank; + result->ref->u.ar.as = symbol->ts.type == BT_CLASS + ? CLASS_DATA (symbol)->as : symbol->as; + if (warn_array_temporaries) + gfc_warning (OPT_Warray_temporaries, + "Creating array temporary at %L", &(e->where)); + } + + /* Generate the new assignment. */ + n = XCNEW (gfc_code); + n->op = EXEC_ASSIGN; + n->loc = (*current_code)->loc; + n->next = *changed_statement; + n->expr1 = gfc_copy_expr (result); + n->expr2 = e; + *changed_statement = n; + n_vars ++; + + return result; +} + +/* Warn about function elimination. */ + +static void +do_warn_function_elimination (gfc_expr *e) +{ + const char *name; + if (e->expr_type == EXPR_FUNCTION + && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e)) + { + if (name) + gfc_warning (OPT_Wfunction_elimination, + "Removing call to impure function %qs at %L", name, + &(e->where)); + else + gfc_warning (OPT_Wfunction_elimination, + "Removing call to impure function at %L", + &(e->where)); + } +} + + +/* Callback function for the code walker for doing common function + elimination. This builds up the list of functions in the expression + and goes through them to detect duplicates, which it then replaces + by variables. */ + +static int +cfe_expr_0 (gfc_expr **e, int *walk_subtrees, + void *data ATTRIBUTE_UNUSED) +{ + int i,j; + gfc_expr *newvar; + gfc_expr **ei, **ej; + + /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */ + + if (in_omp_workshare || in_omp_atomic || in_assoc_list) + { + *walk_subtrees = 0; + return 0; + } + + expr_array.release (); + + gfc_expr_walker (e, cfe_register_funcs, NULL); + + /* Walk through all the functions. */ + + FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1) + { + /* Skip if the function has been replaced by a variable already. */ + if ((*ei)->expr_type == EXPR_VARIABLE) + continue; + + newvar = NULL; + for (j=0; j0) + b = sum(foo(a) + foo(a)) + END WHERE + + with + + WHERE (a > 0) + tmp = foo(a) + b = sum(tmp + tmp) + END WHERE +*/ + + if ((*c)->op == EXEC_WHERE) + { + *walk_subtrees = 0; + return 0; + } + + + return 0; +} + +/* Dummy function for expression call back, for use when we + really don't want to do any walking. */ + +static int +dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees, + void *data ATTRIBUTE_UNUSED) +{ + *walk_subtrees = 0; + return 0; +} + +/* Dummy function for code callback, for use when we really + don't want to do anything. */ +int +gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED, + int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + return 0; +} + +/* Code callback function for converting + do while(a) + end do + into the equivalent + do + if (.not. a) exit + end do + This is because common function elimination would otherwise place the + temporary variables outside the loop. */ + +static int +convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co = *c; + gfc_code *c_if1, *c_if2, *c_exit; + gfc_code *loopblock; + gfc_expr *e_not, *e_cond; + + if (co->op != EXEC_DO_WHILE) + return 0; + + if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT) + return 0; + + e_cond = co->expr1; + + /* Generate the condition of the if statement, which is .not. the original + statement. */ + e_not = gfc_get_expr (); + e_not->ts = e_cond->ts; + e_not->where = e_cond->where; + e_not->expr_type = EXPR_OP; + e_not->value.op.op = INTRINSIC_NOT; + e_not->value.op.op1 = e_cond; + + /* Generate the EXIT statement. */ + c_exit = XCNEW (gfc_code); + c_exit->op = EXEC_EXIT; + c_exit->ext.which_construct = co; + c_exit->loc = co->loc; + + /* Generate the IF statement. */ + c_if2 = XCNEW (gfc_code); + c_if2->op = EXEC_IF; + c_if2->expr1 = e_not; + c_if2->next = c_exit; + c_if2->loc = co->loc; + + /* ... plus the one to chain it to. */ + c_if1 = XCNEW (gfc_code); + c_if1->op = EXEC_IF; + c_if1->block = c_if2; + c_if1->loc = co->loc; + + /* Make the DO WHILE loop into a DO block by replacing the condition + with a true constant. */ + co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true); + + /* Hang the generated if statement into the loop body. */ + + loopblock = co->block->next; + co->block->next = c_if1; + c_if1->next = loopblock; + + return 0; +} + +/* Code callback function for converting + if (a) then + ... + else if (b) then + end if + + into + if (a) then + else + if (b) then + end if + end if + + because otherwise common function elimination would place the BLOCKs + into the wrong place. */ + +static int +convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co = *c; + gfc_code *c_if1, *c_if2, *else_stmt; + + if (co->op != EXEC_IF) + return 0; + + /* This loop starts out with the first ELSE statement. */ + else_stmt = co->block->block; + + while (else_stmt != NULL) + { + gfc_code *next_else; + + /* If there is no condition, we're done. */ + if (else_stmt->expr1 == NULL) + break; + + next_else = else_stmt->block; + + /* Generate the new IF statement. */ + c_if2 = XCNEW (gfc_code); + c_if2->op = EXEC_IF; + c_if2->expr1 = else_stmt->expr1; + c_if2->next = else_stmt->next; + c_if2->loc = else_stmt->loc; + c_if2->block = next_else; + + /* ... plus the one to chain it to. */ + c_if1 = XCNEW (gfc_code); + c_if1->op = EXEC_IF; + c_if1->block = c_if2; + c_if1->loc = else_stmt->loc; + + /* Insert the new IF after the ELSE. */ + else_stmt->expr1 = NULL; + else_stmt->next = c_if1; + else_stmt->block = NULL; + + else_stmt = next_else; + } + /* Don't walk subtrees. */ + return 0; +} + +/* Callback function to var_in_expr - return true if expr1 and + expr2 are identical variables. */ +static int +var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + gfc_expr *expr1 = (gfc_expr *) data; + gfc_expr *expr2 = *e; + + if (expr2->expr_type != EXPR_VARIABLE) + return 0; + + return expr1->symtree->n.sym == expr2->symtree->n.sym; +} + +/* Return true if expr1 is found in expr2. */ + +static bool +var_in_expr (gfc_expr *expr1, gfc_expr *expr2) +{ + gcc_assert (expr1->expr_type == EXPR_VARIABLE); + + return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1); +} + +struct do_stack +{ + struct do_stack *prev; + gfc_iterator *iter; + gfc_code *code; +} *stack_top; + +/* Recursively traverse the block of a WRITE or READ statement, and maybe + optimize by replacing do loops with their analog array slices. For + example: + + write (*,*) (a(i), i=1,4) + + is replaced with + + write (*,*) a(1:4:1) . */ + +static bool +traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev) +{ + gfc_code *curr; + gfc_expr *new_e, *expr, *start; + gfc_ref *ref; + struct do_stack ds_push; + int i, future_rank = 0; + gfc_iterator *iters[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + + /* Find the first transfer/do statement. */ + for (curr = code; curr; curr = curr->next) + { + if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER) + break; + } + + /* Ensure it is the only transfer/do statement because cases like + + write (*,*) (a(i), b(i), i=1,4) + + cannot be optimized. */ + + if (!curr || curr->next) + return false; + + if (curr->op == EXEC_DO) + { + if (curr->ext.iterator->var->ref) + return false; + ds_push.prev = stack_top; + ds_push.iter = curr->ext.iterator; + ds_push.code = curr; + stack_top = &ds_push; + if (traverse_io_block (curr->block->next, has_reached, prev)) + { + if (curr != stack_top->code && !*has_reached) + { + curr->block->next = NULL; + gfc_free_statements (curr); + } + else + *has_reached = true; + return true; + } + return false; + } + + gcc_assert (curr->op == EXEC_TRANSFER); + + e = curr->expr1; + ref = e->ref; + if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next) + return false; + + /* Find the iterators belonging to each variable and check conditions. */ + for (i = 0; i < ref->u.ar.dimen; i++) + { + if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref + || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) + return false; + + start = ref->u.ar.start[i]; + gfc_simplify_expr (start, 0); + switch (start->expr_type) + { + case EXPR_VARIABLE: + + /* write (*,*) (a(i), i=a%b,1) not handled yet. */ + if (start->ref) + return false; + + /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */ + if (!stack_top || !stack_top->iter + || stack_top->iter->var->symtree != start->symtree) + { + /* Check for (a(i,i), i=1,3). */ + int j; + + for (j=0; jvar->symtree == start->symtree) + return false; + + iters[i] = NULL; + } + else + { + iters[i] = stack_top->iter; + stack_top = stack_top->prev; + future_rank++; + } + break; + case EXPR_CONSTANT: + iters[i] = NULL; + break; + case EXPR_OP: + switch (start->value.op.op) + { + case INTRINSIC_PLUS: + case INTRINSIC_TIMES: + if (start->value.op.op1->expr_type != EXPR_VARIABLE) + std::swap (start->value.op.op1, start->value.op.op2); + gcc_fallthrough (); + case INTRINSIC_MINUS: + if (start->value.op.op1->expr_type!= EXPR_VARIABLE + || start->value.op.op2->expr_type != EXPR_CONSTANT + || start->value.op.op1->ref) + return false; + if (!stack_top || !stack_top->iter + || stack_top->iter->var->symtree + != start->value.op.op1->symtree) + return false; + iters[i] = stack_top->iter; + stack_top = stack_top->prev; + break; + default: + return false; + } + future_rank++; + break; + default: + return false; + } + } + + /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */ + for (int i = 1; i < ref->u.ar.dimen; i++) + { + if (iters[i]) + { + gfc_expr *var = iters[i]->var; + for (int j = i - 1; j < i; j++) + { + if (iters[j] + && (var_in_expr (var, iters[j]->start) + || var_in_expr (var, iters[j]->end) + || var_in_expr (var, iters[j]->step))) + return false; + } + } + } + + /* Create new expr. */ + new_e = gfc_copy_expr (curr->expr1); + new_e->expr_type = EXPR_VARIABLE; + new_e->rank = future_rank; + if (curr->expr1->shape) + new_e->shape = gfc_get_shape (new_e->rank); + + /* Assign new starts, ends and strides if necessary. */ + for (i = 0; i < ref->u.ar.dimen; i++) + { + if (!iters[i]) + continue; + start = ref->u.ar.start[i]; + switch (start->expr_type) + { + case EXPR_CONSTANT: + gfc_internal_error ("bad expression"); + break; + case EXPR_VARIABLE: + new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; + new_e->ref->u.ar.type = AR_SECTION; + gfc_free_expr (new_e->ref->u.ar.start[i]); + new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start); + new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end); + new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); + break; + case EXPR_OP: + new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; + new_e->ref->u.ar.type = AR_SECTION; + gfc_free_expr (new_e->ref->u.ar.start[i]); + expr = gfc_copy_expr (start); + expr->value.op.op1 = gfc_copy_expr (iters[i]->start); + new_e->ref->u.ar.start[i] = expr; + gfc_simplify_expr (new_e->ref->u.ar.start[i], 0); + expr = gfc_copy_expr (start); + expr->value.op.op1 = gfc_copy_expr (iters[i]->end); + new_e->ref->u.ar.end[i] = expr; + gfc_simplify_expr (new_e->ref->u.ar.end[i], 0); + switch (start->value.op.op) + { + case INTRINSIC_MINUS: + case INTRINSIC_PLUS: + new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); + break; + case INTRINSIC_TIMES: + expr = gfc_copy_expr (start); + expr->value.op.op1 = gfc_copy_expr (iters[i]->step); + new_e->ref->u.ar.stride[i] = expr; + gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0); + break; + default: + gfc_internal_error ("bad op"); + } + break; + default: + gfc_internal_error ("bad expression"); + } + } + curr->expr1 = new_e; + + /* Insert modified statement. Check whether the statement needs to be + inserted at the lowest level. */ + if (!stack_top->iter) + { + if (prev) + { + curr->next = prev->next->next; + prev->next = curr; + } + else + { + curr->next = stack_top->code->block->next->next->next; + stack_top->code->block->next = curr; + } + } + else + stack_top->code->block->next = curr; + return true; +} + +/* Function for the gfc_code_walker. If code is a READ or WRITE statement, it + tries to optimize its block. */ + +static int +simplify_io_impl_do (gfc_code **code, int *walk_subtrees, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code **curr, *prev = NULL; + struct do_stack write, first; + bool b = false; + *walk_subtrees = 1; + if (!(*code)->block + || ((*code)->block->op != EXEC_WRITE + && (*code)->block->op != EXEC_READ)) + return 0; + + *walk_subtrees = 0; + write.prev = NULL; + write.iter = NULL; + write.code = *code; + + for (curr = &(*code)->block; *curr; curr = &(*curr)->next) + { + if ((*curr)->op == EXEC_DO) + { + first.prev = &write; + first.iter = (*curr)->ext.iterator; + first.code = *curr; + stack_top = &first; + traverse_io_block ((*curr)->block->next, &b, prev); + stack_top = NULL; + } + prev = *curr; + } + return 0; +} + +/* Optimize a namespace, including all contained namespaces. + flag_frontend_optimize and flag_fronend_loop_interchange are + handled separately. */ + +static void +optimize_namespace (gfc_namespace *ns) +{ + gfc_namespace *saved_ns = gfc_current_ns; + current_ns = ns; + gfc_current_ns = ns; + forall_level = 0; + iterator_level = 0; + in_assoc_list = false; + in_omp_workshare = false; + in_omp_atomic = false; + + if (flag_frontend_optimize) + { + gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL); + gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); + gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); + gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); + gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); + if (flag_inline_matmul_limit != 0 || flag_external_blas) + { + bool found; + do + { + found = false; + gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr, + (void *) &found); + } + while (found); + + gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback, + NULL); + } + + if (flag_external_blas) + gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback, + NULL); + + if (flag_inline_matmul_limit != 0) + gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback, + NULL); + } + + if (flag_frontend_loop_interchange) + gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback, + NULL); + + /* BLOCKs are handled in the expression walker below. */ + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + optimize_namespace (ns); + } + gfc_current_ns = saved_ns; +} + +/* Handle dependencies for allocatable strings which potentially redefine + themselves in an assignment. */ + +static void +realloc_strings (gfc_namespace *ns) +{ + current_ns = ns; + gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + realloc_strings (ns); + } + +} + +static void +optimize_reduction (gfc_namespace *ns) +{ + current_ns = ns; + gfc_code_walker (&ns->code, gfc_dummy_code_callback, + callback_reduction, NULL); + +/* BLOCKs are handled in the expression walker below. */ + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + optimize_reduction (ns); + } +} + +/* Replace code like + a = matmul(b,c) + d + with + a = matmul(b,c) ; a = a + d + where the array function is not elemental and not allocatable + and does not depend on the left-hand side. +*/ + +static bool +optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) +{ + gfc_expr *e; + + if (!*rhs) + return false; + + e = *rhs; + if (e->expr_type == EXPR_OP) + { + switch (e->value.op.op) + { + /* Unary operators and exponentiation: Only look at a single + operand. */ + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_PARENTHESES: + case INTRINSIC_POWER: + if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op)) + return true; + break; + + case INTRINSIC_CONCAT: + /* Do not do string concatenations. */ + break; + + default: + /* Binary operators. */ + if (optimize_binop_array_assignment (c, &e->value.op.op1, true)) + return true; + + if (optimize_binop_array_assignment (c, &e->value.op.op2, true)) + return true; + + break; + } + } + else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 + && ! (e->value.function.esym + && (e->value.function.esym->attr.elemental + || e->value.function.esym->attr.allocatable + || e->value.function.esym->ts.type != c->expr1->ts.type + || e->value.function.esym->ts.kind != c->expr1->ts.kind)) + && ! (e->value.function.isym + && (e->value.function.isym->elemental + || e->ts.type != c->expr1->ts.type + || e->ts.kind != c->expr1->ts.kind)) + && ! gfc_inline_intrinsic_function_p (e)) + { + + gfc_code *n; + gfc_expr *new_expr; + + /* Insert a new assignment statement after the current one. */ + n = XCNEW (gfc_code); + n->op = EXEC_ASSIGN; + n->loc = c->loc; + n->next = c->next; + c->next = n; + + n->expr1 = gfc_copy_expr (c->expr1); + n->expr2 = c->expr2; + new_expr = gfc_copy_expr (c->expr1); + c->expr2 = e; + *rhs = new_expr; + + return true; + + } + + /* Nothing to optimize. */ + return false; +} + +/* Remove unneeded TRIMs at the end of expressions. */ + +static bool +remove_trim (gfc_expr *rhs) +{ + bool ret; + + ret = false; + if (!rhs) + return ret; + + /* Check for a // b // trim(c). Looping is probably not + necessary because the parser usually generates + (// (// a b ) trim(c) ) , but better safe than sorry. */ + + while (rhs->expr_type == EXPR_OP + && rhs->value.op.op == INTRINSIC_CONCAT) + rhs = rhs->value.op.op2; + + while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym + && rhs->value.function.isym->id == GFC_ISYM_TRIM) + { + strip_function_call (rhs); + /* Recursive call to catch silly stuff like trim ( a // trim(b)). */ + remove_trim (rhs); + ret = true; + } + + return ret; +} + +/* Optimizations for an assignment. */ + +static void +optimize_assignment (gfc_code * c) +{ + gfc_expr *lhs, *rhs; + + lhs = c->expr1; + rhs = c->expr2; + + if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred) + { + /* Optimize a = trim(b) to a = b. */ + remove_trim (rhs); + + /* Replace a = ' ' by a = '' to optimize away a memcpy. */ + if (is_empty_string (rhs)) + rhs->value.character.length = 0; + } + + if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0) + optimize_binop_array_assignment (c, &rhs, false); +} + + +/* Remove an unneeded function call, modifying the expression. + This replaces the function call with the value of its + first argument. The rest of the argument list is freed. */ + +static void +strip_function_call (gfc_expr *e) +{ + gfc_expr *e1; + gfc_actual_arglist *a; + + a = e->value.function.actual; + + /* We should have at least one argument. */ + gcc_assert (a->expr != NULL); + + e1 = a->expr; + + /* Free the remaining arglist, if any. */ + if (a->next) + gfc_free_actual_arglist (a->next); + + /* Graft the argument expression onto the original function. */ + *e = *e1; + free (e1); + +} + +/* Optimization of lexical comparison functions. */ + +static bool +optimize_lexical_comparison (gfc_expr *e) +{ + if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL) + return false; + + switch (e->value.function.isym->id) + { + case GFC_ISYM_LLE: + return optimize_comparison (e, INTRINSIC_LE); + + case GFC_ISYM_LGE: + return optimize_comparison (e, INTRINSIC_GE); + + case GFC_ISYM_LGT: + return optimize_comparison (e, INTRINSIC_GT); + + case GFC_ISYM_LLT: + return optimize_comparison (e, INTRINSIC_LT); + + default: + break; + } + return false; +} + +/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not + do CHARACTER because of possible pessimization involving character + lengths. */ + +static bool +combine_array_constructor (gfc_expr *e) +{ + + gfc_expr *op1, *op2; + gfc_expr *scalar; + gfc_expr *new_expr; + gfc_constructor *c, *new_c; + gfc_constructor_base oldbase, newbase; + bool scalar_first; + int n_elem; + bool all_const; + + /* Array constructors have rank one. */ + if (e->rank != 1) + return false; + + /* Don't try to combine association lists, this makes no sense + and leads to an ICE. */ + if (in_assoc_list) + return false; + + /* With FORALL, the BLOCKS created by create_var will cause an ICE. */ + if (forall_level > 0) + return false; + + /* Inside an iterator, things can get hairy; we are likely to create + an invalid temporary variable. */ + if (iterator_level > 0) + return false; + + /* WHERE also doesn't work. */ + if (in_where > 0) + return false; + + op1 = e->value.op.op1; + op2 = e->value.op.op2; + + if (!op1 || !op2) + return false; + + if (op1->expr_type == EXPR_ARRAY && op2->rank == 0) + scalar_first = false; + else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0) + { + scalar_first = true; + op1 = e->value.op.op2; + op2 = e->value.op.op1; + } + else + return false; + + if (op2->ts.type == BT_CHARACTER) + return false; + + /* This might be an expanded constructor with very many constant values. If + we perform the operation here, we might end up with a long compile time + and actually longer execution time, so a length bound is in order here. + If the constructor constains something which is not a constant, it did + not come from an expansion, so leave it alone. */ + +#define CONSTR_LEN_MAX 4 + + oldbase = op1->value.constructor; + + n_elem = 0; + all_const = true; + for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c)) + { + if (c->expr->expr_type != EXPR_CONSTANT) + { + all_const = false; + break; + } + n_elem += 1; + } + + if (all_const && n_elem > CONSTR_LEN_MAX) + return false; + +#undef CONSTR_LEN_MAX + + newbase = NULL; + e->expr_type = EXPR_ARRAY; + + scalar = create_var (gfc_copy_expr (op2), "constr"); + + for (c = gfc_constructor_first (oldbase); c; + c = gfc_constructor_next (c)) + { + new_expr = gfc_get_expr (); + new_expr->ts = e->ts; + new_expr->expr_type = EXPR_OP; + new_expr->rank = c->expr->rank; + new_expr->where = c->expr->where; + new_expr->value.op.op = e->value.op.op; + + if (scalar_first) + { + new_expr->value.op.op1 = gfc_copy_expr (scalar); + new_expr->value.op.op2 = gfc_copy_expr (c->expr); + } + else + { + new_expr->value.op.op1 = gfc_copy_expr (c->expr); + new_expr->value.op.op2 = gfc_copy_expr (scalar); + } + + new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where)); + new_c->iterator = c->iterator; + c->iterator = NULL; + } + + gfc_free_expr (op1); + gfc_free_expr (op2); + gfc_free_expr (scalar); + + e->value.constructor = newbase; + return true; +} + +/* Recursive optimization of operators. */ + +static bool +optimize_op (gfc_expr *e) +{ + bool changed; + + gfc_intrinsic_op op = e->value.op.op; + + changed = false; + + /* Only use new-style comparisons. */ + switch(op) + { + case INTRINSIC_EQ_OS: + op = INTRINSIC_EQ; + break; + + case INTRINSIC_GE_OS: + op = INTRINSIC_GE; + break; + + case INTRINSIC_LE_OS: + op = INTRINSIC_LE; + break; + + case INTRINSIC_NE_OS: + op = INTRINSIC_NE; + break; + + case INTRINSIC_GT_OS: + op = INTRINSIC_GT; + break; + + case INTRINSIC_LT_OS: + op = INTRINSIC_LT; + break; + + default: + break; + } + + switch (op) + { + case INTRINSIC_EQ: + case INTRINSIC_GE: + case INTRINSIC_LE: + case INTRINSIC_NE: + case INTRINSIC_GT: + case INTRINSIC_LT: + changed = optimize_comparison (e, op); + + gcc_fallthrough (); + /* Look at array constructors. */ + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + return combine_array_constructor (e) || changed; + + default: + break; + } + + return false; +} + + +/* Return true if a constant string contains only blanks. */ + +static bool +is_empty_string (gfc_expr *e) +{ + int i; + + if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) + return false; + + for (i=0; i < e->value.character.length; i++) + { + if (e->value.character.string[i] != ' ') + return false; + } + + return true; +} + + +/* Insert a call to the intrinsic len_trim. Use a different name for + the symbol tree so we don't run into trouble when the user has + renamed len_trim for some reason. */ + +static gfc_expr* +get_len_trim_call (gfc_expr *str, int kind) +{ + gfc_expr *fcn; + gfc_actual_arglist *actual_arglist, *next; + + fcn = gfc_get_expr (); + fcn->expr_type = EXPR_FUNCTION; + fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); + actual_arglist = gfc_get_actual_arglist (); + actual_arglist->expr = str; + next = gfc_get_actual_arglist (); + next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind); + actual_arglist->next = next; + + fcn->value.function.actual = actual_arglist; + fcn->where = str->where; + fcn->ts.type = BT_INTEGER; + fcn->ts.kind = gfc_charlen_int_kind; + + gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false); + fcn->symtree->n.sym->ts = fcn->ts; + fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; + fcn->symtree->n.sym->attr.function = 1; + fcn->symtree->n.sym->attr.elemental = 1; + fcn->symtree->n.sym->attr.referenced = 1; + fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; + gfc_commit_symbol (fcn->symtree->n.sym); + + return fcn; +} + + +/* Optimize expressions for equality. */ + +static bool +optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) +{ + gfc_expr *op1, *op2; + bool change; + int eq; + bool result; + gfc_actual_arglist *firstarg, *secondarg; + + if (e->expr_type == EXPR_OP) + { + firstarg = NULL; + secondarg = NULL; + op1 = e->value.op.op1; + op2 = e->value.op.op2; + } + else if (e->expr_type == EXPR_FUNCTION) + { + /* One of the lexical comparison functions. */ + firstarg = e->value.function.actual; + secondarg = firstarg->next; + op1 = firstarg->expr; + op2 = secondarg->expr; + } + else + gcc_unreachable (); + + /* Strip off unneeded TRIM calls from string comparisons. */ + + change = remove_trim (op1); + + if (remove_trim (op2)) + change = true; + + /* An expression of type EXPR_CONSTANT is only valid for scalars. */ + /* TODO: A scalar constant may be acceptable in some cases (the scalarizer + handles them well). However, there are also cases that need a non-scalar + argument. For example the any intrinsic. See PR 45380. */ + if (e->rank > 0) + return change; + + /* Replace a == '' with len_trim(a) == 0 and a /= '' with + len_trim(a) != 0 */ + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && (op == INTRINSIC_EQ || op == INTRINSIC_NE)) + { + bool empty_op1, empty_op2; + empty_op1 = is_empty_string (op1); + empty_op2 = is_empty_string (op2); + + if (empty_op1 || empty_op2) + { + gfc_expr *fcn; + gfc_expr *zero; + gfc_expr *str; + + /* This can only happen when an error for comparing + characters of different kinds has already been issued. */ + if (empty_op1 && empty_op2) + return false; + + zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0); + str = empty_op1 ? op2 : op1; + + fcn = get_len_trim_call (str, gfc_charlen_int_kind); + + + if (empty_op1) + gfc_free_expr (op1); + else + gfc_free_expr (op2); + + op1 = fcn; + op2 = zero; + e->value.op.op1 = fcn; + e->value.op.op2 = zero; + } + } + + + /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ + + if (flag_finite_math_only + || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL + && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX)) + { + eq = gfc_dep_compare_expr (op1, op2); + if (eq <= -2) + { + /* Replace A // B < A // C with B < C, and A // B < C // B + with A < C. */ + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && op1->expr_type == EXPR_OP + && op1->value.op.op == INTRINSIC_CONCAT + && op2->expr_type == EXPR_OP + && op2->value.op.op == INTRINSIC_CONCAT) + { + gfc_expr *op1_left = op1->value.op.op1; + gfc_expr *op2_left = op2->value.op.op1; + gfc_expr *op1_right = op1->value.op.op2; + gfc_expr *op2_right = op2->value.op.op2; + + if (gfc_dep_compare_expr (op1_left, op2_left) == 0) + { + /* Watch out for 'A ' // x vs. 'A' // x. */ + + if (op1_left->expr_type == EXPR_CONSTANT + && op2_left->expr_type == EXPR_CONSTANT + && op1_left->value.character.length + != op2_left->value.character.length) + return change; + else + { + free (op1_left); + free (op2_left); + if (firstarg) + { + firstarg->expr = op1_right; + secondarg->expr = op2_right; + } + else + { + e->value.op.op1 = op1_right; + e->value.op.op2 = op2_right; + } + optimize_comparison (e, op); + return true; + } + } + if (gfc_dep_compare_expr (op1_right, op2_right) == 0) + { + free (op1_right); + free (op2_right); + if (firstarg) + { + firstarg->expr = op1_left; + secondarg->expr = op2_left; + } + else + { + e->value.op.op1 = op1_left; + e->value.op.op2 = op2_left; + } + + optimize_comparison (e, op); + return true; + } + } + } + else + { + /* eq can only be -1, 0 or 1 at this point. */ + switch (op) + { + case INTRINSIC_EQ: + result = eq == 0; + break; + + case INTRINSIC_GE: + result = eq >= 0; + break; + + case INTRINSIC_LE: + result = eq <= 0; + break; + + case INTRINSIC_NE: + result = eq != 0; + break; + + case INTRINSIC_GT: + result = eq > 0; + break; + + case INTRINSIC_LT: + result = eq < 0; + break; + + default: + gfc_internal_error ("illegal OP in optimize_comparison"); + break; + } + + /* Replace the expression by a constant expression. The typespec + and where remains the way it is. */ + free (op1); + free (op2); + e->expr_type = EXPR_CONSTANT; + e->value.logical = result; + return true; + } + } + + return change; +} + +/* Optimize a trim function by replacing it with an equivalent substring + involving a call to len_trim. This only works for expressions where + variables are trimmed. Return true if anything was modified. */ + +static bool +optimize_trim (gfc_expr *e) +{ + gfc_expr *a; + gfc_ref *ref; + gfc_expr *fcn; + gfc_ref **rr = NULL; + + /* Don't do this optimization within an argument list, because + otherwise aliasing issues may occur. */ + + if (count_arglist != 1) + return false; + + if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION + || e->value.function.isym == NULL + || e->value.function.isym->id != GFC_ISYM_TRIM) + return false; + + a = e->value.function.actual->expr; + + if (a->expr_type != EXPR_VARIABLE) + return false; + + /* This would pessimize the idiom a = trim(a) for reallocatable strings. */ + + if (a->symtree->n.sym->attr.allocatable) + return false; + + /* Follow all references to find the correct place to put the newly + created reference. FIXME: Also handle substring references and + array references. Array references cause strange regressions at + the moment. */ + + if (a->ref) + { + for (rr = &(a->ref); *rr; rr = &((*rr)->next)) + { + if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY) + return false; + } + } + + strip_function_call (e); + + if (e->ref == NULL) + rr = &(e->ref); + + /* Create the reference. */ + + ref = gfc_get_ref (); + ref->type = REF_SUBSTRING; + + /* Set the start of the reference. */ + + ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); + + /* Build the function call to len_trim(x, gfc_default_integer_kind). */ + + fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind); + + /* Set the end of the reference to the call to len_trim. */ + + ref->u.ss.end = fcn; + gcc_assert (rr != NULL && *rr == NULL); + *rr = ref; + return true; +} + +/* Optimize minloc(b), where b is rank 1 array, into + (/ minloc(b, dim=1) /), and similarly for maxloc, + as the latter forms are expanded inline. */ + +static void +optimize_minmaxloc (gfc_expr **e) +{ + gfc_expr *fn = *e; + gfc_actual_arglist *a; + char *name, *p; + + if (fn->rank != 1 + || fn->value.function.actual == NULL + || fn->value.function.actual->expr == NULL + || fn->value.function.actual->expr->rank != 1) + return; + + *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); + (*e)->shape = fn->shape; + fn->rank = 0; + fn->shape = NULL; + gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where); + + name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1); + strcpy (name, fn->value.function.name); + p = strstr (name, "loc0"); + p[3] = '1'; + fn->value.function.name = gfc_get_string ("%s", name); + if (fn->value.function.actual->next) + { + a = fn->value.function.actual->next; + gcc_assert (a->expr == NULL); + } + else + { + a = gfc_get_actual_arglist (); + fn->value.function.actual->next = a; + } + a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &fn->where); + mpz_set_ui (a->expr->value.integer, 1); +} + +/* Data package to hand down for DO loop checks in a contained + procedure. */ +typedef struct contained_info +{ + gfc_symbol *do_var; + gfc_symbol *procedure; + locus where_do; +} contained_info; + +static enum gfc_exec_op last_io_op; + +/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a + contained function call. */ + +static int +doloop_contained_function_call (gfc_expr **e, + int *walk_subtrees ATTRIBUTE_UNUSED, void *data) +{ + gfc_expr *expr = *e; + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_symbol *sym, *do_var; + contained_info *info; + + if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym + || expr->value.function.esym == NULL) + return 0; + + sym = expr->value.function.esym; + f = gfc_sym_get_dummy_args (sym); + if (f == NULL) + return 0; + + info = (contained_info *) data; + do_var = info->do_var; + a = expr->value.function.actual; + + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + return 0; +} + +/* Callback function that goes through the code in a contained + procedure to make sure it does not change a variable in a DO + loop. */ + +static int +doloop_contained_procedure_code (gfc_code **c, + int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + gfc_code *co = *c; + contained_info *info = (contained_info *) data; + gfc_symbol *do_var = info->do_var; + const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs " + "called from within DO loop at %L"); + static enum gfc_exec_op saved_io_op; + + switch (co->op) + { + case EXEC_ASSIGN: + if (co->expr1->symtree && co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_DO: + if (co->ext.iterator && co->ext.iterator->var + && co->ext.iterator->var->symtree->n.sym == do_var) + gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_READ: + case EXEC_WRITE: + case EXEC_INQUIRE: + case EXEC_IOLENGTH: + saved_io_op = last_io_op; + last_io_op = co->op; + break; + + case EXEC_OPEN: + if (co->ext.open && co->ext.open->iostat + && co->ext.open->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_CLOSE: + if (co->ext.close && co->ext.close->iostat + && co->ext.close->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_TRANSFER: + switch (last_io_op) + { + + case EXEC_INQUIRE: +#define CHECK_INQ(a) do { if (co->ext.inquire && \ + co->ext.inquire->a && \ + co->ext.inquire->a->symtree->n.sym == do_var) \ + gfc_error_now (errmsg, do_var->name, \ + &co->ext.inquire->a->where, \ + info->procedure->name, \ + &info->where_do); \ + } while (0) + + CHECK_INQ(iostat); + CHECK_INQ(number); + CHECK_INQ(position); + CHECK_INQ(recl); + CHECK_INQ(position); + CHECK_INQ(iolength); + CHECK_INQ(strm_pos); + break; +#undef CHECK_INQ + + case EXEC_READ: + if (co->expr1 && co->expr1->symtree + && co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->expr1->where, + info->procedure->name, &info->where_do); + + /* Fallthrough. */ + + case EXEC_WRITE: + if (co->ext.dt && co->ext.dt->iostat && co->ext.dt->iostat->symtree + && co->ext.dt->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_IOLENGTH: + if (co->expr1 && co->expr1->symtree + && co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->expr1->where, + info->procedure->name, &info->where_do); + break; + + default: + gcc_unreachable (); + } + break; + + case EXEC_DT_END: + last_io_op = saved_io_op; + break; + + case EXEC_CALL: + gfc_formal_arglist *f; + gfc_actual_arglist *a; + + f = gfc_sym_get_dummy_args (co->resolved_sym); + if (f == NULL) + break; + a = co->ext.actual; + /* Slightly different error message here. If there is an error, + return 1 to avoid an infinite loop. */ + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", + do_var->name, &a->expr->where, + info->procedure->name, &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + break; + default: + break; + } + return 0; +} + +/* Callback function for code checking that we do not pass a DO variable to an + INTENT(OUT) or INTENT(INOUT) dummy variable. */ + +static int +doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co; + int i; + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_code *cl; + do_t loop, *lp; + bool seen_goto; + + co = *c; + + /* If the doloop_list grew, we have to truncate it here. */ + + if ((unsigned) doloop_level < doloop_list.length()) + doloop_list.truncate (doloop_level); + + seen_goto = false; + switch (co->op) + { + case EXEC_DO: + + if (co->ext.iterator && co->ext.iterator->var) + loop.c = co; + else + loop.c = NULL; + + loop.branch_level = if_level + select_level; + loop.seen_goto = false; + doloop_list.safe_push (loop); + break; + + /* If anything could transfer control away from a suspicious + subscript, make sure to set seen_goto in the current DO loop + (if any). */ + case EXEC_GOTO: + case EXEC_EXIT: + case EXEC_STOP: + case EXEC_ERROR_STOP: + case EXEC_CYCLE: + seen_goto = true; + break; + + case EXEC_OPEN: + if (co->ext.open->err) + seen_goto = true; + break; + + case EXEC_CLOSE: + if (co->ext.close->err) + seen_goto = true; + break; + + case EXEC_BACKSPACE: + case EXEC_ENDFILE: + case EXEC_REWIND: + case EXEC_FLUSH: + + if (co->ext.filepos->err) + seen_goto = true; + break; + + case EXEC_INQUIRE: + if (co->ext.filepos->err) + seen_goto = true; + break; + + case EXEC_READ: + case EXEC_WRITE: + if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor) + seen_goto = true; + break; + + case EXEC_WAIT: + if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor) + loop.seen_goto = true; + break; + + case EXEC_CALL: + if (co->resolved_sym == NULL) + break; + + /* Test if somebody stealthily changes the DO variable from + under us by changing it in a host-associated procedure. */ + if (co->resolved_sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + gfc_symbol *sym = co->resolved_sym; + contained_info info; + gfc_namespace *ns; + + cl = lp->c; + info.do_var = cl->ext.iterator->var->symtree->n.sym; + info.procedure = co->resolved_sym; /* sym? */ + info.where_do = co->loc; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + doloop_contained_function_call, &info); + } + } + + f = gfc_sym_get_dummy_args (co->resolved_sym); + + /* Withot a formal arglist, there is only unknown INTENT, + which we don't check for. */ + if (f == NULL) + break; + + a = co->ext.actual; + + while (a && f) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + gfc_symbol *do_sym; + cl = lp->c; + + if (cl == NULL) + break; + + do_sym = cl->ext.iterator->var->symtree->n.sym; + + if (a->expr && a->expr->symtree && f->sym + && a->expr->symtree->n.sym == do_sym) + { + if (f->sym->attr.intent == INTENT_OUT) + gfc_error_now ("Variable %qs at %L set to undefined " + "value inside loop beginning at %L as " + "INTENT(OUT) argument to subroutine %qs", + do_sym->name, &a->expr->where, + &(doloop_list[i].c->loc), + co->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_INOUT) + gfc_error_now ("Variable %qs at %L not definable inside " + "loop beginning at %L as INTENT(INOUT) " + "argument to subroutine %qs", + do_sym->name, &a->expr->where, + &(doloop_list[i].c->loc), + co->symtree->n.sym->name); + } + } + a = a->next; + f = f->next; + } + + break; + + default: + break; + } + if (seen_goto && doloop_level > 0) + doloop_list[doloop_level-1].seen_goto = true; + + return 0; +} + +/* Callback function to warn about different things within DO loops. */ + +static int +do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + do_t *last; + + if (doloop_list.length () == 0) + return 0; + + if ((*e)->expr_type == EXPR_FUNCTION) + do_intent (e); + + last = &doloop_list.last(); + if (last->seen_goto && !warn_do_subscript) + return 0; + + if ((*e)->expr_type == EXPR_VARIABLE) + do_subscript (e); + + return 0; +} + +typedef struct +{ + gfc_symbol *sym; + mpz_t val; +} insert_index_t; + +/* Callback function - if the expression is the variable in data->sym, + replace it with a constant from data->val. */ + +static int +callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + insert_index_t *d; + gfc_expr *ex, *n; + + ex = (*e); + if (ex->expr_type != EXPR_VARIABLE) + return 0; + + d = (insert_index_t *) data; + if (ex->symtree->n.sym != d->sym) + return 0; + + n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where); + mpz_set (n->value.integer, d->val); + + gfc_free_expr (ex); + *e = n; + return 0; +} + +/* In the expression e, replace occurrences of the variable sym with + val. If this results in a constant expression, return true and + return the value in ret. Return false if the expression already + is a constant. Caller has to clear ret in that case. */ + +static bool +insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret) +{ + gfc_expr *n; + insert_index_t data; + bool rc; + + if (e->expr_type == EXPR_CONSTANT) + return false; + + n = gfc_copy_expr (e); + data.sym = sym; + mpz_init_set (data.val, val); + gfc_expr_walker (&n, callback_insert_index, (void *) &data); + + /* Suppress errors here - we could get errors here such as an + out of bounds access for arrays, see PR 90563. */ + gfc_push_suppress_errors (); + gfc_simplify_expr (n, 0); + gfc_pop_suppress_errors (); + + if (n->expr_type == EXPR_CONSTANT) + { + rc = true; + mpz_init_set (ret, n->value.integer); + } + else + rc = false; + + mpz_clear (data.val); + gfc_free_expr (n); + return rc; + +} + +/* Check array subscripts for possible out-of-bounds accesses in DO + loops with constant bounds. */ + +static int +do_subscript (gfc_expr **e) +{ + gfc_expr *v; + gfc_array_ref *ar; + gfc_ref *ref; + int i,j; + gfc_code *dl; + do_t *lp; + + v = *e; + /* Constants are already checked. */ + if (v->expr_type == EXPR_CONSTANT) + return 0; + + /* Wrong warnings will be generated in an associate list. */ + if (in_assoc_list) + return 0; + + /* We already warned about this. */ + if (v->do_not_warn) + return 0; + + v->do_not_warn = 1; + + for (ref = v->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) + { + ar = & ref->u.ar; + FOR_EACH_VEC_ELT (doloop_list, j, lp) + { + gfc_symbol *do_sym; + mpz_t do_start, do_step, do_end; + bool have_do_start, have_do_end; + bool error_not_proven; + int warn; + int sgn; + + dl = lp->c; + if (dl == NULL) + break; + + /* If we are within a branch, or a goto or equivalent + was seen in the DO loop before, then we cannot prove that + this expression is actually evaluated. Don't do anything + unless we want to see it all. */ + error_not_proven = lp->seen_goto + || lp->branch_level < if_level + select_level; + + if (error_not_proven && !warn_do_subscript) + break; + + if (error_not_proven) + warn = OPT_Wdo_subscript; + else + warn = 0; + + do_sym = dl->ext.iterator->var->symtree->n.sym; + if (do_sym->ts.type != BT_INTEGER) + continue; + + /* If we do not know about the stepsize, the loop may be zero trip. + Do not warn in this case. */ + + if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT) + { + sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0); + /* This can happen, but then the error has been + reported previously. */ + if (sgn == 0) + continue; + + mpz_init_set (do_step, dl->ext.iterator->step->value.integer); + } + + else + continue; + + if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT) + { + have_do_start = true; + mpz_init_set (do_start, dl->ext.iterator->start->value.integer); + } + else + have_do_start = false; + + if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT) + { + have_do_end = true; + mpz_init_set (do_end, dl->ext.iterator->end->value.integer); + } + else + have_do_end = false; + + if (!have_do_start && !have_do_end) + return 0; + + /* No warning inside a zero-trip loop. */ + if (have_do_start && have_do_end) + { + int cmp; + + cmp = mpz_cmp (do_end, do_start); + if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)) + break; + } + + /* May have to correct the end value if the step does not equal + one. */ + if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0) + { + mpz_t diff, rem; + + mpz_init (diff); + mpz_init (rem); + mpz_sub (diff, do_end, do_start); + mpz_tdiv_r (rem, diff, do_step); + mpz_sub (do_end, do_end, rem); + mpz_clear (diff); + mpz_clear (rem); + } + + for (i = 0; i< ar->dimen; i++) + { + mpz_t val; + if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start + && insert_index (ar->start[i], do_sym, do_start, val)) + { + if (ar->as->lower[i] + && ar->as->lower[i]->expr_type == EXPR_CONSTANT + && ar->as->lower[i]->ts.type == BT_INTEGER + && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) + gfc_warning (warn, "Array reference at %L out of bounds " + "(%ld < %ld) in loop beginning at %L", + &ar->start[i]->where, mpz_get_si (val), + mpz_get_si (ar->as->lower[i]->value.integer), + &doloop_list[j].c->loc); + + if (ar->as->upper[i] + && ar->as->upper[i]->expr_type == EXPR_CONSTANT + && ar->as->upper[i]->ts.type == BT_INTEGER + && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) + gfc_warning (warn, "Array reference at %L out of bounds " + "(%ld > %ld) in loop beginning at %L", + &ar->start[i]->where, mpz_get_si (val), + mpz_get_si (ar->as->upper[i]->value.integer), + &doloop_list[j].c->loc); + + mpz_clear (val); + } + + if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end + && insert_index (ar->start[i], do_sym, do_end, val)) + { + if (ar->as->lower[i] + && ar->as->lower[i]->expr_type == EXPR_CONSTANT + && ar->as->lower[i]->ts.type == BT_INTEGER + && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) + gfc_warning (warn, "Array reference at %L out of bounds " + "(%ld < %ld) in loop beginning at %L", + &ar->start[i]->where, mpz_get_si (val), + mpz_get_si (ar->as->lower[i]->value.integer), + &doloop_list[j].c->loc); + + if (ar->as->upper[i] + && ar->as->upper[i]->expr_type == EXPR_CONSTANT + && ar->as->upper[i]->ts.type == BT_INTEGER + && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) + gfc_warning (warn, "Array reference at %L out of bounds " + "(%ld > %ld) in loop beginning at %L", + &ar->start[i]->where, mpz_get_si (val), + mpz_get_si (ar->as->upper[i]->value.integer), + &doloop_list[j].c->loc); + + mpz_clear (val); + } + } + } + } + } + return 0; +} +/* Function for functions checking that we do not pass a DO variable + to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ + +static int +do_intent (gfc_expr **e) +{ + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_expr *expr; + gfc_code *dl; + do_t *lp; + int i; + gfc_symbol *sym; + + expr = *e; + if (expr->expr_type != EXPR_FUNCTION) + return 0; + + /* Intrinsic functions don't modify their arguments. */ + + if (expr->value.function.isym) + return 0; + + sym = expr->value.function.esym; + if (sym == NULL) + return 0; + + if (sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + contained_info info; + gfc_namespace *ns; + + dl = lp->c; + info.do_var = dl->ext.iterator->var->symtree->n.sym; + info.procedure = sym; + info.where_do = expr->where; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + dummy_expr_callback, &info); + } + } + + f = gfc_sym_get_dummy_args (sym); + + /* Without a formal arglist, there is only unknown INTENT, + which we don't check for. */ + if (f == NULL) + return 0; + + a = expr->value.function.actual; + + while (a && f) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + gfc_symbol *do_sym; + dl = lp->c; + if (dl == NULL) + break; + + do_sym = dl->ext.iterator->var->symtree->n.sym; + + if (a->expr && a->expr->symtree + && a->expr->symtree->n.sym == do_sym) + { + if (f->sym->attr.intent == INTENT_OUT) + gfc_error_now ("Variable %qs at %L set to undefined value " + "inside loop beginning at %L as INTENT(OUT) " + "argument to function %qs", do_sym->name, + &a->expr->where, &doloop_list[i].c->loc, + expr->symtree->n.sym->name); + else if (f->sym->attr.intent == INTENT_INOUT) + gfc_error_now ("Variable %qs at %L not definable inside loop" + " beginning at %L as INTENT(INOUT) argument to" + " function %qs", do_sym->name, + &a->expr->where, &doloop_list[i].c->loc, + expr->symtree->n.sym->name); + } + } + a = a->next; + f = f->next; + } + + return 0; +} + +static void +doloop_warn (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, doloop_code, do_function, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + doloop_warn (ns); + } +} + +/* This selction deals with inlining calls to MATMUL. */ + +/* Replace calls to matmul outside of straight assignments with a temporary + variable so that later inlining will work. */ + +static int +matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + gfc_expr *e, *n; + bool *found = (bool *) data; + + e = *ep; + + if (e->expr_type != EXPR_FUNCTION + || e->value.function.isym == NULL + || e->value.function.isym->id != GFC_ISYM_MATMUL) + return 0; + + if (forall_level > 0 || iterator_level > 0 || in_omp_workshare + || in_omp_atomic || in_where || in_assoc_list) + return 0; + + /* Check if this is already in the form c = matmul(a,b). */ + + if ((*current_code)->expr2 == e) + return 0; + + n = create_var (e, "matmul"); + + /* If create_var is unable to create a variable (for example if + -fno-realloc-lhs is in force with a variable that does not have bounds + known at compile-time), just return. */ + + if (n == NULL) + return 0; + + *ep = n; + *found = true; + return 0; +} + +/* Set current_code and associated variables so that matmul_to_var_expr can + work. */ + +static int +matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + if (current_code != c) + { + current_code = c; + inserted_block = NULL; + changed_statement = NULL; + } + + return 0; +} + + +/* Take a statement of the shape c = matmul(a,b) and create temporaries + for a and b if there is a dependency between the arguments and the + result variable or if a or b are the result of calculations that cannot + be handled by the inliner. */ + +static int +matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_expr *expr1, *expr2; + gfc_code *co; + gfc_actual_arglist *a, *b; + bool a_tmp, b_tmp; + gfc_expr *matrix_a, *matrix_b; + bool conjg_a, conjg_b, transpose_a, transpose_b; + + co = *c; + + if (co->op != EXEC_ASSIGN) + return 0; + + if (forall_level > 0 || iterator_level > 0 || in_omp_workshare + || in_omp_atomic || in_where) + return 0; + + /* This has some duplication with inline_matmul_assign. This + is because the creation of temporary variables could still fail, + and inline_matmul_assign still needs to be able to handle these + cases. */ + expr1 = co->expr1; + expr2 = co->expr2; + + if (expr2->expr_type != EXPR_FUNCTION + || expr2->value.function.isym == NULL + || expr2->value.function.isym->id != GFC_ISYM_MATMUL) + return 0; + + a_tmp = false; + a = expr2->value.function.actual; + matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); + if (matrix_a != NULL) + { + if (matrix_a->expr_type == EXPR_VARIABLE + && (gfc_check_dependency (matrix_a, expr1, true) + || gfc_has_dimen_vector_ref (matrix_a))) + a_tmp = true; + } + else + a_tmp = true; + + b_tmp = false; + b = a->next; + matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); + if (matrix_b != NULL) + { + if (matrix_b->expr_type == EXPR_VARIABLE + && (gfc_check_dependency (matrix_b, expr1, true) + || gfc_has_dimen_vector_ref (matrix_b))) + b_tmp = true; + } + else + b_tmp = true; + + if (!a_tmp && !b_tmp) + return 0; + + current_code = c; + inserted_block = NULL; + changed_statement = NULL; + if (a_tmp) + { + gfc_expr *at; + at = create_var (a->expr,"mma"); + if (at) + a->expr = at; + } + if (b_tmp) + { + gfc_expr *bt; + bt = create_var (b->expr,"mmb"); + if (bt) + b->expr = bt; + } + return 0; +} + +/* Auxiliary function to build and simplify an array inquiry function. + dim is zero-based. */ + +static gfc_expr * +get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0) +{ + gfc_expr *fcn; + gfc_expr *dim_arg, *kind; + const char *name; + gfc_expr *ec; + + switch (id) + { + case GFC_ISYM_LBOUND: + name = "_gfortran_lbound"; + break; + + case GFC_ISYM_UBOUND: + name = "_gfortran_ubound"; + break; + + case GFC_ISYM_SIZE: + name = "_gfortran_size"; + break; + + default: + gcc_unreachable (); + } + + dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim); + if (okind != 0) + kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, + okind); + else + kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, + gfc_index_integer_kind); + + ec = gfc_copy_expr (e); + + /* No bounds checking, this will be done before the loops if -fcheck=bounds + is in effect. */ + ec->no_bounds_check = 1; + fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3, + ec, dim_arg, kind); + gfc_simplify_expr (fcn, 0); + fcn->no_bounds_check = 1; + return fcn; +} + +/* Builds a logical expression. */ + +static gfc_expr* +build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) +{ + gfc_typespec ts; + gfc_expr *res; + + ts.type = BT_LOGICAL; + ts.kind = gfc_default_logical_kind; + res = gfc_get_expr (); + res->where = e1->where; + res->expr_type = EXPR_OP; + res->value.op.op = op; + res->value.op.op1 = e1; + res->value.op.op2 = e2; + res->ts = ts; + + return res; +} + + +/* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes + compatible typespecs. */ + +static gfc_expr * +get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) +{ + gfc_expr *res; + + res = gfc_get_expr (); + res->ts = e1->ts; + res->where = e1->where; + res->expr_type = EXPR_OP; + res->value.op.op = op; + res->value.op.op1 = e1; + res->value.op.op2 = e2; + gfc_simplify_expr (res, 0); + return res; +} + +/* Generate the IF statement for a runtime check if we want to do inlining or + not - putting in the code for both branches and putting it into the syntax + tree is the caller's responsibility. For fixed array sizes, this should be + removed by DCE. Only called for rank-two matrices A and B. */ + +static gfc_code * +inline_limit_check (gfc_expr *a, gfc_expr *b, int limit, int rank_a) +{ + gfc_expr *inline_limit; + gfc_code *if_1, *if_2, *else_2; + gfc_expr *b2, *a2, *a1, *m1, *m2; + gfc_typespec ts; + gfc_expr *cond; + + gcc_assert (rank_a == 1 || rank_a == 2); + + /* Calculation is done in real to avoid integer overflow. */ + + inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind, + &a->where); + mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE); + + /* Set the limit according to the rank. */ + mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, rank_a + 1, + GFC_RND_MODE); + + a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1); + + /* For a_rank = 1, must use one as the size of a along the second + dimension as to avoid too much code duplication. */ + + if (rank_a == 2) + a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2); + else + a2 = gfc_get_int_expr (gfc_index_integer_kind, &a->where, 1); + + b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2); + + gfc_clear_ts (&ts); + ts.type = BT_REAL; + ts.kind = gfc_default_real_kind; + gfc_convert_type_warn (a1, &ts, 2, 0); + gfc_convert_type_warn (a2, &ts, 2, 0); + gfc_convert_type_warn (b2, &ts, 2, 0); + + m1 = get_operand (INTRINSIC_TIMES, a1, a2); + m2 = get_operand (INTRINSIC_TIMES, m1, b2); + + cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit); + gfc_simplify_expr (cond, 0); + + else_2 = XCNEW (gfc_code); + else_2->op = EXEC_IF; + else_2->loc = a->where; + + if_2 = XCNEW (gfc_code); + if_2->op = EXEC_IF; + if_2->expr1 = cond; + if_2->loc = a->where; + if_2->block = else_2; + + if_1 = XCNEW (gfc_code); + if_1->op = EXEC_IF; + if_1->block = if_2; + if_1->loc = a->where; + + return if_1; +} + + +/* Insert code to issue a runtime error if the expressions are not equal. */ + +static gfc_code * +runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg) +{ + gfc_expr *cond; + gfc_code *if_1, *if_2; + gfc_code *c; + gfc_actual_arglist *a1, *a2, *a3; + + gcc_assert (e1->where.lb); + /* Build the call to runtime_error. */ + c = XCNEW (gfc_code); + c->op = EXEC_CALL; + c->loc = e1->where; + + /* Get a null-terminated message string. */ + + a1 = gfc_get_actual_arglist (); + a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where, + msg, strlen(msg)+1); + c->ext.actual = a1; + + /* Pass the value of the first expression. */ + a2 = gfc_get_actual_arglist (); + a2->expr = gfc_copy_expr (e1); + a1->next = a2; + + /* Pass the value of the second expression. */ + a3 = gfc_get_actual_arglist (); + a3->expr = gfc_copy_expr (e2); + a2->next = a3; + + gfc_check_fe_runtime_error (c->ext.actual); + gfc_resolve_fe_runtime_error (c); + + if_2 = XCNEW (gfc_code); + if_2->op = EXEC_IF; + if_2->loc = e1->where; + if_2->next = c; + + if_1 = XCNEW (gfc_code); + if_1->op = EXEC_IF; + if_1->block = if_2; + if_1->loc = e1->where; + + cond = build_logical_expr (INTRINSIC_NE, e1, e2); + gfc_simplify_expr (cond, 0); + if_2->expr1 = cond; + + return if_1; +} + +/* Handle matrix reallocation. Caller is responsible to insert into + the code tree. + + For the two-dimensional case, build + + if (allocated(c)) then + if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then + deallocate(c) + allocate (c(size(a,1), size(b,2))) + end if + else + allocate (c(size(a,1),size(b,2))) + end if + + and for the other cases correspondingly. +*/ + +static gfc_code * +matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, + enum matrix_case m_case) +{ + + gfc_expr *allocated, *alloc_expr; + gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2; + gfc_code *else_alloc; + gfc_code *deallocate, *allocate1, *allocate_else; + gfc_array_ref *ar; + gfc_expr *cond, *ne1, *ne2; + + if (warn_realloc_lhs) + gfc_warning (OPT_Wrealloc_lhs, + "Code for reallocating the allocatable array at %L will " + "be added", &c->where); + + alloc_expr = gfc_copy_expr (c); + + ar = gfc_find_array_ref (alloc_expr); + gcc_assert (ar && ar->type == AR_FULL); + + /* c comes in as a full ref. Change it into a copy and make it into an + element ref so it has the right form for ALLOCATE. In the same + switch statement, also generate the size comparison for the secod IF + statement. */ + + ar->type = AR_ELEMENT; + + switch (m_case) + { + case A2B2: + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); + ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); + ne1 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, a, 1)); + ne2 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 2), + get_array_inq_function (GFC_ISYM_SIZE, b, 2)); + cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); + break; + + case A2B2T: + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); + ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); + + ne1 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, a, 1)); + ne2 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 2), + get_array_inq_function (GFC_ISYM_SIZE, b, 1)); + cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); + break; + + case A2TB2: + + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); + ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); + + ne1 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, a, 2)); + ne2 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 2), + get_array_inq_function (GFC_ISYM_SIZE, b, 2)); + cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); + break; + + case A2B1: + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); + cond = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, a, 2)); + break; + + case A1B2: + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); + cond = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, b, 2)); + break; + + case A2TB2T: + /* This can only happen for BLAS, we do not handle that case in + inline mamtul. */ + ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); + ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); + + ne1 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 1), + get_array_inq_function (GFC_ISYM_SIZE, a, 2)); + ne2 = build_logical_expr (INTRINSIC_NE, + get_array_inq_function (GFC_ISYM_SIZE, c, 2), + get_array_inq_function (GFC_ISYM_SIZE, b, 1)); + + cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); + break; + + default: + gcc_unreachable(); + + } + + gfc_simplify_expr (cond, 0); + + /* We need two identical allocate statements in two + branches of the IF statement. */ + + allocate1 = XCNEW (gfc_code); + allocate1->op = EXEC_ALLOCATE; + allocate1->ext.alloc.list = gfc_get_alloc (); + allocate1->loc = c->where; + allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr); + + allocate_else = XCNEW (gfc_code); + allocate_else->op = EXEC_ALLOCATE; + allocate_else->ext.alloc.list = gfc_get_alloc (); + allocate_else->loc = c->where; + allocate_else->ext.alloc.list->expr = alloc_expr; + + allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED, + "_gfortran_allocated", c->where, + 1, gfc_copy_expr (c)); + + deallocate = XCNEW (gfc_code); + deallocate->op = EXEC_DEALLOCATE; + deallocate->ext.alloc.list = gfc_get_alloc (); + deallocate->ext.alloc.list->expr = gfc_copy_expr (c); + deallocate->next = allocate1; + deallocate->loc = c->where; + + if_size_2 = XCNEW (gfc_code); + if_size_2->op = EXEC_IF; + if_size_2->expr1 = cond; + if_size_2->loc = c->where; + if_size_2->next = deallocate; + + if_size_1 = XCNEW (gfc_code); + if_size_1->op = EXEC_IF; + if_size_1->block = if_size_2; + if_size_1->loc = c->where; + + else_alloc = XCNEW (gfc_code); + else_alloc->op = EXEC_IF; + else_alloc->loc = c->where; + else_alloc->next = allocate_else; + + if_alloc_2 = XCNEW (gfc_code); + if_alloc_2->op = EXEC_IF; + if_alloc_2->expr1 = allocated; + if_alloc_2->loc = c->where; + if_alloc_2->next = if_size_1; + if_alloc_2->block = else_alloc; + + if_alloc_1 = XCNEW (gfc_code); + if_alloc_1->op = EXEC_IF; + if_alloc_1->block = if_alloc_2; + if_alloc_1->loc = c->where; + + return if_alloc_1; +} + +/* Callback function for has_function_or_op. */ + +static int +is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + if ((*e) == 0) + return 0; + else + return (*e)->expr_type == EXPR_FUNCTION + || (*e)->expr_type == EXPR_OP; +} + +/* Returns true if the expression contains a function. */ + +static bool +has_function_or_op (gfc_expr **e) +{ + if (e == NULL) + return false; + else + return gfc_expr_walker (e, is_function_or_op, NULL); +} + +/* Freeze (assign to a temporary variable) a single expression. */ + +static void +freeze_expr (gfc_expr **ep) +{ + gfc_expr *ne; + if (has_function_or_op (ep)) + { + ne = create_var (*ep, "freeze"); + *ep = ne; + } +} + +/* Go through an expression's references and assign them to temporary + variables if they contain functions. This is usually done prior to + front-end scalarization to avoid multiple invocations of functions. */ + +static void +freeze_references (gfc_expr *e) +{ + gfc_ref *r; + gfc_array_ref *ar; + int i; + + for (r=e->ref; r; r=r->next) + { + if (r->type == REF_SUBSTRING) + { + if (r->u.ss.start != NULL) + freeze_expr (&r->u.ss.start); + + if (r->u.ss.end != NULL) + freeze_expr (&r->u.ss.end); + } + else if (r->type == REF_ARRAY) + { + ar = &r->u.ar; + switch (ar->type) + { + case AR_FULL: + break; + + case AR_SECTION: + for (i=0; idimen; i++) + { + if (ar->dimen_type[i] == DIMEN_RANGE) + { + freeze_expr (&ar->start[i]); + freeze_expr (&ar->end[i]); + freeze_expr (&ar->stride[i]); + } + else if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + freeze_expr (&ar->start[i]); + } + } + break; + + case AR_ELEMENT: + for (i=0; idimen; i++) + freeze_expr (&ar->start[i]); + break; + + default: + break; + } + } + } +} + +/* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */ + +static gfc_expr * +convert_to_index_kind (gfc_expr *e) +{ + gfc_expr *res; + + gcc_assert (e != NULL); + + res = gfc_copy_expr (e); + + gcc_assert (e->ts.type == BT_INTEGER); + + if (res->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + + gfc_convert_type_warn (e, &ts, 2, 0); + } + + return res; +} + +/* Function to create a DO loop including creation of the + iteration variable. gfc_expr are copied.*/ + +static gfc_code * +create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where, + gfc_namespace *ns, char *vname) +{ + + char name[GFC_MAX_SYMBOL_LEN +1]; + gfc_symtree *symtree; + gfc_symbol *symbol; + gfc_expr *i; + gfc_code *n, *n2; + + /* Create an expression for the iteration variable. */ + if (vname) + sprintf (name, "__var_%d_do_%s", var_num++, vname); + else + sprintf (name, "__var_%d_do", var_num++); + + + if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) + gcc_unreachable (); + + /* Create the loop variable. */ + + symbol = symtree->n.sym; + symbol->ts.type = BT_INTEGER; + symbol->ts.kind = gfc_index_integer_kind; + symbol->attr.flavor = FL_VARIABLE; + symbol->attr.referenced = 1; + symbol->attr.dimension = 0; + symbol->attr.fe_temp = 1; + gfc_commit_symbol (symbol); + + i = gfc_get_expr (); + i->expr_type = EXPR_VARIABLE; + i->ts = symbol->ts; + i->rank = 0; + i->where = *where; + i->symtree = symtree; + + /* ... and the nested DO statements. */ + n = XCNEW (gfc_code); + n->op = EXEC_DO; + n->loc = *where; + n->ext.iterator = gfc_get_iterator (); + n->ext.iterator->var = i; + n->ext.iterator->start = convert_to_index_kind (start); + n->ext.iterator->end = convert_to_index_kind (end); + if (step) + n->ext.iterator->step = convert_to_index_kind (step); + else + n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind, + where, 1); + + n2 = XCNEW (gfc_code); + n2->op = EXEC_DO; + n2->loc = *where; + n2->next = NULL; + n->block = n2; + return n; +} + +/* Get the upper bound of the DO loops for matmul along a dimension. This + is one-based. */ + +static gfc_expr* +get_size_m1 (gfc_expr *e, int dimen) +{ + mpz_t size; + gfc_expr *res; + + if (gfc_array_dimen_size (e, dimen - 1, &size)) + { + res = gfc_get_constant_expr (BT_INTEGER, + gfc_index_integer_kind, &e->where); + mpz_sub_ui (res->value.integer, size, 1); + mpz_clear (size); + } + else + { + res = get_operand (INTRINSIC_MINUS, + get_array_inq_function (GFC_ISYM_SIZE, e, dimen), + gfc_get_int_expr (gfc_index_integer_kind, + &e->where, 1)); + gfc_simplify_expr (res, 0); + } + + return res; +} + +/* Function to return a scalarized expression. It is assumed that indices are + zero based to make generation of DO loops easier. A zero as index will + access the first element along a dimension. Single element references will + be skipped. A NULL as an expression will be replaced by a full reference. + This assumes that the index loops have gfc_index_integer_kind, and that all + references have been frozen. */ + +static gfc_expr* +scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) +{ + gfc_array_ref *ar; + int i; + int rank; + gfc_expr *e; + int i_index; + bool was_fullref; + + e = gfc_copy_expr(e_in); + + rank = e->rank; + + ar = gfc_find_array_ref (e); + + /* We scalarize count_index variables, reducing the rank by count_index. */ + + e->rank = rank - count_index; + + was_fullref = ar->type == AR_FULL; + + if (e->rank == 0) + ar->type = AR_ELEMENT; + else + ar->type = AR_SECTION; + + /* Loop over the indices. For each index, create the expression + index * stride + lbound(e, dim). */ + + i_index = 0; + for (i=0; i < ar->dimen; i++) + { + if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE) + { + if (index[i_index] != NULL) + { + gfc_expr *lbound, *nindex; + gfc_expr *loopvar; + + loopvar = gfc_copy_expr (index[i_index]); + + if (ar->stride[i]) + { + gfc_expr *tmp; + + tmp = gfc_copy_expr(ar->stride[i]); + if (tmp->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + gfc_convert_type (tmp, &ts, 2); + } + nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp); + } + else + nindex = loopvar; + + /* Calculate the lower bound of the expression. */ + if (ar->start[i]) + { + lbound = gfc_copy_expr (ar->start[i]); + if (lbound->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + gfc_convert_type (lbound, &ts, 2); + + } + } + else + { + gfc_expr *lbound_e; + gfc_ref *ref; + + lbound_e = gfc_copy_expr (e_in); + + for (ref = lbound_e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && (ref->u.ar.type == AR_FULL + || ref->u.ar.type == AR_SECTION)) + break; + + if (ref->next) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + + if (!was_fullref) + { + /* Look at full individual sections, like a(:). The first index + is the lbound of a full ref. */ + int j; + gfc_array_ref *ar; + int to; + + ar = &ref->u.ar; + + /* For assumed size, we need to keep around the final + reference in order not to get an error on resolution + below, and we cannot use AR_FULL. */ + + if (ar->as->type == AS_ASSUMED_SIZE) + { + ar->type = AR_SECTION; + to = ar->dimen - 1; + } + else + { + to = ar->dimen; + ar->type = AR_FULL; + } + + for (j = 0; j < to; j++) + { + gfc_free_expr (ar->start[j]); + ar->start[j] = NULL; + gfc_free_expr (ar->end[j]); + ar->end[j] = NULL; + gfc_free_expr (ar->stride[j]); + ar->stride[j] = NULL; + } + + /* We have to get rid of the shape, if there is one. Do + so by freeing it and calling gfc_resolve to rebuild + it, if necessary. */ + + if (lbound_e->shape) + gfc_free_shape (&(lbound_e->shape), lbound_e->rank); + + lbound_e->rank = ar->dimen; + gfc_resolve_expr (lbound_e); + } + lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e, + i + 1); + gfc_free_expr (lbound_e); + } + + ar->dimen_type[i] = DIMEN_ELEMENT; + + gfc_free_expr (ar->start[i]); + ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound); + + gfc_free_expr (ar->end[i]); + ar->end[i] = NULL; + gfc_free_expr (ar->stride[i]); + ar->stride[i] = NULL; + gfc_simplify_expr (ar->start[i], 0); + } + else if (was_fullref) + { + gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented"); + } + i_index ++; + } + } + + /* Bounds checking will be done before the loops if -fcheck=bounds + is in effect. */ + e->no_bounds_check = 1; + return e; +} + +/* Helper function to check for a dimen vector as subscript. */ + +bool +gfc_has_dimen_vector_ref (gfc_expr *e) +{ + gfc_array_ref *ar; + int i; + + ar = gfc_find_array_ref (e); + gcc_assert (ar); + if (ar->type == AR_FULL) + return false; + + for (i=0; idimen; i++) + if (ar->dimen_type[i] == DIMEN_VECTOR) + return true; + + return false; +} + +/* If handed an expression of the form + + TRANSPOSE(CONJG(A)) + + check if A can be handled by matmul and return if there is an uneven number + of CONJG calls. Return a pointer to the array when everything is OK, NULL + otherwise. The caller has to check for the correct rank. */ + +static gfc_expr* +check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose) +{ + *conjg = false; + *transpose = false; + + do + { + if (e->expr_type == EXPR_VARIABLE) + { + gcc_assert (e->rank == 1 || e->rank == 2); + return e; + } + else if (e->expr_type == EXPR_FUNCTION) + { + if (e->value.function.isym == NULL) + return NULL; + + if (e->value.function.isym->id == GFC_ISYM_CONJG) + *conjg = !*conjg; + else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE) + *transpose = !*transpose; + else return NULL; + } + else + return NULL; + + e = e->value.function.actual->expr; + } + while(1); + + return NULL; +} + +/* Macros for unified error messages. */ + +#define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \ + "dimension 1: is %ld, should be %ld") + +#define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \ + "(%ld/%ld)") + +#define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \ + "(%ld/%ld)") + + +/* Inline assignments of the form c = matmul(a,b). + Handle only the cases currently where b and c are rank-two arrays. + + This basically translates the code to + + BLOCK + integer i,j,k + c = 0 + do j=0, size(b,2)-1 + do k=0, size(a, 2)-1 + do i=0, size(a, 1)-1 + c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) = + c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) + + a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) * + b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2)) + end do + end do + end do + END BLOCK + +*/ + +static int +inline_matmul_assign (gfc_code **c, int *walk_subtrees, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co = *c; + gfc_expr *expr1, *expr2; + gfc_expr *matrix_a, *matrix_b; + gfc_actual_arglist *a, *b; + gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul; + gfc_expr *zero_e; + gfc_expr *u1, *u2, *u3; + gfc_expr *list[2]; + gfc_expr *ascalar, *bscalar, *cscalar; + gfc_expr *mult; + gfc_expr *var_1, *var_2, *var_3; + gfc_expr *zero; + gfc_namespace *ns; + gfc_intrinsic_op op_times, op_plus; + enum matrix_case m_case; + int i; + gfc_code *if_limit = NULL; + gfc_code **next_code_point; + bool conjg_a, conjg_b, transpose_a, transpose_b; + bool realloc_c; + + if (co->op != EXEC_ASSIGN) + return 0; + + if (in_where || in_assoc_list) + return 0; + + /* The BLOCKS generated for the temporary variables and FORALL don't + mix. */ + if (forall_level > 0) + return 0; + + /* For now don't do anything in OpenMP workshare, it confuses + its translation, which expects only the allowed statements in there. + We should figure out how to parallelize this eventually. */ + if (in_omp_workshare || in_omp_atomic) + return 0; + + expr1 = co->expr1; + expr2 = co->expr2; + if (expr2->expr_type != EXPR_FUNCTION + || expr2->value.function.isym == NULL + || expr2->value.function.isym->id != GFC_ISYM_MATMUL) + return 0; + + current_code = c; + inserted_block = NULL; + changed_statement = NULL; + + a = expr2->value.function.actual; + matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); + if (matrix_a == NULL) + return 0; + + b = a->next; + matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); + if (matrix_b == NULL) + return 0; + + if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a) + || gfc_has_dimen_vector_ref (matrix_b)) + return 0; + + /* We do not handle data dependencies yet. */ + if (gfc_check_dependency (expr1, matrix_a, true) + || gfc_check_dependency (expr1, matrix_b, true)) + return 0; + + m_case = none; + if (matrix_a->rank == 2) + { + if (transpose_a) + { + if (matrix_b->rank == 2 && !transpose_b) + m_case = A2TB2; + } + else + { + if (matrix_b->rank == 1) + m_case = A2B1; + else /* matrix_b->rank == 2 */ + { + if (transpose_b) + m_case = A2B2T; + else + m_case = A2B2; + } + } + } + else /* matrix_a->rank == 1 */ + { + if (matrix_b->rank == 2) + { + if (!transpose_b) + m_case = A1B2; + } + } + + if (m_case == none) + return 0; + + /* We only handle assignment to numeric or logical variables. */ + switch(expr1->ts.type) + { + case BT_INTEGER: + case BT_LOGICAL: + case BT_REAL: + case BT_COMPLEX: + break; + + default: + return 0; + } + + ns = insert_block (); + + /* Assign the type of the zero expression for initializing the resulting + array, and the expression (+ and * for real, integer and complex; + .and. and .or for logical. */ + + switch(expr1->ts.type) + { + case BT_INTEGER: + zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0); + op_times = INTRINSIC_TIMES; + op_plus = INTRINSIC_PLUS; + break; + + case BT_LOGICAL: + op_times = INTRINSIC_AND; + op_plus = INTRINSIC_OR; + zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where, + 0); + break; + case BT_REAL: + zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind, + &expr1->where); + mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE); + op_times = INTRINSIC_TIMES; + op_plus = INTRINSIC_PLUS; + break; + + case BT_COMPLEX: + zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind, + &expr1->where); + mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE); + op_times = INTRINSIC_TIMES; + op_plus = INTRINSIC_PLUS; + + break; + + default: + gcc_unreachable(); + } + + current_code = &ns->code; + + /* Freeze the references, keeping track of how many temporary variables were + created. */ + n_vars = 0; + freeze_references (matrix_a); + freeze_references (matrix_b); + freeze_references (expr1); + + if (n_vars == 0) + next_code_point = current_code; + else + { + next_code_point = &ns->code; + for (i=0; inext; + } + + /* Take care of the inline flag. If the limit check evaluates to a + constant, dead code elimination will eliminate the unneeded branch. */ + + if (flag_inline_matmul_limit > 0 + && (matrix_a->rank == 1 || matrix_a->rank == 2) + && matrix_b->rank == 2) + { + if_limit = inline_limit_check (matrix_a, matrix_b, + flag_inline_matmul_limit, + matrix_a->rank); + + /* Insert the original statement into the else branch. */ + if_limit->block->block->next = co; + co->next = NULL; + + /* ... and the new ones go into the original one. */ + *next_code_point = if_limit; + next_code_point = &if_limit->block->next; + } + + zero_e->no_bounds_check = 1; + + assign_zero = XCNEW (gfc_code); + assign_zero->op = EXEC_ASSIGN; + assign_zero->loc = co->loc; + assign_zero->expr1 = gfc_copy_expr (expr1); + assign_zero->expr1->no_bounds_check = 1; + assign_zero->expr2 = zero_e; + + realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); + + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + gfc_code *test; + gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; + + switch (m_case) + { + case A2B1: + + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + test = runtime_error_ne (b1, a2, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (c1, a1, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + case A1B2: + + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (b1, a1, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + test = runtime_error_ne (c1, b2, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + case A2B2: + + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + test = runtime_error_ne (b1, a2, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (c1, a1, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + test = runtime_error_ne (c2, b2, C_ERROR_2); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + case A2B2T: + + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + /* matrix_b is transposed, hence dimension 1 for the error message. */ + test = runtime_error_ne (b2, a2, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (c1, a1, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + test = runtime_error_ne (c2, b1, C_ERROR_2); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + case A2TB2: + + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (b1, a1, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + test = runtime_error_ne (c1, a2, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + test = runtime_error_ne (c2, b2, C_ERROR_2); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + default: + gcc_unreachable (); + } + } + + /* Handle the reallocation, if needed. */ + + if (realloc_c) + { + gfc_code *lhs_alloc; + + lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); + + *next_code_point = lhs_alloc; + next_code_point = &lhs_alloc->next; + + } + + *next_code_point = assign_zero; + + zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0); + + assign_matmul = XCNEW (gfc_code); + assign_matmul->op = EXEC_ASSIGN; + assign_matmul->loc = co->loc; + + /* Get the bounds for the loops, create them and create the scalarized + expressions. */ + + switch (m_case) + { + case A2B2: + + u1 = get_size_m1 (matrix_b, 2); + u2 = get_size_m1 (matrix_a, 2); + u3 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = do_3; + do_3->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + var_3 = do_3->ext.iterator->var; + + list[0] = var_3; + list[1] = var_1; + cscalar = scalarized_expr (co->expr1, list, 2); + + list[0] = var_3; + list[1] = var_2; + ascalar = scalarized_expr (matrix_a, list, 2); + + list[0] = var_2; + list[1] = var_1; + bscalar = scalarized_expr (matrix_b, list, 2); + + break; + + case A2B2T: + + u1 = get_size_m1 (matrix_b, 1); + u2 = get_size_m1 (matrix_a, 2); + u3 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = do_3; + do_3->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + var_3 = do_3->ext.iterator->var; + + list[0] = var_3; + list[1] = var_1; + cscalar = scalarized_expr (co->expr1, list, 2); + + list[0] = var_3; + list[1] = var_2; + ascalar = scalarized_expr (matrix_a, list, 2); + + list[0] = var_1; + list[1] = var_2; + bscalar = scalarized_expr (matrix_b, list, 2); + + break; + + case A2TB2: + + u1 = get_size_m1 (matrix_a, 2); + u2 = get_size_m1 (matrix_b, 2); + u3 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = do_3; + do_3->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + var_3 = do_3->ext.iterator->var; + + list[0] = var_1; + list[1] = var_2; + cscalar = scalarized_expr (co->expr1, list, 2); + + list[0] = var_3; + list[1] = var_1; + ascalar = scalarized_expr (matrix_a, list, 2); + + list[0] = var_3; + list[1] = var_2; + bscalar = scalarized_expr (matrix_b, list, 2); + + break; + + case A2B1: + u1 = get_size_m1 (matrix_b, 1); + u2 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + + list[0] = var_2; + cscalar = scalarized_expr (co->expr1, list, 1); + + list[0] = var_2; + list[1] = var_1; + ascalar = scalarized_expr (matrix_a, list, 2); + + list[0] = var_1; + bscalar = scalarized_expr (matrix_b, list, 1); + + break; + + case A1B2: + u1 = get_size_m1 (matrix_b, 2); + u2 = get_size_m1 (matrix_a, 1); + + do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); + do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); + + do_1->block->next = do_2; + do_2->block->next = assign_matmul; + + var_1 = do_1->ext.iterator->var; + var_2 = do_2->ext.iterator->var; + + list[0] = var_1; + cscalar = scalarized_expr (co->expr1, list, 1); + + list[0] = var_2; + ascalar = scalarized_expr (matrix_a, list, 1); + + list[0] = var_2; + list[1] = var_1; + bscalar = scalarized_expr (matrix_b, list, 2); + + break; + + default: + gcc_unreachable(); + } + + /* Build the conjg call around the variables. Set the typespec manually + because gfc_build_intrinsic_call sometimes gets this wrong. */ + if (conjg_a) + { + gfc_typespec ts; + ts = matrix_a->ts; + ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", + matrix_a->where, 1, ascalar); + ascalar->ts = ts; + } + + if (conjg_b) + { + gfc_typespec ts; + ts = matrix_b->ts; + bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", + matrix_b->where, 1, bscalar); + bscalar->ts = ts; + } + /* First loop comes after the zero assignment. */ + assign_zero->next = do_1; + + /* Build the assignment expression in the loop. */ + assign_matmul->expr1 = gfc_copy_expr (cscalar); + + mult = get_operand (op_times, ascalar, bscalar); + assign_matmul->expr2 = get_operand (op_plus, cscalar, mult); + + /* If we don't want to keep the original statement around in + the else branch, we can free it. */ + + if (if_limit == NULL) + gfc_free_statements(co); + else + co->next = NULL; + + gfc_free_expr (zero); + *walk_subtrees = 0; + return 0; +} + +/* Change matmul function calls in the form of + + c = matmul(a,b) + + to the corresponding call to a BLAS routine, if applicable. */ + +static int +call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co, *co_next; + gfc_expr *expr1, *expr2; + gfc_expr *matrix_a, *matrix_b; + gfc_code *if_limit = NULL; + gfc_actual_arglist *a, *b; + bool conjg_a, conjg_b, transpose_a, transpose_b; + gfc_code *call; + const char *blas_name; + const char *transa, *transb; + gfc_expr *c1, *c2, *b1; + gfc_actual_arglist *actual, *next; + bt type; + int kind; + enum matrix_case m_case; + bool realloc_c; + gfc_code **next_code_point; + + /* Many of the tests for inline matmul also apply here. */ + + co = *c; + + if (co->op != EXEC_ASSIGN) + return 0; + + if (in_where || in_assoc_list) + return 0; + + /* The BLOCKS generated for the temporary variables and FORALL don't + mix. */ + if (forall_level > 0) + return 0; + + /* For now don't do anything in OpenMP workshare, it confuses + its translation, which expects only the allowed statements in there. */ + + if (in_omp_workshare || in_omp_atomic) + return 0; + + expr1 = co->expr1; + expr2 = co->expr2; + if (expr2->expr_type != EXPR_FUNCTION + || expr2->value.function.isym == NULL + || expr2->value.function.isym->id != GFC_ISYM_MATMUL) + return 0; + + type = expr2->ts.type; + kind = expr2->ts.kind; + + /* Guard against recursion. */ + + if (expr2->external_blas) + return 0; + + if (type != expr1->ts.type || kind != expr1->ts.kind) + return 0; + + if (type == BT_REAL) + { + if (kind == 4) + blas_name = "sgemm"; + else if (kind == 8) + blas_name = "dgemm"; + else + return 0; + } + else if (type == BT_COMPLEX) + { + if (kind == 4) + blas_name = "cgemm"; + else if (kind == 8) + blas_name = "zgemm"; + else + return 0; + } + else + return 0; + + a = expr2->value.function.actual; + if (a->expr->rank != 2) + return 0; + + b = a->next; + if (b->expr->rank != 2) + return 0; + + matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); + if (matrix_a == NULL) + return 0; + + if (transpose_a) + { + if (conjg_a) + transa = "C"; + else + transa = "T"; + } + else + transa = "N"; + + matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); + if (matrix_b == NULL) + return 0; + + if (transpose_b) + { + if (conjg_b) + transb = "C"; + else + transb = "T"; + } + else + transb = "N"; + + if (transpose_a) + { + if (transpose_b) + m_case = A2TB2T; + else + m_case = A2TB2; + } + else + { + if (transpose_b) + m_case = A2B2T; + else + m_case = A2B2; + } + + current_code = c; + inserted_block = NULL; + changed_statement = NULL; + + expr2->external_blas = 1; + + /* We do not handle data dependencies yet. */ + if (gfc_check_dependency (expr1, matrix_a, true) + || gfc_check_dependency (expr1, matrix_b, true)) + return 0; + + /* Generate the if statement and hang it into the tree. */ + if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit, 2); + co_next = co->next; + (*current_code) = if_limit; + co->next = NULL; + if_limit->block->next = co; + + call = XCNEW (gfc_code); + call->loc = co->loc; + + /* Bounds checking - a bit simpler than for inlining since we only + have to take care of two-dimensional arrays here. */ + + realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); + next_code_point = &(if_limit->block->block->next); + + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + gfc_code *test; + // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; + gfc_expr *c1, *a1, *c2, *b2, *a2; + switch (m_case) + { + case A2B2: + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + test = runtime_error_ne (b1, a2, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (c1, a1, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + test = runtime_error_ne (c2, b2, C_ERROR_2); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + case A2B2T: + + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + /* matrix_b is transposed, hence dimension 1 for the error message. */ + test = runtime_error_ne (b2, a2, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (c1, a1, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + test = runtime_error_ne (c2, b1, C_ERROR_2); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + case A2TB2: + + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (b1, a1, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + test = runtime_error_ne (c1, a2, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + test = runtime_error_ne (c2, b2, C_ERROR_2); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + case A2TB2T: + b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); + a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); + test = runtime_error_ne (b2, a1, B_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + if (!realloc_c) + { + c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); + a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); + test = runtime_error_ne (c1, a2, C_ERROR_1); + *next_code_point = test; + next_code_point = &test->next; + + c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); + b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); + test = runtime_error_ne (c2, b1, C_ERROR_2); + *next_code_point = test; + next_code_point = &test->next; + } + break; + + default: + gcc_unreachable (); + } + } + + /* Handle the reallocation, if needed. */ + + if (realloc_c) + { + gfc_code *lhs_alloc; + + lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); + *next_code_point = lhs_alloc; + next_code_point = &lhs_alloc->next; + } + + *next_code_point = call; + if_limit->next = co_next; + + /* Set up the BLAS call. */ + + call->op = EXEC_CALL; + + gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true); + call->symtree->n.sym->attr.subroutine = 1; + call->symtree->n.sym->attr.procedure = 1; + call->symtree->n.sym->attr.flavor = FL_PROCEDURE; + call->resolved_sym = call->symtree->n.sym; + gfc_commit_symbol (call->resolved_sym); + + /* Argument TRANSA. */ + next = gfc_get_actual_arglist (); + next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, + transa, 1); + + call->ext.actual = next; + + /* Argument TRANSB. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, + transb, 1); + actual->next = next; + + c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1, + gfc_integer_4_kind); + c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2, + gfc_integer_4_kind); + + b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1, + gfc_integer_4_kind); + + /* Argument M. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = c1; + actual->next = next; + + /* Argument N. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = c2; + actual->next = next; + + /* Argument K. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = b1; + actual->next = next; + + /* Argument ALPHA - set to one. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = gfc_get_constant_expr (type, kind, &co->loc); + if (type == BT_REAL) + mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE); + else + mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE); + actual->next = next; + + /* Argument A. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = gfc_copy_expr (matrix_a); + actual->next = next; + + /* Argument LDA. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a), + 1, gfc_integer_4_kind); + actual->next = next; + + /* Argument B. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = gfc_copy_expr (matrix_b); + actual->next = next; + + /* Argument LDB. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b), + 1, gfc_integer_4_kind); + actual->next = next; + + /* Argument BETA - set to zero. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = gfc_get_constant_expr (type, kind, &co->loc); + if (type == BT_REAL) + mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE); + else + mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE); + actual->next = next; + + /* Argument C. */ + + actual = next; + next = gfc_get_actual_arglist (); + next->expr = gfc_copy_expr (expr1); + actual->next = next; + + /* Argument LDC. */ + actual = next; + next = gfc_get_actual_arglist (); + next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1), + 1, gfc_integer_4_kind); + actual->next = next; + + return 0; +} + + +/* Code for index interchange for loops which are grouped together in DO + CONCURRENT or FORALL statements. This is currently only applied if the + iterations are grouped together in a single statement. + + For this transformation, it is assumed that memory access in strides is + expensive, and that loops which access later indices (which access memory + in bigger strides) should be moved to the first loops. + + For this, a loop over all the statements is executed, counting the times + that the loop iteration values are accessed in each index. The loop + indices are then sorted to minimize access to later indices from inner + loops. */ + +/* Type for holding index information. */ + +typedef struct { + gfc_symbol *sym; + gfc_forall_iterator *fa; + int num; + int n[GFC_MAX_DIMENSIONS]; +} ind_type; + +/* Callback function to determine if an expression is the + corresponding variable. */ + +static int +has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data) +{ + gfc_expr *expr = *e; + gfc_symbol *sym; + + if (expr->expr_type != EXPR_VARIABLE) + return 0; + + sym = (gfc_symbol *) data; + return sym == expr->symtree->n.sym; +} + +/* Callback function to calculate the cost of a certain index. */ + +static int +index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + ind_type *ind; + gfc_expr *expr; + gfc_array_ref *ar; + gfc_ref *ref; + int i,j; + + expr = *e; + if (expr->expr_type != EXPR_VARIABLE) + return 0; + + ar = NULL; + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + ar = &ref->u.ar; + break; + } + } + if (ar == NULL || ar->type != AR_ELEMENT) + return 0; + + ind = (ind_type *) data; + for (i = 0; i < ar->dimen; i++) + { + for (j=0; ind[j].sym != NULL; j++) + { + if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym))) + ind[j].n[i]++; + } + } + return 0; +} + +/* Callback function for qsort, to sort the loop indices. */ + +static int +loop_comp (const void *e1, const void *e2) +{ + const ind_type *i1 = (const ind_type *) e1; + const ind_type *i2 = (const ind_type *) e2; + int i; + + for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--) + { + if (i1->n[i] != i2->n[i]) + return i1->n[i] - i2->n[i]; + } + /* All other things being equal, let's not change the ordering. */ + return i2->num - i1->num; +} + +/* Main function to do the index interchange. */ + +static int +index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co; + co = *c; + int n_iter; + gfc_forall_iterator *fa; + ind_type *ind; + int i, j; + + if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT) + return 0; + + n_iter = 0; + for (fa = co->ext.forall_iterator; fa; fa = fa->next) + n_iter ++; + + /* Nothing to reorder. */ + if (n_iter < 2) + return 0; + + ind = XALLOCAVEC (ind_type, n_iter + 1); + + i = 0; + for (fa = co->ext.forall_iterator; fa; fa = fa->next) + { + ind[i].sym = fa->var->symtree->n.sym; + ind[i].fa = fa; + for (j=0; jext.forall_iterator = fa = ind[0].fa; + for (i=1; inext = ind[i].fa; + fa = fa->next; + } + fa->next = NULL; + + if (flag_warn_frontend_loop_interchange) + { + for (i=1; i ind[i].num) + { + gfc_warning (OPT_Wfrontend_loop_interchange, + "Interchanging loops at %L", &co->loc); + break; + } + } + } + + return 0; +} + +#define WALK_SUBEXPR(NODE) \ + do \ + { \ + result = gfc_expr_walker (&(NODE), exprfn, data); \ + if (result) \ + return result; \ + } \ + while (0) +#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue + +/* Walk expression *E, calling EXPRFN on each expression in it. */ + +int +gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) +{ + while (*e) + { + int walk_subtrees = 1; + gfc_actual_arglist *a; + gfc_ref *r; + gfc_constructor *c; + + int result = exprfn (e, &walk_subtrees, data); + if (result) + return result; + if (walk_subtrees) + switch ((*e)->expr_type) + { + case EXPR_OP: + WALK_SUBEXPR ((*e)->value.op.op1); + WALK_SUBEXPR_TAIL ((*e)->value.op.op2); + /* No fallthru because of the tail recursion above. */ + case EXPR_FUNCTION: + for (a = (*e)->value.function.actual; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + case EXPR_COMPCALL: + case EXPR_PPC: + WALK_SUBEXPR ((*e)->value.compcall.base_object); + for (a = (*e)->value.compcall.actual; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + for (c = gfc_constructor_first ((*e)->value.constructor); c; + c = gfc_constructor_next (c)) + { + if (c->iterator == NULL) + WALK_SUBEXPR (c->expr); + else + { + iterator_level ++; + WALK_SUBEXPR (c->expr); + iterator_level --; + WALK_SUBEXPR (c->iterator->var); + WALK_SUBEXPR (c->iterator->start); + WALK_SUBEXPR (c->iterator->end); + WALK_SUBEXPR (c->iterator->step); + } + } + + if ((*e)->expr_type != EXPR_ARRAY) + break; + + /* Fall through to the variable case in order to walk the + reference. */ + gcc_fallthrough (); + + case EXPR_SUBSTRING: + case EXPR_VARIABLE: + for (r = (*e)->ref; r; r = r->next) + { + gfc_array_ref *ar; + int i; + + switch (r->type) + { + case REF_ARRAY: + ar = &r->u.ar; + if (ar->type == AR_SECTION || ar->type == AR_ELEMENT) + { + for (i=0; i< ar->dimen; i++) + { + WALK_SUBEXPR (ar->start[i]); + WALK_SUBEXPR (ar->end[i]); + WALK_SUBEXPR (ar->stride[i]); + } + } + + break; + + case REF_SUBSTRING: + WALK_SUBEXPR (r->u.ss.start); + WALK_SUBEXPR (r->u.ss.end); + break; + + case REF_COMPONENT: + case REF_INQUIRY: + break; + } + } + + default: + break; + } + return 0; + } + return 0; +} + +#define WALK_SUBCODE(NODE) \ + do \ + { \ + result = gfc_code_walker (&(NODE), codefn, exprfn, data); \ + if (result) \ + return result; \ + } \ + while (0) + +/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN + on each expression in it. If any of the hooks returns non-zero, that + value is immediately returned. If the hook sets *WALK_SUBTREES to 0, + no subcodes or subexpressions are traversed. */ + +int +gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, + void *data) +{ + for (; *c; c = &(*c)->next) + { + int walk_subtrees = 1; + int result = codefn (c, &walk_subtrees, data); + if (result) + return result; + + if (walk_subtrees) + { + gfc_code *b; + gfc_actual_arglist *a; + gfc_code *co; + gfc_association_list *alist; + bool saved_in_omp_workshare; + bool saved_in_omp_atomic; + bool saved_in_where; + + /* There might be statement insertions before the current code, + which must not affect the expression walker. */ + + co = *c; + saved_in_omp_workshare = in_omp_workshare; + saved_in_omp_atomic = in_omp_atomic; + saved_in_where = in_where; + + switch (co->op) + { + + case EXEC_BLOCK: + WALK_SUBCODE (co->ext.block.ns->code); + if (co->ext.block.assoc) + { + bool saved_in_assoc_list = in_assoc_list; + + in_assoc_list = true; + for (alist = co->ext.block.assoc; alist; alist = alist->next) + WALK_SUBEXPR (alist->target); + + in_assoc_list = saved_in_assoc_list; + } + + break; + + case EXEC_DO: + doloop_level ++; + WALK_SUBEXPR (co->ext.iterator->var); + WALK_SUBEXPR (co->ext.iterator->start); + WALK_SUBEXPR (co->ext.iterator->end); + WALK_SUBEXPR (co->ext.iterator->step); + break; + + case EXEC_IF: + if_level ++; + break; + + case EXEC_WHERE: + in_where = true; + break; + + case EXEC_CALL: + case EXEC_ASSIGN_CALL: + for (a = co->ext.actual; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + + case EXEC_CALL_PPC: + WALK_SUBEXPR (co->expr1); + for (a = co->ext.actual; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + + case EXEC_SELECT: + WALK_SUBEXPR (co->expr1); + select_level ++; + for (b = co->block; b; b = b->block) + { + gfc_case *cp; + for (cp = b->ext.block.case_list; cp; cp = cp->next) + { + WALK_SUBEXPR (cp->low); + WALK_SUBEXPR (cp->high); + } + WALK_SUBCODE (b->next); + } + continue; + + case EXEC_ALLOCATE: + case EXEC_DEALLOCATE: + { + gfc_alloc *a; + for (a = co->ext.alloc.list; a; a = a->next) + WALK_SUBEXPR (a->expr); + break; + } + + case EXEC_FORALL: + case EXEC_DO_CONCURRENT: + { + gfc_forall_iterator *fa; + for (fa = co->ext.forall_iterator; fa; fa = fa->next) + { + WALK_SUBEXPR (fa->var); + WALK_SUBEXPR (fa->start); + WALK_SUBEXPR (fa->end); + WALK_SUBEXPR (fa->stride); + } + if (co->op == EXEC_FORALL) + forall_level ++; + break; + } + + case EXEC_OPEN: + WALK_SUBEXPR (co->ext.open->unit); + WALK_SUBEXPR (co->ext.open->file); + WALK_SUBEXPR (co->ext.open->status); + WALK_SUBEXPR (co->ext.open->access); + WALK_SUBEXPR (co->ext.open->form); + WALK_SUBEXPR (co->ext.open->recl); + WALK_SUBEXPR (co->ext.open->blank); + WALK_SUBEXPR (co->ext.open->position); + WALK_SUBEXPR (co->ext.open->action); + WALK_SUBEXPR (co->ext.open->delim); + WALK_SUBEXPR (co->ext.open->pad); + WALK_SUBEXPR (co->ext.open->iostat); + WALK_SUBEXPR (co->ext.open->iomsg); + WALK_SUBEXPR (co->ext.open->convert); + WALK_SUBEXPR (co->ext.open->decimal); + WALK_SUBEXPR (co->ext.open->encoding); + WALK_SUBEXPR (co->ext.open->round); + WALK_SUBEXPR (co->ext.open->sign); + WALK_SUBEXPR (co->ext.open->asynchronous); + WALK_SUBEXPR (co->ext.open->id); + WALK_SUBEXPR (co->ext.open->newunit); + WALK_SUBEXPR (co->ext.open->share); + WALK_SUBEXPR (co->ext.open->cc); + break; + + case EXEC_CLOSE: + WALK_SUBEXPR (co->ext.close->unit); + WALK_SUBEXPR (co->ext.close->status); + WALK_SUBEXPR (co->ext.close->iostat); + WALK_SUBEXPR (co->ext.close->iomsg); + break; + + case EXEC_BACKSPACE: + case EXEC_ENDFILE: + case EXEC_REWIND: + case EXEC_FLUSH: + WALK_SUBEXPR (co->ext.filepos->unit); + WALK_SUBEXPR (co->ext.filepos->iostat); + WALK_SUBEXPR (co->ext.filepos->iomsg); + break; + + case EXEC_INQUIRE: + WALK_SUBEXPR (co->ext.inquire->unit); + WALK_SUBEXPR (co->ext.inquire->file); + WALK_SUBEXPR (co->ext.inquire->iomsg); + WALK_SUBEXPR (co->ext.inquire->iostat); + WALK_SUBEXPR (co->ext.inquire->exist); + WALK_SUBEXPR (co->ext.inquire->opened); + WALK_SUBEXPR (co->ext.inquire->number); + WALK_SUBEXPR (co->ext.inquire->named); + WALK_SUBEXPR (co->ext.inquire->name); + WALK_SUBEXPR (co->ext.inquire->access); + WALK_SUBEXPR (co->ext.inquire->sequential); + WALK_SUBEXPR (co->ext.inquire->direct); + WALK_SUBEXPR (co->ext.inquire->form); + WALK_SUBEXPR (co->ext.inquire->formatted); + WALK_SUBEXPR (co->ext.inquire->unformatted); + WALK_SUBEXPR (co->ext.inquire->recl); + WALK_SUBEXPR (co->ext.inquire->nextrec); + WALK_SUBEXPR (co->ext.inquire->blank); + WALK_SUBEXPR (co->ext.inquire->position); + WALK_SUBEXPR (co->ext.inquire->action); + WALK_SUBEXPR (co->ext.inquire->read); + WALK_SUBEXPR (co->ext.inquire->write); + WALK_SUBEXPR (co->ext.inquire->readwrite); + WALK_SUBEXPR (co->ext.inquire->delim); + WALK_SUBEXPR (co->ext.inquire->encoding); + WALK_SUBEXPR (co->ext.inquire->pad); + WALK_SUBEXPR (co->ext.inquire->iolength); + WALK_SUBEXPR (co->ext.inquire->convert); + WALK_SUBEXPR (co->ext.inquire->strm_pos); + WALK_SUBEXPR (co->ext.inquire->asynchronous); + WALK_SUBEXPR (co->ext.inquire->decimal); + WALK_SUBEXPR (co->ext.inquire->pending); + WALK_SUBEXPR (co->ext.inquire->id); + WALK_SUBEXPR (co->ext.inquire->sign); + WALK_SUBEXPR (co->ext.inquire->size); + WALK_SUBEXPR (co->ext.inquire->round); + break; + + case EXEC_WAIT: + WALK_SUBEXPR (co->ext.wait->unit); + WALK_SUBEXPR (co->ext.wait->iostat); + WALK_SUBEXPR (co->ext.wait->iomsg); + WALK_SUBEXPR (co->ext.wait->id); + break; + + case EXEC_READ: + case EXEC_WRITE: + WALK_SUBEXPR (co->ext.dt->io_unit); + WALK_SUBEXPR (co->ext.dt->format_expr); + WALK_SUBEXPR (co->ext.dt->rec); + WALK_SUBEXPR (co->ext.dt->advance); + WALK_SUBEXPR (co->ext.dt->iostat); + WALK_SUBEXPR (co->ext.dt->size); + WALK_SUBEXPR (co->ext.dt->iomsg); + WALK_SUBEXPR (co->ext.dt->id); + WALK_SUBEXPR (co->ext.dt->pos); + WALK_SUBEXPR (co->ext.dt->asynchronous); + WALK_SUBEXPR (co->ext.dt->blank); + WALK_SUBEXPR (co->ext.dt->decimal); + WALK_SUBEXPR (co->ext.dt->delim); + WALK_SUBEXPR (co->ext.dt->pad); + WALK_SUBEXPR (co->ext.dt->round); + WALK_SUBEXPR (co->ext.dt->sign); + WALK_SUBEXPR (co->ext.dt->extra_comma); + break; + + case EXEC_OACC_ATOMIC: + case EXEC_OMP_ATOMIC: + in_omp_atomic = true; + break; + + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + + in_omp_workshare = false; + + /* This goto serves as a shortcut to avoid code + duplication or a larger if or switch statement. */ + goto check_omp_clauses; + + case EXEC_OMP_WORKSHARE: + case EXEC_OMP_PARALLEL_WORKSHARE: + + in_omp_workshare = true; + + /* Fall through */ + + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_LOOP: + case EXEC_OMP_ORDERED: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_END_SINGLE: + case EXEC_OMP_SIMD: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + + /* Come to this label only from the + EXEC_OMP_PARALLEL_* cases above. */ + + check_omp_clauses: + + if (co->ext.omp_clauses) + { + gfc_omp_namelist *n; + static int list_types[] + = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND, + OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM }; + size_t idx; + WALK_SUBEXPR (co->ext.omp_clauses->if_expr); + WALK_SUBEXPR (co->ext.omp_clauses->final_expr); + WALK_SUBEXPR (co->ext.omp_clauses->num_threads); + WALK_SUBEXPR (co->ext.omp_clauses->chunk_size); + WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr); + WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr); + WALK_SUBEXPR (co->ext.omp_clauses->num_teams_lower); + WALK_SUBEXPR (co->ext.omp_clauses->num_teams_upper); + WALK_SUBEXPR (co->ext.omp_clauses->device); + WALK_SUBEXPR (co->ext.omp_clauses->thread_limit); + WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size); + WALK_SUBEXPR (co->ext.omp_clauses->grainsize); + WALK_SUBEXPR (co->ext.omp_clauses->hint); + WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); + WALK_SUBEXPR (co->ext.omp_clauses->priority); + WALK_SUBEXPR (co->ext.omp_clauses->detach); + for (idx = 0; idx < OMP_IF_LAST; idx++) + WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]); + for (idx = 0; + idx < sizeof (list_types) / sizeof (list_types[0]); + idx++) + for (n = co->ext.omp_clauses->lists[list_types[idx]]; + n; n = n->next) + WALK_SUBEXPR (n->expr); + } + break; + default: + break; + } + + WALK_SUBEXPR (co->expr1); + WALK_SUBEXPR (co->expr2); + WALK_SUBEXPR (co->expr3); + WALK_SUBEXPR (co->expr4); + for (b = co->block; b; b = b->block) + { + WALK_SUBEXPR (b->expr1); + WALK_SUBEXPR (b->expr2); + WALK_SUBCODE (b->next); + } + + if (co->op == EXEC_FORALL) + forall_level --; + + if (co->op == EXEC_DO) + doloop_level --; + + if (co->op == EXEC_IF) + if_level --; + + if (co->op == EXEC_SELECT) + select_level --; + + in_omp_workshare = saved_in_omp_workshare; + in_omp_atomic = saved_in_omp_atomic; + in_where = saved_in_where; + } + } + return 0; +} + +/* As a post-resolution step, check that all global symbols which are + not declared in the source file match in their call signatures. + We do this by looping over the code (and expressions). The first call + we happen to find is assumed to be canonical. */ + + +/* Common tests for argument checking for both functions and subroutines. */ + +static int +check_externals_procedure (gfc_symbol *sym, locus *loc, + gfc_actual_arglist *actual) +{ + gfc_gsymbol *gsym; + gfc_symbol *def_sym = NULL; + + if (sym == NULL || sym->attr.is_bind_c) + return 0; + + if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) + return 0; + + if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) + return 0; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); + if (gsym == NULL) + return 0; + + if (gsym->ns) + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (def_sym) + { + gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc); + return 0; + } + + /* First time we have seen this procedure called. Let's create an + "interface" from the call and put it into a new namespace. */ + gfc_namespace *save_ns; + gfc_symbol *new_sym; + + gsym->where = *loc; + save_ns = gfc_current_ns; + gsym->ns = gfc_get_namespace (gfc_current_ns, 0); + gsym->ns->proc_name = sym; + + gfc_get_symbol (sym->name, gsym->ns, &new_sym); + gcc_assert (new_sym); + new_sym->attr = sym->attr; + new_sym->attr.if_source = IFSRC_DECL; + gfc_current_ns = gsym->ns; + + gfc_get_formal_from_actual_arglist (new_sym, actual); + new_sym->declared_at = *loc; + gfc_current_ns = save_ns; + + return 0; + +} + +/* Callback for calls of external routines. */ + +static int +check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co = *c; + gfc_symbol *sym; + locus *loc; + gfc_actual_arglist *actual; + + if (co->op != EXEC_CALL) + return 0; + + sym = co->resolved_sym; + loc = &co->loc; + actual = co->ext.actual; + + return check_externals_procedure (sym, loc, actual); + +} + +/* Callback for external functions. */ + +static int +check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_expr *e = *ep; + gfc_symbol *sym; + locus *loc; + gfc_actual_arglist *actual; + + if (e->expr_type != EXPR_FUNCTION) + return 0; + + sym = e->value.function.esym; + if (sym == NULL) + return 0; + + loc = &e->where; + actual = e->value.function.actual; + + return check_externals_procedure (sym, loc, actual); +} + +/* Function to check if any interface clashes with a global + identifier, to be invoked via gfc_traverse_ns. */ + +static void +check_against_globals (gfc_symbol *sym) +{ + gfc_gsymbol *gsym; + gfc_symbol *def_sym = NULL; + const char *sym_name; + char buf [200]; + + if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE + || sym->attr.generic || sym->error) + return; + + if (sym->binding_label) + sym_name = sym->binding_label; + else + sym_name = sym->name; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name); + if (gsym && gsym->ns) + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (!def_sym || def_sym->error || def_sym->attr.generic) + return; + + buf[0] = 0; + gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf), + NULL, NULL, NULL); + if (buf[0] != 0) + { + gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at, + &sym->declared_at); + sym->error = 1; + def_sym->error = 1; + } + +} + +/* Do the code-walkling part for gfc_check_externals. */ + +static void +gfc_check_externals0 (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + gfc_check_externals0 (ns); + } + +} + +/* Called routine. */ + +void +gfc_check_externals (gfc_namespace *ns) +{ + gfc_clear_error (); + + /* Turn errors into warnings if the user indicated this. */ + + if (!pedantic && flag_allow_argument_mismatch) + gfc_errors_to_warnings (true); + + gfc_check_externals0 (ns); + gfc_traverse_ns (ns, check_against_globals); + + gfc_errors_to_warnings (false); +} + +/* Callback function. If there is a call to a subroutine which is + neither pure nor implicit_pure, unset the implicit_pure flag for + the caller and return -1. */ + +static int +implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *sym_data) +{ + gfc_code *co = *c; + gfc_symbol *caller_sym; + symbol_attribute *a; + + if (co->op != EXEC_CALL || co->resolved_sym == NULL) + return 0; + + a = &co->resolved_sym->attr; + if (a->intrinsic || a->pure || a->implicit_pure) + return 0; + + caller_sym = (gfc_symbol *) sym_data; + gfc_unset_implicit_pure (caller_sym); + return 1; +} + +/* Callback function. If there is a call to a function which is + neither pure nor implicit_pure, unset the implicit_pure flag for + the caller and return 1. */ + +static int +implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data) +{ + gfc_expr *expr = *e; + gfc_symbol *caller_sym; + gfc_symbol *sym; + symbol_attribute *a; + + if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym) + return 0; + + sym = expr->symtree->n.sym; + a = &sym->attr; + if (a->pure || a->implicit_pure) + return 0; + + caller_sym = (gfc_symbol *) sym_data; + gfc_unset_implicit_pure (caller_sym); + return 1; +} + +/* Go through all procedures in the namespace and unset the + implicit_pure attribute for any procedure that calls something not + pure or implicit pure. */ + +bool +gfc_fix_implicit_pure (gfc_namespace *ns) +{ + bool changed = false; + gfc_symbol *proc = ns->proc_name; + + if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure + && ns->code + && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr, + (void *) ns->proc_name)) + changed = true; + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (gfc_fix_implicit_pure (ns)) + changed = true; + } + + return changed; +} diff --git a/gcc/fortran/gfortranspec.c b/gcc/fortran/gfortranspec.c deleted file mode 100644 index 4858366..0000000 --- a/gcc/fortran/gfortranspec.c +++ /dev/null @@ -1,450 +0,0 @@ -/* Specific flags and argument handling of the Fortran front-end. - Copyright (C) 1997-2022 Free Software Foundation, Inc. - -This file is part of GCC. - -GNU CC 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. - -GNU CC 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 -. */ - -/* This file is copied more or less verbatim from g77. */ -/* This file contains a filter for the main `gcc' driver, which is - replicated for the `gfortran' driver by adding this filter. The purpose - of this filter is to be basically identical to gcc (in that - it faithfully passes all of the original arguments to gcc) but, - unless explicitly overridden by the user in certain ways, ensure - that the needs of the language supported by this wrapper are met. - - For GNU Fortran 95(gfortran), we do the following to the argument list - before passing it to `gcc': - - 1. Make sure `-lgfortran -lm' is at the end of the list. - - 2. Make sure each time `-lgfortran' or `-lm' is seen, it forms - part of the series `-lgfortran -lm'. - - #1 and #2 are not done if `-nostdlib' or any option that disables - the linking phase is present, or if `-xfoo' is in effect. Note that - a lack of source files or -l options disables linking. - - This program was originally made out of gcc/cp/g++spec.c, but the - way it builds the new argument list was rewritten so it is much - easier to maintain, improve the way it decides to add or not add - extra arguments, etc. And several improvements were made in the - handling of arguments, primarily to make it more consistent with - `gcc' itself. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "opt-suggestions.h" -#include "gcc.h" -#include "opts.h" - -#include "tm.h" -#include "intl.h" - -#ifndef MATH_LIBRARY -#define MATH_LIBRARY "m" -#endif - -#ifndef FORTRAN_LIBRARY -#define FORTRAN_LIBRARY "gfortran" -#endif - -/* Name of the spec file. */ -#define SPEC_FILE "libgfortran.spec" - -/* The original argument list and related info is copied here. */ -static unsigned int g77_xargc; -static const struct cl_decoded_option *g77_x_decoded_options; -static void append_arg (const struct cl_decoded_option *); - -/* The new argument list will be built here. */ -static unsigned int g77_newargc; -static struct cl_decoded_option *g77_new_decoded_options; - -/* This will be NULL if we encounter a situation where we should not - link in the fortran libraries. */ -static const char *library = NULL; - - -/* Return whether strings S1 and S2 are both NULL or both the same - string. */ - -static bool -strings_same (const char *s1, const char *s2) -{ - return s1 == s2 || (s1 != NULL && s2 != NULL && strcmp (s1, s2) == 0); -} - -/* Return whether decoded option structures OPT1 and OPT2 are the - same. */ - -static bool -options_same (const struct cl_decoded_option *opt1, - const struct cl_decoded_option *opt2) -{ - return (opt1->opt_index == opt2->opt_index - && strings_same (opt1->arg, opt2->arg) - && strings_same (opt1->orig_option_with_args_text, - opt2->orig_option_with_args_text) - && strings_same (opt1->canonical_option[0], - opt2->canonical_option[0]) - && strings_same (opt1->canonical_option[1], - opt2->canonical_option[1]) - && strings_same (opt1->canonical_option[2], - opt2->canonical_option[2]) - && strings_same (opt1->canonical_option[3], - opt2->canonical_option[3]) - && (opt1->canonical_option_num_elements - == opt2->canonical_option_num_elements) - && opt1->value == opt2->value - && opt1->errors == opt2->errors); -} - -/* Append another argument to the list being built. As long as it is - identical to the corresponding arg in the original list, just increment - the new arg count. Otherwise allocate a new list, etc. */ - -static void -append_arg (const struct cl_decoded_option *arg) -{ - static unsigned int newargsize; - - if (g77_new_decoded_options == g77_x_decoded_options - && g77_newargc < g77_xargc - && options_same (arg, &g77_x_decoded_options[g77_newargc])) - { - ++g77_newargc; - return; /* Nothing new here. */ - } - - if (g77_new_decoded_options == g77_x_decoded_options) - { /* Make new arglist. */ - unsigned int i; - - newargsize = (g77_xargc << 2) + 20; /* This should handle all. */ - g77_new_decoded_options = XNEWVEC (struct cl_decoded_option, newargsize); - - /* Copy what has been done so far. */ - for (i = 0; i < g77_newargc; ++i) - g77_new_decoded_options[i] = g77_x_decoded_options[i]; - } - - if (g77_newargc == newargsize) - fatal_error (input_location, "overflowed output argument list for %qs", - arg->orig_option_with_args_text); - - g77_new_decoded_options[g77_newargc++] = *arg; -} - -/* Append an option described by OPT_INDEX, ARG and VALUE to the list - being built. */ -static void -append_option (size_t opt_index, const char *arg, int value) -{ - struct cl_decoded_option decoded; - - generate_option (opt_index, arg, value, CL_DRIVER, &decoded); - append_arg (&decoded); -} - -/* Append a libgfortran argument to the list being built. If - FORCE_STATIC, ensure the library is linked statically. */ - -static void -add_arg_libgfortran (bool force_static ATTRIBUTE_UNUSED) -{ -#ifdef HAVE_LD_STATIC_DYNAMIC - if (force_static) - append_option (OPT_Wl_, LD_STATIC_OPTION, 1); -#endif - append_option (OPT_l, FORTRAN_LIBRARY, 1); -#ifdef HAVE_LD_STATIC_DYNAMIC - if (force_static) - append_option (OPT_Wl_, LD_DYNAMIC_OPTION, 1); -#endif -} - -void -lang_specific_driver (struct cl_decoded_option **in_decoded_options, - unsigned int *in_decoded_options_count, - int *in_added_libraries ATTRIBUTE_UNUSED) -{ - unsigned int argc = *in_decoded_options_count; - struct cl_decoded_option *decoded_options = *in_decoded_options; - unsigned int i; - int verbose = 0; - - /* 0 => -xnone in effect. - 1 => -xfoo in effect. */ - int saw_speclang = 0; - - /* 0 => initial/reset state - 1 => last arg was -l - 2 => last two args were -l -lm. */ - int saw_library = 0; - - /* By default, we throw on the math library if we have one. */ - int need_math = (MATH_LIBRARY[0] != '\0'); - - /* Whether we should link a static libgfortran. */ - int static_lib = 0; - - /* Whether we need to link statically. */ - int static_linking = 0; - - /* The number of input and output files in the incoming arg list. */ - int n_infiles = 0; - int n_outfiles = 0; - - library = FORTRAN_LIBRARY; - -#if 0 - fprintf (stderr, "Incoming:"); - for (i = 0; i < argc; i++) - fprintf (stderr, " %s", decoded_options[i].orig_option_with_args_text); - fprintf (stderr, "\n"); -#endif - - g77_xargc = argc; - g77_x_decoded_options = decoded_options; - g77_newargc = 0; - g77_new_decoded_options = decoded_options; - - /* First pass through arglist. - - If -nostdlib or a "turn-off-linking" option is anywhere in the - command line, don't do any library-option processing (except - relating to -x). */ - - for (i = 1; i < argc; ++i) - { - if (decoded_options[i].errors & CL_ERR_MISSING_ARG) - continue; - - switch (decoded_options[i].opt_index) - { - case OPT_SPECIAL_input_file: - ++n_infiles; - continue; - - case OPT_nostdlib: - case OPT_nodefaultlibs: - case OPT_c: - case OPT_r: - case OPT_S: - case OPT_fsyntax_only: - case OPT_E: - /* These options disable linking entirely or linking of the - standard libraries. */ - library = 0; - break; - - case OPT_static_libgfortran: -#ifdef HAVE_LD_STATIC_DYNAMIC - static_lib = 1; -#endif - break; - - case OPT_static: -#ifdef HAVE_LD_STATIC_DYNAMIC - static_linking = 1; -#endif - break; - - case OPT_l: - ++n_infiles; - break; - - case OPT_o: - ++n_outfiles; - break; - - case OPT_v: - verbose = 1; - break; - - case OPT__version: - printf ("GNU Fortran %s%s\n", pkgversion_string, version_string); - printf ("Copyright %s 2022 Free Software Foundation, Inc.\n", - _("(C)")); - fputs (_("This is free software; see the source for copying conditions. There is NO\n\ -warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"), - stdout); - exit (0); - break; - - case OPT__help: - /* Let gcc.c handle this, as it has a really - cool facility for handling --help and --verbose --help. */ - return; - - default: - break; - } - } - - if ((n_outfiles != 0) && (n_infiles == 0)) - fatal_error (input_location, - "no input files; unwilling to write output files"); - - /* If there are no input files, no need for the library. */ - if (n_infiles == 0) - library = 0; - - /* Second pass through arglist, transforming arguments as appropriate. */ - - append_arg (&decoded_options[0]); /* Start with command name, of course. */ - - for (i = 1; i < argc; ++i) - { - if (decoded_options[i].errors & CL_ERR_MISSING_ARG) - { - append_arg (&decoded_options[i]); - continue; - } - - if (decoded_options[i].opt_index == OPT_SPECIAL_input_file - && decoded_options[i].arg[0] == '\0') - { - /* Interesting. Just append as is. */ - append_arg (&decoded_options[i]); - continue; - } - - if (decoded_options[i].opt_index != OPT_l - && (decoded_options[i].opt_index != OPT_SPECIAL_input_file - || strcmp (decoded_options[i].arg, "-") == 0)) - { - /* Not a filename or library. */ - - if (saw_library == 1 && need_math) /* -l. */ - append_option (OPT_l, MATH_LIBRARY, 1); - - saw_library = 0; - - if (decoded_options[i].opt_index == OPT_SPECIAL_input_file) - { - append_arg (&decoded_options[i]); /* "-" == Standard input. */ - continue; - } - - if (decoded_options[i].opt_index == OPT_x) - { - /* Track input language. */ - const char *lang = decoded_options[i].arg; - - saw_speclang = (strcmp (lang, "none") != 0); - } - - append_arg (&decoded_options[i]); - - continue; - } - - /* A filename/library, not an option. */ - - if (saw_speclang) - saw_library = 0; /* -xfoo currently active. */ - else - { /* -lfoo or filename. */ - if (decoded_options[i].opt_index == OPT_l - && strcmp (decoded_options[i].arg, MATH_LIBRARY) == 0) - { - if (saw_library == 1) - saw_library = 2; /* -l -lm. */ - else - add_arg_libgfortran (static_lib && !static_linking); - } - else if (decoded_options[i].opt_index == OPT_l - && strcmp (decoded_options[i].arg, FORTRAN_LIBRARY) == 0) - { - saw_library = 1; /* -l. */ - add_arg_libgfortran (static_lib && !static_linking); - continue; - } - else - { /* Other library, or filename. */ - if (saw_library == 1 && need_math) - append_option (OPT_l, MATH_LIBRARY, 1); - saw_library = 0; - } - } - append_arg (&decoded_options[i]); - } - - /* Append `-lgfortran -lm' as necessary. */ - - if (library) - { /* Doing a link and no -nostdlib. */ - if (saw_speclang) - append_option (OPT_x, "none", 1); - - switch (saw_library) - { - case 0: - add_arg_libgfortran (static_lib && !static_linking); - /* Fall through. */ - - case 1: - if (need_math) - append_option (OPT_l, MATH_LIBRARY, 1); - default: - break; - } - } - -#ifdef ENABLE_SHARED_LIBGCC - if (library) - { - unsigned int i; - - for (i = 1; i < g77_newargc; i++) - if (g77_new_decoded_options[i].opt_index == OPT_static_libgcc - || g77_new_decoded_options[i].opt_index == OPT_static) - break; - - if (i == g77_newargc) - append_option (OPT_shared_libgcc, NULL, 1); - } - -#endif - - if (verbose && g77_new_decoded_options != g77_x_decoded_options) - { - fprintf (stderr, _("Driving:")); - for (i = 0; i < g77_newargc; i++) - fprintf (stderr, " %s", - g77_new_decoded_options[i].orig_option_with_args_text); - fprintf (stderr, "\n"); - } - - *in_decoded_options_count = g77_newargc; - *in_decoded_options = g77_new_decoded_options; -} - - -/* Called before linking. Returns 0 on success and -1 on failure. */ -int -lang_specific_pre_link (void) -{ - if (library) - do_spec ("%:include(libgfortran.spec)"); - - return 0; -} - -/* Number of extra output files that lang_specific_pre_link may generate. */ -int lang_specific_extra_outfiles = 0; /* Not used for F77. */ diff --git a/gcc/fortran/gfortranspec.cc b/gcc/fortran/gfortranspec.cc new file mode 100644 index 0000000..4858366 --- /dev/null +++ b/gcc/fortran/gfortranspec.cc @@ -0,0 +1,450 @@ +/* Specific flags and argument handling of the Fortran front-end. + Copyright (C) 1997-2022 Free Software Foundation, Inc. + +This file is part of GCC. + +GNU CC 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. + +GNU CC 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 +. */ + +/* This file is copied more or less verbatim from g77. */ +/* This file contains a filter for the main `gcc' driver, which is + replicated for the `gfortran' driver by adding this filter. The purpose + of this filter is to be basically identical to gcc (in that + it faithfully passes all of the original arguments to gcc) but, + unless explicitly overridden by the user in certain ways, ensure + that the needs of the language supported by this wrapper are met. + + For GNU Fortran 95(gfortran), we do the following to the argument list + before passing it to `gcc': + + 1. Make sure `-lgfortran -lm' is at the end of the list. + + 2. Make sure each time `-lgfortran' or `-lm' is seen, it forms + part of the series `-lgfortran -lm'. + + #1 and #2 are not done if `-nostdlib' or any option that disables + the linking phase is present, or if `-xfoo' is in effect. Note that + a lack of source files or -l options disables linking. + + This program was originally made out of gcc/cp/g++spec.c, but the + way it builds the new argument list was rewritten so it is much + easier to maintain, improve the way it decides to add or not add + extra arguments, etc. And several improvements were made in the + handling of arguments, primarily to make it more consistent with + `gcc' itself. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "opt-suggestions.h" +#include "gcc.h" +#include "opts.h" + +#include "tm.h" +#include "intl.h" + +#ifndef MATH_LIBRARY +#define MATH_LIBRARY "m" +#endif + +#ifndef FORTRAN_LIBRARY +#define FORTRAN_LIBRARY "gfortran" +#endif + +/* Name of the spec file. */ +#define SPEC_FILE "libgfortran.spec" + +/* The original argument list and related info is copied here. */ +static unsigned int g77_xargc; +static const struct cl_decoded_option *g77_x_decoded_options; +static void append_arg (const struct cl_decoded_option *); + +/* The new argument list will be built here. */ +static unsigned int g77_newargc; +static struct cl_decoded_option *g77_new_decoded_options; + +/* This will be NULL if we encounter a situation where we should not + link in the fortran libraries. */ +static const char *library = NULL; + + +/* Return whether strings S1 and S2 are both NULL or both the same + string. */ + +static bool +strings_same (const char *s1, const char *s2) +{ + return s1 == s2 || (s1 != NULL && s2 != NULL && strcmp (s1, s2) == 0); +} + +/* Return whether decoded option structures OPT1 and OPT2 are the + same. */ + +static bool +options_same (const struct cl_decoded_option *opt1, + const struct cl_decoded_option *opt2) +{ + return (opt1->opt_index == opt2->opt_index + && strings_same (opt1->arg, opt2->arg) + && strings_same (opt1->orig_option_with_args_text, + opt2->orig_option_with_args_text) + && strings_same (opt1->canonical_option[0], + opt2->canonical_option[0]) + && strings_same (opt1->canonical_option[1], + opt2->canonical_option[1]) + && strings_same (opt1->canonical_option[2], + opt2->canonical_option[2]) + && strings_same (opt1->canonical_option[3], + opt2->canonical_option[3]) + && (opt1->canonical_option_num_elements + == opt2->canonical_option_num_elements) + && opt1->value == opt2->value + && opt1->errors == opt2->errors); +} + +/* Append another argument to the list being built. As long as it is + identical to the corresponding arg in the original list, just increment + the new arg count. Otherwise allocate a new list, etc. */ + +static void +append_arg (const struct cl_decoded_option *arg) +{ + static unsigned int newargsize; + + if (g77_new_decoded_options == g77_x_decoded_options + && g77_newargc < g77_xargc + && options_same (arg, &g77_x_decoded_options[g77_newargc])) + { + ++g77_newargc; + return; /* Nothing new here. */ + } + + if (g77_new_decoded_options == g77_x_decoded_options) + { /* Make new arglist. */ + unsigned int i; + + newargsize = (g77_xargc << 2) + 20; /* This should handle all. */ + g77_new_decoded_options = XNEWVEC (struct cl_decoded_option, newargsize); + + /* Copy what has been done so far. */ + for (i = 0; i < g77_newargc; ++i) + g77_new_decoded_options[i] = g77_x_decoded_options[i]; + } + + if (g77_newargc == newargsize) + fatal_error (input_location, "overflowed output argument list for %qs", + arg->orig_option_with_args_text); + + g77_new_decoded_options[g77_newargc++] = *arg; +} + +/* Append an option described by OPT_INDEX, ARG and VALUE to the list + being built. */ +static void +append_option (size_t opt_index, const char *arg, int value) +{ + struct cl_decoded_option decoded; + + generate_option (opt_index, arg, value, CL_DRIVER, &decoded); + append_arg (&decoded); +} + +/* Append a libgfortran argument to the list being built. If + FORCE_STATIC, ensure the library is linked statically. */ + +static void +add_arg_libgfortran (bool force_static ATTRIBUTE_UNUSED) +{ +#ifdef HAVE_LD_STATIC_DYNAMIC + if (force_static) + append_option (OPT_Wl_, LD_STATIC_OPTION, 1); +#endif + append_option (OPT_l, FORTRAN_LIBRARY, 1); +#ifdef HAVE_LD_STATIC_DYNAMIC + if (force_static) + append_option (OPT_Wl_, LD_DYNAMIC_OPTION, 1); +#endif +} + +void +lang_specific_driver (struct cl_decoded_option **in_decoded_options, + unsigned int *in_decoded_options_count, + int *in_added_libraries ATTRIBUTE_UNUSED) +{ + unsigned int argc = *in_decoded_options_count; + struct cl_decoded_option *decoded_options = *in_decoded_options; + unsigned int i; + int verbose = 0; + + /* 0 => -xnone in effect. + 1 => -xfoo in effect. */ + int saw_speclang = 0; + + /* 0 => initial/reset state + 1 => last arg was -l + 2 => last two args were -l -lm. */ + int saw_library = 0; + + /* By default, we throw on the math library if we have one. */ + int need_math = (MATH_LIBRARY[0] != '\0'); + + /* Whether we should link a static libgfortran. */ + int static_lib = 0; + + /* Whether we need to link statically. */ + int static_linking = 0; + + /* The number of input and output files in the incoming arg list. */ + int n_infiles = 0; + int n_outfiles = 0; + + library = FORTRAN_LIBRARY; + +#if 0 + fprintf (stderr, "Incoming:"); + for (i = 0; i < argc; i++) + fprintf (stderr, " %s", decoded_options[i].orig_option_with_args_text); + fprintf (stderr, "\n"); +#endif + + g77_xargc = argc; + g77_x_decoded_options = decoded_options; + g77_newargc = 0; + g77_new_decoded_options = decoded_options; + + /* First pass through arglist. + + If -nostdlib or a "turn-off-linking" option is anywhere in the + command line, don't do any library-option processing (except + relating to -x). */ + + for (i = 1; i < argc; ++i) + { + if (decoded_options[i].errors & CL_ERR_MISSING_ARG) + continue; + + switch (decoded_options[i].opt_index) + { + case OPT_SPECIAL_input_file: + ++n_infiles; + continue; + + case OPT_nostdlib: + case OPT_nodefaultlibs: + case OPT_c: + case OPT_r: + case OPT_S: + case OPT_fsyntax_only: + case OPT_E: + /* These options disable linking entirely or linking of the + standard libraries. */ + library = 0; + break; + + case OPT_static_libgfortran: +#ifdef HAVE_LD_STATIC_DYNAMIC + static_lib = 1; +#endif + break; + + case OPT_static: +#ifdef HAVE_LD_STATIC_DYNAMIC + static_linking = 1; +#endif + break; + + case OPT_l: + ++n_infiles; + break; + + case OPT_o: + ++n_outfiles; + break; + + case OPT_v: + verbose = 1; + break; + + case OPT__version: + printf ("GNU Fortran %s%s\n", pkgversion_string, version_string); + printf ("Copyright %s 2022 Free Software Foundation, Inc.\n", + _("(C)")); + fputs (_("This is free software; see the source for copying conditions. There is NO\n\ +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n\n"), + stdout); + exit (0); + break; + + case OPT__help: + /* Let gcc.c handle this, as it has a really + cool facility for handling --help and --verbose --help. */ + return; + + default: + break; + } + } + + if ((n_outfiles != 0) && (n_infiles == 0)) + fatal_error (input_location, + "no input files; unwilling to write output files"); + + /* If there are no input files, no need for the library. */ + if (n_infiles == 0) + library = 0; + + /* Second pass through arglist, transforming arguments as appropriate. */ + + append_arg (&decoded_options[0]); /* Start with command name, of course. */ + + for (i = 1; i < argc; ++i) + { + if (decoded_options[i].errors & CL_ERR_MISSING_ARG) + { + append_arg (&decoded_options[i]); + continue; + } + + if (decoded_options[i].opt_index == OPT_SPECIAL_input_file + && decoded_options[i].arg[0] == '\0') + { + /* Interesting. Just append as is. */ + append_arg (&decoded_options[i]); + continue; + } + + if (decoded_options[i].opt_index != OPT_l + && (decoded_options[i].opt_index != OPT_SPECIAL_input_file + || strcmp (decoded_options[i].arg, "-") == 0)) + { + /* Not a filename or library. */ + + if (saw_library == 1 && need_math) /* -l. */ + append_option (OPT_l, MATH_LIBRARY, 1); + + saw_library = 0; + + if (decoded_options[i].opt_index == OPT_SPECIAL_input_file) + { + append_arg (&decoded_options[i]); /* "-" == Standard input. */ + continue; + } + + if (decoded_options[i].opt_index == OPT_x) + { + /* Track input language. */ + const char *lang = decoded_options[i].arg; + + saw_speclang = (strcmp (lang, "none") != 0); + } + + append_arg (&decoded_options[i]); + + continue; + } + + /* A filename/library, not an option. */ + + if (saw_speclang) + saw_library = 0; /* -xfoo currently active. */ + else + { /* -lfoo or filename. */ + if (decoded_options[i].opt_index == OPT_l + && strcmp (decoded_options[i].arg, MATH_LIBRARY) == 0) + { + if (saw_library == 1) + saw_library = 2; /* -l -lm. */ + else + add_arg_libgfortran (static_lib && !static_linking); + } + else if (decoded_options[i].opt_index == OPT_l + && strcmp (decoded_options[i].arg, FORTRAN_LIBRARY) == 0) + { + saw_library = 1; /* -l. */ + add_arg_libgfortran (static_lib && !static_linking); + continue; + } + else + { /* Other library, or filename. */ + if (saw_library == 1 && need_math) + append_option (OPT_l, MATH_LIBRARY, 1); + saw_library = 0; + } + } + append_arg (&decoded_options[i]); + } + + /* Append `-lgfortran -lm' as necessary. */ + + if (library) + { /* Doing a link and no -nostdlib. */ + if (saw_speclang) + append_option (OPT_x, "none", 1); + + switch (saw_library) + { + case 0: + add_arg_libgfortran (static_lib && !static_linking); + /* Fall through. */ + + case 1: + if (need_math) + append_option (OPT_l, MATH_LIBRARY, 1); + default: + break; + } + } + +#ifdef ENABLE_SHARED_LIBGCC + if (library) + { + unsigned int i; + + for (i = 1; i < g77_newargc; i++) + if (g77_new_decoded_options[i].opt_index == OPT_static_libgcc + || g77_new_decoded_options[i].opt_index == OPT_static) + break; + + if (i == g77_newargc) + append_option (OPT_shared_libgcc, NULL, 1); + } + +#endif + + if (verbose && g77_new_decoded_options != g77_x_decoded_options) + { + fprintf (stderr, _("Driving:")); + for (i = 0; i < g77_newargc; i++) + fprintf (stderr, " %s", + g77_new_decoded_options[i].orig_option_with_args_text); + fprintf (stderr, "\n"); + } + + *in_decoded_options_count = g77_newargc; + *in_decoded_options = g77_new_decoded_options; +} + + +/* Called before linking. Returns 0 on success and -1 on failure. */ +int +lang_specific_pre_link (void) +{ + if (library) + do_spec ("%:include(libgfortran.spec)"); + + return 0; +} + +/* Number of extra output files that lang_specific_pre_link may generate. */ +int lang_specific_extra_outfiles = 0; /* Not used for F77. */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c deleted file mode 100644 index 0fd881d..0000000 --- a/gcc/fortran/interface.c +++ /dev/null @@ -1,5589 +0,0 @@ -/* Deal with interfaces. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - - -/* Deal with interfaces. An explicit interface is represented as a - singly linked list of formal argument structures attached to the - relevant symbols. For an implicit interface, the arguments don't - point to symbols. Explicit interfaces point to namespaces that - contain the symbols within that interface. - - Implicit interfaces are linked together in a singly linked list - along the next_if member of symbol nodes. Since a particular - symbol can only have a single explicit interface, the symbol cannot - be part of multiple lists and a single next-member suffices. - - This is not the case for general classes, though. An operator - definition is independent of just about all other uses and has it's - own head pointer. - - Nameless interfaces: - Nameless interfaces create symbols with explicit interfaces within - the current namespace. They are otherwise unlinked. - - Generic interfaces: - The generic name points to a linked list of symbols. Each symbol - has an explicit interface. Each explicit interface has its own - namespace containing the arguments. Module procedures are symbols in - which the interface is added later when the module procedure is parsed. - - User operators: - User-defined operators are stored in a their own set of symtrees - separate from regular symbols. The symtrees point to gfc_user_op - structures which in turn head up a list of relevant interfaces. - - Extended intrinsics and assignment: - The head of these interface lists are stored in the containing namespace. - - Implicit interfaces: - An implicit interface is represented as a singly linked list of - formal argument list structures that don't point to any symbol - nodes -- they just contain types. - - - When a subprogram is defined, the program unit's name points to an - interface as usual, but the link to the namespace is NULL and the - formal argument list points to symbols within the same namespace as - the program unit name. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "match.h" -#include "arith.h" - -/* The current_interface structure holds information about the - interface currently being parsed. This structure is saved and - restored during recursive interfaces. */ - -gfc_interface_info current_interface; - - -/* Free a singly linked list of gfc_interface structures. */ - -void -gfc_free_interface (gfc_interface *intr) -{ - gfc_interface *next; - - for (; intr; intr = next) - { - next = intr->next; - free (intr); - } -} - - -/* Change the operators unary plus and minus into binary plus and - minus respectively, leaving the rest unchanged. */ - -static gfc_intrinsic_op -fold_unary_intrinsic (gfc_intrinsic_op op) -{ - switch (op) - { - case INTRINSIC_UPLUS: - op = INTRINSIC_PLUS; - break; - case INTRINSIC_UMINUS: - op = INTRINSIC_MINUS; - break; - default: - break; - } - - return op; -} - - -/* Return the operator depending on the DTIO moded string. Note that - these are not operators in the normal sense and so have been placed - beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */ - -static gfc_intrinsic_op -dtio_op (char* mode) -{ - if (strcmp (mode, "formatted") == 0) - return INTRINSIC_FORMATTED; - if (strcmp (mode, "unformatted") == 0) - return INTRINSIC_UNFORMATTED; - return INTRINSIC_NONE; -} - - -/* Match a generic specification. Depending on which type of - interface is found, the 'name' or 'op' pointers may be set. - This subroutine doesn't return MATCH_NO. */ - -match -gfc_match_generic_spec (interface_type *type, - char *name, - gfc_intrinsic_op *op) -{ - char buffer[GFC_MAX_SYMBOL_LEN + 1]; - match m; - gfc_intrinsic_op i; - - if (gfc_match (" assignment ( = )") == MATCH_YES) - { - *type = INTERFACE_INTRINSIC_OP; - *op = INTRINSIC_ASSIGN; - return MATCH_YES; - } - - if (gfc_match (" operator ( %o )", &i) == MATCH_YES) - { /* Operator i/f */ - *type = INTERFACE_INTRINSIC_OP; - *op = fold_unary_intrinsic (i); - return MATCH_YES; - } - - *op = INTRINSIC_NONE; - if (gfc_match (" operator ( ") == MATCH_YES) - { - m = gfc_match_defined_op_name (buffer, 1); - if (m == MATCH_NO) - goto syntax; - if (m != MATCH_YES) - return MATCH_ERROR; - - m = gfc_match_char (')'); - if (m == MATCH_NO) - goto syntax; - if (m != MATCH_YES) - return MATCH_ERROR; - - strcpy (name, buffer); - *type = INTERFACE_USER_OP; - return MATCH_YES; - } - - if (gfc_match (" read ( %n )", buffer) == MATCH_YES) - { - *op = dtio_op (buffer); - if (*op == INTRINSIC_FORMATTED) - { - strcpy (name, gfc_code2string (dtio_procs, DTIO_RF)); - *type = INTERFACE_DTIO; - } - if (*op == INTRINSIC_UNFORMATTED) - { - strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF)); - *type = INTERFACE_DTIO; - } - if (*op != INTRINSIC_NONE) - return MATCH_YES; - } - - if (gfc_match (" write ( %n )", buffer) == MATCH_YES) - { - *op = dtio_op (buffer); - if (*op == INTRINSIC_FORMATTED) - { - strcpy (name, gfc_code2string (dtio_procs, DTIO_WF)); - *type = INTERFACE_DTIO; - } - if (*op == INTRINSIC_UNFORMATTED) - { - strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF)); - *type = INTERFACE_DTIO; - } - if (*op != INTRINSIC_NONE) - return MATCH_YES; - } - - if (gfc_match_name (buffer) == MATCH_YES) - { - strcpy (name, buffer); - *type = INTERFACE_GENERIC; - return MATCH_YES; - } - - *type = INTERFACE_NAMELESS; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in generic specification at %C"); - return MATCH_ERROR; -} - - -/* Match one of the five F95 forms of an interface statement. The - matcher for the abstract interface follows. */ - -match -gfc_match_interface (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - interface_type type; - gfc_symbol *sym; - gfc_intrinsic_op op; - match m; - - m = gfc_match_space (); - - if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) - return MATCH_ERROR; - - /* If we're not looking at the end of the statement now, or if this - is not a nameless interface but we did not see a space, punt. */ - if (gfc_match_eos () != MATCH_YES - || (type != INTERFACE_NAMELESS && m != MATCH_YES)) - { - gfc_error ("Syntax error: Trailing garbage in INTERFACE statement " - "at %C"); - return MATCH_ERROR; - } - - current_interface.type = type; - - switch (type) - { - case INTERFACE_DTIO: - case INTERFACE_GENERIC: - if (gfc_get_symbol (name, NULL, &sym)) - return MATCH_ERROR; - - if (!sym->attr.generic - && !gfc_add_generic (&sym->attr, sym->name, NULL)) - return MATCH_ERROR; - - if (sym->attr.dummy) - { - gfc_error ("Dummy procedure %qs at %C cannot have a " - "generic interface", sym->name); - return MATCH_ERROR; - } - - current_interface.sym = gfc_new_block = sym; - break; - - case INTERFACE_USER_OP: - current_interface.uop = gfc_get_uop (name); - break; - - case INTERFACE_INTRINSIC_OP: - current_interface.op = op; - break; - - case INTERFACE_NAMELESS: - case INTERFACE_ABSTRACT: - break; - } - - return MATCH_YES; -} - - - -/* Match a F2003 abstract interface. */ - -match -gfc_match_abstract_interface (void) -{ - match m; - - if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C")) - return MATCH_ERROR; - - m = gfc_match_eos (); - - if (m != MATCH_YES) - { - gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C"); - return MATCH_ERROR; - } - - current_interface.type = INTERFACE_ABSTRACT; - - return m; -} - - -/* Match the different sort of generic-specs that can be present after - the END INTERFACE itself. */ - -match -gfc_match_end_interface (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - interface_type type; - gfc_intrinsic_op op; - match m; - - m = gfc_match_space (); - - if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) - return MATCH_ERROR; - - /* If we're not looking at the end of the statement now, or if this - is not a nameless interface but we did not see a space, punt. */ - if (gfc_match_eos () != MATCH_YES - || (type != INTERFACE_NAMELESS && m != MATCH_YES)) - { - gfc_error ("Syntax error: Trailing garbage in END INTERFACE " - "statement at %C"); - return MATCH_ERROR; - } - - m = MATCH_YES; - - switch (current_interface.type) - { - case INTERFACE_NAMELESS: - case INTERFACE_ABSTRACT: - if (type != INTERFACE_NAMELESS) - { - gfc_error ("Expected a nameless interface at %C"); - m = MATCH_ERROR; - } - - break; - - case INTERFACE_INTRINSIC_OP: - if (type != current_interface.type || op != current_interface.op) - { - - if (current_interface.op == INTRINSIC_ASSIGN) - { - m = MATCH_ERROR; - gfc_error ("Expected % at %C"); - } - else - { - const char *s1, *s2; - s1 = gfc_op2string (current_interface.op); - s2 = gfc_op2string (op); - - /* The following if-statements are used to enforce C1202 - from F2003. */ - if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0) - || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0)) - break; - if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0) - || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0)) - break; - if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0) - || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0)) - break; - if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0) - || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0)) - break; - if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0) - || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0)) - break; - if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0) - || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0)) - break; - - m = MATCH_ERROR; - if (strcmp(s2, "none") == 0) - gfc_error ("Expecting % " - "at %C", s1); - else - gfc_error ("Expecting % at %C, " - "but got %qs", s1, s2); - } - - } - - break; - - case INTERFACE_USER_OP: - /* Comparing the symbol node names is OK because only use-associated - symbols can be renamed. */ - if (type != current_interface.type - || strcmp (current_interface.uop->name, name) != 0) - { - gfc_error ("Expecting % at %C", - current_interface.uop->name); - m = MATCH_ERROR; - } - - break; - - case INTERFACE_DTIO: - case INTERFACE_GENERIC: - if (type != current_interface.type - || strcmp (current_interface.sym->name, name) != 0) - { - gfc_error ("Expecting % at %C", - current_interface.sym->name); - m = MATCH_ERROR; - } - - break; - } - - return m; -} - - -/* Return whether the component was defined anonymously. */ - -static bool -is_anonymous_component (gfc_component *cmp) -{ - /* Only UNION and MAP components are anonymous. In the case of a MAP, - the derived type symbol is FL_STRUCT and the component name looks like mM*. - This is the only case in which the second character of a component name is - uppercase. */ - return cmp->ts.type == BT_UNION - || (cmp->ts.type == BT_DERIVED - && cmp->ts.u.derived->attr.flavor == FL_STRUCT - && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1])); -} - - -/* Return whether the derived type was defined anonymously. */ - -static bool -is_anonymous_dt (gfc_symbol *derived) -{ - /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE - types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT - and the type name looks like XX*. This is the only case in which the - second character of a type name is uppercase. */ - return derived->attr.flavor == FL_UNION - || (derived->attr.flavor == FL_STRUCT - && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1])); -} - - -/* Compare components according to 4.4.2 of the Fortran standard. */ - -static bool -compare_components (gfc_component *cmp1, gfc_component *cmp2, - gfc_symbol *derived1, gfc_symbol *derived2) -{ - /* Compare names, but not for anonymous components such as UNION or MAP. */ - if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2) - && strcmp (cmp1->name, cmp2->name) != 0) - return false; - - if (cmp1->attr.access != cmp2->attr.access) - return false; - - if (cmp1->attr.pointer != cmp2->attr.pointer) - return false; - - if (cmp1->attr.dimension != cmp2->attr.dimension) - return false; - - if (cmp1->attr.allocatable != cmp2->attr.allocatable) - return false; - - if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0) - return false; - - if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER) - { - gfc_charlen *l1 = cmp1->ts.u.cl; - gfc_charlen *l2 = cmp2->ts.u.cl; - if (l1 && l2 && l1->length && l2->length - && l1->length->expr_type == EXPR_CONSTANT - && l2->length->expr_type == EXPR_CONSTANT - && gfc_dep_compare_expr (l1->length, l2->length) != 0) - return false; - } - - /* Make sure that link lists do not put this function into an - endless recursive loop! */ - if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) - && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived) - && !gfc_compare_types (&cmp1->ts, &cmp2->ts)) - return false; - - else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) - && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) - return false; - - else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) - && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) - return false; - - return true; -} - - -/* Compare two union types by comparing the components of their maps. - Because unions and maps are anonymous their types get special internal - names; therefore the usual derived type comparison will fail on them. - - Returns nonzero if equal, as with gfc_compare_derived_types. Also as with - gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate - definitions' than 'equivalent structure'. */ - -static bool -compare_union_types (gfc_symbol *un1, gfc_symbol *un2) -{ - gfc_component *map1, *map2, *cmp1, *cmp2; - gfc_symbol *map1_t, *map2_t; - - if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION) - return false; - - if (un1->attr.zero_comp != un2->attr.zero_comp) - return false; - - if (un1->attr.zero_comp) - return true; - - map1 = un1->components; - map2 = un2->components; - - /* In terms of 'equality' here we are worried about types which are - declared the same in two places, not types that represent equivalent - structures. (This is common because of FORTRAN's weird scoping rules.) - Though two unions with their maps in different orders could be equivalent, - we will say they are not equal for the purposes of this test; therefore - we compare the maps sequentially. */ - for (;;) - { - map1_t = map1->ts.u.derived; - map2_t = map2->ts.u.derived; - - cmp1 = map1_t->components; - cmp2 = map2_t->components; - - /* Protect against null components. */ - if (map1_t->attr.zero_comp != map2_t->attr.zero_comp) - return false; - - if (map1_t->attr.zero_comp) - return true; - - for (;;) - { - /* No two fields will ever point to the same map type unless they are - the same component, because one map field is created with its type - declaration. Therefore don't worry about recursion here. */ - /* TODO: worry about recursion into parent types of the unions? */ - if (!compare_components (cmp1, cmp2, map1_t, map2_t)) - return false; - - cmp1 = cmp1->next; - cmp2 = cmp2->next; - - if (cmp1 == NULL && cmp2 == NULL) - break; - if (cmp1 == NULL || cmp2 == NULL) - return false; - } - - map1 = map1->next; - map2 = map2->next; - - if (map1 == NULL && map2 == NULL) - break; - if (map1 == NULL || map2 == NULL) - return false; - } - - return true; -} - - - -/* Compare two derived types using the criteria in 4.4.2 of the standard, - recursing through gfc_compare_types for the components. */ - -bool -gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) -{ - gfc_component *cmp1, *cmp2; - - if (derived1 == derived2) - return true; - - if (!derived1 || !derived2) - gfc_internal_error ("gfc_compare_derived_types: invalid derived type"); - - /* Compare UNION types specially. */ - if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION) - return compare_union_types (derived1, derived2); - - /* Special case for comparing derived types across namespaces. If the - true names and module names are the same and the module name is - nonnull, then they are equal. */ - if (strcmp (derived1->name, derived2->name) == 0 - && derived1->module != NULL && derived2->module != NULL - && strcmp (derived1->module, derived2->module) == 0) - return true; - - /* Compare type via the rules of the standard. Both types must have - the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special - because they can be anonymous; therefore two structures with different - names may be equal. */ - - /* Compare names, but not for anonymous types such as UNION or MAP. */ - if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2) - && strcmp (derived1->name, derived2->name) != 0) - return false; - - if (derived1->component_access == ACCESS_PRIVATE - || derived2->component_access == ACCESS_PRIVATE) - return false; - - if (!(derived1->attr.sequence && derived2->attr.sequence) - && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c) - && !(derived1->attr.pdt_type && derived2->attr.pdt_type)) - return false; - - /* Protect against null components. */ - if (derived1->attr.zero_comp != derived2->attr.zero_comp) - return false; - - if (derived1->attr.zero_comp) - return true; - - cmp1 = derived1->components; - cmp2 = derived2->components; - - /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a - simple test can speed things up. Otherwise, lots of things have to - match. */ - for (;;) - { - if (!compare_components (cmp1, cmp2, derived1, derived2)) - return false; - - cmp1 = cmp1->next; - cmp2 = cmp2->next; - - if (cmp1 == NULL && cmp2 == NULL) - break; - if (cmp1 == NULL || cmp2 == NULL) - return false; - } - - return true; -} - - -/* Compare two typespecs, recursively if necessary. */ - -bool -gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) -{ - /* See if one of the typespecs is a BT_VOID, which is what is being used - to allow the funcs like c_f_pointer to accept any pointer type. - TODO: Possibly should narrow this to just the one typespec coming in - that is for the formal arg, but oh well. */ - if (ts1->type == BT_VOID || ts2->type == BT_VOID) - return true; - - /* Special case for our C interop types. FIXME: There should be a - better way of doing this. When ISO C binding is cleared up, - this can probably be removed. See PR 57048. */ - - if (((ts1->type == BT_INTEGER && ts2->type == BT_DERIVED) - || (ts1->type == BT_DERIVED && ts2->type == BT_INTEGER)) - && ts1->u.derived && ts2->u.derived - && ts1->u.derived == ts2->u.derived) - return true; - - /* The _data component is not always present, therefore check for its - presence before assuming, that its derived->attr is available. - When the _data component is not present, then nevertheless the - unlimited_polymorphic flag may be set in the derived type's attr. */ - if (ts1->type == BT_CLASS && ts1->u.derived->components - && ((ts1->u.derived->attr.is_class - && ts1->u.derived->components->ts.u.derived->attr - .unlimited_polymorphic) - || ts1->u.derived->attr.unlimited_polymorphic)) - return true; - - /* F2003: C717 */ - if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED - && ts2->u.derived->components - && ((ts2->u.derived->attr.is_class - && ts2->u.derived->components->ts.u.derived->attr - .unlimited_polymorphic) - || ts2->u.derived->attr.unlimited_polymorphic) - && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) - return true; - - if (ts1->type != ts2->type - && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) - || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) - return false; - - if (ts1->type == BT_UNION) - return compare_union_types (ts1->u.derived, ts2->u.derived); - - if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) - return (ts1->kind == ts2->kind); - - /* Compare derived types. */ - return gfc_type_compatible (ts1, ts2); -} - - -static bool -compare_type (gfc_symbol *s1, gfc_symbol *s2) -{ - if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - return true; - - return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED; -} - - -static bool -compare_type_characteristics (gfc_symbol *s1, gfc_symbol *s2) -{ - /* TYPE and CLASS of the same declared type are type compatible, - but have different characteristics. */ - if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED) - || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS)) - return false; - - return compare_type (s1, s2); -} - - -static bool -compare_rank (gfc_symbol *s1, gfc_symbol *s2) -{ - gfc_array_spec *as1, *as2; - int r1, r2; - - if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - return true; - - as1 = (s1->ts.type == BT_CLASS - && !s1->ts.u.derived->attr.unlimited_polymorphic) - ? CLASS_DATA (s1)->as : s1->as; - as2 = (s2->ts.type == BT_CLASS - && !s2->ts.u.derived->attr.unlimited_polymorphic) - ? CLASS_DATA (s2)->as : s2->as; - - r1 = as1 ? as1->rank : 0; - r2 = as2 ? as2->rank : 0; - - if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK)) - return false; /* Ranks differ. */ - - return true; -} - - -/* Given two symbols that are formal arguments, compare their ranks - and types. Returns true if they have the same rank and type, - false otherwise. */ - -static bool -compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) -{ - return compare_type (s1, s2) && compare_rank (s1, s2); -} - - -/* Given two symbols that are formal arguments, compare their types - and rank and their formal interfaces if they are both dummy - procedures. Returns true if the same, false if different. */ - -static bool -compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2) -{ - if (s1 == NULL || s2 == NULL) - return (s1 == s2); - - if (s1 == s2) - return true; - - if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE) - return compare_type_rank (s1, s2); - - if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE) - return false; - - /* At this point, both symbols are procedures. It can happen that - external procedures are compared, where one is identified by usage - to be a function or subroutine but the other is not. Check TKR - nonetheless for these cases. */ - if (s1->attr.function == 0 && s1->attr.subroutine == 0) - return s1->attr.external ? compare_type_rank (s1, s2) : false; - - if (s2->attr.function == 0 && s2->attr.subroutine == 0) - return s2->attr.external ? compare_type_rank (s1, s2) : false; - - /* Now the type of procedure has been identified. */ - if (s1->attr.function != s2->attr.function - || s1->attr.subroutine != s2->attr.subroutine) - return false; - - if (s1->attr.function && !compare_type_rank (s1, s2)) - return false; - - /* Originally, gfortran recursed here to check the interfaces of passed - procedures. This is explicitly not required by the standard. */ - return true; -} - - -/* Given a formal argument list and a keyword name, search the list - for that keyword. Returns the correct symbol node if found, NULL - if not found. */ - -static gfc_symbol * -find_keyword_arg (const char *name, gfc_formal_arglist *f) -{ - for (; f; f = f->next) - if (strcmp (f->sym->name, name) == 0) - return f->sym; - - return NULL; -} - - -/******** Interface checking subroutines **********/ - - -/* Given an operator interface and the operator, make sure that all - interfaces for that operator are legal. */ - -bool -gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op, - locus opwhere) -{ - gfc_formal_arglist *formal; - sym_intent i1, i2; - bt t1, t2; - int args, r1, r2, k1, k2; - - gcc_assert (sym); - - args = 0; - t1 = t2 = BT_UNKNOWN; - i1 = i2 = INTENT_UNKNOWN; - r1 = r2 = -1; - k1 = k2 = -1; - - for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next) - { - gfc_symbol *fsym = formal->sym; - if (fsym == NULL) - { - gfc_error ("Alternate return cannot appear in operator " - "interface at %L", &sym->declared_at); - return false; - } - if (args == 0) - { - t1 = fsym->ts.type; - i1 = fsym->attr.intent; - r1 = (fsym->as != NULL) ? fsym->as->rank : 0; - k1 = fsym->ts.kind; - } - if (args == 1) - { - t2 = fsym->ts.type; - i2 = fsym->attr.intent; - r2 = (fsym->as != NULL) ? fsym->as->rank : 0; - k2 = fsym->ts.kind; - } - args++; - } - - /* Only +, - and .not. can be unary operators. - .not. cannot be a binary operator. */ - if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS - && op != INTRINSIC_MINUS - && op != INTRINSIC_NOT) - || (args == 2 && op == INTRINSIC_NOT)) - { - if (op == INTRINSIC_ASSIGN) - gfc_error ("Assignment operator interface at %L must have " - "two arguments", &sym->declared_at); - else - gfc_error ("Operator interface at %L has the wrong number of arguments", - &sym->declared_at); - return false; - } - - /* Check that intrinsics are mapped to functions, except - INTRINSIC_ASSIGN which should map to a subroutine. */ - if (op == INTRINSIC_ASSIGN) - { - gfc_formal_arglist *dummy_args; - - if (!sym->attr.subroutine) - { - gfc_error ("Assignment operator interface at %L must be " - "a SUBROUTINE", &sym->declared_at); - return false; - } - - /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments): - - First argument an array with different rank than second, - - First argument is a scalar and second an array, - - Types and kinds do not conform, or - - First argument is of derived type. */ - dummy_args = gfc_sym_get_dummy_args (sym); - if (dummy_args->sym->ts.type != BT_DERIVED - && dummy_args->sym->ts.type != BT_CLASS - && (r2 == 0 || r1 == r2) - && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type - || (gfc_numeric_ts (&dummy_args->sym->ts) - && gfc_numeric_ts (&dummy_args->next->sym->ts)))) - { - gfc_error ("Assignment operator interface at %L must not redefine " - "an INTRINSIC type assignment", &sym->declared_at); - return false; - } - } - else - { - if (!sym->attr.function) - { - gfc_error ("Intrinsic operator interface at %L must be a FUNCTION", - &sym->declared_at); - return false; - } - } - - /* Check intents on operator interfaces. */ - if (op == INTRINSIC_ASSIGN) - { - if (i1 != INTENT_OUT && i1 != INTENT_INOUT) - { - gfc_error ("First argument of defined assignment at %L must be " - "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at); - return false; - } - - if (i2 != INTENT_IN) - { - gfc_error ("Second argument of defined assignment at %L must be " - "INTENT(IN)", &sym->declared_at); - return false; - } - } - else - { - if (i1 != INTENT_IN) - { - gfc_error ("First argument of operator interface at %L must be " - "INTENT(IN)", &sym->declared_at); - return false; - } - - if (args == 2 && i2 != INTENT_IN) - { - gfc_error ("Second argument of operator interface at %L must be " - "INTENT(IN)", &sym->declared_at); - return false; - } - } - - /* From now on, all we have to do is check that the operator definition - doesn't conflict with an intrinsic operator. The rules for this - game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards, - as well as 12.3.2.1.1 of Fortran 2003: - - "If the operator is an intrinsic-operator (R310), the number of - function arguments shall be consistent with the intrinsic uses of - that operator, and the types, kind type parameters, or ranks of the - dummy arguments shall differ from those required for the intrinsic - operation (7.1.2)." */ - -#define IS_NUMERIC_TYPE(t) \ - ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX) - - /* Unary ops are easy, do them first. */ - if (op == INTRINSIC_NOT) - { - if (t1 == BT_LOGICAL) - goto bad_repl; - else - return true; - } - - if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS)) - { - if (IS_NUMERIC_TYPE (t1)) - goto bad_repl; - else - return true; - } - - /* Character intrinsic operators have same character kind, thus - operator definitions with operands of different character kinds - are always safe. */ - if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2) - return true; - - /* Intrinsic operators always perform on arguments of same rank, - so different ranks is also always safe. (rank == 0) is an exception - to that, because all intrinsic operators are elemental. */ - if (r1 != r2 && r1 != 0 && r2 != 0) - return true; - - switch (op) - { - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) - goto bad_repl; - /* Fall through. */ - - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: - if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2)) - goto bad_repl; - break; - - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) - goto bad_repl; - if ((t1 == BT_INTEGER || t1 == BT_REAL) - && (t2 == BT_INTEGER || t2 == BT_REAL)) - goto bad_repl; - break; - - case INTRINSIC_CONCAT: - if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) - goto bad_repl; - break; - - case INTRINSIC_AND: - case INTRINSIC_OR: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: - if (t1 == BT_LOGICAL && t2 == BT_LOGICAL) - goto bad_repl; - break; - - default: - break; - } - - return true; - -#undef IS_NUMERIC_TYPE - -bad_repl: - gfc_error ("Operator interface at %L conflicts with intrinsic interface", - &opwhere); - return false; -} - - -/* Given a pair of formal argument lists, we see if the two lists can - be distinguished by counting the number of nonoptional arguments of - a given type/rank in f1 and seeing if there are less then that - number of those arguments in f2 (including optional arguments). - Since this test is asymmetric, it has to be called twice to make it - symmetric. Returns nonzero if the argument lists are incompatible - by this test. This subroutine implements rule 1 of section F03:16.2.3. - 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ - -static bool -count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, - const char *p1, const char *p2) -{ - int ac1, ac2, i, j, k, n1; - gfc_formal_arglist *f; - - typedef struct - { - int flag; - gfc_symbol *sym; - } - arginfo; - - arginfo *arg; - - n1 = 0; - - for (f = f1; f; f = f->next) - n1++; - - /* Build an array of integers that gives the same integer to - arguments of the same type/rank. */ - arg = XCNEWVEC (arginfo, n1); - - f = f1; - for (i = 0; i < n1; i++, f = f->next) - { - arg[i].flag = -1; - arg[i].sym = f->sym; - } - - k = 0; - - for (i = 0; i < n1; i++) - { - if (arg[i].flag != -1) - continue; - - if (arg[i].sym && (arg[i].sym->attr.optional - || (p1 && strcmp (arg[i].sym->name, p1) == 0))) - continue; /* Skip OPTIONAL and PASS arguments. */ - - arg[i].flag = k; - - /* Find other non-optional, non-pass arguments of the same type/rank. */ - for (j = i + 1; j < n1; j++) - if ((arg[j].sym == NULL - || !(arg[j].sym->attr.optional - || (p1 && strcmp (arg[j].sym->name, p1) == 0))) - && (compare_type_rank_if (arg[i].sym, arg[j].sym) - || compare_type_rank_if (arg[j].sym, arg[i].sym))) - arg[j].flag = k; - - k++; - } - - /* Now loop over each distinct type found in f1. */ - k = 0; - bool rc = false; - - for (i = 0; i < n1; i++) - { - if (arg[i].flag != k) - continue; - - ac1 = 1; - for (j = i + 1; j < n1; j++) - if (arg[j].flag == k) - ac1++; - - /* Count the number of non-pass arguments in f2 with that type, - including those that are optional. */ - ac2 = 0; - - for (f = f2; f; f = f->next) - if ((!p2 || strcmp (f->sym->name, p2) != 0) - && (compare_type_rank_if (arg[i].sym, f->sym) - || compare_type_rank_if (f->sym, arg[i].sym))) - ac2++; - - if (ac1 > ac2) - { - rc = true; - break; - } - - k++; - } - - free (arg); - - return rc; -} - - -/* Returns true if two dummy arguments are distinguishable due to their POINTER - and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3). - The function is asymmetric wrt to the arguments s1 and s2 and should always - be called twice (with flipped arguments in the second call). */ - -static bool -compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2) -{ - /* Is s1 allocatable? */ - const bool a1 = s1->ts.type == BT_CLASS ? - CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable; - /* Is s2 a pointer? */ - const bool p2 = s2->ts.type == BT_CLASS ? - CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer; - return a1 && p2 && (s2->attr.intent != INTENT_IN); -} - - -/* Perform the correspondence test in rule (3) of F08:C1215. - Returns zero if no argument is found that satisfies this rule, - nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures - (if applicable). - - This test is also not symmetric in f1 and f2 and must be called - twice. This test finds problems caused by sorting the actual - argument list with keywords. For example: - - INTERFACE FOO - SUBROUTINE F1(A, B) - INTEGER :: A ; REAL :: B - END SUBROUTINE F1 - - SUBROUTINE F2(B, A) - INTEGER :: A ; REAL :: B - END SUBROUTINE F1 - END INTERFACE FOO - - At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */ - -static bool -generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, - const char *p1, const char *p2) -{ - gfc_formal_arglist *f2_save, *g; - gfc_symbol *sym; - - f2_save = f2; - - while (f1) - { - if (!f1->sym || f1->sym->attr.optional) - goto next; - - if (p1 && strcmp (f1->sym->name, p1) == 0) - f1 = f1->next; - if (f2 && p2 && strcmp (f2->sym->name, p2) == 0) - f2 = f2->next; - - if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym) - || compare_type_rank (f2->sym, f1->sym)) - && !((gfc_option.allow_std & GFC_STD_F2008) - && (compare_ptr_alloc(f1->sym, f2->sym) - || compare_ptr_alloc(f2->sym, f1->sym)))) - goto next; - - /* Now search for a disambiguating keyword argument starting at - the current non-match. */ - for (g = f1; g; g = g->next) - { - if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0)) - continue; - - sym = find_keyword_arg (g->sym->name, f2_save); - if (sym == NULL || !compare_type_rank (g->sym, sym) - || ((gfc_option.allow_std & GFC_STD_F2008) - && (compare_ptr_alloc(sym, g->sym) - || compare_ptr_alloc(g->sym, sym)))) - return true; - } - - next: - if (f1 != NULL) - f1 = f1->next; - if (f2 != NULL) - f2 = f2->next; - } - - return false; -} - - -static int -symbol_rank (gfc_symbol *sym) -{ - gfc_array_spec *as = NULL; - - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) - as = CLASS_DATA (sym)->as; - else - as = sym->as; - - return as ? as->rank : 0; -} - - -/* Check if the characteristics of two dummy arguments match, - cf. F08:12.3.2. */ - -bool -gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, - bool type_must_agree, char *errmsg, - int err_len) -{ - if (s1 == NULL || s2 == NULL) - return s1 == s2 ? true : false; - - /* Check type and rank. */ - if (type_must_agree) - { - if (!compare_type_characteristics (s1, s2) - || !compare_type_characteristics (s2, s1)) - { - snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)", - s1->name, gfc_dummy_typename (&s1->ts), - gfc_dummy_typename (&s2->ts)); - return false; - } - if (!compare_rank (s1, s2)) - { - snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)", - s1->name, symbol_rank (s1), symbol_rank (s2)); - return false; - } - } - - /* Check INTENT. */ - if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial - && !s2->attr.artificial) - { - snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check OPTIONAL attribute. */ - if (s1->attr.optional != s2->attr.optional) - { - snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check ALLOCATABLE attribute. */ - if (s1->attr.allocatable != s2->attr.allocatable) - { - snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check POINTER attribute. */ - if (s1->attr.pointer != s2->attr.pointer) - { - snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check TARGET attribute. */ - if (s1->attr.target != s2->attr.target) - { - snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check ASYNCHRONOUS attribute. */ - if (s1->attr.asynchronous != s2->attr.asynchronous) - { - snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check CONTIGUOUS attribute. */ - if (s1->attr.contiguous != s2->attr.contiguous) - { - snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check VALUE attribute. */ - if (s1->attr.value != s2->attr.value) - { - snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check VOLATILE attribute. */ - if (s1->attr.volatile_ != s2->attr.volatile_) - { - snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", - s1->name); - return false; - } - - /* Check interface of dummy procedures. */ - if (s1->attr.flavor == FL_PROCEDURE) - { - char err[200]; - if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err), - NULL, NULL)) - { - snprintf (errmsg, err_len, "Interface mismatch in dummy procedure " - "'%s': %s", s1->name, err); - return false; - } - } - - /* Check string length. */ - if (s1->ts.type == BT_CHARACTER - && s1->ts.u.cl && s1->ts.u.cl->length - && s2->ts.u.cl && s2->ts.u.cl->length) - { - int compval = gfc_dep_compare_expr (s1->ts.u.cl->length, - s2->ts.u.cl->length); - switch (compval) - { - case -1: - case 1: - case -3: - snprintf (errmsg, err_len, "Character length mismatch " - "in argument '%s'", s1->name); - return false; - - case -2: - /* FIXME: Implement a warning for this case. - gfc_warning (0, "Possible character length mismatch in argument %qs", - s1->name);*/ - break; - - case 0: - break; - - default: - gfc_internal_error ("check_dummy_characteristics: Unexpected result " - "%i of gfc_dep_compare_expr", compval); - break; - } - } - - /* Check array shape. */ - if (s1->as && s2->as) - { - int i, compval; - gfc_expr *shape1, *shape2; - - /* Sometimes the ambiguity between deferred shape and assumed shape - does not get resolved in module procedures, where the only explicit - declaration of the dummy is in the interface. */ - if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure - && s1->as->type == AS_ASSUMED_SHAPE - && s2->as->type == AS_DEFERRED) - { - s2->as->type = AS_ASSUMED_SHAPE; - for (i = 0; i < s2->as->rank; i++) - if (s1->as->lower[i] != NULL) - s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]); - } - - if (s1->as->type != s2->as->type) - { - snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", - s1->name); - return false; - } - - if (s1->as->corank != s2->as->corank) - { - snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)", - s1->name, s1->as->corank, s2->as->corank); - return false; - } - - if (s1->as->type == AS_EXPLICIT) - for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++) - { - shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]), - gfc_copy_expr (s1->as->lower[i])); - shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]), - gfc_copy_expr (s2->as->lower[i])); - compval = gfc_dep_compare_expr (shape1, shape2); - gfc_free_expr (shape1); - gfc_free_expr (shape2); - switch (compval) - { - case -1: - case 1: - case -3: - if (i < s1->as->rank) - snprintf (errmsg, err_len, "Shape mismatch in dimension %i of" - " argument '%s'", i + 1, s1->name); - else - snprintf (errmsg, err_len, "Shape mismatch in codimension %i " - "of argument '%s'", i - s1->as->rank + 1, s1->name); - return false; - - case -2: - /* FIXME: Implement a warning for this case. - gfc_warning (0, "Possible shape mismatch in argument %qs", - s1->name);*/ - break; - - case 0: - break; - - default: - gfc_internal_error ("check_dummy_characteristics: Unexpected " - "result %i of gfc_dep_compare_expr", - compval); - break; - } - } - } - - return true; -} - - -/* Check if the characteristics of two function results match, - cf. F08:12.3.3. */ - -bool -gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, - char *errmsg, int err_len) -{ - gfc_symbol *r1, *r2; - - if (s1->ts.interface && s1->ts.interface->result) - r1 = s1->ts.interface->result; - else - r1 = s1->result ? s1->result : s1; - - if (s2->ts.interface && s2->ts.interface->result) - r2 = s2->ts.interface->result; - else - r2 = s2->result ? s2->result : s2; - - if (r1->ts.type == BT_UNKNOWN) - return true; - - /* Check type and rank. */ - if (!compare_type_characteristics (r1, r2)) - { - snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)", - gfc_typename (&r1->ts), gfc_typename (&r2->ts)); - return false; - } - if (!compare_rank (r1, r2)) - { - snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)", - symbol_rank (r1), symbol_rank (r2)); - return false; - } - - /* Check ALLOCATABLE attribute. */ - if (r1->attr.allocatable != r2->attr.allocatable) - { - snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in " - "function result"); - return false; - } - - /* Check POINTER attribute. */ - if (r1->attr.pointer != r2->attr.pointer) - { - snprintf (errmsg, err_len, "POINTER attribute mismatch in " - "function result"); - return false; - } - - /* Check CONTIGUOUS attribute. */ - if (r1->attr.contiguous != r2->attr.contiguous) - { - snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in " - "function result"); - return false; - } - - /* Check PROCEDURE POINTER attribute. */ - if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer) - { - snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in " - "function result"); - return false; - } - - /* Check string length. */ - if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl) - { - if (r1->ts.deferred != r2->ts.deferred) - { - snprintf (errmsg, err_len, "Character length mismatch " - "in function result"); - return false; - } - - if (r1->ts.u.cl->length && r2->ts.u.cl->length) - { - int compval = gfc_dep_compare_expr (r1->ts.u.cl->length, - r2->ts.u.cl->length); - switch (compval) - { - case -1: - case 1: - case -3: - snprintf (errmsg, err_len, "Character length mismatch " - "in function result"); - return false; - - case -2: - /* FIXME: Implement a warning for this case. - snprintf (errmsg, err_len, "Possible character length mismatch " - "in function result");*/ - break; - - case 0: - break; - - default: - gfc_internal_error ("check_result_characteristics (1): Unexpected " - "result %i of gfc_dep_compare_expr", compval); - break; - } - } - } - - /* Check array shape. */ - if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as) - { - int i, compval; - gfc_expr *shape1, *shape2; - - if (r1->as->type != r2->as->type) - { - snprintf (errmsg, err_len, "Shape mismatch in function result"); - return false; - } - - if (r1->as->type == AS_EXPLICIT) - for (i = 0; i < r1->as->rank + r1->as->corank; i++) - { - shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]), - gfc_copy_expr (r1->as->lower[i])); - shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]), - gfc_copy_expr (r2->as->lower[i])); - compval = gfc_dep_compare_expr (shape1, shape2); - gfc_free_expr (shape1); - gfc_free_expr (shape2); - switch (compval) - { - case -1: - case 1: - case -3: - snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " - "function result", i + 1); - return false; - - case -2: - /* FIXME: Implement a warning for this case. - gfc_warning (0, "Possible shape mismatch in return value");*/ - break; - - case 0: - break; - - default: - gfc_internal_error ("check_result_characteristics (2): " - "Unexpected result %i of " - "gfc_dep_compare_expr", compval); - break; - } - } - } - - return true; -} - - -/* 'Compare' two formal interfaces associated with a pair of symbols. - We return true if there exists an actual argument list that - would be ambiguous between the two interfaces, zero otherwise. - 'strict_flag' specifies whether all the characteristics are - required to match, which is not the case for ambiguity checks. - 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ - -bool -gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, - int generic_flag, int strict_flag, - char *errmsg, int err_len, - const char *p1, const char *p2, - bool *bad_result_characteristics) -{ - gfc_formal_arglist *f1, *f2; - - gcc_assert (name2 != NULL); - - if (bad_result_characteristics) - *bad_result_characteristics = false; - - if (s1->attr.function && (s2->attr.subroutine - || (!s2->attr.function && s2->ts.type == BT_UNKNOWN - && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN))) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "'%s' is not a function", name2); - return false; - } - - if (s1->attr.subroutine && s2->attr.function) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "'%s' is not a subroutine", name2); - return false; - } - - /* Do strict checks on all characteristics - (for dummy procedures and procedure pointer assignments). */ - if (!generic_flag && strict_flag) - { - if (s1->attr.function && s2->attr.function) - { - /* If both are functions, check result characteristics. */ - if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len) - || !gfc_check_result_characteristics (s2, s1, errmsg, err_len)) - { - if (bad_result_characteristics) - *bad_result_characteristics = true; - return false; - } - } - - if (s1->attr.pure && !s2->attr.pure) - { - snprintf (errmsg, err_len, "Mismatch in PURE attribute"); - return false; - } - if (s1->attr.elemental && !s2->attr.elemental) - { - snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute"); - return false; - } - } - - if (s1->attr.if_source == IFSRC_UNKNOWN - || s2->attr.if_source == IFSRC_UNKNOWN) - return true; - - f1 = gfc_sym_get_dummy_args (s1); - f2 = gfc_sym_get_dummy_args (s2); - - /* Special case: No arguments. */ - if (f1 == NULL && f2 == NULL) - return true; - - if (generic_flag) - { - if (count_types_test (f1, f2, p1, p2) - || count_types_test (f2, f1, p2, p1)) - return false; - - /* Special case: alternate returns. If both f1->sym and f2->sym are - NULL, then the leading formal arguments are alternate returns. - The previous conditional should catch argument lists with - different number of argument. */ - if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) - return true; - - if (generic_correspondence (f1, f2, p1, p2) - || generic_correspondence (f2, f1, p2, p1)) - return false; - } - else - /* Perform the abbreviated correspondence test for operators (the - arguments cannot be optional and are always ordered correctly). - This is also done when comparing interfaces for dummy procedures and in - procedure pointer assignments. */ - - for (; f1 || f2; f1 = f1->next, f2 = f2->next) - { - /* Check existence. */ - if (f1 == NULL || f2 == NULL) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "'%s' has the wrong number of " - "arguments", name2); - return false; - } - - if (strict_flag) - { - /* Check all characteristics. */ - if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true, - errmsg, err_len)) - return false; - } - else - { - /* Operators: Only check type and rank of arguments. */ - if (!compare_type (f2->sym, f1->sym)) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "Type mismatch in argument '%s' " - "(%s/%s)", f1->sym->name, - gfc_typename (&f1->sym->ts), - gfc_typename (&f2->sym->ts)); - return false; - } - if (!compare_rank (f2->sym, f1->sym)) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "Rank mismatch in argument " - "'%s' (%i/%i)", f1->sym->name, - symbol_rank (f1->sym), symbol_rank (f2->sym)); - return false; - } - if ((gfc_option.allow_std & GFC_STD_F2008) - && (compare_ptr_alloc(f1->sym, f2->sym) - || compare_ptr_alloc(f2->sym, f1->sym))) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "Mismatching POINTER/ALLOCATABLE " - "attribute in argument '%s' ", f1->sym->name); - return false; - } - } - } - - return true; -} - - -/* Given a pointer to an interface pointer, remove duplicate - interfaces and make sure that all symbols are either functions - or subroutines, and all of the same kind. Returns true if - something goes wrong. */ - -static bool -check_interface0 (gfc_interface *p, const char *interface_name) -{ - gfc_interface *psave, *q, *qlast; - - psave = p; - for (; p; p = p->next) - { - /* Make sure all symbols in the interface have been defined as - functions or subroutines. */ - if (((!p->sym->attr.function && !p->sym->attr.subroutine) - || !p->sym->attr.if_source) - && !gfc_fl_struct (p->sym->attr.flavor)) - { - const char *guessed - = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root); - - if (p->sym->attr.external) - if (guessed) - gfc_error ("Procedure %qs in %s at %L has no explicit interface" - "; did you mean %qs?", - p->sym->name, interface_name, &p->sym->declared_at, - guessed); - else - gfc_error ("Procedure %qs in %s at %L has no explicit interface", - p->sym->name, interface_name, &p->sym->declared_at); - else - if (guessed) - gfc_error ("Procedure %qs in %s at %L is neither function nor " - "subroutine; did you mean %qs?", p->sym->name, - interface_name, &p->sym->declared_at, guessed); - else - gfc_error ("Procedure %qs in %s at %L is neither function nor " - "subroutine", p->sym->name, interface_name, - &p->sym->declared_at); - return true; - } - - /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ - if ((psave->sym->attr.function && !p->sym->attr.function - && !gfc_fl_struct (p->sym->attr.flavor)) - || (psave->sym->attr.subroutine && !p->sym->attr.subroutine)) - { - if (!gfc_fl_struct (p->sym->attr.flavor)) - gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" - " or all FUNCTIONs", interface_name, - &p->sym->declared_at); - else if (p->sym->attr.flavor == FL_DERIVED) - gfc_error ("In %s at %L procedures must be all FUNCTIONs as the " - "generic name is also the name of a derived type", - interface_name, &p->sym->declared_at); - return true; - } - - /* F2003, C1207. F2008, C1207. */ - if (p->sym->attr.proc == PROC_INTERNAL - && !gfc_notify_std (GFC_STD_F2008, "Internal procedure " - "%qs in %s at %L", p->sym->name, - interface_name, &p->sym->declared_at)) - return true; - } - p = psave; - - /* Remove duplicate interfaces in this interface list. */ - for (; p; p = p->next) - { - qlast = p; - - for (q = p->next; q;) - { - if (p->sym != q->sym) - { - qlast = q; - q = q->next; - } - else - { - /* Duplicate interface. */ - qlast->next = q->next; - free (q); - q = qlast->next; - } - } - } - - return false; -} - - -/* Check lists of interfaces to make sure that no two interfaces are - ambiguous. Duplicate interfaces (from the same symbol) are OK here. */ - -static bool -check_interface1 (gfc_interface *p, gfc_interface *q0, - int generic_flag, const char *interface_name, - bool referenced) -{ - gfc_interface *q; - for (; p; p = p->next) - for (q = q0; q; q = q->next) - { - if (p->sym == q->sym) - continue; /* Duplicates OK here. */ - - if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) - continue; - - if (!gfc_fl_struct (p->sym->attr.flavor) - && !gfc_fl_struct (q->sym->attr.flavor) - && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, - generic_flag, 0, NULL, 0, NULL, NULL)) - { - if (referenced) - gfc_error ("Ambiguous interfaces in %s for %qs at %L " - "and %qs at %L", interface_name, - q->sym->name, &q->sym->declared_at, - p->sym->name, &p->sym->declared_at); - else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) - gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L " - "and %qs at %L", interface_name, - q->sym->name, &q->sym->declared_at, - p->sym->name, &p->sym->declared_at); - else - gfc_warning (0, "Although not referenced, %qs has ambiguous " - "interfaces at %L", interface_name, &p->where); - return true; - } - } - return false; -} - - -/* Check the generic and operator interfaces of symbols to make sure - that none of the interfaces conflict. The check has to be done - after all of the symbols are actually loaded. */ - -static void -check_sym_interfaces (gfc_symbol *sym) -{ - /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */ - char interface_name[2*GFC_MAX_SYMBOL_LEN+2 + sizeof("generic interface ''")]; - gfc_interface *p; - - if (sym->ns != gfc_current_ns) - return; - - if (sym->generic != NULL) - { - size_t len = strlen (sym->name) + sizeof("generic interface ''"); - gcc_assert (len < sizeof (interface_name)); - sprintf (interface_name, "generic interface '%s'", sym->name); - if (check_interface0 (sym->generic, interface_name)) - return; - - for (p = sym->generic; p; p = p->next) - { - if (p->sym->attr.mod_proc - && !p->sym->attr.module_procedure - && (p->sym->attr.if_source != IFSRC_DECL - || p->sym->attr.procedure)) - { - gfc_error ("%qs at %L is not a module procedure", - p->sym->name, &p->where); - return; - } - } - - /* Originally, this test was applied to host interfaces too; - this is incorrect since host associated symbols, from any - source, cannot be ambiguous with local symbols. */ - check_interface1 (sym->generic, sym->generic, 1, interface_name, - sym->attr.referenced || !sym->attr.use_assoc); - } -} - - -static void -check_uop_interfaces (gfc_user_op *uop) -{ - char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")]; - gfc_user_op *uop2; - gfc_namespace *ns; - - sprintf (interface_name, "operator interface '%s'", uop->name); - if (check_interface0 (uop->op, interface_name)) - return; - - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - uop2 = gfc_find_uop (uop->name, ns); - if (uop2 == NULL) - continue; - - check_interface1 (uop->op, uop2->op, 0, - interface_name, true); - } -} - -/* Given an intrinsic op, return an equivalent op if one exists, - or INTRINSIC_NONE otherwise. */ - -gfc_intrinsic_op -gfc_equivalent_op (gfc_intrinsic_op op) -{ - switch(op) - { - case INTRINSIC_EQ: - return INTRINSIC_EQ_OS; - - case INTRINSIC_EQ_OS: - return INTRINSIC_EQ; - - case INTRINSIC_NE: - return INTRINSIC_NE_OS; - - case INTRINSIC_NE_OS: - return INTRINSIC_NE; - - case INTRINSIC_GT: - return INTRINSIC_GT_OS; - - case INTRINSIC_GT_OS: - return INTRINSIC_GT; - - case INTRINSIC_GE: - return INTRINSIC_GE_OS; - - case INTRINSIC_GE_OS: - return INTRINSIC_GE; - - case INTRINSIC_LT: - return INTRINSIC_LT_OS; - - case INTRINSIC_LT_OS: - return INTRINSIC_LT; - - case INTRINSIC_LE: - return INTRINSIC_LE_OS; - - case INTRINSIC_LE_OS: - return INTRINSIC_LE; - - default: - return INTRINSIC_NONE; - } -} - -/* For the namespace, check generic, user operator and intrinsic - operator interfaces for consistency and to remove duplicate - interfaces. We traverse the whole namespace, counting on the fact - that most symbols will not have generic or operator interfaces. */ - -void -gfc_check_interfaces (gfc_namespace *ns) -{ - gfc_namespace *old_ns, *ns2; - char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")]; - int i; - - old_ns = gfc_current_ns; - gfc_current_ns = ns; - - gfc_traverse_ns (ns, check_sym_interfaces); - - gfc_traverse_user_op (ns, check_uop_interfaces); - - for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) - { - if (i == INTRINSIC_USER) - continue; - - if (i == INTRINSIC_ASSIGN) - strcpy (interface_name, "intrinsic assignment operator"); - else - sprintf (interface_name, "intrinsic '%s' operator", - gfc_op2string ((gfc_intrinsic_op) i)); - - if (check_interface0 (ns->op[i], interface_name)) - continue; - - if (ns->op[i]) - gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i, - ns->op[i]->where); - - for (ns2 = ns; ns2; ns2 = ns2->parent) - { - gfc_intrinsic_op other_op; - - if (check_interface1 (ns->op[i], ns2->op[i], 0, - interface_name, true)) - goto done; - - /* i should be gfc_intrinsic_op, but has to be int with this cast - here for stupid C++ compatibility rules. */ - other_op = gfc_equivalent_op ((gfc_intrinsic_op) i); - if (other_op != INTRINSIC_NONE - && check_interface1 (ns->op[i], ns2->op[other_op], - 0, interface_name, true)) - goto done; - } - } - -done: - gfc_current_ns = old_ns; -} - - -/* Given a symbol of a formal argument list and an expression, if the - formal argument is allocatable, check that the actual argument is - allocatable. Returns true if compatible, zero if not compatible. */ - -static bool -compare_allocatable (gfc_symbol *formal, gfc_expr *actual) -{ - if (formal->attr.allocatable - || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable)) - { - symbol_attribute attr = gfc_expr_attr (actual); - if (actual->ts.type == BT_CLASS && !attr.class_ok) - return true; - else if (!attr.allocatable) - return false; - } - - return true; -} - - -/* Given a symbol of a formal argument list and an expression, if the - formal argument is a pointer, see if the actual argument is a - pointer. Returns nonzero if compatible, zero if not compatible. */ - -static int -compare_pointer (gfc_symbol *formal, gfc_expr *actual) -{ - symbol_attribute attr; - - if (formal->attr.pointer - || (formal->ts.type == BT_CLASS && CLASS_DATA (formal) - && CLASS_DATA (formal)->attr.class_pointer)) - { - attr = gfc_expr_attr (actual); - - /* Fortran 2008 allows non-pointer actual arguments. */ - if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN) - return 2; - - if (!attr.pointer) - return 0; - } - - return 1; -} - - -/* Emit clear error messages for rank mismatch. */ - -static void -argument_rank_mismatch (const char *name, locus *where, - int rank1, int rank2, locus *where_formal) -{ - - /* TS 29113, C407b. */ - if (where_formal == NULL) - { - if (rank2 == -1) - gfc_error ("The assumed-rank array at %L requires that the dummy " - "argument %qs has assumed-rank", where, name); - else if (rank1 == 0) - gfc_error_opt (0, "Rank mismatch in argument %qs " - "at %L (scalar and rank-%d)", name, where, rank2); - else if (rank2 == 0) - gfc_error_opt (0, "Rank mismatch in argument %qs " - "at %L (rank-%d and scalar)", name, where, rank1); - else - gfc_error_opt (0, "Rank mismatch in argument %qs " - "at %L (rank-%d and rank-%d)", name, where, rank1, - rank2); - } - else - { - if (rank2 == -1) - /* This is an assumed rank-actual passed to a function without - an explicit interface, which is already diagnosed in - gfc_procedure_use. */ - return; - if (rank1 == 0) - gfc_error_opt (0, "Rank mismatch between actual argument at %L " - "and actual argument at %L (scalar and rank-%d)", - where, where_formal, rank2); - else if (rank2 == 0) - gfc_error_opt (0, "Rank mismatch between actual argument at %L " - "and actual argument at %L (rank-%d and scalar)", - where, where_formal, rank1); - else - gfc_error_opt (0, "Rank mismatch between actual argument at %L " - "and actual argument at %L (rank-%d and rank-%d)", where, - where_formal, rank1, rank2); - } -} - - -/* Under certain conditions, a scalar actual argument can be passed - to an array dummy argument - see F2018, 15.5.2.4, paragraph 14. - This function returns true for these conditions so that an error - or warning for this can be suppressed later. Always return false - for expressions with rank > 0. */ - -bool -maybe_dummy_array_arg (gfc_expr *e) -{ - gfc_symbol *s; - gfc_ref *ref; - bool array_pointer = false; - bool assumed_shape = false; - bool scalar_ref = true; - - if (e->rank > 0) - return false; - - if (e->ts.type == BT_CHARACTER && e->ts.kind == 1) - return true; - - /* If this comes from a constructor, it has been an array element - originally. */ - - if (e->expr_type == EXPR_CONSTANT) - return e->from_constructor; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - s = e->symtree->n.sym; - - if (s->attr.dimension) - { - scalar_ref = false; - array_pointer = s->attr.pointer; - } - - if (s->as && s->as->type == AS_ASSUMED_SHAPE) - assumed_shape = true; - - for (ref=e->ref; ref; ref=ref->next) - { - if (ref->type == REF_COMPONENT) - { - symbol_attribute *attr; - attr = &ref->u.c.component->attr; - if (attr->dimension) - { - array_pointer = attr->pointer; - assumed_shape = false; - scalar_ref = false; - } - else - scalar_ref = true; - } - } - - return !(scalar_ref || array_pointer || assumed_shape); -} - -/* Given a symbol of a formal argument list and an expression, see if - the two are compatible as arguments. Returns true if - compatible, false if not compatible. */ - -static bool -compare_parameter (gfc_symbol *formal, gfc_expr *actual, - int ranks_must_agree, int is_elemental, locus *where) -{ - gfc_ref *ref; - bool rank_check, is_pointer; - char err[200]; - gfc_component *ppc; - bool codimension = false; - - /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding - procs c_f_pointer or c_f_procpointer, and we need to accept most - pointers the user could give us. This should allow that. */ - if (formal->ts.type == BT_VOID) - return true; - - if (formal->ts.type == BT_DERIVED - && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c - && actual->ts.type == BT_DERIVED - && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) - return true; - - if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) - /* Make sure the vtab symbol is present when - the module variables are generated. */ - gfc_find_derived_vtab (actual->ts.u.derived); - - if (actual->ts.type == BT_PROCEDURE) - { - gfc_symbol *act_sym = actual->symtree->n.sym; - - if (formal->attr.flavor != FL_PROCEDURE) - { - if (where) - gfc_error ("Invalid procedure argument at %L", &actual->where); - return false; - } - - if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, - sizeof(err), NULL, NULL)) - { - if (where) - gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" - " %s", formal->name, &actual->where, err); - return false; - } - - if (formal->attr.function && !act_sym->attr.function) - { - gfc_add_function (&act_sym->attr, act_sym->name, - &act_sym->declared_at); - if (act_sym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (act_sym, 1, act_sym->ns)) - return false; - } - else if (formal->attr.subroutine && !act_sym->attr.subroutine) - gfc_add_subroutine (&act_sym->attr, act_sym->name, - &act_sym->declared_at); - - return true; - } - - ppc = gfc_get_proc_ptr_comp (actual); - if (ppc && ppc->ts.interface) - { - if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1, - err, sizeof(err), NULL, NULL)) - { - if (where) - gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" - " %s", formal->name, &actual->where, err); - return false; - } - } - - /* F2008, C1241. */ - if (formal->attr.pointer && formal->attr.contiguous - && !gfc_is_simply_contiguous (actual, true, false)) - { - if (where) - gfc_error ("Actual argument to contiguous pointer dummy %qs at %L " - "must be simply contiguous", formal->name, &actual->where); - return false; - } - - symbol_attribute actual_attr = gfc_expr_attr (actual); - if (actual->ts.type == BT_CLASS && !actual_attr.class_ok) - return true; - - if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) - && actual->ts.type != BT_HOLLERITH - && formal->ts.type != BT_ASSUMED - && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - && !gfc_compare_types (&formal->ts, &actual->ts) - && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS - && gfc_compare_derived_types (formal->ts.u.derived, - CLASS_DATA (actual)->ts.u.derived))) - { - if (where) - { - if (formal->attr.artificial) - { - if (!flag_allow_argument_mismatch || !formal->error) - gfc_error_opt (0, "Type mismatch between actual argument at %L " - "and actual argument at %L (%s/%s).", - &actual->where, - &formal->declared_at, - gfc_typename (actual), - gfc_dummy_typename (&formal->ts)); - - formal->error = 1; - } - else - gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s " - "to %s", formal->name, where, gfc_typename (actual), - gfc_dummy_typename (&formal->ts)); - } - return false; - } - - if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED) - { - if (where) - gfc_error ("Assumed-type actual argument at %L requires that dummy " - "argument %qs is of assumed type", &actual->where, - formal->name); - return false; - } - - /* TS29113 C407c; F2018 C711. */ - if (actual->ts.type == BT_ASSUMED - && symbol_rank (formal) == -1 - && actual->rank != -1 - && !(actual->symtree->n.sym->as - && actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)) - { - if (where) - gfc_error ("Assumed-type actual argument at %L corresponding to " - "assumed-rank dummy argument %qs must be " - "assumed-shape or assumed-rank", - &actual->where, formal->name); - return false; - } - - /* F2008, 12.5.2.5; IR F08/0073. */ - if (formal->ts.type == BT_CLASS && formal->attr.class_ok - && actual->expr_type != EXPR_NULL - && ((CLASS_DATA (formal)->attr.class_pointer - && formal->attr.intent != INTENT_IN) - || CLASS_DATA (formal)->attr.allocatable)) - { - if (actual->ts.type != BT_CLASS) - { - if (where) - gfc_error ("Actual argument to %qs at %L must be polymorphic", - formal->name, &actual->where); - return false; - } - - if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) - && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, - CLASS_DATA (formal)->ts.u.derived)) - { - if (where) - gfc_error ("Actual argument to %qs at %L must have the same " - "declared type", formal->name, &actual->where); - return false; - } - } - - /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this - is necessary also for F03, so retain error for both. - NOTE: Other type/kind errors pre-empt this error. Since they are F03 - compatible, no attempt has been made to channel to this one. */ - if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) - && (CLASS_DATA (formal)->attr.allocatable - ||CLASS_DATA (formal)->attr.class_pointer)) - { - if (where) - gfc_error ("Actual argument to %qs at %L must be unlimited " - "polymorphic since the formal argument is a " - "pointer or allocatable unlimited polymorphic " - "entity [F2008: 12.5.2.5]", formal->name, - &actual->where); - return false; - } - - if (formal->ts.type == BT_CLASS && formal->attr.class_ok) - codimension = CLASS_DATA (formal)->attr.codimension; - else - codimension = formal->attr.codimension; - - if (codimension && !gfc_is_coarray (actual)) - { - if (where) - gfc_error ("Actual argument to %qs at %L must be a coarray", - formal->name, &actual->where); - return false; - } - - if (codimension && formal->attr.allocatable) - { - gfc_ref *last = NULL; - - for (ref = actual->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - last = ref; - - /* F2008, 12.5.2.6. */ - if ((last && last->u.c.component->as->corank != formal->as->corank) - || (!last - && actual->symtree->n.sym->as->corank != formal->as->corank)) - { - if (where) - gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)", - formal->name, &actual->where, formal->as->corank, - last ? last->u.c.component->as->corank - : actual->symtree->n.sym->as->corank); - return false; - } - } - - if (codimension) - { - /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */ - /* F2018, 12.5.2.8. */ - if (formal->attr.dimension - && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) - && actual_attr.dimension - && !gfc_is_simply_contiguous (actual, true, true)) - { - if (where) - gfc_error ("Actual argument to %qs at %L must be simply " - "contiguous or an element of such an array", - formal->name, &actual->where); - return false; - } - - /* F2008, C1303 and C1304. */ - if (formal->attr.intent != INTENT_INOUT - && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) - && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) - || formal->attr.lock_comp)) - - { - if (where) - gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " - "which is LOCK_TYPE or has a LOCK_TYPE component", - formal->name, &actual->where); - return false; - } - - /* TS18508, C702/C703. */ - if (formal->attr.intent != INTENT_INOUT - && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) - && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) - || formal->attr.event_comp)) - - { - if (where) - gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " - "which is EVENT_TYPE or has a EVENT_TYPE component", - formal->name, &actual->where); - return false; - } - } - - /* F2008, C1239/C1240. */ - if (actual->expr_type == EXPR_VARIABLE - && (actual->symtree->n.sym->attr.asynchronous - || actual->symtree->n.sym->attr.volatile_) - && (formal->attr.asynchronous || formal->attr.volatile_) - && actual->rank && formal->as - && !gfc_is_simply_contiguous (actual, true, false) - && ((formal->as->type != AS_ASSUMED_SHAPE - && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer) - || formal->attr.contiguous)) - { - if (where) - gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or " - "assumed-rank array without CONTIGUOUS attribute - as actual" - " argument at %L is not simply contiguous and both are " - "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where); - return false; - } - - if (formal->attr.allocatable && !codimension - && actual_attr.codimension) - { - if (formal->attr.intent == INTENT_OUT) - { - if (where) - gfc_error ("Passing coarray at %L to allocatable, noncoarray, " - "INTENT(OUT) dummy argument %qs", &actual->where, - formal->name); - return false; - } - else if (warn_surprising && where && formal->attr.intent != INTENT_IN) - gfc_warning (OPT_Wsurprising, - "Passing coarray at %L to allocatable, noncoarray dummy " - "argument %qs, which is invalid if the allocation status" - " is modified", &actual->where, formal->name); - } - - /* If the rank is the same or the formal argument has assumed-rank. */ - if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1) - return true; - - rank_check = where != NULL && !is_elemental && formal->as - && (formal->as->type == AS_ASSUMED_SHAPE - || formal->as->type == AS_DEFERRED) - && actual->expr_type != EXPR_NULL; - - /* Skip rank checks for NO_ARG_CHECK. */ - if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - return true; - - /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ - if (rank_check || ranks_must_agree - || (formal->attr.pointer && actual->expr_type != EXPR_NULL) - || (actual->rank != 0 && !(is_elemental || formal->attr.dimension)) - || (actual->rank == 0 - && ((formal->ts.type == BT_CLASS - && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE) - || (formal->ts.type != BT_CLASS - && formal->as->type == AS_ASSUMED_SHAPE)) - && actual->expr_type != EXPR_NULL) - || (actual->rank == 0 && formal->attr.dimension - && gfc_is_coindexed (actual)) - /* Assumed-rank actual argument; F2018 C838. */ - || actual->rank == -1) - { - if (where - && (!formal->attr.artificial || (!formal->maybe_array - && !maybe_dummy_array_arg (actual)))) - { - locus *where_formal; - if (formal->attr.artificial) - where_formal = &formal->declared_at; - else - where_formal = NULL; - - argument_rank_mismatch (formal->name, &actual->where, - symbol_rank (formal), actual->rank, - where_formal); - } - return false; - } - else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) - return true; - - /* At this point, we are considering a scalar passed to an array. This - is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4), - - if the actual argument is (a substring of) an element of a - non-assumed-shape/non-pointer/non-polymorphic array; or - - (F2003) if the actual argument is of type character of default/c_char - kind. */ - - is_pointer = actual->expr_type == EXPR_VARIABLE - ? actual->symtree->n.sym->attr.pointer : false; - - for (ref = actual->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT) - is_pointer = ref->u.c.component->attr.pointer; - else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT - && ref->u.ar.dimen > 0 - && (!ref->next - || (ref->next->type == REF_SUBSTRING && !ref->next->next))) - break; - } - - if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL) - { - if (where) - gfc_error ("Polymorphic scalar passed to array dummy argument %qs " - "at %L", formal->name, &actual->where); - return false; - } - - if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER - && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) - { - if (where) - { - if (formal->attr.artificial) - gfc_error ("Element of assumed-shape or pointer array " - "as actual argument at %L cannot correspond to " - "actual argument at %L", - &actual->where, &formal->declared_at); - else - gfc_error ("Element of assumed-shape or pointer " - "array passed to array dummy argument %qs at %L", - formal->name, &actual->where); - } - return false; - } - - if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL - && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) - { - if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0) - { - if (where) - gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " - "CHARACTER actual argument with array dummy argument " - "%qs at %L", formal->name, &actual->where); - return false; - } - - if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) - { - gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " - "array dummy argument %qs at %L", - formal->name, &actual->where); - return false; - } - else - return ((gfc_option.allow_std & GFC_STD_F2003) != 0); - } - - if (ref == NULL && actual->expr_type != EXPR_NULL) - { - if (where - && (!formal->attr.artificial || (!formal->maybe_array - && !maybe_dummy_array_arg (actual)))) - { - locus *where_formal; - if (formal->attr.artificial) - where_formal = &formal->declared_at; - else - where_formal = NULL; - - argument_rank_mismatch (formal->name, &actual->where, - symbol_rank (formal), actual->rank, - where_formal); - } - return false; - } - - return true; -} - - -/* Returns the storage size of a symbol (formal argument) or - zero if it cannot be determined. */ - -static unsigned long -get_sym_storage_size (gfc_symbol *sym) -{ - int i; - unsigned long strlen, elements; - - if (sym->ts.type == BT_CHARACTER) - { - if (sym->ts.u.cl && sym->ts.u.cl->length - && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) - strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer); - else - return 0; - } - else - strlen = 1; - - if (symbol_rank (sym) == 0) - return strlen; - - elements = 1; - if (sym->as->type != AS_EXPLICIT) - return 0; - for (i = 0; i < sym->as->rank; i++) - { - if (sym->as->upper[i]->expr_type != EXPR_CONSTANT - || sym->as->lower[i]->expr_type != EXPR_CONSTANT) - return 0; - - elements *= mpz_get_si (sym->as->upper[i]->value.integer) - - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; - } - - return strlen*elements; -} - - -/* Returns the storage size of an expression (actual argument) or - zero if it cannot be determined. For an array element, it returns - the remaining size as the element sequence consists of all storage - units of the actual argument up to the end of the array. */ - -static unsigned long -get_expr_storage_size (gfc_expr *e) -{ - int i; - long int strlen, elements; - long int substrlen = 0; - bool is_str_storage = false; - gfc_ref *ref; - - if (e == NULL) - return 0; - - if (e->ts.type == BT_CHARACTER) - { - if (e->ts.u.cl && e->ts.u.cl->length - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) - strlen = mpz_get_si (e->ts.u.cl->length->value.integer); - else if (e->expr_type == EXPR_CONSTANT - && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) - strlen = e->value.character.length; - else - return 0; - } - else - strlen = 1; /* Length per element. */ - - if (e->rank == 0 && !e->ref) - return strlen; - - elements = 1; - if (!e->ref) - { - if (!e->shape) - return 0; - for (i = 0; i < e->rank; i++) - elements *= mpz_get_si (e->shape[i]); - return elements*strlen; - } - - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_SUBSTRING && ref->u.ss.start - && ref->u.ss.start->expr_type == EXPR_CONSTANT) - { - if (is_str_storage) - { - /* The string length is the substring length. - Set now to full string length. */ - if (!ref->u.ss.length || !ref->u.ss.length->length - || ref->u.ss.length->length->expr_type != EXPR_CONSTANT) - return 0; - - strlen = mpz_get_ui (ref->u.ss.length->length->value.integer); - } - substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1; - continue; - } - - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) - for (i = 0; i < ref->u.ar.dimen; i++) - { - long int start, end, stride; - stride = 1; - - if (ref->u.ar.stride[i]) - { - if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT) - stride = mpz_get_si (ref->u.ar.stride[i]->value.integer); - else - return 0; - } - - if (ref->u.ar.start[i]) - { - if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT) - start = mpz_get_si (ref->u.ar.start[i]->value.integer); - else - return 0; - } - else if (ref->u.ar.as->lower[i] - && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT) - start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer); - else - return 0; - - if (ref->u.ar.end[i]) - { - if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT) - end = mpz_get_si (ref->u.ar.end[i]->value.integer); - else - return 0; - } - else if (ref->u.ar.as->upper[i] - && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT) - end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer); - else - return 0; - - elements *= (end - start)/stride + 1L; - } - else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL) - for (i = 0; i < ref->u.ar.as->rank; i++) - { - if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i] - && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT - && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER - && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT - && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER) - elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer) - - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) - + 1L; - else - return 0; - } - else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT - && e->expr_type == EXPR_VARIABLE) - { - if (ref->u.ar.as->type == AS_ASSUMED_SHAPE - || e->symtree->n.sym->attr.pointer) - { - elements = 1; - continue; - } - - /* Determine the number of remaining elements in the element - sequence for array element designators. */ - is_str_storage = true; - for (i = ref->u.ar.dimen - 1; i >= 0; i--) - { - if (ref->u.ar.start[i] == NULL - || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT - || ref->u.ar.as->upper[i] == NULL - || ref->u.ar.as->lower[i] == NULL - || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT - || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT) - return 0; - - elements - = elements - * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer) - - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) - + 1L) - - (mpz_get_si (ref->u.ar.start[i]->value.integer) - - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)); - } - } - else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function - && ref->u.c.component->attr.proc_pointer - && ref->u.c.component->attr.dimension) - { - /* Array-valued procedure-pointer components. */ - gfc_array_spec *as = ref->u.c.component->as; - for (i = 0; i < as->rank; i++) - { - if (!as->upper[i] || !as->lower[i] - || as->upper[i]->expr_type != EXPR_CONSTANT - || as->lower[i]->expr_type != EXPR_CONSTANT) - return 0; - - elements = elements - * (mpz_get_si (as->upper[i]->value.integer) - - mpz_get_si (as->lower[i]->value.integer) + 1L); - } - } - } - - if (substrlen) - return (is_str_storage) ? substrlen + (elements-1)*strlen - : elements*strlen; - else - return elements*strlen; -} - - -/* Given an expression, check whether it is an array section - which has a vector subscript. */ - -bool -gfc_has_vector_subscript (gfc_expr *e) -{ - int i; - gfc_ref *ref; - - if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE) - return false; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) - for (i = 0; i < ref->u.ar.dimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) - return true; - - return false; -} - - -static bool -is_procptr_result (gfc_expr *expr) -{ - gfc_component *c = gfc_get_proc_ptr_comp (expr); - if (c) - return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1)); - else - return ((expr->symtree->n.sym->result != expr->symtree->n.sym) - && (expr->symtree->n.sym->result->attr.proc_pointer == 1)); -} - - -/* Recursively append candidate argument ARG to CANDIDATES. Store the - number of total candidates in CANDIDATES_LEN. */ - -static void -lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg, - char **&candidates, - size_t &candidates_len) -{ - for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next) - vec_push (candidates, candidates_len, p->sym->name); -} - - -/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */ - -static const char* -lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments) -{ - char **candidates = NULL; - size_t candidates_len = 0; - lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len); - return gfc_closest_fuzzy_match (arg, candidates); -} - - -static gfc_dummy_arg * -get_nonintrinsic_dummy_arg (gfc_formal_arglist *formal) -{ - gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg (); - - dummy_arg->intrinsicness = GFC_NON_INTRINSIC_DUMMY_ARG; - dummy_arg->u.non_intrinsic = formal; - - return dummy_arg; -} - - -/* Given formal and actual argument lists, see if they are compatible. - If they are compatible, the actual argument list is sorted to - correspond with the formal list, and elements for missing optional - arguments are inserted. If WHERE pointer is nonnull, then we issue - errors when things don't match instead of just returning the status - code. */ - -bool -gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, - int ranks_must_agree, int is_elemental, - bool in_statement_function, locus *where) -{ - gfc_actual_arglist **new_arg, *a, *actual; - gfc_formal_arglist *f; - int i, n, na; - unsigned long actual_size, formal_size; - bool full_array = false; - gfc_array_ref *actual_arr_ref; - gfc_array_spec *fas, *aas; - bool pointer_dummy, pointer_arg, allocatable_arg; - - bool ok = true; - - actual = *ap; - - if (actual == NULL && formal == NULL) - return true; - - n = 0; - for (f = formal; f; f = f->next) - n++; - - new_arg = XALLOCAVEC (gfc_actual_arglist *, n); - - for (i = 0; i < n; i++) - new_arg[i] = NULL; - - na = 0; - f = formal; - i = 0; - - for (a = actual; a; a = a->next, f = f->next) - { - if (a->name != NULL && in_statement_function) - { - gfc_error ("Keyword argument %qs at %L is invalid in " - "a statement function", a->name, &a->expr->where); - return false; - } - - /* Look for keywords but ignore g77 extensions like %VAL. */ - if (a->name != NULL && a->name[0] != '%') - { - i = 0; - for (f = formal; f; f = f->next, i++) - { - if (f->sym == NULL) - continue; - if (strcmp (f->sym->name, a->name) == 0) - break; - } - - if (f == NULL) - { - if (where) - { - const char *guessed = lookup_arg_fuzzy (a->name, formal); - if (guessed) - gfc_error ("Keyword argument %qs at %L is not in " - "the procedure; did you mean %qs?", - a->name, &a->expr->where, guessed); - else - gfc_error ("Keyword argument %qs at %L is not in " - "the procedure", a->name, &a->expr->where); - } - return false; - } - - if (new_arg[i] != NULL) - { - if (where) - gfc_error ("Keyword argument %qs at %L is already associated " - "with another actual argument", a->name, - &a->expr->where); - return false; - } - } - - if (f == NULL) - { - if (where) - gfc_error ("More actual than formal arguments in procedure " - "call at %L", where); - return false; - } - - if (f->sym == NULL && a->expr == NULL) - goto match; - - if (f->sym == NULL) - { - /* These errors have to be issued, otherwise an ICE can occur. - See PR 78865. */ - if (where) - gfc_error_now ("Missing alternate return specifier in subroutine " - "call at %L", where); - return false; - } - else - a->associated_dummy = get_nonintrinsic_dummy_arg (f); - - if (a->expr == NULL) - { - if (f->sym->attr.optional) - continue; - else - { - if (where) - gfc_error_now ("Unexpected alternate return specifier in " - "subroutine call at %L", where); - return false; - } - } - - /* Make sure that intrinsic vtables exist for calls to unlimited - polymorphic formal arguments. */ - if (UNLIMITED_POLY (f->sym) - && a->expr->ts.type != BT_DERIVED - && a->expr->ts.type != BT_CLASS - && a->expr->ts.type != BT_ASSUMED) - gfc_find_vtab (&a->expr->ts); - - if (a->expr->expr_type == EXPR_NULL - && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer - && (f->sym->attr.allocatable || !f->sym->attr.optional - || (gfc_option.allow_std & GFC_STD_F2008) == 0)) - || (f->sym->ts.type == BT_CLASS - && !CLASS_DATA (f->sym)->attr.class_pointer - && (CLASS_DATA (f->sym)->attr.allocatable - || !f->sym->attr.optional - || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) - { - if (where - && (!f->sym->attr.optional - || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) - || (f->sym->ts.type == BT_CLASS - && CLASS_DATA (f->sym)->attr.allocatable))) - gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs", - where, f->sym->name); - else if (where) - gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " - "dummy %qs", where, f->sym->name); - ok = false; - goto match; - } - - if (!compare_parameter (f->sym, a->expr, ranks_must_agree, - is_elemental, where)) - { - ok = false; - goto match; - } - - /* TS 29113, 6.3p2; F2018 15.5.2.4. */ - if (f->sym->ts.type == BT_ASSUMED - && (a->expr->ts.type == BT_DERIVED - || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr)))) - { - gfc_symbol *derived = (a->expr->ts.type == BT_DERIVED - ? a->expr->ts.u.derived - : CLASS_DATA (a->expr)->ts.u.derived); - gfc_namespace *f2k_derived = derived->f2k_derived; - if (derived->attr.pdt_type - || (f2k_derived - && (f2k_derived->finalizers || f2k_derived->tb_sym_root))) - { - gfc_error ("Actual argument at %L to assumed-type dummy " - "has type parameters or is of " - "derived type with type-bound or FINAL procedures", - &a->expr->where); - ok = false; - goto match; - } - } - - /* Special case for character arguments. For allocatable, pointer - and assumed-shape dummies, the string length needs to match - exactly. */ - if (a->expr->ts.type == BT_CHARACTER - && a->expr->ts.u.cl && a->expr->ts.u.cl->length - && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT - && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl - && f->sym->ts.u.cl->length - && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT - && (f->sym->attr.pointer || f->sym->attr.allocatable - || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) - && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, - f->sym->ts.u.cl->length->value.integer) != 0)) - { - if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) - gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " - "argument and pointer or allocatable dummy argument " - "%qs at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); - else if (where) - gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " - "argument and assumed-shape dummy argument %qs " - "at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); - ok = false; - goto match; - } - - if ((f->sym->attr.pointer || f->sym->attr.allocatable) - && f->sym->ts.deferred != a->expr->ts.deferred - && a->expr->ts.type == BT_CHARACTER) - { - if (where) - gfc_error ("Actual argument at %L to allocatable or " - "pointer dummy argument %qs must have a deferred " - "length type parameter if and only if the dummy has one", - &a->expr->where, f->sym->name); - ok = false; - goto match; - } - - if (f->sym->ts.type == BT_CLASS) - goto skip_size_check; - - actual_size = get_expr_storage_size (a->expr); - formal_size = get_sym_storage_size (f->sym); - if (actual_size != 0 && actual_size < formal_size - && a->expr->ts.type != BT_PROCEDURE - && f->sym->attr.flavor != FL_PROCEDURE) - { - if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) - { - gfc_warning (0, "Character length of actual argument shorter " - "than of dummy argument %qs (%lu/%lu) at %L", - f->sym->name, actual_size, formal_size, - &a->expr->where); - goto skip_size_check; - } - else if (where) - { - /* Emit a warning for -std=legacy and an error otherwise. */ - if (gfc_option.warn_std == 0) - gfc_warning (0, "Actual argument contains too few " - "elements for dummy argument %qs (%lu/%lu) " - "at %L", f->sym->name, actual_size, - formal_size, &a->expr->where); - else - gfc_error_now ("Actual argument contains too few " - "elements for dummy argument %qs (%lu/%lu) " - "at %L", f->sym->name, actual_size, - formal_size, &a->expr->where); - } - ok = false; - goto match; - } - - skip_size_check: - - /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual - argument is provided for a procedure pointer formal argument. */ - if (f->sym->attr.proc_pointer - && !((a->expr->expr_type == EXPR_VARIABLE - && (a->expr->symtree->n.sym->attr.proc_pointer - || gfc_is_proc_ptr_comp (a->expr))) - || (a->expr->expr_type == EXPR_FUNCTION - && is_procptr_result (a->expr)))) - { - if (where) - gfc_error ("Expected a procedure pointer for argument %qs at %L", - f->sym->name, &a->expr->where); - ok = false; - goto match; - } - - /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is - provided for a procedure formal argument. */ - if (f->sym->attr.flavor == FL_PROCEDURE - && !((a->expr->expr_type == EXPR_VARIABLE - && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE - || a->expr->symtree->n.sym->attr.proc_pointer - || gfc_is_proc_ptr_comp (a->expr))) - || (a->expr->expr_type == EXPR_FUNCTION - && is_procptr_result (a->expr)))) - { - if (where) - gfc_error ("Expected a procedure for argument %qs at %L", - f->sym->name, &a->expr->where); - ok = false; - goto match; - } - - /* Class array variables and expressions store array info in a - different place from non-class objects; consolidate the logic - to access it here instead of repeating it below. Note that - pointer_arg and allocatable_arg are not fully general and are - only used in a specific situation below with an assumed-rank - argument. */ - if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)) - { - gfc_component *classdata = CLASS_DATA (f->sym); - fas = classdata->as; - pointer_dummy = classdata->attr.class_pointer; - } - else - { - fas = f->sym->as; - pointer_dummy = f->sym->attr.pointer; - } - - if (a->expr->expr_type != EXPR_VARIABLE) - { - aas = NULL; - pointer_arg = false; - allocatable_arg = false; - } - else if (a->expr->ts.type == BT_CLASS - && a->expr->symtree->n.sym - && CLASS_DATA (a->expr->symtree->n.sym)) - { - gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym); - aas = classdata->as; - pointer_arg = classdata->attr.class_pointer; - allocatable_arg = classdata->attr.allocatable; - } - else - { - aas = a->expr->symtree->n.sym->as; - pointer_arg = a->expr->symtree->n.sym->attr.pointer; - allocatable_arg = a->expr->symtree->n.sym->attr.allocatable; - } - - /* F2018:9.5.2(2) permits assumed-size whole array expressions as - actual arguments only if the shape is not required; thus it - cannot be passed to an assumed-shape array dummy. - F2018:15.5.2.(2) permits passing a nonpointer actual to an - intent(in) pointer dummy argument and this is accepted by - the compare_pointer check below, but this also requires shape - information. - There's more discussion of this in PR94110. */ - if (fas - && (fas->type == AS_ASSUMED_SHAPE - || fas->type == AS_DEFERRED - || (fas->type == AS_ASSUMED_RANK && pointer_dummy)) - && aas - && aas->type == AS_ASSUMED_SIZE - && (a->expr->ref == NULL - || (a->expr->ref->type == REF_ARRAY - && a->expr->ref->u.ar.type == AR_FULL))) - { - if (where) - gfc_error ("Actual argument for %qs cannot be an assumed-size" - " array at %L", f->sym->name, where); - ok = false; - goto match; - } - - /* Diagnose F2018 C839 (TS29113 C535c). Here the problem is - passing an assumed-size array to an INTENT(OUT) assumed-rank - dummy when it doesn't have the size information needed to run - initializers and finalizers. */ - if (f->sym->attr.intent == INTENT_OUT - && fas - && fas->type == AS_ASSUMED_RANK - && aas - && ((aas->type == AS_ASSUMED_SIZE - && (a->expr->ref == NULL - || (a->expr->ref->type == REF_ARRAY - && a->expr->ref->u.ar.type == AR_FULL))) - || (aas->type == AS_ASSUMED_RANK - && !pointer_arg - && !allocatable_arg)) - && (a->expr->ts.type == BT_CLASS - || (a->expr->ts.type == BT_DERIVED - && (gfc_is_finalizable (a->expr->ts.u.derived, NULL) - || gfc_has_ultimate_allocatable (a->expr) - || gfc_has_default_initializer - (a->expr->ts.u.derived))))) - { - if (where) - gfc_error ("Actual argument to assumed-rank INTENT(OUT) " - "dummy %qs at %L cannot be of unknown size", - f->sym->name, where); - ok = false; - goto match; - } - - if (a->expr->expr_type != EXPR_NULL - && compare_pointer (f->sym, a->expr) == 0) - { - if (where) - gfc_error ("Actual argument for %qs must be a pointer at %L", - f->sym->name, &a->expr->where); - ok = false; - goto match; - } - - if (a->expr->expr_type != EXPR_NULL - && (gfc_option.allow_std & GFC_STD_F2008) == 0 - && compare_pointer (f->sym, a->expr) == 2) - { - if (where) - gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " - "pointer dummy %qs", &a->expr->where,f->sym->name); - ok = false; - goto match; - } - - - /* Fortran 2008, C1242. */ - if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) - { - if (where) - gfc_error ("Coindexed actual argument at %L to pointer " - "dummy %qs", - &a->expr->where, f->sym->name); - ok = false; - goto match; - } - - /* Fortran 2008, 12.5.2.5 (no constraint). */ - if (a->expr->expr_type == EXPR_VARIABLE - && f->sym->attr.intent != INTENT_IN - && f->sym->attr.allocatable - && gfc_is_coindexed (a->expr)) - { - if (where) - gfc_error ("Coindexed actual argument at %L to allocatable " - "dummy %qs requires INTENT(IN)", - &a->expr->where, f->sym->name); - ok = false; - goto match; - } - - /* Fortran 2008, C1237. */ - if (a->expr->expr_type == EXPR_VARIABLE - && (f->sym->attr.asynchronous || f->sym->attr.volatile_) - && gfc_is_coindexed (a->expr) - && (a->expr->symtree->n.sym->attr.volatile_ - || a->expr->symtree->n.sym->attr.asynchronous)) - { - if (where) - gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " - "%L requires that dummy %qs has neither " - "ASYNCHRONOUS nor VOLATILE", &a->expr->where, - f->sym->name); - ok = false; - goto match; - } - - /* Fortran 2008, 12.5.2.4 (no constraint). */ - if (a->expr->expr_type == EXPR_VARIABLE - && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value - && gfc_is_coindexed (a->expr) - && gfc_has_ultimate_allocatable (a->expr)) - { - if (where) - gfc_error ("Coindexed actual argument at %L with allocatable " - "ultimate component to dummy %qs requires either VALUE " - "or INTENT(IN)", &a->expr->where, f->sym->name); - ok = false; - goto match; - } - - if (f->sym->ts.type == BT_CLASS - && CLASS_DATA (f->sym)->attr.allocatable - && gfc_is_class_array_ref (a->expr, &full_array) - && !full_array) - { - if (where) - gfc_error ("Actual CLASS array argument for %qs must be a full " - "array at %L", f->sym->name, &a->expr->where); - ok = false; - goto match; - } - - - if (a->expr->expr_type != EXPR_NULL - && !compare_allocatable (f->sym, a->expr)) - { - if (where) - gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", - f->sym->name, &a->expr->where); - ok = false; - goto match; - } - - /* Check intent = OUT/INOUT for definable actual argument. */ - if (!in_statement_function - && (f->sym->attr.intent == INTENT_OUT - || f->sym->attr.intent == INTENT_INOUT)) - { - const char* context = (where - ? _("actual argument to INTENT = OUT/INOUT") - : NULL); - - if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok - && CLASS_DATA (f->sym)->attr.class_pointer) - || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) - && !gfc_check_vardef_context (a->expr, true, false, false, context)) - { - ok = false; - goto match; - } - if (!gfc_check_vardef_context (a->expr, false, false, false, context)) - { - ok = false; - goto match; - } - } - - if ((f->sym->attr.intent == INTENT_OUT - || f->sym->attr.intent == INTENT_INOUT - || f->sym->attr.volatile_ - || f->sym->attr.asynchronous) - && gfc_has_vector_subscript (a->expr)) - { - if (where) - gfc_error ("Array-section actual argument with vector " - "subscripts at %L is incompatible with INTENT(OUT), " - "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " - "of the dummy argument %qs", - &a->expr->where, f->sym->name); - ok = false; - goto match; - } - - /* C1232 (R1221) For an actual argument which is an array section or - an assumed-shape array, the dummy argument shall be an assumed- - shape array, if the dummy argument has the VOLATILE attribute. */ - - if (f->sym->attr.volatile_ - && a->expr->expr_type == EXPR_VARIABLE - && a->expr->symtree->n.sym->as - && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE - && !(fas && fas->type == AS_ASSUMED_SHAPE)) - { - if (where) - gfc_error ("Assumed-shape actual argument at %L is " - "incompatible with the non-assumed-shape " - "dummy argument %qs due to VOLATILE attribute", - &a->expr->where,f->sym->name); - ok = false; - goto match; - } - - /* Find the last array_ref. */ - actual_arr_ref = NULL; - if (a->expr->ref) - actual_arr_ref = gfc_find_array_ref (a->expr, true); - - if (f->sym->attr.volatile_ - && actual_arr_ref && actual_arr_ref->type == AR_SECTION - && !(fas && fas->type == AS_ASSUMED_SHAPE)) - { - if (where) - gfc_error ("Array-section actual argument at %L is " - "incompatible with the non-assumed-shape " - "dummy argument %qs due to VOLATILE attribute", - &a->expr->where, f->sym->name); - ok = false; - goto match; - } - - /* C1233 (R1221) For an actual argument which is a pointer array, the - dummy argument shall be an assumed-shape or pointer array, if the - dummy argument has the VOLATILE attribute. */ - - if (f->sym->attr.volatile_ - && a->expr->expr_type == EXPR_VARIABLE - && a->expr->symtree->n.sym->attr.pointer - && a->expr->symtree->n.sym->as - && !(fas - && (fas->type == AS_ASSUMED_SHAPE - || f->sym->attr.pointer))) - { - if (where) - gfc_error ("Pointer-array actual argument at %L requires " - "an assumed-shape or pointer-array dummy " - "argument %qs due to VOLATILE attribute", - &a->expr->where,f->sym->name); - ok = false; - goto match; - } - - match: - if (a == actual) - na = i; - - new_arg[i++] = a; - } - - /* Give up now if we saw any bad argument. */ - if (!ok) - return false; - - /* Make sure missing actual arguments are optional. */ - i = 0; - for (f = formal; f; f = f->next, i++) - { - if (new_arg[i] != NULL) - continue; - if (f->sym == NULL) - { - if (where) - gfc_error ("Missing alternate return spec in subroutine call " - "at %L", where); - return false; - } - /* For CLASS, the optional attribute might be set at either location. */ - if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional) - && !f->sym->attr.optional) - || (in_statement_function - && (f->sym->attr.optional - || (f->sym->ts.type == BT_CLASS - && CLASS_DATA (f->sym)->attr.optional)))) - { - if (where) - gfc_error ("Missing actual argument for argument %qs at %L", - f->sym->name, where); - return false; - } - } - - /* We should have handled the cases where the formal arglist is null - already. */ - gcc_assert (n > 0); - - /* The argument lists are compatible. We now relink a new actual - argument list with null arguments in the right places. The head - of the list remains the head. */ - for (f = formal, i = 0; f; f = f->next, i++) - if (new_arg[i] == NULL) - { - new_arg[i] = gfc_get_actual_arglist (); - new_arg[i]->associated_dummy = get_nonintrinsic_dummy_arg (f); - } - - if (na != 0) - { - std::swap (*new_arg[0], *actual); - std::swap (new_arg[0], new_arg[na]); - } - - for (i = 0; i < n - 1; i++) - new_arg[i]->next = new_arg[i + 1]; - - new_arg[i]->next = NULL; - - if (*ap == NULL && n > 0) - *ap = new_arg[0]; - - return true; -} - - -typedef struct -{ - gfc_formal_arglist *f; - gfc_actual_arglist *a; -} -argpair; - -/* qsort comparison function for argument pairs, with the following - order: - - p->a->expr == NULL - - p->a->expr->expr_type != EXPR_VARIABLE - - by gfc_symbol pointer value (larger first). */ - -static int -pair_cmp (const void *p1, const void *p2) -{ - const gfc_actual_arglist *a1, *a2; - - /* *p1 and *p2 are elements of the to-be-sorted array. */ - a1 = ((const argpair *) p1)->a; - a2 = ((const argpair *) p2)->a; - if (!a1->expr) - { - if (!a2->expr) - return 0; - return -1; - } - if (!a2->expr) - return 1; - if (a1->expr->expr_type != EXPR_VARIABLE) - { - if (a2->expr->expr_type != EXPR_VARIABLE) - return 0; - return -1; - } - if (a2->expr->expr_type != EXPR_VARIABLE) - return 1; - if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym) - return -1; - return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym; -} - - -/* Given two expressions from some actual arguments, test whether they - refer to the same expression. The analysis is conservative. - Returning false will produce no warning. */ - -static bool -compare_actual_expr (gfc_expr *e1, gfc_expr *e2) -{ - const gfc_ref *r1, *r2; - - if (!e1 || !e2 - || e1->expr_type != EXPR_VARIABLE - || e2->expr_type != EXPR_VARIABLE - || e1->symtree->n.sym != e2->symtree->n.sym) - return false; - - /* TODO: improve comparison, see expr.c:show_ref(). */ - for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next) - { - if (r1->type != r2->type) - return false; - switch (r1->type) - { - case REF_ARRAY: - if (r1->u.ar.type != r2->u.ar.type) - return false; - /* TODO: At the moment, consider only full arrays; - we could do better. */ - if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL) - return false; - break; - - case REF_COMPONENT: - if (r1->u.c.component != r2->u.c.component) - return false; - break; - - case REF_SUBSTRING: - return false; - - case REF_INQUIRY: - if (e1->symtree->n.sym->ts.type == BT_COMPLEX - && e1->ts.type == BT_REAL && e2->ts.type == BT_REAL - && r1->u.i != r2->u.i) - return false; - break; - - default: - gfc_internal_error ("compare_actual_expr(): Bad component code"); - } - } - if (!r1 && !r2) - return true; - return false; -} - - -/* Given formal and actual argument lists that correspond to one - another, check that identical actual arguments aren't not - associated with some incompatible INTENTs. */ - -static bool -check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) -{ - sym_intent f1_intent, f2_intent; - gfc_formal_arglist *f1; - gfc_actual_arglist *a1; - size_t n, i, j; - argpair *p; - bool t = true; - - n = 0; - for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next) - { - if (f1 == NULL && a1 == NULL) - break; - if (f1 == NULL || a1 == NULL) - gfc_internal_error ("check_some_aliasing(): List mismatch"); - n++; - } - if (n == 0) - return t; - p = XALLOCAVEC (argpair, n); - - for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next) - { - p[i].f = f1; - p[i].a = a1; - } - - qsort (p, n, sizeof (argpair), pair_cmp); - - for (i = 0; i < n; i++) - { - if (!p[i].a->expr - || p[i].a->expr->expr_type != EXPR_VARIABLE - || p[i].a->expr->ts.type == BT_PROCEDURE) - continue; - f1_intent = p[i].f->sym->attr.intent; - for (j = i + 1; j < n; j++) - { - /* Expected order after the sort. */ - if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE) - gfc_internal_error ("check_some_aliasing(): corrupted data"); - - /* Are the expression the same? */ - if (!compare_actual_expr (p[i].a->expr, p[j].a->expr)) - break; - f2_intent = p[j].f->sym->attr.intent; - if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT) - || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN) - || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT)) - { - gfc_warning (0, "Same actual argument associated with INTENT(%s) " - "argument %qs and INTENT(%s) argument %qs at %L", - gfc_intent_string (f1_intent), p[i].f->sym->name, - gfc_intent_string (f2_intent), p[j].f->sym->name, - &p[i].a->expr->where); - t = false; - } - } - } - - return t; -} - - -/* Given formal and actual argument lists that correspond to one - another, check that they are compatible in the sense that intents - are not mismatched. */ - -static bool -check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) -{ - sym_intent f_intent; - - for (;; f = f->next, a = a->next) - { - gfc_expr *expr; - - if (f == NULL && a == NULL) - break; - if (f == NULL || a == NULL) - gfc_internal_error ("check_intents(): List mismatch"); - - if (a->expr && a->expr->expr_type == EXPR_FUNCTION - && a->expr->value.function.isym - && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET) - expr = a->expr->value.function.actual->expr; - else - expr = a->expr; - - if (expr == NULL || expr->expr_type != EXPR_VARIABLE) - continue; - - f_intent = f->sym->attr.intent; - - if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym)) - { - if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok - && CLASS_DATA (f->sym)->attr.class_pointer) - || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) - { - gfc_error ("Procedure argument at %L is local to a PURE " - "procedure and has the POINTER attribute", - &expr->where); - return false; - } - } - - /* Fortran 2008, C1283. */ - if (gfc_pure (NULL) && gfc_is_coindexed (expr)) - { - if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) - { - gfc_error ("Coindexed actual argument at %L in PURE procedure " - "is passed to an INTENT(%s) argument", - &expr->where, gfc_intent_string (f_intent)); - return false; - } - - if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok - && CLASS_DATA (f->sym)->attr.class_pointer) - || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) - { - gfc_error ("Coindexed actual argument at %L in PURE procedure " - "is passed to a POINTER dummy argument", - &expr->where); - return false; - } - } - - /* F2008, Section 12.5.2.4. */ - if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS - && gfc_is_coindexed (expr)) - { - gfc_error ("Coindexed polymorphic actual argument at %L is passed " - "polymorphic dummy argument %qs", - &expr->where, f->sym->name); - return false; - } - } - - return true; -} - - -/* Check how a procedure is used against its interface. If all goes - well, the actual argument list will also end up being properly - sorted. */ - -bool -gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) -{ - gfc_actual_arglist *a; - gfc_formal_arglist *dummy_args; - bool implicit = false; - - /* Warn about calls with an implicit interface. Special case - for calling a ISO_C_BINDING because c_loc and c_funloc - are pseudo-unknown. Additionally, warn about procedures not - explicitly declared at all if requested. */ - if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) - { - bool has_implicit_none_export = false; - implicit = true; - if (sym->attr.proc == PROC_UNKNOWN) - for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent) - if (ns->has_implicit_none_export) - { - has_implicit_none_export = true; - break; - } - if (has_implicit_none_export) - { - const char *guessed - = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); - if (guessed) - gfc_error ("Procedure %qs called at %L is not explicitly declared" - "; did you mean %qs?", - sym->name, where, guessed); - else - gfc_error ("Procedure %qs called at %L is not explicitly declared", - sym->name, where); - return false; - } - if (warn_implicit_interface) - gfc_warning (OPT_Wimplicit_interface, - "Procedure %qs called with an implicit interface at %L", - sym->name, where); - else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN) - gfc_warning (OPT_Wimplicit_procedure, - "Procedure %qs called at %L is not explicitly declared", - sym->name, where); - gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1; - } - - if (sym->attr.if_source == IFSRC_UNKNOWN) - { - if (sym->attr.pointer) - { - gfc_error ("The pointer object %qs at %L must have an explicit " - "function interface or be declared as array", - sym->name, where); - return false; - } - - if (sym->attr.allocatable && !sym->attr.external) - { - gfc_error ("The allocatable object %qs at %L must have an explicit " - "function interface or be declared as array", - sym->name, where); - return false; - } - - if (sym->attr.allocatable) - { - gfc_error ("Allocatable function %qs at %L must have an explicit " - "function interface", sym->name, where); - return false; - } - - for (a = *ap; a; a = a->next) - { - if (a->expr && a->expr->error) - return false; - - /* F2018, 15.4.2.2 Explicit interface is required for a - polymorphic dummy argument, so there is no way to - legally have a class appear in an argument with an - implicit interface. */ - - if (implicit && a->expr && a->expr->ts.type == BT_CLASS) - { - gfc_error ("Explicit interface required for polymorphic " - "argument at %L",&a->expr->where); - a->expr->error = 1; - break; - } - - /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ - if (a->name != NULL && a->name[0] != '%') - { - gfc_error ("Keyword argument requires explicit interface " - "for procedure %qs at %L", sym->name, &a->expr->where); - break; - } - - /* TS 29113, 6.2. */ - if (a->expr && a->expr->ts.type == BT_ASSUMED - && sym->intmod_sym_id != ISOCBINDING_LOC) - { - gfc_error ("Assumed-type argument %s at %L requires an explicit " - "interface", a->expr->symtree->n.sym->name, - &a->expr->where); - a->expr->error = 1; - break; - } - - /* F2008, C1303 and C1304. */ - if (a->expr - && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) - && a->expr->ts.u.derived - && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) - || gfc_expr_attr (a->expr).lock_comp)) - { - gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " - "component at %L requires an explicit interface for " - "procedure %qs", &a->expr->where, sym->name); - a->expr->error = 1; - break; - } - - if (a->expr - && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) - && a->expr->ts.u.derived - && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && a->expr->ts.u.derived->intmod_sym_id - == ISOFORTRAN_EVENT_TYPE) - || gfc_expr_attr (a->expr).event_comp)) - { - gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE " - "component at %L requires an explicit interface for " - "procedure %qs", &a->expr->where, sym->name); - a->expr->error = 1; - break; - } - - if (a->expr && a->expr->expr_type == EXPR_NULL - && a->expr->ts.type == BT_UNKNOWN) - { - gfc_error ("MOLD argument to NULL required at %L", - &a->expr->where); - a->expr->error = 1; - return false; - } - - /* TS 29113, C407b. */ - if (a->expr && a->expr->expr_type == EXPR_VARIABLE - && symbol_rank (a->expr->symtree->n.sym) == -1) - { - gfc_error ("Assumed-rank argument requires an explicit interface " - "at %L", &a->expr->where); - a->expr->error = 1; - return false; - } - } - - return true; - } - - dummy_args = gfc_sym_get_dummy_args (sym); - - /* For a statement function, check that types and type parameters of actual - arguments and dummy arguments match. */ - if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, - sym->attr.proc == PROC_ST_FUNCTION, where)) - return false; - - if (!check_intents (dummy_args, *ap)) - return false; - - if (warn_aliasing) - check_some_aliasing (dummy_args, *ap); - - return true; -} - - -/* Check how a procedure pointer component is used against its interface. - If all goes well, the actual argument list will also end up being properly - sorted. Completely analogous to gfc_procedure_use. */ - -void -gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) -{ - /* Warn about calls with an implicit interface. Special case - for calling a ISO_C_BINDING because c_loc and c_funloc - are pseudo-unknown. */ - if (warn_implicit_interface - && comp->attr.if_source == IFSRC_UNKNOWN - && !comp->attr.is_iso_c) - gfc_warning (OPT_Wimplicit_interface, - "Procedure pointer component %qs called with an implicit " - "interface at %L", comp->name, where); - - if (comp->attr.if_source == IFSRC_UNKNOWN) - { - gfc_actual_arglist *a; - for (a = *ap; a; a = a->next) - { - /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ - if (a->name != NULL && a->name[0] != '%') - { - gfc_error ("Keyword argument requires explicit interface " - "for procedure pointer component %qs at %L", - comp->name, &a->expr->where); - break; - } - } - - return; - } - - if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0, - comp->attr.elemental, false, where)) - return; - - check_intents (comp->ts.interface->formal, *ap); - if (warn_aliasing) - check_some_aliasing (comp->ts.interface->formal, *ap); -} - - -/* Try if an actual argument list matches the formal list of a symbol, - respecting the symbol's attributes like ELEMENTAL. This is used for - GENERIC resolution. */ - -bool -gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) -{ - gfc_formal_arglist *dummy_args; - bool r; - - if (sym->attr.flavor != FL_PROCEDURE) - return false; - - dummy_args = gfc_sym_get_dummy_args (sym); - - r = !sym->attr.elemental; - if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL)) - { - check_intents (dummy_args, *args); - if (warn_aliasing) - check_some_aliasing (dummy_args, *args); - return true; - } - - return false; -} - - -/* Given an interface pointer and an actual argument list, search for - a formal argument list that matches the actual. If found, returns - a pointer to the symbol of the correct interface. Returns NULL if - not found. */ - -gfc_symbol * -gfc_search_interface (gfc_interface *intr, int sub_flag, - gfc_actual_arglist **ap) -{ - gfc_symbol *elem_sym = NULL; - gfc_symbol *null_sym = NULL; - locus null_expr_loc; - gfc_actual_arglist *a; - bool has_null_arg = false; - - for (a = *ap; a; a = a->next) - if (a->expr && a->expr->expr_type == EXPR_NULL - && a->expr->ts.type == BT_UNKNOWN) - { - has_null_arg = true; - null_expr_loc = a->expr->where; - break; - } - - for (; intr; intr = intr->next) - { - if (gfc_fl_struct (intr->sym->attr.flavor)) - continue; - if (sub_flag && intr->sym->attr.function) - continue; - if (!sub_flag && intr->sym->attr.subroutine) - continue; - - if (gfc_arglist_matches_symbol (ap, intr->sym)) - { - if (has_null_arg && null_sym) - { - gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity " - "between specific functions %s and %s", - &null_expr_loc, null_sym->name, intr->sym->name); - return NULL; - } - else if (has_null_arg) - { - null_sym = intr->sym; - continue; - } - - /* Satisfy 12.4.4.1 such that an elemental match has lower - weight than a non-elemental match. */ - if (intr->sym->attr.elemental) - { - elem_sym = intr->sym; - continue; - } - return intr->sym; - } - } - - if (null_sym) - return null_sym; - - return elem_sym ? elem_sym : NULL; -} - - -/* Do a brute force recursive search for a symbol. */ - -static gfc_symtree * -find_symtree0 (gfc_symtree *root, gfc_symbol *sym) -{ - gfc_symtree * st; - - if (root->n.sym == sym) - return root; - - st = NULL; - if (root->left) - st = find_symtree0 (root->left, sym); - if (root->right && ! st) - st = find_symtree0 (root->right, sym); - return st; -} - - -/* Find a symtree for a symbol. */ - -gfc_symtree * -gfc_find_sym_in_symtree (gfc_symbol *sym) -{ - gfc_symtree *st; - gfc_namespace *ns; - - /* First try to find it by name. */ - gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st); - if (st && st->n.sym == sym) - return st; - - /* If it's been renamed, resort to a brute-force search. */ - /* TODO: avoid having to do this search. If the symbol doesn't exist - in the symtree for the current namespace, it should probably be added. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - st = find_symtree0 (ns->sym_root, sym); - if (st) - return st; - } - gfc_internal_error ("Unable to find symbol %qs", sym->name); - /* Not reached. */ -} - - -/* See if the arglist to an operator-call contains a derived-type argument - with a matching type-bound operator. If so, return the matching specific - procedure defined as operator-target as well as the base-object to use - (which is the found derived-type argument with operator). The generic - name, if any, is transmitted to the final expression via 'gname'. */ - -static gfc_typebound_proc* -matching_typebound_op (gfc_expr** tb_base, - gfc_actual_arglist* args, - gfc_intrinsic_op op, const char* uop, - const char ** gname) -{ - gfc_actual_arglist* base; - - for (base = args; base; base = base->next) - if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS) - { - gfc_typebound_proc* tb; - gfc_symbol* derived; - bool result; - - while (base->expr->expr_type == EXPR_OP - && base->expr->value.op.op == INTRINSIC_PARENTHESES) - base->expr = base->expr->value.op.op1; - - if (base->expr->ts.type == BT_CLASS) - { - if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL - || !gfc_expr_attr (base->expr).class_ok) - continue; - derived = CLASS_DATA (base->expr)->ts.u.derived; - } - else - derived = base->expr->ts.u.derived; - - if (op == INTRINSIC_USER) - { - gfc_symtree* tb_uop; - - gcc_assert (uop); - tb_uop = gfc_find_typebound_user_op (derived, &result, uop, - false, NULL); - - if (tb_uop) - tb = tb_uop->n.tb; - else - tb = NULL; - } - else - tb = gfc_find_typebound_intrinsic_op (derived, &result, op, - false, NULL); - - /* This means we hit a PRIVATE operator which is use-associated and - should thus not be seen. */ - if (!result) - tb = NULL; - - /* Look through the super-type hierarchy for a matching specific - binding. */ - for (; tb; tb = tb->overridden) - { - gfc_tbp_generic* g; - - gcc_assert (tb->is_generic); - for (g = tb->u.generic; g; g = g->next) - { - gfc_symbol* target; - gfc_actual_arglist* argcopy; - bool matches; - - gcc_assert (g->specific); - if (g->specific->error) - continue; - - target = g->specific->u.specific->n.sym; - - /* Check if this arglist matches the formal. */ - argcopy = gfc_copy_actual_arglist (args); - matches = gfc_arglist_matches_symbol (&argcopy, target); - gfc_free_actual_arglist (argcopy); - - /* Return if we found a match. */ - if (matches) - { - *tb_base = base->expr; - *gname = g->specific_st->name; - return g->specific; - } - } - } - } - - return NULL; -} - - -/* For the 'actual arglist' of an operator call and a specific typebound - procedure that has been found the target of a type-bound operator, build the - appropriate EXPR_COMPCALL and resolve it. We take this indirection over - type-bound procedures rather than resolving type-bound operators 'directly' - so that we can reuse the existing logic. */ - -static void -build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual, - gfc_expr* base, gfc_typebound_proc* target, - const char *gname) -{ - e->expr_type = EXPR_COMPCALL; - e->value.compcall.tbp = target; - e->value.compcall.name = gname ? gname : "$op"; - e->value.compcall.actual = actual; - e->value.compcall.base_object = base; - e->value.compcall.ignore_pass = 1; - e->value.compcall.assign = 0; - if (e->ts.type == BT_UNKNOWN - && target->function) - { - if (target->is_generic) - e->ts = target->u.generic->specific->u.specific->n.sym->ts; - else - e->ts = target->u.specific->n.sym->ts; - } -} - - -/* This subroutine is called when an expression is being resolved. - The expression node in question is either a user defined operator - or an intrinsic operator with arguments that aren't compatible - with the operator. This subroutine builds an actual argument list - corresponding to the operands, then searches for a compatible - interface. If one is found, the expression node is replaced with - the appropriate function call. We use the 'match' enum to specify - whether a replacement has been made or not, or if an error occurred. */ - -match -gfc_extend_expr (gfc_expr *e) -{ - gfc_actual_arglist *actual; - gfc_symbol *sym; - gfc_namespace *ns; - gfc_user_op *uop; - gfc_intrinsic_op i; - const char *gname; - gfc_typebound_proc* tbo; - gfc_expr* tb_base; - - sym = NULL; - - actual = gfc_get_actual_arglist (); - actual->expr = e->value.op.op1; - - gname = NULL; - - if (e->value.op.op2 != NULL) - { - actual->next = gfc_get_actual_arglist (); - actual->next->expr = e->value.op.op2; - } - - i = fold_unary_intrinsic (e->value.op.op); - - /* See if we find a matching type-bound operator. */ - if (i == INTRINSIC_USER) - tbo = matching_typebound_op (&tb_base, actual, - i, e->value.op.uop->name, &gname); - else - switch (i) - { -#define CHECK_OS_COMPARISON(comp) \ - case INTRINSIC_##comp: \ - case INTRINSIC_##comp##_OS: \ - tbo = matching_typebound_op (&tb_base, actual, \ - INTRINSIC_##comp, NULL, &gname); \ - if (!tbo) \ - tbo = matching_typebound_op (&tb_base, actual, \ - INTRINSIC_##comp##_OS, NULL, &gname); \ - break; - CHECK_OS_COMPARISON(EQ) - CHECK_OS_COMPARISON(NE) - CHECK_OS_COMPARISON(GT) - CHECK_OS_COMPARISON(GE) - CHECK_OS_COMPARISON(LT) - CHECK_OS_COMPARISON(LE) -#undef CHECK_OS_COMPARISON - - default: - tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); - break; - } - - /* If there is a matching typebound-operator, replace the expression with - a call to it and succeed. */ - if (tbo) - { - gcc_assert (tb_base); - build_compcall_for_operator (e, actual, tb_base, tbo, gname); - - if (!gfc_resolve_expr (e)) - return MATCH_ERROR; - else - return MATCH_YES; - } - - if (i == INTRINSIC_USER) - { - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - uop = gfc_find_uop (e->value.op.uop->name, ns); - if (uop == NULL) - continue; - - sym = gfc_search_interface (uop->op, 0, &actual); - if (sym != NULL) - break; - } - } - else - { - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - /* Due to the distinction between '==' and '.eq.' and friends, one has - to check if either is defined. */ - switch (i) - { -#define CHECK_OS_COMPARISON(comp) \ - case INTRINSIC_##comp: \ - case INTRINSIC_##comp##_OS: \ - sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \ - if (!sym) \ - sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \ - break; - CHECK_OS_COMPARISON(EQ) - CHECK_OS_COMPARISON(NE) - CHECK_OS_COMPARISON(GT) - CHECK_OS_COMPARISON(GE) - CHECK_OS_COMPARISON(LT) - CHECK_OS_COMPARISON(LE) -#undef CHECK_OS_COMPARISON - - default: - sym = gfc_search_interface (ns->op[i], 0, &actual); - } - - if (sym != NULL) - break; - } - } - - /* TODO: Do an ambiguity-check and error if multiple matching interfaces are - found rather than just taking the first one and not checking further. */ - - if (sym == NULL) - { - /* Don't use gfc_free_actual_arglist(). */ - free (actual->next); - free (actual); - return MATCH_NO; - } - - /* Change the expression node to a function call. */ - e->expr_type = EXPR_FUNCTION; - e->symtree = gfc_find_sym_in_symtree (sym); - e->value.function.actual = actual; - e->value.function.esym = NULL; - e->value.function.isym = NULL; - e->value.function.name = NULL; - e->user_operator = 1; - - if (!gfc_resolve_expr (e)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* Tries to replace an assignment code node with a subroutine call to the - subroutine associated with the assignment operator. Return true if the node - was replaced. On false, no error is generated. */ - -bool -gfc_extend_assign (gfc_code *c, gfc_namespace *ns) -{ - gfc_actual_arglist *actual; - gfc_expr *lhs, *rhs, *tb_base; - gfc_symbol *sym = NULL; - const char *gname = NULL; - gfc_typebound_proc* tbo; - - lhs = c->expr1; - rhs = c->expr2; - - /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */ - if (c->op == EXEC_ASSIGN - && c->expr1->expr_type == EXPR_VARIABLE - && c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ) - return false; - - /* Don't allow an intrinsic assignment to be replaced. */ - if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS - && (rhs->rank == 0 || rhs->rank == lhs->rank) - && (lhs->ts.type == rhs->ts.type - || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts)))) - return false; - - actual = gfc_get_actual_arglist (); - actual->expr = lhs; - - actual->next = gfc_get_actual_arglist (); - actual->next->expr = rhs; - - /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ - - /* See if we find a matching type-bound assignment. */ - tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN, - NULL, &gname); - - if (tbo) - { - /* Success: Replace the expression with a type-bound call. */ - gcc_assert (tb_base); - c->expr1 = gfc_get_expr (); - build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); - c->expr1->value.compcall.assign = 1; - c->expr1->where = c->loc; - c->expr2 = NULL; - c->op = EXEC_COMPCALL; - return true; - } - - /* See if we find an 'ordinary' (non-typebound) assignment procedure. */ - for (; ns; ns = ns->parent) - { - sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual); - if (sym != NULL) - break; - } - - if (sym) - { - /* Success: Replace the assignment with the call. */ - c->op = EXEC_ASSIGN_CALL; - c->symtree = gfc_find_sym_in_symtree (sym); - c->expr1 = NULL; - c->expr2 = NULL; - c->ext.actual = actual; - return true; - } - - /* Failure: No assignment procedure found. */ - free (actual->next); - free (actual); - return false; -} - - -/* Make sure that the interface just parsed is not already present in - the given interface list. Ambiguity isn't checked yet since module - procedures can be present without interfaces. */ - -bool -gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc) -{ - gfc_interface *ip; - - for (ip = base; ip; ip = ip->next) - { - if (ip->sym == new_sym) - { - gfc_error ("Entity %qs at %L is already present in the interface", - new_sym->name, &loc); - return false; - } - } - - return true; -} - - -/* Add a symbol to the current interface. */ - -bool -gfc_add_interface (gfc_symbol *new_sym) -{ - gfc_interface **head, *intr; - gfc_namespace *ns; - gfc_symbol *sym; - - switch (current_interface.type) - { - case INTERFACE_NAMELESS: - case INTERFACE_ABSTRACT: - return true; - - case INTERFACE_INTRINSIC_OP: - for (ns = current_interface.ns; ns; ns = ns->parent) - switch (current_interface.op) - { - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, - gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], - new_sym, gfc_current_locus)) - return false; - break; - - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, - gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], - new_sym, gfc_current_locus)) - return false; - break; - - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], - new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], - new_sym, gfc_current_locus)) - return false; - break; - - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], - new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], - new_sym, gfc_current_locus)) - return false; - break; - - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], - new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], - new_sym, gfc_current_locus)) - return false; - break; - - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], - new_sym, gfc_current_locus) - || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], - new_sym, gfc_current_locus)) - return false; - break; - - default: - if (!gfc_check_new_interface (ns->op[current_interface.op], - new_sym, gfc_current_locus)) - return false; - } - - head = ¤t_interface.ns->op[current_interface.op]; - break; - - case INTERFACE_GENERIC: - case INTERFACE_DTIO: - for (ns = current_interface.ns; ns; ns = ns->parent) - { - gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); - if (sym == NULL) - continue; - - if (!gfc_check_new_interface (sym->generic, - new_sym, gfc_current_locus)) - return false; - } - - head = ¤t_interface.sym->generic; - break; - - case INTERFACE_USER_OP: - if (!gfc_check_new_interface (current_interface.uop->op, - new_sym, gfc_current_locus)) - return false; - - head = ¤t_interface.uop->op; - break; - - default: - gfc_internal_error ("gfc_add_interface(): Bad interface type"); - } - - intr = gfc_get_interface (); - intr->sym = new_sym; - intr->where = gfc_current_locus; - - intr->next = *head; - *head = intr; - - return true; -} - - -gfc_interface * -gfc_current_interface_head (void) -{ - switch (current_interface.type) - { - case INTERFACE_INTRINSIC_OP: - return current_interface.ns->op[current_interface.op]; - - case INTERFACE_GENERIC: - case INTERFACE_DTIO: - return current_interface.sym->generic; - - case INTERFACE_USER_OP: - return current_interface.uop->op; - - default: - gcc_unreachable (); - } -} - - -void -gfc_set_current_interface_head (gfc_interface *i) -{ - switch (current_interface.type) - { - case INTERFACE_INTRINSIC_OP: - current_interface.ns->op[current_interface.op] = i; - break; - - case INTERFACE_GENERIC: - case INTERFACE_DTIO: - current_interface.sym->generic = i; - break; - - case INTERFACE_USER_OP: - current_interface.uop->op = i; - break; - - default: - gcc_unreachable (); - } -} - - -/* Gets rid of a formal argument list. We do not free symbols. - Symbols are freed when a namespace is freed. */ - -void -gfc_free_formal_arglist (gfc_formal_arglist *p) -{ - gfc_formal_arglist *q; - - for (; p; p = q) - { - q = p->next; - free (p); - } -} - - -/* Check that it is ok for the type-bound procedure 'proc' to override the - procedure 'old', cf. F08:4.5.7.3. */ - -bool -gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) -{ - locus where; - gfc_symbol *proc_target, *old_target; - unsigned proc_pass_arg, old_pass_arg, argpos; - gfc_formal_arglist *proc_formal, *old_formal; - bool check_type; - char err[200]; - - /* This procedure should only be called for non-GENERIC proc. */ - gcc_assert (!proc->n.tb->is_generic); - - /* If the overwritten procedure is GENERIC, this is an error. */ - if (old->n.tb->is_generic) - { - gfc_error ("Cannot overwrite GENERIC %qs at %L", - old->name, &proc->n.tb->where); - return false; - } - - where = proc->n.tb->where; - proc_target = proc->n.tb->u.specific->n.sym; - old_target = old->n.tb->u.specific->n.sym; - - /* Check that overridden binding is not NON_OVERRIDABLE. */ - if (old->n.tb->non_overridable) - { - gfc_error ("%qs at %L overrides a procedure binding declared" - " NON_OVERRIDABLE", proc->name, &where); - return false; - } - - /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ - if (!old->n.tb->deferred && proc->n.tb->deferred) - { - gfc_error ("%qs at %L must not be DEFERRED as it overrides a" - " non-DEFERRED binding", proc->name, &where); - return false; - } - - /* If the overridden binding is PURE, the overriding must be, too. */ - if (old_target->attr.pure && !proc_target->attr.pure) - { - gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE", - proc->name, &where); - return false; - } - - /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it - is not, the overriding must not be either. */ - if (old_target->attr.elemental && !proc_target->attr.elemental) - { - gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be" - " ELEMENTAL", proc->name, &where); - return false; - } - if (!old_target->attr.elemental && proc_target->attr.elemental) - { - gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not" - " be ELEMENTAL, either", proc->name, &where); - return false; - } - - /* If the overridden binding is a SUBROUTINE, the overriding must also be a - SUBROUTINE. */ - if (old_target->attr.subroutine && !proc_target->attr.subroutine) - { - gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a" - " SUBROUTINE", proc->name, &where); - return false; - } - - /* If the overridden binding is a FUNCTION, the overriding must also be a - FUNCTION and have the same characteristics. */ - if (old_target->attr.function) - { - if (!proc_target->attr.function) - { - gfc_error ("%qs at %L overrides a FUNCTION and must also be a" - " FUNCTION", proc->name, &where); - return false; - } - - if (!gfc_check_result_characteristics (proc_target, old_target, - err, sizeof(err))) - { - gfc_error ("Result mismatch for the overriding procedure " - "%qs at %L: %s", proc->name, &where, err); - return false; - } - } - - /* If the overridden binding is PUBLIC, the overriding one must not be - PRIVATE. */ - if (old->n.tb->access == ACCESS_PUBLIC - && proc->n.tb->access == ACCESS_PRIVATE) - { - gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be" - " PRIVATE", proc->name, &where); - return false; - } - - /* Compare the formal argument lists of both procedures. This is also abused - to find the position of the passed-object dummy arguments of both - bindings as at least the overridden one might not yet be resolved and we - need those positions in the check below. */ - proc_pass_arg = old_pass_arg = 0; - if (!proc->n.tb->nopass && !proc->n.tb->pass_arg) - proc_pass_arg = 1; - if (!old->n.tb->nopass && !old->n.tb->pass_arg) - old_pass_arg = 1; - argpos = 1; - proc_formal = gfc_sym_get_dummy_args (proc_target); - old_formal = gfc_sym_get_dummy_args (old_target); - for ( ; proc_formal && old_formal; - proc_formal = proc_formal->next, old_formal = old_formal->next) - { - if (proc->n.tb->pass_arg - && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name)) - proc_pass_arg = argpos; - if (old->n.tb->pass_arg - && !strcmp (old->n.tb->pass_arg, old_formal->sym->name)) - old_pass_arg = argpos; - - /* Check that the names correspond. */ - if (strcmp (proc_formal->sym->name, old_formal->sym->name)) - { - gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as" - " to match the corresponding argument of the overridden" - " procedure", proc_formal->sym->name, proc->name, &where, - old_formal->sym->name); - return false; - } - - check_type = proc_pass_arg != argpos && old_pass_arg != argpos; - if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym, - check_type, err, sizeof(err))) - { - gfc_error_opt (0, "Argument mismatch for the overriding procedure " - "%qs at %L: %s", proc->name, &where, err); - return false; - } - - ++argpos; - } - if (proc_formal || old_formal) - { - gfc_error ("%qs at %L must have the same number of formal arguments as" - " the overridden procedure", proc->name, &where); - return false; - } - - /* If the overridden binding is NOPASS, the overriding one must also be - NOPASS. */ - if (old->n.tb->nopass && !proc->n.tb->nopass) - { - gfc_error ("%qs at %L overrides a NOPASS binding and must also be" - " NOPASS", proc->name, &where); - return false; - } - - /* If the overridden binding is PASS(x), the overriding one must also be - PASS and the passed-object dummy arguments must correspond. */ - if (!old->n.tb->nopass) - { - if (proc->n.tb->nopass) - { - gfc_error ("%qs at %L overrides a binding with PASS and must also be" - " PASS", proc->name, &where); - return false; - } - - if (proc_pass_arg != old_pass_arg) - { - gfc_error ("Passed-object dummy argument of %qs at %L must be at" - " the same position as the passed-object dummy argument of" - " the overridden procedure", proc->name, &where); - return false; - } - } - - return true; -} - - -/* The following three functions check that the formal arguments - of user defined derived type IO procedures are compliant with - the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */ - -static void -check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, - int kind, int rank, sym_intent intent) -{ - if (fsym->ts.type != type) - { - gfc_error ("DTIO dummy argument at %L must be of type %s", - &fsym->declared_at, gfc_basic_typename (type)); - return; - } - - if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED - && fsym->ts.kind != kind) - gfc_error ("DTIO dummy argument at %L must be of KIND = %d", - &fsym->declared_at, kind); - - if (!typebound - && rank == 0 - && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension) - || ((type != BT_CLASS) && fsym->attr.dimension))) - gfc_error ("DTIO dummy argument at %L must be a scalar", - &fsym->declared_at); - else if (rank == 1 - && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE)) - gfc_error ("DTIO dummy argument at %L must be an " - "ASSUMED SHAPE ARRAY", &fsym->declared_at); - - if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL) - gfc_error ("DTIO character argument at %L must have assumed length", - &fsym->declared_at); - - if (fsym->attr.intent != intent) - gfc_error ("DTIO dummy argument at %L must have INTENT %s", - &fsym->declared_at, gfc_code2string (intents, (int)intent)); - return; -} - - -static void -check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, - bool typebound, bool formatted, int code) -{ - gfc_symbol *dtio_sub, *generic_proc, *fsym; - gfc_typebound_proc *tb_io_proc, *specific_proc; - gfc_interface *intr; - gfc_formal_arglist *formal; - int arg_num; - - bool read = ((dtio_codes)code == DTIO_RF) - || ((dtio_codes)code == DTIO_RUF); - bt type; - sym_intent intent; - int kind; - - dtio_sub = NULL; - if (typebound) - { - /* Typebound DTIO binding. */ - tb_io_proc = tb_io_st->n.tb; - if (tb_io_proc == NULL) - return; - - gcc_assert (tb_io_proc->is_generic); - - specific_proc = tb_io_proc->u.generic->specific; - if (specific_proc == NULL || specific_proc->is_generic) - return; - - dtio_sub = specific_proc->u.specific->n.sym; - } - else - { - generic_proc = tb_io_st->n.sym; - if (generic_proc == NULL || generic_proc->generic == NULL) - return; - - for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next) - { - if (intr->sym && intr->sym->formal && intr->sym->formal->sym - && ((intr->sym->formal->sym->ts.type == BT_CLASS - && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived - == derived) - || (intr->sym->formal->sym->ts.type == BT_DERIVED - && intr->sym->formal->sym->ts.u.derived == derived))) - { - dtio_sub = intr->sym; - break; - } - else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym) - { - gfc_error ("Alternate return at %L is not permitted in a DTIO " - "procedure", &intr->sym->declared_at); - return; - } - } - - if (dtio_sub == NULL) - return; - } - - gcc_assert (dtio_sub); - if (!dtio_sub->attr.subroutine) - gfc_error ("DTIO procedure %qs at %L must be a subroutine", - dtio_sub->name, &dtio_sub->declared_at); - - if (!dtio_sub->resolve_symbol_called) - gfc_resolve_formal_arglist (dtio_sub); - - arg_num = 0; - for (formal = dtio_sub->formal; formal; formal = formal->next) - arg_num++; - - if (arg_num < (formatted ? 6 : 4)) - { - gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L", - dtio_sub->name, &dtio_sub->declared_at); - return; - } - - if (arg_num > (formatted ? 6 : 4)) - { - gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L", - dtio_sub->name, &dtio_sub->declared_at); - return; - } - - /* Now go through the formal arglist. */ - arg_num = 1; - for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++) - { - if (!formatted && arg_num == 3) - arg_num = 5; - fsym = formal->sym; - - if (fsym == NULL) - { - gfc_error ("Alternate return at %L is not permitted in a DTIO " - "procedure", &dtio_sub->declared_at); - return; - } - - switch (arg_num) - { - case(1): /* DTV */ - type = derived->attr.sequence || derived->attr.is_bind_c ? - BT_DERIVED : BT_CLASS; - kind = 0; - intent = read ? INTENT_INOUT : INTENT_IN; - check_dtio_arg_TKR_intent (fsym, typebound, type, kind, - 0, intent); - break; - - case(2): /* UNIT */ - type = BT_INTEGER; - kind = gfc_default_integer_kind; - intent = INTENT_IN; - check_dtio_arg_TKR_intent (fsym, typebound, type, kind, - 0, intent); - break; - case(3): /* IOTYPE */ - type = BT_CHARACTER; - kind = gfc_default_character_kind; - intent = INTENT_IN; - check_dtio_arg_TKR_intent (fsym, typebound, type, kind, - 0, intent); - break; - case(4): /* VLIST */ - type = BT_INTEGER; - kind = gfc_default_integer_kind; - intent = INTENT_IN; - check_dtio_arg_TKR_intent (fsym, typebound, type, kind, - 1, intent); - break; - case(5): /* IOSTAT */ - type = BT_INTEGER; - kind = gfc_default_integer_kind; - intent = INTENT_OUT; - check_dtio_arg_TKR_intent (fsym, typebound, type, kind, - 0, intent); - break; - case(6): /* IOMSG */ - type = BT_CHARACTER; - kind = gfc_default_character_kind; - intent = INTENT_INOUT; - check_dtio_arg_TKR_intent (fsym, typebound, type, kind, - 0, intent); - break; - default: - gcc_unreachable (); - } - } - derived->attr.has_dtio_procs = 1; - return; -} - -void -gfc_check_dtio_interfaces (gfc_symbol *derived) -{ - gfc_symtree *tb_io_st; - bool t = false; - int code; - bool formatted; - - if (derived->attr.is_class == 1 || derived->attr.vtype == 1) - return; - - /* Check typebound DTIO bindings. */ - for (code = 0; code < 4; code++) - { - formatted = ((dtio_codes)code == DTIO_RF) - || ((dtio_codes)code == DTIO_WF); - - tb_io_st = gfc_find_typebound_proc (derived, &t, - gfc_code2string (dtio_procs, code), - true, &derived->declared_at); - if (tb_io_st != NULL) - check_dtio_interface1 (derived, tb_io_st, true, formatted, code); - } - - /* Check generic DTIO interfaces. */ - for (code = 0; code < 4; code++) - { - formatted = ((dtio_codes)code == DTIO_RF) - || ((dtio_codes)code == DTIO_WF); - - tb_io_st = gfc_find_symtree (derived->ns->sym_root, - gfc_code2string (dtio_procs, code)); - if (tb_io_st != NULL) - check_dtio_interface1 (derived, tb_io_st, false, formatted, code); - } -} - - -gfc_symtree* -gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) -{ - gfc_symtree *tb_io_st = NULL; - bool t = false; - - if (!derived || !derived->resolve_symbol_called - || derived->attr.flavor != FL_DERIVED) - return NULL; - - /* Try to find a typebound DTIO binding. */ - if (formatted == true) - { - if (write == true) - tb_io_st = gfc_find_typebound_proc (derived, &t, - gfc_code2string (dtio_procs, - DTIO_WF), - true, - &derived->declared_at); - else - tb_io_st = gfc_find_typebound_proc (derived, &t, - gfc_code2string (dtio_procs, - DTIO_RF), - true, - &derived->declared_at); - } - else - { - if (write == true) - tb_io_st = gfc_find_typebound_proc (derived, &t, - gfc_code2string (dtio_procs, - DTIO_WUF), - true, - &derived->declared_at); - else - tb_io_st = gfc_find_typebound_proc (derived, &t, - gfc_code2string (dtio_procs, - DTIO_RUF), - true, - &derived->declared_at); - } - return tb_io_st; -} - - -gfc_symbol * -gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) -{ - gfc_symtree *tb_io_st = NULL; - gfc_symbol *dtio_sub = NULL; - gfc_symbol *extended; - gfc_typebound_proc *tb_io_proc, *specific_proc; - - tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted); - - if (tb_io_st != NULL) - { - const char *genname; - gfc_symtree *st; - - tb_io_proc = tb_io_st->n.tb; - gcc_assert (tb_io_proc != NULL); - gcc_assert (tb_io_proc->is_generic); - gcc_assert (tb_io_proc->u.generic->next == NULL); - - specific_proc = tb_io_proc->u.generic->specific; - gcc_assert (!specific_proc->is_generic); - - /* Go back and make sure that we have the right specific procedure. - Here we most likely have a procedure from the parent type, which - can be overridden in extensions. */ - genname = tb_io_proc->u.generic->specific_st->name; - st = gfc_find_typebound_proc (derived, NULL, genname, - true, &tb_io_proc->where); - if (st) - dtio_sub = st->n.tb->u.specific->n.sym; - else - dtio_sub = specific_proc->u.specific->n.sym; - - goto finish; - } - - /* If there is not a typebound binding, look for a generic - DTIO interface. */ - for (extended = derived; extended; - extended = gfc_get_derived_super_type (extended)) - { - if (extended == NULL || extended->ns == NULL - || extended->attr.flavor == FL_UNKNOWN) - return NULL; - - if (formatted == true) - { - if (write == true) - tb_io_st = gfc_find_symtree (extended->ns->sym_root, - gfc_code2string (dtio_procs, - DTIO_WF)); - else - tb_io_st = gfc_find_symtree (extended->ns->sym_root, - gfc_code2string (dtio_procs, - DTIO_RF)); - } - else - { - if (write == true) - tb_io_st = gfc_find_symtree (extended->ns->sym_root, - gfc_code2string (dtio_procs, - DTIO_WUF)); - else - tb_io_st = gfc_find_symtree (extended->ns->sym_root, - gfc_code2string (dtio_procs, - DTIO_RUF)); - } - - if (tb_io_st != NULL - && tb_io_st->n.sym - && tb_io_st->n.sym->generic) - { - for (gfc_interface *intr = tb_io_st->n.sym->generic; - intr && intr->sym; intr = intr->next) - { - if (intr->sym->formal) - { - gfc_symbol *fsym = intr->sym->formal->sym; - if ((fsym->ts.type == BT_CLASS - && CLASS_DATA (fsym)->ts.u.derived == extended) - || (fsym->ts.type == BT_DERIVED - && fsym->ts.u.derived == extended)) - { - dtio_sub = intr->sym; - break; - } - } - } - } - } - -finish: - if (dtio_sub - && dtio_sub->formal->sym->ts.type == BT_CLASS - && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived) - gfc_find_derived_vtab (derived); - - return dtio_sub; -} - -/* Helper function - if we do not find an interface for a procedure, - construct it from the actual arglist. Luckily, this can only - happen for call by reference, so the information we actually need - to provide (and which would be impossible to guess from the call - itself) is not actually needed. */ - -void -gfc_get_formal_from_actual_arglist (gfc_symbol *sym, - gfc_actual_arglist *actual_args) -{ - gfc_actual_arglist *a; - gfc_formal_arglist **f; - gfc_symbol *s; - char name[GFC_MAX_SYMBOL_LEN + 1]; - static int var_num; - - f = &sym->formal; - for (a = actual_args; a != NULL; a = a->next) - { - (*f) = gfc_get_formal_arglist (); - if (a->expr) - { - snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++); - gfc_get_symbol (name, gfc_current_ns, &s); - if (a->expr->ts.type == BT_PROCEDURE) - { - s->attr.flavor = FL_PROCEDURE; - } - else - { - s->ts = a->expr->ts; - - if (s->ts.type == BT_CHARACTER) - s->ts.u.cl = gfc_get_charlen (); - - s->ts.deferred = 0; - s->ts.is_iso_c = 0; - s->ts.is_c_interop = 0; - s->attr.flavor = FL_VARIABLE; - if (a->expr->rank > 0) - { - s->attr.dimension = 1; - s->as = gfc_get_array_spec (); - s->as->rank = 1; - s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, - &a->expr->where, 1); - s->as->upper[0] = NULL; - s->as->type = AS_ASSUMED_SIZE; - } - else - s->maybe_array = maybe_dummy_array_arg (a->expr); - } - s->attr.dummy = 1; - s->attr.artificial = 1; - s->declared_at = a->expr->where; - s->attr.intent = INTENT_UNKNOWN; - (*f)->sym = s; - } - else /* If a->expr is NULL, this is an alternate rerturn. */ - (*f)->sym = NULL; - - f = &((*f)->next); - } -} - - -const char * -gfc_dummy_arg_get_name (gfc_dummy_arg & dummy_arg) -{ - switch (dummy_arg.intrinsicness) - { - case GFC_INTRINSIC_DUMMY_ARG: - return dummy_arg.u.intrinsic->name; - - case GFC_NON_INTRINSIC_DUMMY_ARG: - return dummy_arg.u.non_intrinsic->sym->name; - - default: - gcc_unreachable (); - } -} - - -const gfc_typespec & -gfc_dummy_arg_get_typespec (gfc_dummy_arg & dummy_arg) -{ - switch (dummy_arg.intrinsicness) - { - case GFC_INTRINSIC_DUMMY_ARG: - return dummy_arg.u.intrinsic->ts; - - case GFC_NON_INTRINSIC_DUMMY_ARG: - return dummy_arg.u.non_intrinsic->sym->ts; - - default: - gcc_unreachable (); - } -} - - -bool -gfc_dummy_arg_is_optional (gfc_dummy_arg & dummy_arg) -{ - switch (dummy_arg.intrinsicness) - { - case GFC_INTRINSIC_DUMMY_ARG: - return dummy_arg.u.intrinsic->optional; - - case GFC_NON_INTRINSIC_DUMMY_ARG: - return dummy_arg.u.non_intrinsic->sym->attr.optional; - - default: - gcc_unreachable (); - } -} diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc new file mode 100644 index 0000000..0fd881d --- /dev/null +++ b/gcc/fortran/interface.cc @@ -0,0 +1,5589 @@ +/* Deal with interfaces. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + + +/* Deal with interfaces. An explicit interface is represented as a + singly linked list of formal argument structures attached to the + relevant symbols. For an implicit interface, the arguments don't + point to symbols. Explicit interfaces point to namespaces that + contain the symbols within that interface. + + Implicit interfaces are linked together in a singly linked list + along the next_if member of symbol nodes. Since a particular + symbol can only have a single explicit interface, the symbol cannot + be part of multiple lists and a single next-member suffices. + + This is not the case for general classes, though. An operator + definition is independent of just about all other uses and has it's + own head pointer. + + Nameless interfaces: + Nameless interfaces create symbols with explicit interfaces within + the current namespace. They are otherwise unlinked. + + Generic interfaces: + The generic name points to a linked list of symbols. Each symbol + has an explicit interface. Each explicit interface has its own + namespace containing the arguments. Module procedures are symbols in + which the interface is added later when the module procedure is parsed. + + User operators: + User-defined operators are stored in a their own set of symtrees + separate from regular symbols. The symtrees point to gfc_user_op + structures which in turn head up a list of relevant interfaces. + + Extended intrinsics and assignment: + The head of these interface lists are stored in the containing namespace. + + Implicit interfaces: + An implicit interface is represented as a singly linked list of + formal argument list structures that don't point to any symbol + nodes -- they just contain types. + + + When a subprogram is defined, the program unit's name points to an + interface as usual, but the link to the namespace is NULL and the + formal argument list points to symbols within the same namespace as + the program unit name. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "match.h" +#include "arith.h" + +/* The current_interface structure holds information about the + interface currently being parsed. This structure is saved and + restored during recursive interfaces. */ + +gfc_interface_info current_interface; + + +/* Free a singly linked list of gfc_interface structures. */ + +void +gfc_free_interface (gfc_interface *intr) +{ + gfc_interface *next; + + for (; intr; intr = next) + { + next = intr->next; + free (intr); + } +} + + +/* Change the operators unary plus and minus into binary plus and + minus respectively, leaving the rest unchanged. */ + +static gfc_intrinsic_op +fold_unary_intrinsic (gfc_intrinsic_op op) +{ + switch (op) + { + case INTRINSIC_UPLUS: + op = INTRINSIC_PLUS; + break; + case INTRINSIC_UMINUS: + op = INTRINSIC_MINUS; + break; + default: + break; + } + + return op; +} + + +/* Return the operator depending on the DTIO moded string. Note that + these are not operators in the normal sense and so have been placed + beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */ + +static gfc_intrinsic_op +dtio_op (char* mode) +{ + if (strcmp (mode, "formatted") == 0) + return INTRINSIC_FORMATTED; + if (strcmp (mode, "unformatted") == 0) + return INTRINSIC_UNFORMATTED; + return INTRINSIC_NONE; +} + + +/* Match a generic specification. Depending on which type of + interface is found, the 'name' or 'op' pointers may be set. + This subroutine doesn't return MATCH_NO. */ + +match +gfc_match_generic_spec (interface_type *type, + char *name, + gfc_intrinsic_op *op) +{ + char buffer[GFC_MAX_SYMBOL_LEN + 1]; + match m; + gfc_intrinsic_op i; + + if (gfc_match (" assignment ( = )") == MATCH_YES) + { + *type = INTERFACE_INTRINSIC_OP; + *op = INTRINSIC_ASSIGN; + return MATCH_YES; + } + + if (gfc_match (" operator ( %o )", &i) == MATCH_YES) + { /* Operator i/f */ + *type = INTERFACE_INTRINSIC_OP; + *op = fold_unary_intrinsic (i); + return MATCH_YES; + } + + *op = INTRINSIC_NONE; + if (gfc_match (" operator ( ") == MATCH_YES) + { + m = gfc_match_defined_op_name (buffer, 1); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return MATCH_ERROR; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return MATCH_ERROR; + + strcpy (name, buffer); + *type = INTERFACE_USER_OP; + return MATCH_YES; + } + + if (gfc_match (" read ( %n )", buffer) == MATCH_YES) + { + *op = dtio_op (buffer); + if (*op == INTRINSIC_FORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_RF)); + *type = INTERFACE_DTIO; + } + if (*op == INTRINSIC_UNFORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF)); + *type = INTERFACE_DTIO; + } + if (*op != INTRINSIC_NONE) + return MATCH_YES; + } + + if (gfc_match (" write ( %n )", buffer) == MATCH_YES) + { + *op = dtio_op (buffer); + if (*op == INTRINSIC_FORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_WF)); + *type = INTERFACE_DTIO; + } + if (*op == INTRINSIC_UNFORMATTED) + { + strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF)); + *type = INTERFACE_DTIO; + } + if (*op != INTRINSIC_NONE) + return MATCH_YES; + } + + if (gfc_match_name (buffer) == MATCH_YES) + { + strcpy (name, buffer); + *type = INTERFACE_GENERIC; + return MATCH_YES; + } + + *type = INTERFACE_NAMELESS; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in generic specification at %C"); + return MATCH_ERROR; +} + + +/* Match one of the five F95 forms of an interface statement. The + matcher for the abstract interface follows. */ + +match +gfc_match_interface (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + interface_type type; + gfc_symbol *sym; + gfc_intrinsic_op op; + match m; + + m = gfc_match_space (); + + if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) + return MATCH_ERROR; + + /* If we're not looking at the end of the statement now, or if this + is not a nameless interface but we did not see a space, punt. */ + if (gfc_match_eos () != MATCH_YES + || (type != INTERFACE_NAMELESS && m != MATCH_YES)) + { + gfc_error ("Syntax error: Trailing garbage in INTERFACE statement " + "at %C"); + return MATCH_ERROR; + } + + current_interface.type = type; + + switch (type) + { + case INTERFACE_DTIO: + case INTERFACE_GENERIC: + if (gfc_get_symbol (name, NULL, &sym)) + return MATCH_ERROR; + + if (!sym->attr.generic + && !gfc_add_generic (&sym->attr, sym->name, NULL)) + return MATCH_ERROR; + + if (sym->attr.dummy) + { + gfc_error ("Dummy procedure %qs at %C cannot have a " + "generic interface", sym->name); + return MATCH_ERROR; + } + + current_interface.sym = gfc_new_block = sym; + break; + + case INTERFACE_USER_OP: + current_interface.uop = gfc_get_uop (name); + break; + + case INTERFACE_INTRINSIC_OP: + current_interface.op = op; + break; + + case INTERFACE_NAMELESS: + case INTERFACE_ABSTRACT: + break; + } + + return MATCH_YES; +} + + + +/* Match a F2003 abstract interface. */ + +match +gfc_match_abstract_interface (void) +{ + match m; + + if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C")) + return MATCH_ERROR; + + m = gfc_match_eos (); + + if (m != MATCH_YES) + { + gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C"); + return MATCH_ERROR; + } + + current_interface.type = INTERFACE_ABSTRACT; + + return m; +} + + +/* Match the different sort of generic-specs that can be present after + the END INTERFACE itself. */ + +match +gfc_match_end_interface (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + interface_type type; + gfc_intrinsic_op op; + match m; + + m = gfc_match_space (); + + if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) + return MATCH_ERROR; + + /* If we're not looking at the end of the statement now, or if this + is not a nameless interface but we did not see a space, punt. */ + if (gfc_match_eos () != MATCH_YES + || (type != INTERFACE_NAMELESS && m != MATCH_YES)) + { + gfc_error ("Syntax error: Trailing garbage in END INTERFACE " + "statement at %C"); + return MATCH_ERROR; + } + + m = MATCH_YES; + + switch (current_interface.type) + { + case INTERFACE_NAMELESS: + case INTERFACE_ABSTRACT: + if (type != INTERFACE_NAMELESS) + { + gfc_error ("Expected a nameless interface at %C"); + m = MATCH_ERROR; + } + + break; + + case INTERFACE_INTRINSIC_OP: + if (type != current_interface.type || op != current_interface.op) + { + + if (current_interface.op == INTRINSIC_ASSIGN) + { + m = MATCH_ERROR; + gfc_error ("Expected % at %C"); + } + else + { + const char *s1, *s2; + s1 = gfc_op2string (current_interface.op); + s2 = gfc_op2string (op); + + /* The following if-statements are used to enforce C1202 + from F2003. */ + if ((strcmp(s1, "==") == 0 && strcmp (s2, ".eq.") == 0) + || (strcmp(s1, ".eq.") == 0 && strcmp (s2, "==") == 0)) + break; + if ((strcmp(s1, "/=") == 0 && strcmp (s2, ".ne.") == 0) + || (strcmp(s1, ".ne.") == 0 && strcmp (s2, "/=") == 0)) + break; + if ((strcmp(s1, "<=") == 0 && strcmp (s2, ".le.") == 0) + || (strcmp(s1, ".le.") == 0 && strcmp (s2, "<=") == 0)) + break; + if ((strcmp(s1, "<") == 0 && strcmp (s2, ".lt.") == 0) + || (strcmp(s1, ".lt.") == 0 && strcmp (s2, "<") == 0)) + break; + if ((strcmp(s1, ">=") == 0 && strcmp (s2, ".ge.") == 0) + || (strcmp(s1, ".ge.") == 0 && strcmp (s2, ">=") == 0)) + break; + if ((strcmp(s1, ">") == 0 && strcmp (s2, ".gt.") == 0) + || (strcmp(s1, ".gt.") == 0 && strcmp (s2, ">") == 0)) + break; + + m = MATCH_ERROR; + if (strcmp(s2, "none") == 0) + gfc_error ("Expecting % " + "at %C", s1); + else + gfc_error ("Expecting % at %C, " + "but got %qs", s1, s2); + } + + } + + break; + + case INTERFACE_USER_OP: + /* Comparing the symbol node names is OK because only use-associated + symbols can be renamed. */ + if (type != current_interface.type + || strcmp (current_interface.uop->name, name) != 0) + { + gfc_error ("Expecting % at %C", + current_interface.uop->name); + m = MATCH_ERROR; + } + + break; + + case INTERFACE_DTIO: + case INTERFACE_GENERIC: + if (type != current_interface.type + || strcmp (current_interface.sym->name, name) != 0) + { + gfc_error ("Expecting % at %C", + current_interface.sym->name); + m = MATCH_ERROR; + } + + break; + } + + return m; +} + + +/* Return whether the component was defined anonymously. */ + +static bool +is_anonymous_component (gfc_component *cmp) +{ + /* Only UNION and MAP components are anonymous. In the case of a MAP, + the derived type symbol is FL_STRUCT and the component name looks like mM*. + This is the only case in which the second character of a component name is + uppercase. */ + return cmp->ts.type == BT_UNION + || (cmp->ts.type == BT_DERIVED + && cmp->ts.u.derived->attr.flavor == FL_STRUCT + && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1])); +} + + +/* Return whether the derived type was defined anonymously. */ + +static bool +is_anonymous_dt (gfc_symbol *derived) +{ + /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE + types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT + and the type name looks like XX*. This is the only case in which the + second character of a type name is uppercase. */ + return derived->attr.flavor == FL_UNION + || (derived->attr.flavor == FL_STRUCT + && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1])); +} + + +/* Compare components according to 4.4.2 of the Fortran standard. */ + +static bool +compare_components (gfc_component *cmp1, gfc_component *cmp2, + gfc_symbol *derived1, gfc_symbol *derived2) +{ + /* Compare names, but not for anonymous components such as UNION or MAP. */ + if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2) + && strcmp (cmp1->name, cmp2->name) != 0) + return false; + + if (cmp1->attr.access != cmp2->attr.access) + return false; + + if (cmp1->attr.pointer != cmp2->attr.pointer) + return false; + + if (cmp1->attr.dimension != cmp2->attr.dimension) + return false; + + if (cmp1->attr.allocatable != cmp2->attr.allocatable) + return false; + + if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0) + return false; + + if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER) + { + gfc_charlen *l1 = cmp1->ts.u.cl; + gfc_charlen *l2 = cmp2->ts.u.cl; + if (l1 && l2 && l1->length && l2->length + && l1->length->expr_type == EXPR_CONSTANT + && l2->length->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (l1->length, l2->length) != 0) + return false; + } + + /* Make sure that link lists do not put this function into an + endless recursive loop! */ + if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) + && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived) + && !gfc_compare_types (&cmp1->ts, &cmp2->ts)) + return false; + + else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) + && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) + return false; + + else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived) + && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)) + return false; + + return true; +} + + +/* Compare two union types by comparing the components of their maps. + Because unions and maps are anonymous their types get special internal + names; therefore the usual derived type comparison will fail on them. + + Returns nonzero if equal, as with gfc_compare_derived_types. Also as with + gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate + definitions' than 'equivalent structure'. */ + +static bool +compare_union_types (gfc_symbol *un1, gfc_symbol *un2) +{ + gfc_component *map1, *map2, *cmp1, *cmp2; + gfc_symbol *map1_t, *map2_t; + + if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION) + return false; + + if (un1->attr.zero_comp != un2->attr.zero_comp) + return false; + + if (un1->attr.zero_comp) + return true; + + map1 = un1->components; + map2 = un2->components; + + /* In terms of 'equality' here we are worried about types which are + declared the same in two places, not types that represent equivalent + structures. (This is common because of FORTRAN's weird scoping rules.) + Though two unions with their maps in different orders could be equivalent, + we will say they are not equal for the purposes of this test; therefore + we compare the maps sequentially. */ + for (;;) + { + map1_t = map1->ts.u.derived; + map2_t = map2->ts.u.derived; + + cmp1 = map1_t->components; + cmp2 = map2_t->components; + + /* Protect against null components. */ + if (map1_t->attr.zero_comp != map2_t->attr.zero_comp) + return false; + + if (map1_t->attr.zero_comp) + return true; + + for (;;) + { + /* No two fields will ever point to the same map type unless they are + the same component, because one map field is created with its type + declaration. Therefore don't worry about recursion here. */ + /* TODO: worry about recursion into parent types of the unions? */ + if (!compare_components (cmp1, cmp2, map1_t, map2_t)) + return false; + + cmp1 = cmp1->next; + cmp2 = cmp2->next; + + if (cmp1 == NULL && cmp2 == NULL) + break; + if (cmp1 == NULL || cmp2 == NULL) + return false; + } + + map1 = map1->next; + map2 = map2->next; + + if (map1 == NULL && map2 == NULL) + break; + if (map1 == NULL || map2 == NULL) + return false; + } + + return true; +} + + + +/* Compare two derived types using the criteria in 4.4.2 of the standard, + recursing through gfc_compare_types for the components. */ + +bool +gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) +{ + gfc_component *cmp1, *cmp2; + + if (derived1 == derived2) + return true; + + if (!derived1 || !derived2) + gfc_internal_error ("gfc_compare_derived_types: invalid derived type"); + + /* Compare UNION types specially. */ + if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION) + return compare_union_types (derived1, derived2); + + /* Special case for comparing derived types across namespaces. If the + true names and module names are the same and the module name is + nonnull, then they are equal. */ + if (strcmp (derived1->name, derived2->name) == 0 + && derived1->module != NULL && derived2->module != NULL + && strcmp (derived1->module, derived2->module) == 0) + return true; + + /* Compare type via the rules of the standard. Both types must have + the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special + because they can be anonymous; therefore two structures with different + names may be equal. */ + + /* Compare names, but not for anonymous types such as UNION or MAP. */ + if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2) + && strcmp (derived1->name, derived2->name) != 0) + return false; + + if (derived1->component_access == ACCESS_PRIVATE + || derived2->component_access == ACCESS_PRIVATE) + return false; + + if (!(derived1->attr.sequence && derived2->attr.sequence) + && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c) + && !(derived1->attr.pdt_type && derived2->attr.pdt_type)) + return false; + + /* Protect against null components. */ + if (derived1->attr.zero_comp != derived2->attr.zero_comp) + return false; + + if (derived1->attr.zero_comp) + return true; + + cmp1 = derived1->components; + cmp2 = derived2->components; + + /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a + simple test can speed things up. Otherwise, lots of things have to + match. */ + for (;;) + { + if (!compare_components (cmp1, cmp2, derived1, derived2)) + return false; + + cmp1 = cmp1->next; + cmp2 = cmp2->next; + + if (cmp1 == NULL && cmp2 == NULL) + break; + if (cmp1 == NULL || cmp2 == NULL) + return false; + } + + return true; +} + + +/* Compare two typespecs, recursively if necessary. */ + +bool +gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) +{ + /* See if one of the typespecs is a BT_VOID, which is what is being used + to allow the funcs like c_f_pointer to accept any pointer type. + TODO: Possibly should narrow this to just the one typespec coming in + that is for the formal arg, but oh well. */ + if (ts1->type == BT_VOID || ts2->type == BT_VOID) + return true; + + /* Special case for our C interop types. FIXME: There should be a + better way of doing this. When ISO C binding is cleared up, + this can probably be removed. See PR 57048. */ + + if (((ts1->type == BT_INTEGER && ts2->type == BT_DERIVED) + || (ts1->type == BT_DERIVED && ts2->type == BT_INTEGER)) + && ts1->u.derived && ts2->u.derived + && ts1->u.derived == ts2->u.derived) + return true; + + /* The _data component is not always present, therefore check for its + presence before assuming, that its derived->attr is available. + When the _data component is not present, then nevertheless the + unlimited_polymorphic flag may be set in the derived type's attr. */ + if (ts1->type == BT_CLASS && ts1->u.derived->components + && ((ts1->u.derived->attr.is_class + && ts1->u.derived->components->ts.u.derived->attr + .unlimited_polymorphic) + || ts1->u.derived->attr.unlimited_polymorphic)) + return true; + + /* F2003: C717 */ + if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED + && ts2->u.derived->components + && ((ts2->u.derived->attr.is_class + && ts2->u.derived->components->ts.u.derived->attr + .unlimited_polymorphic) + || ts2->u.derived->attr.unlimited_polymorphic) + && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c)) + return true; + + if (ts1->type != ts2->type + && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS) + || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS))) + return false; + + if (ts1->type == BT_UNION) + return compare_union_types (ts1->u.derived, ts2->u.derived); + + if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) + return (ts1->kind == ts2->kind); + + /* Compare derived types. */ + return gfc_type_compatible (ts1, ts2); +} + + +static bool +compare_type (gfc_symbol *s1, gfc_symbol *s2) +{ + if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + return true; + + return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED; +} + + +static bool +compare_type_characteristics (gfc_symbol *s1, gfc_symbol *s2) +{ + /* TYPE and CLASS of the same declared type are type compatible, + but have different characteristics. */ + if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED) + || (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS)) + return false; + + return compare_type (s1, s2); +} + + +static bool +compare_rank (gfc_symbol *s1, gfc_symbol *s2) +{ + gfc_array_spec *as1, *as2; + int r1, r2; + + if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + return true; + + as1 = (s1->ts.type == BT_CLASS + && !s1->ts.u.derived->attr.unlimited_polymorphic) + ? CLASS_DATA (s1)->as : s1->as; + as2 = (s2->ts.type == BT_CLASS + && !s2->ts.u.derived->attr.unlimited_polymorphic) + ? CLASS_DATA (s2)->as : s2->as; + + r1 = as1 ? as1->rank : 0; + r2 = as2 ? as2->rank : 0; + + if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK)) + return false; /* Ranks differ. */ + + return true; +} + + +/* Given two symbols that are formal arguments, compare their ranks + and types. Returns true if they have the same rank and type, + false otherwise. */ + +static bool +compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) +{ + return compare_type (s1, s2) && compare_rank (s1, s2); +} + + +/* Given two symbols that are formal arguments, compare their types + and rank and their formal interfaces if they are both dummy + procedures. Returns true if the same, false if different. */ + +static bool +compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2) +{ + if (s1 == NULL || s2 == NULL) + return (s1 == s2); + + if (s1 == s2) + return true; + + if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE) + return compare_type_rank (s1, s2); + + if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE) + return false; + + /* At this point, both symbols are procedures. It can happen that + external procedures are compared, where one is identified by usage + to be a function or subroutine but the other is not. Check TKR + nonetheless for these cases. */ + if (s1->attr.function == 0 && s1->attr.subroutine == 0) + return s1->attr.external ? compare_type_rank (s1, s2) : false; + + if (s2->attr.function == 0 && s2->attr.subroutine == 0) + return s2->attr.external ? compare_type_rank (s1, s2) : false; + + /* Now the type of procedure has been identified. */ + if (s1->attr.function != s2->attr.function + || s1->attr.subroutine != s2->attr.subroutine) + return false; + + if (s1->attr.function && !compare_type_rank (s1, s2)) + return false; + + /* Originally, gfortran recursed here to check the interfaces of passed + procedures. This is explicitly not required by the standard. */ + return true; +} + + +/* Given a formal argument list and a keyword name, search the list + for that keyword. Returns the correct symbol node if found, NULL + if not found. */ + +static gfc_symbol * +find_keyword_arg (const char *name, gfc_formal_arglist *f) +{ + for (; f; f = f->next) + if (strcmp (f->sym->name, name) == 0) + return f->sym; + + return NULL; +} + + +/******** Interface checking subroutines **********/ + + +/* Given an operator interface and the operator, make sure that all + interfaces for that operator are legal. */ + +bool +gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op, + locus opwhere) +{ + gfc_formal_arglist *formal; + sym_intent i1, i2; + bt t1, t2; + int args, r1, r2, k1, k2; + + gcc_assert (sym); + + args = 0; + t1 = t2 = BT_UNKNOWN; + i1 = i2 = INTENT_UNKNOWN; + r1 = r2 = -1; + k1 = k2 = -1; + + for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next) + { + gfc_symbol *fsym = formal->sym; + if (fsym == NULL) + { + gfc_error ("Alternate return cannot appear in operator " + "interface at %L", &sym->declared_at); + return false; + } + if (args == 0) + { + t1 = fsym->ts.type; + i1 = fsym->attr.intent; + r1 = (fsym->as != NULL) ? fsym->as->rank : 0; + k1 = fsym->ts.kind; + } + if (args == 1) + { + t2 = fsym->ts.type; + i2 = fsym->attr.intent; + r2 = (fsym->as != NULL) ? fsym->as->rank : 0; + k2 = fsym->ts.kind; + } + args++; + } + + /* Only +, - and .not. can be unary operators. + .not. cannot be a binary operator. */ + if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS + && op != INTRINSIC_MINUS + && op != INTRINSIC_NOT) + || (args == 2 && op == INTRINSIC_NOT)) + { + if (op == INTRINSIC_ASSIGN) + gfc_error ("Assignment operator interface at %L must have " + "two arguments", &sym->declared_at); + else + gfc_error ("Operator interface at %L has the wrong number of arguments", + &sym->declared_at); + return false; + } + + /* Check that intrinsics are mapped to functions, except + INTRINSIC_ASSIGN which should map to a subroutine. */ + if (op == INTRINSIC_ASSIGN) + { + gfc_formal_arglist *dummy_args; + + if (!sym->attr.subroutine) + { + gfc_error ("Assignment operator interface at %L must be " + "a SUBROUTINE", &sym->declared_at); + return false; + } + + /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments): + - First argument an array with different rank than second, + - First argument is a scalar and second an array, + - Types and kinds do not conform, or + - First argument is of derived type. */ + dummy_args = gfc_sym_get_dummy_args (sym); + if (dummy_args->sym->ts.type != BT_DERIVED + && dummy_args->sym->ts.type != BT_CLASS + && (r2 == 0 || r1 == r2) + && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type + || (gfc_numeric_ts (&dummy_args->sym->ts) + && gfc_numeric_ts (&dummy_args->next->sym->ts)))) + { + gfc_error ("Assignment operator interface at %L must not redefine " + "an INTRINSIC type assignment", &sym->declared_at); + return false; + } + } + else + { + if (!sym->attr.function) + { + gfc_error ("Intrinsic operator interface at %L must be a FUNCTION", + &sym->declared_at); + return false; + } + } + + /* Check intents on operator interfaces. */ + if (op == INTRINSIC_ASSIGN) + { + if (i1 != INTENT_OUT && i1 != INTENT_INOUT) + { + gfc_error ("First argument of defined assignment at %L must be " + "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at); + return false; + } + + if (i2 != INTENT_IN) + { + gfc_error ("Second argument of defined assignment at %L must be " + "INTENT(IN)", &sym->declared_at); + return false; + } + } + else + { + if (i1 != INTENT_IN) + { + gfc_error ("First argument of operator interface at %L must be " + "INTENT(IN)", &sym->declared_at); + return false; + } + + if (args == 2 && i2 != INTENT_IN) + { + gfc_error ("Second argument of operator interface at %L must be " + "INTENT(IN)", &sym->declared_at); + return false; + } + } + + /* From now on, all we have to do is check that the operator definition + doesn't conflict with an intrinsic operator. The rules for this + game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards, + as well as 12.3.2.1.1 of Fortran 2003: + + "If the operator is an intrinsic-operator (R310), the number of + function arguments shall be consistent with the intrinsic uses of + that operator, and the types, kind type parameters, or ranks of the + dummy arguments shall differ from those required for the intrinsic + operation (7.1.2)." */ + +#define IS_NUMERIC_TYPE(t) \ + ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX) + + /* Unary ops are easy, do them first. */ + if (op == INTRINSIC_NOT) + { + if (t1 == BT_LOGICAL) + goto bad_repl; + else + return true; + } + + if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS)) + { + if (IS_NUMERIC_TYPE (t1)) + goto bad_repl; + else + return true; + } + + /* Character intrinsic operators have same character kind, thus + operator definitions with operands of different character kinds + are always safe. */ + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2) + return true; + + /* Intrinsic operators always perform on arguments of same rank, + so different ranks is also always safe. (rank == 0) is an exception + to that, because all intrinsic operators are elemental. */ + if (r1 != r2 && r1 != 0 && r2 != 0) + return true; + + switch (op) + { + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) + goto bad_repl; + /* Fall through. */ + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2)) + goto bad_repl; + break; + + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) + goto bad_repl; + if ((t1 == BT_INTEGER || t1 == BT_REAL) + && (t2 == BT_INTEGER || t2 == BT_REAL)) + goto bad_repl; + break; + + case INTRINSIC_CONCAT: + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) + goto bad_repl; + break; + + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + if (t1 == BT_LOGICAL && t2 == BT_LOGICAL) + goto bad_repl; + break; + + default: + break; + } + + return true; + +#undef IS_NUMERIC_TYPE + +bad_repl: + gfc_error ("Operator interface at %L conflicts with intrinsic interface", + &opwhere); + return false; +} + + +/* Given a pair of formal argument lists, we see if the two lists can + be distinguished by counting the number of nonoptional arguments of + a given type/rank in f1 and seeing if there are less then that + number of those arguments in f2 (including optional arguments). + Since this test is asymmetric, it has to be called twice to make it + symmetric. Returns nonzero if the argument lists are incompatible + by this test. This subroutine implements rule 1 of section F03:16.2.3. + 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ + +static bool +count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2, + const char *p1, const char *p2) +{ + int ac1, ac2, i, j, k, n1; + gfc_formal_arglist *f; + + typedef struct + { + int flag; + gfc_symbol *sym; + } + arginfo; + + arginfo *arg; + + n1 = 0; + + for (f = f1; f; f = f->next) + n1++; + + /* Build an array of integers that gives the same integer to + arguments of the same type/rank. */ + arg = XCNEWVEC (arginfo, n1); + + f = f1; + for (i = 0; i < n1; i++, f = f->next) + { + arg[i].flag = -1; + arg[i].sym = f->sym; + } + + k = 0; + + for (i = 0; i < n1; i++) + { + if (arg[i].flag != -1) + continue; + + if (arg[i].sym && (arg[i].sym->attr.optional + || (p1 && strcmp (arg[i].sym->name, p1) == 0))) + continue; /* Skip OPTIONAL and PASS arguments. */ + + arg[i].flag = k; + + /* Find other non-optional, non-pass arguments of the same type/rank. */ + for (j = i + 1; j < n1; j++) + if ((arg[j].sym == NULL + || !(arg[j].sym->attr.optional + || (p1 && strcmp (arg[j].sym->name, p1) == 0))) + && (compare_type_rank_if (arg[i].sym, arg[j].sym) + || compare_type_rank_if (arg[j].sym, arg[i].sym))) + arg[j].flag = k; + + k++; + } + + /* Now loop over each distinct type found in f1. */ + k = 0; + bool rc = false; + + for (i = 0; i < n1; i++) + { + if (arg[i].flag != k) + continue; + + ac1 = 1; + for (j = i + 1; j < n1; j++) + if (arg[j].flag == k) + ac1++; + + /* Count the number of non-pass arguments in f2 with that type, + including those that are optional. */ + ac2 = 0; + + for (f = f2; f; f = f->next) + if ((!p2 || strcmp (f->sym->name, p2) != 0) + && (compare_type_rank_if (arg[i].sym, f->sym) + || compare_type_rank_if (f->sym, arg[i].sym))) + ac2++; + + if (ac1 > ac2) + { + rc = true; + break; + } + + k++; + } + + free (arg); + + return rc; +} + + +/* Returns true if two dummy arguments are distinguishable due to their POINTER + and ALLOCATABLE attributes according to F2018 section 15.4.3.4.5 (3). + The function is asymmetric wrt to the arguments s1 and s2 and should always + be called twice (with flipped arguments in the second call). */ + +static bool +compare_ptr_alloc(gfc_symbol *s1, gfc_symbol *s2) +{ + /* Is s1 allocatable? */ + const bool a1 = s1->ts.type == BT_CLASS ? + CLASS_DATA(s1)->attr.allocatable : s1->attr.allocatable; + /* Is s2 a pointer? */ + const bool p2 = s2->ts.type == BT_CLASS ? + CLASS_DATA(s2)->attr.class_pointer : s2->attr.pointer; + return a1 && p2 && (s2->attr.intent != INTENT_IN); +} + + +/* Perform the correspondence test in rule (3) of F08:C1215. + Returns zero if no argument is found that satisfies this rule, + nonzero otherwise. 'p1' and 'p2' are the PASS arguments of both procedures + (if applicable). + + This test is also not symmetric in f1 and f2 and must be called + twice. This test finds problems caused by sorting the actual + argument list with keywords. For example: + + INTERFACE FOO + SUBROUTINE F1(A, B) + INTEGER :: A ; REAL :: B + END SUBROUTINE F1 + + SUBROUTINE F2(B, A) + INTEGER :: A ; REAL :: B + END SUBROUTINE F1 + END INTERFACE FOO + + At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */ + +static bool +generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, + const char *p1, const char *p2) +{ + gfc_formal_arglist *f2_save, *g; + gfc_symbol *sym; + + f2_save = f2; + + while (f1) + { + if (!f1->sym || f1->sym->attr.optional) + goto next; + + if (p1 && strcmp (f1->sym->name, p1) == 0) + f1 = f1->next; + if (f2 && p2 && strcmp (f2->sym->name, p2) == 0) + f2 = f2->next; + + if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym) + || compare_type_rank (f2->sym, f1->sym)) + && !((gfc_option.allow_std & GFC_STD_F2008) + && (compare_ptr_alloc(f1->sym, f2->sym) + || compare_ptr_alloc(f2->sym, f1->sym)))) + goto next; + + /* Now search for a disambiguating keyword argument starting at + the current non-match. */ + for (g = f1; g; g = g->next) + { + if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0)) + continue; + + sym = find_keyword_arg (g->sym->name, f2_save); + if (sym == NULL || !compare_type_rank (g->sym, sym) + || ((gfc_option.allow_std & GFC_STD_F2008) + && (compare_ptr_alloc(sym, g->sym) + || compare_ptr_alloc(g->sym, sym)))) + return true; + } + + next: + if (f1 != NULL) + f1 = f1->next; + if (f2 != NULL) + f2 = f2->next; + } + + return false; +} + + +static int +symbol_rank (gfc_symbol *sym) +{ + gfc_array_spec *as = NULL; + + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + as = CLASS_DATA (sym)->as; + else + as = sym->as; + + return as ? as->rank : 0; +} + + +/* Check if the characteristics of two dummy arguments match, + cf. F08:12.3.2. */ + +bool +gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, + bool type_must_agree, char *errmsg, + int err_len) +{ + if (s1 == NULL || s2 == NULL) + return s1 == s2 ? true : false; + + /* Check type and rank. */ + if (type_must_agree) + { + if (!compare_type_characteristics (s1, s2) + || !compare_type_characteristics (s2, s1)) + { + snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)", + s1->name, gfc_dummy_typename (&s1->ts), + gfc_dummy_typename (&s2->ts)); + return false; + } + if (!compare_rank (s1, s2)) + { + snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)", + s1->name, symbol_rank (s1), symbol_rank (s2)); + return false; + } + } + + /* Check INTENT. */ + if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial + && !s2->attr.artificial) + { + snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check OPTIONAL attribute. */ + if (s1->attr.optional != s2->attr.optional) + { + snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check ALLOCATABLE attribute. */ + if (s1->attr.allocatable != s2->attr.allocatable) + { + snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check POINTER attribute. */ + if (s1->attr.pointer != s2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check TARGET attribute. */ + if (s1->attr.target != s2->attr.target) + { + snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check ASYNCHRONOUS attribute. */ + if (s1->attr.asynchronous != s2->attr.asynchronous) + { + snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check CONTIGUOUS attribute. */ + if (s1->attr.contiguous != s2->attr.contiguous) + { + snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check VALUE attribute. */ + if (s1->attr.value != s2->attr.value) + { + snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check VOLATILE attribute. */ + if (s1->attr.volatile_ != s2->attr.volatile_) + { + snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check interface of dummy procedures. */ + if (s1->attr.flavor == FL_PROCEDURE) + { + char err[200]; + if (!gfc_compare_interfaces (s1, s2, s2->name, 0, 1, err, sizeof(err), + NULL, NULL)) + { + snprintf (errmsg, err_len, "Interface mismatch in dummy procedure " + "'%s': %s", s1->name, err); + return false; + } + } + + /* Check string length. */ + if (s1->ts.type == BT_CHARACTER + && s1->ts.u.cl && s1->ts.u.cl->length + && s2->ts.u.cl && s2->ts.u.cl->length) + { + int compval = gfc_dep_compare_expr (s1->ts.u.cl->length, + s2->ts.u.cl->length); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Character length mismatch " + "in argument '%s'", s1->name); + return false; + + case -2: + /* FIXME: Implement a warning for this case. + gfc_warning (0, "Possible character length mismatch in argument %qs", + s1->name);*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_dummy_characteristics: Unexpected result " + "%i of gfc_dep_compare_expr", compval); + break; + } + } + + /* Check array shape. */ + if (s1->as && s2->as) + { + int i, compval; + gfc_expr *shape1, *shape2; + + /* Sometimes the ambiguity between deferred shape and assumed shape + does not get resolved in module procedures, where the only explicit + declaration of the dummy is in the interface. */ + if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure + && s1->as->type == AS_ASSUMED_SHAPE + && s2->as->type == AS_DEFERRED) + { + s2->as->type = AS_ASSUMED_SHAPE; + for (i = 0; i < s2->as->rank; i++) + if (s1->as->lower[i] != NULL) + s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]); + } + + if (s1->as->type != s2->as->type) + { + snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", + s1->name); + return false; + } + + if (s1->as->corank != s2->as->corank) + { + snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)", + s1->name, s1->as->corank, s2->as->corank); + return false; + } + + if (s1->as->type == AS_EXPLICIT) + for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++) + { + shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]), + gfc_copy_expr (s1->as->lower[i])); + shape2 = gfc_subtract (gfc_copy_expr (s2->as->upper[i]), + gfc_copy_expr (s2->as->lower[i])); + compval = gfc_dep_compare_expr (shape1, shape2); + gfc_free_expr (shape1); + gfc_free_expr (shape2); + switch (compval) + { + case -1: + case 1: + case -3: + if (i < s1->as->rank) + snprintf (errmsg, err_len, "Shape mismatch in dimension %i of" + " argument '%s'", i + 1, s1->name); + else + snprintf (errmsg, err_len, "Shape mismatch in codimension %i " + "of argument '%s'", i - s1->as->rank + 1, s1->name); + return false; + + case -2: + /* FIXME: Implement a warning for this case. + gfc_warning (0, "Possible shape mismatch in argument %qs", + s1->name);*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_dummy_characteristics: Unexpected " + "result %i of gfc_dep_compare_expr", + compval); + break; + } + } + } + + return true; +} + + +/* Check if the characteristics of two function results match, + cf. F08:12.3.3. */ + +bool +gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, + char *errmsg, int err_len) +{ + gfc_symbol *r1, *r2; + + if (s1->ts.interface && s1->ts.interface->result) + r1 = s1->ts.interface->result; + else + r1 = s1->result ? s1->result : s1; + + if (s2->ts.interface && s2->ts.interface->result) + r2 = s2->ts.interface->result; + else + r2 = s2->result ? s2->result : s2; + + if (r1->ts.type == BT_UNKNOWN) + return true; + + /* Check type and rank. */ + if (!compare_type_characteristics (r1, r2)) + { + snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)", + gfc_typename (&r1->ts), gfc_typename (&r2->ts)); + return false; + } + if (!compare_rank (r1, r2)) + { + snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)", + symbol_rank (r1), symbol_rank (r2)); + return false; + } + + /* Check ALLOCATABLE attribute. */ + if (r1->attr.allocatable != r2->attr.allocatable) + { + snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in " + "function result"); + return false; + } + + /* Check POINTER attribute. */ + if (r1->attr.pointer != r2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER attribute mismatch in " + "function result"); + return false; + } + + /* Check CONTIGUOUS attribute. */ + if (r1->attr.contiguous != r2->attr.contiguous) + { + snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in " + "function result"); + return false; + } + + /* Check PROCEDURE POINTER attribute. */ + if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer) + { + snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in " + "function result"); + return false; + } + + /* Check string length. */ + if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl) + { + if (r1->ts.deferred != r2->ts.deferred) + { + snprintf (errmsg, err_len, "Character length mismatch " + "in function result"); + return false; + } + + if (r1->ts.u.cl->length && r2->ts.u.cl->length) + { + int compval = gfc_dep_compare_expr (r1->ts.u.cl->length, + r2->ts.u.cl->length); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Character length mismatch " + "in function result"); + return false; + + case -2: + /* FIXME: Implement a warning for this case. + snprintf (errmsg, err_len, "Possible character length mismatch " + "in function result");*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_result_characteristics (1): Unexpected " + "result %i of gfc_dep_compare_expr", compval); + break; + } + } + } + + /* Check array shape. */ + if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as) + { + int i, compval; + gfc_expr *shape1, *shape2; + + if (r1->as->type != r2->as->type) + { + snprintf (errmsg, err_len, "Shape mismatch in function result"); + return false; + } + + if (r1->as->type == AS_EXPLICIT) + for (i = 0; i < r1->as->rank + r1->as->corank; i++) + { + shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]), + gfc_copy_expr (r1->as->lower[i])); + shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]), + gfc_copy_expr (r2->as->lower[i])); + compval = gfc_dep_compare_expr (shape1, shape2); + gfc_free_expr (shape1); + gfc_free_expr (shape2); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " + "function result", i + 1); + return false; + + case -2: + /* FIXME: Implement a warning for this case. + gfc_warning (0, "Possible shape mismatch in return value");*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_result_characteristics (2): " + "Unexpected result %i of " + "gfc_dep_compare_expr", compval); + break; + } + } + } + + return true; +} + + +/* 'Compare' two formal interfaces associated with a pair of symbols. + We return true if there exists an actual argument list that + would be ambiguous between the two interfaces, zero otherwise. + 'strict_flag' specifies whether all the characteristics are + required to match, which is not the case for ambiguity checks. + 'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */ + +bool +gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, + int generic_flag, int strict_flag, + char *errmsg, int err_len, + const char *p1, const char *p2, + bool *bad_result_characteristics) +{ + gfc_formal_arglist *f1, *f2; + + gcc_assert (name2 != NULL); + + if (bad_result_characteristics) + *bad_result_characteristics = false; + + if (s1->attr.function && (s2->attr.subroutine + || (!s2->attr.function && s2->ts.type == BT_UNKNOWN + && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN))) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "'%s' is not a function", name2); + return false; + } + + if (s1->attr.subroutine && s2->attr.function) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "'%s' is not a subroutine", name2); + return false; + } + + /* Do strict checks on all characteristics + (for dummy procedures and procedure pointer assignments). */ + if (!generic_flag && strict_flag) + { + if (s1->attr.function && s2->attr.function) + { + /* If both are functions, check result characteristics. */ + if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len) + || !gfc_check_result_characteristics (s2, s1, errmsg, err_len)) + { + if (bad_result_characteristics) + *bad_result_characteristics = true; + return false; + } + } + + if (s1->attr.pure && !s2->attr.pure) + { + snprintf (errmsg, err_len, "Mismatch in PURE attribute"); + return false; + } + if (s1->attr.elemental && !s2->attr.elemental) + { + snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute"); + return false; + } + } + + if (s1->attr.if_source == IFSRC_UNKNOWN + || s2->attr.if_source == IFSRC_UNKNOWN) + return true; + + f1 = gfc_sym_get_dummy_args (s1); + f2 = gfc_sym_get_dummy_args (s2); + + /* Special case: No arguments. */ + if (f1 == NULL && f2 == NULL) + return true; + + if (generic_flag) + { + if (count_types_test (f1, f2, p1, p2) + || count_types_test (f2, f1, p2, p1)) + return false; + + /* Special case: alternate returns. If both f1->sym and f2->sym are + NULL, then the leading formal arguments are alternate returns. + The previous conditional should catch argument lists with + different number of argument. */ + if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) + return true; + + if (generic_correspondence (f1, f2, p1, p2) + || generic_correspondence (f2, f1, p2, p1)) + return false; + } + else + /* Perform the abbreviated correspondence test for operators (the + arguments cannot be optional and are always ordered correctly). + This is also done when comparing interfaces for dummy procedures and in + procedure pointer assignments. */ + + for (; f1 || f2; f1 = f1->next, f2 = f2->next) + { + /* Check existence. */ + if (f1 == NULL || f2 == NULL) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "'%s' has the wrong number of " + "arguments", name2); + return false; + } + + if (strict_flag) + { + /* Check all characteristics. */ + if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true, + errmsg, err_len)) + return false; + } + else + { + /* Operators: Only check type and rank of arguments. */ + if (!compare_type (f2->sym, f1->sym)) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "Type mismatch in argument '%s' " + "(%s/%s)", f1->sym->name, + gfc_typename (&f1->sym->ts), + gfc_typename (&f2->sym->ts)); + return false; + } + if (!compare_rank (f2->sym, f1->sym)) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "Rank mismatch in argument " + "'%s' (%i/%i)", f1->sym->name, + symbol_rank (f1->sym), symbol_rank (f2->sym)); + return false; + } + if ((gfc_option.allow_std & GFC_STD_F2008) + && (compare_ptr_alloc(f1->sym, f2->sym) + || compare_ptr_alloc(f2->sym, f1->sym))) + { + if (errmsg != NULL) + snprintf (errmsg, err_len, "Mismatching POINTER/ALLOCATABLE " + "attribute in argument '%s' ", f1->sym->name); + return false; + } + } + } + + return true; +} + + +/* Given a pointer to an interface pointer, remove duplicate + interfaces and make sure that all symbols are either functions + or subroutines, and all of the same kind. Returns true if + something goes wrong. */ + +static bool +check_interface0 (gfc_interface *p, const char *interface_name) +{ + gfc_interface *psave, *q, *qlast; + + psave = p; + for (; p; p = p->next) + { + /* Make sure all symbols in the interface have been defined as + functions or subroutines. */ + if (((!p->sym->attr.function && !p->sym->attr.subroutine) + || !p->sym->attr.if_source) + && !gfc_fl_struct (p->sym->attr.flavor)) + { + const char *guessed + = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root); + + if (p->sym->attr.external) + if (guessed) + gfc_error ("Procedure %qs in %s at %L has no explicit interface" + "; did you mean %qs?", + p->sym->name, interface_name, &p->sym->declared_at, + guessed); + else + gfc_error ("Procedure %qs in %s at %L has no explicit interface", + p->sym->name, interface_name, &p->sym->declared_at); + else + if (guessed) + gfc_error ("Procedure %qs in %s at %L is neither function nor " + "subroutine; did you mean %qs?", p->sym->name, + interface_name, &p->sym->declared_at, guessed); + else + gfc_error ("Procedure %qs in %s at %L is neither function nor " + "subroutine", p->sym->name, interface_name, + &p->sym->declared_at); + return true; + } + + /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ + if ((psave->sym->attr.function && !p->sym->attr.function + && !gfc_fl_struct (p->sym->attr.flavor)) + || (psave->sym->attr.subroutine && !p->sym->attr.subroutine)) + { + if (!gfc_fl_struct (p->sym->attr.flavor)) + gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" + " or all FUNCTIONs", interface_name, + &p->sym->declared_at); + else if (p->sym->attr.flavor == FL_DERIVED) + gfc_error ("In %s at %L procedures must be all FUNCTIONs as the " + "generic name is also the name of a derived type", + interface_name, &p->sym->declared_at); + return true; + } + + /* F2003, C1207. F2008, C1207. */ + if (p->sym->attr.proc == PROC_INTERNAL + && !gfc_notify_std (GFC_STD_F2008, "Internal procedure " + "%qs in %s at %L", p->sym->name, + interface_name, &p->sym->declared_at)) + return true; + } + p = psave; + + /* Remove duplicate interfaces in this interface list. */ + for (; p; p = p->next) + { + qlast = p; + + for (q = p->next; q;) + { + if (p->sym != q->sym) + { + qlast = q; + q = q->next; + } + else + { + /* Duplicate interface. */ + qlast->next = q->next; + free (q); + q = qlast->next; + } + } + } + + return false; +} + + +/* Check lists of interfaces to make sure that no two interfaces are + ambiguous. Duplicate interfaces (from the same symbol) are OK here. */ + +static bool +check_interface1 (gfc_interface *p, gfc_interface *q0, + int generic_flag, const char *interface_name, + bool referenced) +{ + gfc_interface *q; + for (; p; p = p->next) + for (q = q0; q; q = q->next) + { + if (p->sym == q->sym) + continue; /* Duplicates OK here. */ + + if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) + continue; + + if (!gfc_fl_struct (p->sym->attr.flavor) + && !gfc_fl_struct (q->sym->attr.flavor) + && gfc_compare_interfaces (p->sym, q->sym, q->sym->name, + generic_flag, 0, NULL, 0, NULL, NULL)) + { + if (referenced) + gfc_error ("Ambiguous interfaces in %s for %qs at %L " + "and %qs at %L", interface_name, + q->sym->name, &q->sym->declared_at, + p->sym->name, &p->sym->declared_at); + else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc) + gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L " + "and %qs at %L", interface_name, + q->sym->name, &q->sym->declared_at, + p->sym->name, &p->sym->declared_at); + else + gfc_warning (0, "Although not referenced, %qs has ambiguous " + "interfaces at %L", interface_name, &p->where); + return true; + } + } + return false; +} + + +/* Check the generic and operator interfaces of symbols to make sure + that none of the interfaces conflict. The check has to be done + after all of the symbols are actually loaded. */ + +static void +check_sym_interfaces (gfc_symbol *sym) +{ + /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */ + char interface_name[2*GFC_MAX_SYMBOL_LEN+2 + sizeof("generic interface ''")]; + gfc_interface *p; + + if (sym->ns != gfc_current_ns) + return; + + if (sym->generic != NULL) + { + size_t len = strlen (sym->name) + sizeof("generic interface ''"); + gcc_assert (len < sizeof (interface_name)); + sprintf (interface_name, "generic interface '%s'", sym->name); + if (check_interface0 (sym->generic, interface_name)) + return; + + for (p = sym->generic; p; p = p->next) + { + if (p->sym->attr.mod_proc + && !p->sym->attr.module_procedure + && (p->sym->attr.if_source != IFSRC_DECL + || p->sym->attr.procedure)) + { + gfc_error ("%qs at %L is not a module procedure", + p->sym->name, &p->where); + return; + } + } + + /* Originally, this test was applied to host interfaces too; + this is incorrect since host associated symbols, from any + source, cannot be ambiguous with local symbols. */ + check_interface1 (sym->generic, sym->generic, 1, interface_name, + sym->attr.referenced || !sym->attr.use_assoc); + } +} + + +static void +check_uop_interfaces (gfc_user_op *uop) +{ + char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")]; + gfc_user_op *uop2; + gfc_namespace *ns; + + sprintf (interface_name, "operator interface '%s'", uop->name); + if (check_interface0 (uop->op, interface_name)) + return; + + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + uop2 = gfc_find_uop (uop->name, ns); + if (uop2 == NULL) + continue; + + check_interface1 (uop->op, uop2->op, 0, + interface_name, true); + } +} + +/* Given an intrinsic op, return an equivalent op if one exists, + or INTRINSIC_NONE otherwise. */ + +gfc_intrinsic_op +gfc_equivalent_op (gfc_intrinsic_op op) +{ + switch(op) + { + case INTRINSIC_EQ: + return INTRINSIC_EQ_OS; + + case INTRINSIC_EQ_OS: + return INTRINSIC_EQ; + + case INTRINSIC_NE: + return INTRINSIC_NE_OS; + + case INTRINSIC_NE_OS: + return INTRINSIC_NE; + + case INTRINSIC_GT: + return INTRINSIC_GT_OS; + + case INTRINSIC_GT_OS: + return INTRINSIC_GT; + + case INTRINSIC_GE: + return INTRINSIC_GE_OS; + + case INTRINSIC_GE_OS: + return INTRINSIC_GE; + + case INTRINSIC_LT: + return INTRINSIC_LT_OS; + + case INTRINSIC_LT_OS: + return INTRINSIC_LT; + + case INTRINSIC_LE: + return INTRINSIC_LE_OS; + + case INTRINSIC_LE_OS: + return INTRINSIC_LE; + + default: + return INTRINSIC_NONE; + } +} + +/* For the namespace, check generic, user operator and intrinsic + operator interfaces for consistency and to remove duplicate + interfaces. We traverse the whole namespace, counting on the fact + that most symbols will not have generic or operator interfaces. */ + +void +gfc_check_interfaces (gfc_namespace *ns) +{ + gfc_namespace *old_ns, *ns2; + char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")]; + int i; + + old_ns = gfc_current_ns; + gfc_current_ns = ns; + + gfc_traverse_ns (ns, check_sym_interfaces); + + gfc_traverse_user_op (ns, check_uop_interfaces); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + if (i == INTRINSIC_USER) + continue; + + if (i == INTRINSIC_ASSIGN) + strcpy (interface_name, "intrinsic assignment operator"); + else + sprintf (interface_name, "intrinsic '%s' operator", + gfc_op2string ((gfc_intrinsic_op) i)); + + if (check_interface0 (ns->op[i], interface_name)) + continue; + + if (ns->op[i]) + gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i, + ns->op[i]->where); + + for (ns2 = ns; ns2; ns2 = ns2->parent) + { + gfc_intrinsic_op other_op; + + if (check_interface1 (ns->op[i], ns2->op[i], 0, + interface_name, true)) + goto done; + + /* i should be gfc_intrinsic_op, but has to be int with this cast + here for stupid C++ compatibility rules. */ + other_op = gfc_equivalent_op ((gfc_intrinsic_op) i); + if (other_op != INTRINSIC_NONE + && check_interface1 (ns->op[i], ns2->op[other_op], + 0, interface_name, true)) + goto done; + } + } + +done: + gfc_current_ns = old_ns; +} + + +/* Given a symbol of a formal argument list and an expression, if the + formal argument is allocatable, check that the actual argument is + allocatable. Returns true if compatible, zero if not compatible. */ + +static bool +compare_allocatable (gfc_symbol *formal, gfc_expr *actual) +{ + if (formal->attr.allocatable + || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable)) + { + symbol_attribute attr = gfc_expr_attr (actual); + if (actual->ts.type == BT_CLASS && !attr.class_ok) + return true; + else if (!attr.allocatable) + return false; + } + + return true; +} + + +/* Given a symbol of a formal argument list and an expression, if the + formal argument is a pointer, see if the actual argument is a + pointer. Returns nonzero if compatible, zero if not compatible. */ + +static int +compare_pointer (gfc_symbol *formal, gfc_expr *actual) +{ + symbol_attribute attr; + + if (formal->attr.pointer + || (formal->ts.type == BT_CLASS && CLASS_DATA (formal) + && CLASS_DATA (formal)->attr.class_pointer)) + { + attr = gfc_expr_attr (actual); + + /* Fortran 2008 allows non-pointer actual arguments. */ + if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN) + return 2; + + if (!attr.pointer) + return 0; + } + + return 1; +} + + +/* Emit clear error messages for rank mismatch. */ + +static void +argument_rank_mismatch (const char *name, locus *where, + int rank1, int rank2, locus *where_formal) +{ + + /* TS 29113, C407b. */ + if (where_formal == NULL) + { + if (rank2 == -1) + gfc_error ("The assumed-rank array at %L requires that the dummy " + "argument %qs has assumed-rank", where, name); + else if (rank1 == 0) + gfc_error_opt (0, "Rank mismatch in argument %qs " + "at %L (scalar and rank-%d)", name, where, rank2); + else if (rank2 == 0) + gfc_error_opt (0, "Rank mismatch in argument %qs " + "at %L (rank-%d and scalar)", name, where, rank1); + else + gfc_error_opt (0, "Rank mismatch in argument %qs " + "at %L (rank-%d and rank-%d)", name, where, rank1, + rank2); + } + else + { + if (rank2 == -1) + /* This is an assumed rank-actual passed to a function without + an explicit interface, which is already diagnosed in + gfc_procedure_use. */ + return; + if (rank1 == 0) + gfc_error_opt (0, "Rank mismatch between actual argument at %L " + "and actual argument at %L (scalar and rank-%d)", + where, where_formal, rank2); + else if (rank2 == 0) + gfc_error_opt (0, "Rank mismatch between actual argument at %L " + "and actual argument at %L (rank-%d and scalar)", + where, where_formal, rank1); + else + gfc_error_opt (0, "Rank mismatch between actual argument at %L " + "and actual argument at %L (rank-%d and rank-%d)", where, + where_formal, rank1, rank2); + } +} + + +/* Under certain conditions, a scalar actual argument can be passed + to an array dummy argument - see F2018, 15.5.2.4, paragraph 14. + This function returns true for these conditions so that an error + or warning for this can be suppressed later. Always return false + for expressions with rank > 0. */ + +bool +maybe_dummy_array_arg (gfc_expr *e) +{ + gfc_symbol *s; + gfc_ref *ref; + bool array_pointer = false; + bool assumed_shape = false; + bool scalar_ref = true; + + if (e->rank > 0) + return false; + + if (e->ts.type == BT_CHARACTER && e->ts.kind == 1) + return true; + + /* If this comes from a constructor, it has been an array element + originally. */ + + if (e->expr_type == EXPR_CONSTANT) + return e->from_constructor; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + s = e->symtree->n.sym; + + if (s->attr.dimension) + { + scalar_ref = false; + array_pointer = s->attr.pointer; + } + + if (s->as && s->as->type == AS_ASSUMED_SHAPE) + assumed_shape = true; + + for (ref=e->ref; ref; ref=ref->next) + { + if (ref->type == REF_COMPONENT) + { + symbol_attribute *attr; + attr = &ref->u.c.component->attr; + if (attr->dimension) + { + array_pointer = attr->pointer; + assumed_shape = false; + scalar_ref = false; + } + else + scalar_ref = true; + } + } + + return !(scalar_ref || array_pointer || assumed_shape); +} + +/* Given a symbol of a formal argument list and an expression, see if + the two are compatible as arguments. Returns true if + compatible, false if not compatible. */ + +static bool +compare_parameter (gfc_symbol *formal, gfc_expr *actual, + int ranks_must_agree, int is_elemental, locus *where) +{ + gfc_ref *ref; + bool rank_check, is_pointer; + char err[200]; + gfc_component *ppc; + bool codimension = false; + + /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding + procs c_f_pointer or c_f_procpointer, and we need to accept most + pointers the user could give us. This should allow that. */ + if (formal->ts.type == BT_VOID) + return true; + + if (formal->ts.type == BT_DERIVED + && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c + && actual->ts.type == BT_DERIVED + && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) + return true; + + if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) + /* Make sure the vtab symbol is present when + the module variables are generated. */ + gfc_find_derived_vtab (actual->ts.u.derived); + + if (actual->ts.type == BT_PROCEDURE) + { + gfc_symbol *act_sym = actual->symtree->n.sym; + + if (formal->attr.flavor != FL_PROCEDURE) + { + if (where) + gfc_error ("Invalid procedure argument at %L", &actual->where); + return false; + } + + if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, + sizeof(err), NULL, NULL)) + { + if (where) + gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" + " %s", formal->name, &actual->where, err); + return false; + } + + if (formal->attr.function && !act_sym->attr.function) + { + gfc_add_function (&act_sym->attr, act_sym->name, + &act_sym->declared_at); + if (act_sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (act_sym, 1, act_sym->ns)) + return false; + } + else if (formal->attr.subroutine && !act_sym->attr.subroutine) + gfc_add_subroutine (&act_sym->attr, act_sym->name, + &act_sym->declared_at); + + return true; + } + + ppc = gfc_get_proc_ptr_comp (actual); + if (ppc && ppc->ts.interface) + { + if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1, + err, sizeof(err), NULL, NULL)) + { + if (where) + gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:" + " %s", formal->name, &actual->where, err); + return false; + } + } + + /* F2008, C1241. */ + if (formal->attr.pointer && formal->attr.contiguous + && !gfc_is_simply_contiguous (actual, true, false)) + { + if (where) + gfc_error ("Actual argument to contiguous pointer dummy %qs at %L " + "must be simply contiguous", formal->name, &actual->where); + return false; + } + + symbol_attribute actual_attr = gfc_expr_attr (actual); + if (actual->ts.type == BT_CLASS && !actual_attr.class_ok) + return true; + + if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) + && actual->ts.type != BT_HOLLERITH + && formal->ts.type != BT_ASSUMED + && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + && !gfc_compare_types (&formal->ts, &actual->ts) + && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS + && gfc_compare_derived_types (formal->ts.u.derived, + CLASS_DATA (actual)->ts.u.derived))) + { + if (where) + { + if (formal->attr.artificial) + { + if (!flag_allow_argument_mismatch || !formal->error) + gfc_error_opt (0, "Type mismatch between actual argument at %L " + "and actual argument at %L (%s/%s).", + &actual->where, + &formal->declared_at, + gfc_typename (actual), + gfc_dummy_typename (&formal->ts)); + + formal->error = 1; + } + else + gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s " + "to %s", formal->name, where, gfc_typename (actual), + gfc_dummy_typename (&formal->ts)); + } + return false; + } + + if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED) + { + if (where) + gfc_error ("Assumed-type actual argument at %L requires that dummy " + "argument %qs is of assumed type", &actual->where, + formal->name); + return false; + } + + /* TS29113 C407c; F2018 C711. */ + if (actual->ts.type == BT_ASSUMED + && symbol_rank (formal) == -1 + && actual->rank != -1 + && !(actual->symtree->n.sym->as + && actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)) + { + if (where) + gfc_error ("Assumed-type actual argument at %L corresponding to " + "assumed-rank dummy argument %qs must be " + "assumed-shape or assumed-rank", + &actual->where, formal->name); + return false; + } + + /* F2008, 12.5.2.5; IR F08/0073. */ + if (formal->ts.type == BT_CLASS && formal->attr.class_ok + && actual->expr_type != EXPR_NULL + && ((CLASS_DATA (formal)->attr.class_pointer + && formal->attr.intent != INTENT_IN) + || CLASS_DATA (formal)->attr.allocatable)) + { + if (actual->ts.type != BT_CLASS) + { + if (where) + gfc_error ("Actual argument to %qs at %L must be polymorphic", + formal->name, &actual->where); + return false; + } + + if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual)) + && !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived, + CLASS_DATA (formal)->ts.u.derived)) + { + if (where) + gfc_error ("Actual argument to %qs at %L must have the same " + "declared type", formal->name, &actual->where); + return false; + } + } + + /* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this + is necessary also for F03, so retain error for both. + NOTE: Other type/kind errors pre-empt this error. Since they are F03 + compatible, no attempt has been made to channel to this one. */ + if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual) + && (CLASS_DATA (formal)->attr.allocatable + ||CLASS_DATA (formal)->attr.class_pointer)) + { + if (where) + gfc_error ("Actual argument to %qs at %L must be unlimited " + "polymorphic since the formal argument is a " + "pointer or allocatable unlimited polymorphic " + "entity [F2008: 12.5.2.5]", formal->name, + &actual->where); + return false; + } + + if (formal->ts.type == BT_CLASS && formal->attr.class_ok) + codimension = CLASS_DATA (formal)->attr.codimension; + else + codimension = formal->attr.codimension; + + if (codimension && !gfc_is_coarray (actual)) + { + if (where) + gfc_error ("Actual argument to %qs at %L must be a coarray", + formal->name, &actual->where); + return false; + } + + if (codimension && formal->attr.allocatable) + { + gfc_ref *last = NULL; + + for (ref = actual->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + /* F2008, 12.5.2.6. */ + if ((last && last->u.c.component->as->corank != formal->as->corank) + || (!last + && actual->symtree->n.sym->as->corank != formal->as->corank)) + { + if (where) + gfc_error ("Corank mismatch in argument %qs at %L (%d and %d)", + formal->name, &actual->where, formal->as->corank, + last ? last->u.c.component->as->corank + : actual->symtree->n.sym->as->corank); + return false; + } + } + + if (codimension) + { + /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */ + /* F2018, 12.5.2.8. */ + if (formal->attr.dimension + && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) + && actual_attr.dimension + && !gfc_is_simply_contiguous (actual, true, true)) + { + if (where) + gfc_error ("Actual argument to %qs at %L must be simply " + "contiguous or an element of such an array", + formal->name, &actual->where); + return false; + } + + /* F2008, C1303 and C1304. */ + if (formal->attr.intent != INTENT_INOUT + && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) + && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + || formal->attr.lock_comp)) + + { + if (where) + gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " + "which is LOCK_TYPE or has a LOCK_TYPE component", + formal->name, &actual->where); + return false; + } + + /* TS18508, C702/C703. */ + if (formal->attr.intent != INTENT_INOUT + && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS) + && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + || formal->attr.event_comp)) + + { + if (where) + gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, " + "which is EVENT_TYPE or has a EVENT_TYPE component", + formal->name, &actual->where); + return false; + } + } + + /* F2008, C1239/C1240. */ + if (actual->expr_type == EXPR_VARIABLE + && (actual->symtree->n.sym->attr.asynchronous + || actual->symtree->n.sym->attr.volatile_) + && (formal->attr.asynchronous || formal->attr.volatile_) + && actual->rank && formal->as + && !gfc_is_simply_contiguous (actual, true, false) + && ((formal->as->type != AS_ASSUMED_SHAPE + && formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer) + || formal->attr.contiguous)) + { + if (where) + gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or " + "assumed-rank array without CONTIGUOUS attribute - as actual" + " argument at %L is not simply contiguous and both are " + "ASYNCHRONOUS or VOLATILE", formal->name, &actual->where); + return false; + } + + if (formal->attr.allocatable && !codimension + && actual_attr.codimension) + { + if (formal->attr.intent == INTENT_OUT) + { + if (where) + gfc_error ("Passing coarray at %L to allocatable, noncoarray, " + "INTENT(OUT) dummy argument %qs", &actual->where, + formal->name); + return false; + } + else if (warn_surprising && where && formal->attr.intent != INTENT_IN) + gfc_warning (OPT_Wsurprising, + "Passing coarray at %L to allocatable, noncoarray dummy " + "argument %qs, which is invalid if the allocation status" + " is modified", &actual->where, formal->name); + } + + /* If the rank is the same or the formal argument has assumed-rank. */ + if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1) + return true; + + rank_check = where != NULL && !is_elemental && formal->as + && (formal->as->type == AS_ASSUMED_SHAPE + || formal->as->type == AS_DEFERRED) + && actual->expr_type != EXPR_NULL; + + /* Skip rank checks for NO_ARG_CHECK. */ + if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + return true; + + /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ + if (rank_check || ranks_must_agree + || (formal->attr.pointer && actual->expr_type != EXPR_NULL) + || (actual->rank != 0 && !(is_elemental || formal->attr.dimension)) + || (actual->rank == 0 + && ((formal->ts.type == BT_CLASS + && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE) + || (formal->ts.type != BT_CLASS + && formal->as->type == AS_ASSUMED_SHAPE)) + && actual->expr_type != EXPR_NULL) + || (actual->rank == 0 && formal->attr.dimension + && gfc_is_coindexed (actual)) + /* Assumed-rank actual argument; F2018 C838. */ + || actual->rank == -1) + { + if (where + && (!formal->attr.artificial || (!formal->maybe_array + && !maybe_dummy_array_arg (actual)))) + { + locus *where_formal; + if (formal->attr.artificial) + where_formal = &formal->declared_at; + else + where_formal = NULL; + + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank, + where_formal); + } + return false; + } + else if (actual->rank != 0 && (is_elemental || formal->attr.dimension)) + return true; + + /* At this point, we are considering a scalar passed to an array. This + is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4), + - if the actual argument is (a substring of) an element of a + non-assumed-shape/non-pointer/non-polymorphic array; or + - (F2003) if the actual argument is of type character of default/c_char + kind. */ + + is_pointer = actual->expr_type == EXPR_VARIABLE + ? actual->symtree->n.sym->attr.pointer : false; + + for (ref = actual->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + is_pointer = ref->u.c.component->attr.pointer; + else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT + && ref->u.ar.dimen > 0 + && (!ref->next + || (ref->next->type == REF_SUBSTRING && !ref->next->next))) + break; + } + + if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL) + { + if (where) + gfc_error ("Polymorphic scalar passed to array dummy argument %qs " + "at %L", formal->name, &actual->where); + return false; + } + + if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER + && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) + { + if (where) + { + if (formal->attr.artificial) + gfc_error ("Element of assumed-shape or pointer array " + "as actual argument at %L cannot correspond to " + "actual argument at %L", + &actual->where, &formal->declared_at); + else + gfc_error ("Element of assumed-shape or pointer " + "array passed to array dummy argument %qs at %L", + formal->name, &actual->where); + } + return false; + } + + if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL + && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE)) + { + if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0) + { + if (where) + gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind " + "CHARACTER actual argument with array dummy argument " + "%qs at %L", formal->name, &actual->where); + return false; + } + + if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0) + { + gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with " + "array dummy argument %qs at %L", + formal->name, &actual->where); + return false; + } + else + return ((gfc_option.allow_std & GFC_STD_F2003) != 0); + } + + if (ref == NULL && actual->expr_type != EXPR_NULL) + { + if (where + && (!formal->attr.artificial || (!formal->maybe_array + && !maybe_dummy_array_arg (actual)))) + { + locus *where_formal; + if (formal->attr.artificial) + where_formal = &formal->declared_at; + else + where_formal = NULL; + + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank, + where_formal); + } + return false; + } + + return true; +} + + +/* Returns the storage size of a symbol (formal argument) or + zero if it cannot be determined. */ + +static unsigned long +get_sym_storage_size (gfc_symbol *sym) +{ + int i; + unsigned long strlen, elements; + + if (sym->ts.type == BT_CHARACTER) + { + if (sym->ts.u.cl && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) + strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer); + else + return 0; + } + else + strlen = 1; + + if (symbol_rank (sym) == 0) + return strlen; + + elements = 1; + if (sym->as->type != AS_EXPLICIT) + return 0; + for (i = 0; i < sym->as->rank; i++) + { + if (sym->as->upper[i]->expr_type != EXPR_CONSTANT + || sym->as->lower[i]->expr_type != EXPR_CONSTANT) + return 0; + + elements *= mpz_get_si (sym->as->upper[i]->value.integer) + - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; + } + + return strlen*elements; +} + + +/* Returns the storage size of an expression (actual argument) or + zero if it cannot be determined. For an array element, it returns + the remaining size as the element sequence consists of all storage + units of the actual argument up to the end of the array. */ + +static unsigned long +get_expr_storage_size (gfc_expr *e) +{ + int i; + long int strlen, elements; + long int substrlen = 0; + bool is_str_storage = false; + gfc_ref *ref; + + if (e == NULL) + return 0; + + if (e->ts.type == BT_CHARACTER) + { + if (e->ts.u.cl && e->ts.u.cl->length + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) + strlen = mpz_get_si (e->ts.u.cl->length->value.integer); + else if (e->expr_type == EXPR_CONSTANT + && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) + strlen = e->value.character.length; + else + return 0; + } + else + strlen = 1; /* Length per element. */ + + if (e->rank == 0 && !e->ref) + return strlen; + + elements = 1; + if (!e->ref) + { + if (!e->shape) + return 0; + for (i = 0; i < e->rank; i++) + elements *= mpz_get_si (e->shape[i]); + return elements*strlen; + } + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_SUBSTRING && ref->u.ss.start + && ref->u.ss.start->expr_type == EXPR_CONSTANT) + { + if (is_str_storage) + { + /* The string length is the substring length. + Set now to full string length. */ + if (!ref->u.ss.length || !ref->u.ss.length->length + || ref->u.ss.length->length->expr_type != EXPR_CONSTANT) + return 0; + + strlen = mpz_get_ui (ref->u.ss.length->length->value.integer); + } + substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1; + continue; + } + + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) + for (i = 0; i < ref->u.ar.dimen; i++) + { + long int start, end, stride; + stride = 1; + + if (ref->u.ar.stride[i]) + { + if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT) + stride = mpz_get_si (ref->u.ar.stride[i]->value.integer); + else + return 0; + } + + if (ref->u.ar.start[i]) + { + if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT) + start = mpz_get_si (ref->u.ar.start[i]->value.integer); + else + return 0; + } + else if (ref->u.ar.as->lower[i] + && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT) + start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer); + else + return 0; + + if (ref->u.ar.end[i]) + { + if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT) + end = mpz_get_si (ref->u.ar.end[i]->value.integer); + else + return 0; + } + else if (ref->u.ar.as->upper[i] + && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT) + end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer); + else + return 0; + + elements *= (end - start)/stride + 1L; + } + else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL) + for (i = 0; i < ref->u.ar.as->rank; i++) + { + if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i] + && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT + && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER + && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT + && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER) + elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer) + - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) + + 1L; + else + return 0; + } + else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT + && e->expr_type == EXPR_VARIABLE) + { + if (ref->u.ar.as->type == AS_ASSUMED_SHAPE + || e->symtree->n.sym->attr.pointer) + { + elements = 1; + continue; + } + + /* Determine the number of remaining elements in the element + sequence for array element designators. */ + is_str_storage = true; + for (i = ref->u.ar.dimen - 1; i >= 0; i--) + { + if (ref->u.ar.start[i] == NULL + || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT + || ref->u.ar.as->upper[i] == NULL + || ref->u.ar.as->lower[i] == NULL + || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT + || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT) + return 0; + + elements + = elements + * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer) + - mpz_get_si (ref->u.ar.as->lower[i]->value.integer) + + 1L) + - (mpz_get_si (ref->u.ar.start[i]->value.integer) + - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)); + } + } + else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function + && ref->u.c.component->attr.proc_pointer + && ref->u.c.component->attr.dimension) + { + /* Array-valued procedure-pointer components. */ + gfc_array_spec *as = ref->u.c.component->as; + for (i = 0; i < as->rank; i++) + { + if (!as->upper[i] || !as->lower[i] + || as->upper[i]->expr_type != EXPR_CONSTANT + || as->lower[i]->expr_type != EXPR_CONSTANT) + return 0; + + elements = elements + * (mpz_get_si (as->upper[i]->value.integer) + - mpz_get_si (as->lower[i]->value.integer) + 1L); + } + } + } + + if (substrlen) + return (is_str_storage) ? substrlen + (elements-1)*strlen + : elements*strlen; + else + return elements*strlen; +} + + +/* Given an expression, check whether it is an array section + which has a vector subscript. */ + +bool +gfc_has_vector_subscript (gfc_expr *e) +{ + int i; + gfc_ref *ref; + + if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) + for (i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + return true; + + return false; +} + + +static bool +is_procptr_result (gfc_expr *expr) +{ + gfc_component *c = gfc_get_proc_ptr_comp (expr); + if (c) + return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1)); + else + return ((expr->symtree->n.sym->result != expr->symtree->n.sym) + && (expr->symtree->n.sym->result->attr.proc_pointer == 1)); +} + + +/* Recursively append candidate argument ARG to CANDIDATES. Store the + number of total candidates in CANDIDATES_LEN. */ + +static void +lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg, + char **&candidates, + size_t &candidates_len) +{ + for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next) + vec_push (candidates, candidates_len, p->sym->name); +} + + +/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */ + +static const char* +lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments) +{ + char **candidates = NULL; + size_t candidates_len = 0; + lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len); + return gfc_closest_fuzzy_match (arg, candidates); +} + + +static gfc_dummy_arg * +get_nonintrinsic_dummy_arg (gfc_formal_arglist *formal) +{ + gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg (); + + dummy_arg->intrinsicness = GFC_NON_INTRINSIC_DUMMY_ARG; + dummy_arg->u.non_intrinsic = formal; + + return dummy_arg; +} + + +/* Given formal and actual argument lists, see if they are compatible. + If they are compatible, the actual argument list is sorted to + correspond with the formal list, and elements for missing optional + arguments are inserted. If WHERE pointer is nonnull, then we issue + errors when things don't match instead of just returning the status + code. */ + +bool +gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, + int ranks_must_agree, int is_elemental, + bool in_statement_function, locus *where) +{ + gfc_actual_arglist **new_arg, *a, *actual; + gfc_formal_arglist *f; + int i, n, na; + unsigned long actual_size, formal_size; + bool full_array = false; + gfc_array_ref *actual_arr_ref; + gfc_array_spec *fas, *aas; + bool pointer_dummy, pointer_arg, allocatable_arg; + + bool ok = true; + + actual = *ap; + + if (actual == NULL && formal == NULL) + return true; + + n = 0; + for (f = formal; f; f = f->next) + n++; + + new_arg = XALLOCAVEC (gfc_actual_arglist *, n); + + for (i = 0; i < n; i++) + new_arg[i] = NULL; + + na = 0; + f = formal; + i = 0; + + for (a = actual; a; a = a->next, f = f->next) + { + if (a->name != NULL && in_statement_function) + { + gfc_error ("Keyword argument %qs at %L is invalid in " + "a statement function", a->name, &a->expr->where); + return false; + } + + /* Look for keywords but ignore g77 extensions like %VAL. */ + if (a->name != NULL && a->name[0] != '%') + { + i = 0; + for (f = formal; f; f = f->next, i++) + { + if (f->sym == NULL) + continue; + if (strcmp (f->sym->name, a->name) == 0) + break; + } + + if (f == NULL) + { + if (where) + { + const char *guessed = lookup_arg_fuzzy (a->name, formal); + if (guessed) + gfc_error ("Keyword argument %qs at %L is not in " + "the procedure; did you mean %qs?", + a->name, &a->expr->where, guessed); + else + gfc_error ("Keyword argument %qs at %L is not in " + "the procedure", a->name, &a->expr->where); + } + return false; + } + + if (new_arg[i] != NULL) + { + if (where) + gfc_error ("Keyword argument %qs at %L is already associated " + "with another actual argument", a->name, + &a->expr->where); + return false; + } + } + + if (f == NULL) + { + if (where) + gfc_error ("More actual than formal arguments in procedure " + "call at %L", where); + return false; + } + + if (f->sym == NULL && a->expr == NULL) + goto match; + + if (f->sym == NULL) + { + /* These errors have to be issued, otherwise an ICE can occur. + See PR 78865. */ + if (where) + gfc_error_now ("Missing alternate return specifier in subroutine " + "call at %L", where); + return false; + } + else + a->associated_dummy = get_nonintrinsic_dummy_arg (f); + + if (a->expr == NULL) + { + if (f->sym->attr.optional) + continue; + else + { + if (where) + gfc_error_now ("Unexpected alternate return specifier in " + "subroutine call at %L", where); + return false; + } + } + + /* Make sure that intrinsic vtables exist for calls to unlimited + polymorphic formal arguments. */ + if (UNLIMITED_POLY (f->sym) + && a->expr->ts.type != BT_DERIVED + && a->expr->ts.type != BT_CLASS + && a->expr->ts.type != BT_ASSUMED) + gfc_find_vtab (&a->expr->ts); + + if (a->expr->expr_type == EXPR_NULL + && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer + && (f->sym->attr.allocatable || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)) + || (f->sym->ts.type == BT_CLASS + && !CLASS_DATA (f->sym)->attr.class_pointer + && (CLASS_DATA (f->sym)->attr.allocatable + || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) + { + if (where + && (!f->sym->attr.optional + || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.allocatable))) + gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs", + where, f->sym->name); + else if (where) + gfc_error ("Fortran 2008: Null pointer at %L to non-pointer " + "dummy %qs", where, f->sym->name); + ok = false; + goto match; + } + + if (!compare_parameter (f->sym, a->expr, ranks_must_agree, + is_elemental, where)) + { + ok = false; + goto match; + } + + /* TS 29113, 6.3p2; F2018 15.5.2.4. */ + if (f->sym->ts.type == BT_ASSUMED + && (a->expr->ts.type == BT_DERIVED + || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr)))) + { + gfc_symbol *derived = (a->expr->ts.type == BT_DERIVED + ? a->expr->ts.u.derived + : CLASS_DATA (a->expr)->ts.u.derived); + gfc_namespace *f2k_derived = derived->f2k_derived; + if (derived->attr.pdt_type + || (f2k_derived + && (f2k_derived->finalizers || f2k_derived->tb_sym_root))) + { + gfc_error ("Actual argument at %L to assumed-type dummy " + "has type parameters or is of " + "derived type with type-bound or FINAL procedures", + &a->expr->where); + ok = false; + goto match; + } + } + + /* Special case for character arguments. For allocatable, pointer + and assumed-shape dummies, the string length needs to match + exactly. */ + if (a->expr->ts.type == BT_CHARACTER + && a->expr->ts.u.cl && a->expr->ts.u.cl->length + && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT + && f->sym->ts.type == BT_CHARACTER && f->sym->ts.u.cl + && f->sym->ts.u.cl->length + && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT + && (f->sym->attr.pointer || f->sym->attr.allocatable + || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE)) + && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, + f->sym->ts.u.cl->length->value.integer) != 0)) + { + if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) + gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " + "argument and pointer or allocatable dummy argument " + "%qs at %L", + mpz_get_si (a->expr->ts.u.cl->length->value.integer), + mpz_get_si (f->sym->ts.u.cl->length->value.integer), + f->sym->name, &a->expr->where); + else if (where) + gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " + "argument and assumed-shape dummy argument %qs " + "at %L", + mpz_get_si (a->expr->ts.u.cl->length->value.integer), + mpz_get_si (f->sym->ts.u.cl->length->value.integer), + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + if ((f->sym->attr.pointer || f->sym->attr.allocatable) + && f->sym->ts.deferred != a->expr->ts.deferred + && a->expr->ts.type == BT_CHARACTER) + { + if (where) + gfc_error ("Actual argument at %L to allocatable or " + "pointer dummy argument %qs must have a deferred " + "length type parameter if and only if the dummy has one", + &a->expr->where, f->sym->name); + ok = false; + goto match; + } + + if (f->sym->ts.type == BT_CLASS) + goto skip_size_check; + + actual_size = get_expr_storage_size (a->expr); + formal_size = get_sym_storage_size (f->sym); + if (actual_size != 0 && actual_size < formal_size + && a->expr->ts.type != BT_PROCEDURE + && f->sym->attr.flavor != FL_PROCEDURE) + { + if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) + { + gfc_warning (0, "Character length of actual argument shorter " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); + goto skip_size_check; + } + else if (where) + { + /* Emit a warning for -std=legacy and an error otherwise. */ + if (gfc_option.warn_std == 0) + gfc_warning (0, "Actual argument contains too few " + "elements for dummy argument %qs (%lu/%lu) " + "at %L", f->sym->name, actual_size, + formal_size, &a->expr->where); + else + gfc_error_now ("Actual argument contains too few " + "elements for dummy argument %qs (%lu/%lu) " + "at %L", f->sym->name, actual_size, + formal_size, &a->expr->where); + } + ok = false; + goto match; + } + + skip_size_check: + + /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual + argument is provided for a procedure pointer formal argument. */ + if (f->sym->attr.proc_pointer + && !((a->expr->expr_type == EXPR_VARIABLE + && (a->expr->symtree->n.sym->attr.proc_pointer + || gfc_is_proc_ptr_comp (a->expr))) + || (a->expr->expr_type == EXPR_FUNCTION + && is_procptr_result (a->expr)))) + { + if (where) + gfc_error ("Expected a procedure pointer for argument %qs at %L", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + /* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is + provided for a procedure formal argument. */ + if (f->sym->attr.flavor == FL_PROCEDURE + && !((a->expr->expr_type == EXPR_VARIABLE + && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE + || a->expr->symtree->n.sym->attr.proc_pointer + || gfc_is_proc_ptr_comp (a->expr))) + || (a->expr->expr_type == EXPR_FUNCTION + && is_procptr_result (a->expr)))) + { + if (where) + gfc_error ("Expected a procedure for argument %qs at %L", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + /* Class array variables and expressions store array info in a + different place from non-class objects; consolidate the logic + to access it here instead of repeating it below. Note that + pointer_arg and allocatable_arg are not fully general and are + only used in a specific situation below with an assumed-rank + argument. */ + if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)) + { + gfc_component *classdata = CLASS_DATA (f->sym); + fas = classdata->as; + pointer_dummy = classdata->attr.class_pointer; + } + else + { + fas = f->sym->as; + pointer_dummy = f->sym->attr.pointer; + } + + if (a->expr->expr_type != EXPR_VARIABLE) + { + aas = NULL; + pointer_arg = false; + allocatable_arg = false; + } + else if (a->expr->ts.type == BT_CLASS + && a->expr->symtree->n.sym + && CLASS_DATA (a->expr->symtree->n.sym)) + { + gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym); + aas = classdata->as; + pointer_arg = classdata->attr.class_pointer; + allocatable_arg = classdata->attr.allocatable; + } + else + { + aas = a->expr->symtree->n.sym->as; + pointer_arg = a->expr->symtree->n.sym->attr.pointer; + allocatable_arg = a->expr->symtree->n.sym->attr.allocatable; + } + + /* F2018:9.5.2(2) permits assumed-size whole array expressions as + actual arguments only if the shape is not required; thus it + cannot be passed to an assumed-shape array dummy. + F2018:15.5.2.(2) permits passing a nonpointer actual to an + intent(in) pointer dummy argument and this is accepted by + the compare_pointer check below, but this also requires shape + information. + There's more discussion of this in PR94110. */ + if (fas + && (fas->type == AS_ASSUMED_SHAPE + || fas->type == AS_DEFERRED + || (fas->type == AS_ASSUMED_RANK && pointer_dummy)) + && aas + && aas->type == AS_ASSUMED_SIZE + && (a->expr->ref == NULL + || (a->expr->ref->type == REF_ARRAY + && a->expr->ref->u.ar.type == AR_FULL))) + { + if (where) + gfc_error ("Actual argument for %qs cannot be an assumed-size" + " array at %L", f->sym->name, where); + ok = false; + goto match; + } + + /* Diagnose F2018 C839 (TS29113 C535c). Here the problem is + passing an assumed-size array to an INTENT(OUT) assumed-rank + dummy when it doesn't have the size information needed to run + initializers and finalizers. */ + if (f->sym->attr.intent == INTENT_OUT + && fas + && fas->type == AS_ASSUMED_RANK + && aas + && ((aas->type == AS_ASSUMED_SIZE + && (a->expr->ref == NULL + || (a->expr->ref->type == REF_ARRAY + && a->expr->ref->u.ar.type == AR_FULL))) + || (aas->type == AS_ASSUMED_RANK + && !pointer_arg + && !allocatable_arg)) + && (a->expr->ts.type == BT_CLASS + || (a->expr->ts.type == BT_DERIVED + && (gfc_is_finalizable (a->expr->ts.u.derived, NULL) + || gfc_has_ultimate_allocatable (a->expr) + || gfc_has_default_initializer + (a->expr->ts.u.derived))))) + { + if (where) + gfc_error ("Actual argument to assumed-rank INTENT(OUT) " + "dummy %qs at %L cannot be of unknown size", + f->sym->name, where); + ok = false; + goto match; + } + + if (a->expr->expr_type != EXPR_NULL + && compare_pointer (f->sym, a->expr) == 0) + { + if (where) + gfc_error ("Actual argument for %qs must be a pointer at %L", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + if (a->expr->expr_type != EXPR_NULL + && (gfc_option.allow_std & GFC_STD_F2008) == 0 + && compare_pointer (f->sym, a->expr) == 2) + { + if (where) + gfc_error ("Fortran 2008: Non-pointer actual argument at %L to " + "pointer dummy %qs", &a->expr->where,f->sym->name); + ok = false; + goto match; + } + + + /* Fortran 2008, C1242. */ + if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L to pointer " + "dummy %qs", + &a->expr->where, f->sym->name); + ok = false; + goto match; + } + + /* Fortran 2008, 12.5.2.5 (no constraint). */ + if (a->expr->expr_type == EXPR_VARIABLE + && f->sym->attr.intent != INTENT_IN + && f->sym->attr.allocatable + && gfc_is_coindexed (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L to allocatable " + "dummy %qs requires INTENT(IN)", + &a->expr->where, f->sym->name); + ok = false; + goto match; + } + + /* Fortran 2008, C1237. */ + if (a->expr->expr_type == EXPR_VARIABLE + && (f->sym->attr.asynchronous || f->sym->attr.volatile_) + && gfc_is_coindexed (a->expr) + && (a->expr->symtree->n.sym->attr.volatile_ + || a->expr->symtree->n.sym->attr.asynchronous)) + { + if (where) + gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " + "%L requires that dummy %qs has neither " + "ASYNCHRONOUS nor VOLATILE", &a->expr->where, + f->sym->name); + ok = false; + goto match; + } + + /* Fortran 2008, 12.5.2.4 (no constraint). */ + if (a->expr->expr_type == EXPR_VARIABLE + && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value + && gfc_is_coindexed (a->expr) + && gfc_has_ultimate_allocatable (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L with allocatable " + "ultimate component to dummy %qs requires either VALUE " + "or INTENT(IN)", &a->expr->where, f->sym->name); + ok = false; + goto match; + } + + if (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.allocatable + && gfc_is_class_array_ref (a->expr, &full_array) + && !full_array) + { + if (where) + gfc_error ("Actual CLASS array argument for %qs must be a full " + "array at %L", f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + + if (a->expr->expr_type != EXPR_NULL + && !compare_allocatable (f->sym, a->expr)) + { + if (where) + gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + + /* Check intent = OUT/INOUT for definable actual argument. */ + if (!in_statement_function + && (f->sym->attr.intent == INTENT_OUT + || f->sym->attr.intent == INTENT_INOUT)) + { + const char* context = (where + ? _("actual argument to INTENT = OUT/INOUT") + : NULL); + + if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) + && !gfc_check_vardef_context (a->expr, true, false, false, context)) + { + ok = false; + goto match; + } + if (!gfc_check_vardef_context (a->expr, false, false, false, context)) + { + ok = false; + goto match; + } + } + + if ((f->sym->attr.intent == INTENT_OUT + || f->sym->attr.intent == INTENT_INOUT + || f->sym->attr.volatile_ + || f->sym->attr.asynchronous) + && gfc_has_vector_subscript (a->expr)) + { + if (where) + gfc_error ("Array-section actual argument with vector " + "subscripts at %L is incompatible with INTENT(OUT), " + "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute " + "of the dummy argument %qs", + &a->expr->where, f->sym->name); + ok = false; + goto match; + } + + /* C1232 (R1221) For an actual argument which is an array section or + an assumed-shape array, the dummy argument shall be an assumed- + shape array, if the dummy argument has the VOLATILE attribute. */ + + if (f->sym->attr.volatile_ + && a->expr->expr_type == EXPR_VARIABLE + && a->expr->symtree->n.sym->as + && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE + && !(fas && fas->type == AS_ASSUMED_SHAPE)) + { + if (where) + gfc_error ("Assumed-shape actual argument at %L is " + "incompatible with the non-assumed-shape " + "dummy argument %qs due to VOLATILE attribute", + &a->expr->where,f->sym->name); + ok = false; + goto match; + } + + /* Find the last array_ref. */ + actual_arr_ref = NULL; + if (a->expr->ref) + actual_arr_ref = gfc_find_array_ref (a->expr, true); + + if (f->sym->attr.volatile_ + && actual_arr_ref && actual_arr_ref->type == AR_SECTION + && !(fas && fas->type == AS_ASSUMED_SHAPE)) + { + if (where) + gfc_error ("Array-section actual argument at %L is " + "incompatible with the non-assumed-shape " + "dummy argument %qs due to VOLATILE attribute", + &a->expr->where, f->sym->name); + ok = false; + goto match; + } + + /* C1233 (R1221) For an actual argument which is a pointer array, the + dummy argument shall be an assumed-shape or pointer array, if the + dummy argument has the VOLATILE attribute. */ + + if (f->sym->attr.volatile_ + && a->expr->expr_type == EXPR_VARIABLE + && a->expr->symtree->n.sym->attr.pointer + && a->expr->symtree->n.sym->as + && !(fas + && (fas->type == AS_ASSUMED_SHAPE + || f->sym->attr.pointer))) + { + if (where) + gfc_error ("Pointer-array actual argument at %L requires " + "an assumed-shape or pointer-array dummy " + "argument %qs due to VOLATILE attribute", + &a->expr->where,f->sym->name); + ok = false; + goto match; + } + + match: + if (a == actual) + na = i; + + new_arg[i++] = a; + } + + /* Give up now if we saw any bad argument. */ + if (!ok) + return false; + + /* Make sure missing actual arguments are optional. */ + i = 0; + for (f = formal; f; f = f->next, i++) + { + if (new_arg[i] != NULL) + continue; + if (f->sym == NULL) + { + if (where) + gfc_error ("Missing alternate return spec in subroutine call " + "at %L", where); + return false; + } + /* For CLASS, the optional attribute might be set at either location. */ + if (((f->sym->ts.type != BT_CLASS || !CLASS_DATA (f->sym)->attr.optional) + && !f->sym->attr.optional) + || (in_statement_function + && (f->sym->attr.optional + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.optional)))) + { + if (where) + gfc_error ("Missing actual argument for argument %qs at %L", + f->sym->name, where); + return false; + } + } + + /* We should have handled the cases where the formal arglist is null + already. */ + gcc_assert (n > 0); + + /* The argument lists are compatible. We now relink a new actual + argument list with null arguments in the right places. The head + of the list remains the head. */ + for (f = formal, i = 0; f; f = f->next, i++) + if (new_arg[i] == NULL) + { + new_arg[i] = gfc_get_actual_arglist (); + new_arg[i]->associated_dummy = get_nonintrinsic_dummy_arg (f); + } + + if (na != 0) + { + std::swap (*new_arg[0], *actual); + std::swap (new_arg[0], new_arg[na]); + } + + for (i = 0; i < n - 1; i++) + new_arg[i]->next = new_arg[i + 1]; + + new_arg[i]->next = NULL; + + if (*ap == NULL && n > 0) + *ap = new_arg[0]; + + return true; +} + + +typedef struct +{ + gfc_formal_arglist *f; + gfc_actual_arglist *a; +} +argpair; + +/* qsort comparison function for argument pairs, with the following + order: + - p->a->expr == NULL + - p->a->expr->expr_type != EXPR_VARIABLE + - by gfc_symbol pointer value (larger first). */ + +static int +pair_cmp (const void *p1, const void *p2) +{ + const gfc_actual_arglist *a1, *a2; + + /* *p1 and *p2 are elements of the to-be-sorted array. */ + a1 = ((const argpair *) p1)->a; + a2 = ((const argpair *) p2)->a; + if (!a1->expr) + { + if (!a2->expr) + return 0; + return -1; + } + if (!a2->expr) + return 1; + if (a1->expr->expr_type != EXPR_VARIABLE) + { + if (a2->expr->expr_type != EXPR_VARIABLE) + return 0; + return -1; + } + if (a2->expr->expr_type != EXPR_VARIABLE) + return 1; + if (a1->expr->symtree->n.sym > a2->expr->symtree->n.sym) + return -1; + return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym; +} + + +/* Given two expressions from some actual arguments, test whether they + refer to the same expression. The analysis is conservative. + Returning false will produce no warning. */ + +static bool +compare_actual_expr (gfc_expr *e1, gfc_expr *e2) +{ + const gfc_ref *r1, *r2; + + if (!e1 || !e2 + || e1->expr_type != EXPR_VARIABLE + || e2->expr_type != EXPR_VARIABLE + || e1->symtree->n.sym != e2->symtree->n.sym) + return false; + + /* TODO: improve comparison, see expr.c:show_ref(). */ + for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next) + { + if (r1->type != r2->type) + return false; + switch (r1->type) + { + case REF_ARRAY: + if (r1->u.ar.type != r2->u.ar.type) + return false; + /* TODO: At the moment, consider only full arrays; + we could do better. */ + if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL) + return false; + break; + + case REF_COMPONENT: + if (r1->u.c.component != r2->u.c.component) + return false; + break; + + case REF_SUBSTRING: + return false; + + case REF_INQUIRY: + if (e1->symtree->n.sym->ts.type == BT_COMPLEX + && e1->ts.type == BT_REAL && e2->ts.type == BT_REAL + && r1->u.i != r2->u.i) + return false; + break; + + default: + gfc_internal_error ("compare_actual_expr(): Bad component code"); + } + } + if (!r1 && !r2) + return true; + return false; +} + + +/* Given formal and actual argument lists that correspond to one + another, check that identical actual arguments aren't not + associated with some incompatible INTENTs. */ + +static bool +check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a) +{ + sym_intent f1_intent, f2_intent; + gfc_formal_arglist *f1; + gfc_actual_arglist *a1; + size_t n, i, j; + argpair *p; + bool t = true; + + n = 0; + for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next) + { + if (f1 == NULL && a1 == NULL) + break; + if (f1 == NULL || a1 == NULL) + gfc_internal_error ("check_some_aliasing(): List mismatch"); + n++; + } + if (n == 0) + return t; + p = XALLOCAVEC (argpair, n); + + for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next) + { + p[i].f = f1; + p[i].a = a1; + } + + qsort (p, n, sizeof (argpair), pair_cmp); + + for (i = 0; i < n; i++) + { + if (!p[i].a->expr + || p[i].a->expr->expr_type != EXPR_VARIABLE + || p[i].a->expr->ts.type == BT_PROCEDURE) + continue; + f1_intent = p[i].f->sym->attr.intent; + for (j = i + 1; j < n; j++) + { + /* Expected order after the sort. */ + if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE) + gfc_internal_error ("check_some_aliasing(): corrupted data"); + + /* Are the expression the same? */ + if (!compare_actual_expr (p[i].a->expr, p[j].a->expr)) + break; + f2_intent = p[j].f->sym->attr.intent; + if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT) + || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN) + || (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT)) + { + gfc_warning (0, "Same actual argument associated with INTENT(%s) " + "argument %qs and INTENT(%s) argument %qs at %L", + gfc_intent_string (f1_intent), p[i].f->sym->name, + gfc_intent_string (f2_intent), p[j].f->sym->name, + &p[i].a->expr->where); + t = false; + } + } + } + + return t; +} + + +/* Given formal and actual argument lists that correspond to one + another, check that they are compatible in the sense that intents + are not mismatched. */ + +static bool +check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) +{ + sym_intent f_intent; + + for (;; f = f->next, a = a->next) + { + gfc_expr *expr; + + if (f == NULL && a == NULL) + break; + if (f == NULL || a == NULL) + gfc_internal_error ("check_intents(): List mismatch"); + + if (a->expr && a->expr->expr_type == EXPR_FUNCTION + && a->expr->value.function.isym + && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET) + expr = a->expr->value.function.actual->expr; + else + expr = a->expr; + + if (expr == NULL || expr->expr_type != EXPR_VARIABLE) + continue; + + f_intent = f->sym->attr.intent; + + if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym)) + { + if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) + { + gfc_error ("Procedure argument at %L is local to a PURE " + "procedure and has the POINTER attribute", + &expr->where); + return false; + } + } + + /* Fortran 2008, C1283. */ + if (gfc_pure (NULL) && gfc_is_coindexed (expr)) + { + if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) + { + gfc_error ("Coindexed actual argument at %L in PURE procedure " + "is passed to an INTENT(%s) argument", + &expr->where, gfc_intent_string (f_intent)); + return false; + } + + if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok + && CLASS_DATA (f->sym)->attr.class_pointer) + || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer)) + { + gfc_error ("Coindexed actual argument at %L in PURE procedure " + "is passed to a POINTER dummy argument", + &expr->where); + return false; + } + } + + /* F2008, Section 12.5.2.4. */ + if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS + && gfc_is_coindexed (expr)) + { + gfc_error ("Coindexed polymorphic actual argument at %L is passed " + "polymorphic dummy argument %qs", + &expr->where, f->sym->name); + return false; + } + } + + return true; +} + + +/* Check how a procedure is used against its interface. If all goes + well, the actual argument list will also end up being properly + sorted. */ + +bool +gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) +{ + gfc_actual_arglist *a; + gfc_formal_arglist *dummy_args; + bool implicit = false; + + /* Warn about calls with an implicit interface. Special case + for calling a ISO_C_BINDING because c_loc and c_funloc + are pseudo-unknown. Additionally, warn about procedures not + explicitly declared at all if requested. */ + if (sym->attr.if_source == IFSRC_UNKNOWN && !sym->attr.is_iso_c) + { + bool has_implicit_none_export = false; + implicit = true; + if (sym->attr.proc == PROC_UNKNOWN) + for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent) + if (ns->has_implicit_none_export) + { + has_implicit_none_export = true; + break; + } + if (has_implicit_none_export) + { + const char *guessed + = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); + if (guessed) + gfc_error ("Procedure %qs called at %L is not explicitly declared" + "; did you mean %qs?", + sym->name, where, guessed); + else + gfc_error ("Procedure %qs called at %L is not explicitly declared", + sym->name, where); + return false; + } + if (warn_implicit_interface) + gfc_warning (OPT_Wimplicit_interface, + "Procedure %qs called with an implicit interface at %L", + sym->name, where); + else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN) + gfc_warning (OPT_Wimplicit_procedure, + "Procedure %qs called at %L is not explicitly declared", + sym->name, where); + gfc_find_proc_namespace (sym->ns)->implicit_interface_calls = 1; + } + + if (sym->attr.if_source == IFSRC_UNKNOWN) + { + if (sym->attr.pointer) + { + gfc_error ("The pointer object %qs at %L must have an explicit " + "function interface or be declared as array", + sym->name, where); + return false; + } + + if (sym->attr.allocatable && !sym->attr.external) + { + gfc_error ("The allocatable object %qs at %L must have an explicit " + "function interface or be declared as array", + sym->name, where); + return false; + } + + if (sym->attr.allocatable) + { + gfc_error ("Allocatable function %qs at %L must have an explicit " + "function interface", sym->name, where); + return false; + } + + for (a = *ap; a; a = a->next) + { + if (a->expr && a->expr->error) + return false; + + /* F2018, 15.4.2.2 Explicit interface is required for a + polymorphic dummy argument, so there is no way to + legally have a class appear in an argument with an + implicit interface. */ + + if (implicit && a->expr && a->expr->ts.type == BT_CLASS) + { + gfc_error ("Explicit interface required for polymorphic " + "argument at %L",&a->expr->where); + a->expr->error = 1; + break; + } + + /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ + if (a->name != NULL && a->name[0] != '%') + { + gfc_error ("Keyword argument requires explicit interface " + "for procedure %qs at %L", sym->name, &a->expr->where); + break; + } + + /* TS 29113, 6.2. */ + if (a->expr && a->expr->ts.type == BT_ASSUMED + && sym->intmod_sym_id != ISOCBINDING_LOC) + { + gfc_error ("Assumed-type argument %s at %L requires an explicit " + "interface", a->expr->symtree->n.sym->name, + &a->expr->where); + a->expr->error = 1; + break; + } + + /* F2008, C1303 and C1304. */ + if (a->expr + && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) + && a->expr->ts.u.derived + && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + || gfc_expr_attr (a->expr).lock_comp)) + { + gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE " + "component at %L requires an explicit interface for " + "procedure %qs", &a->expr->where, sym->name); + a->expr->error = 1; + break; + } + + if (a->expr + && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS) + && a->expr->ts.u.derived + && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && a->expr->ts.u.derived->intmod_sym_id + == ISOFORTRAN_EVENT_TYPE) + || gfc_expr_attr (a->expr).event_comp)) + { + gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE " + "component at %L requires an explicit interface for " + "procedure %qs", &a->expr->where, sym->name); + a->expr->error = 1; + break; + } + + if (a->expr && a->expr->expr_type == EXPR_NULL + && a->expr->ts.type == BT_UNKNOWN) + { + gfc_error ("MOLD argument to NULL required at %L", + &a->expr->where); + a->expr->error = 1; + return false; + } + + /* TS 29113, C407b. */ + if (a->expr && a->expr->expr_type == EXPR_VARIABLE + && symbol_rank (a->expr->symtree->n.sym) == -1) + { + gfc_error ("Assumed-rank argument requires an explicit interface " + "at %L", &a->expr->where); + a->expr->error = 1; + return false; + } + } + + return true; + } + + dummy_args = gfc_sym_get_dummy_args (sym); + + /* For a statement function, check that types and type parameters of actual + arguments and dummy arguments match. */ + if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, + sym->attr.proc == PROC_ST_FUNCTION, where)) + return false; + + if (!check_intents (dummy_args, *ap)) + return false; + + if (warn_aliasing) + check_some_aliasing (dummy_args, *ap); + + return true; +} + + +/* Check how a procedure pointer component is used against its interface. + If all goes well, the actual argument list will also end up being properly + sorted. Completely analogous to gfc_procedure_use. */ + +void +gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where) +{ + /* Warn about calls with an implicit interface. Special case + for calling a ISO_C_BINDING because c_loc and c_funloc + are pseudo-unknown. */ + if (warn_implicit_interface + && comp->attr.if_source == IFSRC_UNKNOWN + && !comp->attr.is_iso_c) + gfc_warning (OPT_Wimplicit_interface, + "Procedure pointer component %qs called with an implicit " + "interface at %L", comp->name, where); + + if (comp->attr.if_source == IFSRC_UNKNOWN) + { + gfc_actual_arglist *a; + for (a = *ap; a; a = a->next) + { + /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */ + if (a->name != NULL && a->name[0] != '%') + { + gfc_error ("Keyword argument requires explicit interface " + "for procedure pointer component %qs at %L", + comp->name, &a->expr->where); + break; + } + } + + return; + } + + if (!gfc_compare_actual_formal (ap, comp->ts.interface->formal, 0, + comp->attr.elemental, false, where)) + return; + + check_intents (comp->ts.interface->formal, *ap); + if (warn_aliasing) + check_some_aliasing (comp->ts.interface->formal, *ap); +} + + +/* Try if an actual argument list matches the formal list of a symbol, + respecting the symbol's attributes like ELEMENTAL. This is used for + GENERIC resolution. */ + +bool +gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) +{ + gfc_formal_arglist *dummy_args; + bool r; + + if (sym->attr.flavor != FL_PROCEDURE) + return false; + + dummy_args = gfc_sym_get_dummy_args (sym); + + r = !sym->attr.elemental; + if (gfc_compare_actual_formal (args, dummy_args, r, !r, false, NULL)) + { + check_intents (dummy_args, *args); + if (warn_aliasing) + check_some_aliasing (dummy_args, *args); + return true; + } + + return false; +} + + +/* Given an interface pointer and an actual argument list, search for + a formal argument list that matches the actual. If found, returns + a pointer to the symbol of the correct interface. Returns NULL if + not found. */ + +gfc_symbol * +gfc_search_interface (gfc_interface *intr, int sub_flag, + gfc_actual_arglist **ap) +{ + gfc_symbol *elem_sym = NULL; + gfc_symbol *null_sym = NULL; + locus null_expr_loc; + gfc_actual_arglist *a; + bool has_null_arg = false; + + for (a = *ap; a; a = a->next) + if (a->expr && a->expr->expr_type == EXPR_NULL + && a->expr->ts.type == BT_UNKNOWN) + { + has_null_arg = true; + null_expr_loc = a->expr->where; + break; + } + + for (; intr; intr = intr->next) + { + if (gfc_fl_struct (intr->sym->attr.flavor)) + continue; + if (sub_flag && intr->sym->attr.function) + continue; + if (!sub_flag && intr->sym->attr.subroutine) + continue; + + if (gfc_arglist_matches_symbol (ap, intr->sym)) + { + if (has_null_arg && null_sym) + { + gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity " + "between specific functions %s and %s", + &null_expr_loc, null_sym->name, intr->sym->name); + return NULL; + } + else if (has_null_arg) + { + null_sym = intr->sym; + continue; + } + + /* Satisfy 12.4.4.1 such that an elemental match has lower + weight than a non-elemental match. */ + if (intr->sym->attr.elemental) + { + elem_sym = intr->sym; + continue; + } + return intr->sym; + } + } + + if (null_sym) + return null_sym; + + return elem_sym ? elem_sym : NULL; +} + + +/* Do a brute force recursive search for a symbol. */ + +static gfc_symtree * +find_symtree0 (gfc_symtree *root, gfc_symbol *sym) +{ + gfc_symtree * st; + + if (root->n.sym == sym) + return root; + + st = NULL; + if (root->left) + st = find_symtree0 (root->left, sym); + if (root->right && ! st) + st = find_symtree0 (root->right, sym); + return st; +} + + +/* Find a symtree for a symbol. */ + +gfc_symtree * +gfc_find_sym_in_symtree (gfc_symbol *sym) +{ + gfc_symtree *st; + gfc_namespace *ns; + + /* First try to find it by name. */ + gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st); + if (st && st->n.sym == sym) + return st; + + /* If it's been renamed, resort to a brute-force search. */ + /* TODO: avoid having to do this search. If the symbol doesn't exist + in the symtree for the current namespace, it should probably be added. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + st = find_symtree0 (ns->sym_root, sym); + if (st) + return st; + } + gfc_internal_error ("Unable to find symbol %qs", sym->name); + /* Not reached. */ +} + + +/* See if the arglist to an operator-call contains a derived-type argument + with a matching type-bound operator. If so, return the matching specific + procedure defined as operator-target as well as the base-object to use + (which is the found derived-type argument with operator). The generic + name, if any, is transmitted to the final expression via 'gname'. */ + +static gfc_typebound_proc* +matching_typebound_op (gfc_expr** tb_base, + gfc_actual_arglist* args, + gfc_intrinsic_op op, const char* uop, + const char ** gname) +{ + gfc_actual_arglist* base; + + for (base = args; base; base = base->next) + if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS) + { + gfc_typebound_proc* tb; + gfc_symbol* derived; + bool result; + + while (base->expr->expr_type == EXPR_OP + && base->expr->value.op.op == INTRINSIC_PARENTHESES) + base->expr = base->expr->value.op.op1; + + if (base->expr->ts.type == BT_CLASS) + { + if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL + || !gfc_expr_attr (base->expr).class_ok) + continue; + derived = CLASS_DATA (base->expr)->ts.u.derived; + } + else + derived = base->expr->ts.u.derived; + + if (op == INTRINSIC_USER) + { + gfc_symtree* tb_uop; + + gcc_assert (uop); + tb_uop = gfc_find_typebound_user_op (derived, &result, uop, + false, NULL); + + if (tb_uop) + tb = tb_uop->n.tb; + else + tb = NULL; + } + else + tb = gfc_find_typebound_intrinsic_op (derived, &result, op, + false, NULL); + + /* This means we hit a PRIVATE operator which is use-associated and + should thus not be seen. */ + if (!result) + tb = NULL; + + /* Look through the super-type hierarchy for a matching specific + binding. */ + for (; tb; tb = tb->overridden) + { + gfc_tbp_generic* g; + + gcc_assert (tb->is_generic); + for (g = tb->u.generic; g; g = g->next) + { + gfc_symbol* target; + gfc_actual_arglist* argcopy; + bool matches; + + gcc_assert (g->specific); + if (g->specific->error) + continue; + + target = g->specific->u.specific->n.sym; + + /* Check if this arglist matches the formal. */ + argcopy = gfc_copy_actual_arglist (args); + matches = gfc_arglist_matches_symbol (&argcopy, target); + gfc_free_actual_arglist (argcopy); + + /* Return if we found a match. */ + if (matches) + { + *tb_base = base->expr; + *gname = g->specific_st->name; + return g->specific; + } + } + } + } + + return NULL; +} + + +/* For the 'actual arglist' of an operator call and a specific typebound + procedure that has been found the target of a type-bound operator, build the + appropriate EXPR_COMPCALL and resolve it. We take this indirection over + type-bound procedures rather than resolving type-bound operators 'directly' + so that we can reuse the existing logic. */ + +static void +build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual, + gfc_expr* base, gfc_typebound_proc* target, + const char *gname) +{ + e->expr_type = EXPR_COMPCALL; + e->value.compcall.tbp = target; + e->value.compcall.name = gname ? gname : "$op"; + e->value.compcall.actual = actual; + e->value.compcall.base_object = base; + e->value.compcall.ignore_pass = 1; + e->value.compcall.assign = 0; + if (e->ts.type == BT_UNKNOWN + && target->function) + { + if (target->is_generic) + e->ts = target->u.generic->specific->u.specific->n.sym->ts; + else + e->ts = target->u.specific->n.sym->ts; + } +} + + +/* This subroutine is called when an expression is being resolved. + The expression node in question is either a user defined operator + or an intrinsic operator with arguments that aren't compatible + with the operator. This subroutine builds an actual argument list + corresponding to the operands, then searches for a compatible + interface. If one is found, the expression node is replaced with + the appropriate function call. We use the 'match' enum to specify + whether a replacement has been made or not, or if an error occurred. */ + +match +gfc_extend_expr (gfc_expr *e) +{ + gfc_actual_arglist *actual; + gfc_symbol *sym; + gfc_namespace *ns; + gfc_user_op *uop; + gfc_intrinsic_op i; + const char *gname; + gfc_typebound_proc* tbo; + gfc_expr* tb_base; + + sym = NULL; + + actual = gfc_get_actual_arglist (); + actual->expr = e->value.op.op1; + + gname = NULL; + + if (e->value.op.op2 != NULL) + { + actual->next = gfc_get_actual_arglist (); + actual->next->expr = e->value.op.op2; + } + + i = fold_unary_intrinsic (e->value.op.op); + + /* See if we find a matching type-bound operator. */ + if (i == INTRINSIC_USER) + tbo = matching_typebound_op (&tb_base, actual, + i, e->value.op.uop->name, &gname); + else + switch (i) + { +#define CHECK_OS_COMPARISON(comp) \ + case INTRINSIC_##comp: \ + case INTRINSIC_##comp##_OS: \ + tbo = matching_typebound_op (&tb_base, actual, \ + INTRINSIC_##comp, NULL, &gname); \ + if (!tbo) \ + tbo = matching_typebound_op (&tb_base, actual, \ + INTRINSIC_##comp##_OS, NULL, &gname); \ + break; + CHECK_OS_COMPARISON(EQ) + CHECK_OS_COMPARISON(NE) + CHECK_OS_COMPARISON(GT) + CHECK_OS_COMPARISON(GE) + CHECK_OS_COMPARISON(LT) + CHECK_OS_COMPARISON(LE) +#undef CHECK_OS_COMPARISON + + default: + tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname); + break; + } + + /* If there is a matching typebound-operator, replace the expression with + a call to it and succeed. */ + if (tbo) + { + gcc_assert (tb_base); + build_compcall_for_operator (e, actual, tb_base, tbo, gname); + + if (!gfc_resolve_expr (e)) + return MATCH_ERROR; + else + return MATCH_YES; + } + + if (i == INTRINSIC_USER) + { + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + uop = gfc_find_uop (e->value.op.uop->name, ns); + if (uop == NULL) + continue; + + sym = gfc_search_interface (uop->op, 0, &actual); + if (sym != NULL) + break; + } + } + else + { + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + /* Due to the distinction between '==' and '.eq.' and friends, one has + to check if either is defined. */ + switch (i) + { +#define CHECK_OS_COMPARISON(comp) \ + case INTRINSIC_##comp: \ + case INTRINSIC_##comp##_OS: \ + sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \ + if (!sym) \ + sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \ + break; + CHECK_OS_COMPARISON(EQ) + CHECK_OS_COMPARISON(NE) + CHECK_OS_COMPARISON(GT) + CHECK_OS_COMPARISON(GE) + CHECK_OS_COMPARISON(LT) + CHECK_OS_COMPARISON(LE) +#undef CHECK_OS_COMPARISON + + default: + sym = gfc_search_interface (ns->op[i], 0, &actual); + } + + if (sym != NULL) + break; + } + } + + /* TODO: Do an ambiguity-check and error if multiple matching interfaces are + found rather than just taking the first one and not checking further. */ + + if (sym == NULL) + { + /* Don't use gfc_free_actual_arglist(). */ + free (actual->next); + free (actual); + return MATCH_NO; + } + + /* Change the expression node to a function call. */ + e->expr_type = EXPR_FUNCTION; + e->symtree = gfc_find_sym_in_symtree (sym); + e->value.function.actual = actual; + e->value.function.esym = NULL; + e->value.function.isym = NULL; + e->value.function.name = NULL; + e->user_operator = 1; + + if (!gfc_resolve_expr (e)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Tries to replace an assignment code node with a subroutine call to the + subroutine associated with the assignment operator. Return true if the node + was replaced. On false, no error is generated. */ + +bool +gfc_extend_assign (gfc_code *c, gfc_namespace *ns) +{ + gfc_actual_arglist *actual; + gfc_expr *lhs, *rhs, *tb_base; + gfc_symbol *sym = NULL; + const char *gname = NULL; + gfc_typebound_proc* tbo; + + lhs = c->expr1; + rhs = c->expr2; + + /* Don't allow an intrinsic assignment with a BOZ rhs to be replaced. */ + if (c->op == EXEC_ASSIGN + && c->expr1->expr_type == EXPR_VARIABLE + && c->expr2->expr_type == EXPR_CONSTANT && c->expr2->ts.type == BT_BOZ) + return false; + + /* Don't allow an intrinsic assignment to be replaced. */ + if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS + && (rhs->rank == 0 || rhs->rank == lhs->rank) + && (lhs->ts.type == rhs->ts.type + || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts)))) + return false; + + actual = gfc_get_actual_arglist (); + actual->expr = lhs; + + actual->next = gfc_get_actual_arglist (); + actual->next->expr = rhs; + + /* TODO: Ambiguity-check, see above for gfc_extend_expr. */ + + /* See if we find a matching type-bound assignment. */ + tbo = matching_typebound_op (&tb_base, actual, INTRINSIC_ASSIGN, + NULL, &gname); + + if (tbo) + { + /* Success: Replace the expression with a type-bound call. */ + gcc_assert (tb_base); + c->expr1 = gfc_get_expr (); + build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname); + c->expr1->value.compcall.assign = 1; + c->expr1->where = c->loc; + c->expr2 = NULL; + c->op = EXEC_COMPCALL; + return true; + } + + /* See if we find an 'ordinary' (non-typebound) assignment procedure. */ + for (; ns; ns = ns->parent) + { + sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual); + if (sym != NULL) + break; + } + + if (sym) + { + /* Success: Replace the assignment with the call. */ + c->op = EXEC_ASSIGN_CALL; + c->symtree = gfc_find_sym_in_symtree (sym); + c->expr1 = NULL; + c->expr2 = NULL; + c->ext.actual = actual; + return true; + } + + /* Failure: No assignment procedure found. */ + free (actual->next); + free (actual); + return false; +} + + +/* Make sure that the interface just parsed is not already present in + the given interface list. Ambiguity isn't checked yet since module + procedures can be present without interfaces. */ + +bool +gfc_check_new_interface (gfc_interface *base, gfc_symbol *new_sym, locus loc) +{ + gfc_interface *ip; + + for (ip = base; ip; ip = ip->next) + { + if (ip->sym == new_sym) + { + gfc_error ("Entity %qs at %L is already present in the interface", + new_sym->name, &loc); + return false; + } + } + + return true; +} + + +/* Add a symbol to the current interface. */ + +bool +gfc_add_interface (gfc_symbol *new_sym) +{ + gfc_interface **head, *intr; + gfc_namespace *ns; + gfc_symbol *sym; + + switch (current_interface.type) + { + case INTERFACE_NAMELESS: + case INTERFACE_ABSTRACT: + return true; + + case INTERFACE_INTRINSIC_OP: + for (ns = current_interface.ns; ns; ns = ns->parent) + switch (current_interface.op) + { + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym, + gfc_current_locus) + || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS], + new_sym, gfc_current_locus)) + return false; + break; + + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym, + gfc_current_locus) + || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS], + new_sym, gfc_current_locus)) + return false; + break; + + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + if (!gfc_check_new_interface (ns->op[INTRINSIC_GT], + new_sym, gfc_current_locus) + || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS], + new_sym, gfc_current_locus)) + return false; + break; + + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + if (!gfc_check_new_interface (ns->op[INTRINSIC_GE], + new_sym, gfc_current_locus) + || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS], + new_sym, gfc_current_locus)) + return false; + break; + + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + if (!gfc_check_new_interface (ns->op[INTRINSIC_LT], + new_sym, gfc_current_locus) + || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS], + new_sym, gfc_current_locus)) + return false; + break; + + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + if (!gfc_check_new_interface (ns->op[INTRINSIC_LE], + new_sym, gfc_current_locus) + || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS], + new_sym, gfc_current_locus)) + return false; + break; + + default: + if (!gfc_check_new_interface (ns->op[current_interface.op], + new_sym, gfc_current_locus)) + return false; + } + + head = ¤t_interface.ns->op[current_interface.op]; + break; + + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + for (ns = current_interface.ns; ns; ns = ns->parent) + { + gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); + if (sym == NULL) + continue; + + if (!gfc_check_new_interface (sym->generic, + new_sym, gfc_current_locus)) + return false; + } + + head = ¤t_interface.sym->generic; + break; + + case INTERFACE_USER_OP: + if (!gfc_check_new_interface (current_interface.uop->op, + new_sym, gfc_current_locus)) + return false; + + head = ¤t_interface.uop->op; + break; + + default: + gfc_internal_error ("gfc_add_interface(): Bad interface type"); + } + + intr = gfc_get_interface (); + intr->sym = new_sym; + intr->where = gfc_current_locus; + + intr->next = *head; + *head = intr; + + return true; +} + + +gfc_interface * +gfc_current_interface_head (void) +{ + switch (current_interface.type) + { + case INTERFACE_INTRINSIC_OP: + return current_interface.ns->op[current_interface.op]; + + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + return current_interface.sym->generic; + + case INTERFACE_USER_OP: + return current_interface.uop->op; + + default: + gcc_unreachable (); + } +} + + +void +gfc_set_current_interface_head (gfc_interface *i) +{ + switch (current_interface.type) + { + case INTERFACE_INTRINSIC_OP: + current_interface.ns->op[current_interface.op] = i; + break; + + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + current_interface.sym->generic = i; + break; + + case INTERFACE_USER_OP: + current_interface.uop->op = i; + break; + + default: + gcc_unreachable (); + } +} + + +/* Gets rid of a formal argument list. We do not free symbols. + Symbols are freed when a namespace is freed. */ + +void +gfc_free_formal_arglist (gfc_formal_arglist *p) +{ + gfc_formal_arglist *q; + + for (; p; p = q) + { + q = p->next; + free (p); + } +} + + +/* Check that it is ok for the type-bound procedure 'proc' to override the + procedure 'old', cf. F08:4.5.7.3. */ + +bool +gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) +{ + locus where; + gfc_symbol *proc_target, *old_target; + unsigned proc_pass_arg, old_pass_arg, argpos; + gfc_formal_arglist *proc_formal, *old_formal; + bool check_type; + char err[200]; + + /* This procedure should only be called for non-GENERIC proc. */ + gcc_assert (!proc->n.tb->is_generic); + + /* If the overwritten procedure is GENERIC, this is an error. */ + if (old->n.tb->is_generic) + { + gfc_error ("Cannot overwrite GENERIC %qs at %L", + old->name, &proc->n.tb->where); + return false; + } + + where = proc->n.tb->where; + proc_target = proc->n.tb->u.specific->n.sym; + old_target = old->n.tb->u.specific->n.sym; + + /* Check that overridden binding is not NON_OVERRIDABLE. */ + if (old->n.tb->non_overridable) + { + gfc_error ("%qs at %L overrides a procedure binding declared" + " NON_OVERRIDABLE", proc->name, &where); + return false; + } + + /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */ + if (!old->n.tb->deferred && proc->n.tb->deferred) + { + gfc_error ("%qs at %L must not be DEFERRED as it overrides a" + " non-DEFERRED binding", proc->name, &where); + return false; + } + + /* If the overridden binding is PURE, the overriding must be, too. */ + if (old_target->attr.pure && !proc_target->attr.pure) + { + gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE", + proc->name, &where); + return false; + } + + /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it + is not, the overriding must not be either. */ + if (old_target->attr.elemental && !proc_target->attr.elemental) + { + gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be" + " ELEMENTAL", proc->name, &where); + return false; + } + if (!old_target->attr.elemental && proc_target->attr.elemental) + { + gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not" + " be ELEMENTAL, either", proc->name, &where); + return false; + } + + /* If the overridden binding is a SUBROUTINE, the overriding must also be a + SUBROUTINE. */ + if (old_target->attr.subroutine && !proc_target->attr.subroutine) + { + gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a" + " SUBROUTINE", proc->name, &where); + return false; + } + + /* If the overridden binding is a FUNCTION, the overriding must also be a + FUNCTION and have the same characteristics. */ + if (old_target->attr.function) + { + if (!proc_target->attr.function) + { + gfc_error ("%qs at %L overrides a FUNCTION and must also be a" + " FUNCTION", proc->name, &where); + return false; + } + + if (!gfc_check_result_characteristics (proc_target, old_target, + err, sizeof(err))) + { + gfc_error ("Result mismatch for the overriding procedure " + "%qs at %L: %s", proc->name, &where, err); + return false; + } + } + + /* If the overridden binding is PUBLIC, the overriding one must not be + PRIVATE. */ + if (old->n.tb->access == ACCESS_PUBLIC + && proc->n.tb->access == ACCESS_PRIVATE) + { + gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be" + " PRIVATE", proc->name, &where); + return false; + } + + /* Compare the formal argument lists of both procedures. This is also abused + to find the position of the passed-object dummy arguments of both + bindings as at least the overridden one might not yet be resolved and we + need those positions in the check below. */ + proc_pass_arg = old_pass_arg = 0; + if (!proc->n.tb->nopass && !proc->n.tb->pass_arg) + proc_pass_arg = 1; + if (!old->n.tb->nopass && !old->n.tb->pass_arg) + old_pass_arg = 1; + argpos = 1; + proc_formal = gfc_sym_get_dummy_args (proc_target); + old_formal = gfc_sym_get_dummy_args (old_target); + for ( ; proc_formal && old_formal; + proc_formal = proc_formal->next, old_formal = old_formal->next) + { + if (proc->n.tb->pass_arg + && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name)) + proc_pass_arg = argpos; + if (old->n.tb->pass_arg + && !strcmp (old->n.tb->pass_arg, old_formal->sym->name)) + old_pass_arg = argpos; + + /* Check that the names correspond. */ + if (strcmp (proc_formal->sym->name, old_formal->sym->name)) + { + gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as" + " to match the corresponding argument of the overridden" + " procedure", proc_formal->sym->name, proc->name, &where, + old_formal->sym->name); + return false; + } + + check_type = proc_pass_arg != argpos && old_pass_arg != argpos; + if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym, + check_type, err, sizeof(err))) + { + gfc_error_opt (0, "Argument mismatch for the overriding procedure " + "%qs at %L: %s", proc->name, &where, err); + return false; + } + + ++argpos; + } + if (proc_formal || old_formal) + { + gfc_error ("%qs at %L must have the same number of formal arguments as" + " the overridden procedure", proc->name, &where); + return false; + } + + /* If the overridden binding is NOPASS, the overriding one must also be + NOPASS. */ + if (old->n.tb->nopass && !proc->n.tb->nopass) + { + gfc_error ("%qs at %L overrides a NOPASS binding and must also be" + " NOPASS", proc->name, &where); + return false; + } + + /* If the overridden binding is PASS(x), the overriding one must also be + PASS and the passed-object dummy arguments must correspond. */ + if (!old->n.tb->nopass) + { + if (proc->n.tb->nopass) + { + gfc_error ("%qs at %L overrides a binding with PASS and must also be" + " PASS", proc->name, &where); + return false; + } + + if (proc_pass_arg != old_pass_arg) + { + gfc_error ("Passed-object dummy argument of %qs at %L must be at" + " the same position as the passed-object dummy argument of" + " the overridden procedure", proc->name, &where); + return false; + } + } + + return true; +} + + +/* The following three functions check that the formal arguments + of user defined derived type IO procedures are compliant with + the requirements of the standard, see F03:9.5.3.7.2 (F08:9.6.4.8.3). */ + +static void +check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type, + int kind, int rank, sym_intent intent) +{ + if (fsym->ts.type != type) + { + gfc_error ("DTIO dummy argument at %L must be of type %s", + &fsym->declared_at, gfc_basic_typename (type)); + return; + } + + if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED + && fsym->ts.kind != kind) + gfc_error ("DTIO dummy argument at %L must be of KIND = %d", + &fsym->declared_at, kind); + + if (!typebound + && rank == 0 + && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension) + || ((type != BT_CLASS) && fsym->attr.dimension))) + gfc_error ("DTIO dummy argument at %L must be a scalar", + &fsym->declared_at); + else if (rank == 1 + && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE)) + gfc_error ("DTIO dummy argument at %L must be an " + "ASSUMED SHAPE ARRAY", &fsym->declared_at); + + if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL) + gfc_error ("DTIO character argument at %L must have assumed length", + &fsym->declared_at); + + if (fsym->attr.intent != intent) + gfc_error ("DTIO dummy argument at %L must have INTENT %s", + &fsym->declared_at, gfc_code2string (intents, (int)intent)); + return; +} + + +static void +check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, + bool typebound, bool formatted, int code) +{ + gfc_symbol *dtio_sub, *generic_proc, *fsym; + gfc_typebound_proc *tb_io_proc, *specific_proc; + gfc_interface *intr; + gfc_formal_arglist *formal; + int arg_num; + + bool read = ((dtio_codes)code == DTIO_RF) + || ((dtio_codes)code == DTIO_RUF); + bt type; + sym_intent intent; + int kind; + + dtio_sub = NULL; + if (typebound) + { + /* Typebound DTIO binding. */ + tb_io_proc = tb_io_st->n.tb; + if (tb_io_proc == NULL) + return; + + gcc_assert (tb_io_proc->is_generic); + + specific_proc = tb_io_proc->u.generic->specific; + if (specific_proc == NULL || specific_proc->is_generic) + return; + + dtio_sub = specific_proc->u.specific->n.sym; + } + else + { + generic_proc = tb_io_st->n.sym; + if (generic_proc == NULL || generic_proc->generic == NULL) + return; + + for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next) + { + if (intr->sym && intr->sym->formal && intr->sym->formal->sym + && ((intr->sym->formal->sym->ts.type == BT_CLASS + && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived + == derived) + || (intr->sym->formal->sym->ts.type == BT_DERIVED + && intr->sym->formal->sym->ts.u.derived == derived))) + { + dtio_sub = intr->sym; + break; + } + else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym) + { + gfc_error ("Alternate return at %L is not permitted in a DTIO " + "procedure", &intr->sym->declared_at); + return; + } + } + + if (dtio_sub == NULL) + return; + } + + gcc_assert (dtio_sub); + if (!dtio_sub->attr.subroutine) + gfc_error ("DTIO procedure %qs at %L must be a subroutine", + dtio_sub->name, &dtio_sub->declared_at); + + if (!dtio_sub->resolve_symbol_called) + gfc_resolve_formal_arglist (dtio_sub); + + arg_num = 0; + for (formal = dtio_sub->formal; formal; formal = formal->next) + arg_num++; + + if (arg_num < (formatted ? 6 : 4)) + { + gfc_error ("Too few dummy arguments in DTIO procedure %qs at %L", + dtio_sub->name, &dtio_sub->declared_at); + return; + } + + if (arg_num > (formatted ? 6 : 4)) + { + gfc_error ("Too many dummy arguments in DTIO procedure %qs at %L", + dtio_sub->name, &dtio_sub->declared_at); + return; + } + + /* Now go through the formal arglist. */ + arg_num = 1; + for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++) + { + if (!formatted && arg_num == 3) + arg_num = 5; + fsym = formal->sym; + + if (fsym == NULL) + { + gfc_error ("Alternate return at %L is not permitted in a DTIO " + "procedure", &dtio_sub->declared_at); + return; + } + + switch (arg_num) + { + case(1): /* DTV */ + type = derived->attr.sequence || derived->attr.is_bind_c ? + BT_DERIVED : BT_CLASS; + kind = 0; + intent = read ? INTENT_INOUT : INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + + case(2): /* UNIT */ + type = BT_INTEGER; + kind = gfc_default_integer_kind; + intent = INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + case(3): /* IOTYPE */ + type = BT_CHARACTER; + kind = gfc_default_character_kind; + intent = INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + case(4): /* VLIST */ + type = BT_INTEGER; + kind = gfc_default_integer_kind; + intent = INTENT_IN; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 1, intent); + break; + case(5): /* IOSTAT */ + type = BT_INTEGER; + kind = gfc_default_integer_kind; + intent = INTENT_OUT; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + case(6): /* IOMSG */ + type = BT_CHARACTER; + kind = gfc_default_character_kind; + intent = INTENT_INOUT; + check_dtio_arg_TKR_intent (fsym, typebound, type, kind, + 0, intent); + break; + default: + gcc_unreachable (); + } + } + derived->attr.has_dtio_procs = 1; + return; +} + +void +gfc_check_dtio_interfaces (gfc_symbol *derived) +{ + gfc_symtree *tb_io_st; + bool t = false; + int code; + bool formatted; + + if (derived->attr.is_class == 1 || derived->attr.vtype == 1) + return; + + /* Check typebound DTIO bindings. */ + for (code = 0; code < 4; code++) + { + formatted = ((dtio_codes)code == DTIO_RF) + || ((dtio_codes)code == DTIO_WF); + + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, code), + true, &derived->declared_at); + if (tb_io_st != NULL) + check_dtio_interface1 (derived, tb_io_st, true, formatted, code); + } + + /* Check generic DTIO interfaces. */ + for (code = 0; code < 4; code++) + { + formatted = ((dtio_codes)code == DTIO_RF) + || ((dtio_codes)code == DTIO_WF); + + tb_io_st = gfc_find_symtree (derived->ns->sym_root, + gfc_code2string (dtio_procs, code)); + if (tb_io_st != NULL) + check_dtio_interface1 (derived, tb_io_st, false, formatted, code); + } +} + + +gfc_symtree* +gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +{ + gfc_symtree *tb_io_st = NULL; + bool t = false; + + if (!derived || !derived->resolve_symbol_called + || derived->attr.flavor != FL_DERIVED) + return NULL; + + /* Try to find a typebound DTIO binding. */ + if (formatted == true) + { + if (write == true) + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_WF), + true, + &derived->declared_at); + else + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_RF), + true, + &derived->declared_at); + } + else + { + if (write == true) + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_WUF), + true, + &derived->declared_at); + else + tb_io_st = gfc_find_typebound_proc (derived, &t, + gfc_code2string (dtio_procs, + DTIO_RUF), + true, + &derived->declared_at); + } + return tb_io_st; +} + + +gfc_symbol * +gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted) +{ + gfc_symtree *tb_io_st = NULL; + gfc_symbol *dtio_sub = NULL; + gfc_symbol *extended; + gfc_typebound_proc *tb_io_proc, *specific_proc; + + tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted); + + if (tb_io_st != NULL) + { + const char *genname; + gfc_symtree *st; + + tb_io_proc = tb_io_st->n.tb; + gcc_assert (tb_io_proc != NULL); + gcc_assert (tb_io_proc->is_generic); + gcc_assert (tb_io_proc->u.generic->next == NULL); + + specific_proc = tb_io_proc->u.generic->specific; + gcc_assert (!specific_proc->is_generic); + + /* Go back and make sure that we have the right specific procedure. + Here we most likely have a procedure from the parent type, which + can be overridden in extensions. */ + genname = tb_io_proc->u.generic->specific_st->name; + st = gfc_find_typebound_proc (derived, NULL, genname, + true, &tb_io_proc->where); + if (st) + dtio_sub = st->n.tb->u.specific->n.sym; + else + dtio_sub = specific_proc->u.specific->n.sym; + + goto finish; + } + + /* If there is not a typebound binding, look for a generic + DTIO interface. */ + for (extended = derived; extended; + extended = gfc_get_derived_super_type (extended)) + { + if (extended == NULL || extended->ns == NULL + || extended->attr.flavor == FL_UNKNOWN) + return NULL; + + if (formatted == true) + { + if (write == true) + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_WF)); + else + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_RF)); + } + else + { + if (write == true) + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_WUF)); + else + tb_io_st = gfc_find_symtree (extended->ns->sym_root, + gfc_code2string (dtio_procs, + DTIO_RUF)); + } + + if (tb_io_st != NULL + && tb_io_st->n.sym + && tb_io_st->n.sym->generic) + { + for (gfc_interface *intr = tb_io_st->n.sym->generic; + intr && intr->sym; intr = intr->next) + { + if (intr->sym->formal) + { + gfc_symbol *fsym = intr->sym->formal->sym; + if ((fsym->ts.type == BT_CLASS + && CLASS_DATA (fsym)->ts.u.derived == extended) + || (fsym->ts.type == BT_DERIVED + && fsym->ts.u.derived == extended)) + { + dtio_sub = intr->sym; + break; + } + } + } + } + } + +finish: + if (dtio_sub + && dtio_sub->formal->sym->ts.type == BT_CLASS + && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived) + gfc_find_derived_vtab (derived); + + return dtio_sub; +} + +/* Helper function - if we do not find an interface for a procedure, + construct it from the actual arglist. Luckily, this can only + happen for call by reference, so the information we actually need + to provide (and which would be impossible to guess from the call + itself) is not actually needed. */ + +void +gfc_get_formal_from_actual_arglist (gfc_symbol *sym, + gfc_actual_arglist *actual_args) +{ + gfc_actual_arglist *a; + gfc_formal_arglist **f; + gfc_symbol *s; + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int var_num; + + f = &sym->formal; + for (a = actual_args; a != NULL; a = a->next) + { + (*f) = gfc_get_formal_arglist (); + if (a->expr) + { + snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++); + gfc_get_symbol (name, gfc_current_ns, &s); + if (a->expr->ts.type == BT_PROCEDURE) + { + s->attr.flavor = FL_PROCEDURE; + } + else + { + s->ts = a->expr->ts; + + if (s->ts.type == BT_CHARACTER) + s->ts.u.cl = gfc_get_charlen (); + + s->ts.deferred = 0; + s->ts.is_iso_c = 0; + s->ts.is_c_interop = 0; + s->attr.flavor = FL_VARIABLE; + if (a->expr->rank > 0) + { + s->attr.dimension = 1; + s->as = gfc_get_array_spec (); + s->as->rank = 1; + s->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, + &a->expr->where, 1); + s->as->upper[0] = NULL; + s->as->type = AS_ASSUMED_SIZE; + } + else + s->maybe_array = maybe_dummy_array_arg (a->expr); + } + s->attr.dummy = 1; + s->attr.artificial = 1; + s->declared_at = a->expr->where; + s->attr.intent = INTENT_UNKNOWN; + (*f)->sym = s; + } + else /* If a->expr is NULL, this is an alternate rerturn. */ + (*f)->sym = NULL; + + f = &((*f)->next); + } +} + + +const char * +gfc_dummy_arg_get_name (gfc_dummy_arg & dummy_arg) +{ + switch (dummy_arg.intrinsicness) + { + case GFC_INTRINSIC_DUMMY_ARG: + return dummy_arg.u.intrinsic->name; + + case GFC_NON_INTRINSIC_DUMMY_ARG: + return dummy_arg.u.non_intrinsic->sym->name; + + default: + gcc_unreachable (); + } +} + + +const gfc_typespec & +gfc_dummy_arg_get_typespec (gfc_dummy_arg & dummy_arg) +{ + switch (dummy_arg.intrinsicness) + { + case GFC_INTRINSIC_DUMMY_ARG: + return dummy_arg.u.intrinsic->ts; + + case GFC_NON_INTRINSIC_DUMMY_ARG: + return dummy_arg.u.non_intrinsic->sym->ts; + + default: + gcc_unreachable (); + } +} + + +bool +gfc_dummy_arg_is_optional (gfc_dummy_arg & dummy_arg) +{ + switch (dummy_arg.intrinsicness) + { + case GFC_INTRINSIC_DUMMY_ARG: + return dummy_arg.u.intrinsic->optional; + + case GFC_NON_INTRINSIC_DUMMY_ARG: + return dummy_arg.u.non_intrinsic->sym->attr.optional; + + default: + gcc_unreachable (); + } +} diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c deleted file mode 100644 index 9746cd5..0000000 --- a/gcc/fortran/intrinsic.c +++ /dev/null @@ -1,5503 +0,0 @@ -/* Build up a list of intrinsic subroutines and functions for the - name-resolution stage. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught & Katherine Holcomb - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "intrinsic.h" - -/* Namespace to hold the resolved symbols for intrinsic subroutines. */ -static gfc_namespace *gfc_intrinsic_namespace; - -bool gfc_init_expr_flag = false; - -/* Pointers to an intrinsic function and its argument names that are being - checked. */ - -const char *gfc_current_intrinsic; -gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; -locus *gfc_current_intrinsic_where; - -static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; -static gfc_intrinsic_sym *char_conversions; -static gfc_intrinsic_arg *next_arg; - -static int nfunc, nsub, nargs, nconv, ncharconv; - -static enum -{ SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS } -sizing; - -enum klass -{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL, - CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC }; - -#define ACTUAL_NO 0 -#define ACTUAL_YES 1 - -#define REQUIRED 0 -#define OPTIONAL 1 - - -/* Return a letter based on the passed type. Used to construct the - name of a type-dependent subroutine. If logical_equals_int is - true, we can treat a logical like an int. */ - -char -gfc_type_letter (bt type, bool logical_equals_int) -{ - char c; - - switch (type) - { - case BT_LOGICAL: - if (logical_equals_int) - c = 'i'; - else - c = 'l'; - - break; - case BT_CHARACTER: - c = 's'; - break; - case BT_INTEGER: - c = 'i'; - break; - case BT_REAL: - c = 'r'; - break; - case BT_COMPLEX: - c = 'c'; - break; - - case BT_HOLLERITH: - c = 'h'; - break; - - default: - c = 'u'; - break; - } - - return c; -} - - -/* Return kind that should be used for ABI purposes in libgfortran - APIs. Usually the same as ts->kind, except for BT_REAL/BT_COMPLEX - for IEEE 754 quad format kind 16 where it returns 17. */ - -int -gfc_type_abi_kind (bt type, int kind) -{ - switch (type) - { - case BT_REAL: - case BT_COMPLEX: - if (kind == 16) - for (int i = 0; gfc_real_kinds[i].kind != 0; i++) - if (gfc_real_kinds[i].kind == kind) - return gfc_real_kinds[i].abi_kind; - return kind; - default: - return kind; - } -} - -/* Get a symbol for a resolved name. Note, if needed be, the elemental - attribute has be added afterwards. */ - -gfc_symbol * -gfc_get_intrinsic_sub_symbol (const char *name) -{ - gfc_symbol *sym; - - gfc_get_symbol (name, gfc_intrinsic_namespace, &sym); - sym->attr.always_explicit = 1; - sym->attr.subroutine = 1; - sym->attr.flavor = FL_PROCEDURE; - sym->attr.proc = PROC_INTRINSIC; - - gfc_commit_symbol (sym); - - return sym; -} - -/* Get a symbol for a resolved function, with its special name. The - actual argument list needs to be set by the caller. */ - -gfc_symbol * -gfc_get_intrinsic_function_symbol (gfc_expr *expr) -{ - gfc_symbol *sym; - - gfc_get_symbol (expr->value.function.name, gfc_intrinsic_namespace, &sym); - sym->attr.external = 1; - sym->attr.function = 1; - sym->attr.always_explicit = 1; - sym->attr.proc = PROC_INTRINSIC; - sym->attr.flavor = FL_PROCEDURE; - sym->result = sym; - if (expr->rank > 0) - { - sym->attr.dimension = 1; - sym->as = gfc_get_array_spec (); - sym->as->type = AS_ASSUMED_SHAPE; - sym->as->rank = expr->rank; - } - return sym; -} - -/* Find a symbol for a resolved intrinsic procedure, return NULL if - not found. */ - -gfc_symbol * -gfc_find_intrinsic_symbol (gfc_expr *expr) -{ - gfc_symbol *sym; - gfc_find_symbol (expr->value.function.name, gfc_intrinsic_namespace, - 0, &sym); - return sym; -} - - -/* Return a pointer to the name of a conversion function given two - typespecs. */ - -static const char * -conv_name (gfc_typespec *from, gfc_typespec *to) -{ - return gfc_get_string ("__convert_%c%d_%c%d", - gfc_type_letter (from->type), gfc_type_abi_kind (from), - gfc_type_letter (to->type), gfc_type_abi_kind (to)); -} - - -/* Given a pair of typespecs, find the gfc_intrinsic_sym node that - corresponds to the conversion. Returns NULL if the conversion - isn't found. */ - -static gfc_intrinsic_sym * -find_conv (gfc_typespec *from, gfc_typespec *to) -{ - gfc_intrinsic_sym *sym; - const char *target; - int i; - - target = conv_name (from, to); - sym = conversion; - - for (i = 0; i < nconv; i++, sym++) - if (target == sym->name) - return sym; - - return NULL; -} - - -/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node - that corresponds to the conversion. Returns NULL if the conversion - isn't found. */ - -static gfc_intrinsic_sym * -find_char_conv (gfc_typespec *from, gfc_typespec *to) -{ - gfc_intrinsic_sym *sym; - const char *target; - int i; - - target = conv_name (from, to); - sym = char_conversions; - - for (i = 0; i < ncharconv; i++, sym++) - if (target == sym->name) - return sym; - - return NULL; -} - - -/* Check TS29113, C407b for assumed type and C535b for assumed-rank, - and a likewise check for NO_ARG_CHECK. */ - -static bool -do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) -{ - gfc_actual_arglist *a; - bool ok = true; - - for (a = arg; a; a = a->next) - { - if (!a->expr) - continue; - - if (a->expr->expr_type == EXPR_VARIABLE - && (a->expr->symtree->n.sym->attr.ext_attr - & (1 << EXT_ATTR_NO_ARG_CHECK)) - && specific->id != GFC_ISYM_C_LOC - && specific->id != GFC_ISYM_PRESENT) - { - gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only " - "permitted as argument to the intrinsic functions " - "C_LOC and PRESENT", &a->expr->where); - ok = false; - } - else if (a->expr->ts.type == BT_ASSUMED - && specific->id != GFC_ISYM_LBOUND - && specific->id != GFC_ISYM_PRESENT - && specific->id != GFC_ISYM_RANK - && specific->id != GFC_ISYM_SHAPE - && specific->id != GFC_ISYM_SIZE - && specific->id != GFC_ISYM_SIZEOF - && specific->id != GFC_ISYM_UBOUND - && specific->id != GFC_ISYM_IS_CONTIGUOUS - && specific->id != GFC_ISYM_C_LOC) - { - gfc_error ("Assumed-type argument at %L is not permitted as actual" - " argument to the intrinsic %s", &a->expr->where, - gfc_current_intrinsic); - ok = false; - } - else if (a->expr->ts.type == BT_ASSUMED && a != arg) - { - gfc_error ("Assumed-type argument at %L is only permitted as " - "first actual argument to the intrinsic %s", - &a->expr->where, gfc_current_intrinsic); - ok = false; - } - else if (a->expr->rank == -1 && !specific->inquiry) - { - gfc_error ("Assumed-rank argument at %L is only permitted as actual " - "argument to intrinsic inquiry functions", - &a->expr->where); - ok = false; - } - else if (a->expr->rank == -1 && arg != a) - { - gfc_error ("Assumed-rank argument at %L is only permitted as first " - "actual argument to the intrinsic inquiry function %s", - &a->expr->where, gfc_current_intrinsic); - ok = false; - } - } - - return ok; -} - - -/* Interface to the check functions. We break apart an argument list - and call the proper check function rather than forcing each - function to manipulate the argument list. */ - -static bool -do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) -{ - gfc_expr *a1, *a2, *a3, *a4, *a5; - - if (arg == NULL) - return (*specific->check.f0) (); - - a1 = arg->expr; - arg = arg->next; - if (arg == NULL) - return (*specific->check.f1) (a1); - - a2 = arg->expr; - arg = arg->next; - if (arg == NULL) - return (*specific->check.f2) (a1, a2); - - a3 = arg->expr; - arg = arg->next; - if (arg == NULL) - return (*specific->check.f3) (a1, a2, a3); - - a4 = arg->expr; - arg = arg->next; - if (arg == NULL) - return (*specific->check.f4) (a1, a2, a3, a4); - - a5 = arg->expr; - arg = arg->next; - if (arg == NULL) - return (*specific->check.f5) (a1, a2, a3, a4, a5); - - gfc_internal_error ("do_check(): too many args"); -} - - -/*********** Subroutines to build the intrinsic list ****************/ - -/* Add a single intrinsic symbol to the current list. - - Argument list: - char * name of function - int whether function is elemental - int If the function can be used as an actual argument [1] - bt return type of function - int kind of return type of function - int Fortran standard version - check pointer to check function - simplify pointer to simplification function - resolve pointer to resolution function - - Optional arguments come in multiples of five: - char * name of argument - bt type of argument - int kind of argument - int arg optional flag (1=optional, 0=required) - sym_intent intent of argument - - The sequence is terminated by a NULL name. - - - [1] Whether a function can or cannot be used as an actual argument is - determined by its presence on the 13.6 list in Fortran 2003. The - following intrinsics, which are GNU extensions, are considered allowed - as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG - ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT. */ - -static void -add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, - int standard, gfc_check_f check, gfc_simplify_f simplify, - gfc_resolve_f resolve, ...) -{ - char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */ - int optional, first_flag; - sym_intent intent; - va_list argp; - - switch (sizing) - { - case SZ_SUBS: - nsub++; - break; - - case SZ_FUNCS: - nfunc++; - break; - - case SZ_NOTHING: - next_sym->name = gfc_get_string ("%s", name); - - strcpy (buf, "_gfortran_"); - strcat (buf, name); - next_sym->lib_name = gfc_get_string ("%s", buf); - - next_sym->pure = (cl != CLASS_IMPURE); - next_sym->elemental = (cl == CLASS_ELEMENTAL); - next_sym->inquiry = (cl == CLASS_INQUIRY); - next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL); - next_sym->actual_ok = actual_ok; - next_sym->ts.type = type; - next_sym->ts.kind = kind; - next_sym->standard = standard; - next_sym->simplify = simplify; - next_sym->check = check; - next_sym->resolve = resolve; - next_sym->specific = 0; - next_sym->generic = 0; - next_sym->conversion = 0; - next_sym->id = id; - break; - - default: - gfc_internal_error ("add_sym(): Bad sizing mode"); - } - - va_start (argp, resolve); - - first_flag = 1; - - for (;;) - { - name = va_arg (argp, char *); - if (name == NULL) - break; - - type = (bt) va_arg (argp, int); - kind = va_arg (argp, int); - optional = va_arg (argp, int); - intent = (sym_intent) va_arg (argp, int); - - if (sizing != SZ_NOTHING) - nargs++; - else - { - next_arg++; - - if (first_flag) - next_sym->formal = next_arg; - else - (next_arg - 1)->next = next_arg; - - first_flag = 0; - - strcpy (next_arg->name, name); - next_arg->ts.type = type; - next_arg->ts.kind = kind; - next_arg->optional = optional; - next_arg->value = 0; - next_arg->intent = intent; - } - } - - va_end (argp); - - next_sym++; -} - - -/* Add a symbol to the function list where the function takes - 0 arguments. */ - -static void -add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (void), - gfc_expr *(*simplify) (void), - void (*resolve) (gfc_expr *)) -{ - gfc_simplify_f sf; - gfc_check_f cf; - gfc_resolve_f rf; - - cf.f0 = check; - sf.f0 = simplify; - rf.f0 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - (void *) 0); -} - - -/* Add a symbol to the subroutine list where the subroutine takes - 0 arguments. */ - -static void -add_sym_0s (const char *name, gfc_isym_id id, int standard, - void (*resolve) (gfc_code *)) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f1 = NULL; - sf.f1 = NULL; - rf.s1 = resolve; - - add_sym (name, id, CLASS_IMPURE, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, - rf, (void *) 0); -} - - -/* Add a symbol to the function list where the function takes - 1 arguments. */ - -static void -add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f1 = check; - sf.f1 = simplify; - rf.f1 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - (void *) 0); -} - - -/* Add a symbol to the function list where the function takes - 1 arguments, specifying the intent of the argument. */ - -static void -add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl, - int actual_ok, bt type, int kind, int standard, - bool (*check) (gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f1 = check; - sf.f1 = simplify; - rf.f1 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - (void *) 0); -} - - -/* Add a symbol to the subroutine list where the subroutine takes - 1 arguments, specifying the intent of the argument. */ - -static void -add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, - int standard, bool (*check) (gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f1 = check; - sf.f1 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - (void *) 0); -} - -/* Add a symbol to the subroutine ilst where the subroutine takes one - printf-style character argument and a variable number of arguments - to follow. */ - -static void -add_sym_1p (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, - int standard, bool (*check) (gfc_actual_arglist *), - gfc_expr *(*simplify) (gfc_expr*), void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, sym_intent intent1) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f1m = check; - sf.f1 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - (void *) 0); -} - - -/* Add a symbol from the MAX/MIN family of intrinsic functions to the - function. MAX et al take 2 or more arguments. */ - -static void -add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (gfc_actual_arglist *), - gfc_expr *(*simplify) (gfc_expr *), - void (*resolve) (gfc_expr *, gfc_actual_arglist *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f1m = check; - sf.f1 = simplify; - rf.f1m = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - (void *) 0); -} - - -/* Add a symbol to the function list where the function takes - 2 arguments. */ - -static void -add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f2 = check; - sf.f2 = simplify; - rf.f2 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - (void *) 0); -} - - -/* Add a symbol to the function list where the function takes - 2 arguments; same as add_sym_2 - but allows to specify the intent. */ - -static void -add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl, - int actual_ok, bt type, int kind, int standard, - bool (*check) (gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1, const char *a2, bt type2, int kind2, - int optional2, sym_intent intent2) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f2 = check; - sf.f2 = simplify; - rf.f2 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - a2, type2, kind2, optional2, intent2, - (void *) 0); -} - - -/* Add a symbol to the subroutine list where the subroutine takes - 2 arguments, specifying the intent of the arguments. */ - -static void -add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, - int kind, int standard, - bool (*check) (gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1, const char *a2, bt type2, int kind2, - int optional2, sym_intent intent2) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f2 = check; - sf.f2 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - a2, type2, kind2, optional2, intent2, - (void *) 0); -} - - -/* Add a symbol to the function list where the function takes - 3 arguments. */ - -static void -add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f3 = check; - sf.f3 = simplify; - rf.f3 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - a3, type3, kind3, optional3, INTENT_IN, - (void *) 0); -} - - -/* MINLOC and MAXLOC get special treatment because their - argument might have to be reordered. */ - -static void -add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (gfc_actual_arglist *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3, - const char *a4, bt type4, int kind4, int optional4, - const char *a5, bt type5, int kind5, int optional5) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f5ml = check; - sf.f5 = simplify; - rf.f5 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - a3, type3, kind3, optional3, INTENT_IN, - a4, type4, kind4, optional4, INTENT_IN, - a5, type5, kind5, optional5, INTENT_IN, - (void *) 0); -} - -/* Similar for FINDLOC. */ - -static void -add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, - bt type, int kind, int standard, - bool (*check) (gfc_actual_arglist *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *, gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *, gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3, - const char *a4, bt type4, int kind4, int optional4, - const char *a5, bt type5, int kind5, int optional5, - const char *a6, bt type6, int kind6, int optional6) - -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f6fl = check; - sf.f6 = simplify; - rf.f6 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - a3, type3, kind3, optional3, INTENT_IN, - a4, type4, kind4, optional4, INTENT_IN, - a5, type5, kind5, optional5, INTENT_IN, - a6, type6, kind6, optional6, INTENT_IN, - (void *) 0); -} - - -/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because - their argument also might have to be reordered. */ - -static void -add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (gfc_actual_arglist *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f3red = check; - sf.f3 = simplify; - rf.f3 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - a3, type3, kind3, optional3, INTENT_IN, - (void *) 0); -} - - -/* Add a symbol to the subroutine list where the subroutine takes - 3 arguments, specifying the intent of the arguments. */ - -static void -add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, - int kind, int standard, - bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1, const char *a2, bt type2, int kind2, - int optional2, sym_intent intent2, const char *a3, bt type3, - int kind3, int optional3, sym_intent intent3) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f3 = check; - sf.f3 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - a2, type2, kind2, optional2, intent2, - a3, type3, kind3, optional3, intent3, - (void *) 0); -} - - -/* Add a symbol to the function list where the function takes - 4 arguments. */ - -static void -add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, - int kind, int standard, - bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *), - const char *a1, bt type1, int kind1, int optional1, - const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3, - const char *a4, bt type4, int kind4, int optional4 ) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f4 = check; - sf.f4 = simplify; - rf.f4 = resolve; - - add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, INTENT_IN, - a2, type2, kind2, optional2, INTENT_IN, - a3, type3, kind3, optional3, INTENT_IN, - a4, type4, kind4, optional4, INTENT_IN, - (void *) 0); -} - - -/* Add a symbol to the subroutine list where the subroutine takes - 4 arguments. */ - -static void -add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, - int standard, - bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1, const char *a2, bt type2, int kind2, - int optional2, sym_intent intent2, const char *a3, bt type3, - int kind3, int optional3, sym_intent intent3, const char *a4, - bt type4, int kind4, int optional4, sym_intent intent4) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f4 = check; - sf.f4 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - a2, type2, kind2, optional2, intent2, - a3, type3, kind3, optional3, intent3, - a4, type4, kind4, optional4, intent4, - (void *) 0); -} - - -/* Add a symbol to the subroutine list where the subroutine takes - 5 arguments. */ - -static void -add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, - int standard, - bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, - gfc_expr *, gfc_expr *), - void (*resolve) (gfc_code *), - const char *a1, bt type1, int kind1, int optional1, - sym_intent intent1, const char *a2, bt type2, int kind2, - int optional2, sym_intent intent2, const char *a3, bt type3, - int kind3, int optional3, sym_intent intent3, const char *a4, - bt type4, int kind4, int optional4, sym_intent intent4, - const char *a5, bt type5, int kind5, int optional5, - sym_intent intent5) -{ - gfc_check_f cf; - gfc_simplify_f sf; - gfc_resolve_f rf; - - cf.f5 = check; - sf.f5 = simplify; - rf.s1 = resolve; - - add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, - a1, type1, kind1, optional1, intent1, - a2, type2, kind2, optional2, intent2, - a3, type3, kind3, optional3, intent3, - a4, type4, kind4, optional4, intent4, - a5, type5, kind5, optional5, intent5, - (void *) 0); -} - - -/* Locate an intrinsic symbol given a base pointer, number of elements - in the table and a pointer to a name. Returns the NULL pointer if - a name is not found. */ - -static gfc_intrinsic_sym * -find_sym (gfc_intrinsic_sym *start, int n, const char *name) -{ - /* name may be a user-supplied string, so we must first make sure - that we're comparing against a pointer into the global string - table. */ - const char *p = gfc_get_string ("%s", name); - - while (n > 0) - { - if (p == start->name) - return start; - - start++; - n--; - } - - return NULL; -} - - -gfc_isym_id -gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id) -{ - if (from_intmod == INTMOD_NONE) - return (gfc_isym_id) intmod_sym_id; - else if (from_intmod == INTMOD_ISO_C_BINDING) - return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value; - else if (from_intmod == INTMOD_ISO_FORTRAN_ENV) - switch (intmod_sym_id) - { -#define NAMED_SUBROUTINE(a,b,c,d) \ - case a: \ - return (gfc_isym_id) c; -#define NAMED_FUNCTION(a,b,c,d) \ - case a: \ - return (gfc_isym_id) c; -#include "iso-fortran-env.def" - default: - gcc_unreachable (); - } - else - gcc_unreachable (); - return (gfc_isym_id) 0; -} - - -gfc_isym_id -gfc_isym_id_by_intmod_sym (gfc_symbol *sym) -{ - return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id); -} - - -gfc_intrinsic_sym * -gfc_intrinsic_subroutine_by_id (gfc_isym_id id) -{ - gfc_intrinsic_sym *start = subroutines; - int n = nsub; - - while (true) - { - gcc_assert (n > 0); - if (id == start->id) - return start; - - start++; - n--; - } -} - - -gfc_intrinsic_sym * -gfc_intrinsic_function_by_id (gfc_isym_id id) -{ - gfc_intrinsic_sym *start = functions; - int n = nfunc; - - while (true) - { - gcc_assert (n > 0); - if (id == start->id) - return start; - - start++; - n--; - } -} - - -/* Given a name, find a function in the intrinsic function table. - Returns NULL if not found. */ - -gfc_intrinsic_sym * -gfc_find_function (const char *name) -{ - gfc_intrinsic_sym *sym; - - sym = find_sym (functions, nfunc, name); - if (!sym || sym->from_module) - sym = find_sym (conversion, nconv, name); - - return (!sym || sym->from_module) ? NULL : sym; -} - - -/* Given a name, find a function in the intrinsic subroutine table. - Returns NULL if not found. */ - -gfc_intrinsic_sym * -gfc_find_subroutine (const char *name) -{ - gfc_intrinsic_sym *sym; - sym = find_sym (subroutines, nsub, name); - return (!sym || sym->from_module) ? NULL : sym; -} - - -/* Given a string, figure out if it is the name of a generic intrinsic - function or not. */ - -int -gfc_generic_intrinsic (const char *name) -{ - gfc_intrinsic_sym *sym; - - sym = gfc_find_function (name); - return (!sym || sym->from_module) ? 0 : sym->generic; -} - - -/* Given a string, figure out if it is the name of a specific - intrinsic function or not. */ - -int -gfc_specific_intrinsic (const char *name) -{ - gfc_intrinsic_sym *sym; - - sym = gfc_find_function (name); - return (!sym || sym->from_module) ? 0 : sym->specific; -} - - -/* Given a string, figure out if it is the name of an intrinsic function - or subroutine allowed as an actual argument or not. */ -int -gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag) -{ - gfc_intrinsic_sym *sym; - - /* Intrinsic subroutines are not allowed as actual arguments. */ - if (subroutine_flag) - return 0; - else - { - sym = gfc_find_function (name); - return (sym == NULL) ? 0 : sym->actual_ok; - } -} - - -/* Given a symbol, find out if it is (and is to be treated as) an intrinsic. - If its name refers to an intrinsic, but this intrinsic is not included in - the selected standard, this returns FALSE and sets the symbol's external - attribute. */ - -bool -gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) -{ - gfc_intrinsic_sym* isym; - const char* symstd; - - /* If INTRINSIC attribute is already known, return. */ - if (sym->attr.intrinsic) - return true; - - /* Check for attributes which prevent the symbol from being INTRINSIC. */ - if (sym->attr.external || sym->attr.contained - || sym->attr.if_source == IFSRC_IFBODY) - return false; - - if (subroutine_flag) - isym = gfc_find_subroutine (sym->name); - else - isym = gfc_find_function (sym->name); - - /* No such intrinsic available at all? */ - if (!isym) - return false; - - /* See if this intrinsic is allowed in the current standard. */ - if (!gfc_check_intrinsic_standard (isym, &symstd, false, loc) - && !sym->attr.artificial) - { - if (sym->attr.proc == PROC_UNKNOWN && warn_intrinsics_std) - gfc_warning_now (OPT_Wintrinsics_std, "The intrinsic %qs at %L is not " - "included in the selected standard but %s and %qs will" - " be treated as if declared EXTERNAL. Use an" - " appropriate %<-std=%>* option or define" - " %<-fall-intrinsics%> to allow this intrinsic.", - sym->name, &loc, symstd, sym->name); - - return false; - } - - return true; -} - - -/* Collect a set of intrinsic functions into a generic collection. - The first argument is the name of the generic function, which is - also the name of a specific function. The rest of the specifics - currently in the table are placed into the list of specific - functions associated with that generic. - - PR fortran/32778 - FIXME: Remove the argument STANDARD if no regressions are - encountered. Change all callers (approx. 360). -*/ - -static void -make_generic (const char *name, gfc_isym_id id, int standard ATTRIBUTE_UNUSED) -{ - gfc_intrinsic_sym *g; - - if (sizing != SZ_NOTHING) - return; - - g = gfc_find_function (name); - if (g == NULL) - gfc_internal_error ("make_generic(): Cannot find generic symbol %qs", - name); - - gcc_assert (g->id == id); - - g->generic = 1; - g->specific = 1; - if ((g + 1)->name != NULL) - g->specific_head = g + 1; - g++; - - while (g->name != NULL) - { - g->next = g + 1; - g->specific = 1; - g++; - } - - g--; - g->next = NULL; -} - - -/* Create a duplicate intrinsic function entry for the current - function, the only differences being the alternate name and - a different standard if necessary. Note that we use argument - lists more than once, but all argument lists are freed as a - single block. */ - -static void -make_alias (const char *name, int standard) -{ - switch (sizing) - { - case SZ_FUNCS: - nfunc++; - break; - - case SZ_SUBS: - nsub++; - break; - - case SZ_NOTHING: - next_sym[0] = next_sym[-1]; - next_sym->name = gfc_get_string ("%s", name); - next_sym->standard = standard; - next_sym++; - break; - - default: - break; - } -} - - -/* Make the current subroutine noreturn. */ - -static void -make_noreturn (void) -{ - if (sizing == SZ_NOTHING) - next_sym[-1].noreturn = 1; -} - - -/* Mark current intrinsic as module intrinsic. */ -static void -make_from_module (void) -{ - if (sizing == SZ_NOTHING) - next_sym[-1].from_module = 1; -} - - -/* Mark the current subroutine as having a variable number of - arguments. */ - -static void -make_vararg (void) -{ - if (sizing == SZ_NOTHING) - next_sym[-1].vararg = 1; -} - -/* Set the attr.value of the current procedure. */ - -static void -set_attr_value (int n, ...) -{ - gfc_intrinsic_arg *arg; - va_list argp; - int i; - - if (sizing != SZ_NOTHING) - return; - - va_start (argp, n); - arg = next_sym[-1].formal; - - for (i = 0; i < n; i++) - { - gcc_assert (arg != NULL); - arg->value = va_arg (argp, int); - arg = arg->next; - } - va_end (argp); -} - - -/* Add intrinsic functions. */ - -static void -add_functions (void) -{ - /* Argument names. These are used as argument keywords and so need to - match the documentation. Please keep this list in sorted order. */ - const char - *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", - *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", - *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command", - *dist = "distance", *dm = "dim", *f = "field", *failed="failed", - *fs = "fsource", *han = "handler", *i = "i", - *image = "image", *j = "j", *kind = "kind", - *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a", - *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask", - *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number", - *ord = "order", *p = "p", *p1 = "path1", *p2 = "path2", - *pad = "pad", *pid = "pid", *pos = "pos", *pt = "pointer", - *r = "r", *s = "s", *set = "set", *sh = "shift", *shp = "shape", - *sig = "sig", *src = "source", *ssg = "substring", - *sta = "string_a", *stb = "string_b", *stg = "string", - *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time", - *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", - *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", - *z = "z"; - - int di, dr, dd, dl, dc, dz, ii; - - di = gfc_default_integer_kind; - dr = gfc_default_real_kind; - dd = gfc_default_double_kind; - dl = gfc_default_logical_kind; - dc = gfc_default_character_kind; - dz = gfc_default_complex_kind; - ii = gfc_index_integer_kind; - - add_sym_1 ("abs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs, - a, BT_REAL, dr, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("babs", GFC_STD_GNU); - make_alias ("iiabs", GFC_STD_GNU); - make_alias ("jiabs", GFC_STD_GNU); - make_alias ("kiabs", GFC_STD_GNU); - } - - add_sym_1 ("iabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, - NULL, gfc_simplify_abs, gfc_resolve_abs, - a, BT_INTEGER, di, REQUIRED); - - add_sym_1 ("dabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_abs, gfc_resolve_abs, - a, BT_REAL, dd, REQUIRED); - - add_sym_1 ("cabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - NULL, gfc_simplify_abs, gfc_resolve_abs, - a, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - NULL, gfc_simplify_abs, gfc_resolve_abs, - a, BT_COMPLEX, dd, REQUIRED); - - make_alias ("cdabs", GFC_STD_GNU); - - make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77); - - /* The checking function for ACCESS is called gfc_check_access_func - because the name gfc_check_access is already used in module.c. */ - add_sym_2 ("access", GFC_ISYM_ACCESS, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_access_func, NULL, gfc_resolve_access, - nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); - - make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU); - - add_sym_2 ("achar", GFC_ISYM_ACHAR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_CHARACTER, dc, GFC_STD_F95, - gfc_check_achar, gfc_simplify_achar, gfc_resolve_achar, - i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95); - - add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_acos, gfc_resolve_acos, - x, BT_REAL, dd, REQUIRED); - - make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77); - - add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh, - gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_acosh, gfc_resolve_acosh, - x, BT_REAL, dd, REQUIRED); - - make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008); - - add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, - BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl, - gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED); - - make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95); - - add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr, - gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED); - - make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95); - - add_sym_1 ("aimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag, - z, BT_COMPLEX, dz, REQUIRED); - - make_alias ("imag", GFC_STD_GNU); - make_alias ("imagpart", GFC_STD_GNU); - - add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - NULL, gfc_simplify_aimag, gfc_resolve_aimag, - z, BT_COMPLEX, dd, REQUIRED); - - make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77); - - add_sym_2 ("aint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint, - a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - add_sym_1 ("dint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - NULL, gfc_simplify_dint, gfc_resolve_dint, - a, BT_REAL, dd, REQUIRED); - - make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77); - - add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_all_any, gfc_simplify_all, gfc_resolve_all, - msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); - - make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95); - - add_sym_1 ("allocated", GFC_ISYM_ALLOCATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_allocated, NULL, NULL, - ar, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95); - - add_sym_2 ("anint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint, - a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - add_sym_1 ("dnint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - NULL, gfc_simplify_dnint, gfc_resolve_dnint, - a, BT_REAL, dd, REQUIRED); - - make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77); - - add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_all_any, gfc_simplify_any, gfc_resolve_any, - msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); - - make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95); - - add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_asin, gfc_resolve_asin, - x, BT_REAL, dd, REQUIRED); - - make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77); - - add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh, - gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_asinh, gfc_resolve_asinh, - x, BT_REAL, dd, REQUIRED); - - make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_F2008); - - add_sym_2 ("associated", GFC_ISYM_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, - GFC_STD_F95, gfc_check_associated, NULL, NULL, - pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL); - - make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95); - - add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_atan, gfc_resolve_atan, - x, BT_REAL, dd, REQUIRED); - - /* Two-argument version of atan, equivalent to atan2. */ - add_sym_2 ("atan", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008, - gfc_check_atan_2, gfc_simplify_atan2, gfc_resolve_atan2, - y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); - - make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77); - - add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh, - gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_atanh, gfc_resolve_atanh, - x, BT_REAL, dd, REQUIRED); - - make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_F2008); - - add_sym_2 ("atan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2, - y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); - - add_sym_2 ("datan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_datan2, gfc_simplify_atan2, gfc_resolve_atan2, - y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED); - - make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77); - - /* Bessel and Neumann functions for G77 compatibility. */ - add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, - x, BT_REAL, dr, REQUIRED); - - make_alias ("bessel_j0", GFC_STD_F2008); - - add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, - x, BT_REAL, dd, REQUIRED); - - make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008); - - add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, - x, BT_REAL, dr, REQUIRED); - - make_alias ("bessel_j1", GFC_STD_F2008); - - add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, - x, BT_REAL, dd, REQUIRED); - - make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008); - - add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, - n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); - - make_alias ("bessel_jn", GFC_STD_F2008); - - add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, - n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); - - add_sym_3 ("bessel_jn", GFC_ISYM_JN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, - gfc_check_bessel_n2, gfc_simplify_bessel_jn2, gfc_resolve_bessel_n2, - "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, - x, BT_REAL, dr, REQUIRED); - set_attr_value (3, true, true, true); - - make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008); - - add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, - x, BT_REAL, dr, REQUIRED); - - make_alias ("bessel_y0", GFC_STD_F2008); - - add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, - x, BT_REAL, dd, REQUIRED); - - make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008); - - add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, - x, BT_REAL, dr, REQUIRED); - - make_alias ("bessel_y1", GFC_STD_F2008); - - add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, - x, BT_REAL, dd, REQUIRED); - - make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008); - - add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, - n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); - - make_alias ("bessel_yn", GFC_STD_F2008); - - add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, - n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); - - add_sym_3 ("bessel_yn", GFC_ISYM_YN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, - gfc_check_bessel_n2, gfc_simplify_bessel_yn2, gfc_resolve_bessel_n2, - "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, - x, BT_REAL, dr, REQUIRED); - set_attr_value (3, true, true, true); - - make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008); - - add_sym_2 ("bge", GFC_ISYM_BGE, CLASS_ELEMENTAL, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F2008, - gfc_check_bge_bgt_ble_blt, gfc_simplify_bge, NULL, - i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - - make_generic ("bge", GFC_ISYM_BGE, GFC_STD_F2008); - - add_sym_2 ("bgt", GFC_ISYM_BGT, CLASS_ELEMENTAL, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F2008, - gfc_check_bge_bgt_ble_blt, gfc_simplify_bgt, NULL, - i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - - make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008); - - add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_i, gfc_simplify_bit_size, NULL, - i, BT_INTEGER, di, REQUIRED); - - make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95); - - add_sym_2 ("ble", GFC_ISYM_BLE, CLASS_ELEMENTAL, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F2008, - gfc_check_bge_bgt_ble_blt, gfc_simplify_ble, NULL, - i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - - make_generic ("ble", GFC_ISYM_BLE, GFC_STD_F2008); - - add_sym_2 ("blt", GFC_ISYM_BLT, CLASS_ELEMENTAL, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F2008, - gfc_check_bge_bgt_ble_blt, gfc_simplify_blt, NULL, - i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - - make_generic ("blt", GFC_ISYM_BLT, GFC_STD_F2008); - - add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest, - i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bbtest", GFC_STD_GNU); - make_alias ("bitest", GFC_STD_GNU); - make_alias ("bjtest", GFC_STD_GNU); - make_alias ("bktest", GFC_STD_GNU); - } - - make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95); - - add_sym_2 ("ceiling", GFC_ISYM_CEILING, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling, - a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95); - - add_sym_2 ("char", GFC_ISYM_CHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77, - gfc_check_char, gfc_simplify_char, gfc_resolve_char, - i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77); - - add_sym_1 ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir, - nm, BT_CHARACTER, dc, REQUIRED); - - make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU); - - add_sym_2 ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_chmod, NULL, gfc_resolve_chmod, - nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); - - make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU); - - add_sym_3 ("cmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_F77, - gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx, - x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77); - - add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL); - - make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, - GFC_STD_F2003); - - add_sym_2 ("complex", GFC_ISYM_COMPLEX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU, - gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex, - x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED); - - make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU); - - /* Making dcmplx a specific of cmplx causes cmplx to return a double - complex instead of the default complex. */ - - add_sym_2 ("dcmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dd, GFC_STD_GNU, - gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx, - x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL); - - make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU); - - add_sym_1 ("conjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, - gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg, - z, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_conjg, gfc_resolve_conjg, - z, BT_COMPLEX, dd, REQUIRED); - - make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77); - - add_sym_1 ("cos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_cos, gfc_resolve_cos, - x, BT_REAL, dd, REQUIRED); - - add_sym_1 ("ccos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, - NULL, gfc_simplify_cos, gfc_resolve_cos, - x, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_cos, gfc_resolve_cos, - x, BT_COMPLEX, dd, REQUIRED); - - make_alias ("cdcos", GFC_STD_GNU); - - make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77); - - add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_cosh, gfc_resolve_cosh, - x, BT_REAL, dd, REQUIRED); - - make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77); - - add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_count, gfc_simplify_count, gfc_resolve_count, - msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95); - - add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, - BT_REAL, dr, GFC_STD_F95, - gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift, - ar, BT_REAL, dr, REQUIRED, - sh, BT_INTEGER, di, REQUIRED, - dm, BT_INTEGER, ii, OPTIONAL); - - make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95); - - add_sym_1 ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, - 0, GFC_STD_GNU, gfc_check_ctime, NULL, gfc_resolve_ctime, - tm, BT_INTEGER, di, REQUIRED); - - make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU); - - add_sym_1 ("dble", GFC_ISYM_DBLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, - gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble, - a, BT_REAL, dr, REQUIRED); - - make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77); - - add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_digits, gfc_simplify_digits, NULL, - x, BT_UNKNOWN, dr, REQUIRED); - - make_generic ("digits", GFC_ISYM_DIGITS, GFC_STD_F95); - - add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim, - x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); - - add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, - NULL, gfc_simplify_dim, gfc_resolve_dim, - x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED); - - add_sym_2 ("ddim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_x_yd, gfc_simplify_dim, gfc_resolve_dim, - x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED); - - make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77); - - add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F95, gfc_check_dot_product, gfc_simplify_dot_product, gfc_resolve_dot_product, - va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED); - - make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95); - - add_sym_2 ("dprod", GFC_ISYM_DPROD,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_dprod, gfc_simplify_dprod, gfc_resolve_dprod, - x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); - - make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77); - - add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, - BT_REAL, dd, GFC_STD_GNU, NULL, gfc_simplify_dreal, NULL, - a, BT_COMPLEX, dd, REQUIRED); - - make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU); - - add_sym_3 ("dshiftl", GFC_ISYM_DSHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_dshift, gfc_simplify_dshiftl, gfc_resolve_dshift, - i, BT_INTEGER, di, REQUIRED, - j, BT_INTEGER, di, REQUIRED, - sh, BT_INTEGER, di, REQUIRED); - - make_generic ("dshiftl", GFC_ISYM_DSHIFTL, GFC_STD_F2008); - - add_sym_3 ("dshiftr", GFC_ISYM_DSHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_dshift, gfc_simplify_dshiftr, gfc_resolve_dshift, - i, BT_INTEGER, di, REQUIRED, - j, BT_INTEGER, di, REQUIRED, - sh, BT_INTEGER, di, REQUIRED); - - make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008); - - add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_eoshift, gfc_simplify_eoshift, gfc_resolve_eoshift, - ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED, - bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); - - make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95); - - add_sym_1 ("epsilon", GFC_ISYM_EPSILON, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F95, gfc_check_fn_r, gfc_simplify_epsilon, NULL, - x, BT_REAL, dr, REQUIRED); - - make_generic ("epsilon", GFC_ISYM_EPSILON, GFC_STD_F95); - - /* G77 compatibility for the ERF() and ERFC() functions. */ - add_sym_1 ("erf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erf, - gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("derf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, - GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erf, - gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); - - make_generic ("erf", GFC_ISYM_ERF, GFC_STD_F2008); - - add_sym_1 ("erfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erfc, - gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("derfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, - GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erfc, - gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); - - make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_F2008); - - add_sym_1 ("erfc_scaled", GFC_ISYM_ERFC_SCALED, CLASS_ELEMENTAL, ACTUAL_NO, - BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r, - gfc_simplify_erfc_scaled, gfc_resolve_g77_math1, x, BT_REAL, - dr, REQUIRED); - - make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008); - - /* G77 compatibility */ - add_sym_1 ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, - 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, - x, BT_REAL, 4, REQUIRED); - - make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU); - - add_sym_1 ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, - 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, - x, BT_REAL, 4, REQUIRED); - - make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU); - - add_sym_1 ("exp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_exp, gfc_resolve_exp, - x, BT_REAL, dd, REQUIRED); - - add_sym_1 ("cexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, - NULL, gfc_simplify_exp, gfc_resolve_exp, - x, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_exp, gfc_resolve_exp, - x, BT_COMPLEX, dd, REQUIRED); - - make_alias ("cdexp", GFC_STD_GNU); - - make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77); - - add_sym_1 ("exponent", GFC_ISYM_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_F95, gfc_check_fn_r, gfc_simplify_exponent, gfc_resolve_exponent, - x, BT_REAL, dr, REQUIRED); - - make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95); - - add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY, - ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_same_type_as, gfc_simplify_extends_type_of, - gfc_resolve_extends_type_of, - a, BT_UNKNOWN, 0, REQUIRED, - mo, BT_UNKNOWN, 0, REQUIRED); - - add_sym_2 ("failed_images", GFC_ISYM_FAILED_IMAGES, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2018, - gfc_check_failed_or_stopped_images, - gfc_simplify_failed_or_stopped_images, - gfc_resolve_failed_images, team, BT_VOID, di, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, - dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate); - - make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU); - - add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor, - a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95); - - /* G77 compatible fnum */ - add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum, - ut, BT_INTEGER, di, REQUIRED); - - make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU); - - add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F95, gfc_check_fn_r, gfc_simplify_fraction, gfc_resolve_fraction, - x, BT_REAL, dr, REQUIRED); - - make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95); - - add_sym_2_intent ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_GNU, - gfc_check_fstat, NULL, gfc_resolve_fstat, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); - - make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU); - - add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell, - ut, BT_INTEGER, di, REQUIRED); - - make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU); - - add_sym_2_intent ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_GNU, - gfc_check_fgetputc, NULL, gfc_resolve_fgetc, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU); - - add_sym_1_intent ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU); - - add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc, - ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED); - - make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU); - - add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput, - c, BT_CHARACTER, dc, REQUIRED); - - make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU); - - add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma, - gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma, - x, BT_REAL, dr, REQUIRED); - - make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008); - - /* Unix IDs (g77 compatibility) */ - add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd, - c, BT_CHARACTER, dc, REQUIRED); - - make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU); - - add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid); - - make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU); - - add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid); - - make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); - - add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, - gfc_check_get_team, NULL, gfc_resolve_get_team, - level, BT_INTEGER, di, OPTIONAL); - - add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); - - make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU); - - add_sym_1_intent ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_GNU, - gfc_check_hostnm, NULL, gfc_resolve_hostnm, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU); - - add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_huge, gfc_simplify_huge, NULL, - x, BT_UNKNOWN, dr, REQUIRED); - - make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95); - - add_sym_2 ("hypot", GFC_ISYM_HYPOT, CLASS_ELEMENTAL, ACTUAL_NO, - BT_REAL, dr, GFC_STD_F2008, - gfc_check_hypot, gfc_simplify_hypot, gfc_resolve_hypot, - x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); - - make_generic ("hypot", GFC_ISYM_HYPOT, GFC_STD_F2008); - - add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar, - c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95); - - add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_F95, - gfc_check_iand_ieor_ior, gfc_simplify_iand, gfc_resolve_iand, - i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("biand", GFC_STD_GNU); - make_alias ("iiand", GFC_STD_GNU); - make_alias ("jiand", GFC_STD_GNU); - make_alias ("kiand", GFC_STD_GNU); - } - - make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95); - - add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, - dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and, - i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU); - - add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, - gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008); - - add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, - gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008); - - add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, NULL); - - make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU); - - add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr, - i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bbclr", GFC_STD_GNU); - make_alias ("iibclr", GFC_STD_GNU); - make_alias ("jibclr", GFC_STD_GNU); - make_alias ("kibclr", GFC_STD_GNU); - } - - make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95); - - add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits, - i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED, - ln, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bbits", GFC_STD_GNU); - make_alias ("iibits", GFC_STD_GNU); - make_alias ("jibits", GFC_STD_GNU); - make_alias ("kibits", GFC_STD_GNU); - } - - make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95); - - add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset, - i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bbset", GFC_STD_GNU); - make_alias ("iibset", GFC_STD_GNU); - make_alias ("jibset", GFC_STD_GNU); - make_alias ("kibset", GFC_STD_GNU); - } - - make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95); - - add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F77, - gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar, - c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77); - - add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_F95, - gfc_check_iand_ieor_ior, gfc_simplify_ieor, gfc_resolve_ieor, - i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bieor", GFC_STD_GNU); - make_alias ("iieor", GFC_STD_GNU); - make_alias ("jieor", GFC_STD_GNU); - make_alias ("kieor", GFC_STD_GNU); - } - - make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95); - - add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, - dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor, - i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU); - - add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno); - - make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); - - add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, - ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); - - add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status, - gfc_simplify_image_status, gfc_resolve_image_status, image, - BT_INTEGER, di, REQUIRED, team, BT_VOID, di, OPTIONAL); - - /* The resolution function for INDEX is called gfc_resolve_index_func - because the name gfc_resolve_index is already used in resolve.c. */ - add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, - BT_INTEGER, di, GFC_STD_F77, - gfc_check_index, gfc_simplify_index, gfc_resolve_index_func, - stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, - bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77); - - add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, - gfc_check_int, gfc_simplify_int, gfc_resolve_int, - a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, - NULL, gfc_simplify_ifix, NULL, - a, BT_REAL, dr, REQUIRED); - - add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, - NULL, gfc_simplify_idint, NULL, - a, BT_REAL, dd, REQUIRED); - - make_generic ("int", GFC_ISYM_INT, GFC_STD_F77); - - add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2, - a, BT_REAL, dr, REQUIRED); - - make_alias ("short", GFC_STD_GNU); - - make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU); - - add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8, - a, BT_REAL, dr, REQUIRED); - - make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU); - - add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, - gfc_check_intconv, gfc_simplify_long, gfc_resolve_long, - a, BT_REAL, dr, REQUIRED); - - make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU); - - add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_F95, - gfc_check_iand_ieor_ior, gfc_simplify_ior, gfc_resolve_ior, - i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bior", GFC_STD_GNU); - make_alias ("iior", GFC_STD_GNU); - make_alias ("jior", GFC_STD_GNU); - make_alias ("kior", GFC_STD_GNU); - } - - make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95); - - add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, - dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or, - i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU); - - add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, - gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008); - - /* The following function is for G77 compatibility. */ - add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - 4, GFC_STD_GNU, gfc_check_irand, NULL, NULL, - i, BT_INTEGER, 4, OPTIONAL); - - make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU); - - add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, - dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty, - ut, BT_INTEGER, di, REQUIRED); - - make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU); - - add_sym_1 ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, CLASS_INQUIRY, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F2008, - gfc_check_is_contiguous, gfc_simplify_is_contiguous, - gfc_resolve_is_contiguous, - ar, BT_REAL, dr, REQUIRED); - - make_generic ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, GFC_STD_F2008); - - add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, - CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_i, gfc_simplify_is_iostat_end, NULL, - i, BT_INTEGER, 0, REQUIRED); - - make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003); - - add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, - CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_i, gfc_simplify_is_iostat_eor, NULL, - i, BT_INTEGER, 0, REQUIRED); - - make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003); - - add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_GNU, - gfc_check_isnan, gfc_simplify_isnan, NULL, - x, BT_REAL, 0, REQUIRED); - - make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU); - - add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_GNU, - gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift, - i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); - - make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU); - - add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_GNU, - gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift, - i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); - - make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU); - - add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft, - i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bshft", GFC_STD_GNU); - make_alias ("iishft", GFC_STD_GNU); - make_alias ("jishft", GFC_STD_GNU); - make_alias ("kishft", GFC_STD_GNU); - } - - make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95); - - add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc, - i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED, - sz, BT_INTEGER, di, OPTIONAL); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bshftc", GFC_STD_GNU); - make_alias ("iishftc", GFC_STD_GNU); - make_alias ("jishftc", GFC_STD_GNU); - make_alias ("kishftc", GFC_STD_GNU); - } - - make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95); - - add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_kill, NULL, NULL, - pid, BT_INTEGER, di, REQUIRED, sig, BT_INTEGER, di, REQUIRED); - - make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU); - - add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_kind, gfc_simplify_kind, NULL, - x, BT_REAL, dr, REQUIRED); - - make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95); - - add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95); - - add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound, - ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008); - - add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_i, gfc_simplify_leadz, NULL, - i, BT_INTEGER, di, REQUIRED); - - make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008); - - add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES, - BT_INTEGER, di, GFC_STD_F77, - gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len, - stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77); - - add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim, - stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_alias ("lnblnk", GFC_STD_GNU); - - make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95); - - add_sym_1 ("lgamma", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, - dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma, - x, BT_REAL, dr, REQUIRED); - - make_alias ("log_gamma", GFC_STD_F2008); - - add_sym_1 ("algama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dlgama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_lgamma, gfc_resolve_lgamma, - x, BT_REAL, dr, REQUIRED); - - make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008); - - - add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, - GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL, - sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); - - make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77); - - add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, - GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL, - sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); - - make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77); - - add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, - GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL, - sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); - - make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77); - - add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, - GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL, - sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); - - make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77); - - add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link, - p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); - - make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU); - - add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - NULL, gfc_simplify_log, gfc_resolve_log, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_log, gfc_resolve_log, - x, BT_REAL, dd, REQUIRED); - - add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, - NULL, gfc_simplify_log, gfc_resolve_log, - x, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_log, gfc_resolve_log, - x, BT_COMPLEX, dd, REQUIRED); - - make_alias ("cdlog", GFC_STD_GNU); - - make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77); - - add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - NULL, gfc_simplify_log10, gfc_resolve_log10, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_log10, gfc_resolve_log10, - x, BT_REAL, dd, REQUIRED); - - make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77); - - add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, - gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical, - l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95); - - add_sym_2_intent ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_GNU, - gfc_check_stat, NULL, gfc_resolve_lstat, - nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); - - make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU); - - add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, - GFC_STD_GNU, gfc_check_malloc, NULL, NULL, - sz, BT_INTEGER, di, REQUIRED); - - make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU); - - add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask, - i, BT_INTEGER, di, REQUIRED, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008); - - add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask, - i, BT_INTEGER, di, REQUIRED, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008); - - add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul, - ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED); - - make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95); - - /* Note: amax0 is equivalent to real(max), max1 is equivalent to - int(max). The max function must take at least two arguments. */ - - add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77, - gfc_check_min_max, gfc_simplify_max, gfc_resolve_max, - a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED); - - add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, - gfc_check_min_max_integer, gfc_simplify_max, NULL, - a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); - - add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_min_max_integer, gfc_simplify_max, NULL, - a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); - - add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_min_max_real, gfc_simplify_max, NULL, - a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); - - add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, - gfc_check_min_max_real, gfc_simplify_max, NULL, - a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); - - add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, - gfc_check_min_max_double, gfc_simplify_max, NULL, - a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED); - - make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77); - - add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_F95, gfc_check_fn_r, gfc_simplify_maxexponent, NULL, - x, BT_UNKNOWN, dr, REQUIRED); - - make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95); - - add_sym_5ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_minloc_maxloc, gfc_simplify_maxloc, gfc_resolve_maxloc, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL, - bck, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95); - - add_sym_6fl ("findloc", GFC_ISYM_FINDLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_findloc, gfc_simplify_findloc, gfc_resolve_findloc, - ar, BT_REAL, dr, REQUIRED, val, BT_REAL, dr, REQUIRED, - dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL, bck, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("findloc", GFC_ISYM_FINDLOC, GFC_STD_F2008); - - add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95); - - add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock); - - make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU); - - add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8); - - make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU); - - add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_merge, gfc_simplify_merge, gfc_resolve_merge, - ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED, - msk, BT_LOGICAL, dl, REQUIRED); - - make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95); - - add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_merge_bits, gfc_simplify_merge_bits, - gfc_resolve_merge_bits, - i, BT_INTEGER, di, REQUIRED, - j, BT_INTEGER, di, REQUIRED, - msk, BT_INTEGER, di, REQUIRED); - - make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008); - - /* Note: amin0 is equivalent to real(min), min1 is equivalent to - int(min). */ - - add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77, - gfc_check_min_max, gfc_simplify_min, gfc_resolve_min, - a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); - - add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, - gfc_check_min_max_integer, gfc_simplify_min, NULL, - a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); - - add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_min_max_integer, gfc_simplify_min, NULL, - a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); - - add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_min_max_real, gfc_simplify_min, NULL, - a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); - - add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, - gfc_check_min_max_real, gfc_simplify_min, NULL, - a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); - - add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, - gfc_check_min_max_double, gfc_simplify_min, NULL, - a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED); - - make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77); - - add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_F95, gfc_check_fn_r, gfc_simplify_minexponent, NULL, - x, BT_UNKNOWN, dr, REQUIRED); - - make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95); - - add_sym_5ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_minloc_maxloc, gfc_simplify_minloc, gfc_resolve_minloc, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL, - bck, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95); - - add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95); - - add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, - gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod, - a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bmod", GFC_STD_GNU); - make_alias ("imod", GFC_STD_GNU); - make_alias ("jmod", GFC_STD_GNU); - make_alias ("kmod", GFC_STD_GNU); - } - - add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - NULL, gfc_simplify_mod, gfc_resolve_mod, - a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED); - - add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_x_yd, gfc_simplify_mod, gfc_resolve_mod, - a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED); - - make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77); - - add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95, - gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo, - a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED); - - make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95); - - add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest, - x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED); - - make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95); - - add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc, - GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL, - a, BT_CHARACTER, dc, REQUIRED); - - make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003); - - add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, - gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint, - a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, - gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint, - a, BT_REAL, dd, REQUIRED); - - make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77); - - add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_i, gfc_simplify_not, gfc_resolve_not, - i, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bnot", GFC_STD_GNU); - make_alias ("inot", GFC_STD_GNU); - make_alias ("jnot", GFC_STD_GNU); - make_alias ("knot", GFC_STD_GNU); - } - - make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95); - - add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2, - x, BT_REAL, dr, REQUIRED, - dm, BT_INTEGER, ii, OPTIONAL); - - make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008); - - add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_null, gfc_simplify_null, NULL, - mo, BT_INTEGER, di, OPTIONAL); - - make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); - - add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_num_images, gfc_simplify_num_images, NULL, - dist, BT_INTEGER, di, OPTIONAL, - failed, BT_LOGICAL, dl, OPTIONAL); - - add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack, - ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, - v, BT_REAL, dr, OPTIONAL); - - make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95); - - - add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, - GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity, - msk, BT_LOGICAL, dl, REQUIRED, - dm, BT_INTEGER, ii, OPTIONAL); - - make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008); - - add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_i, gfc_simplify_popcnt, NULL, - i, BT_INTEGER, di, REQUIRED); - - make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008); - - add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_i, gfc_simplify_poppar, NULL, - i, BT_INTEGER, di, REQUIRED); - - make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008); - - add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_precision, gfc_simplify_precision, NULL, - x, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95); - - add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL, - a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN); - - make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95); - - add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95); - - add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_radix, gfc_simplify_radix, NULL, - x, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95); - - /* The following function is for G77 compatibility. */ - add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, - 4, GFC_STD_GNU, gfc_check_rand, NULL, NULL, - i, BT_INTEGER, 4, OPTIONAL); - - /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran() - use slightly different shoddy multiplicative congruential PRNG. */ - make_alias ("ran", GFC_STD_GNU); - - make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU); - - add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_range, gfc_simplify_range, NULL, - x, BT_REAL, dr, REQUIRED); - - make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95); - - add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_F2018, gfc_check_rank, gfc_simplify_rank, gfc_resolve_rank, - a, BT_REAL, dr, REQUIRED); - make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2018); - - add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_real, gfc_simplify_real, gfc_resolve_real, - a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77); - - /* This provides compatibility with g77. */ - add_sym_1 ("realpart", GFC_ISYM_REALPART, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart, - a, BT_UNKNOWN, dr, REQUIRED); - - make_generic ("realpart", GFC_ISYM_REALPART, GFC_STD_F77); - - add_sym_1 ("float", GFC_ISYM_FLOAT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_float, gfc_simplify_float, NULL, - a, BT_INTEGER, di, REQUIRED); - - if (flag_dec_intrinsic_ints) - { - make_alias ("floati", GFC_STD_GNU); - make_alias ("floatj", GFC_STD_GNU); - make_alias ("floatk", GFC_STD_GNU); - } - - make_generic ("float", GFC_ISYM_FLOAT, GFC_STD_F77); - - add_sym_1 ("dfloat", GFC_ISYM_DFLOAT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, - gfc_check_float, gfc_simplify_dble, gfc_resolve_dble, - a, BT_REAL, dr, REQUIRED); - - make_generic ("dfloat", GFC_ISYM_DFLOAT, GFC_STD_F77); - - add_sym_1 ("sngl", GFC_ISYM_SNGL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, - gfc_check_sngl, gfc_simplify_sngl, NULL, - a, BT_REAL, dd, REQUIRED); - - make_generic ("sngl", GFC_ISYM_SNGL, GFC_STD_F77); - - add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename, - p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); - - make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU); - - add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, - gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat, - stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED); - - make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95); - - add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape, - src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED, - pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL); - - make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95); - - add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F95, gfc_check_fn_r, gfc_simplify_rrspacing, gfc_resolve_rrspacing, - x, BT_REAL, dr, REQUIRED); - - make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95); - - add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F2003, - gfc_check_same_type_as, gfc_simplify_same_type_as, NULL, - a, BT_UNKNOWN, 0, REQUIRED, - b, BT_UNKNOWN, 0, REQUIRED); - - add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale, - x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); - - make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95); - - add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan, - stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED, - bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95); - - /* Added for G77 compatibility garbage. */ - add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, - 4, GFC_STD_GNU, NULL, NULL, NULL); - - make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU); - - /* Added for G77 compatibility. */ - add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL, - dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds, - x, BT_REAL, dr, REQUIRED); - - make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU); - - add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, - gfc_check_selected_char_kind, gfc_simplify_selected_char_kind, - NULL, nm, BT_CHARACTER, dc, REQUIRED); - - make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003); - - add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_F95, gfc_check_selected_int_kind, - gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED); - - make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); - - add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_F95, gfc_check_selected_real_kind, - gfc_simplify_selected_real_kind, NULL, - p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL, - "radix", BT_INTEGER, di, OPTIONAL); - - make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95); - - add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_set_exponent, gfc_simplify_set_exponent, - gfc_resolve_set_exponent, - x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); - - make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95); - - add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape, - src, BT_REAL, dr, REQUIRED, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95); - - add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift, - i, BT_INTEGER, di, REQUIRED, - sh, BT_INTEGER, di, REQUIRED); - - make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008); - - add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift, - i, BT_INTEGER, di, REQUIRED, - sh, BT_INTEGER, di, REQUIRED); - - make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008); - - add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift, - i, BT_INTEGER, di, REQUIRED, - sh, BT_INTEGER, di, REQUIRED); - - make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008); - - add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign, - a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED); - - add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, - NULL, gfc_simplify_sign, gfc_resolve_sign, - a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED); - - add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_x_yd, gfc_simplify_sign, gfc_resolve_sign, - a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED); - - make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77); - - add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal, - num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED); - - make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU); - - add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_sin, gfc_resolve_sin, - x, BT_REAL, dd, REQUIRED); - - add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, - NULL, gfc_simplify_sin, gfc_resolve_sin, - x, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_sin, gfc_resolve_sin, - x, BT_COMPLEX, dd, REQUIRED); - - make_alias ("cdsin", GFC_STD_GNU); - - make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77); - - add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_sinh, gfc_resolve_sinh, - x, BT_REAL, dd, REQUIRED); - - make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77); - - add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_size, gfc_simplify_size, gfc_resolve_size, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95); - - /* Obtain the stride for a given dimensions; to be used only internally. - "make_from_module" makes it inaccessible for external users. */ - add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU, - NULL, NULL, gfc_resolve_stride, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); - make_from_module(); - - add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, ii, GFC_STD_GNU, - gfc_check_sizeof, gfc_simplify_sizeof, NULL, - x, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU); - - /* The following functions are part of ISO_C_BINDING. */ - add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, - BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL, - c_ptr_1, BT_VOID, 0, REQUIRED, - c_ptr_2, BT_VOID, 0, OPTIONAL); - make_from_module(); - - add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO, - BT_VOID, 0, GFC_STD_F2003, - gfc_check_c_loc, NULL, gfc_resolve_c_loc, - x, BT_UNKNOWN, 0, REQUIRED); - make_from_module(); - - add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO, - BT_VOID, 0, GFC_STD_F2003, - gfc_check_c_funloc, NULL, gfc_resolve_c_funloc, - x, BT_UNKNOWN, 0, REQUIRED); - make_from_module(); - - add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008, - gfc_check_c_sizeof, gfc_simplify_sizeof, NULL, - x, BT_UNKNOWN, 0, REQUIRED); - make_from_module(); - - /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */ - add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY, - ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008, - NULL, gfc_simplify_compiler_options, NULL); - make_from_module(); - - add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_INQUIRY, - ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008, - NULL, gfc_simplify_compiler_version, NULL); - make_from_module(); - - add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, - GFC_STD_F95, gfc_check_fn_r, gfc_simplify_spacing, gfc_resolve_spacing, - x, BT_REAL, dr, REQUIRED); - - make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95); - - add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread, - src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED, - ncopies, BT_INTEGER, di, REQUIRED); - - make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95); - - add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt, - x, BT_REAL, dd, REQUIRED); - - add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, - NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, - x, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, - x, BT_COMPLEX, dd, REQUIRED); - - make_alias ("cdsqrt", GFC_STD_GNU); - - make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77); - - add_sym_2_intent ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_GNU, - gfc_check_stat, NULL, gfc_resolve_stat, - nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); - - make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU); - - add_sym_2 ("stopped_images", GFC_ISYM_STOPPED_IMAGES, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2018, - gfc_check_failed_or_stopped_images, - gfc_simplify_failed_or_stopped_images, - gfc_resolve_stopped_images, team, BT_VOID, di, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_storage_size, gfc_simplify_storage_size, - gfc_resolve_storage_size, - a, BT_UNKNOWN, 0, REQUIRED, - kind, BT_INTEGER, di, OPTIONAL); - - add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); - - make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95); - - add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk, - p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); - - make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU); - - add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, NULL, NULL, NULL, - com, BT_CHARACTER, dc, REQUIRED); - - make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU); - - add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan, - x, BT_REAL, dd, REQUIRED); - - make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77); - - add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, - gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, - gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh, - x, BT_REAL, dd, REQUIRED); - - make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); - - add_sym_1 ("team_number", GFC_ISYM_TEAM_NUMBER, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, - gfc_check_team_number, NULL, gfc_resolve_team_number, - team, BT_DERIVED, di, OPTIONAL); - - add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, - ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, - dist, BT_INTEGER, di, OPTIONAL); - - add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); - - make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU); - - add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8); - - make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU); - - add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_fn_r, gfc_simplify_tiny, NULL, x, BT_REAL, dr, REQUIRED); - - make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95); - - add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_i, gfc_simplify_trailz, NULL, - i, BT_INTEGER, di, REQUIRED); - - make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008); - - add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer, - src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED, - sz, BT_INTEGER, di, OPTIONAL); - - make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95); - - add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_transpose, gfc_simplify_transpose, gfc_resolve_transpose, - m, BT_REAL, dr, REQUIRED); - - make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95); - - add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, - gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim, - stg, BT_CHARACTER, dc, REQUIRED); - - make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95); - - add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, - 0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam, - ut, BT_INTEGER, di, REQUIRED); - - make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU); - - add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound, - ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95); - - add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, - gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound, - ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008); - - /* g77 compatibility for UMASK. */ - add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, - GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask, - msk, BT_INTEGER, di, REQUIRED); - - make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU); - - /* g77 compatibility for UNLINK. */ - add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, - di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink, - "path", BT_CHARACTER, dc, REQUIRED); - - make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU); - - add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack, - v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, - f, BT_REAL, dr, REQUIRED); - - make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95); - - add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify, - stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED, - bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); - - make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95); - - add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, - GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc, - x, BT_UNKNOWN, 0, REQUIRED); - - make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU); - - - /* The next of intrinsic subprogram are the degree trignometric functions. - These were hidden behind the -fdec-math option, but are now simply - included as extensions to the set of intrinsic subprograms. */ - - add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_GNU); - - add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_GNU); - - add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - make_generic ("atand", GFC_ISYM_ATAND, GFC_STD_GNU); - - add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2, - y, BT_REAL, dr, REQUIRED, - x, BT_REAL, dr, REQUIRED); - - add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trigd2, - y, BT_REAL, dd, REQUIRED, - x, BT_REAL, dd, REQUIRED); - - make_generic ("atan2d", GFC_ISYM_ATAN2D, GFC_STD_GNU); - - add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_GNU); - - add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_COMPLEX, dz, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, - x, BT_COMPLEX, dz, REQUIRED); - - add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, - BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, - x, BT_COMPLEX, dd, REQUIRED); - - make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU); - - add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU); - - add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - make_generic ("sind", GFC_ISYM_SIND, GFC_STD_GNU); - - add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd, - x, BT_REAL, dr, REQUIRED); - - add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, - BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trigd, - x, BT_REAL, dd, REQUIRED); - - make_generic ("tand", GFC_ISYM_TAND, GFC_STD_GNU); - - /* The following function is internally used for coarray libray functions. - "make_from_module" makes it inaccessible for external users. */ - add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO, - BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL, - x, BT_REAL, dr, REQUIRED); - make_from_module(); -} - - -/* Add intrinsic subroutines. */ - -static void -add_subroutines (void) -{ - /* Argument names. These are used as argument keywords and so need to - match the documentation. Please keep this list in sorted order. */ - static const char - *a = "a", *c_ = "c", *c = "count", *cm = "count_max", *com = "command", - *cr = "count_rate", *dt = "date", *errmsg = "errmsg", *f = "from", - *fp = "frompos", *gt = "get", *h = "harvest", *han = "handler", - *length = "length", *ln = "len", *md = "mode", *msk = "mask", - *name = "name", *num = "number", *of = "offset", *old = "old", - *p1 = "path1", *p2 = "path2", *pid = "pid", *pos = "pos", - *pt = "put", *ptr = "ptr", *res = "result", - *result_image = "result_image", *sec = "seconds", *sig = "sig", - *st = "status", *stat = "stat", *sz = "size", *t = "to", - *tm = "time", *tp = "topos", *trim_name = "trim_name", *ut = "unit", - *val = "value", *vl = "values", *whence = "whence", *zn = "zone"; - - int di, dr, dc, dl, ii; - - di = gfc_default_integer_kind; - dr = gfc_default_real_kind; - dc = gfc_default_character_kind; - dl = gfc_default_logical_kind; - ii = gfc_index_integer_kind; - - add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL); - - make_noreturn(); - - add_sym_3s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2008, - gfc_check_atomic_def, NULL, gfc_resolve_atomic_def, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2008, - gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref, - "value", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "atom", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_5s ("atomic_cas", GFC_ISYM_ATOMIC_CAS, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_cas, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_INOUT, - "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "compare", BT_INTEGER, di, REQUIRED, INTENT_IN, - "new", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("atomic_add", GFC_ISYM_ATOMIC_ADD, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("atomic_and", GFC_ISYM_ATOMIC_AND, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("atomic_or", GFC_ISYM_ATOMIC_OR, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("atomic_xor", GFC_ISYM_ATOMIC_XOR, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_4s ("atomic_fetch_add", GFC_ISYM_ATOMIC_FETCH_ADD, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_fetch_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_4s ("atomic_fetch_and", GFC_ISYM_ATOMIC_FETCH_AND, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_fetch_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_4s ("atomic_fetch_or", GFC_ISYM_ATOMIC_FETCH_OR, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_fetch_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_4s ("atomic_fetch_xor", GFC_ISYM_ATOMIC_FETCH_XOR, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_atomic_fetch_op, NULL, NULL, - "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN, - "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL); - - add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time, - tm, BT_REAL, dr, REQUIRED, INTENT_OUT); - - add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_event_query, NULL, gfc_resolve_event_query, - "event", BT_INTEGER, di, REQUIRED, INTENT_IN, - c, BT_INTEGER, di, OPTIONAL, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - /* More G77 compatibility garbage. */ - add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub, - tm, BT_INTEGER, di, REQUIRED, INTENT_IN, - res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_itime_idate, NULL, gfc_resolve_idate, - vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); - - add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_itime_idate, NULL, gfc_resolve_itime, - vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); - - add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime, - tm, BT_INTEGER, di, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); - - add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime, - tm, BT_INTEGER, di, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); - - add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub, - tm, BT_REAL, dr, REQUIRED, INTENT_OUT); - - add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub, - name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub, - name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - md, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN, - 0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL, - dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, - tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, - zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, - vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - /* More G77 compatibility garbage. */ - add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub, - vl, BT_REAL, 4, REQUIRED, INTENT_OUT, - tm, BT_REAL, 4, REQUIRED, INTENT_OUT); - - add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub, - vl, BT_REAL, 4, REQUIRED, INTENT_OUT, - tm, BT_REAL, 4, REQUIRED, INTENT_OUT); - - add_sym_5s ("execute_command_line", GFC_ISYM_EXECUTE_COMMAND_LINE, - CLASS_IMPURE , BT_UNKNOWN, 0, GFC_STD_F2008, - NULL, NULL, gfc_resolve_execute_command_line, - "command", BT_CHARACTER, dc, REQUIRED, INTENT_IN, - "wait", BT_LOGICAL, dl, OPTIONAL, INTENT_IN, - "exitstat", BT_INTEGER, di, OPTIONAL, INTENT_INOUT, - "cmdstat", BT_INTEGER, di, OPTIONAL, INTENT_OUT, - "cmdmsg", BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); - - add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub, - dt, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN, - 0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror, - res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN, - 0, GFC_STD_GNU, NULL, NULL, NULL, - name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN, - 0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg, - pos, BT_INTEGER, di, REQUIRED, INTENT_IN, - val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN, - 0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - /* F2003 commandline routines. */ - - add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2003, - NULL, NULL, gfc_resolve_get_command, - com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, - length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, - CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL, - gfc_resolve_get_command_argument, - num, BT_INTEGER, di, REQUIRED, INTENT_IN, - val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, - length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - /* F2003 subroutine to get environment variables. */ - - add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, - CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, - NULL, NULL, gfc_resolve_get_environment_variable, - name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, - length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN); - - add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, - GFC_STD_F2003, - gfc_check_move_alloc, NULL, NULL, - f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, - t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); - - add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, - GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits, - f, BT_INTEGER, di, REQUIRED, INTENT_IN, - fp, BT_INTEGER, di, REQUIRED, INTENT_IN, - ln, BT_INTEGER, di, REQUIRED, INTENT_IN, - t, BT_INTEGER, di, REQUIRED, INTENT_INOUT, - tp, BT_INTEGER, di, REQUIRED, INTENT_IN); - - if (flag_dec_intrinsic_ints) - { - make_alias ("bmvbits", GFC_STD_GNU); - make_alias ("imvbits", GFC_STD_GNU); - make_alias ("jmvbits", GFC_STD_GNU); - make_alias ("kmvbits", GFC_STD_GNU); - } - - add_sym_2s ("random_init", GFC_ISYM_RANDOM_INIT, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_random_init, NULL, gfc_resolve_random_init, - "repeatable", BT_LOGICAL, dl, REQUIRED, INTENT_IN, - "image_distinct", BT_LOGICAL, dl, REQUIRED, INTENT_IN); - - add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F95, - gfc_check_random_number, NULL, gfc_resolve_random_number, - h, BT_REAL, dr, REQUIRED, INTENT_OUT); - - add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F95, - gfc_check_random_seed, NULL, gfc_resolve_random_seed, - sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - pt, BT_INTEGER, di, OPTIONAL, INTENT_IN, - gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - /* The following subroutines are part of ISO_C_BINDING. */ - - add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL, - "cptr", BT_VOID, 0, REQUIRED, INTENT_IN, - "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT, - "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN); - make_from_module(); - - add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer, - NULL, NULL, - "cptr", BT_VOID, 0, REQUIRED, INTENT_IN, - "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); - make_from_module(); - - /* Internal subroutine for emitting a runtime error. */ - - add_sym_1p ("fe_runtime_error", GFC_ISYM_FE_RUNTIME_ERROR, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fe_runtime_error, NULL, gfc_resolve_fe_runtime_error, - "msg", BT_CHARACTER, dc, REQUIRED, INTENT_IN); - - make_noreturn (); - make_vararg (); - make_from_module (); - - /* Coarray collectives. */ - add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_co_broadcast, NULL, NULL, - a, BT_REAL, dr, REQUIRED, INTENT_INOUT, - "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); - - add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_co_minmax, NULL, NULL, - a, BT_REAL, dr, REQUIRED, INTENT_INOUT, - result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); - - add_sym_4s ("co_min", GFC_ISYM_CO_MIN, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_co_minmax, NULL, NULL, - a, BT_REAL, dr, REQUIRED, INTENT_INOUT, - result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); - - add_sym_4s ("co_sum", GFC_ISYM_CO_SUM, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_co_sum, NULL, NULL, - a, BT_REAL, dr, REQUIRED, INTENT_INOUT, - result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); - - add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F2018, - gfc_check_co_reduce, NULL, NULL, - a, BT_REAL, dr, REQUIRED, INTENT_INOUT, - "operation", BT_INTEGER, di, REQUIRED, INTENT_IN, - result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, - stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); - - - /* The following subroutine is internally used for coarray libray functions. - "make_from_module" makes it inaccessible for external users. */ - add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL, - "x", BT_REAL, dr, REQUIRED, INTENT_OUT, - "y", BT_REAL, dr, REQUIRED, INTENT_IN); - make_from_module(); - - - /* More G77 compatibility garbage. */ - add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub, - sec, BT_INTEGER, di, REQUIRED, INTENT_IN, - han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN, - di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand, - "seed", BT_INTEGER, 4, REQUIRED, INTENT_IN); - - add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_exit, NULL, gfc_resolve_exit, - st, BT_INTEGER, di, OPTIONAL, INTENT_IN); - - make_noreturn(); - - add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub, - c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_flush, NULL, gfc_resolve_flush, - ut, BT_INTEGER, di, OPTIONAL, INTENT_IN); - - add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub, - c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_free, NULL, NULL, - ptr, BT_INTEGER, ii, REQUIRED, INTENT_INOUT); - - add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - of, BT_INTEGER, di, REQUIRED, INTENT_IN, - whence, BT_INTEGER, di, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - of, BT_INTEGER, ii, REQUIRED, INTENT_OUT); - - add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub, - c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_kill_sub, NULL, NULL, - pid, BT_INTEGER, di, REQUIRED, INTENT_IN, - sig, BT_INTEGER, di, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_link_sub, NULL, gfc_resolve_link_sub, - p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN, - 0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror, - "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN); - - add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub, - p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub, - sec, BT_INTEGER, di, REQUIRED, INTENT_IN); - - add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub, - name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_stat_sub, NULL, gfc_resolve_stat_sub, - name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub, - num, BT_INTEGER, di, REQUIRED, INTENT_IN, - han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub, - p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN, - 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub, - com, BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE, - BT_UNKNOWN, 0, GFC_STD_F95, - gfc_check_system_clock, NULL, gfc_resolve_system_clock, - c, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT, - cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub, - ut, BT_INTEGER, di, REQUIRED, INTENT_IN, - name, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); - - add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, - gfc_check_umask_sub, NULL, gfc_resolve_umask_sub, - msk, BT_INTEGER, di, REQUIRED, INTENT_IN, - old, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - - add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0, - GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub, - "path", BT_CHARACTER, dc, REQUIRED, INTENT_IN, - st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); -} - - -/* Add a function to the list of conversion symbols. */ - -static void -add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard) -{ - gfc_typespec from, to; - gfc_intrinsic_sym *sym; - - if (sizing == SZ_CONVS) - { - nconv++; - return; - } - - gfc_clear_ts (&from); - from.type = from_type; - from.kind = from_kind; - - gfc_clear_ts (&to); - to.type = to_type; - to.kind = to_kind; - - sym = conversion + nconv; - - sym->name = conv_name (&from, &to); - sym->lib_name = sym->name; - sym->simplify.cc = gfc_convert_constant; - sym->standard = standard; - sym->elemental = 1; - sym->pure = 1; - sym->conversion = 1; - sym->ts = to; - sym->id = GFC_ISYM_CONVERSION; - - nconv++; -} - - -/* Create gfc_intrinsic_sym nodes for all intrinsic conversion - functions by looping over the kind tables. */ - -static void -add_conversions (void) -{ - int i, j; - - /* Integer-Integer conversions. */ - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - for (j = 0; gfc_integer_kinds[j].kind != 0; j++) - { - if (i == j) - continue; - - add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, - BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77); - } - - /* Integer-Real/Complex conversions. */ - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - for (j = 0; gfc_real_kinds[j].kind != 0; j++) - { - add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, - BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); - - add_conv (BT_REAL, gfc_real_kinds[j].kind, - BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); - - add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, - BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); - - add_conv (BT_COMPLEX, gfc_real_kinds[j].kind, - BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); - } - - if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) - { - /* Hollerith-Integer conversions. */ - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - add_conv (BT_HOLLERITH, gfc_default_character_kind, - BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); - /* Hollerith-Real conversions. */ - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - add_conv (BT_HOLLERITH, gfc_default_character_kind, - BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); - /* Hollerith-Complex conversions. */ - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - add_conv (BT_HOLLERITH, gfc_default_character_kind, - BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); - - /* Hollerith-Character conversions. */ - add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER, - gfc_default_character_kind, GFC_STD_LEGACY); - - /* Hollerith-Logical conversions. */ - for (i = 0; gfc_logical_kinds[i].kind != 0; i++) - add_conv (BT_HOLLERITH, gfc_default_character_kind, - BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); - } - - /* Real/Complex - Real/Complex conversions. */ - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - for (j = 0; gfc_real_kinds[j].kind != 0; j++) - { - if (i != j) - { - add_conv (BT_REAL, gfc_real_kinds[i].kind, - BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); - - add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, - BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); - } - - add_conv (BT_REAL, gfc_real_kinds[i].kind, - BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); - - add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, - BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); - } - - /* Logical/Logical kind conversion. */ - for (i = 0; gfc_logical_kinds[i].kind; i++) - for (j = 0; gfc_logical_kinds[j].kind; j++) - { - if (i == j) - continue; - - add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind, - BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77); - } - - /* Integer-Logical and Logical-Integer conversions. */ - if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) - for (i=0; gfc_integer_kinds[i].kind; i++) - for (j=0; gfc_logical_kinds[j].kind; j++) - { - add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, - BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY); - add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind, - BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); - } - - /* DEC legacy feature allows character conversions similar to Hollerith - conversions - the character data will transferred on a byte by byte - basis. */ - if (flag_dec_char_conversions) - { - /* Character-Integer conversions. */ - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - add_conv (BT_CHARACTER, gfc_default_character_kind, - BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); - /* Character-Real conversions. */ - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - add_conv (BT_CHARACTER, gfc_default_character_kind, - BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); - /* Character-Complex conversions. */ - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - add_conv (BT_CHARACTER, gfc_default_character_kind, - BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); - /* Character-Logical conversions. */ - for (i = 0; gfc_logical_kinds[i].kind != 0; i++) - add_conv (BT_CHARACTER, gfc_default_character_kind, - BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); - } -} - - -static void -add_char_conversions (void) -{ - int n, i, j; - - /* Count possible conversions. */ - for (i = 0; gfc_character_kinds[i].kind != 0; i++) - for (j = 0; gfc_character_kinds[j].kind != 0; j++) - if (i != j) - ncharconv++; - - /* Allocate memory. */ - char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv); - - /* Add the conversions themselves. */ - n = 0; - for (i = 0; gfc_character_kinds[i].kind != 0; i++) - for (j = 0; gfc_character_kinds[j].kind != 0; j++) - { - gfc_typespec from, to; - - if (i == j) - continue; - - gfc_clear_ts (&from); - from.type = BT_CHARACTER; - from.kind = gfc_character_kinds[i].kind; - - gfc_clear_ts (&to); - to.type = BT_CHARACTER; - to.kind = gfc_character_kinds[j].kind; - - char_conversions[n].name = conv_name (&from, &to); - char_conversions[n].lib_name = char_conversions[n].name; - char_conversions[n].simplify.cc = gfc_convert_char_constant; - char_conversions[n].standard = GFC_STD_F2003; - char_conversions[n].elemental = 1; - char_conversions[n].pure = 1; - char_conversions[n].conversion = 0; - char_conversions[n].ts = to; - char_conversions[n].id = GFC_ISYM_CONVERSION; - - n++; - } -} - - -/* Initialize the table of intrinsics. */ -void -gfc_intrinsic_init_1 (void) -{ - nargs = nfunc = nsub = nconv = 0; - - /* Create a namespace to hold the resolved intrinsic symbols. */ - gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0); - - sizing = SZ_FUNCS; - add_functions (); - sizing = SZ_SUBS; - add_subroutines (); - sizing = SZ_CONVS; - add_conversions (); - - functions = XCNEWVAR (struct gfc_intrinsic_sym, - sizeof (gfc_intrinsic_sym) * (nfunc + nsub) - + sizeof (gfc_intrinsic_arg) * nargs); - - next_sym = functions; - subroutines = functions + nfunc; - - conversion = XCNEWVEC (gfc_intrinsic_sym, nconv); - - next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1; - - sizing = SZ_NOTHING; - nconv = 0; - - add_functions (); - add_subroutines (); - add_conversions (); - - /* Character conversion intrinsics need to be treated separately. */ - add_char_conversions (); -} - - -void -gfc_intrinsic_done_1 (void) -{ - free (functions); - free (conversion); - free (char_conversions); - gfc_free_namespace (gfc_intrinsic_namespace); -} - - -/******** Subroutines to check intrinsic interfaces ***********/ - -/* Given a formal argument list, remove any NULL arguments that may - have been left behind by a sort against some formal argument list. */ - -static void -remove_nullargs (gfc_actual_arglist **ap) -{ - gfc_actual_arglist *head, *tail, *next; - - tail = NULL; - - for (head = *ap; head; head = next) - { - next = head->next; - - if (head->expr == NULL && !head->label) - { - head->next = NULL; - gfc_free_actual_arglist (head); - } - else - { - if (tail == NULL) - *ap = head; - else - tail->next = head; - - tail = head; - tail->next = NULL; - } - } - - if (tail == NULL) - *ap = NULL; -} - - -static gfc_dummy_arg * -get_intrinsic_dummy_arg (gfc_intrinsic_arg *intrinsic) -{ - gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg (); - - dummy_arg->intrinsicness = GFC_INTRINSIC_DUMMY_ARG; - dummy_arg->u.intrinsic = intrinsic; - - return dummy_arg; -} - - -/* Given an actual arglist and a formal arglist, sort the actual - arglist so that its arguments are in a one-to-one correspondence - with the format arglist. Arguments that are not present are given - a blank gfc_actual_arglist structure. If something is obviously - wrong (say, a missing required argument) we abort sorting and - return false. */ - -static bool -sort_actual (const char *name, gfc_actual_arglist **ap, - gfc_intrinsic_arg *formal, locus *where) -{ - gfc_actual_arglist *actual, *a; - gfc_intrinsic_arg *f; - - remove_nullargs (ap); - actual = *ap; - - auto_vec dummy_args; - auto_vec ordered_actual_args; - - for (f = formal; f; f = f->next) - dummy_args.safe_push (f); - - ordered_actual_args.safe_grow_cleared (dummy_args.length (), - /* exact = */true); - - f = formal; - a = actual; - - if (f == NULL && a == NULL) /* No arguments */ - return true; - - /* ALLOCATED has two mutually exclusive keywords, but only one - can be present at time and neither is optional. */ - if (strcmp (name, "allocated") == 0) - { - if (!a) - { - gfc_error ("ALLOCATED intrinsic at %L requires an array or scalar " - "allocatable entity", where); - return false; - } - - if (a->name) - { - if (strcmp (a->name, "scalar") == 0) - { - if (a->next) - goto whoops; - if (a->expr->rank != 0) - { - gfc_error ("Scalar entity required at %L", &a->expr->where); - return false; - } - return true; - } - else if (strcmp (a->name, "array") == 0) - { - if (a->next) - goto whoops; - if (a->expr->rank == 0) - { - gfc_error ("Array entity required at %L", &a->expr->where); - return false; - } - return true; - } - else - { - gfc_error ("Invalid keyword %qs in %qs intrinsic function at %L", - a->name, name, &a->expr->where); - return false; - } - } - } - - for (int i = 0;; i++) - { /* Put the nonkeyword arguments in a 1:1 correspondence */ - if (f == NULL) - break; - if (a == NULL) - goto optional; - - if (a->name != NULL) - goto keywords; - - ordered_actual_args[i] = a; - - f = f->next; - a = a->next; - } - - if (a == NULL) - goto do_sort; - -whoops: - gfc_error ("Too many arguments in call to %qs at %L", name, where); - return false; - -keywords: - /* Associate the remaining actual arguments, all of which have - to be keyword arguments. */ - for (; a; a = a->next) - { - int idx; - FOR_EACH_VEC_ELT (dummy_args, idx, f) - if (strcmp (a->name, f->name) == 0) - break; - - if (f == NULL) - { - if (a->name[0] == '%') - gfc_error ("The argument list functions %%VAL, %%LOC or %%REF " - "are not allowed in this context at %L", where); - else - gfc_error ("Cannot find keyword named %qs in call to %qs at %L", - a->name, name, where); - return false; - } - - if (ordered_actual_args[idx] != NULL) - { - gfc_error ("Argument %qs appears twice in call to %qs at %L", - f->name, name, where); - return false; - } - ordered_actual_args[idx] = a; - } - -optional: - /* At this point, all unmatched formal args must be optional. */ - int idx; - FOR_EACH_VEC_ELT (dummy_args, idx, f) - { - if (ordered_actual_args[idx] == NULL && f->optional == 0) - { - gfc_error ("Missing actual argument %qs in call to %qs at %L", - f->name, name, where); - return false; - } - } - -do_sort: - /* Using the formal argument list, string the actual argument list - together in a way that corresponds with the formal list. */ - actual = NULL; - - FOR_EACH_VEC_ELT (dummy_args, idx, f) - { - a = ordered_actual_args[idx]; - if (a && a->label != NULL) - { - gfc_error ("ALTERNATE RETURN not permitted at %L", where); - return false; - } - - if (a == NULL) - a = gfc_get_actual_arglist (); - - a->associated_dummy = get_intrinsic_dummy_arg (f); - - if (actual == NULL) - *ap = a; - else - actual->next = a; - - actual = a; - } - actual->next = NULL; /* End the sorted argument list. */ - - return true; -} - - -/* Compare an actual argument list with an intrinsic's formal argument - list. The lists are checked for agreement of type. We don't check - for arrayness here. */ - -static bool -check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, - int error_flag) -{ - gfc_actual_arglist *actual; - gfc_intrinsic_arg *formal; - int i; - - formal = sym->formal; - actual = *ap; - - i = 0; - for (; formal; formal = formal->next, actual = actual->next, i++) - { - gfc_typespec ts; - - if (actual->expr == NULL) - continue; - - ts = formal->ts; - - /* A kind of 0 means we don't check for kind. */ - if (ts.kind == 0) - ts.kind = actual->expr->ts.kind; - - if (!gfc_compare_types (&ts, &actual->expr->ts)) - { - if (error_flag) - gfc_error ("In call to %qs at %L, type mismatch in argument " - "%qs; pass %qs to %qs", gfc_current_intrinsic, - &actual->expr->where, - gfc_current_intrinsic_arg[i]->name, - gfc_typename (actual->expr), - gfc_dummy_typename (&formal->ts)); - return false; - } - - /* F2018, p. 328: An argument to an intrinsic procedure other than - ASSOCIATED, NULL, or PRESENT shall be a data object. An EXPR_NULL - is not a data object. */ - if (actual->expr->expr_type == EXPR_NULL - && (!(sym->id == GFC_ISYM_ASSOCIATED - || sym->id == GFC_ISYM_NULL - || sym->id == GFC_ISYM_PRESENT))) - { - gfc_invalid_null_arg (actual->expr); - return false; - } - - /* If the formal argument is INTENT([IN]OUT), check for definability. */ - if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT) - { - const char* context = (error_flag - ? _("actual argument to INTENT = OUT/INOUT") - : NULL); - - /* No pointer arguments for intrinsics. */ - if (!gfc_check_vardef_context (actual->expr, false, false, false, context)) - return false; - } - } - - return true; -} - - -/* Given a pointer to an intrinsic symbol and an expression node that - represent the function call to that subroutine, figure out the type - of the result. This may involve calling a resolution subroutine. */ - -static void -resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) -{ - gfc_expr *a1, *a2, *a3, *a4, *a5, *a6; - gfc_actual_arglist *arg; - - if (specific->resolve.f1 == NULL) - { - if (e->value.function.name == NULL) - e->value.function.name = specific->lib_name; - - if (e->ts.type == BT_UNKNOWN) - e->ts = specific->ts; - return; - } - - arg = e->value.function.actual; - - /* Special case hacks for MIN and MAX. */ - if (specific->resolve.f1m == gfc_resolve_max - || specific->resolve.f1m == gfc_resolve_min) - { - (*specific->resolve.f1m) (e, arg); - return; - } - - if (arg == NULL) - { - (*specific->resolve.f0) (e); - return; - } - - a1 = arg->expr; - arg = arg->next; - - if (arg == NULL) - { - (*specific->resolve.f1) (e, a1); - return; - } - - a2 = arg->expr; - arg = arg->next; - - if (arg == NULL) - { - (*specific->resolve.f2) (e, a1, a2); - return; - } - - a3 = arg->expr; - arg = arg->next; - - if (arg == NULL) - { - (*specific->resolve.f3) (e, a1, a2, a3); - return; - } - - a4 = arg->expr; - arg = arg->next; - - if (arg == NULL) - { - (*specific->resolve.f4) (e, a1, a2, a3, a4); - return; - } - - a5 = arg->expr; - arg = arg->next; - - if (arg == NULL) - { - (*specific->resolve.f5) (e, a1, a2, a3, a4, a5); - return; - } - - a6 = arg->expr; - arg = arg->next; - - if (arg == NULL) - { - (*specific->resolve.f6) (e, a1, a2, a3, a4, a5, a6); - return; - } - - gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic"); -} - - -/* Given an intrinsic symbol node and an expression node, call the - simplification function (if there is one), perhaps replacing the - expression with something simpler. We return false on an error - of the simplification, true if the simplification worked, even - if nothing has changed in the expression itself. */ - -static bool -do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) -{ - gfc_expr *result, *a1, *a2, *a3, *a4, *a5, *a6; - gfc_actual_arglist *arg; - - /* Max and min require special handling due to the variable number - of args. */ - if (specific->simplify.f1 == gfc_simplify_min) - { - result = gfc_simplify_min (e); - goto finish; - } - - if (specific->simplify.f1 == gfc_simplify_max) - { - result = gfc_simplify_max (e); - goto finish; - } - - if (specific->simplify.f1 == NULL) - { - result = NULL; - goto finish; - } - - arg = e->value.function.actual; - - if (arg == NULL) - { - result = (*specific->simplify.f0) (); - goto finish; - } - - a1 = arg->expr; - arg = arg->next; - - if (specific->simplify.cc == gfc_convert_constant - || specific->simplify.cc == gfc_convert_char_constant) - { - result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind); - goto finish; - } - - if (arg == NULL) - result = (*specific->simplify.f1) (a1); - else - { - a2 = arg->expr; - arg = arg->next; - - if (arg == NULL) - result = (*specific->simplify.f2) (a1, a2); - else - { - a3 = arg->expr; - arg = arg->next; - - if (arg == NULL) - result = (*specific->simplify.f3) (a1, a2, a3); - else - { - a4 = arg->expr; - arg = arg->next; - - if (arg == NULL) - result = (*specific->simplify.f4) (a1, a2, a3, a4); - else - { - a5 = arg->expr; - arg = arg->next; - - if (arg == NULL) - result = (*specific->simplify.f5) (a1, a2, a3, a4, a5); - else - { - a6 = arg->expr; - arg = arg->next; - - if (arg == NULL) - result = (*specific->simplify.f6) - (a1, a2, a3, a4, a5, a6); - else - gfc_internal_error - ("do_simplify(): Too many args for intrinsic"); - } - } - } - } - } - -finish: - if (result == &gfc_bad_expr) - return false; - - if (result == NULL) - resolve_intrinsic (specific, e); /* Must call at run-time */ - else - { - result->where = e->where; - gfc_replace_expr (e, result); - } - - return true; -} - - -/* Initialize the gfc_current_intrinsic_arg[] array for the benefit of - error messages. This subroutine returns false if a subroutine - has more than MAX_INTRINSIC_ARGS, in which case the actual argument - list cannot match any intrinsic. */ - -static void -init_arglist (gfc_intrinsic_sym *isym) -{ - gfc_intrinsic_arg *formal; - int i; - - gfc_current_intrinsic = isym->name; - - i = 0; - for (formal = isym->formal; formal; formal = formal->next) - { - if (i >= MAX_INTRINSIC_ARGS) - gfc_internal_error ("init_arglist(): too many arguments"); - gfc_current_intrinsic_arg[i++] = formal; - } -} - - -/* Given a pointer to an intrinsic symbol and an expression consisting - of a function call, see if the function call is consistent with the - intrinsic's formal argument list. Return true if the expression - and intrinsic match, false otherwise. */ - -static bool -check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) -{ - gfc_actual_arglist *arg, **ap; - bool t; - - ap = &expr->value.function.actual; - - init_arglist (specific); - - /* Don't attempt to sort the argument list for min or max. */ - if (specific->check.f1m == gfc_check_min_max - || specific->check.f1m == gfc_check_min_max_integer - || specific->check.f1m == gfc_check_min_max_real - || specific->check.f1m == gfc_check_min_max_double) - { - if (!do_ts29113_check (specific, *ap)) - return false; - return (*specific->check.f1m) (*ap); - } - - if (!sort_actual (specific->name, ap, specific->formal, &expr->where)) - return false; - - if (!do_ts29113_check (specific, *ap)) - return false; - - if (specific->check.f5ml == gfc_check_minloc_maxloc) - /* This is special because we might have to reorder the argument list. */ - t = gfc_check_minloc_maxloc (*ap); - else if (specific->check.f6fl == gfc_check_findloc) - t = gfc_check_findloc (*ap); - else if (specific->check.f3red == gfc_check_minval_maxval) - /* This is also special because we also might have to reorder the - argument list. */ - t = gfc_check_minval_maxval (*ap); - else if (specific->check.f3red == gfc_check_product_sum) - /* Same here. The difference to the previous case is that we allow a - general numeric type. */ - t = gfc_check_product_sum (*ap); - else if (specific->check.f3red == gfc_check_transf_bit_intrins) - /* Same as for PRODUCT and SUM, but different checks. */ - t = gfc_check_transf_bit_intrins (*ap); - else - { - if (specific->check.f1 == NULL) - { - t = check_arglist (ap, specific, error_flag); - if (t) - expr->ts = specific->ts; - } - else - t = do_check (specific, *ap); - } - - /* Check conformance of elemental intrinsics. */ - if (t && specific->elemental) - { - int n = 0; - gfc_expr *first_expr; - arg = expr->value.function.actual; - - /* There is no elemental intrinsic without arguments. */ - gcc_assert(arg != NULL); - first_expr = arg->expr; - - for ( ; arg && arg->expr; arg = arg->next, n++) - if (!gfc_check_conformance (first_expr, arg->expr, - _("arguments '%s' and '%s' for " - "intrinsic '%s'"), - gfc_current_intrinsic_arg[0]->name, - gfc_current_intrinsic_arg[n]->name, - gfc_current_intrinsic)) - return false; - } - - if (!t) - remove_nullargs (ap); - - return t; -} - - -/* Check whether an intrinsic belongs to whatever standard the user - has chosen, taking also into account -fall-intrinsics. Here, no - warning/error is emitted; but if symstd is not NULL, it is pointed to a - textual representation of the symbols standard status (like - "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that - can be used to construct a detailed warning/error message in case of - a false. */ - -bool -gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, - const char** symstd, bool silent, locus where) -{ - const char* symstd_msg; - - /* For -fall-intrinsics, just succeed. */ - if (flag_all_intrinsics) - return true; - - /* Find the symbol's standard message for later usage. */ - switch (isym->standard) - { - case GFC_STD_F77: - symstd_msg = _("available since Fortran 77"); - break; - - case GFC_STD_F95_OBS: - symstd_msg = _("obsolescent in Fortran 95"); - break; - - case GFC_STD_F95_DEL: - symstd_msg = _("deleted in Fortran 95"); - break; - - case GFC_STD_F95: - symstd_msg = _("new in Fortran 95"); - break; - - case GFC_STD_F2003: - symstd_msg = _("new in Fortran 2003"); - break; - - case GFC_STD_F2008: - symstd_msg = _("new in Fortran 2008"); - break; - - case GFC_STD_F2018: - symstd_msg = _("new in Fortran 2018"); - break; - - case GFC_STD_GNU: - symstd_msg = _("a GNU Fortran extension"); - break; - - case GFC_STD_LEGACY: - symstd_msg = _("for backward compatibility"); - break; - - default: - gfc_internal_error ("Invalid standard code on intrinsic %qs (%d)", - isym->name, isym->standard); - } - - /* If warning about the standard, warn and succeed. */ - if (gfc_option.warn_std & isym->standard) - { - /* Do only print a warning if not a GNU extension. */ - if (!silent && isym->standard != GFC_STD_GNU) - gfc_warning (0, "Intrinsic %qs (%s) used at %L", - isym->name, symstd_msg, &where); - - return true; - } - - /* If allowing the symbol's standard, succeed, too. */ - if (gfc_option.allow_std & isym->standard) - return true; - - /* Otherwise, fail. */ - if (symstd) - *symstd = symstd_msg; - return false; -} - - -/* See if a function call corresponds to an intrinsic function call. - We return: - - MATCH_YES if the call corresponds to an intrinsic, simplification - is done if possible. - - MATCH_NO if the call does not correspond to an intrinsic - - MATCH_ERROR if the call corresponds to an intrinsic but there was an - error during the simplification process. - - The error_flag parameter enables an error reporting. */ - -match -gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag) -{ - gfc_symbol *sym; - gfc_intrinsic_sym *isym, *specific; - gfc_actual_arglist *actual; - int flag; - - if (expr->value.function.isym != NULL) - return (!do_simplify(expr->value.function.isym, expr)) - ? MATCH_ERROR : MATCH_YES; - - if (!error_flag) - gfc_push_suppress_errors (); - flag = 0; - - for (actual = expr->value.function.actual; actual; actual = actual->next) - if (actual->expr != NULL) - flag |= (actual->expr->ts.type != BT_INTEGER - && actual->expr->ts.type != BT_CHARACTER); - - sym = expr->symtree->n.sym; - - if (sym->intmod_sym_id) - { - gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); - isym = specific = gfc_intrinsic_function_by_id (id); - } - else - isym = specific = gfc_find_function (sym->name); - - if (isym == NULL) - { - if (!error_flag) - gfc_pop_suppress_errors (); - return MATCH_NO; - } - - if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE - || isym->id == GFC_ISYM_CMPLX || isym->id == GFC_ISYM_FLOAT - || isym->id == GFC_ISYM_SNGL || isym->id == GFC_ISYM_DFLOAT) - && gfc_init_expr_flag - && !gfc_notify_std (GFC_STD_F2003, "Function %qs as initialization " - "expression at %L", sym->name, &expr->where)) - { - if (!error_flag) - gfc_pop_suppress_errors (); - return MATCH_ERROR; - } - - /* F95, 7.1.6.1: Only transformational functions REPEAT, RESHAPE, - SELECTED_INT_KIND, SELECTED_REAL_KIND, TRANSFER, and TRIM are allowed in - initialization expressions. */ - - if (gfc_init_expr_flag && isym->transformational) - { - gfc_isym_id id = isym->id; - if (id != GFC_ISYM_REPEAT && id != GFC_ISYM_RESHAPE - && id != GFC_ISYM_SI_KIND && id != GFC_ISYM_SR_KIND - && id != GFC_ISYM_TRANSFER && id != GFC_ISYM_TRIM - && !gfc_notify_std (GFC_STD_F2003, "Transformational function %qs " - "at %L is invalid in an initialization " - "expression", sym->name, &expr->where)) - { - if (!error_flag) - gfc_pop_suppress_errors (); - - return MATCH_ERROR; - } - } - - gfc_current_intrinsic_where = &expr->where; - - /* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */ - if (isym->check.f1m == gfc_check_min_max) - { - init_arglist (isym); - - if (isym->check.f1m(expr->value.function.actual)) - goto got_specific; - - if (!error_flag) - gfc_pop_suppress_errors (); - return MATCH_NO; - } - - /* If the function is generic, check all of its specific - incarnations. If the generic name is also a specific, we check - that name last, so that any error message will correspond to the - specific. */ - gfc_push_suppress_errors (); - - if (isym->generic) - { - for (specific = isym->specific_head; specific; - specific = specific->next) - { - if (specific == isym) - continue; - if (check_specific (specific, expr, 0)) - { - gfc_pop_suppress_errors (); - goto got_specific; - } - } - } - - gfc_pop_suppress_errors (); - - if (!check_specific (isym, expr, error_flag)) - { - if (!error_flag) - gfc_pop_suppress_errors (); - return MATCH_NO; - } - - specific = isym; - -got_specific: - expr->value.function.isym = specific; - if (!error_flag) - gfc_pop_suppress_errors (); - - if (!do_simplify (specific, expr)) - return MATCH_ERROR; - - /* F95, 7.1.6.1, Initialization expressions - (4) An elemental intrinsic function reference of type integer or - character where each argument is an initialization expression - of type integer or character - - F2003, 7.1.7 Initialization expression - (4) A reference to an elemental standard intrinsic function, - where each argument is an initialization expression */ - - if (gfc_init_expr_flag && isym->elemental && flag - && !gfc_notify_std (GFC_STD_F2003, "Elemental function as " - "initialization expression with non-integer/non-" - "character arguments at %L", &expr->where)) - return MATCH_ERROR; - - if (sym->attr.flavor == FL_UNKNOWN) - { - sym->attr.function = 1; - sym->attr.intrinsic = 1; - sym->attr.flavor = FL_PROCEDURE; - } - if (sym->attr.flavor == FL_PROCEDURE) - { - sym->attr.function = 1; - sym->attr.proc = PROC_INTRINSIC; - } - - if (!sym->module) - gfc_intrinsic_symbol (sym); - - /* Have another stab at simplification since elemental intrinsics with array - actual arguments would be missed by the calls above to do_simplify. */ - if (isym->elemental) - gfc_simplify_expr (expr, 1); - - return MATCH_YES; -} - - -/* See if a CALL statement corresponds to an intrinsic subroutine. - Returns MATCH_YES if the subroutine corresponds to an intrinsic, - MATCH_NO if not, and MATCH_ERROR if there was an error (but did - correspond). */ - -match -gfc_intrinsic_sub_interface (gfc_code *c, int error_flag) -{ - gfc_intrinsic_sym *isym; - const char *name; - - name = c->symtree->n.sym->name; - - if (c->symtree->n.sym->intmod_sym_id) - { - gfc_isym_id id; - id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym); - isym = gfc_intrinsic_subroutine_by_id (id); - } - else - isym = gfc_find_subroutine (name); - if (isym == NULL) - return MATCH_NO; - - if (!error_flag) - gfc_push_suppress_errors (); - - init_arglist (isym); - - if (!isym->vararg && !sort_actual (name, &c->ext.actual, isym->formal, &c->loc)) - goto fail; - - if (!do_ts29113_check (isym, c->ext.actual)) - goto fail; - - if (isym->check.f1 != NULL) - { - if (!do_check (isym, c->ext.actual)) - goto fail; - } - else - { - if (!check_arglist (&c->ext.actual, isym, 1)) - goto fail; - } - - /* The subroutine corresponds to an intrinsic. Allow errors to be - seen at this point. */ - if (!error_flag) - gfc_pop_suppress_errors (); - - c->resolved_isym = isym; - if (isym->resolve.s1 != NULL) - isym->resolve.s1 (c); - else - { - c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name); - c->resolved_sym->attr.elemental = isym->elemental; - } - - if (gfc_do_concurrent_flag && !isym->pure) - { - gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT " - "block at %L is not PURE", name, &c->loc); - return MATCH_ERROR; - } - - if (!isym->pure && gfc_pure (NULL)) - { - gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name, - &c->loc); - return MATCH_ERROR; - } - - if (!isym->pure) - gfc_unset_implicit_pure (NULL); - - c->resolved_sym->attr.noreturn = isym->noreturn; - - return MATCH_YES; - -fail: - if (!error_flag) - gfc_pop_suppress_errors (); - return MATCH_NO; -} - - -/* Call gfc_convert_type() with warning enabled. */ - -bool -gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag) -{ - return gfc_convert_type_warn (expr, ts, eflag, 1); -} - - -/* Try to convert an expression (in place) from one type to another. - 'eflag' controls the behavior on error. - - The possible values are: - - 1 Generate a gfc_error() - 2 Generate a gfc_internal_error(). - - 'wflag' controls the warning related to conversion. - - 'array' indicates whether the conversion is in an array constructor. - Non-standard conversion from character to numeric not allowed if true. -*/ - -bool -gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag, - bool array) -{ - gfc_intrinsic_sym *sym; - gfc_typespec from_ts; - locus old_where; - gfc_expr *new_expr; - int rank; - mpz_t *shape; - bool is_char_constant = (expr->expr_type == EXPR_CONSTANT) - && (expr->ts.type == BT_CHARACTER); - - from_ts = expr->ts; /* expr->ts gets clobbered */ - - if (ts->type == BT_UNKNOWN) - goto bad; - - expr->do_not_warn = ! wflag; - - /* NULL and zero size arrays get their type here, unless they already have a - typespec. */ - if ((expr->expr_type == EXPR_NULL - || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL)) - && expr->ts.type == BT_UNKNOWN) - { - /* Sometimes the RHS acquire the type. */ - expr->ts = *ts; - return true; - } - - if (expr->ts.type == BT_UNKNOWN) - goto bad; - - /* In building an array constructor, gfortran can end up here when no - conversion is required for an intrinsic type. We need to let derived - types drop through. */ - if (from_ts.type != BT_DERIVED && from_ts.type != BT_CLASS - && (from_ts.type == ts->type && from_ts.kind == ts->kind)) - return true; - - if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && (ts->type == BT_DERIVED || ts->type == BT_CLASS) - && gfc_compare_types (ts, &expr->ts)) - return true; - - /* If array is true then conversion is in an array constructor where - non-standard conversion is not allowed. */ - if (array && from_ts.type == BT_CHARACTER - && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) - goto bad; - - sym = find_conv (&expr->ts, ts); - if (sym == NULL) - goto bad; - - /* At this point, a conversion is necessary. A warning may be needed. */ - if ((gfc_option.warn_std & sym->standard) != 0) - { - const char *type_name = is_char_constant ? gfc_typename (expr) - : gfc_typename (&from_ts); - gfc_warning_now (0, "Extension: Conversion from %s to %s at %L", - type_name, gfc_dummy_typename (ts), - &expr->where); - } - else if (wflag) - { - if (flag_range_check && expr->expr_type == EXPR_CONSTANT - && from_ts.type == ts->type) - { - /* Do nothing. Constants of the same type are range-checked - elsewhere. If a value too large for the target type is - assigned, an error is generated. Not checking here avoids - duplications of warnings/errors. - If range checking was disabled, but -Wconversion enabled, - a non range checked warning is generated below. */ - } - else if (flag_dec_char_conversions && from_ts.type == BT_CHARACTER - && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) - { - const char *type_name = is_char_constant ? gfc_typename (expr) - : gfc_typename (&from_ts); - gfc_warning_now (OPT_Wconversion, "Nonstandard conversion from %s " - "to %s at %L", type_name, gfc_typename (ts), - &expr->where); - } - else if (from_ts.type == ts->type - || (from_ts.type == BT_INTEGER && ts->type == BT_REAL) - || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX) - || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)) - { - /* Larger kinds can hold values of smaller kinds without problems. - Hence, only warn if target kind is smaller than the source - kind - or if -Wconversion-extra is specified. LOGICAL values - will always fit regardless of kind so ignore conversion. */ - if (expr->expr_type != EXPR_CONSTANT - && ts->type != BT_LOGICAL) - { - if (warn_conversion && from_ts.kind > ts->kind) - gfc_warning_now (OPT_Wconversion, "Possible change of value in " - "conversion from %s to %s at %L", - gfc_typename (&from_ts), gfc_typename (ts), - &expr->where); - else - gfc_warning_now (OPT_Wconversion_extra, "Conversion from %s to %s " - "at %L", gfc_typename (&from_ts), - gfc_typename (ts), &expr->where); - } - } - else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER) - || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER) - || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL)) - { - /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL - usually comes with a loss of information, regardless of kinds. */ - if (expr->expr_type != EXPR_CONSTANT) - gfc_warning_now (OPT_Wconversion, "Possible change of value in " - "conversion from %s to %s at %L", - gfc_typename (&from_ts), gfc_typename (ts), - &expr->where); - } - else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH) - { - /* If HOLLERITH is involved, all bets are off. */ - gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L", - gfc_typename (&from_ts), gfc_dummy_typename (ts), - &expr->where); - } - else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL) - { - /* Do nothing. This block exists only to simplify the other - else-if expressions. - LOGICAL <> LOGICAL no warning, independent of kind values - LOGICAL <> INTEGER extension, warned elsewhere - LOGICAL <> REAL invalid, error generated elsewhere - LOGICAL <> COMPLEX invalid, error generated elsewhere */ - } - else - gcc_unreachable (); - } - - /* Insert a pre-resolved function call to the right function. */ - old_where = expr->where; - rank = expr->rank; - shape = expr->shape; - - new_expr = gfc_get_expr (); - *new_expr = *expr; - - new_expr = gfc_build_conversion (new_expr); - new_expr->value.function.name = sym->lib_name; - new_expr->value.function.isym = sym; - new_expr->where = old_where; - new_expr->ts = *ts; - new_expr->rank = rank; - new_expr->shape = gfc_copy_shape (shape, rank); - - gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); - new_expr->symtree->n.sym->result = new_expr->symtree->n.sym; - new_expr->symtree->n.sym->ts.type = ts->type; - new_expr->symtree->n.sym->ts.kind = ts->kind; - new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; - new_expr->symtree->n.sym->attr.function = 1; - new_expr->symtree->n.sym->attr.elemental = 1; - new_expr->symtree->n.sym->attr.pure = 1; - new_expr->symtree->n.sym->attr.referenced = 1; - gfc_intrinsic_symbol(new_expr->symtree->n.sym); - gfc_commit_symbol (new_expr->symtree->n.sym); - - *expr = *new_expr; - - free (new_expr); - expr->ts = *ts; - - if (gfc_is_constant_expr (expr->value.function.actual->expr) - && !do_simplify (sym, expr)) - { - - if (eflag == 2) - goto bad; - return false; /* Error already generated in do_simplify() */ - } - - return true; - -bad: - const char *type_name = is_char_constant ? gfc_typename (expr) - : gfc_typename (&from_ts); - if (eflag == 1) - { - gfc_error ("Cannot convert %s to %s at %L", type_name, gfc_typename (ts), - &expr->where); - return false; - } - - gfc_internal_error ("Cannot convert %qs to %qs at %L", type_name, - gfc_typename (ts), &expr->where); - /* Not reached */ -} - - -bool -gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) -{ - gfc_intrinsic_sym *sym; - locus old_where; - gfc_expr *new_expr; - int rank; - mpz_t *shape; - - gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER); - - sym = find_char_conv (&expr->ts, ts); - gcc_assert (sym); - - /* Insert a pre-resolved function call to the right function. */ - old_where = expr->where; - rank = expr->rank; - shape = expr->shape; - - new_expr = gfc_get_expr (); - *new_expr = *expr; - - new_expr = gfc_build_conversion (new_expr); - new_expr->value.function.name = sym->lib_name; - new_expr->value.function.isym = sym; - new_expr->where = old_where; - new_expr->ts = *ts; - new_expr->rank = rank; - new_expr->shape = gfc_copy_shape (shape, rank); - - gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); - new_expr->symtree->n.sym->ts.type = ts->type; - new_expr->symtree->n.sym->ts.kind = ts->kind; - new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; - new_expr->symtree->n.sym->attr.function = 1; - new_expr->symtree->n.sym->attr.elemental = 1; - new_expr->symtree->n.sym->attr.referenced = 1; - gfc_intrinsic_symbol(new_expr->symtree->n.sym); - gfc_commit_symbol (new_expr->symtree->n.sym); - - *expr = *new_expr; - - free (new_expr); - expr->ts = *ts; - - if (gfc_is_constant_expr (expr->value.function.actual->expr) - && !do_simplify (sym, expr)) - { - /* Error already generated in do_simplify() */ - return false; - } - - return true; -} - - -/* Check if the passed name is name of an intrinsic (taking into account the - current -std=* and -fall-intrinsic settings). If it is, see if we should - warn about this as a user-procedure having the same name as an intrinsic - (-Wintrinsic-shadow enabled) and do so if we should. */ - -void -gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func) -{ - gfc_intrinsic_sym* isym; - - /* If the warning is disabled, do nothing at all. */ - if (!warn_intrinsic_shadow) - return; - - /* Try to find an intrinsic of the same name. */ - if (func) - isym = gfc_find_function (sym->name); - else - isym = gfc_find_subroutine (sym->name); - - /* If no intrinsic was found with this name or it's not included in the - selected standard, everything's fine. */ - if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true, - sym->declared_at)) - return; - - /* Emit the warning. */ - if (in_module || sym->ns->proc_name) - gfc_warning (OPT_Wintrinsic_shadow, - "%qs declared at %L may shadow the intrinsic of the same" - " name. In order to call the intrinsic, explicit INTRINSIC" - " declarations may be required.", - sym->name, &sym->declared_at); - else - gfc_warning (OPT_Wintrinsic_shadow, - "%qs declared at %L is also the name of an intrinsic. It can" - " only be called via an explicit interface or if declared" - " EXTERNAL.", sym->name, &sym->declared_at); -} diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc new file mode 100644 index 0000000..9746cd5 --- /dev/null +++ b/gcc/fortran/intrinsic.cc @@ -0,0 +1,5503 @@ +/* Build up a list of intrinsic subroutines and functions for the + name-resolution stage. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "intrinsic.h" + +/* Namespace to hold the resolved symbols for intrinsic subroutines. */ +static gfc_namespace *gfc_intrinsic_namespace; + +bool gfc_init_expr_flag = false; + +/* Pointers to an intrinsic function and its argument names that are being + checked. */ + +const char *gfc_current_intrinsic; +gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +locus *gfc_current_intrinsic_where; + +static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; +static gfc_intrinsic_sym *char_conversions; +static gfc_intrinsic_arg *next_arg; + +static int nfunc, nsub, nargs, nconv, ncharconv; + +static enum +{ SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS } +sizing; + +enum klass +{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL, + CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC }; + +#define ACTUAL_NO 0 +#define ACTUAL_YES 1 + +#define REQUIRED 0 +#define OPTIONAL 1 + + +/* Return a letter based on the passed type. Used to construct the + name of a type-dependent subroutine. If logical_equals_int is + true, we can treat a logical like an int. */ + +char +gfc_type_letter (bt type, bool logical_equals_int) +{ + char c; + + switch (type) + { + case BT_LOGICAL: + if (logical_equals_int) + c = 'i'; + else + c = 'l'; + + break; + case BT_CHARACTER: + c = 's'; + break; + case BT_INTEGER: + c = 'i'; + break; + case BT_REAL: + c = 'r'; + break; + case BT_COMPLEX: + c = 'c'; + break; + + case BT_HOLLERITH: + c = 'h'; + break; + + default: + c = 'u'; + break; + } + + return c; +} + + +/* Return kind that should be used for ABI purposes in libgfortran + APIs. Usually the same as ts->kind, except for BT_REAL/BT_COMPLEX + for IEEE 754 quad format kind 16 where it returns 17. */ + +int +gfc_type_abi_kind (bt type, int kind) +{ + switch (type) + { + case BT_REAL: + case BT_COMPLEX: + if (kind == 16) + for (int i = 0; gfc_real_kinds[i].kind != 0; i++) + if (gfc_real_kinds[i].kind == kind) + return gfc_real_kinds[i].abi_kind; + return kind; + default: + return kind; + } +} + +/* Get a symbol for a resolved name. Note, if needed be, the elemental + attribute has be added afterwards. */ + +gfc_symbol * +gfc_get_intrinsic_sub_symbol (const char *name) +{ + gfc_symbol *sym; + + gfc_get_symbol (name, gfc_intrinsic_namespace, &sym); + sym->attr.always_explicit = 1; + sym->attr.subroutine = 1; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.proc = PROC_INTRINSIC; + + gfc_commit_symbol (sym); + + return sym; +} + +/* Get a symbol for a resolved function, with its special name. The + actual argument list needs to be set by the caller. */ + +gfc_symbol * +gfc_get_intrinsic_function_symbol (gfc_expr *expr) +{ + gfc_symbol *sym; + + gfc_get_symbol (expr->value.function.name, gfc_intrinsic_namespace, &sym); + sym->attr.external = 1; + sym->attr.function = 1; + sym->attr.always_explicit = 1; + sym->attr.proc = PROC_INTRINSIC; + sym->attr.flavor = FL_PROCEDURE; + sym->result = sym; + if (expr->rank > 0) + { + sym->attr.dimension = 1; + sym->as = gfc_get_array_spec (); + sym->as->type = AS_ASSUMED_SHAPE; + sym->as->rank = expr->rank; + } + return sym; +} + +/* Find a symbol for a resolved intrinsic procedure, return NULL if + not found. */ + +gfc_symbol * +gfc_find_intrinsic_symbol (gfc_expr *expr) +{ + gfc_symbol *sym; + gfc_find_symbol (expr->value.function.name, gfc_intrinsic_namespace, + 0, &sym); + return sym; +} + + +/* Return a pointer to the name of a conversion function given two + typespecs. */ + +static const char * +conv_name (gfc_typespec *from, gfc_typespec *to) +{ + return gfc_get_string ("__convert_%c%d_%c%d", + gfc_type_letter (from->type), gfc_type_abi_kind (from), + gfc_type_letter (to->type), gfc_type_abi_kind (to)); +} + + +/* Given a pair of typespecs, find the gfc_intrinsic_sym node that + corresponds to the conversion. Returns NULL if the conversion + isn't found. */ + +static gfc_intrinsic_sym * +find_conv (gfc_typespec *from, gfc_typespec *to) +{ + gfc_intrinsic_sym *sym; + const char *target; + int i; + + target = conv_name (from, to); + sym = conversion; + + for (i = 0; i < nconv; i++, sym++) + if (target == sym->name) + return sym; + + return NULL; +} + + +/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node + that corresponds to the conversion. Returns NULL if the conversion + isn't found. */ + +static gfc_intrinsic_sym * +find_char_conv (gfc_typespec *from, gfc_typespec *to) +{ + gfc_intrinsic_sym *sym; + const char *target; + int i; + + target = conv_name (from, to); + sym = char_conversions; + + for (i = 0; i < ncharconv; i++, sym++) + if (target == sym->name) + return sym; + + return NULL; +} + + +/* Check TS29113, C407b for assumed type and C535b for assumed-rank, + and a likewise check for NO_ARG_CHECK. */ + +static bool +do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) +{ + gfc_actual_arglist *a; + bool ok = true; + + for (a = arg; a; a = a->next) + { + if (!a->expr) + continue; + + if (a->expr->expr_type == EXPR_VARIABLE + && (a->expr->symtree->n.sym->attr.ext_attr + & (1 << EXT_ATTR_NO_ARG_CHECK)) + && specific->id != GFC_ISYM_C_LOC + && specific->id != GFC_ISYM_PRESENT) + { + gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only " + "permitted as argument to the intrinsic functions " + "C_LOC and PRESENT", &a->expr->where); + ok = false; + } + else if (a->expr->ts.type == BT_ASSUMED + && specific->id != GFC_ISYM_LBOUND + && specific->id != GFC_ISYM_PRESENT + && specific->id != GFC_ISYM_RANK + && specific->id != GFC_ISYM_SHAPE + && specific->id != GFC_ISYM_SIZE + && specific->id != GFC_ISYM_SIZEOF + && specific->id != GFC_ISYM_UBOUND + && specific->id != GFC_ISYM_IS_CONTIGUOUS + && specific->id != GFC_ISYM_C_LOC) + { + gfc_error ("Assumed-type argument at %L is not permitted as actual" + " argument to the intrinsic %s", &a->expr->where, + gfc_current_intrinsic); + ok = false; + } + else if (a->expr->ts.type == BT_ASSUMED && a != arg) + { + gfc_error ("Assumed-type argument at %L is only permitted as " + "first actual argument to the intrinsic %s", + &a->expr->where, gfc_current_intrinsic); + ok = false; + } + else if (a->expr->rank == -1 && !specific->inquiry) + { + gfc_error ("Assumed-rank argument at %L is only permitted as actual " + "argument to intrinsic inquiry functions", + &a->expr->where); + ok = false; + } + else if (a->expr->rank == -1 && arg != a) + { + gfc_error ("Assumed-rank argument at %L is only permitted as first " + "actual argument to the intrinsic inquiry function %s", + &a->expr->where, gfc_current_intrinsic); + ok = false; + } + } + + return ok; +} + + +/* Interface to the check functions. We break apart an argument list + and call the proper check function rather than forcing each + function to manipulate the argument list. */ + +static bool +do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) +{ + gfc_expr *a1, *a2, *a3, *a4, *a5; + + if (arg == NULL) + return (*specific->check.f0) (); + + a1 = arg->expr; + arg = arg->next; + if (arg == NULL) + return (*specific->check.f1) (a1); + + a2 = arg->expr; + arg = arg->next; + if (arg == NULL) + return (*specific->check.f2) (a1, a2); + + a3 = arg->expr; + arg = arg->next; + if (arg == NULL) + return (*specific->check.f3) (a1, a2, a3); + + a4 = arg->expr; + arg = arg->next; + if (arg == NULL) + return (*specific->check.f4) (a1, a2, a3, a4); + + a5 = arg->expr; + arg = arg->next; + if (arg == NULL) + return (*specific->check.f5) (a1, a2, a3, a4, a5); + + gfc_internal_error ("do_check(): too many args"); +} + + +/*********** Subroutines to build the intrinsic list ****************/ + +/* Add a single intrinsic symbol to the current list. + + Argument list: + char * name of function + int whether function is elemental + int If the function can be used as an actual argument [1] + bt return type of function + int kind of return type of function + int Fortran standard version + check pointer to check function + simplify pointer to simplification function + resolve pointer to resolution function + + Optional arguments come in multiples of five: + char * name of argument + bt type of argument + int kind of argument + int arg optional flag (1=optional, 0=required) + sym_intent intent of argument + + The sequence is terminated by a NULL name. + + + [1] Whether a function can or cannot be used as an actual argument is + determined by its presence on the 13.6 list in Fortran 2003. The + following intrinsics, which are GNU extensions, are considered allowed + as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG + ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT. */ + +static void +add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, + int standard, gfc_check_f check, gfc_simplify_f simplify, + gfc_resolve_f resolve, ...) +{ + char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */ + int optional, first_flag; + sym_intent intent; + va_list argp; + + switch (sizing) + { + case SZ_SUBS: + nsub++; + break; + + case SZ_FUNCS: + nfunc++; + break; + + case SZ_NOTHING: + next_sym->name = gfc_get_string ("%s", name); + + strcpy (buf, "_gfortran_"); + strcat (buf, name); + next_sym->lib_name = gfc_get_string ("%s", buf); + + next_sym->pure = (cl != CLASS_IMPURE); + next_sym->elemental = (cl == CLASS_ELEMENTAL); + next_sym->inquiry = (cl == CLASS_INQUIRY); + next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL); + next_sym->actual_ok = actual_ok; + next_sym->ts.type = type; + next_sym->ts.kind = kind; + next_sym->standard = standard; + next_sym->simplify = simplify; + next_sym->check = check; + next_sym->resolve = resolve; + next_sym->specific = 0; + next_sym->generic = 0; + next_sym->conversion = 0; + next_sym->id = id; + break; + + default: + gfc_internal_error ("add_sym(): Bad sizing mode"); + } + + va_start (argp, resolve); + + first_flag = 1; + + for (;;) + { + name = va_arg (argp, char *); + if (name == NULL) + break; + + type = (bt) va_arg (argp, int); + kind = va_arg (argp, int); + optional = va_arg (argp, int); + intent = (sym_intent) va_arg (argp, int); + + if (sizing != SZ_NOTHING) + nargs++; + else + { + next_arg++; + + if (first_flag) + next_sym->formal = next_arg; + else + (next_arg - 1)->next = next_arg; + + first_flag = 0; + + strcpy (next_arg->name, name); + next_arg->ts.type = type; + next_arg->ts.kind = kind; + next_arg->optional = optional; + next_arg->value = 0; + next_arg->intent = intent; + } + } + + va_end (argp); + + next_sym++; +} + + +/* Add a symbol to the function list where the function takes + 0 arguments. */ + +static void +add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (void), + gfc_expr *(*simplify) (void), + void (*resolve) (gfc_expr *)) +{ + gfc_simplify_f sf; + gfc_check_f cf; + gfc_resolve_f rf; + + cf.f0 = check; + sf.f0 = simplify; + rf.f0 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + (void *) 0); +} + + +/* Add a symbol to the subroutine list where the subroutine takes + 0 arguments. */ + +static void +add_sym_0s (const char *name, gfc_isym_id id, int standard, + void (*resolve) (gfc_code *)) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1 = NULL; + sf.f1 = NULL; + rf.s1 = resolve; + + add_sym (name, id, CLASS_IMPURE, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, + rf, (void *) 0); +} + + +/* Add a symbol to the function list where the function takes + 1 arguments. */ + +static void +add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1 = check; + sf.f1 = simplify; + rf.f1 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + (void *) 0); +} + + +/* Add a symbol to the function list where the function takes + 1 arguments, specifying the intent of the argument. */ + +static void +add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl, + int actual_ok, bt type, int kind, int standard, + bool (*check) (gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1 = check; + sf.f1 = simplify; + rf.f1 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + (void *) 0); +} + + +/* Add a symbol to the subroutine list where the subroutine takes + 1 arguments, specifying the intent of the argument. */ + +static void +add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, + int standard, bool (*check) (gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1 = check; + sf.f1 = simplify; + rf.s1 = resolve; + + add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + (void *) 0); +} + +/* Add a symbol to the subroutine ilst where the subroutine takes one + printf-style character argument and a variable number of arguments + to follow. */ + +static void +add_sym_1p (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, + int standard, bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr*), void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, sym_intent intent1) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1m = check; + sf.f1 = simplify; + rf.s1 = resolve; + + add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + (void *) 0); +} + + +/* Add a symbol from the MAX/MIN family of intrinsic functions to the + function. MAX et al take 2 or more arguments. */ + +static void +add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr *), + void (*resolve) (gfc_expr *, gfc_actual_arglist *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1m = check; + sf.f1 = simplify; + rf.f1m = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + (void *) 0); +} + + +/* Add a symbol to the function list where the function takes + 2 arguments. */ + +static void +add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f2 = check; + sf.f2 = simplify; + rf.f2 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + (void *) 0); +} + + +/* Add a symbol to the function list where the function takes + 2 arguments; same as add_sym_2 - but allows to specify the intent. */ + +static void +add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl, + int actual_ok, bt type, int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f2 = check; + sf.f2 = simplify; + rf.f2 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + a2, type2, kind2, optional2, intent2, + (void *) 0); +} + + +/* Add a symbol to the subroutine list where the subroutine takes + 2 arguments, specifying the intent of the arguments. */ + +static void +add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, + int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), + void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f2 = check; + sf.f2 = simplify; + rf.s1 = resolve; + + add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + a2, type2, kind2, optional2, intent2, + (void *) 0); +} + + +/* Add a symbol to the function list where the function takes + 3 arguments. */ + +static void +add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3 = check; + sf.f3 = simplify; + rf.f3 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + (void *) 0); +} + + +/* MINLOC and MAXLOC get special treatment because their + argument might have to be reordered. */ + +static void +add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4, + const char *a5, bt type5, int kind5, int optional5) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f5ml = check; + sf.f5 = simplify; + rf.f5 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, + a5, type5, kind5, optional5, INTENT_IN, + (void *) 0); +} + +/* Similar for FINDLOC. */ + +static void +add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, + bt type, int kind, int standard, + bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4, + const char *a5, bt type5, int kind5, int optional5, + const char *a6, bt type6, int kind6, int optional6) + +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f6fl = check; + sf.f6 = simplify; + rf.f6 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, + a5, type5, kind5, optional5, INTENT_IN, + a6, type6, kind6, optional6, INTENT_IN, + (void *) 0); +} + + +/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because + their argument also might have to be reordered. */ + +static void +add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (gfc_actual_arglist *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3red = check; + sf.f3 = simplify; + rf.f3 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + (void *) 0); +} + + +/* Add a symbol to the subroutine list where the subroutine takes + 3 arguments, specifying the intent of the arguments. */ + +static void +add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, + int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2, const char *a3, bt type3, + int kind3, int optional3, sym_intent intent3) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3 = check; + sf.f3 = simplify; + rf.s1 = resolve; + + add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + a2, type2, kind2, optional2, intent2, + a3, type3, kind3, optional3, intent3, + (void *) 0); +} + + +/* Add a symbol to the function list where the function takes + 4 arguments. */ + +static void +add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, + int kind, int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + const char *a1, bt type1, int kind1, int optional1, + const char *a2, bt type2, int kind2, int optional2, + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4 ) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f4 = check; + sf.f4 = simplify; + rf.f4 = resolve; + + add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, INTENT_IN, + a2, type2, kind2, optional2, INTENT_IN, + a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, + (void *) 0); +} + + +/* Add a symbol to the subroutine list where the subroutine takes + 4 arguments. */ + +static void +add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, + int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2, const char *a3, bt type3, + int kind3, int optional3, sym_intent intent3, const char *a4, + bt type4, int kind4, int optional4, sym_intent intent4) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f4 = check; + sf.f4 = simplify; + rf.s1 = resolve; + + add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + a2, type2, kind2, optional2, intent2, + a3, type3, kind3, optional3, intent3, + a4, type4, kind4, optional4, intent4, + (void *) 0); +} + + +/* Add a symbol to the subroutine list where the subroutine takes + 5 arguments. */ + +static void +add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, + int standard, + bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *, gfc_expr *), + void (*resolve) (gfc_code *), + const char *a1, bt type1, int kind1, int optional1, + sym_intent intent1, const char *a2, bt type2, int kind2, + int optional2, sym_intent intent2, const char *a3, bt type3, + int kind3, int optional3, sym_intent intent3, const char *a4, + bt type4, int kind4, int optional4, sym_intent intent4, + const char *a5, bt type5, int kind5, int optional5, + sym_intent intent5) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f5 = check; + sf.f5 = simplify; + rf.s1 = resolve; + + add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, + a1, type1, kind1, optional1, intent1, + a2, type2, kind2, optional2, intent2, + a3, type3, kind3, optional3, intent3, + a4, type4, kind4, optional4, intent4, + a5, type5, kind5, optional5, intent5, + (void *) 0); +} + + +/* Locate an intrinsic symbol given a base pointer, number of elements + in the table and a pointer to a name. Returns the NULL pointer if + a name is not found. */ + +static gfc_intrinsic_sym * +find_sym (gfc_intrinsic_sym *start, int n, const char *name) +{ + /* name may be a user-supplied string, so we must first make sure + that we're comparing against a pointer into the global string + table. */ + const char *p = gfc_get_string ("%s", name); + + while (n > 0) + { + if (p == start->name) + return start; + + start++; + n--; + } + + return NULL; +} + + +gfc_isym_id +gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id) +{ + if (from_intmod == INTMOD_NONE) + return (gfc_isym_id) intmod_sym_id; + else if (from_intmod == INTMOD_ISO_C_BINDING) + return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value; + else if (from_intmod == INTMOD_ISO_FORTRAN_ENV) + switch (intmod_sym_id) + { +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + return (gfc_isym_id) c; +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + return (gfc_isym_id) c; +#include "iso-fortran-env.def" + default: + gcc_unreachable (); + } + else + gcc_unreachable (); + return (gfc_isym_id) 0; +} + + +gfc_isym_id +gfc_isym_id_by_intmod_sym (gfc_symbol *sym) +{ + return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id); +} + + +gfc_intrinsic_sym * +gfc_intrinsic_subroutine_by_id (gfc_isym_id id) +{ + gfc_intrinsic_sym *start = subroutines; + int n = nsub; + + while (true) + { + gcc_assert (n > 0); + if (id == start->id) + return start; + + start++; + n--; + } +} + + +gfc_intrinsic_sym * +gfc_intrinsic_function_by_id (gfc_isym_id id) +{ + gfc_intrinsic_sym *start = functions; + int n = nfunc; + + while (true) + { + gcc_assert (n > 0); + if (id == start->id) + return start; + + start++; + n--; + } +} + + +/* Given a name, find a function in the intrinsic function table. + Returns NULL if not found. */ + +gfc_intrinsic_sym * +gfc_find_function (const char *name) +{ + gfc_intrinsic_sym *sym; + + sym = find_sym (functions, nfunc, name); + if (!sym || sym->from_module) + sym = find_sym (conversion, nconv, name); + + return (!sym || sym->from_module) ? NULL : sym; +} + + +/* Given a name, find a function in the intrinsic subroutine table. + Returns NULL if not found. */ + +gfc_intrinsic_sym * +gfc_find_subroutine (const char *name) +{ + gfc_intrinsic_sym *sym; + sym = find_sym (subroutines, nsub, name); + return (!sym || sym->from_module) ? NULL : sym; +} + + +/* Given a string, figure out if it is the name of a generic intrinsic + function or not. */ + +int +gfc_generic_intrinsic (const char *name) +{ + gfc_intrinsic_sym *sym; + + sym = gfc_find_function (name); + return (!sym || sym->from_module) ? 0 : sym->generic; +} + + +/* Given a string, figure out if it is the name of a specific + intrinsic function or not. */ + +int +gfc_specific_intrinsic (const char *name) +{ + gfc_intrinsic_sym *sym; + + sym = gfc_find_function (name); + return (!sym || sym->from_module) ? 0 : sym->specific; +} + + +/* Given a string, figure out if it is the name of an intrinsic function + or subroutine allowed as an actual argument or not. */ +int +gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag) +{ + gfc_intrinsic_sym *sym; + + /* Intrinsic subroutines are not allowed as actual arguments. */ + if (subroutine_flag) + return 0; + else + { + sym = gfc_find_function (name); + return (sym == NULL) ? 0 : sym->actual_ok; + } +} + + +/* Given a symbol, find out if it is (and is to be treated as) an intrinsic. + If its name refers to an intrinsic, but this intrinsic is not included in + the selected standard, this returns FALSE and sets the symbol's external + attribute. */ + +bool +gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) +{ + gfc_intrinsic_sym* isym; + const char* symstd; + + /* If INTRINSIC attribute is already known, return. */ + if (sym->attr.intrinsic) + return true; + + /* Check for attributes which prevent the symbol from being INTRINSIC. */ + if (sym->attr.external || sym->attr.contained + || sym->attr.if_source == IFSRC_IFBODY) + return false; + + if (subroutine_flag) + isym = gfc_find_subroutine (sym->name); + else + isym = gfc_find_function (sym->name); + + /* No such intrinsic available at all? */ + if (!isym) + return false; + + /* See if this intrinsic is allowed in the current standard. */ + if (!gfc_check_intrinsic_standard (isym, &symstd, false, loc) + && !sym->attr.artificial) + { + if (sym->attr.proc == PROC_UNKNOWN && warn_intrinsics_std) + gfc_warning_now (OPT_Wintrinsics_std, "The intrinsic %qs at %L is not " + "included in the selected standard but %s and %qs will" + " be treated as if declared EXTERNAL. Use an" + " appropriate %<-std=%>* option or define" + " %<-fall-intrinsics%> to allow this intrinsic.", + sym->name, &loc, symstd, sym->name); + + return false; + } + + return true; +} + + +/* Collect a set of intrinsic functions into a generic collection. + The first argument is the name of the generic function, which is + also the name of a specific function. The rest of the specifics + currently in the table are placed into the list of specific + functions associated with that generic. + + PR fortran/32778 + FIXME: Remove the argument STANDARD if no regressions are + encountered. Change all callers (approx. 360). +*/ + +static void +make_generic (const char *name, gfc_isym_id id, int standard ATTRIBUTE_UNUSED) +{ + gfc_intrinsic_sym *g; + + if (sizing != SZ_NOTHING) + return; + + g = gfc_find_function (name); + if (g == NULL) + gfc_internal_error ("make_generic(): Cannot find generic symbol %qs", + name); + + gcc_assert (g->id == id); + + g->generic = 1; + g->specific = 1; + if ((g + 1)->name != NULL) + g->specific_head = g + 1; + g++; + + while (g->name != NULL) + { + g->next = g + 1; + g->specific = 1; + g++; + } + + g--; + g->next = NULL; +} + + +/* Create a duplicate intrinsic function entry for the current + function, the only differences being the alternate name and + a different standard if necessary. Note that we use argument + lists more than once, but all argument lists are freed as a + single block. */ + +static void +make_alias (const char *name, int standard) +{ + switch (sizing) + { + case SZ_FUNCS: + nfunc++; + break; + + case SZ_SUBS: + nsub++; + break; + + case SZ_NOTHING: + next_sym[0] = next_sym[-1]; + next_sym->name = gfc_get_string ("%s", name); + next_sym->standard = standard; + next_sym++; + break; + + default: + break; + } +} + + +/* Make the current subroutine noreturn. */ + +static void +make_noreturn (void) +{ + if (sizing == SZ_NOTHING) + next_sym[-1].noreturn = 1; +} + + +/* Mark current intrinsic as module intrinsic. */ +static void +make_from_module (void) +{ + if (sizing == SZ_NOTHING) + next_sym[-1].from_module = 1; +} + + +/* Mark the current subroutine as having a variable number of + arguments. */ + +static void +make_vararg (void) +{ + if (sizing == SZ_NOTHING) + next_sym[-1].vararg = 1; +} + +/* Set the attr.value of the current procedure. */ + +static void +set_attr_value (int n, ...) +{ + gfc_intrinsic_arg *arg; + va_list argp; + int i; + + if (sizing != SZ_NOTHING) + return; + + va_start (argp, n); + arg = next_sym[-1].formal; + + for (i = 0; i < n; i++) + { + gcc_assert (arg != NULL); + arg->value = va_arg (argp, int); + arg = arg->next; + } + va_end (argp); +} + + +/* Add intrinsic functions. */ + +static void +add_functions (void) +{ + /* Argument names. These are used as argument keywords and so need to + match the documentation. Please keep this list in sorted order. */ + const char + *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", + *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", + *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command", + *dist = "distance", *dm = "dim", *f = "field", *failed="failed", + *fs = "fsource", *han = "handler", *i = "i", + *image = "image", *j = "j", *kind = "kind", + *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a", + *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask", + *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number", + *ord = "order", *p = "p", *p1 = "path1", *p2 = "path2", + *pad = "pad", *pid = "pid", *pos = "pos", *pt = "pointer", + *r = "r", *s = "s", *set = "set", *sh = "shift", *shp = "shape", + *sig = "sig", *src = "source", *ssg = "substring", + *sta = "string_a", *stb = "string_b", *stg = "string", + *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time", + *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", + *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", + *z = "z"; + + int di, dr, dd, dl, dc, dz, ii; + + di = gfc_default_integer_kind; + dr = gfc_default_real_kind; + dd = gfc_default_double_kind; + dl = gfc_default_logical_kind; + dc = gfc_default_character_kind; + dz = gfc_default_complex_kind; + ii = gfc_index_integer_kind; + + add_sym_1 ("abs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs, + a, BT_REAL, dr, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("babs", GFC_STD_GNU); + make_alias ("iiabs", GFC_STD_GNU); + make_alias ("jiabs", GFC_STD_GNU); + make_alias ("kiabs", GFC_STD_GNU); + } + + add_sym_1 ("iabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, + NULL, gfc_simplify_abs, gfc_resolve_abs, + a, BT_INTEGER, di, REQUIRED); + + add_sym_1 ("dabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_abs, gfc_resolve_abs, + a, BT_REAL, dd, REQUIRED); + + add_sym_1 ("cabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + NULL, gfc_simplify_abs, gfc_resolve_abs, + a, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, + NULL, gfc_simplify_abs, gfc_resolve_abs, + a, BT_COMPLEX, dd, REQUIRED); + + make_alias ("cdabs", GFC_STD_GNU); + + make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77); + + /* The checking function for ACCESS is called gfc_check_access_func + because the name gfc_check_access is already used in module.c. */ + add_sym_2 ("access", GFC_ISYM_ACCESS, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_access_func, NULL, gfc_resolve_access, + nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); + + make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU); + + add_sym_2 ("achar", GFC_ISYM_ACHAR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, + gfc_check_achar, gfc_simplify_achar, gfc_resolve_achar, + i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95); + + add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_acos, gfc_resolve_acos, + x, BT_REAL, dd, REQUIRED); + + make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77); + + add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh, + gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_acosh, gfc_resolve_acosh, + x, BT_REAL, dd, REQUIRED); + + make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008); + + add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl, + gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED); + + make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95); + + add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr, + gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED); + + make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95); + + add_sym_1 ("aimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag, + z, BT_COMPLEX, dz, REQUIRED); + + make_alias ("imag", GFC_STD_GNU); + make_alias ("imagpart", GFC_STD_GNU); + + add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, + NULL, gfc_simplify_aimag, gfc_resolve_aimag, + z, BT_COMPLEX, dd, REQUIRED); + + make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77); + + add_sym_2 ("aint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint, + a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + add_sym_1 ("dint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + NULL, gfc_simplify_dint, gfc_resolve_dint, + a, BT_REAL, dd, REQUIRED); + + make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77); + + add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, + gfc_check_all_any, gfc_simplify_all, gfc_resolve_all, + msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95); + + add_sym_1 ("allocated", GFC_ISYM_ALLOCATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, + gfc_check_allocated, NULL, NULL, + ar, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95); + + add_sym_2 ("anint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint, + a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + add_sym_1 ("dnint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + NULL, gfc_simplify_dnint, gfc_resolve_dnint, + a, BT_REAL, dd, REQUIRED); + + make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77); + + add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, + gfc_check_all_any, gfc_simplify_any, gfc_resolve_any, + msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95); + + add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_asin, gfc_resolve_asin, + x, BT_REAL, dd, REQUIRED); + + make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77); + + add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh, + gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_asinh, gfc_resolve_asinh, + x, BT_REAL, dd, REQUIRED); + + make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_F2008); + + add_sym_2 ("associated", GFC_ISYM_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F95, gfc_check_associated, NULL, NULL, + pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL); + + make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95); + + add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_atan, gfc_resolve_atan, + x, BT_REAL, dd, REQUIRED); + + /* Two-argument version of atan, equivalent to atan2. */ + add_sym_2 ("atan", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008, + gfc_check_atan_2, gfc_simplify_atan2, gfc_resolve_atan2, + y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); + + make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77); + + add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, + GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh, + gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_atanh, gfc_resolve_atanh, + x, BT_REAL, dd, REQUIRED); + + make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_F2008); + + add_sym_2 ("atan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2, + y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); + + add_sym_2 ("datan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_datan2, gfc_simplify_atan2, gfc_resolve_atan2, + y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED); + + make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77); + + /* Bessel and Neumann functions for G77 compatibility. */ + add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, + x, BT_REAL, dr, REQUIRED); + + make_alias ("bessel_j0", GFC_STD_F2008); + + add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, + x, BT_REAL, dd, REQUIRED); + + make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008); + + add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, + x, BT_REAL, dr, REQUIRED); + + make_alias ("bessel_j1", GFC_STD_F2008); + + add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, + x, BT_REAL, dd, REQUIRED); + + make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008); + + add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, + n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); + + make_alias ("bessel_jn", GFC_STD_F2008); + + add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, + n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); + + add_sym_3 ("bessel_jn", GFC_ISYM_JN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_bessel_n2, gfc_simplify_bessel_jn2, gfc_resolve_bessel_n2, + "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, + x, BT_REAL, dr, REQUIRED); + set_attr_value (3, true, true, true); + + make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008); + + add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, + x, BT_REAL, dr, REQUIRED); + + make_alias ("bessel_y0", GFC_STD_F2008); + + add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, + x, BT_REAL, dd, REQUIRED); + + make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008); + + add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, + x, BT_REAL, dr, REQUIRED); + + make_alias ("bessel_y1", GFC_STD_F2008); + + add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, + x, BT_REAL, dd, REQUIRED); + + make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008); + + add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, + n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); + + make_alias ("bessel_yn", GFC_STD_F2008); + + add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, + n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); + + add_sym_3 ("bessel_yn", GFC_ISYM_YN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_bessel_n2, gfc_simplify_bessel_yn2, gfc_resolve_bessel_n2, + "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, + x, BT_REAL, dr, REQUIRED); + set_attr_value (3, true, true, true); + + make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008); + + add_sym_2 ("bge", GFC_ISYM_BGE, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_bge, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("bge", GFC_ISYM_BGE, GFC_STD_F2008); + + add_sym_2 ("bgt", GFC_ISYM_BGT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_bgt, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008); + + add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_i, gfc_simplify_bit_size, NULL, + i, BT_INTEGER, di, REQUIRED); + + make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95); + + add_sym_2 ("ble", GFC_ISYM_BLE, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_ble, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("ble", GFC_ISYM_BLE, GFC_STD_F2008); + + add_sym_2 ("blt", GFC_ISYM_BLT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_bge_bgt_ble_blt, gfc_simplify_blt, NULL, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + make_generic ("blt", GFC_ISYM_BLT, GFC_STD_F2008); + + add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, + gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest, + i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bbtest", GFC_STD_GNU); + make_alias ("bitest", GFC_STD_GNU); + make_alias ("bjtest", GFC_STD_GNU); + make_alias ("bktest", GFC_STD_GNU); + } + + make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95); + + add_sym_2 ("ceiling", GFC_ISYM_CEILING, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling, + a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95); + + add_sym_2 ("char", GFC_ISYM_CHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77, + gfc_check_char, gfc_simplify_char, gfc_resolve_char, + i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77); + + add_sym_1 ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir, + nm, BT_CHARACTER, dc, REQUIRED); + + make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU); + + add_sym_2 ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_chmod, NULL, gfc_resolve_chmod, + nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); + + make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU); + + add_sym_3 ("cmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_F77, + gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx, + x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77); + + add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL); + + make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, + GFC_STD_F2003); + + add_sym_2 ("complex", GFC_ISYM_COMPLEX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU, + gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex, + x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED); + + make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU); + + /* Making dcmplx a specific of cmplx causes cmplx to return a double + complex instead of the default complex. */ + + add_sym_2 ("dcmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dd, GFC_STD_GNU, + gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx, + x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL); + + make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU); + + add_sym_1 ("conjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, + gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg, + z, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, + NULL, gfc_simplify_conjg, gfc_resolve_conjg, + z, BT_COMPLEX, dd, REQUIRED); + + make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77); + + add_sym_1 ("cos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_cos, gfc_resolve_cos, + x, BT_REAL, dd, REQUIRED); + + add_sym_1 ("ccos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, + NULL, gfc_simplify_cos, gfc_resolve_cos, + x, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, + NULL, gfc_simplify_cos, gfc_resolve_cos, + x, BT_COMPLEX, dd, REQUIRED); + + make_alias ("cdcos", GFC_STD_GNU); + + make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77); + + add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_cosh, gfc_resolve_cosh, + x, BT_REAL, dd, REQUIRED); + + make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77); + + add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_count, gfc_simplify_count, gfc_resolve_count, + msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95); + + add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F95, + gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift, + ar, BT_REAL, dr, REQUIRED, + sh, BT_INTEGER, di, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95); + + add_sym_1 ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, + 0, GFC_STD_GNU, gfc_check_ctime, NULL, gfc_resolve_ctime, + tm, BT_INTEGER, di, REQUIRED); + + make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU); + + add_sym_1 ("dble", GFC_ISYM_DBLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, + gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble, + a, BT_REAL, dr, REQUIRED); + + make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77); + + add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_digits, gfc_simplify_digits, NULL, + x, BT_UNKNOWN, dr, REQUIRED); + + make_generic ("digits", GFC_ISYM_DIGITS, GFC_STD_F95); + + add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim, + x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); + + add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, + NULL, gfc_simplify_dim, gfc_resolve_dim, + x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED); + + add_sym_2 ("ddim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_x_yd, gfc_simplify_dim, gfc_resolve_dim, + x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED); + + make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77); + + add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F95, gfc_check_dot_product, gfc_simplify_dot_product, gfc_resolve_dot_product, + va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED); + + make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95); + + add_sym_2 ("dprod", GFC_ISYM_DPROD,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_dprod, gfc_simplify_dprod, gfc_resolve_dprod, + x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); + + make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77); + + add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_REAL, dd, GFC_STD_GNU, NULL, gfc_simplify_dreal, NULL, + a, BT_COMPLEX, dd, REQUIRED); + + make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU); + + add_sym_3 ("dshiftl", GFC_ISYM_DSHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_dshift, gfc_simplify_dshiftl, gfc_resolve_dshift, + i, BT_INTEGER, di, REQUIRED, + j, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("dshiftl", GFC_ISYM_DSHIFTL, GFC_STD_F2008); + + add_sym_3 ("dshiftr", GFC_ISYM_DSHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_dshift, gfc_simplify_dshiftr, gfc_resolve_dshift, + i, BT_INTEGER, di, REQUIRED, + j, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008); + + add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_eoshift, gfc_simplify_eoshift, gfc_resolve_eoshift, + ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED, + bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95); + + add_sym_1 ("epsilon", GFC_ISYM_EPSILON, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F95, gfc_check_fn_r, gfc_simplify_epsilon, NULL, + x, BT_REAL, dr, REQUIRED); + + make_generic ("epsilon", GFC_ISYM_EPSILON, GFC_STD_F95); + + /* G77 compatibility for the ERF() and ERFC() functions. */ + add_sym_1 ("erf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erf, + gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("derf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erf, + gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); + + make_generic ("erf", GFC_ISYM_ERF, GFC_STD_F2008); + + add_sym_1 ("erfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erfc, + gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("derfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, + GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erfc, + gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); + + make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_F2008); + + add_sym_1 ("erfc_scaled", GFC_ISYM_ERFC_SCALED, CLASS_ELEMENTAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r, + gfc_simplify_erfc_scaled, gfc_resolve_g77_math1, x, BT_REAL, + dr, REQUIRED); + + make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008); + + /* G77 compatibility */ + add_sym_1 ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, + x, BT_REAL, 4, REQUIRED); + + make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU); + + add_sym_1 ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, + x, BT_REAL, 4, REQUIRED); + + make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU); + + add_sym_1 ("exp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_exp, gfc_resolve_exp, + x, BT_REAL, dd, REQUIRED); + + add_sym_1 ("cexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, + NULL, gfc_simplify_exp, gfc_resolve_exp, + x, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, + NULL, gfc_simplify_exp, gfc_resolve_exp, + x, BT_COMPLEX, dd, REQUIRED); + + make_alias ("cdexp", GFC_STD_GNU); + + make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77); + + add_sym_1 ("exponent", GFC_ISYM_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_F95, gfc_check_fn_r, gfc_simplify_exponent, gfc_resolve_exponent, + x, BT_REAL, dr, REQUIRED); + + make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95); + + add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY, + ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_same_type_as, gfc_simplify_extends_type_of, + gfc_resolve_extends_type_of, + a, BT_UNKNOWN, 0, REQUIRED, + mo, BT_UNKNOWN, 0, REQUIRED); + + add_sym_2 ("failed_images", GFC_ISYM_FAILED_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2018, + gfc_check_failed_or_stopped_images, + gfc_simplify_failed_or_stopped_images, + gfc_resolve_failed_images, team, BT_VOID, di, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, + dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate); + + make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU); + + add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor, + a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95); + + /* G77 compatible fnum */ + add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum, + ut, BT_INTEGER, di, REQUIRED); + + make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU); + + add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F95, gfc_check_fn_r, gfc_simplify_fraction, gfc_resolve_fraction, + x, BT_REAL, dr, REQUIRED); + + make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95); + + add_sym_2_intent ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_fstat, NULL, gfc_resolve_fstat, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); + + make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU); + + add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell, + ut, BT_INTEGER, di, REQUIRED); + + make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU); + + add_sym_2_intent ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_fgetputc, NULL, gfc_resolve_fgetc, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU); + + add_sym_1_intent ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU); + + add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc, + ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED); + + make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU); + + add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput, + c, BT_CHARACTER, dc, REQUIRED); + + make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU); + + add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma, + gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma, + x, BT_REAL, dr, REQUIRED); + + make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008); + + /* Unix IDs (g77 compatibility) */ + add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd, + c, BT_CHARACTER, dc, REQUIRED); + + make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU); + + add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid); + + make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU); + + add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid); + + make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); + + add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, + gfc_check_get_team, NULL, gfc_resolve_get_team, + level, BT_INTEGER, di, OPTIONAL); + + add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); + + make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU); + + add_sym_1_intent ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_hostnm, NULL, gfc_resolve_hostnm, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU); + + add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_huge, gfc_simplify_huge, NULL, + x, BT_UNKNOWN, dr, REQUIRED); + + make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95); + + add_sym_2 ("hypot", GFC_ISYM_HYPOT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F2008, + gfc_check_hypot, gfc_simplify_hypot, gfc_resolve_hypot, + x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); + + make_generic ("hypot", GFC_ISYM_HYPOT, GFC_STD_F2008); + + add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar, + c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95); + + add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_F95, + gfc_check_iand_ieor_ior, gfc_simplify_iand, gfc_resolve_iand, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("biand", GFC_STD_GNU); + make_alias ("iiand", GFC_STD_GNU); + make_alias ("jiand", GFC_STD_GNU); + make_alias ("kiand", GFC_STD_GNU); + } + + make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95); + + add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and, + i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU); + + add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008); + + add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008); + + add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, NULL); + + make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU); + + add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr, + i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bbclr", GFC_STD_GNU); + make_alias ("iibclr", GFC_STD_GNU); + make_alias ("jibclr", GFC_STD_GNU); + make_alias ("kibclr", GFC_STD_GNU); + } + + make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95); + + add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits, + i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED, + ln, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bbits", GFC_STD_GNU); + make_alias ("iibits", GFC_STD_GNU); + make_alias ("jibits", GFC_STD_GNU); + make_alias ("kibits", GFC_STD_GNU); + } + + make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95); + + add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset, + i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bbset", GFC_STD_GNU); + make_alias ("iibset", GFC_STD_GNU); + make_alias ("jibset", GFC_STD_GNU); + make_alias ("kibset", GFC_STD_GNU); + } + + make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95); + + add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F77, + gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar, + c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77); + + add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_F95, + gfc_check_iand_ieor_ior, gfc_simplify_ieor, gfc_resolve_ieor, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bieor", GFC_STD_GNU); + make_alias ("iieor", GFC_STD_GNU); + make_alias ("jieor", GFC_STD_GNU); + make_alias ("kieor", GFC_STD_GNU); + } + + make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95); + + add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor, + i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU); + + add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno); + + make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); + + add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, + ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + + add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status, + gfc_simplify_image_status, gfc_resolve_image_status, image, + BT_INTEGER, di, REQUIRED, team, BT_VOID, di, OPTIONAL); + + /* The resolution function for INDEX is called gfc_resolve_index_func + because the name gfc_resolve_index is already used in resolve.c. */ + add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, + BT_INTEGER, di, GFC_STD_F77, + gfc_check_index, gfc_simplify_index, gfc_resolve_index_func, + stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, + bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77); + + add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, + gfc_check_int, gfc_simplify_int, gfc_resolve_int, + a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, + NULL, gfc_simplify_ifix, NULL, + a, BT_REAL, dr, REQUIRED); + + add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, + NULL, gfc_simplify_idint, NULL, + a, BT_REAL, dd, REQUIRED); + + make_generic ("int", GFC_ISYM_INT, GFC_STD_F77); + + add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2, + a, BT_REAL, dr, REQUIRED); + + make_alias ("short", GFC_STD_GNU); + + make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU); + + add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8, + a, BT_REAL, dr, REQUIRED); + + make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU); + + add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, + gfc_check_intconv, gfc_simplify_long, gfc_resolve_long, + a, BT_REAL, dr, REQUIRED); + + make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU); + + add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_F95, + gfc_check_iand_ieor_ior, gfc_simplify_ior, gfc_resolve_ior, + i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bior", GFC_STD_GNU); + make_alias ("iior", GFC_STD_GNU); + make_alias ("jior", GFC_STD_GNU); + make_alias ("kior", GFC_STD_GNU); + } + + make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95); + + add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or, + i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU); + + add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, + gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008); + + /* The following function is for G77 compatibility. */ + add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + 4, GFC_STD_GNU, gfc_check_irand, NULL, NULL, + i, BT_INTEGER, 4, OPTIONAL); + + make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU); + + add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, + dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty, + ut, BT_INTEGER, di, REQUIRED); + + make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU); + + add_sym_1 ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_is_contiguous, gfc_simplify_is_contiguous, + gfc_resolve_is_contiguous, + ar, BT_REAL, dr, REQUIRED); + + make_generic ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, GFC_STD_F2008); + + add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, + CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_i, gfc_simplify_is_iostat_end, NULL, + i, BT_INTEGER, 0, REQUIRED); + + make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003); + + add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, + CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_i, gfc_simplify_is_iostat_eor, NULL, + i, BT_INTEGER, 0, REQUIRED); + + make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003); + + add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_GNU, + gfc_check_isnan, gfc_simplify_isnan, NULL, + x, BT_REAL, 0, REQUIRED); + + make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU); + + add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift, + i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); + + make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU); + + add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift, + i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); + + make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU); + + add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft, + i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bshft", GFC_STD_GNU); + make_alias ("iishft", GFC_STD_GNU); + make_alias ("jishft", GFC_STD_GNU); + make_alias ("kishft", GFC_STD_GNU); + } + + make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95); + + add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc, + i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED, + sz, BT_INTEGER, di, OPTIONAL); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bshftc", GFC_STD_GNU); + make_alias ("iishftc", GFC_STD_GNU); + make_alias ("jishftc", GFC_STD_GNU); + make_alias ("kishftc", GFC_STD_GNU); + } + + make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95); + + add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_kill, NULL, NULL, + pid, BT_INTEGER, di, REQUIRED, sig, BT_INTEGER, di, REQUIRED); + + make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU); + + add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_kind, gfc_simplify_kind, NULL, + x, BT_REAL, dr, REQUIRED); + + make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95); + + add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95); + + add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008); + + add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_i, gfc_simplify_leadz, NULL, + i, BT_INTEGER, di, REQUIRED); + + make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008); + + add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES, + BT_INTEGER, di, GFC_STD_F77, + gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len, + stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77); + + add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim, + stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_alias ("lnblnk", GFC_STD_GNU); + + make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95); + + add_sym_1 ("lgamma", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, + dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma, + x, BT_REAL, dr, REQUIRED); + + make_alias ("log_gamma", GFC_STD_F2008); + + add_sym_1 ("algama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dlgama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_lgamma, gfc_resolve_lgamma, + x, BT_REAL, dr, REQUIRED); + + make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008); + + + add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL, + sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); + + make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77); + + add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL, + sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); + + make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77); + + add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL, + sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); + + make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77); + + add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL, + sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); + + make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77); + + add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link, + p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); + + make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU); + + add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + NULL, gfc_simplify_log, gfc_resolve_log, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_log, gfc_resolve_log, + x, BT_REAL, dd, REQUIRED); + + add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, + NULL, gfc_simplify_log, gfc_resolve_log, + x, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, + NULL, gfc_simplify_log, gfc_resolve_log, + x, BT_COMPLEX, dd, REQUIRED); + + make_alias ("cdlog", GFC_STD_GNU); + + make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77); + + add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + NULL, gfc_simplify_log10, gfc_resolve_log10, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_log10, gfc_resolve_log10, + x, BT_REAL, dd, REQUIRED); + + make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77); + + add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, + gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical, + l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95); + + add_sym_2_intent ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_stat, NULL, gfc_resolve_lstat, + nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); + + make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU); + + add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, + GFC_STD_GNU, gfc_check_malloc, NULL, NULL, + sz, BT_INTEGER, di, REQUIRED); + + make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU); + + add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask, + i, BT_INTEGER, di, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008); + + add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask, + i, BT_INTEGER, di, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008); + + add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul, + ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED); + + make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95); + + /* Note: amax0 is equivalent to real(max), max1 is equivalent to + int(max). The max function must take at least two arguments. */ + + add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77, + gfc_check_min_max, gfc_simplify_max, gfc_resolve_max, + a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED); + + add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, + gfc_check_min_max_integer, gfc_simplify_max, NULL, + a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); + + add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_min_max_integer, gfc_simplify_max, NULL, + a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); + + add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_min_max_real, gfc_simplify_max, NULL, + a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); + + add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, + gfc_check_min_max_real, gfc_simplify_max, NULL, + a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); + + add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, + gfc_check_min_max_double, gfc_simplify_max, NULL, + a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED); + + make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77); + + add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_F95, gfc_check_fn_r, gfc_simplify_maxexponent, NULL, + x, BT_UNKNOWN, dr, REQUIRED); + + make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95); + + add_sym_5ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_minloc_maxloc, gfc_simplify_maxloc, gfc_resolve_maxloc, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL, + bck, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95); + + add_sym_6fl ("findloc", GFC_ISYM_FINDLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_findloc, gfc_simplify_findloc, gfc_resolve_findloc, + ar, BT_REAL, dr, REQUIRED, val, BT_REAL, dr, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL, bck, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("findloc", GFC_ISYM_FINDLOC, GFC_STD_F2008); + + add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95); + + add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock); + + make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU); + + add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8); + + make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU); + + add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_merge, gfc_simplify_merge, gfc_resolve_merge, + ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED, + msk, BT_LOGICAL, dl, REQUIRED); + + make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95); + + add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_merge_bits, gfc_simplify_merge_bits, + gfc_resolve_merge_bits, + i, BT_INTEGER, di, REQUIRED, + j, BT_INTEGER, di, REQUIRED, + msk, BT_INTEGER, di, REQUIRED); + + make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008); + + /* Note: amin0 is equivalent to real(min), min1 is equivalent to + int(min). */ + + add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77, + gfc_check_min_max, gfc_simplify_min, gfc_resolve_min, + a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); + + add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, + gfc_check_min_max_integer, gfc_simplify_min, NULL, + a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); + + add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_min_max_integer, gfc_simplify_min, NULL, + a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); + + add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_min_max_real, gfc_simplify_min, NULL, + a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); + + add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, + gfc_check_min_max_real, gfc_simplify_min, NULL, + a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); + + add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, + gfc_check_min_max_double, gfc_simplify_min, NULL, + a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED); + + make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77); + + add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_F95, gfc_check_fn_r, gfc_simplify_minexponent, NULL, + x, BT_UNKNOWN, dr, REQUIRED); + + make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95); + + add_sym_5ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_minloc_maxloc, gfc_simplify_minloc, gfc_resolve_minloc, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL, + bck, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95); + + add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95); + + add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, + gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod, + a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bmod", GFC_STD_GNU); + make_alias ("imod", GFC_STD_GNU); + make_alias ("jmod", GFC_STD_GNU); + make_alias ("kmod", GFC_STD_GNU); + } + + add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + NULL, gfc_simplify_mod, gfc_resolve_mod, + a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED); + + add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_x_yd, gfc_simplify_mod, gfc_resolve_mod, + a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED); + + make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77); + + add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95, + gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo, + a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED); + + make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95); + + add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest, + x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED); + + make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95); + + add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc, + GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL, + a, BT_CHARACTER, dc, REQUIRED); + + make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003); + + add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, + gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint, + a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, + gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint, + a, BT_REAL, dd, REQUIRED); + + make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77); + + add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_i, gfc_simplify_not, gfc_resolve_not, + i, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bnot", GFC_STD_GNU); + make_alias ("inot", GFC_STD_GNU); + make_alias ("jnot", GFC_STD_GNU); + make_alias ("knot", GFC_STD_GNU); + } + + make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95); + + add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2, + x, BT_REAL, dr, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008); + + add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_null, gfc_simplify_null, NULL, + mo, BT_INTEGER, di, OPTIONAL); + + make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); + + add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + gfc_check_num_images, gfc_simplify_num_images, NULL, + dist, BT_INTEGER, di, OPTIONAL, + failed, BT_LOGICAL, dl, OPTIONAL); + + add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack, + ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, + v, BT_REAL, dr, OPTIONAL); + + make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95); + + + add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, + GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity, + msk, BT_LOGICAL, dl, REQUIRED, + dm, BT_INTEGER, ii, OPTIONAL); + + make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008); + + add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_i, gfc_simplify_popcnt, NULL, + i, BT_INTEGER, di, REQUIRED); + + make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008); + + add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_i, gfc_simplify_poppar, NULL, + i, BT_INTEGER, di, REQUIRED); + + make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008); + + add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_precision, gfc_simplify_precision, NULL, + x, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95); + + add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN); + + make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95); + + add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95); + + add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_radix, gfc_simplify_radix, NULL, + x, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95); + + /* The following function is for G77 compatibility. */ + add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, gfc_check_rand, NULL, NULL, + i, BT_INTEGER, 4, OPTIONAL); + + /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran() + use slightly different shoddy multiplicative congruential PRNG. */ + make_alias ("ran", GFC_STD_GNU); + + make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU); + + add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_range, gfc_simplify_range, NULL, + x, BT_REAL, dr, REQUIRED); + + make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95); + + add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_F2018, gfc_check_rank, gfc_simplify_rank, gfc_resolve_rank, + a, BT_REAL, dr, REQUIRED); + make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2018); + + add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_real, gfc_simplify_real, gfc_resolve_real, + a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77); + + /* This provides compatibility with g77. */ + add_sym_1 ("realpart", GFC_ISYM_REALPART, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart, + a, BT_UNKNOWN, dr, REQUIRED); + + make_generic ("realpart", GFC_ISYM_REALPART, GFC_STD_F77); + + add_sym_1 ("float", GFC_ISYM_FLOAT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_float, gfc_simplify_float, NULL, + a, BT_INTEGER, di, REQUIRED); + + if (flag_dec_intrinsic_ints) + { + make_alias ("floati", GFC_STD_GNU); + make_alias ("floatj", GFC_STD_GNU); + make_alias ("floatk", GFC_STD_GNU); + } + + make_generic ("float", GFC_ISYM_FLOAT, GFC_STD_F77); + + add_sym_1 ("dfloat", GFC_ISYM_DFLOAT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, + gfc_check_float, gfc_simplify_dble, gfc_resolve_dble, + a, BT_REAL, dr, REQUIRED); + + make_generic ("dfloat", GFC_ISYM_DFLOAT, GFC_STD_F77); + + add_sym_1 ("sngl", GFC_ISYM_SNGL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, + gfc_check_sngl, gfc_simplify_sngl, NULL, + a, BT_REAL, dd, REQUIRED); + + make_generic ("sngl", GFC_ISYM_SNGL, GFC_STD_F77); + + add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename, + p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); + + make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU); + + add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, + gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat, + stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED); + + make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95); + + add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape, + src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED, + pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL); + + make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95); + + add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F95, gfc_check_fn_r, gfc_simplify_rrspacing, gfc_resolve_rrspacing, + x, BT_REAL, dr, REQUIRED); + + make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95); + + add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_same_type_as, gfc_simplify_same_type_as, NULL, + a, BT_UNKNOWN, 0, REQUIRED, + b, BT_UNKNOWN, 0, REQUIRED); + + add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale, + x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); + + make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95); + + add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan, + stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED, + bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95); + + /* Added for G77 compatibility garbage. */ + add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + 4, GFC_STD_GNU, NULL, NULL, NULL); + + make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU); + + /* Added for G77 compatibility. */ + add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL, + dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds, + x, BT_REAL, dr, REQUIRED); + + make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU); + + add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, + gfc_check_selected_char_kind, gfc_simplify_selected_char_kind, + NULL, nm, BT_CHARACTER, dc, REQUIRED); + + make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003); + + add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_F95, gfc_check_selected_int_kind, + gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED); + + make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); + + add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_F95, gfc_check_selected_real_kind, + gfc_simplify_selected_real_kind, NULL, + p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL, + "radix", BT_INTEGER, di, OPTIONAL); + + make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95); + + add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_set_exponent, gfc_simplify_set_exponent, + gfc_resolve_set_exponent, + x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); + + make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95); + + add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape, + src, BT_REAL, dr, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95); + + add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift, + i, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008); + + add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift, + i, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008); + + add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift, + i, BT_INTEGER, di, REQUIRED, + sh, BT_INTEGER, di, REQUIRED); + + make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008); + + add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign, + a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED); + + add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, + NULL, gfc_simplify_sign, gfc_resolve_sign, + a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED); + + add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_x_yd, gfc_simplify_sign, gfc_resolve_sign, + a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED); + + make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77); + + add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal, + num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED); + + make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU); + + add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_sin, gfc_resolve_sin, + x, BT_REAL, dd, REQUIRED); + + add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, + NULL, gfc_simplify_sin, gfc_resolve_sin, + x, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, + NULL, gfc_simplify_sin, gfc_resolve_sin, + x, BT_COMPLEX, dd, REQUIRED); + + make_alias ("cdsin", GFC_STD_GNU); + + make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77); + + add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_sinh, gfc_resolve_sinh, + x, BT_REAL, dd, REQUIRED); + + make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77); + + add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_size, gfc_simplify_size, gfc_resolve_size, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95); + + /* Obtain the stride for a given dimensions; to be used only internally. + "make_from_module" makes it inaccessible for external users. */ + add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU, + NULL, NULL, gfc_resolve_stride, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); + make_from_module(); + + add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, ii, GFC_STD_GNU, + gfc_check_sizeof, gfc_simplify_sizeof, NULL, + x, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU); + + /* The following functions are part of ISO_C_BINDING. */ + add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL, + c_ptr_1, BT_VOID, 0, REQUIRED, + c_ptr_2, BT_VOID, 0, OPTIONAL); + make_from_module(); + + add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO, + BT_VOID, 0, GFC_STD_F2003, + gfc_check_c_loc, NULL, gfc_resolve_c_loc, + x, BT_UNKNOWN, 0, REQUIRED); + make_from_module(); + + add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO, + BT_VOID, 0, GFC_STD_F2003, + gfc_check_c_funloc, NULL, gfc_resolve_c_funloc, + x, BT_UNKNOWN, 0, REQUIRED); + make_from_module(); + + add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008, + gfc_check_c_sizeof, gfc_simplify_sizeof, NULL, + x, BT_UNKNOWN, 0, REQUIRED); + make_from_module(); + + /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */ + add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY, + ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008, + NULL, gfc_simplify_compiler_options, NULL); + make_from_module(); + + add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_INQUIRY, + ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008, + NULL, gfc_simplify_compiler_version, NULL); + make_from_module(); + + add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F95, gfc_check_fn_r, gfc_simplify_spacing, gfc_resolve_spacing, + x, BT_REAL, dr, REQUIRED); + + make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95); + + add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread, + src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED, + ncopies, BT_INTEGER, di, REQUIRED); + + make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95); + + add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt, + x, BT_REAL, dd, REQUIRED); + + add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, + NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, + x, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, + NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, + x, BT_COMPLEX, dd, REQUIRED); + + make_alias ("cdsqrt", GFC_STD_GNU); + + make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77); + + add_sym_2_intent ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_GNU, + gfc_check_stat, NULL, gfc_resolve_stat, + nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); + + make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU); + + add_sym_2 ("stopped_images", GFC_ISYM_STOPPED_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2018, + gfc_check_failed_or_stopped_images, + gfc_simplify_failed_or_stopped_images, + gfc_resolve_stopped_images, team, BT_VOID, di, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_storage_size, gfc_simplify_storage_size, + gfc_resolve_storage_size, + a, BT_UNKNOWN, 0, REQUIRED, + kind, BT_INTEGER, di, OPTIONAL); + + add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + msk, BT_LOGICAL, dl, OPTIONAL); + + make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95); + + add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk, + p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); + + make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU); + + add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_GNU, NULL, NULL, NULL, + com, BT_CHARACTER, dc, REQUIRED); + + make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU); + + add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan, + x, BT_REAL, dd, REQUIRED); + + make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77); + + add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, + gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, + gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh, + x, BT_REAL, dd, REQUIRED); + + make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); + + add_sym_1 ("team_number", GFC_ISYM_TEAM_NUMBER, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, + gfc_check_team_number, NULL, gfc_resolve_team_number, + team, BT_DERIVED, di, OPTIONAL); + + add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, + ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, + dist, BT_INTEGER, di, OPTIONAL); + + add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); + + make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU); + + add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8); + + make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU); + + add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_fn_r, gfc_simplify_tiny, NULL, x, BT_REAL, dr, REQUIRED); + + make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95); + + add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_i, gfc_simplify_trailz, NULL, + i, BT_INTEGER, di, REQUIRED); + + make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008); + + add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer, + src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED, + sz, BT_INTEGER, di, OPTIONAL); + + make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95); + + add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_transpose, gfc_simplify_transpose, gfc_resolve_transpose, + m, BT_REAL, dr, REQUIRED); + + make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95); + + add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, + gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim, + stg, BT_CHARACTER, dc, REQUIRED); + + make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95); + + add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, + 0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam, + ut, BT_INTEGER, di, REQUIRED); + + make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU); + + add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound, + ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95); + + add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound, + ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, + kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008); + + /* g77 compatibility for UMASK. */ + add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, + GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask, + msk, BT_INTEGER, di, REQUIRED); + + make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU); + + /* g77 compatibility for UNLINK. */ + add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, + di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink, + "path", BT_CHARACTER, dc, REQUIRED); + + make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU); + + add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, + gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack, + v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, + f, BT_REAL, dr, REQUIRED); + + make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95); + + add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F95, + gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify, + stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED, + bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); + + make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95); + + add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, + GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc, + x, BT_UNKNOWN, 0, REQUIRED); + + make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU); + + + /* The next of intrinsic subprogram are the degree trignometric functions. + These were hidden behind the -fdec-math option, but are now simply + included as extensions to the set of intrinsic subprograms. */ + + add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_GNU); + + add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_GNU); + + add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + make_generic ("atand", GFC_ISYM_ATAND, GFC_STD_GNU); + + add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2, + y, BT_REAL, dr, REQUIRED, + x, BT_REAL, dr, REQUIRED); + + add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trigd2, + y, BT_REAL, dd, REQUIRED, + x, BT_REAL, dd, REQUIRED); + + make_generic ("atan2d", GFC_ISYM_ATAN2D, GFC_STD_GNU); + + add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_GNU); + + add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, + BT_COMPLEX, dz, GFC_STD_GNU, + NULL, gfc_simplify_cotan, gfc_resolve_trigd, + x, BT_COMPLEX, dz, REQUIRED); + + add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, + BT_COMPLEX, dd, GFC_STD_GNU, + NULL, gfc_simplify_cotan, gfc_resolve_trigd, + x, BT_COMPLEX, dd, REQUIRED); + + make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU); + + add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU); + + add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + make_generic ("sind", GFC_ISYM_SIND, GFC_STD_GNU); + + add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_GNU, + gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd, + x, BT_REAL, dr, REQUIRED); + + add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dd, GFC_STD_GNU, + gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trigd, + x, BT_REAL, dd, REQUIRED); + + make_generic ("tand", GFC_ISYM_TAND, GFC_STD_GNU); + + /* The following function is internally used for coarray libray functions. + "make_from_module" makes it inaccessible for external users. */ + add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO, + BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL, + x, BT_REAL, dr, REQUIRED); + make_from_module(); +} + + +/* Add intrinsic subroutines. */ + +static void +add_subroutines (void) +{ + /* Argument names. These are used as argument keywords and so need to + match the documentation. Please keep this list in sorted order. */ + static const char + *a = "a", *c_ = "c", *c = "count", *cm = "count_max", *com = "command", + *cr = "count_rate", *dt = "date", *errmsg = "errmsg", *f = "from", + *fp = "frompos", *gt = "get", *h = "harvest", *han = "handler", + *length = "length", *ln = "len", *md = "mode", *msk = "mask", + *name = "name", *num = "number", *of = "offset", *old = "old", + *p1 = "path1", *p2 = "path2", *pid = "pid", *pos = "pos", + *pt = "put", *ptr = "ptr", *res = "result", + *result_image = "result_image", *sec = "seconds", *sig = "sig", + *st = "status", *stat = "stat", *sz = "size", *t = "to", + *tm = "time", *tp = "topos", *trim_name = "trim_name", *ut = "unit", + *val = "value", *vl = "values", *whence = "whence", *zn = "zone"; + + int di, dr, dc, dl, ii; + + di = gfc_default_integer_kind; + dr = gfc_default_real_kind; + dc = gfc_default_character_kind; + dl = gfc_default_logical_kind; + ii = gfc_index_integer_kind; + + add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL); + + make_noreturn(); + + add_sym_3s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008, + gfc_check_atomic_def, NULL, gfc_resolve_atomic_def, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008, + gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref, + "value", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "atom", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_5s ("atomic_cas", GFC_ISYM_ATOMIC_CAS, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_cas, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_INOUT, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "compare", BT_INTEGER, di, REQUIRED, INTENT_IN, + "new", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_add", GFC_ISYM_ATOMIC_ADD, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_and", GFC_ISYM_ATOMIC_AND, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_or", GFC_ISYM_ATOMIC_OR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_xor", GFC_ISYM_ATOMIC_XOR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_add", GFC_ISYM_ATOMIC_FETCH_ADD, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_and", GFC_ISYM_ATOMIC_FETCH_AND, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_or", GFC_ISYM_ATOMIC_FETCH_OR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_xor", GFC_ISYM_ATOMIC_FETCH_XOR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL); + + add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time, + tm, BT_REAL, dr, REQUIRED, INTENT_OUT); + + add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_event_query, NULL, gfc_resolve_event_query, + "event", BT_INTEGER, di, REQUIRED, INTENT_IN, + c, BT_INTEGER, di, OPTIONAL, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + /* More G77 compatibility garbage. */ + add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub, + tm, BT_INTEGER, di, REQUIRED, INTENT_IN, + res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_itime_idate, NULL, gfc_resolve_idate, + vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); + + add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_itime_idate, NULL, gfc_resolve_itime, + vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); + + add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime, + tm, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); + + add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime, + tm, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); + + add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub, + tm, BT_REAL, dr, REQUIRED, INTENT_OUT); + + add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + md, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL, + dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, + tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, + zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, + vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + /* More G77 compatibility garbage. */ + add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub, + vl, BT_REAL, 4, REQUIRED, INTENT_OUT, + tm, BT_REAL, 4, REQUIRED, INTENT_OUT); + + add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub, + vl, BT_REAL, 4, REQUIRED, INTENT_OUT, + tm, BT_REAL, 4, REQUIRED, INTENT_OUT); + + add_sym_5s ("execute_command_line", GFC_ISYM_EXECUTE_COMMAND_LINE, + CLASS_IMPURE , BT_UNKNOWN, 0, GFC_STD_F2008, + NULL, NULL, gfc_resolve_execute_command_line, + "command", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + "wait", BT_LOGICAL, dl, OPTIONAL, INTENT_IN, + "exitstat", BT_INTEGER, di, OPTIONAL, INTENT_INOUT, + "cmdstat", BT_INTEGER, di, OPTIONAL, INTENT_OUT, + "cmdmsg", BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); + + add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub, + dt, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror, + res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, NULL, NULL, NULL, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg, + pos, BT_INTEGER, di, REQUIRED, INTENT_IN, + val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + /* F2003 commandline routines. */ + + add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2003, + NULL, NULL, gfc_resolve_get_command, + com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, + length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, + CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL, + gfc_resolve_get_command_argument, + num, BT_INTEGER, di, REQUIRED, INTENT_IN, + val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, + length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + /* F2003 subroutine to get environment variables. */ + + add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, + CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, + NULL, NULL, gfc_resolve_get_environment_variable, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, + length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN); + + add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, + GFC_STD_F2003, + gfc_check_move_alloc, NULL, NULL, + f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, + t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); + + add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, + GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits, + f, BT_INTEGER, di, REQUIRED, INTENT_IN, + fp, BT_INTEGER, di, REQUIRED, INTENT_IN, + ln, BT_INTEGER, di, REQUIRED, INTENT_IN, + t, BT_INTEGER, di, REQUIRED, INTENT_INOUT, + tp, BT_INTEGER, di, REQUIRED, INTENT_IN); + + if (flag_dec_intrinsic_ints) + { + make_alias ("bmvbits", GFC_STD_GNU); + make_alias ("imvbits", GFC_STD_GNU); + make_alias ("jmvbits", GFC_STD_GNU); + make_alias ("kmvbits", GFC_STD_GNU); + } + + add_sym_2s ("random_init", GFC_ISYM_RANDOM_INIT, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_random_init, NULL, gfc_resolve_random_init, + "repeatable", BT_LOGICAL, dl, REQUIRED, INTENT_IN, + "image_distinct", BT_LOGICAL, dl, REQUIRED, INTENT_IN); + + add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F95, + gfc_check_random_number, NULL, gfc_resolve_random_number, + h, BT_REAL, dr, REQUIRED, INTENT_OUT); + + add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F95, + gfc_check_random_seed, NULL, gfc_resolve_random_seed, + sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + pt, BT_INTEGER, di, OPTIONAL, INTENT_IN, + gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + /* The following subroutines are part of ISO_C_BINDING. */ + + add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL, + "cptr", BT_VOID, 0, REQUIRED, INTENT_IN, + "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT, + "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN); + make_from_module(); + + add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer, + NULL, NULL, + "cptr", BT_VOID, 0, REQUIRED, INTENT_IN, + "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); + make_from_module(); + + /* Internal subroutine for emitting a runtime error. */ + + add_sym_1p ("fe_runtime_error", GFC_ISYM_FE_RUNTIME_ERROR, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fe_runtime_error, NULL, gfc_resolve_fe_runtime_error, + "msg", BT_CHARACTER, dc, REQUIRED, INTENT_IN); + + make_noreturn (); + make_vararg (); + make_from_module (); + + /* Coarray collectives. */ + add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_co_broadcast, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_INOUT, + "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); + + add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_co_minmax, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_INOUT, + result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); + + add_sym_4s ("co_min", GFC_ISYM_CO_MIN, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_co_minmax, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_INOUT, + result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); + + add_sym_4s ("co_sum", GFC_ISYM_CO_SUM, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_co_sum, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_INOUT, + result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); + + add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2018, + gfc_check_co_reduce, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_INOUT, + "operation", BT_INTEGER, di, REQUIRED, INTENT_IN, + result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); + + + /* The following subroutine is internally used for coarray libray functions. + "make_from_module" makes it inaccessible for external users. */ + add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL, + "x", BT_REAL, dr, REQUIRED, INTENT_OUT, + "y", BT_REAL, dr, REQUIRED, INTENT_IN); + make_from_module(); + + + /* More G77 compatibility garbage. */ + add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub, + sec, BT_INTEGER, di, REQUIRED, INTENT_IN, + han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN, + di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand, + "seed", BT_INTEGER, 4, REQUIRED, INTENT_IN); + + add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_exit, NULL, gfc_resolve_exit, + st, BT_INTEGER, di, OPTIONAL, INTENT_IN); + + make_noreturn(); + + add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_flush, NULL, gfc_resolve_flush, + ut, BT_INTEGER, di, OPTIONAL, INTENT_IN); + + add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub, + c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_free, NULL, NULL, + ptr, BT_INTEGER, ii, REQUIRED, INTENT_INOUT); + + add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + of, BT_INTEGER, di, REQUIRED, INTENT_IN, + whence, BT_INTEGER, di, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + of, BT_INTEGER, ii, REQUIRED, INTENT_OUT); + + add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub, + c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_kill_sub, NULL, NULL, + pid, BT_INTEGER, di, REQUIRED, INTENT_IN, + sig, BT_INTEGER, di, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_link_sub, NULL, gfc_resolve_link_sub, + p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror, + "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN); + + add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub, + p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub, + sec, BT_INTEGER, di, REQUIRED, INTENT_IN); + + add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_stat_sub, NULL, gfc_resolve_stat_sub, + name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub, + num, BT_INTEGER, di, REQUIRED, INTENT_IN, + han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub, + p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN, + 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub, + com, BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F95, + gfc_check_system_clock, NULL, gfc_resolve_system_clock, + c, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub, + ut, BT_INTEGER, di, REQUIRED, INTENT_IN, + name, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); + + add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, + gfc_check_umask_sub, NULL, gfc_resolve_umask_sub, + msk, BT_INTEGER, di, REQUIRED, INTENT_IN, + old, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0, + GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub, + "path", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); +} + + +/* Add a function to the list of conversion symbols. */ + +static void +add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard) +{ + gfc_typespec from, to; + gfc_intrinsic_sym *sym; + + if (sizing == SZ_CONVS) + { + nconv++; + return; + } + + gfc_clear_ts (&from); + from.type = from_type; + from.kind = from_kind; + + gfc_clear_ts (&to); + to.type = to_type; + to.kind = to_kind; + + sym = conversion + nconv; + + sym->name = conv_name (&from, &to); + sym->lib_name = sym->name; + sym->simplify.cc = gfc_convert_constant; + sym->standard = standard; + sym->elemental = 1; + sym->pure = 1; + sym->conversion = 1; + sym->ts = to; + sym->id = GFC_ISYM_CONVERSION; + + nconv++; +} + + +/* Create gfc_intrinsic_sym nodes for all intrinsic conversion + functions by looping over the kind tables. */ + +static void +add_conversions (void) +{ + int i, j; + + /* Integer-Integer conversions. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + for (j = 0; gfc_integer_kinds[j].kind != 0; j++) + { + if (i == j) + continue; + + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77); + } + + /* Integer-Real/Complex conversions. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + for (j = 0; gfc_real_kinds[j].kind != 0; j++) + { + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); + + add_conv (BT_REAL, gfc_real_kinds[j].kind, + BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); + + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); + + add_conv (BT_COMPLEX, gfc_real_kinds[j].kind, + BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); + } + + if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) + { + /* Hollerith-Integer conversions. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); + /* Hollerith-Real conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); + /* Hollerith-Complex conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); + + /* Hollerith-Character conversions. */ + add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER, + gfc_default_character_kind, GFC_STD_LEGACY); + + /* Hollerith-Logical conversions. */ + for (i = 0; gfc_logical_kinds[i].kind != 0; i++) + add_conv (BT_HOLLERITH, gfc_default_character_kind, + BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); + } + + /* Real/Complex - Real/Complex conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + for (j = 0; gfc_real_kinds[j].kind != 0; j++) + { + if (i != j) + { + add_conv (BT_REAL, gfc_real_kinds[i].kind, + BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); + + add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, + BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); + } + + add_conv (BT_REAL, gfc_real_kinds[i].kind, + BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); + + add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, + BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); + } + + /* Logical/Logical kind conversion. */ + for (i = 0; gfc_logical_kinds[i].kind; i++) + for (j = 0; gfc_logical_kinds[j].kind; j++) + { + if (i == j) + continue; + + add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind, + BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77); + } + + /* Integer-Logical and Logical-Integer conversions. */ + if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) + for (i=0; gfc_integer_kinds[i].kind; i++) + for (j=0; gfc_logical_kinds[j].kind; j++) + { + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY); + add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind, + BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); + } + + /* DEC legacy feature allows character conversions similar to Hollerith + conversions - the character data will transferred on a byte by byte + basis. */ + if (flag_dec_char_conversions) + { + /* Character-Integer conversions. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + add_conv (BT_CHARACTER, gfc_default_character_kind, + BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); + /* Character-Real conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + add_conv (BT_CHARACTER, gfc_default_character_kind, + BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); + /* Character-Complex conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + add_conv (BT_CHARACTER, gfc_default_character_kind, + BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); + /* Character-Logical conversions. */ + for (i = 0; gfc_logical_kinds[i].kind != 0; i++) + add_conv (BT_CHARACTER, gfc_default_character_kind, + BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); + } +} + + +static void +add_char_conversions (void) +{ + int n, i, j; + + /* Count possible conversions. */ + for (i = 0; gfc_character_kinds[i].kind != 0; i++) + for (j = 0; gfc_character_kinds[j].kind != 0; j++) + if (i != j) + ncharconv++; + + /* Allocate memory. */ + char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv); + + /* Add the conversions themselves. */ + n = 0; + for (i = 0; gfc_character_kinds[i].kind != 0; i++) + for (j = 0; gfc_character_kinds[j].kind != 0; j++) + { + gfc_typespec from, to; + + if (i == j) + continue; + + gfc_clear_ts (&from); + from.type = BT_CHARACTER; + from.kind = gfc_character_kinds[i].kind; + + gfc_clear_ts (&to); + to.type = BT_CHARACTER; + to.kind = gfc_character_kinds[j].kind; + + char_conversions[n].name = conv_name (&from, &to); + char_conversions[n].lib_name = char_conversions[n].name; + char_conversions[n].simplify.cc = gfc_convert_char_constant; + char_conversions[n].standard = GFC_STD_F2003; + char_conversions[n].elemental = 1; + char_conversions[n].pure = 1; + char_conversions[n].conversion = 0; + char_conversions[n].ts = to; + char_conversions[n].id = GFC_ISYM_CONVERSION; + + n++; + } +} + + +/* Initialize the table of intrinsics. */ +void +gfc_intrinsic_init_1 (void) +{ + nargs = nfunc = nsub = nconv = 0; + + /* Create a namespace to hold the resolved intrinsic symbols. */ + gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0); + + sizing = SZ_FUNCS; + add_functions (); + sizing = SZ_SUBS; + add_subroutines (); + sizing = SZ_CONVS; + add_conversions (); + + functions = XCNEWVAR (struct gfc_intrinsic_sym, + sizeof (gfc_intrinsic_sym) * (nfunc + nsub) + + sizeof (gfc_intrinsic_arg) * nargs); + + next_sym = functions; + subroutines = functions + nfunc; + + conversion = XCNEWVEC (gfc_intrinsic_sym, nconv); + + next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1; + + sizing = SZ_NOTHING; + nconv = 0; + + add_functions (); + add_subroutines (); + add_conversions (); + + /* Character conversion intrinsics need to be treated separately. */ + add_char_conversions (); +} + + +void +gfc_intrinsic_done_1 (void) +{ + free (functions); + free (conversion); + free (char_conversions); + gfc_free_namespace (gfc_intrinsic_namespace); +} + + +/******** Subroutines to check intrinsic interfaces ***********/ + +/* Given a formal argument list, remove any NULL arguments that may + have been left behind by a sort against some formal argument list. */ + +static void +remove_nullargs (gfc_actual_arglist **ap) +{ + gfc_actual_arglist *head, *tail, *next; + + tail = NULL; + + for (head = *ap; head; head = next) + { + next = head->next; + + if (head->expr == NULL && !head->label) + { + head->next = NULL; + gfc_free_actual_arglist (head); + } + else + { + if (tail == NULL) + *ap = head; + else + tail->next = head; + + tail = head; + tail->next = NULL; + } + } + + if (tail == NULL) + *ap = NULL; +} + + +static gfc_dummy_arg * +get_intrinsic_dummy_arg (gfc_intrinsic_arg *intrinsic) +{ + gfc_dummy_arg * const dummy_arg = gfc_get_dummy_arg (); + + dummy_arg->intrinsicness = GFC_INTRINSIC_DUMMY_ARG; + dummy_arg->u.intrinsic = intrinsic; + + return dummy_arg; +} + + +/* Given an actual arglist and a formal arglist, sort the actual + arglist so that its arguments are in a one-to-one correspondence + with the format arglist. Arguments that are not present are given + a blank gfc_actual_arglist structure. If something is obviously + wrong (say, a missing required argument) we abort sorting and + return false. */ + +static bool +sort_actual (const char *name, gfc_actual_arglist **ap, + gfc_intrinsic_arg *formal, locus *where) +{ + gfc_actual_arglist *actual, *a; + gfc_intrinsic_arg *f; + + remove_nullargs (ap); + actual = *ap; + + auto_vec dummy_args; + auto_vec ordered_actual_args; + + for (f = formal; f; f = f->next) + dummy_args.safe_push (f); + + ordered_actual_args.safe_grow_cleared (dummy_args.length (), + /* exact = */true); + + f = formal; + a = actual; + + if (f == NULL && a == NULL) /* No arguments */ + return true; + + /* ALLOCATED has two mutually exclusive keywords, but only one + can be present at time and neither is optional. */ + if (strcmp (name, "allocated") == 0) + { + if (!a) + { + gfc_error ("ALLOCATED intrinsic at %L requires an array or scalar " + "allocatable entity", where); + return false; + } + + if (a->name) + { + if (strcmp (a->name, "scalar") == 0) + { + if (a->next) + goto whoops; + if (a->expr->rank != 0) + { + gfc_error ("Scalar entity required at %L", &a->expr->where); + return false; + } + return true; + } + else if (strcmp (a->name, "array") == 0) + { + if (a->next) + goto whoops; + if (a->expr->rank == 0) + { + gfc_error ("Array entity required at %L", &a->expr->where); + return false; + } + return true; + } + else + { + gfc_error ("Invalid keyword %qs in %qs intrinsic function at %L", + a->name, name, &a->expr->where); + return false; + } + } + } + + for (int i = 0;; i++) + { /* Put the nonkeyword arguments in a 1:1 correspondence */ + if (f == NULL) + break; + if (a == NULL) + goto optional; + + if (a->name != NULL) + goto keywords; + + ordered_actual_args[i] = a; + + f = f->next; + a = a->next; + } + + if (a == NULL) + goto do_sort; + +whoops: + gfc_error ("Too many arguments in call to %qs at %L", name, where); + return false; + +keywords: + /* Associate the remaining actual arguments, all of which have + to be keyword arguments. */ + for (; a; a = a->next) + { + int idx; + FOR_EACH_VEC_ELT (dummy_args, idx, f) + if (strcmp (a->name, f->name) == 0) + break; + + if (f == NULL) + { + if (a->name[0] == '%') + gfc_error ("The argument list functions %%VAL, %%LOC or %%REF " + "are not allowed in this context at %L", where); + else + gfc_error ("Cannot find keyword named %qs in call to %qs at %L", + a->name, name, where); + return false; + } + + if (ordered_actual_args[idx] != NULL) + { + gfc_error ("Argument %qs appears twice in call to %qs at %L", + f->name, name, where); + return false; + } + ordered_actual_args[idx] = a; + } + +optional: + /* At this point, all unmatched formal args must be optional. */ + int idx; + FOR_EACH_VEC_ELT (dummy_args, idx, f) + { + if (ordered_actual_args[idx] == NULL && f->optional == 0) + { + gfc_error ("Missing actual argument %qs in call to %qs at %L", + f->name, name, where); + return false; + } + } + +do_sort: + /* Using the formal argument list, string the actual argument list + together in a way that corresponds with the formal list. */ + actual = NULL; + + FOR_EACH_VEC_ELT (dummy_args, idx, f) + { + a = ordered_actual_args[idx]; + if (a && a->label != NULL) + { + gfc_error ("ALTERNATE RETURN not permitted at %L", where); + return false; + } + + if (a == NULL) + a = gfc_get_actual_arglist (); + + a->associated_dummy = get_intrinsic_dummy_arg (f); + + if (actual == NULL) + *ap = a; + else + actual->next = a; + + actual = a; + } + actual->next = NULL; /* End the sorted argument list. */ + + return true; +} + + +/* Compare an actual argument list with an intrinsic's formal argument + list. The lists are checked for agreement of type. We don't check + for arrayness here. */ + +static bool +check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, + int error_flag) +{ + gfc_actual_arglist *actual; + gfc_intrinsic_arg *formal; + int i; + + formal = sym->formal; + actual = *ap; + + i = 0; + for (; formal; formal = formal->next, actual = actual->next, i++) + { + gfc_typespec ts; + + if (actual->expr == NULL) + continue; + + ts = formal->ts; + + /* A kind of 0 means we don't check for kind. */ + if (ts.kind == 0) + ts.kind = actual->expr->ts.kind; + + if (!gfc_compare_types (&ts, &actual->expr->ts)) + { + if (error_flag) + gfc_error ("In call to %qs at %L, type mismatch in argument " + "%qs; pass %qs to %qs", gfc_current_intrinsic, + &actual->expr->where, + gfc_current_intrinsic_arg[i]->name, + gfc_typename (actual->expr), + gfc_dummy_typename (&formal->ts)); + return false; + } + + /* F2018, p. 328: An argument to an intrinsic procedure other than + ASSOCIATED, NULL, or PRESENT shall be a data object. An EXPR_NULL + is not a data object. */ + if (actual->expr->expr_type == EXPR_NULL + && (!(sym->id == GFC_ISYM_ASSOCIATED + || sym->id == GFC_ISYM_NULL + || sym->id == GFC_ISYM_PRESENT))) + { + gfc_invalid_null_arg (actual->expr); + return false; + } + + /* If the formal argument is INTENT([IN]OUT), check for definability. */ + if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT) + { + const char* context = (error_flag + ? _("actual argument to INTENT = OUT/INOUT") + : NULL); + + /* No pointer arguments for intrinsics. */ + if (!gfc_check_vardef_context (actual->expr, false, false, false, context)) + return false; + } + } + + return true; +} + + +/* Given a pointer to an intrinsic symbol and an expression node that + represent the function call to that subroutine, figure out the type + of the result. This may involve calling a resolution subroutine. */ + +static void +resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) +{ + gfc_expr *a1, *a2, *a3, *a4, *a5, *a6; + gfc_actual_arglist *arg; + + if (specific->resolve.f1 == NULL) + { + if (e->value.function.name == NULL) + e->value.function.name = specific->lib_name; + + if (e->ts.type == BT_UNKNOWN) + e->ts = specific->ts; + return; + } + + arg = e->value.function.actual; + + /* Special case hacks for MIN and MAX. */ + if (specific->resolve.f1m == gfc_resolve_max + || specific->resolve.f1m == gfc_resolve_min) + { + (*specific->resolve.f1m) (e, arg); + return; + } + + if (arg == NULL) + { + (*specific->resolve.f0) (e); + return; + } + + a1 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f1) (e, a1); + return; + } + + a2 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f2) (e, a1, a2); + return; + } + + a3 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f3) (e, a1, a2, a3); + return; + } + + a4 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f4) (e, a1, a2, a3, a4); + return; + } + + a5 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f5) (e, a1, a2, a3, a4, a5); + return; + } + + a6 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f6) (e, a1, a2, a3, a4, a5, a6); + return; + } + + gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic"); +} + + +/* Given an intrinsic symbol node and an expression node, call the + simplification function (if there is one), perhaps replacing the + expression with something simpler. We return false on an error + of the simplification, true if the simplification worked, even + if nothing has changed in the expression itself. */ + +static bool +do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) +{ + gfc_expr *result, *a1, *a2, *a3, *a4, *a5, *a6; + gfc_actual_arglist *arg; + + /* Max and min require special handling due to the variable number + of args. */ + if (specific->simplify.f1 == gfc_simplify_min) + { + result = gfc_simplify_min (e); + goto finish; + } + + if (specific->simplify.f1 == gfc_simplify_max) + { + result = gfc_simplify_max (e); + goto finish; + } + + if (specific->simplify.f1 == NULL) + { + result = NULL; + goto finish; + } + + arg = e->value.function.actual; + + if (arg == NULL) + { + result = (*specific->simplify.f0) (); + goto finish; + } + + a1 = arg->expr; + arg = arg->next; + + if (specific->simplify.cc == gfc_convert_constant + || specific->simplify.cc == gfc_convert_char_constant) + { + result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind); + goto finish; + } + + if (arg == NULL) + result = (*specific->simplify.f1) (a1); + else + { + a2 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f2) (a1, a2); + else + { + a3 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f3) (a1, a2, a3); + else + { + a4 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f4) (a1, a2, a3, a4); + else + { + a5 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f5) (a1, a2, a3, a4, a5); + else + { + a6 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f6) + (a1, a2, a3, a4, a5, a6); + else + gfc_internal_error + ("do_simplify(): Too many args for intrinsic"); + } + } + } + } + } + +finish: + if (result == &gfc_bad_expr) + return false; + + if (result == NULL) + resolve_intrinsic (specific, e); /* Must call at run-time */ + else + { + result->where = e->where; + gfc_replace_expr (e, result); + } + + return true; +} + + +/* Initialize the gfc_current_intrinsic_arg[] array for the benefit of + error messages. This subroutine returns false if a subroutine + has more than MAX_INTRINSIC_ARGS, in which case the actual argument + list cannot match any intrinsic. */ + +static void +init_arglist (gfc_intrinsic_sym *isym) +{ + gfc_intrinsic_arg *formal; + int i; + + gfc_current_intrinsic = isym->name; + + i = 0; + for (formal = isym->formal; formal; formal = formal->next) + { + if (i >= MAX_INTRINSIC_ARGS) + gfc_internal_error ("init_arglist(): too many arguments"); + gfc_current_intrinsic_arg[i++] = formal; + } +} + + +/* Given a pointer to an intrinsic symbol and an expression consisting + of a function call, see if the function call is consistent with the + intrinsic's formal argument list. Return true if the expression + and intrinsic match, false otherwise. */ + +static bool +check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) +{ + gfc_actual_arglist *arg, **ap; + bool t; + + ap = &expr->value.function.actual; + + init_arglist (specific); + + /* Don't attempt to sort the argument list for min or max. */ + if (specific->check.f1m == gfc_check_min_max + || specific->check.f1m == gfc_check_min_max_integer + || specific->check.f1m == gfc_check_min_max_real + || specific->check.f1m == gfc_check_min_max_double) + { + if (!do_ts29113_check (specific, *ap)) + return false; + return (*specific->check.f1m) (*ap); + } + + if (!sort_actual (specific->name, ap, specific->formal, &expr->where)) + return false; + + if (!do_ts29113_check (specific, *ap)) + return false; + + if (specific->check.f5ml == gfc_check_minloc_maxloc) + /* This is special because we might have to reorder the argument list. */ + t = gfc_check_minloc_maxloc (*ap); + else if (specific->check.f6fl == gfc_check_findloc) + t = gfc_check_findloc (*ap); + else if (specific->check.f3red == gfc_check_minval_maxval) + /* This is also special because we also might have to reorder the + argument list. */ + t = gfc_check_minval_maxval (*ap); + else if (specific->check.f3red == gfc_check_product_sum) + /* Same here. The difference to the previous case is that we allow a + general numeric type. */ + t = gfc_check_product_sum (*ap); + else if (specific->check.f3red == gfc_check_transf_bit_intrins) + /* Same as for PRODUCT and SUM, but different checks. */ + t = gfc_check_transf_bit_intrins (*ap); + else + { + if (specific->check.f1 == NULL) + { + t = check_arglist (ap, specific, error_flag); + if (t) + expr->ts = specific->ts; + } + else + t = do_check (specific, *ap); + } + + /* Check conformance of elemental intrinsics. */ + if (t && specific->elemental) + { + int n = 0; + gfc_expr *first_expr; + arg = expr->value.function.actual; + + /* There is no elemental intrinsic without arguments. */ + gcc_assert(arg != NULL); + first_expr = arg->expr; + + for ( ; arg && arg->expr; arg = arg->next, n++) + if (!gfc_check_conformance (first_expr, arg->expr, + _("arguments '%s' and '%s' for " + "intrinsic '%s'"), + gfc_current_intrinsic_arg[0]->name, + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic)) + return false; + } + + if (!t) + remove_nullargs (ap); + + return t; +} + + +/* Check whether an intrinsic belongs to whatever standard the user + has chosen, taking also into account -fall-intrinsics. Here, no + warning/error is emitted; but if symstd is not NULL, it is pointed to a + textual representation of the symbols standard status (like + "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that + can be used to construct a detailed warning/error message in case of + a false. */ + +bool +gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, + const char** symstd, bool silent, locus where) +{ + const char* symstd_msg; + + /* For -fall-intrinsics, just succeed. */ + if (flag_all_intrinsics) + return true; + + /* Find the symbol's standard message for later usage. */ + switch (isym->standard) + { + case GFC_STD_F77: + symstd_msg = _("available since Fortran 77"); + break; + + case GFC_STD_F95_OBS: + symstd_msg = _("obsolescent in Fortran 95"); + break; + + case GFC_STD_F95_DEL: + symstd_msg = _("deleted in Fortran 95"); + break; + + case GFC_STD_F95: + symstd_msg = _("new in Fortran 95"); + break; + + case GFC_STD_F2003: + symstd_msg = _("new in Fortran 2003"); + break; + + case GFC_STD_F2008: + symstd_msg = _("new in Fortran 2008"); + break; + + case GFC_STD_F2018: + symstd_msg = _("new in Fortran 2018"); + break; + + case GFC_STD_GNU: + symstd_msg = _("a GNU Fortran extension"); + break; + + case GFC_STD_LEGACY: + symstd_msg = _("for backward compatibility"); + break; + + default: + gfc_internal_error ("Invalid standard code on intrinsic %qs (%d)", + isym->name, isym->standard); + } + + /* If warning about the standard, warn and succeed. */ + if (gfc_option.warn_std & isym->standard) + { + /* Do only print a warning if not a GNU extension. */ + if (!silent && isym->standard != GFC_STD_GNU) + gfc_warning (0, "Intrinsic %qs (%s) used at %L", + isym->name, symstd_msg, &where); + + return true; + } + + /* If allowing the symbol's standard, succeed, too. */ + if (gfc_option.allow_std & isym->standard) + return true; + + /* Otherwise, fail. */ + if (symstd) + *symstd = symstd_msg; + return false; +} + + +/* See if a function call corresponds to an intrinsic function call. + We return: + + MATCH_YES if the call corresponds to an intrinsic, simplification + is done if possible. + + MATCH_NO if the call does not correspond to an intrinsic + + MATCH_ERROR if the call corresponds to an intrinsic but there was an + error during the simplification process. + + The error_flag parameter enables an error reporting. */ + +match +gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag) +{ + gfc_symbol *sym; + gfc_intrinsic_sym *isym, *specific; + gfc_actual_arglist *actual; + int flag; + + if (expr->value.function.isym != NULL) + return (!do_simplify(expr->value.function.isym, expr)) + ? MATCH_ERROR : MATCH_YES; + + if (!error_flag) + gfc_push_suppress_errors (); + flag = 0; + + for (actual = expr->value.function.actual; actual; actual = actual->next) + if (actual->expr != NULL) + flag |= (actual->expr->ts.type != BT_INTEGER + && actual->expr->ts.type != BT_CHARACTER); + + sym = expr->symtree->n.sym; + + if (sym->intmod_sym_id) + { + gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); + isym = specific = gfc_intrinsic_function_by_id (id); + } + else + isym = specific = gfc_find_function (sym->name); + + if (isym == NULL) + { + if (!error_flag) + gfc_pop_suppress_errors (); + return MATCH_NO; + } + + if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE + || isym->id == GFC_ISYM_CMPLX || isym->id == GFC_ISYM_FLOAT + || isym->id == GFC_ISYM_SNGL || isym->id == GFC_ISYM_DFLOAT) + && gfc_init_expr_flag + && !gfc_notify_std (GFC_STD_F2003, "Function %qs as initialization " + "expression at %L", sym->name, &expr->where)) + { + if (!error_flag) + gfc_pop_suppress_errors (); + return MATCH_ERROR; + } + + /* F95, 7.1.6.1: Only transformational functions REPEAT, RESHAPE, + SELECTED_INT_KIND, SELECTED_REAL_KIND, TRANSFER, and TRIM are allowed in + initialization expressions. */ + + if (gfc_init_expr_flag && isym->transformational) + { + gfc_isym_id id = isym->id; + if (id != GFC_ISYM_REPEAT && id != GFC_ISYM_RESHAPE + && id != GFC_ISYM_SI_KIND && id != GFC_ISYM_SR_KIND + && id != GFC_ISYM_TRANSFER && id != GFC_ISYM_TRIM + && !gfc_notify_std (GFC_STD_F2003, "Transformational function %qs " + "at %L is invalid in an initialization " + "expression", sym->name, &expr->where)) + { + if (!error_flag) + gfc_pop_suppress_errors (); + + return MATCH_ERROR; + } + } + + gfc_current_intrinsic_where = &expr->where; + + /* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */ + if (isym->check.f1m == gfc_check_min_max) + { + init_arglist (isym); + + if (isym->check.f1m(expr->value.function.actual)) + goto got_specific; + + if (!error_flag) + gfc_pop_suppress_errors (); + return MATCH_NO; + } + + /* If the function is generic, check all of its specific + incarnations. If the generic name is also a specific, we check + that name last, so that any error message will correspond to the + specific. */ + gfc_push_suppress_errors (); + + if (isym->generic) + { + for (specific = isym->specific_head; specific; + specific = specific->next) + { + if (specific == isym) + continue; + if (check_specific (specific, expr, 0)) + { + gfc_pop_suppress_errors (); + goto got_specific; + } + } + } + + gfc_pop_suppress_errors (); + + if (!check_specific (isym, expr, error_flag)) + { + if (!error_flag) + gfc_pop_suppress_errors (); + return MATCH_NO; + } + + specific = isym; + +got_specific: + expr->value.function.isym = specific; + if (!error_flag) + gfc_pop_suppress_errors (); + + if (!do_simplify (specific, expr)) + return MATCH_ERROR; + + /* F95, 7.1.6.1, Initialization expressions + (4) An elemental intrinsic function reference of type integer or + character where each argument is an initialization expression + of type integer or character + + F2003, 7.1.7 Initialization expression + (4) A reference to an elemental standard intrinsic function, + where each argument is an initialization expression */ + + if (gfc_init_expr_flag && isym->elemental && flag + && !gfc_notify_std (GFC_STD_F2003, "Elemental function as " + "initialization expression with non-integer/non-" + "character arguments at %L", &expr->where)) + return MATCH_ERROR; + + if (sym->attr.flavor == FL_UNKNOWN) + { + sym->attr.function = 1; + sym->attr.intrinsic = 1; + sym->attr.flavor = FL_PROCEDURE; + } + if (sym->attr.flavor == FL_PROCEDURE) + { + sym->attr.function = 1; + sym->attr.proc = PROC_INTRINSIC; + } + + if (!sym->module) + gfc_intrinsic_symbol (sym); + + /* Have another stab at simplification since elemental intrinsics with array + actual arguments would be missed by the calls above to do_simplify. */ + if (isym->elemental) + gfc_simplify_expr (expr, 1); + + return MATCH_YES; +} + + +/* See if a CALL statement corresponds to an intrinsic subroutine. + Returns MATCH_YES if the subroutine corresponds to an intrinsic, + MATCH_NO if not, and MATCH_ERROR if there was an error (but did + correspond). */ + +match +gfc_intrinsic_sub_interface (gfc_code *c, int error_flag) +{ + gfc_intrinsic_sym *isym; + const char *name; + + name = c->symtree->n.sym->name; + + if (c->symtree->n.sym->intmod_sym_id) + { + gfc_isym_id id; + id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym); + isym = gfc_intrinsic_subroutine_by_id (id); + } + else + isym = gfc_find_subroutine (name); + if (isym == NULL) + return MATCH_NO; + + if (!error_flag) + gfc_push_suppress_errors (); + + init_arglist (isym); + + if (!isym->vararg && !sort_actual (name, &c->ext.actual, isym->formal, &c->loc)) + goto fail; + + if (!do_ts29113_check (isym, c->ext.actual)) + goto fail; + + if (isym->check.f1 != NULL) + { + if (!do_check (isym, c->ext.actual)) + goto fail; + } + else + { + if (!check_arglist (&c->ext.actual, isym, 1)) + goto fail; + } + + /* The subroutine corresponds to an intrinsic. Allow errors to be + seen at this point. */ + if (!error_flag) + gfc_pop_suppress_errors (); + + c->resolved_isym = isym; + if (isym->resolve.s1 != NULL) + isym->resolve.s1 (c); + else + { + c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name); + c->resolved_sym->attr.elemental = isym->elemental; + } + + if (gfc_do_concurrent_flag && !isym->pure) + { + gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT " + "block at %L is not PURE", name, &c->loc); + return MATCH_ERROR; + } + + if (!isym->pure && gfc_pure (NULL)) + { + gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name, + &c->loc); + return MATCH_ERROR; + } + + if (!isym->pure) + gfc_unset_implicit_pure (NULL); + + c->resolved_sym->attr.noreturn = isym->noreturn; + + return MATCH_YES; + +fail: + if (!error_flag) + gfc_pop_suppress_errors (); + return MATCH_NO; +} + + +/* Call gfc_convert_type() with warning enabled. */ + +bool +gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag) +{ + return gfc_convert_type_warn (expr, ts, eflag, 1); +} + + +/* Try to convert an expression (in place) from one type to another. + 'eflag' controls the behavior on error. + + The possible values are: + + 1 Generate a gfc_error() + 2 Generate a gfc_internal_error(). + + 'wflag' controls the warning related to conversion. + + 'array' indicates whether the conversion is in an array constructor. + Non-standard conversion from character to numeric not allowed if true. +*/ + +bool +gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag, + bool array) +{ + gfc_intrinsic_sym *sym; + gfc_typespec from_ts; + locus old_where; + gfc_expr *new_expr; + int rank; + mpz_t *shape; + bool is_char_constant = (expr->expr_type == EXPR_CONSTANT) + && (expr->ts.type == BT_CHARACTER); + + from_ts = expr->ts; /* expr->ts gets clobbered */ + + if (ts->type == BT_UNKNOWN) + goto bad; + + expr->do_not_warn = ! wflag; + + /* NULL and zero size arrays get their type here, unless they already have a + typespec. */ + if ((expr->expr_type == EXPR_NULL + || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL)) + && expr->ts.type == BT_UNKNOWN) + { + /* Sometimes the RHS acquire the type. */ + expr->ts = *ts; + return true; + } + + if (expr->ts.type == BT_UNKNOWN) + goto bad; + + /* In building an array constructor, gfortran can end up here when no + conversion is required for an intrinsic type. We need to let derived + types drop through. */ + if (from_ts.type != BT_DERIVED && from_ts.type != BT_CLASS + && (from_ts.type == ts->type && from_ts.kind == ts->kind)) + return true; + + if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && (ts->type == BT_DERIVED || ts->type == BT_CLASS) + && gfc_compare_types (ts, &expr->ts)) + return true; + + /* If array is true then conversion is in an array constructor where + non-standard conversion is not allowed. */ + if (array && from_ts.type == BT_CHARACTER + && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) + goto bad; + + sym = find_conv (&expr->ts, ts); + if (sym == NULL) + goto bad; + + /* At this point, a conversion is necessary. A warning may be needed. */ + if ((gfc_option.warn_std & sym->standard) != 0) + { + const char *type_name = is_char_constant ? gfc_typename (expr) + : gfc_typename (&from_ts); + gfc_warning_now (0, "Extension: Conversion from %s to %s at %L", + type_name, gfc_dummy_typename (ts), + &expr->where); + } + else if (wflag) + { + if (flag_range_check && expr->expr_type == EXPR_CONSTANT + && from_ts.type == ts->type) + { + /* Do nothing. Constants of the same type are range-checked + elsewhere. If a value too large for the target type is + assigned, an error is generated. Not checking here avoids + duplications of warnings/errors. + If range checking was disabled, but -Wconversion enabled, + a non range checked warning is generated below. */ + } + else if (flag_dec_char_conversions && from_ts.type == BT_CHARACTER + && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) + { + const char *type_name = is_char_constant ? gfc_typename (expr) + : gfc_typename (&from_ts); + gfc_warning_now (OPT_Wconversion, "Nonstandard conversion from %s " + "to %s at %L", type_name, gfc_typename (ts), + &expr->where); + } + else if (from_ts.type == ts->type + || (from_ts.type == BT_INTEGER && ts->type == BT_REAL) + || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX) + || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)) + { + /* Larger kinds can hold values of smaller kinds without problems. + Hence, only warn if target kind is smaller than the source + kind - or if -Wconversion-extra is specified. LOGICAL values + will always fit regardless of kind so ignore conversion. */ + if (expr->expr_type != EXPR_CONSTANT + && ts->type != BT_LOGICAL) + { + if (warn_conversion && from_ts.kind > ts->kind) + gfc_warning_now (OPT_Wconversion, "Possible change of value in " + "conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + else + gfc_warning_now (OPT_Wconversion_extra, "Conversion from %s to %s " + "at %L", gfc_typename (&from_ts), + gfc_typename (ts), &expr->where); + } + } + else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER) + || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER) + || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL)) + { + /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL + usually comes with a loss of information, regardless of kinds. */ + if (expr->expr_type != EXPR_CONSTANT) + gfc_warning_now (OPT_Wconversion, "Possible change of value in " + "conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + } + else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH) + { + /* If HOLLERITH is involved, all bets are off. */ + gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_dummy_typename (ts), + &expr->where); + } + else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL) + { + /* Do nothing. This block exists only to simplify the other + else-if expressions. + LOGICAL <> LOGICAL no warning, independent of kind values + LOGICAL <> INTEGER extension, warned elsewhere + LOGICAL <> REAL invalid, error generated elsewhere + LOGICAL <> COMPLEX invalid, error generated elsewhere */ + } + else + gcc_unreachable (); + } + + /* Insert a pre-resolved function call to the right function. */ + old_where = expr->where; + rank = expr->rank; + shape = expr->shape; + + new_expr = gfc_get_expr (); + *new_expr = *expr; + + new_expr = gfc_build_conversion (new_expr); + new_expr->value.function.name = sym->lib_name; + new_expr->value.function.isym = sym; + new_expr->where = old_where; + new_expr->ts = *ts; + new_expr->rank = rank; + new_expr->shape = gfc_copy_shape (shape, rank); + + gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); + new_expr->symtree->n.sym->result = new_expr->symtree->n.sym; + new_expr->symtree->n.sym->ts.type = ts->type; + new_expr->symtree->n.sym->ts.kind = ts->kind; + new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; + new_expr->symtree->n.sym->attr.function = 1; + new_expr->symtree->n.sym->attr.elemental = 1; + new_expr->symtree->n.sym->attr.pure = 1; + new_expr->symtree->n.sym->attr.referenced = 1; + gfc_intrinsic_symbol(new_expr->symtree->n.sym); + gfc_commit_symbol (new_expr->symtree->n.sym); + + *expr = *new_expr; + + free (new_expr); + expr->ts = *ts; + + if (gfc_is_constant_expr (expr->value.function.actual->expr) + && !do_simplify (sym, expr)) + { + + if (eflag == 2) + goto bad; + return false; /* Error already generated in do_simplify() */ + } + + return true; + +bad: + const char *type_name = is_char_constant ? gfc_typename (expr) + : gfc_typename (&from_ts); + if (eflag == 1) + { + gfc_error ("Cannot convert %s to %s at %L", type_name, gfc_typename (ts), + &expr->where); + return false; + } + + gfc_internal_error ("Cannot convert %qs to %qs at %L", type_name, + gfc_typename (ts), &expr->where); + /* Not reached */ +} + + +bool +gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) +{ + gfc_intrinsic_sym *sym; + locus old_where; + gfc_expr *new_expr; + int rank; + mpz_t *shape; + + gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER); + + sym = find_char_conv (&expr->ts, ts); + gcc_assert (sym); + + /* Insert a pre-resolved function call to the right function. */ + old_where = expr->where; + rank = expr->rank; + shape = expr->shape; + + new_expr = gfc_get_expr (); + *new_expr = *expr; + + new_expr = gfc_build_conversion (new_expr); + new_expr->value.function.name = sym->lib_name; + new_expr->value.function.isym = sym; + new_expr->where = old_where; + new_expr->ts = *ts; + new_expr->rank = rank; + new_expr->shape = gfc_copy_shape (shape, rank); + + gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); + new_expr->symtree->n.sym->ts.type = ts->type; + new_expr->symtree->n.sym->ts.kind = ts->kind; + new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; + new_expr->symtree->n.sym->attr.function = 1; + new_expr->symtree->n.sym->attr.elemental = 1; + new_expr->symtree->n.sym->attr.referenced = 1; + gfc_intrinsic_symbol(new_expr->symtree->n.sym); + gfc_commit_symbol (new_expr->symtree->n.sym); + + *expr = *new_expr; + + free (new_expr); + expr->ts = *ts; + + if (gfc_is_constant_expr (expr->value.function.actual->expr) + && !do_simplify (sym, expr)) + { + /* Error already generated in do_simplify() */ + return false; + } + + return true; +} + + +/* Check if the passed name is name of an intrinsic (taking into account the + current -std=* and -fall-intrinsic settings). If it is, see if we should + warn about this as a user-procedure having the same name as an intrinsic + (-Wintrinsic-shadow enabled) and do so if we should. */ + +void +gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func) +{ + gfc_intrinsic_sym* isym; + + /* If the warning is disabled, do nothing at all. */ + if (!warn_intrinsic_shadow) + return; + + /* Try to find an intrinsic of the same name. */ + if (func) + isym = gfc_find_function (sym->name); + else + isym = gfc_find_subroutine (sym->name); + + /* If no intrinsic was found with this name or it's not included in the + selected standard, everything's fine. */ + if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true, + sym->declared_at)) + return; + + /* Emit the warning. */ + if (in_module || sym->ns->proc_name) + gfc_warning (OPT_Wintrinsic_shadow, + "%qs declared at %L may shadow the intrinsic of the same" + " name. In order to call the intrinsic, explicit INTRINSIC" + " declarations may be required.", + sym->name, &sym->declared_at); + else + gfc_warning (OPT_Wintrinsic_shadow, + "%qs declared at %L is also the name of an intrinsic. It can" + " only be called via an explicit interface or if declared" + " EXTERNAL.", sym->name, &sym->declared_at); +} diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c deleted file mode 100644 index 902aa19..0000000 --- a/gcc/fortran/io.c +++ /dev/null @@ -1,4899 +0,0 @@ -/* Deal with I/O statements & related stuff. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "match.h" -#include "parse.h" -#include "constructor.h" - -gfc_st_label -format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, - 0, {NULL, NULL}, NULL}; - -typedef struct -{ - const char *name, *spec, *value; - bt type; -} -io_tag; - -static const io_tag - tag_readonly = {"READONLY", " readonly", NULL, BT_UNKNOWN }, - tag_shared = {"SHARE", " shared", NULL, BT_UNKNOWN }, - tag_noshared = {"SHARE", " noshared", NULL, BT_UNKNOWN }, - tag_e_share = {"SHARE", " share =", " %e", BT_CHARACTER }, - tag_v_share = {"SHARE", " share =", " %v", BT_CHARACTER }, - tag_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %e", - BT_CHARACTER }, - tag_v_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %v", - BT_CHARACTER }, - tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, - tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, - tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, - tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER}, - tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER}, - tag_e_blank = {"BLANK", " blank =", " %e", BT_CHARACTER}, - tag_e_position = {"POSITION", " position =", " %e", BT_CHARACTER}, - tag_e_action = {"ACTION", " action =", " %e", BT_CHARACTER}, - tag_e_delim = {"DELIM", " delim =", " %e", BT_CHARACTER}, - tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER}, - tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER}, - tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER}, - tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER}, - tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER}, - tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER}, - tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER}, - tag_advance = {"ADVANCE", " advance =", " %e", BT_CHARACTER}, - tag_rec = {"REC", " rec =", " %e", BT_INTEGER}, - tag_spos = {"POSITION", " pos =", " %e", BT_INTEGER}, - tag_format = {"FORMAT", NULL, NULL, BT_CHARACTER}, - tag_iomsg = {"IOMSG", " iomsg =", " %e", BT_CHARACTER}, - tag_iostat = {"IOSTAT", " iostat =", " %v", BT_INTEGER}, - tag_size = {"SIZE", " size =", " %v", BT_INTEGER}, - tag_exist = {"EXIST", " exist =", " %v", BT_LOGICAL}, - tag_opened = {"OPENED", " opened =", " %v", BT_LOGICAL}, - tag_named = {"NAMED", " named =", " %v", BT_LOGICAL}, - tag_name = {"NAME", " name =", " %v", BT_CHARACTER}, - tag_number = {"NUMBER", " number =", " %v", BT_INTEGER}, - tag_s_access = {"ACCESS", " access =", " %v", BT_CHARACTER}, - tag_sequential = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER}, - tag_direct = {"DIRECT", " direct =", " %v", BT_CHARACTER}, - tag_s_form = {"FORM", " form =", " %v", BT_CHARACTER}, - tag_formatted = {"FORMATTED", " formatted =", " %v", BT_CHARACTER}, - tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER}, - tag_s_recl = {"RECL", " recl =", " %v", BT_INTEGER}, - tag_nextrec = {"NEXTREC", " nextrec =", " %v", BT_INTEGER}, - tag_s_blank = {"BLANK", " blank =", " %v", BT_CHARACTER}, - tag_s_position = {"POSITION", " position =", " %v", BT_CHARACTER}, - tag_s_action = {"ACTION", " action =", " %v", BT_CHARACTER}, - tag_read = {"READ", " read =", " %v", BT_CHARACTER}, - tag_write = {"WRITE", " write =", " %v", BT_CHARACTER}, - tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER}, - tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER}, - tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER}, - tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER}, - tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER}, - tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER}, - tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER}, - tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER}, - tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER}, - tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER}, - tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER}, - tag_err = {"ERR", " err =", " %l", BT_UNKNOWN}, - tag_end = {"END", " end =", " %l", BT_UNKNOWN}, - tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN}, - tag_id = {"ID", " id =", " %v", BT_INTEGER}, - tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}, - tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER}, - tag_s_iqstream = {"STREAM", " stream =", " %v", BT_CHARACTER}; - -static gfc_dt *current_dt; - -#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false; - -/**************** Fortran 95 FORMAT parser *****************/ - -/* FORMAT tokens returned by format_lex(). */ -enum format_token -{ - FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, - FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, - FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, - FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, - FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC, - FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT -}; - -/* Local variables for checking format strings. The saved_token is - used to back up by a single format token during the parsing - process. */ -static gfc_char_t *format_string; -static int format_string_pos; -static int format_length, use_last_char; -static char error_element; -static locus format_locus; - -static format_token saved_token; - -static enum -{ MODE_STRING, MODE_FORMAT, MODE_COPY } -mode; - - -/* Return the next character in the format string. */ - -static char -next_char (gfc_instring in_string) -{ - static gfc_char_t c; - - if (use_last_char) - { - use_last_char = 0; - return c; - } - - format_length++; - - if (mode == MODE_STRING) - c = *format_string++; - else - { - c = gfc_next_char_literal (in_string); - if (c == '\n') - c = '\0'; - } - - if (flag_backslash && c == '\\') - { - locus old_locus = gfc_current_locus; - - if (gfc_match_special_char (&c) == MATCH_NO) - gfc_current_locus = old_locus; - - if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) - gfc_warning (0, "Extension: backslash character at %C"); - } - - if (mode == MODE_COPY) - *format_string++ = c; - - if (mode != MODE_STRING) - format_locus = gfc_current_locus; - - format_string_pos++; - - c = gfc_wide_toupper (c); - return c; -} - - -/* Back up one character position. Only works once. */ - -static void -unget_char (void) -{ - use_last_char = 1; -} - -/* Eat up the spaces and return a character. */ - -static char -next_char_not_space () -{ - char c; - do - { - error_element = c = next_char (NONSTRING); - if (c == '\t') - gfc_warning (OPT_Wtabs, "Nonconforming tab character in format at %C"); - } - while (gfc_is_whitespace (c)); - return c; -} - -static int value = 0; - -/* Simple lexical analyzer for getting the next token in a FORMAT - statement. */ - -static format_token -format_lex (void) -{ - format_token token; - char c, delim; - int zflag; - int negative_flag; - - if (saved_token != FMT_NONE) - { - token = saved_token; - saved_token = FMT_NONE; - return token; - } - - c = next_char_not_space (); - - negative_flag = 0; - switch (c) - { - case '-': - negative_flag = 1; - /* Falls through. */ - - case '+': - c = next_char_not_space (); - if (!ISDIGIT (c)) - { - token = FMT_UNKNOWN; - break; - } - - value = c - '0'; - - do - { - c = next_char_not_space (); - if (ISDIGIT (c)) - value = 10 * value + c - '0'; - } - while (ISDIGIT (c)); - - unget_char (); - - if (negative_flag) - value = -value; - - token = FMT_SIGNED_INT; - break; - - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - zflag = (c == '0'); - - value = c - '0'; - - do - { - c = next_char_not_space (); - if (ISDIGIT (c)) - { - value = 10 * value + c - '0'; - if (c != '0') - zflag = 0; - } - } - while (ISDIGIT (c)); - - unget_char (); - token = zflag ? FMT_ZERO : FMT_POSINT; - break; - - case '.': - token = FMT_PERIOD; - break; - - case ',': - token = FMT_COMMA; - break; - - case ':': - token = FMT_COLON; - break; - - case '/': - token = FMT_SLASH; - break; - - case '$': - token = FMT_DOLLAR; - break; - - case 'T': - c = next_char_not_space (); - switch (c) - { - case 'L': - token = FMT_TL; - break; - case 'R': - token = FMT_TR; - break; - default: - token = FMT_T; - unget_char (); - } - break; - - case '(': - token = FMT_LPAREN; - break; - - case ')': - token = FMT_RPAREN; - break; - - case 'X': - token = FMT_X; - break; - - case 'S': - c = next_char_not_space (); - if (c != 'P' && c != 'S') - unget_char (); - - token = FMT_SIGN; - break; - - case 'B': - c = next_char_not_space (); - if (c == 'N' || c == 'Z') - token = FMT_BLANK; - else - { - unget_char (); - token = FMT_IBOZ; - } - - break; - - case '\'': - case '"': - delim = c; - - value = 0; - - for (;;) - { - c = next_char (INSTRING_WARN); - if (c == '\0') - { - token = FMT_END; - break; - } - - if (c == delim) - { - c = next_char (NONSTRING); - - if (c == '\0') - { - token = FMT_END; - break; - } - - if (c != delim) - { - unget_char (); - token = FMT_CHAR; - break; - } - } - value++; - } - break; - - case 'P': - token = FMT_P; - break; - - case 'I': - case 'O': - case 'Z': - token = FMT_IBOZ; - break; - - case 'F': - token = FMT_F; - break; - - case 'E': - c = next_char_not_space (); - if (c == 'N' ) - token = FMT_EN; - else if (c == 'S') - token = FMT_ES; - else - { - token = FMT_E; - unget_char (); - } - - break; - - case 'G': - token = FMT_G; - break; - - case 'H': - token = FMT_H; - break; - - case 'L': - token = FMT_L; - break; - - case 'A': - token = FMT_A; - break; - - case 'D': - c = next_char_not_space (); - if (c == 'P') - { - if (!gfc_notify_std (GFC_STD_F2003, "DP format " - "specifier not allowed at %C")) - return FMT_ERROR; - token = FMT_DP; - } - else if (c == 'C') - { - if (!gfc_notify_std (GFC_STD_F2003, "DC format " - "specifier not allowed at %C")) - return FMT_ERROR; - token = FMT_DC; - } - else if (c == 'T') - { - if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format " - "specifier not allowed at %C")) - return FMT_ERROR; - token = FMT_DT; - c = next_char_not_space (); - if (c == '\'' || c == '"') - { - delim = c; - value = 0; - - for (;;) - { - c = next_char (INSTRING_WARN); - if (c == '\0') - { - token = FMT_END; - break; - } - - if (c == delim) - { - c = next_char (NONSTRING); - if (c == '\0') - { - token = FMT_END; - break; - } - if (c == '/') - { - token = FMT_SLASH; - break; - } - if (c == delim) - continue; - unget_char (); - break; - } - } - } - else if (c == '/') - { - token = FMT_SLASH; - break; - } - else - unget_char (); - } - else - { - token = FMT_D; - unget_char (); - } - break; - - case 'R': - c = next_char_not_space (); - switch (c) - { - case 'C': - token = FMT_RC; - break; - case 'D': - token = FMT_RD; - break; - case 'N': - token = FMT_RN; - break; - case 'P': - token = FMT_RP; - break; - case 'U': - token = FMT_RU; - break; - case 'Z': - token = FMT_RZ; - break; - default: - token = FMT_UNKNOWN; - unget_char (); - break; - } - break; - - case '\0': - token = FMT_END; - break; - - case '*': - token = FMT_STAR; - break; - - default: - token = FMT_UNKNOWN; - break; - } - - return token; -} - - -static const char * -token_to_string (format_token t) -{ - switch (t) - { - case FMT_D: - return "D"; - case FMT_G: - return "G"; - case FMT_E: - return "E"; - case FMT_EN: - return "EN"; - case FMT_ES: - return "ES"; - default: - return ""; - } -} - -/* Check a format statement. The format string, either from a FORMAT - statement or a constant in an I/O statement has already been parsed - by itself, and we are checking it for validity. The dual origin - means that the warning message is a little less than great. */ - -static bool -check_format (bool is_input) -{ - const char *posint_required - = G_("Positive width required in format string at %L"); - const char *nonneg_required - = G_("Nonnegative width required in format string at %L"); - const char *unexpected_element - = G_("Unexpected element %qc in format string at %L"); - const char *unexpected_end - = G_("Unexpected end of format string in format string at %L"); - const char *zero_width - = G_("Zero width in format descriptor in format string at %L"); - - const char *error = NULL; - format_token t, u; - int level; - int repeat; - bool rv; - - use_last_char = 0; - saved_token = FMT_NONE; - level = 0; - repeat = 0; - rv = true; - format_string_pos = 0; - - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_LPAREN) - { - error = G_("Missing leading left parenthesis in format string at %L"); - goto syntax; - } - - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t == FMT_RPAREN) - goto finished; /* Empty format is legal */ - saved_token = t; - -format_item: - /* In this state, the next thing has to be a format item. */ - t = format_lex (); - if (t == FMT_ERROR) - goto fail; -format_item_1: - switch (t) - { - case FMT_STAR: - repeat = -1; - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t == FMT_LPAREN) - { - level++; - goto format_item; - } - error = G_("Left parenthesis required after %<*%> in format string " - "at %L"); - goto syntax; - - case FMT_POSINT: - repeat = value; - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t == FMT_LPAREN) - { - level++; - goto format_item; - } - - if (t == FMT_SLASH) - goto optional_comma; - - goto data_desc; - - case FMT_LPAREN: - level++; - goto format_item; - - case FMT_SIGNED_INT: - case FMT_ZERO: - /* Signed integer can only precede a P format. */ - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_P) - { - error = G_("Expected P edit descriptor in format string at %L"); - goto syntax; - } - - goto data_desc; - - case FMT_P: - /* P requires a prior number. */ - error = G_("P descriptor requires leading scale factor in format " - "string at %L"); - goto syntax; - - case FMT_X: - /* X requires a prior number if we're being pedantic. */ - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos; - if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading " - "space count at %L", &format_locus)) - return false; - goto between_desc; - - case FMT_SIGN: - case FMT_BLANK: - case FMT_DP: - case FMT_DC: - case FMT_RC: - case FMT_RD: - case FMT_RN: - case FMT_RP: - case FMT_RU: - case FMT_RZ: - goto between_desc; - - case FMT_CHAR: - goto extension_optional_comma; - - case FMT_COLON: - case FMT_SLASH: - goto optional_comma; - - case FMT_DOLLAR: - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - - if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus)) - return false; - if (t != FMT_RPAREN || level > 0) - { - gfc_warning (0, "$ should be the last specifier in format at %L", - &format_locus); - goto optional_comma_1; - } - - goto finished; - - case FMT_T: - case FMT_TL: - case FMT_TR: - case FMT_IBOZ: - case FMT_F: - case FMT_E: - case FMT_EN: - case FMT_ES: - case FMT_G: - case FMT_L: - case FMT_A: - case FMT_D: - case FMT_H: - case FMT_DT: - goto data_desc; - - case FMT_END: - error = unexpected_end; - goto syntax; - - case FMT_RPAREN: - if (flag_dec_blank_format_item) - goto finished; - else - { - error = G_("Missing item in format string at %L"); - goto syntax; - } - - default: - error = unexpected_element; - goto syntax; - } - -data_desc: - /* In this state, t must currently be a data descriptor. - Deal with things that can/must follow the descriptor. */ - switch (t) - { - case FMT_SIGN: - case FMT_BLANK: - case FMT_DP: - case FMT_DC: - case FMT_X: - break; - - case FMT_P: - /* No comma after P allowed only for F, E, EN, ES, D, or G. - 10.1.1 (1). */ - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA - && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES - && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) - { - error = G_("Comma required after P descriptor in format string " - "at %L"); - goto syntax; - } - if (t != FMT_COMMA) - { - if (t == FMT_POSINT) - { - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - } - if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES - && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) - { - error = G_("Comma required after P descriptor in format string " - "at %L"); - goto syntax; - } - } - - saved_token = t; - goto optional_comma; - - case FMT_T: - case FMT_TL: - case FMT_TR: - t = format_lex (); - if (t != FMT_POSINT) - { - error = G_("Positive width required with T descriptor in format " - "string at %L"); - goto syntax; - } - break; - - case FMT_L: - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t == FMT_POSINT) - break; - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos; - if (t == FMT_ZERO) - { - switch (gfc_notification_std (GFC_STD_GNU)) - { - case WARNING: - gfc_warning (0, "Extension: Zero width after L " - "descriptor at %L", &format_locus); - break; - case ERROR: - gfc_error ("Extension: Zero width after L " - "descriptor at %L", &format_locus); - goto fail; - case SILENT: - break; - default: - gcc_unreachable (); - } - } - else - { - saved_token = t; - gfc_notify_std (GFC_STD_GNU, "Missing positive width after " - "L descriptor at %L", &format_locus); - } - break; - - case FMT_A: - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t == FMT_ZERO) - { - error = zero_width; - goto syntax; - } - if (t != FMT_POSINT) - saved_token = t; - break; - - case FMT_D: - case FMT_E: - case FMT_G: - case FMT_EN: - case FMT_ES: - u = format_lex (); - if (t == FMT_G && u == FMT_ZERO) - { - if (is_input) - { - error = zero_width; - goto syntax; - } - if (!gfc_notify_std (GFC_STD_F2008, "% in format at %L", - &format_locus)) - return false; - u = format_lex (); - if (u != FMT_PERIOD) - { - saved_token = u; - break; - } - u = format_lex (); - if (u != FMT_POSINT) - { - error = posint_required; - goto syntax; - } - u = format_lex (); - if (u == FMT_E) - { - error = G_("E specifier not allowed with g0 descriptor in " - "format string at %L"); - goto syntax; - } - saved_token = u; - break; - } - - if (u != FMT_POSINT) - { - if (flag_dec) - { - if (flag_dec_format_defaults) - { - /* Assume a default width based on the variable size. */ - saved_token = u; - break; - } - else - { - gfc_error ("Positive width required in format " - "specifier %s at %L", token_to_string (t), - &format_locus); - saved_token = u; - goto fail; - } - } - - format_locus.nextc += format_string_pos; - if (!gfc_notify_std (GFC_STD_F2018, - "positive width required at %L", - &format_locus)) - { - saved_token = u; - goto fail; - } - if (flag_dec_format_defaults) - { - /* Assume a default width based on the variable size. */ - saved_token = u; - break; - } - } - - u = format_lex (); - if (u == FMT_ERROR) - goto fail; - if (u != FMT_PERIOD) - { - /* Warn if -std=legacy, otherwise error. */ - format_locus.nextc += format_string_pos; - if (gfc_option.warn_std != 0) - { - gfc_error ("Period required in format " - "specifier %s at %L", token_to_string (t), - &format_locus); - saved_token = u; - goto fail; - } - else - gfc_warning (0, "Period required in format " - "specifier %s at %L", token_to_string (t), - &format_locus); - /* If we go to finished, we need to unwind this - before the next round. */ - format_locus.nextc -= format_string_pos; - saved_token = u; - break; - } - - u = format_lex (); - if (u == FMT_ERROR) - goto fail; - if (u != FMT_ZERO && u != FMT_POSINT) - { - error = nonneg_required; - goto syntax; - } - - if (t == FMT_D) - break; - - /* Look for optional exponent. */ - u = format_lex (); - if (u == FMT_ERROR) - goto fail; - if (u != FMT_E) - saved_token = u; - else - { - u = format_lex (); - if (u == FMT_ERROR) - goto fail; - if (u != FMT_POSINT) - { - if (u == FMT_ZERO) - { - if (!gfc_notify_std (GFC_STD_F2018, - "Positive exponent width required in " - "format string at %L", &format_locus)) - { - saved_token = u; - goto fail; - } - } - else - { - error = G_("Positive exponent width required in format " - "string at %L"); - goto syntax; - } - } - } - - break; - - case FMT_DT: - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - switch (t) - { - case FMT_RPAREN: - level--; - if (level < 0) - goto finished; - goto between_desc; - - case FMT_COMMA: - goto format_item; - - case FMT_COLON: - goto format_item_1; - - case FMT_LPAREN: - - dtio_vlist: - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - - if (t != FMT_POSINT) - { - error = posint_required; - goto syntax; - } - - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - - if (t == FMT_COMMA) - goto dtio_vlist; - if (t != FMT_RPAREN) - { - error = G_("Right parenthesis expected at %C in format string " - "at %L"); - goto syntax; - } - goto between_desc; - - default: - error = unexpected_element; - goto syntax; - } - break; - - case FMT_F: - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_ZERO && t != FMT_POSINT) - { - if (flag_dec_format_defaults) - { - /* Assume the default width is expected here and continue lexing. */ - value = 0; /* It doesn't matter what we set the value to here. */ - saved_token = t; - break; - } - error = nonneg_required; - goto syntax; - } - else if (is_input && t == FMT_ZERO) - { - error = posint_required; - goto syntax; - } - - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_PERIOD) - { - /* Warn if -std=legacy, otherwise error. */ - if (gfc_option.warn_std != 0) - { - error = G_("Period required in format specifier in format " - "string at %L"); - goto syntax; - } - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos; - gfc_warning (0, "Period required in format specifier at %L", - &format_locus); - saved_token = t; - break; - } - - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_ZERO && t != FMT_POSINT) - { - error = nonneg_required; - goto syntax; - } - - break; - - case FMT_H: - if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) - { - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos; - gfc_warning (0, "The H format specifier at %L is" - " a Fortran 95 deleted feature", &format_locus); - } - if (mode == MODE_STRING) - { - format_string += value; - format_length -= value; - format_string_pos += repeat; - } - else - { - while (repeat >0) - { - next_char (INSTRING_WARN); - repeat -- ; - } - } - break; - - case FMT_IBOZ: - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_ZERO && t != FMT_POSINT) - { - if (flag_dec_format_defaults) - { - /* Assume the default width is expected here and continue lexing. */ - value = 0; /* It doesn't matter what we set the value to here. */ - saved_token = t; - } - else - { - error = nonneg_required; - goto syntax; - } - } - else if (is_input && t == FMT_ZERO) - { - error = posint_required; - goto syntax; - } - - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_PERIOD) - saved_token = t; - else - { - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - if (t != FMT_ZERO && t != FMT_POSINT) - { - error = nonneg_required; - goto syntax; - } - } - - break; - - default: - error = unexpected_element; - goto syntax; - } - -between_desc: - /* Between a descriptor and what comes next. */ - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - switch (t) - { - - case FMT_COMMA: - goto format_item; - - case FMT_RPAREN: - level--; - if (level < 0) - goto finished; - goto between_desc; - - case FMT_COLON: - case FMT_SLASH: - goto optional_comma; - - case FMT_END: - error = unexpected_end; - goto syntax; - - default: - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos - 1; - if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) - return false; - /* If we do not actually return a failure, we need to unwind this - before the next round. */ - if (mode != MODE_FORMAT) - format_locus.nextc -= format_string_pos; - goto format_item_1; - } - -optional_comma: - /* Optional comma is a weird between state where we've just finished - reading a colon, slash, dollar or P descriptor. */ - t = format_lex (); - if (t == FMT_ERROR) - goto fail; -optional_comma_1: - switch (t) - { - case FMT_COMMA: - break; - - case FMT_RPAREN: - level--; - if (level < 0) - goto finished; - goto between_desc; - - default: - /* Assume that we have another format item. */ - saved_token = t; - break; - } - - goto format_item; - -extension_optional_comma: - /* As a GNU extension, permit a missing comma after a string literal. */ - t = format_lex (); - if (t == FMT_ERROR) - goto fail; - switch (t) - { - case FMT_COMMA: - break; - - case FMT_RPAREN: - level--; - if (level < 0) - goto finished; - goto between_desc; - - case FMT_COLON: - case FMT_SLASH: - goto optional_comma; - - case FMT_END: - error = unexpected_end; - goto syntax; - - default: - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos; - if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) - return false; - /* If we do not actually return a failure, we need to unwind this - before the next round. */ - if (mode != MODE_FORMAT) - format_locus.nextc -= format_string_pos; - saved_token = t; - break; - } - - goto format_item; - -syntax: - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos; - if (error == unexpected_element) - gfc_error (error, error_element, &format_locus); - else - gfc_error (error, &format_locus); -fail: - rv = false; - -finished: - return rv; -} - - -/* Given an expression node that is a constant string, see if it looks - like a format string. */ - -static bool -check_format_string (gfc_expr *e, bool is_input) -{ - bool rv; - int i; - if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) - return true; - - mode = MODE_STRING; - format_string = e->value.character.string; - - /* More elaborate measures are needed to show where a problem is within a - format string that has been calculated, but that's probably not worth the - effort. */ - format_locus = e->where; - rv = check_format (is_input); - /* check for extraneous characters at the end of an otherwise valid format - string, like '(A10,I3)F5' - start at the end and move back to the last character processed, - spaces are OK */ - if (rv && e->value.character.length > format_string_pos) - for (i=e->value.character.length-1;i>format_string_pos-1;i--) - if (e->value.character.string[i] != ' ') - { - format_locus.nextc += format_length + 1; - gfc_warning (0, - "Extraneous characters in format at %L", &format_locus); - break; - } - return rv; -} - - -/************ Fortran I/O statement matchers *************/ - -/* Match a FORMAT statement. This amounts to actually parsing the - format descriptors in order to correctly locate the end of the - format string. */ - -match -gfc_match_format (void) -{ - gfc_expr *e; - locus start; - - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) - { - gfc_error ("Format statement in module main block at %C"); - return MATCH_ERROR; - } - - /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */ - if ((gfc_current_state () == COMP_FUNCTION - || gfc_current_state () == COMP_SUBROUTINE) - && gfc_state_stack->previous->state == COMP_INTERFACE) - { - gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE"); - return MATCH_ERROR; - } - - if (gfc_statement_label == NULL) - { - gfc_error ("Missing format label at %C"); - return MATCH_ERROR; - } - gfc_gobble_whitespace (); - - mode = MODE_FORMAT; - format_length = 0; - - start = gfc_current_locus; - - if (!check_format (false)) - return MATCH_ERROR; - - if (gfc_match_eos () != MATCH_YES) - { - gfc_syntax_error (ST_FORMAT); - return MATCH_ERROR; - } - - /* The label doesn't get created until after the statement is done - being matched, so we have to leave the string for later. */ - - gfc_current_locus = start; /* Back to the beginning */ - - new_st.loc = start; - new_st.op = EXEC_NOP; - - e = gfc_get_character_expr (gfc_default_character_kind, &start, - NULL, format_length); - format_string = e->value.character.string; - gfc_statement_label->format = e; - - mode = MODE_COPY; - check_format (false); /* Guaranteed to succeed */ - gfc_match_eos (); /* Guaranteed to succeed */ - - return MATCH_YES; -} - - -/* Match an expression I/O tag of some sort. */ - -static match -match_etag (const io_tag *tag, gfc_expr **v) -{ - gfc_expr *result; - match m; - - m = gfc_match (tag->spec); - if (m != MATCH_YES) - return m; - - m = gfc_match (tag->value, &result); - if (m != MATCH_YES) - { - gfc_error ("Invalid value for %s specification at %C", tag->name); - return MATCH_ERROR; - } - - if (*v != NULL) - { - gfc_error ("Duplicate %s specification at %C", tag->name); - gfc_free_expr (result); - return MATCH_ERROR; - } - - *v = result; - return MATCH_YES; -} - - -/* Match a variable I/O tag of some sort. */ - -static match -match_vtag (const io_tag *tag, gfc_expr **v) -{ - gfc_expr *result; - match m; - - m = gfc_match (tag->spec); - if (m != MATCH_YES) - return m; - - m = gfc_match (tag->value, &result); - if (m != MATCH_YES) - { - gfc_error ("Invalid value for %s specification at %C", tag->name); - return MATCH_ERROR; - } - - if (*v != NULL) - { - gfc_error ("Duplicate %s specification at %C", tag->name); - gfc_free_expr (result); - return MATCH_ERROR; - } - - if (result->symtree) - { - bool impure; - - if (result->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name); - gfc_free_expr (result); - return MATCH_ERROR; - } - - impure = gfc_impure_variable (result->symtree->n.sym); - if (impure && gfc_pure (NULL)) - { - gfc_error ("Variable %s cannot be assigned in PURE procedure at %C", - tag->name); - gfc_free_expr (result); - return MATCH_ERROR; - } - - if (impure) - gfc_unset_implicit_pure (NULL); - } - - *v = result; - return MATCH_YES; -} - - -/* Match I/O tags that cause variables to become redefined. */ - -static match -match_out_tag (const io_tag *tag, gfc_expr **result) -{ - match m; - - m = match_vtag (tag, result); - if (m == MATCH_YES) - { - if ((*result)->symtree) - gfc_check_do_variable ((*result)->symtree); - - if ((*result)->expr_type == EXPR_CONSTANT) - { - gfc_error ("Expecting a variable at %L", &(*result)->where); - return MATCH_ERROR; - } - } - - return m; -} - - -/* Match a label I/O tag. */ - -static match -match_ltag (const io_tag *tag, gfc_st_label ** label) -{ - match m; - gfc_st_label *old; - - old = *label; - m = gfc_match (tag->spec); - if (m != MATCH_YES) - return m; - - m = gfc_match (tag->value, label); - if (m != MATCH_YES) - { - gfc_error ("Invalid value for %s specification at %C", tag->name); - return MATCH_ERROR; - } - - if (old) - { - gfc_error ("Duplicate %s label specification at %C", tag->name); - return MATCH_ERROR; - } - - if (!gfc_reference_st_label (*label, ST_LABEL_TARGET)) - return MATCH_ERROR; - - return m; -} - - -/* Match a tag using match_etag, but only if -fdec is enabled. */ -static match -match_dec_etag (const io_tag *tag, gfc_expr **e) -{ - match m = match_etag (tag, e); - if (flag_dec && m != MATCH_NO) - return m; - else if (m != MATCH_NO) - { - gfc_error ("%s at %C is a DEC extension, enable with " - "%<-fdec%>", tag->name); - return MATCH_ERROR; - } - return m; -} - - -/* Match a tag using match_vtag, but only if -fdec is enabled. */ -static match -match_dec_vtag (const io_tag *tag, gfc_expr **e) -{ - match m = match_vtag(tag, e); - if (flag_dec && m != MATCH_NO) - return m; - else if (m != MATCH_NO) - { - gfc_error ("%s at %C is a DEC extension, enable with " - "%<-fdec%>", tag->name); - return MATCH_ERROR; - } - return m; -} - - -/* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */ - -static match -match_dec_ftag (const io_tag *tag, gfc_open *o) -{ - match m; - - m = gfc_match (tag->spec); - if (m != MATCH_YES) - return m; - - if (!flag_dec) - { - gfc_error ("%s at %C is a DEC extension, enable with " - "%<-fdec%>", tag->name); - return MATCH_ERROR; - } - - /* Just set the READONLY flag, which we use at runtime to avoid delete on - close. */ - if (tag == &tag_readonly) - { - o->readonly |= 1; - return MATCH_YES; - } - - /* Interpret SHARED as SHARE='DENYNONE' (read lock). */ - else if (tag == &tag_shared) - { - if (o->share != NULL) - { - gfc_error ("Duplicate %s specification at %C", tag->name); - return MATCH_ERROR; - } - o->share = gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, "denynone", 8); - return MATCH_YES; - } - - /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */ - else if (tag == &tag_noshared) - { - if (o->share != NULL) - { - gfc_error ("Duplicate %s specification at %C", tag->name); - return MATCH_ERROR; - } - o->share = gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, "denyrw", 6); - return MATCH_YES; - } - - /* We handle all DEC tags above. */ - gcc_unreachable (); -} - - -/* Resolution of the FORMAT tag, to be called from resolve_tag. */ - -static bool -resolve_tag_format (gfc_expr *e) -{ - if (e->expr_type == EXPR_CONSTANT - && (e->ts.type != BT_CHARACTER - || e->ts.kind != gfc_default_character_kind)) - { - gfc_error ("Constant expression in FORMAT tag at %L must be " - "of type default CHARACTER", &e->where); - return false; - } - - /* Concatenate a constant character array into a single character - expression. */ - - if ((e->expr_type == EXPR_ARRAY || e->rank > 0) - && e->ts.type == BT_CHARACTER - && gfc_is_constant_expr (e)) - { - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.flavor == FL_PARAMETER) - gfc_simplify_expr (e, 1); - - if (e->expr_type == EXPR_ARRAY) - { - gfc_constructor *c; - gfc_charlen_t n, len; - gfc_expr *r; - gfc_char_t *dest, *src; - - if (e->value.constructor == NULL) - { - gfc_error ("FORMAT tag at %L cannot be a zero-sized array", - &e->where); - return false; - } - - n = 0; - c = gfc_constructor_first (e->value.constructor); - len = c->expr->value.character.length; - - for ( ; c; c = gfc_constructor_next (c)) - n += len; - - r = gfc_get_character_expr (e->ts.kind, &e->where, NULL, n); - dest = r->value.character.string; - - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - { - src = c->expr->value.character.string; - for (gfc_charlen_t i = 0 ; i < len; i++) - *dest++ = *src++; - } - - gfc_replace_expr (e, r); - return true; - } - } - - /* If e's rank is zero and e is not an element of an array, it should be - of integer or character type. The integer variable should be - ASSIGNED. */ - if (e->rank == 0 - && (e->expr_type != EXPR_VARIABLE - || e->symtree == NULL - || e->symtree->n.sym->as == NULL - || e->symtree->n.sym->as->rank == 0)) - { - if ((e->ts.type != BT_CHARACTER - || e->ts.kind != gfc_default_character_kind) - && e->ts.type != BT_INTEGER) - { - gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER " - "or of INTEGER", &e->where); - return false; - } - else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) - { - if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in " - "FORMAT tag at %L", &e->where)) - return false; - if (e->symtree->n.sym->attr.assign != 1) - { - gfc_error ("Variable %qs at %L has not been assigned a " - "format label", e->symtree->n.sym->name, &e->where); - return false; - } - } - else if (e->ts.type == BT_INTEGER) - { - gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED " - "variable", gfc_basic_typename (e->ts.type), &e->where); - return false; - } - - return true; - } - - /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY. - It may be assigned an Hollerith constant. */ - if (e->ts.type != BT_CHARACTER) - { - if (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS - || e->ts.type == BT_VOID || e->ts.type == BT_UNKNOWN) - { - gfc_error ("Non-character non-Hollerith in FORMAT tag at %L", - &e->where); - return false; - } - if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag " - "at %L", &e->where)) - return false; - - if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) - { - gfc_error ("Non-character assumed shape array element in FORMAT" - " tag at %L", &e->where); - return false; - } - - if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) - { - gfc_error ("Non-character assumed size array element in FORMAT" - " tag at %L", &e->where); - return false; - } - - if (e->rank == 0 && e->symtree->n.sym->attr.pointer) - { - gfc_error ("Non-character pointer array element in FORMAT tag at %L", - &e->where); - return false; - } - } - - return true; -} - - -/* Do expression resolution and type-checking on an expression tag. */ - -static bool -resolve_tag (const io_tag *tag, gfc_expr *e) -{ - if (e == NULL) - return true; - - if (!gfc_resolve_expr (e)) - return false; - - if (tag == &tag_format) - return resolve_tag_format (e); - - if (e->ts.type != tag->type) - { - gfc_error ("%s tag at %L must be of type %s", tag->name, - &e->where, gfc_basic_typename (tag->type)); - return false; - } - - if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind) - { - gfc_error ("%s tag at %L must be a character string of default kind", - tag->name, &e->where); - return false; - } - - if (e->rank != 0) - { - gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); - return false; - } - - if (tag == &tag_iomsg) - { - if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where)) - return false; - } - - if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength - || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl) - && e->ts.kind != gfc_default_integer_kind) - { - if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " - "INTEGER in %s tag at %L", tag->name, &e->where)) - return false; - } - - if (e->ts.kind != gfc_default_logical_kind && - (tag == &tag_exist || tag == &tag_named || tag == &tag_opened - || tag == &tag_pending)) - { - if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind " - "in %s tag at %L", tag->name, &e->where)) - return false; - } - - if (tag == &tag_newunit) - { - if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L", - &e->where)) - return false; - } - - /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */ - if (tag == &tag_newunit || tag == &tag_iostat - || tag == &tag_size || tag == &tag_iomsg) - { - char context[64]; - - sprintf (context, _("%s tag"), tag->name); - if (!gfc_check_vardef_context (e, false, false, false, context)) - return false; - } - - if (tag == &tag_convert) - { - if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where)) - return false; - } - - return true; -} - - -/* Match a single tag of an OPEN statement. */ - -static match -match_open_element (gfc_open *open) -{ - match m; - - m = match_etag (&tag_e_async, &open->asynchronous); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_unit, &open->unit); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_iomsg, &open->iomsg); - if (m != MATCH_NO) - return m; - m = match_out_tag (&tag_iostat, &open->iostat); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_file, &open->file); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_status, &open->status); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_access, &open->access); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_form, &open->form); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_recl, &open->recl); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_blank, &open->blank); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_position, &open->position); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_action, &open->action); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_delim, &open->delim); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_pad, &open->pad); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_decimal, &open->decimal); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_encoding, &open->encoding); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_round, &open->round); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_sign, &open->sign); - if (m != MATCH_NO) - return m; - m = match_ltag (&tag_err, &open->err); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_convert, &open->convert); - if (m != MATCH_NO) - return m; - m = match_out_tag (&tag_newunit, &open->newunit); - if (m != MATCH_NO) - return m; - - /* The following are extensions enabled with -fdec. */ - m = match_dec_etag (&tag_e_share, &open->share); - if (m != MATCH_NO) - return m; - m = match_dec_etag (&tag_cc, &open->cc); - if (m != MATCH_NO) - return m; - m = match_dec_ftag (&tag_readonly, open); - if (m != MATCH_NO) - return m; - m = match_dec_ftag (&tag_shared, open); - if (m != MATCH_NO) - return m; - m = match_dec_ftag (&tag_noshared, open); - if (m != MATCH_NO) - return m; - - return MATCH_NO; -} - - -/* Free the gfc_open structure and all the expressions it contains. */ - -void -gfc_free_open (gfc_open *open) -{ - if (open == NULL) - return; - - gfc_free_expr (open->unit); - gfc_free_expr (open->iomsg); - gfc_free_expr (open->iostat); - gfc_free_expr (open->file); - gfc_free_expr (open->status); - gfc_free_expr (open->access); - gfc_free_expr (open->form); - gfc_free_expr (open->recl); - gfc_free_expr (open->blank); - gfc_free_expr (open->position); - gfc_free_expr (open->action); - gfc_free_expr (open->delim); - gfc_free_expr (open->pad); - gfc_free_expr (open->decimal); - gfc_free_expr (open->encoding); - gfc_free_expr (open->round); - gfc_free_expr (open->sign); - gfc_free_expr (open->convert); - gfc_free_expr (open->asynchronous); - gfc_free_expr (open->newunit); - gfc_free_expr (open->share); - gfc_free_expr (open->cc); - free (open); -} - - -static int -compare_to_allowed_values (const char *specifier, const char *allowed[], - const char *allowed_f2003[], - const char *allowed_gnu[], gfc_char_t *value, - const char *statement, bool warn, locus *where, - int *num = NULL); - - -static bool -check_open_constraints (gfc_open *open, locus *where); - -/* Resolve everything in a gfc_open structure. */ - -bool -gfc_resolve_open (gfc_open *open, locus *where) -{ - RESOLVE_TAG (&tag_unit, open->unit); - RESOLVE_TAG (&tag_iomsg, open->iomsg); - RESOLVE_TAG (&tag_iostat, open->iostat); - RESOLVE_TAG (&tag_file, open->file); - RESOLVE_TAG (&tag_status, open->status); - RESOLVE_TAG (&tag_e_access, open->access); - RESOLVE_TAG (&tag_e_form, open->form); - RESOLVE_TAG (&tag_e_recl, open->recl); - RESOLVE_TAG (&tag_e_blank, open->blank); - RESOLVE_TAG (&tag_e_position, open->position); - RESOLVE_TAG (&tag_e_action, open->action); - RESOLVE_TAG (&tag_e_delim, open->delim); - RESOLVE_TAG (&tag_e_pad, open->pad); - RESOLVE_TAG (&tag_e_decimal, open->decimal); - RESOLVE_TAG (&tag_e_encoding, open->encoding); - RESOLVE_TAG (&tag_e_async, open->asynchronous); - RESOLVE_TAG (&tag_e_round, open->round); - RESOLVE_TAG (&tag_e_sign, open->sign); - RESOLVE_TAG (&tag_convert, open->convert); - RESOLVE_TAG (&tag_newunit, open->newunit); - RESOLVE_TAG (&tag_e_share, open->share); - RESOLVE_TAG (&tag_cc, open->cc); - - if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) - return false; - - return check_open_constraints (open, where); -} - - -/* Check if a given value for a SPECIFIER is either in the list of values - allowed in F95 or F2003, issuing an error message and returning a zero - value if it is not allowed. */ - - -static int -compare_to_allowed_values (const char *specifier, const char *allowed[], - const char *allowed_f2003[], - const char *allowed_gnu[], gfc_char_t *value, - const char *statement, bool warn, locus *where, - int *num) -{ - int i; - unsigned int len; - - len = gfc_wide_strlen (value); - if (len > 0) - { - for (len--; len > 0; len--) - if (value[len] != ' ') - break; - len++; - } - - for (i = 0; allowed[i]; i++) - if (len == strlen (allowed[i]) - && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) - { - if (num) - *num = i; - return 1; - } - - if (!where) - where = &gfc_current_locus; - - for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) - if (len == strlen (allowed_f2003[i]) - && gfc_wide_strncasecmp (value, allowed_f2003[i], - strlen (allowed_f2003[i])) == 0) - { - notification n = gfc_notification_std (GFC_STD_F2003); - - if (n == WARNING || (warn && n == ERROR)) - { - gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L " - "has value %qs", specifier, statement, where, - allowed_f2003[i]); - return 1; - } - else - if (n == ERROR) - { - gfc_notify_std (GFC_STD_F2003, "%s specifier in " - "%s statement at %L has value %qs", specifier, - statement, where, allowed_f2003[i]); - return 0; - } - - /* n == SILENT */ - return 1; - } - - for (i = 0; allowed_gnu && allowed_gnu[i]; i++) - if (len == strlen (allowed_gnu[i]) - && gfc_wide_strncasecmp (value, allowed_gnu[i], - strlen (allowed_gnu[i])) == 0) - { - notification n = gfc_notification_std (GFC_STD_GNU); - - if (n == WARNING || (warn && n == ERROR)) - { - gfc_warning (0, "Extension: %s specifier in %s statement at %L " - "has value %qs", specifier, statement, where, - allowed_gnu[i]); - return 1; - } - else - if (n == ERROR) - { - gfc_notify_std (GFC_STD_GNU, "%s specifier in " - "%s statement at %L has value %qs", specifier, - statement, where, allowed_gnu[i]); - return 0; - } - - /* n == SILENT */ - return 1; - } - - if (warn) - { - char *s = gfc_widechar_to_char (value, -1); - gfc_warning (0, - "%s specifier in %s statement at %L has invalid value %qs", - specifier, statement, where, s); - free (s); - return 1; - } - else - { - char *s = gfc_widechar_to_char (value, -1); - gfc_error ("%s specifier in %s statement at %L has invalid value %qs", - specifier, statement, where, s); - free (s); - return 0; - } -} - - -/* Check constraints on the OPEN statement. - Similar to check_io_constraints for data transfer statements. - At this point all tags have already been resolved via resolve_tag, which, - among other things, verifies that BT_CHARACTER tags are of default kind. */ - -static bool -check_open_constraints (gfc_open *open, locus *where) -{ -#define warn_or_error(...) \ -{ \ - if (warn) \ - gfc_warning (0, __VA_ARGS__); \ - else \ - { \ - gfc_error (__VA_ARGS__); \ - return false; \ - } \ -} - - bool warn = (open->err || open->iostat) ? true : false; - - /* Checks on the ACCESS specifier. */ - if (open->access && open->access->expr_type == EXPR_CONSTANT) - { - static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL }; - static const char *access_f2003[] = { "STREAM", NULL }; - static const char *access_gnu[] = { "APPEND", NULL }; - - if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, - access_gnu, - open->access->value.character.string, - "OPEN", warn, &open->access->where)) - return false; - } - - /* Checks on the ACTION specifier. */ - if (open->action && open->action->expr_type == EXPR_CONSTANT) - { - gfc_char_t *str = open->action->value.character.string; - static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; - - if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, - str, "OPEN", warn, &open->action->where)) - return false; - - /* With READONLY, only allow ACTION='READ'. */ - if (open->readonly && (gfc_wide_strlen (str) != 4 - || gfc_wide_strncasecmp (str, "READ", 4) != 0)) - { - gfc_error ("ACTION type conflicts with READONLY specifier at %L", - &open->action->where); - return false; - } - } - - /* If we see READONLY and no ACTION, set ACTION='READ'. */ - else if (open->readonly && open->action == NULL) - { - open->action = gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, "read", 4); - } - - /* Checks on the ASYNCHRONOUS specifier. */ - if (open->asynchronous) - { - if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L " - "not allowed in Fortran 95", - &open->asynchronous->where)) - return false; - - if (open->asynchronous->expr_type == EXPR_CONSTANT) - { - static const char * asynchronous[] = { "YES", "NO", NULL }; - - if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, - NULL, NULL, open->asynchronous->value.character.string, - "OPEN", warn, &open->asynchronous->where)) - return false; - } - } - - /* Checks on the BLANK specifier. */ - if (open->blank) - { - if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " - "not allowed in Fortran 95", &open->blank->where)) - return false; - - if (open->blank->expr_type == EXPR_CONSTANT) - { - static const char *blank[] = { "ZERO", "NULL", NULL }; - - if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, - open->blank->value.character.string, - "OPEN", warn, &open->blank->where)) - return false; - } - } - - /* Checks on the CARRIAGECONTROL specifier. */ - if (open->cc && open->cc->expr_type == EXPR_CONSTANT) - { - static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; - if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, - open->cc->value.character.string, - "OPEN", warn, &open->cc->where)) - return false; - } - - /* Checks on the DECIMAL specifier. */ - if (open->decimal) - { - if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " - "not allowed in Fortran 95", &open->decimal->where)) - return false; - - if (open->decimal->expr_type == EXPR_CONSTANT) - { - static const char * decimal[] = { "COMMA", "POINT", NULL }; - - if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, - open->decimal->value.character.string, - "OPEN", warn, &open->decimal->where)) - return false; - } - } - - /* Checks on the DELIM specifier. */ - if (open->delim) - { - if (open->delim->expr_type == EXPR_CONSTANT) - { - static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; - - if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, - open->delim->value.character.string, - "OPEN", warn, &open->delim->where)) - return false; - } - } - - /* Checks on the ENCODING specifier. */ - if (open->encoding) - { - if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L " - "not allowed in Fortran 95", &open->encoding->where)) - return false; - - if (open->encoding->expr_type == EXPR_CONSTANT) - { - static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; - - if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, - open->encoding->value.character.string, - "OPEN", warn, &open->encoding->where)) - return false; - } - } - - /* Checks on the FORM specifier. */ - if (open->form && open->form->expr_type == EXPR_CONSTANT) - { - static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; - - if (!compare_to_allowed_values ("FORM", form, NULL, NULL, - open->form->value.character.string, - "OPEN", warn, &open->form->where)) - return false; - } - - /* Checks on the PAD specifier. */ - if (open->pad && open->pad->expr_type == EXPR_CONSTANT) - { - static const char *pad[] = { "YES", "NO", NULL }; - - if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, - open->pad->value.character.string, - "OPEN", warn, &open->pad->where)) - return false; - } - - /* Checks on the POSITION specifier. */ - if (open->position && open->position->expr_type == EXPR_CONSTANT) - { - static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; - - if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, - open->position->value.character.string, - "OPEN", warn, &open->position->where)) - return false; - } - - /* Checks on the ROUND specifier. */ - if (open->round) - { - if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " - "not allowed in Fortran 95", &open->round->where)) - return false; - - if (open->round->expr_type == EXPR_CONSTANT) - { - static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", - "COMPATIBLE", "PROCESSOR_DEFINED", - NULL }; - - if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, - open->round->value.character.string, - "OPEN", warn, &open->round->where)) - return false; - } - } - - /* Checks on the SHARE specifier. */ - if (open->share && open->share->expr_type == EXPR_CONSTANT) - { - static const char *share[] = { "DENYNONE", "DENYRW", NULL }; - if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, - open->share->value.character.string, - "OPEN", warn, &open->share->where)) - return false; - } - - /* Checks on the SIGN specifier. */ - if (open->sign) - { - if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " - "not allowed in Fortran 95", &open->sign->where)) - return false; - - if (open->sign->expr_type == EXPR_CONSTANT) - { - static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", - NULL }; - - if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, - open->sign->value.character.string, - "OPEN", warn, &open->sign->where)) - return false; - } - } - - /* Checks on the RECL specifier. */ - if (open->recl && open->recl->expr_type == EXPR_CONSTANT - && open->recl->ts.type == BT_INTEGER - && mpz_sgn (open->recl->value.integer) != 1) - { - warn_or_error (G_("RECL in OPEN statement at %L must be positive"), - &open->recl->where); - } - - /* Checks on the STATUS specifier. */ - if (open->status && open->status->expr_type == EXPR_CONSTANT) - { - static const char *status[] = { "OLD", "NEW", "SCRATCH", - "REPLACE", "UNKNOWN", NULL }; - - if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, - open->status->value.character.string, - "OPEN", warn, &open->status->where)) - return false; - - /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, - the FILE= specifier shall appear. */ - if (open->file == NULL - && (gfc_wide_strncasecmp (open->status->value.character.string, - "replace", 7) == 0 - || gfc_wide_strncasecmp (open->status->value.character.string, - "new", 3) == 0)) - { - char *s = gfc_widechar_to_char (open->status->value.character.string, - -1); - warn_or_error (G_("The STATUS specified in OPEN statement at %L is " - "%qs and no FILE specifier is present"), - &open->status->where, s); - free (s); - } - - /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, - the FILE= specifier shall not appear. */ - if (gfc_wide_strncasecmp (open->status->value.character.string, - "scratch", 7) == 0 && open->file) - { - warn_or_error (G_("The STATUS specified in OPEN statement at %L " - "cannot have the value SCRATCH if a FILE specifier " - "is present"), &open->status->where); - } - } - - /* Checks on NEWUNIT specifier. */ - if (open->newunit) - { - if (open->unit) - { - gfc_error ("UNIT specifier not allowed with NEWUNIT at %L", - &open->newunit->where); - return false; - } - - if (!open->file && - (!open->status || - (open->status->expr_type == EXPR_CONSTANT - && gfc_wide_strncasecmp (open->status->value.character.string, - "scratch", 7) != 0))) - { - gfc_error ("NEWUNIT specifier must have FILE= " - "or STATUS='scratch' at %L", &open->newunit->where); - return false; - } - } - else if (!open->unit) - { - gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified", - where); - return false; - } - - /* Things that are not allowed for unformatted I/O. */ - if (open->form && open->form->expr_type == EXPR_CONSTANT - && (open->delim || open->decimal || open->encoding || open->round - || open->sign || open->pad || open->blank) - && gfc_wide_strncasecmp (open->form->value.character.string, - "unformatted", 11) == 0) - { - locus *loc; - const char *spec; - if (open->delim) - { - loc = &open->delim->where; - spec = "DELIM "; - } - else if (open->pad) - { - loc = &open->pad->where; - spec = "PAD "; - } - else if (open->blank) - { - loc = &open->blank->where; - spec = "BLANK "; - } - else - { - loc = where; - spec = ""; - } - - warn_or_error (G_("%s specifier at %L not allowed in OPEN statement for " - "unformatted I/O"), spec, loc); - } - - if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT - && gfc_wide_strncasecmp (open->access->value.character.string, - "stream", 6) == 0) - { - warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for " - "stream I/O"), &open->recl->where); - } - - if (open->position - && open->access && open->access->expr_type == EXPR_CONSTANT - && !(gfc_wide_strncasecmp (open->access->value.character.string, - "sequential", 10) == 0 - || gfc_wide_strncasecmp (open->access->value.character.string, - "stream", 6) == 0 - || gfc_wide_strncasecmp (open->access->value.character.string, - "append", 6) == 0)) - { - warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed " - "for stream or sequential ACCESS"), &open->position->where); - } - - return true; -#undef warn_or_error -} - - -/* Match an OPEN statement. */ - -match -gfc_match_open (void) -{ - gfc_open *open; - match m; - - m = gfc_match_char ('('); - if (m == MATCH_NO) - return m; - - open = XCNEW (gfc_open); - - m = match_open_element (open); - - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_expr (&open->unit); - if (m == MATCH_ERROR) - goto cleanup; - } - - for (;;) - { - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = match_open_element (open); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - if (gfc_match_eos () == MATCH_NO) - goto syntax; - - if (gfc_pure (NULL)) - { - gfc_error ("OPEN statement not allowed in PURE procedure at %C"); - goto cleanup; - } - - gfc_unset_implicit_pure (NULL); - - new_st.op = EXEC_OPEN; - new_st.ext.open = open; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_OPEN); - -cleanup: - gfc_free_open (open); - return MATCH_ERROR; -} - - -/* Free a gfc_close structure an all its expressions. */ - -void -gfc_free_close (gfc_close *close) -{ - if (close == NULL) - return; - - gfc_free_expr (close->unit); - gfc_free_expr (close->iomsg); - gfc_free_expr (close->iostat); - gfc_free_expr (close->status); - free (close); -} - - -/* Match elements of a CLOSE statement. */ - -static match -match_close_element (gfc_close *close) -{ - match m; - - m = match_etag (&tag_unit, &close->unit); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_status, &close->status); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_iomsg, &close->iomsg); - if (m != MATCH_NO) - return m; - m = match_out_tag (&tag_iostat, &close->iostat); - if (m != MATCH_NO) - return m; - m = match_ltag (&tag_err, &close->err); - if (m != MATCH_NO) - return m; - - return MATCH_NO; -} - - -/* Match a CLOSE statement. */ - -match -gfc_match_close (void) -{ - gfc_close *close; - match m; - - m = gfc_match_char ('('); - if (m == MATCH_NO) - return m; - - close = XCNEW (gfc_close); - - m = match_close_element (close); - - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_expr (&close->unit); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - } - - for (;;) - { - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = match_close_element (close); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - if (gfc_match_eos () == MATCH_NO) - goto syntax; - - if (gfc_pure (NULL)) - { - gfc_error ("CLOSE statement not allowed in PURE procedure at %C"); - goto cleanup; - } - - gfc_unset_implicit_pure (NULL); - - new_st.op = EXEC_CLOSE; - new_st.ext.close = close; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_CLOSE); - -cleanup: - gfc_free_close (close); - return MATCH_ERROR; -} - - -static bool -check_close_constraints (gfc_close *close, locus *where) -{ - bool warn = (close->iostat || close->err) ? true : false; - - if (close->unit == NULL) - { - gfc_error ("CLOSE statement at %L requires a UNIT number", where); - return false; - } - - if (close->unit->expr_type == EXPR_CONSTANT - && close->unit->ts.type == BT_INTEGER - && mpz_sgn (close->unit->value.integer) < 0) - { - gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", - &close->unit->where); - } - - /* Checks on the STATUS specifier. */ - if (close->status && close->status->expr_type == EXPR_CONSTANT) - { - static const char *status[] = { "KEEP", "DELETE", NULL }; - - if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, - close->status->value.character.string, - "CLOSE", warn, &close->status->where)) - return false; - } - - return true; -} - -/* Resolve everything in a gfc_close structure. */ - -bool -gfc_resolve_close (gfc_close *close, locus *where) -{ - RESOLVE_TAG (&tag_unit, close->unit); - RESOLVE_TAG (&tag_iomsg, close->iomsg); - RESOLVE_TAG (&tag_iostat, close->iostat); - RESOLVE_TAG (&tag_status, close->status); - - if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) - return false; - - return check_close_constraints (close, where); -} - - -/* Free a gfc_filepos structure. */ - -void -gfc_free_filepos (gfc_filepos *fp) -{ - gfc_free_expr (fp->unit); - gfc_free_expr (fp->iomsg); - gfc_free_expr (fp->iostat); - free (fp); -} - - -/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */ - -static match -match_file_element (gfc_filepos *fp) -{ - match m; - - m = match_etag (&tag_unit, &fp->unit); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_iomsg, &fp->iomsg); - if (m != MATCH_NO) - return m; - m = match_out_tag (&tag_iostat, &fp->iostat); - if (m != MATCH_NO) - return m; - m = match_ltag (&tag_err, &fp->err); - if (m != MATCH_NO) - return m; - - return MATCH_NO; -} - - -/* Match the second half of the file-positioning statements, REWIND, - BACKSPACE, ENDFILE, or the FLUSH statement. */ - -static match -match_filepos (gfc_statement st, gfc_exec_op op) -{ - gfc_filepos *fp; - match m; - - fp = XCNEW (gfc_filepos); - - if (gfc_match_char ('(') == MATCH_NO) - { - m = gfc_match_expr (&fp->unit); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - goto done; - } - - m = match_file_element (fp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_expr (&fp->unit); - if (m == MATCH_ERROR || m == MATCH_NO) - goto syntax; - } - - for (;;) - { - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = match_file_element (fp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - -done: - if (gfc_match_eos () != MATCH_YES) - goto syntax; - - if (gfc_pure (NULL)) - { - gfc_error ("%s statement not allowed in PURE procedure at %C", - gfc_ascii_statement (st)); - - goto cleanup; - } - - gfc_unset_implicit_pure (NULL); - - new_st.op = op; - new_st.ext.filepos = fp; - return MATCH_YES; - -syntax: - gfc_syntax_error (st); - -cleanup: - gfc_free_filepos (fp); - return MATCH_ERROR; -} - - -bool -gfc_resolve_filepos (gfc_filepos *fp, locus *where) -{ - RESOLVE_TAG (&tag_unit, fp->unit); - RESOLVE_TAG (&tag_iostat, fp->iostat); - RESOLVE_TAG (&tag_iomsg, fp->iomsg); - - if (!fp->unit && (fp->iostat || fp->iomsg || fp->err)) - { - gfc_error ("UNIT number missing in statement at %L", where); - return false; - } - - if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) - return false; - - if (fp->unit->expr_type == EXPR_CONSTANT - && fp->unit->ts.type == BT_INTEGER - && mpz_sgn (fp->unit->value.integer) < 0) - { - gfc_error ("UNIT number in statement at %L must be non-negative", - &fp->unit->where); - return false; - } - - return true; -} - - -/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND, - and the FLUSH statement. */ - -match -gfc_match_endfile (void) -{ - return match_filepos (ST_END_FILE, EXEC_ENDFILE); -} - -match -gfc_match_backspace (void) -{ - return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE); -} - -match -gfc_match_rewind (void) -{ - return match_filepos (ST_REWIND, EXEC_REWIND); -} - -match -gfc_match_flush (void) -{ - if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C")) - return MATCH_ERROR; - - return match_filepos (ST_FLUSH, EXEC_FLUSH); -} - -/******************** Data Transfer Statements *********************/ - -/* Return a default unit number. */ - -static gfc_expr * -default_unit (io_kind k) -{ - int unit; - - if (k == M_READ) - unit = 5; - else - unit = 6; - - return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit); -} - - -/* Match a unit specification for a data transfer statement. */ - -static match -match_dt_unit (io_kind k, gfc_dt *dt) -{ - gfc_expr *e; - char c; - - if (gfc_match_char ('*') == MATCH_YES) - { - if (dt->io_unit != NULL) - goto conflict; - - dt->io_unit = default_unit (k); - - c = gfc_peek_ascii_char (); - if (c == ')') - gfc_error_now ("Missing format with default unit at %C"); - - return MATCH_YES; - } - - if (gfc_match_expr (&e) == MATCH_YES) - { - if (dt->io_unit != NULL) - { - gfc_free_expr (e); - goto conflict; - } - - dt->io_unit = e; - return MATCH_YES; - } - - return MATCH_NO; - -conflict: - gfc_error ("Duplicate UNIT specification at %C"); - return MATCH_ERROR; -} - - -/* Match a format specification. */ - -static match -match_dt_format (gfc_dt *dt) -{ - locus where; - gfc_expr *e; - gfc_st_label *label; - match m; - - where = gfc_current_locus; - - if (gfc_match_char ('*') == MATCH_YES) - { - if (dt->format_expr != NULL || dt->format_label != NULL) - goto conflict; - - dt->format_label = &format_asterisk; - return MATCH_YES; - } - - if ((m = gfc_match_st_label (&label)) == MATCH_YES) - { - char c; - - /* Need to check if the format label is actually either an operand - to a user-defined operator or is a kind type parameter. That is, - print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER. - print 1_'(I0)', i ! 1_'(I0)' is a default character string. */ - - gfc_gobble_whitespace (); - c = gfc_peek_ascii_char (); - if (c == '.' || c == '_') - gfc_current_locus = where; - else - { - if (dt->format_expr != NULL || dt->format_label != NULL) - { - gfc_free_st_label (label); - goto conflict; - } - - if (!gfc_reference_st_label (label, ST_LABEL_FORMAT)) - return MATCH_ERROR; - - dt->format_label = label; - return MATCH_YES; - } - } - else if (m == MATCH_ERROR) - /* The label was zero or too large. Emit the correct diagnosis. */ - return MATCH_ERROR; - - if (gfc_match_expr (&e) == MATCH_YES) - { - if (dt->format_expr != NULL || dt->format_label != NULL) - { - gfc_free_expr (e); - goto conflict; - } - dt->format_expr = e; - return MATCH_YES; - } - - gfc_current_locus = where; /* The only case where we have to restore */ - - return MATCH_NO; - -conflict: - gfc_error ("Duplicate format specification at %C"); - return MATCH_ERROR; -} - -/* Check for formatted read and write DTIO procedures. */ - -static bool -dtio_procs_present (gfc_symbol *sym, io_kind k) -{ - gfc_symbol *derived; - - if (sym && sym->ts.u.derived) - { - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) - derived = CLASS_DATA (sym)->ts.u.derived; - else if (sym->ts.type == BT_DERIVED) - derived = sym->ts.u.derived; - else - return false; - if ((k == M_WRITE || k == M_PRINT) && - (gfc_find_specific_dtio_proc (derived, true, true) != NULL)) - return true; - if ((k == M_READ) && - (gfc_find_specific_dtio_proc (derived, false, true) != NULL)) - return true; - } - return false; -} - -/* Traverse a namelist that is part of a READ statement to make sure - that none of the variables in the namelist are INTENT(IN). Returns - nonzero if we find such a variable. */ - -static int -check_namelist (gfc_symbol *sym) -{ - gfc_namelist *p; - - for (p = sym->namelist; p; p = p->next) - if (p->sym->attr.intent == INTENT_IN) - { - gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C", - p->sym->name, sym->name); - return 1; - } - - return 0; -} - - -/* Match a single data transfer element. */ - -static match -match_dt_element (io_kind k, gfc_dt *dt) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - - if (gfc_match (" unit =") == MATCH_YES) - { - m = match_dt_unit (k, dt); - if (m != MATCH_NO) - return m; - } - - if (gfc_match (" fmt =") == MATCH_YES) - { - m = match_dt_format (dt); - if (m != MATCH_NO) - return m; - } - - if (gfc_match (" nml = %n", name) == MATCH_YES) - { - if (dt->namelist != NULL) - { - gfc_error ("Duplicate NML specification at %C"); - return MATCH_ERROR; - } - - if (gfc_find_symbol (name, NULL, 1, &sym)) - return MATCH_ERROR; - - if (sym == NULL || sym->attr.flavor != FL_NAMELIST) - { - gfc_error ("Symbol %qs at %C must be a NAMELIST group name", - sym != NULL ? sym->name : name); - return MATCH_ERROR; - } - - dt->namelist = sym; - if (k == M_READ && check_namelist (sym)) - return MATCH_ERROR; - - return MATCH_YES; - } - - m = match_etag (&tag_e_async, &dt->asynchronous); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_blank, &dt->blank); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_delim, &dt->delim); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_pad, &dt->pad); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_sign, &dt->sign); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_round, &dt->round); - if (m != MATCH_NO) - return m; - m = match_out_tag (&tag_id, &dt->id); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_e_decimal, &dt->decimal); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_rec, &dt->rec); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_spos, &dt->pos); - if (m != MATCH_NO) - return m; - m = match_etag (&tag_iomsg, &dt->iomsg); - if (m != MATCH_NO) - return m; - - m = match_out_tag (&tag_iostat, &dt->iostat); - if (m != MATCH_NO) - return m; - m = match_ltag (&tag_err, &dt->err); - if (m == MATCH_YES) - dt->err_where = gfc_current_locus; - if (m != MATCH_NO) - return m; - m = match_etag (&tag_advance, &dt->advance); - if (m != MATCH_NO) - return m; - m = match_out_tag (&tag_size, &dt->size); - if (m != MATCH_NO) - return m; - - m = match_ltag (&tag_end, &dt->end); - if (m == MATCH_YES) - { - if (k == M_WRITE) - { - gfc_error ("END tag at %C not allowed in output statement"); - return MATCH_ERROR; - } - dt->end_where = gfc_current_locus; - } - if (m != MATCH_NO) - return m; - - m = match_ltag (&tag_eor, &dt->eor); - if (m == MATCH_YES) - dt->eor_where = gfc_current_locus; - if (m != MATCH_NO) - return m; - - return MATCH_NO; -} - - -/* Free a data transfer structure and everything below it. */ - -void -gfc_free_dt (gfc_dt *dt) -{ - if (dt == NULL) - return; - - gfc_free_expr (dt->io_unit); - gfc_free_expr (dt->format_expr); - gfc_free_expr (dt->rec); - gfc_free_expr (dt->advance); - gfc_free_expr (dt->iomsg); - gfc_free_expr (dt->iostat); - gfc_free_expr (dt->size); - gfc_free_expr (dt->pad); - gfc_free_expr (dt->delim); - gfc_free_expr (dt->sign); - gfc_free_expr (dt->round); - gfc_free_expr (dt->blank); - gfc_free_expr (dt->decimal); - gfc_free_expr (dt->pos); - gfc_free_expr (dt->dt_io_kind); - /* dt->extra_comma is a link to dt_io_kind if it is set. */ - free (dt); -} - - -static const char * -io_kind_name (io_kind k); - -static bool -check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, - locus *spec_end); - -/* Resolve everything in a gfc_dt structure. */ - -bool -gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc) -{ - gfc_expr *e; - io_kind k; - - /* This is set in any case. */ - gcc_assert (dt->dt_io_kind); - k = dt->dt_io_kind->value.iokind; - - RESOLVE_TAG (&tag_format, dt->format_expr); - RESOLVE_TAG (&tag_rec, dt->rec); - RESOLVE_TAG (&tag_spos, dt->pos); - RESOLVE_TAG (&tag_advance, dt->advance); - RESOLVE_TAG (&tag_id, dt->id); - RESOLVE_TAG (&tag_iomsg, dt->iomsg); - RESOLVE_TAG (&tag_iostat, dt->iostat); - RESOLVE_TAG (&tag_size, dt->size); - RESOLVE_TAG (&tag_e_pad, dt->pad); - RESOLVE_TAG (&tag_e_delim, dt->delim); - RESOLVE_TAG (&tag_e_sign, dt->sign); - RESOLVE_TAG (&tag_e_round, dt->round); - RESOLVE_TAG (&tag_e_blank, dt->blank); - RESOLVE_TAG (&tag_e_decimal, dt->decimal); - RESOLVE_TAG (&tag_e_async, dt->asynchronous); - - /* Check I/O constraints. - To validate NAMELIST we need to check if we were also given an I/O list, - which is stored in code->block->next with op EXEC_TRANSFER. - Note that the I/O list was already resolved from resolve_transfer. */ - gfc_code *io_code = NULL; - if (dt_code && dt_code->block && dt_code->block->next - && dt_code->block->next->op == EXEC_TRANSFER) - io_code = dt_code->block->next; - - if (!check_io_constraints (k, dt, io_code, loc)) - return false; - - e = dt->io_unit; - if (e == NULL) - { - gfc_error ("UNIT not specified at %L", loc); - return false; - } - - if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER - && e->ts.type == BT_CHARACTER) - { - gfc_error ("UNIT specification at %L must " - "not be a character PARAMETER", &e->where); - return false; - } - - if (gfc_resolve_expr (e) - && (e->ts.type != BT_INTEGER - && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE))) - { - /* If there is no extra comma signifying the "format" form of the IO - statement, then this must be an error. */ - if (!dt->extra_comma) - { - gfc_error ("UNIT specification at %L must be an INTEGER expression " - "or a CHARACTER variable", &e->where); - return false; - } - else - { - /* At this point, we have an extra comma. If io_unit has arrived as - type character, we assume its really the "format" form of the I/O - statement. We set the io_unit to the default unit and format to - the character expression. See F95 Standard section 9.4. */ - if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) - { - dt->format_expr = dt->io_unit; - dt->io_unit = default_unit (k); - - /* Nullify this pointer now so that a warning/error is not - triggered below for the "Extension". */ - dt->extra_comma = NULL; - } - - if (k == M_WRITE) - { - gfc_error ("Invalid form of WRITE statement at %L, UNIT required", - &dt->extra_comma->where); - return false; - } - } - } - - if (e->ts.type == BT_CHARACTER) - { - if (gfc_has_vector_index (e)) - { - gfc_error ("Internal unit with vector subscript at %L", &e->where); - return false; - } - - /* If we are writing, make sure the internal unit can be changed. */ - gcc_assert (k != M_PRINT); - if (k == M_WRITE - && !gfc_check_vardef_context (e, false, false, false, - _("internal unit in WRITE"))) - return false; - } - - if (e->rank && e->ts.type != BT_CHARACTER) - { - gfc_error ("External IO UNIT cannot be an array at %L", &e->where); - return false; - } - - if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER - && mpz_sgn (e->value.integer) < 0) - { - gfc_error ("UNIT number in statement at %L must be non-negative", - &e->where); - return false; - } - - /* If we are reading and have a namelist, check that all namelist symbols - can appear in a variable definition context. */ - if (dt->namelist) - { - gfc_namelist* n; - for (n = dt->namelist->namelist; n; n = n->next) - { - gfc_expr* e; - bool t; - - if (k == M_READ) - { - e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); - t = gfc_check_vardef_context (e, false, false, false, NULL); - gfc_free_expr (e); - - if (!t) - { - gfc_error ("NAMELIST %qs in READ statement at %L contains" - " the symbol %qs which may not appear in a" - " variable definition context", - dt->namelist->name, loc, n->sym->name); - return false; - } - } - - t = dtio_procs_present (n->sym, k); - - if (n->sym->ts.type == BT_CLASS && !t) - { - gfc_error ("NAMELIST object %qs in namelist %qs at %L is " - "polymorphic and requires a defined input/output " - "procedure", n->sym->name, dt->namelist->name, loc); - return false; - } - - if ((n->sym->ts.type == BT_DERIVED) - && (n->sym->ts.u.derived->attr.alloc_comp - || n->sym->ts.u.derived->attr.pointer_comp)) - { - if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " - "namelist %qs at %L with ALLOCATABLE " - "or POINTER components", n->sym->name, - dt->namelist->name, loc)) - return false; - - if (!t) - { - gfc_error ("NAMELIST object %qs in namelist %qs at %L has " - "ALLOCATABLE or POINTER components and thus requires " - "a defined input/output procedure", n->sym->name, - dt->namelist->name, loc); - return false; - } - } - } - } - - if (dt->extra_comma - && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L", - &dt->extra_comma->where)) - return false; - - if (dt->err) - { - if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET)) - return false; - if (dt->err->defined == ST_LABEL_UNKNOWN) - { - gfc_error ("ERR tag label %d at %L not defined", - dt->err->value, &dt->err_where); - return false; - } - } - - if (dt->end) - { - if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET)) - return false; - if (dt->end->defined == ST_LABEL_UNKNOWN) - { - gfc_error ("END tag label %d at %L not defined", - dt->end->value, &dt->end_where); - return false; - } - } - - if (dt->eor) - { - if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET)) - return false; - if (dt->eor->defined == ST_LABEL_UNKNOWN) - { - gfc_error ("EOR tag label %d at %L not defined", - dt->eor->value, &dt->eor_where); - return false; - } - } - - /* Check the format label actually exists. */ - if (dt->format_label && dt->format_label != &format_asterisk - && dt->format_label->defined == ST_LABEL_UNKNOWN) - { - gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value, - loc); - return false; - } - - return true; -} - - -/* Given an io_kind, return its name. */ - -static const char * -io_kind_name (io_kind k) -{ - const char *name; - - switch (k) - { - case M_READ: - name = "READ"; - break; - case M_WRITE: - name = "WRITE"; - break; - case M_PRINT: - name = "PRINT"; - break; - case M_INQUIRE: - name = "INQUIRE"; - break; - default: - gfc_internal_error ("io_kind_name(): bad I/O-kind"); - } - - return name; -} - - -/* Match an IO iteration statement of the form: - - ( [ ,] , I = , [, ] ) - - which is equivalent to a single IO element. This function is - mutually recursive with match_io_element(). */ - -static match match_io_element (io_kind, gfc_code **); - -static match -match_io_iterator (io_kind k, gfc_code **result) -{ - gfc_code *head, *tail, *new_code; - gfc_iterator *iter; - locus old_loc; - match m; - int n; - - iter = NULL; - head = NULL; - old_loc = gfc_current_locus; - - if (gfc_match_char ('(') != MATCH_YES) - return MATCH_NO; - - m = match_io_element (k, &head); - tail = head; - - if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES) - { - m = MATCH_NO; - goto cleanup; - } - - /* Can't be anything but an IO iterator. Build a list. */ - iter = gfc_get_iterator (); - - for (n = 1;; n++) - { - m = gfc_match_iterator (iter, 0); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - gfc_check_do_variable (iter->var->symtree); - break; - } - - m = match_io_element (k, &new_code); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - if (n > 2) - goto syntax; - goto cleanup; - } - - tail = gfc_append_code (tail, new_code); - - if (gfc_match_char (',') != MATCH_YES) - { - if (n > 2) - goto syntax; - m = MATCH_NO; - goto cleanup; - } - } - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - new_code = gfc_get_code (EXEC_DO); - new_code->ext.iterator = iter; - - new_code->block = gfc_get_code (EXEC_DO); - new_code->block->next = head; - - *result = new_code; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in I/O iterator at %C"); - m = MATCH_ERROR; - -cleanup: - gfc_free_iterator (iter, 1); - gfc_free_statements (head); - gfc_current_locus = old_loc; - return m; -} - - -/* Match a single element of an IO list, which is either a single - expression or an IO Iterator. */ - -static match -match_io_element (io_kind k, gfc_code **cpp) -{ - gfc_expr *expr; - gfc_code *cp; - match m; - - expr = NULL; - - m = match_io_iterator (k, cpp); - if (m == MATCH_YES) - return MATCH_YES; - - if (k == M_READ) - { - m = gfc_match_variable (&expr, 0); - if (m == MATCH_NO) - { - gfc_error ("Expecting variable in READ statement at %C"); - m = MATCH_ERROR; - } - - if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT) - { - gfc_error ("Expecting variable or io-implied-do in READ statement " - "at %L", &expr->where); - m = MATCH_ERROR; - } - - if (m == MATCH_YES - && expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym->attr.external) - { - gfc_error ("Expecting variable or io-implied-do at %L", - &expr->where); - m = MATCH_ERROR; - } - } - else - { - m = gfc_match_expr (&expr); - if (m == MATCH_NO) - gfc_error ("Expected expression in %s statement at %C", - io_kind_name (k)); - - if (m == MATCH_YES && expr->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in" - " an output IO list"), &gfc_current_locus)) - return MATCH_ERROR; - if (!gfc_boz2int (expr, gfc_max_integer_kind)) - return MATCH_ERROR; - }; - } - - if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree)) - m = MATCH_ERROR; - - if (m != MATCH_YES) - { - gfc_free_expr (expr); - return MATCH_ERROR; - } - - cp = gfc_get_code (EXEC_TRANSFER); - cp->expr1 = expr; - if (k != M_INQUIRE) - cp->ext.dt = current_dt; - - *cpp = cp; - return MATCH_YES; -} - - -/* Match an I/O list, building gfc_code structures as we go. */ - -static match -match_io_list (io_kind k, gfc_code **head_p) -{ - gfc_code *head, *tail, *new_code; - match m; - - *head_p = head = tail = NULL; - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - - for (;;) - { - m = match_io_element (k, &new_code); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - tail = gfc_append_code (tail, new_code); - if (head == NULL) - head = new_code; - - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - *head_p = head; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); - -cleanup: - gfc_free_statements (head); - return MATCH_ERROR; -} - - -/* Attach the data transfer end node. */ - -static void -terminate_io (gfc_code *io_code) -{ - gfc_code *c; - - if (io_code == NULL) - io_code = new_st.block; - - c = gfc_get_code (EXEC_DT_END); - - /* Point to structure that is already there */ - c->ext.dt = new_st.ext.dt; - gfc_append_code (io_code, c); -} - - -/* Check the constraints for a data transfer statement. The majority of the - constraints appearing in 9.4 of the standard appear here. - - Tag expressions are already resolved by resolve_tag, which includes - verifying the type, that they are scalar, and verifying that BT_CHARACTER - tags are of default kind. */ - -static bool -check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, - locus *spec_end) -{ -#define io_constraint(condition, msg, arg)\ -if (condition) \ - {\ - if ((arg)->lb != NULL)\ - gfc_error ((msg), (arg));\ - else\ - gfc_error ((msg), spec_end);\ - return false;\ - } - - gfc_expr *expr; - gfc_symbol *sym = NULL; - bool warn, unformatted; - - warn = (dt->err || dt->iostat) ? true : false; - unformatted = dt->format_expr == NULL && dt->format_label == NULL - && dt->namelist == NULL; - - expr = dt->io_unit; - if (expr && expr->expr_type == EXPR_VARIABLE - && expr->ts.type == BT_CHARACTER) - { - sym = expr->symtree->n.sym; - - io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN, - "Internal file at %L must not be INTENT(IN)", - &expr->where); - - io_constraint (gfc_has_vector_index (dt->io_unit), - "Internal file incompatible with vector subscript at %L", - &expr->where); - - io_constraint (dt->rec != NULL, - "REC tag at %L is incompatible with internal file", - &dt->rec->where); - - io_constraint (dt->pos != NULL, - "POS tag at %L is incompatible with internal file", - &dt->pos->where); - - io_constraint (unformatted, - "Unformatted I/O not allowed with internal unit at %L", - &dt->io_unit->where); - - io_constraint (dt->asynchronous != NULL, - "ASYNCHRONOUS tag at %L not allowed with internal file", - &dt->asynchronous->where); - - if (dt->namelist != NULL) - { - if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " - "namelist", &expr->where)) - return false; - } - - io_constraint (dt->advance != NULL, - "ADVANCE tag at %L is incompatible with internal file", - &dt->advance->where); - } - - if (expr && expr->ts.type != BT_CHARACTER) - { - - if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE)) - { - gfc_error ("IO UNIT in %s statement at %L must be " - "an internal file in a PURE procedure", - io_kind_name (k), &expr->where); - return false; - } - - if (k == M_READ || k == M_WRITE) - gfc_unset_implicit_pure (NULL); - } - - if (dt->asynchronous) - { - int num = -1; - static const char * asynchronous[] = { "YES", "NO", NULL }; - - /* Note: gfc_reduce_init_expr reports an error if not init-expr. */ - if (!gfc_reduce_init_expr (dt->asynchronous)) - return false; - - if (!compare_to_allowed_values - ("ASYNCHRONOUS", asynchronous, NULL, NULL, - dt->asynchronous->value.character.string, - io_kind_name (k), warn, &dt->asynchronous->where, &num)) - return false; - - gcc_checking_assert (num != -1); - - /* For "YES", mark related symbols as asynchronous. */ - if (num == 0) - { - /* SIZE variable. */ - if (dt->size) - dt->size->symtree->n.sym->attr.asynchronous = 1; - - /* Variables in a NAMELIST. */ - if (dt->namelist) - for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next) - nl->sym->attr.asynchronous = 1; - - /* Variables in an I/O list. */ - for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER; - xfer = xfer->next) - { - gfc_expr *expr = xfer->expr1; - while (expr != NULL && expr->expr_type == EXPR_OP - && expr->value.op.op == INTRINSIC_PARENTHESES) - expr = expr->value.op.op1; - - if (expr && expr->expr_type == EXPR_VARIABLE) - expr->symtree->n.sym->attr.asynchronous = 1; - } - } - } - - if (dt->id) - { - bool not_yes - = !dt->asynchronous - || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 - || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, - "yes", 3) != 0; - io_constraint (not_yes, - "ID= specifier at %L must be with ASYNCHRONOUS='yes' " - "specifier", &dt->id->where); - } - - if (dt->decimal) - { - if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " - "not allowed in Fortran 95", &dt->decimal->where)) - return false; - - if (dt->decimal->expr_type == EXPR_CONSTANT) - { - static const char * decimal[] = { "COMMA", "POINT", NULL }; - - if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, - dt->decimal->value.character.string, - io_kind_name (k), warn, - &dt->decimal->where)) - return false; - - io_constraint (unformatted, - "the DECIMAL= specifier at %L must be with an " - "explicit format expression", &dt->decimal->where); - } - } - - if (dt->blank) - { - if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " - "not allowed in Fortran 95", &dt->blank->where)) - return false; - - if (dt->blank->expr_type == EXPR_CONSTANT) - { - static const char * blank[] = { "NULL", "ZERO", NULL }; - - - if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, - dt->blank->value.character.string, - io_kind_name (k), warn, - &dt->blank->where)) - return false; - - io_constraint (unformatted, - "the BLANK= specifier at %L must be with an " - "explicit format expression", &dt->blank->where); - } - } - - if (dt->pad) - { - if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L " - "not allowed in Fortran 95", &dt->pad->where)) - return false; - - if (dt->pad->expr_type == EXPR_CONSTANT) - { - static const char * pad[] = { "YES", "NO", NULL }; - - if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, - dt->pad->value.character.string, - io_kind_name (k), warn, - &dt->pad->where)) - return false; - - io_constraint (unformatted, - "the PAD= specifier at %L must be with an " - "explicit format expression", &dt->pad->where); - } - } - - if (dt->round) - { - if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " - "not allowed in Fortran 95", &dt->round->where)) - return false; - - if (dt->round->expr_type == EXPR_CONSTANT) - { - static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", - "COMPATIBLE", "PROCESSOR_DEFINED", - NULL }; - - if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, - dt->round->value.character.string, - io_kind_name (k), warn, - &dt->round->where)) - return false; - } - } - - if (dt->sign) - { - /* When implemented, change the following to use gfc_notify_std F2003. - if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " - "not allowed in Fortran 95", &dt->sign->where) == false) - return false; */ - - if (dt->sign->expr_type == EXPR_CONSTANT) - { - static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", - NULL }; - - if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, - dt->sign->value.character.string, - io_kind_name (k), warn, &dt->sign->where)) - return false; - - io_constraint (unformatted, - "SIGN= specifier at %L must be with an " - "explicit format expression", &dt->sign->where); - - io_constraint (k == M_READ, - "SIGN= specifier at %L not allowed in a " - "READ statement", &dt->sign->where); - } - } - - if (dt->delim) - { - if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L " - "not allowed in Fortran 95", &dt->delim->where)) - return false; - - if (dt->delim->expr_type == EXPR_CONSTANT) - { - static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; - - if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, - dt->delim->value.character.string, - io_kind_name (k), warn, - &dt->delim->where)) - return false; - - io_constraint (k == M_READ, - "DELIM= specifier at %L not allowed in a " - "READ statement", &dt->delim->where); - - io_constraint (dt->format_label != &format_asterisk - && dt->namelist == NULL, - "DELIM= specifier at %L must have FMT=*", - &dt->delim->where); - - io_constraint (unformatted && dt->namelist == NULL, - "DELIM= specifier at %L must be with FMT=* or " - "NML= specifier", &dt->delim->where); - } - } - - if (dt->namelist) - { - io_constraint (io_code && dt->namelist, - "NAMELIST cannot be followed by IO-list at %L", - &io_code->loc); - - io_constraint (dt->format_expr, - "IO spec-list cannot contain both NAMELIST group name " - "and format specification at %L", - &dt->format_expr->where); - - io_constraint (dt->format_label, - "IO spec-list cannot contain both NAMELIST group name " - "and format label at %L", spec_end); - - io_constraint (dt->rec, - "NAMELIST IO is not allowed with a REC= specifier " - "at %L", &dt->rec->where); - - io_constraint (dt->advance, - "NAMELIST IO is not allowed with a ADVANCE= specifier " - "at %L", &dt->advance->where); - } - - if (dt->rec) - { - io_constraint (dt->end, - "An END tag is not allowed with a " - "REC= specifier at %L", &dt->end_where); - - io_constraint (dt->format_label == &format_asterisk, - "FMT=* is not allowed with a REC= specifier " - "at %L", spec_end); - - io_constraint (dt->pos, - "POS= is not allowed with REC= specifier " - "at %L", &dt->pos->where); - } - - if (dt->advance) - { - int not_yes, not_no; - expr = dt->advance; - - io_constraint (dt->format_label == &format_asterisk, - "List directed format(*) is not allowed with a " - "ADVANCE= specifier at %L.", &expr->where); - - io_constraint (unformatted, - "the ADVANCE= specifier at %L must appear with an " - "explicit format expression", &expr->where); - - if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) - { - const gfc_char_t *advance = expr->value.character.string; - not_no = gfc_wide_strlen (advance) != 2 - || gfc_wide_strncasecmp (advance, "no", 2) != 0; - not_yes = gfc_wide_strlen (advance) != 3 - || gfc_wide_strncasecmp (advance, "yes", 3) != 0; - } - else - { - not_no = 0; - not_yes = 0; - } - - io_constraint (not_no && not_yes, - "ADVANCE= specifier at %L must have value = " - "YES or NO.", &expr->where); - - io_constraint (dt->size && not_no && k == M_READ, - "SIZE tag at %L requires an ADVANCE = %", - &dt->size->where); - - io_constraint (dt->eor && not_no && k == M_READ, - "EOR tag at %L requires an ADVANCE = %", - &dt->eor_where); - } - - if (k != M_READ) - { - io_constraint (dt->end, "END tag not allowed with output at %L", - &dt->end_where); - - io_constraint (dt->eor, "EOR tag not allowed with output at %L", - &dt->eor_where); - - io_constraint (dt->blank, - "BLANK= specifier not allowed with output at %L", - &dt->blank->where); - - io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", - &dt->pad->where); - - io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", - &dt->size->where); - } - else - { - io_constraint (dt->size && dt->advance == NULL, - "SIZE tag at %L requires an ADVANCE tag", - &dt->size->where); - - io_constraint (dt->eor && dt->advance == NULL, - "EOR tag at %L requires an ADVANCE tag", - &dt->eor_where); - } - - return true; -#undef io_constraint -} - - -/* Match a READ, WRITE or PRINT statement. */ - -static match -match_io (io_kind k) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_code *io_code; - gfc_symbol *sym; - int comma_flag; - locus where; - locus control; - gfc_dt *dt; - match m; - - where = gfc_current_locus; - comma_flag = 0; - current_dt = dt = XCNEW (gfc_dt); - m = gfc_match_char ('('); - if (m == MATCH_NO) - { - where = gfc_current_locus; - if (k == M_WRITE) - goto syntax; - else if (k == M_PRINT) - { - /* Treat the non-standard case of PRINT namelist. */ - if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') - && gfc_match_name (name) == MATCH_YES) - { - gfc_find_symbol (name, NULL, 1, &sym); - if (sym && sym->attr.flavor == FL_NAMELIST) - { - if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at " - "%C is an extension")) - { - m = MATCH_ERROR; - goto cleanup; - } - - dt->io_unit = default_unit (k); - dt->namelist = sym; - goto get_io_list; - } - else - gfc_current_locus = where; - } - - if (gfc_match_char ('*') == MATCH_YES - && gfc_match_char(',') == MATCH_YES) - { - locus where2 = gfc_current_locus; - if (gfc_match_eos () == MATCH_YES) - { - gfc_current_locus = where2; - gfc_error ("Comma after * at %C not allowed without I/O list"); - m = MATCH_ERROR; - goto cleanup; - } - else - gfc_current_locus = where; - } - else - gfc_current_locus = where; - } - - if (gfc_current_form == FORM_FREE) - { - char c = gfc_peek_ascii_char (); - if (c != ' ' && c != '*' && c != '\'' && c != '"') - { - m = MATCH_NO; - goto cleanup; - } - } - - m = match_dt_format (dt); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - comma_flag = 1; - dt->io_unit = default_unit (k); - goto get_io_list; - } - else - { - /* Before issuing an error for a malformed 'print (1,*)' type of - error, check for a default-char-expr of the form ('(I0)'). */ - if (m == MATCH_YES) - { - control = gfc_current_locus; - if (k == M_PRINT) - { - /* Reset current locus to get the initial '(' in an expression. */ - gfc_current_locus = where; - dt->format_expr = NULL; - m = match_dt_format (dt); - - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO || dt->format_expr == NULL) - goto syntax; - - comma_flag = 1; - dt->io_unit = default_unit (k); - goto get_io_list; - } - if (k == M_READ) - { - /* Commit any pending symbols now so that when we undo - symbols later we wont lose them. */ - gfc_commit_symbols (); - /* Reset current locus to get the initial '(' in an expression. */ - gfc_current_locus = where; - dt->format_expr = NULL; - m = gfc_match_expr (&dt->format_expr); - if (m == MATCH_YES) - { - if (dt->format_expr - && dt->format_expr->ts.type == BT_CHARACTER) - { - comma_flag = 1; - dt->io_unit = default_unit (k); - goto get_io_list; - } - else - { - gfc_free_expr (dt->format_expr); - dt->format_expr = NULL; - gfc_current_locus = control; - } - } - else - { - gfc_clear_error (); - gfc_undo_symbols (); - gfc_free_expr (dt->format_expr); - dt->format_expr = NULL; - gfc_current_locus = control; - } - } - } - } - - /* Match a control list */ - if (match_dt_element (k, dt) == MATCH_YES) - goto next; - if (match_dt_unit (k, dt) != MATCH_YES) - goto loop; - - if (gfc_match_char (')') == MATCH_YES) - goto get_io_list; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = match_dt_element (k, dt); - if (m == MATCH_YES) - goto next; - if (m == MATCH_ERROR) - goto cleanup; - - m = match_dt_format (dt); - if (m == MATCH_YES) - goto next; - if (m == MATCH_ERROR) - goto cleanup; - - where = gfc_current_locus; - - m = gfc_match_name (name); - if (m == MATCH_YES) - { - gfc_find_symbol (name, NULL, 1, &sym); - if (sym && sym->attr.flavor == FL_NAMELIST) - { - dt->namelist = sym; - if (k == M_READ && check_namelist (sym)) - { - m = MATCH_ERROR; - goto cleanup; - } - goto next; - } - } - - gfc_current_locus = where; - - goto loop; /* No matches, try regular elements */ - -next: - if (gfc_match_char (')') == MATCH_YES) - goto get_io_list; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - -loop: - for (;;) - { - m = match_dt_element (k, dt); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - -get_io_list: - - /* Save the IO kind for later use. */ - dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); - - /* Optional leading comma (non-standard). We use a gfc_expr structure here - to save the locus. This is used later when resolving transfer statements - that might have a format expression without unit number. */ - if (!comma_flag && gfc_match_char (',') == MATCH_YES) - dt->extra_comma = dt->dt_io_kind; - - io_code = NULL; - if (gfc_match_eos () != MATCH_YES) - { - if (comma_flag && gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expected comma in I/O list at %C"); - m = MATCH_ERROR; - goto cleanup; - } - - m = match_io_list (k, &io_code); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - /* See if we want to use defaults for missing exponents in real transfers - and other DEC runtime extensions. */ - if (flag_dec_format_defaults) - dt->dec_ext = 1; - - /* Check the format string now. */ - if (dt->format_expr - && (!gfc_simplify_expr (dt->format_expr, 0) - || !check_format_string (dt->format_expr, k == M_READ))) - return MATCH_ERROR; - - new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; - new_st.ext.dt = dt; - new_st.block = gfc_get_code (new_st.op); - new_st.block->next = io_code; - - terminate_io (io_code); - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); - m = MATCH_ERROR; - -cleanup: - gfc_free_dt (dt); - return m; -} - - -match -gfc_match_read (void) -{ - return match_io (M_READ); -} - - -match -gfc_match_write (void) -{ - return match_io (M_WRITE); -} - - -match -gfc_match_print (void) -{ - match m; - - m = match_io (M_PRINT); - if (m != MATCH_YES) - return m; - - if (gfc_pure (NULL)) - { - gfc_error ("PRINT statement at %C not allowed within PURE procedure"); - return MATCH_ERROR; - } - - gfc_unset_implicit_pure (NULL); - - return MATCH_YES; -} - - -/* Free a gfc_inquire structure. */ - -void -gfc_free_inquire (gfc_inquire *inquire) -{ - - if (inquire == NULL) - return; - - gfc_free_expr (inquire->unit); - gfc_free_expr (inquire->file); - gfc_free_expr (inquire->iomsg); - gfc_free_expr (inquire->iostat); - gfc_free_expr (inquire->exist); - gfc_free_expr (inquire->opened); - gfc_free_expr (inquire->number); - gfc_free_expr (inquire->named); - gfc_free_expr (inquire->name); - gfc_free_expr (inquire->access); - gfc_free_expr (inquire->sequential); - gfc_free_expr (inquire->direct); - gfc_free_expr (inquire->form); - gfc_free_expr (inquire->formatted); - gfc_free_expr (inquire->unformatted); - gfc_free_expr (inquire->recl); - gfc_free_expr (inquire->nextrec); - gfc_free_expr (inquire->blank); - gfc_free_expr (inquire->position); - gfc_free_expr (inquire->action); - gfc_free_expr (inquire->read); - gfc_free_expr (inquire->write); - gfc_free_expr (inquire->readwrite); - gfc_free_expr (inquire->delim); - gfc_free_expr (inquire->encoding); - gfc_free_expr (inquire->pad); - gfc_free_expr (inquire->iolength); - gfc_free_expr (inquire->convert); - gfc_free_expr (inquire->strm_pos); - gfc_free_expr (inquire->asynchronous); - gfc_free_expr (inquire->decimal); - gfc_free_expr (inquire->pending); - gfc_free_expr (inquire->id); - gfc_free_expr (inquire->sign); - gfc_free_expr (inquire->size); - gfc_free_expr (inquire->round); - gfc_free_expr (inquire->share); - gfc_free_expr (inquire->cc); - free (inquire); -} - - -/* Match an element of an INQUIRE statement. */ - -#define RETM if (m != MATCH_NO) return m; - -static match -match_inquire_element (gfc_inquire *inquire) -{ - match m; - - m = match_etag (&tag_unit, &inquire->unit); - RETM m = match_etag (&tag_file, &inquire->file); - RETM m = match_ltag (&tag_err, &inquire->err); - RETM m = match_etag (&tag_iomsg, &inquire->iomsg); - RETM m = match_out_tag (&tag_iostat, &inquire->iostat); - RETM m = match_vtag (&tag_exist, &inquire->exist); - RETM m = match_vtag (&tag_opened, &inquire->opened); - RETM m = match_vtag (&tag_named, &inquire->named); - RETM m = match_vtag (&tag_name, &inquire->name); - RETM m = match_out_tag (&tag_number, &inquire->number); - RETM m = match_vtag (&tag_s_access, &inquire->access); - RETM m = match_vtag (&tag_sequential, &inquire->sequential); - RETM m = match_vtag (&tag_direct, &inquire->direct); - RETM m = match_vtag (&tag_s_form, &inquire->form); - RETM m = match_vtag (&tag_formatted, &inquire->formatted); - RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); - RETM m = match_out_tag (&tag_s_recl, &inquire->recl); - RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec); - RETM m = match_vtag (&tag_s_blank, &inquire->blank); - RETM m = match_vtag (&tag_s_position, &inquire->position); - RETM m = match_vtag (&tag_s_action, &inquire->action); - RETM m = match_vtag (&tag_read, &inquire->read); - RETM m = match_vtag (&tag_write, &inquire->write); - RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); - RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); - RETM m = match_vtag (&tag_s_delim, &inquire->delim); - RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); - RETM m = match_out_tag (&tag_size, &inquire->size); - RETM m = match_vtag (&tag_s_encoding, &inquire->encoding); - RETM m = match_vtag (&tag_s_round, &inquire->round); - RETM m = match_vtag (&tag_s_sign, &inquire->sign); - RETM m = match_vtag (&tag_s_pad, &inquire->pad); - RETM m = match_out_tag (&tag_iolength, &inquire->iolength); - RETM m = match_vtag (&tag_convert, &inquire->convert); - RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos); - RETM m = match_vtag (&tag_pending, &inquire->pending); - RETM m = match_vtag (&tag_id, &inquire->id); - RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream); - RETM m = match_dec_vtag (&tag_v_share, &inquire->share); - RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc); - RETM return MATCH_NO; -} - -#undef RETM - - -match -gfc_match_inquire (void) -{ - gfc_inquire *inquire; - gfc_code *code; - match m; - locus loc; - - m = gfc_match_char ('('); - if (m == MATCH_NO) - return m; - - inquire = XCNEW (gfc_inquire); - - loc = gfc_current_locus; - - m = match_inquire_element (inquire); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_expr (&inquire->unit); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - /* See if we have the IOLENGTH form of the inquire statement. */ - if (inquire->iolength != NULL) - { - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - m = match_io_list (M_INQUIRE, &code); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - for (gfc_code *c = code; c; c = c->next) - if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION - && c->expr1->symtree && c->expr1->symtree->n.sym->attr.function - && !c->expr1->symtree->n.sym->attr.external - && strcmp (c->expr1->symtree->name, "null") == 0) - { - gfc_error ("NULL() near %L cannot appear in INQUIRE statement", - &c->expr1->where); - goto cleanup; - } - - new_st.op = EXEC_IOLENGTH; - new_st.expr1 = inquire->iolength; - new_st.ext.inquire = inquire; - - if (gfc_pure (NULL)) - { - gfc_free_statements (code); - gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); - return MATCH_ERROR; - } - - gfc_unset_implicit_pure (NULL); - - new_st.block = gfc_get_code (EXEC_IOLENGTH); - terminate_io (code); - new_st.block->next = code; - return MATCH_YES; - } - - /* At this point, we have the non-IOLENGTH inquire statement. */ - for (;;) - { - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = match_inquire_element (inquire); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (inquire->iolength != NULL) - { - gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C"); - goto cleanup; - } - } - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - - if (inquire->unit != NULL && inquire->file != NULL) - { - gfc_error ("INQUIRE statement at %L cannot contain both FILE and " - "UNIT specifiers", &loc); - goto cleanup; - } - - if (inquire->unit == NULL && inquire->file == NULL) - { - gfc_error ("INQUIRE statement at %L requires either FILE or " - "UNIT specifier", &loc); - goto cleanup; - } - - if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT - && inquire->unit->ts.type == BT_INTEGER - && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4) - || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT))) - { - gfc_error ("UNIT number in INQUIRE statement at %L cannot " - "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer)); - goto cleanup; - } - - if (gfc_pure (NULL)) - { - gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); - goto cleanup; - } - - gfc_unset_implicit_pure (NULL); - - if (inquire->id != NULL && inquire->pending == NULL) - { - gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with " - "the ID= specifier", &loc); - goto cleanup; - } - - new_st.op = EXEC_INQUIRE; - new_st.ext.inquire = inquire; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_INQUIRE); - -cleanup: - gfc_free_inquire (inquire); - return MATCH_ERROR; -} - - -/* Resolve everything in a gfc_inquire structure. */ - -bool -gfc_resolve_inquire (gfc_inquire *inquire) -{ - RESOLVE_TAG (&tag_unit, inquire->unit); - RESOLVE_TAG (&tag_file, inquire->file); - RESOLVE_TAG (&tag_id, inquire->id); - - /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition - contexts. Thus, use an extended RESOLVE_TAG macro for that. */ -#define INQUIRE_RESOLVE_TAG(tag, expr) \ - RESOLVE_TAG (tag, expr); \ - if (expr) \ - { \ - char context[64]; \ - sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \ - if (gfc_check_vardef_context ((expr), false, false, false, \ - context) == false) \ - return false; \ - } - INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg); - INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat); - INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist); - INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened); - INQUIRE_RESOLVE_TAG (&tag_number, inquire->number); - INQUIRE_RESOLVE_TAG (&tag_named, inquire->named); - INQUIRE_RESOLVE_TAG (&tag_name, inquire->name); - INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access); - INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential); - INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct); - INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form); - INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted); - INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted); - INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl); - INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec); - INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank); - INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position); - INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action); - INQUIRE_RESOLVE_TAG (&tag_read, inquire->read); - INQUIRE_RESOLVE_TAG (&tag_write, inquire->write); - INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite); - INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim); - INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad); - INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding); - INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); - INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength); - INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert); - INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); - INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous); - INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign); - INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); - INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending); - INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); - INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal); - INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream); - INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share); - INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc); -#undef INQUIRE_RESOLVE_TAG - - if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET)) - return false; - - return true; -} - - -void -gfc_free_wait (gfc_wait *wait) -{ - if (wait == NULL) - return; - - gfc_free_expr (wait->unit); - gfc_free_expr (wait->iostat); - gfc_free_expr (wait->iomsg); - gfc_free_expr (wait->id); - free (wait); -} - - -bool -gfc_resolve_wait (gfc_wait *wait) -{ - RESOLVE_TAG (&tag_unit, wait->unit); - RESOLVE_TAG (&tag_iomsg, wait->iomsg); - RESOLVE_TAG (&tag_iostat, wait->iostat); - RESOLVE_TAG (&tag_id, wait->id); - - if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET)) - return false; - - if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET)) - return false; - - return true; -} - -/* Match an element of a WAIT statement. */ - -#define RETM if (m != MATCH_NO) return m; - -static match -match_wait_element (gfc_wait *wait) -{ - match m; - - m = match_etag (&tag_unit, &wait->unit); - RETM m = match_ltag (&tag_err, &wait->err); - RETM m = match_ltag (&tag_end, &wait->end); - RETM m = match_ltag (&tag_eor, &wait->eor); - RETM m = match_etag (&tag_iomsg, &wait->iomsg); - RETM m = match_out_tag (&tag_iostat, &wait->iostat); - RETM m = match_etag (&tag_id, &wait->id); - RETM return MATCH_NO; -} - -#undef RETM - - -match -gfc_match_wait (void) -{ - gfc_wait *wait; - match m; - - m = gfc_match_char ('('); - if (m == MATCH_NO) - return m; - - wait = XCNEW (gfc_wait); - - m = match_wait_element (wait); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_expr (&wait->unit); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - for (;;) - { - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = match_wait_element (wait); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C " - "not allowed in Fortran 95")) - goto cleanup; - - if (gfc_pure (NULL)) - { - gfc_error ("WAIT statement not allowed in PURE procedure at %C"); - goto cleanup; - } - - gfc_unset_implicit_pure (NULL); - - new_st.op = EXEC_WAIT; - new_st.ext.wait = wait; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_WAIT); - -cleanup: - gfc_free_wait (wait); - return MATCH_ERROR; -} diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc new file mode 100644 index 0000000..902aa19 --- /dev/null +++ b/gcc/fortran/io.cc @@ -0,0 +1,4899 @@ +/* Deal with I/O statements & related stuff. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "match.h" +#include "parse.h" +#include "constructor.h" + +gfc_st_label +format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, + 0, {NULL, NULL}, NULL}; + +typedef struct +{ + const char *name, *spec, *value; + bt type; +} +io_tag; + +static const io_tag + tag_readonly = {"READONLY", " readonly", NULL, BT_UNKNOWN }, + tag_shared = {"SHARE", " shared", NULL, BT_UNKNOWN }, + tag_noshared = {"SHARE", " noshared", NULL, BT_UNKNOWN }, + tag_e_share = {"SHARE", " share =", " %e", BT_CHARACTER }, + tag_v_share = {"SHARE", " share =", " %v", BT_CHARACTER }, + tag_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %e", + BT_CHARACTER }, + tag_v_cc = {"CARRIAGECONTROL", " carriagecontrol =", " %v", + BT_CHARACTER }, + tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, + tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, + tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, + tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER}, + tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER}, + tag_e_blank = {"BLANK", " blank =", " %e", BT_CHARACTER}, + tag_e_position = {"POSITION", " position =", " %e", BT_CHARACTER}, + tag_e_action = {"ACTION", " action =", " %e", BT_CHARACTER}, + tag_e_delim = {"DELIM", " delim =", " %e", BT_CHARACTER}, + tag_e_pad = {"PAD", " pad =", " %e", BT_CHARACTER}, + tag_e_decimal = {"DECIMAL", " decimal =", " %e", BT_CHARACTER}, + tag_e_encoding = {"ENCODING", " encoding =", " %e", BT_CHARACTER}, + tag_e_async = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER}, + tag_e_round = {"ROUND", " round =", " %e", BT_CHARACTER}, + tag_e_sign = {"SIGN", " sign =", " %e", BT_CHARACTER}, + tag_unit = {"UNIT", " unit =", " %e", BT_INTEGER}, + tag_advance = {"ADVANCE", " advance =", " %e", BT_CHARACTER}, + tag_rec = {"REC", " rec =", " %e", BT_INTEGER}, + tag_spos = {"POSITION", " pos =", " %e", BT_INTEGER}, + tag_format = {"FORMAT", NULL, NULL, BT_CHARACTER}, + tag_iomsg = {"IOMSG", " iomsg =", " %e", BT_CHARACTER}, + tag_iostat = {"IOSTAT", " iostat =", " %v", BT_INTEGER}, + tag_size = {"SIZE", " size =", " %v", BT_INTEGER}, + tag_exist = {"EXIST", " exist =", " %v", BT_LOGICAL}, + tag_opened = {"OPENED", " opened =", " %v", BT_LOGICAL}, + tag_named = {"NAMED", " named =", " %v", BT_LOGICAL}, + tag_name = {"NAME", " name =", " %v", BT_CHARACTER}, + tag_number = {"NUMBER", " number =", " %v", BT_INTEGER}, + tag_s_access = {"ACCESS", " access =", " %v", BT_CHARACTER}, + tag_sequential = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER}, + tag_direct = {"DIRECT", " direct =", " %v", BT_CHARACTER}, + tag_s_form = {"FORM", " form =", " %v", BT_CHARACTER}, + tag_formatted = {"FORMATTED", " formatted =", " %v", BT_CHARACTER}, + tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER}, + tag_s_recl = {"RECL", " recl =", " %v", BT_INTEGER}, + tag_nextrec = {"NEXTREC", " nextrec =", " %v", BT_INTEGER}, + tag_s_blank = {"BLANK", " blank =", " %v", BT_CHARACTER}, + tag_s_position = {"POSITION", " position =", " %v", BT_CHARACTER}, + tag_s_action = {"ACTION", " action =", " %v", BT_CHARACTER}, + tag_read = {"READ", " read =", " %v", BT_CHARACTER}, + tag_write = {"WRITE", " write =", " %v", BT_CHARACTER}, + tag_readwrite = {"READWRITE", " readwrite =", " %v", BT_CHARACTER}, + tag_s_delim = {"DELIM", " delim =", " %v", BT_CHARACTER}, + tag_s_pad = {"PAD", " pad =", " %v", BT_CHARACTER}, + tag_s_decimal = {"DECIMAL", " decimal =", " %v", BT_CHARACTER}, + tag_s_encoding = {"ENCODING", " encoding =", " %v", BT_CHARACTER}, + tag_s_async = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER}, + tag_s_round = {"ROUND", " round =", " %v", BT_CHARACTER}, + tag_s_sign = {"SIGN", " sign =", " %v", BT_CHARACTER}, + tag_iolength = {"IOLENGTH", " iolength =", " %v", BT_INTEGER}, + tag_convert = {"CONVERT", " convert =", " %e", BT_CHARACTER}, + tag_strm_out = {"POS", " pos =", " %v", BT_INTEGER}, + tag_err = {"ERR", " err =", " %l", BT_UNKNOWN}, + tag_end = {"END", " end =", " %l", BT_UNKNOWN}, + tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN}, + tag_id = {"ID", " id =", " %v", BT_INTEGER}, + tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}, + tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER}, + tag_s_iqstream = {"STREAM", " stream =", " %v", BT_CHARACTER}; + +static gfc_dt *current_dt; + +#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false; + +/**************** Fortran 95 FORMAT parser *****************/ + +/* FORMAT tokens returned by format_lex(). */ +enum format_token +{ + FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, + FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, + FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, + FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, + FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC, + FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT +}; + +/* Local variables for checking format strings. The saved_token is + used to back up by a single format token during the parsing + process. */ +static gfc_char_t *format_string; +static int format_string_pos; +static int format_length, use_last_char; +static char error_element; +static locus format_locus; + +static format_token saved_token; + +static enum +{ MODE_STRING, MODE_FORMAT, MODE_COPY } +mode; + + +/* Return the next character in the format string. */ + +static char +next_char (gfc_instring in_string) +{ + static gfc_char_t c; + + if (use_last_char) + { + use_last_char = 0; + return c; + } + + format_length++; + + if (mode == MODE_STRING) + c = *format_string++; + else + { + c = gfc_next_char_literal (in_string); + if (c == '\n') + c = '\0'; + } + + if (flag_backslash && c == '\\') + { + locus old_locus = gfc_current_locus; + + if (gfc_match_special_char (&c) == MATCH_NO) + gfc_current_locus = old_locus; + + if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) + gfc_warning (0, "Extension: backslash character at %C"); + } + + if (mode == MODE_COPY) + *format_string++ = c; + + if (mode != MODE_STRING) + format_locus = gfc_current_locus; + + format_string_pos++; + + c = gfc_wide_toupper (c); + return c; +} + + +/* Back up one character position. Only works once. */ + +static void +unget_char (void) +{ + use_last_char = 1; +} + +/* Eat up the spaces and return a character. */ + +static char +next_char_not_space () +{ + char c; + do + { + error_element = c = next_char (NONSTRING); + if (c == '\t') + gfc_warning (OPT_Wtabs, "Nonconforming tab character in format at %C"); + } + while (gfc_is_whitespace (c)); + return c; +} + +static int value = 0; + +/* Simple lexical analyzer for getting the next token in a FORMAT + statement. */ + +static format_token +format_lex (void) +{ + format_token token; + char c, delim; + int zflag; + int negative_flag; + + if (saved_token != FMT_NONE) + { + token = saved_token; + saved_token = FMT_NONE; + return token; + } + + c = next_char_not_space (); + + negative_flag = 0; + switch (c) + { + case '-': + negative_flag = 1; + /* Falls through. */ + + case '+': + c = next_char_not_space (); + if (!ISDIGIT (c)) + { + token = FMT_UNKNOWN; + break; + } + + value = c - '0'; + + do + { + c = next_char_not_space (); + if (ISDIGIT (c)) + value = 10 * value + c - '0'; + } + while (ISDIGIT (c)); + + unget_char (); + + if (negative_flag) + value = -value; + + token = FMT_SIGNED_INT; + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + zflag = (c == '0'); + + value = c - '0'; + + do + { + c = next_char_not_space (); + if (ISDIGIT (c)) + { + value = 10 * value + c - '0'; + if (c != '0') + zflag = 0; + } + } + while (ISDIGIT (c)); + + unget_char (); + token = zflag ? FMT_ZERO : FMT_POSINT; + break; + + case '.': + token = FMT_PERIOD; + break; + + case ',': + token = FMT_COMMA; + break; + + case ':': + token = FMT_COLON; + break; + + case '/': + token = FMT_SLASH; + break; + + case '$': + token = FMT_DOLLAR; + break; + + case 'T': + c = next_char_not_space (); + switch (c) + { + case 'L': + token = FMT_TL; + break; + case 'R': + token = FMT_TR; + break; + default: + token = FMT_T; + unget_char (); + } + break; + + case '(': + token = FMT_LPAREN; + break; + + case ')': + token = FMT_RPAREN; + break; + + case 'X': + token = FMT_X; + break; + + case 'S': + c = next_char_not_space (); + if (c != 'P' && c != 'S') + unget_char (); + + token = FMT_SIGN; + break; + + case 'B': + c = next_char_not_space (); + if (c == 'N' || c == 'Z') + token = FMT_BLANK; + else + { + unget_char (); + token = FMT_IBOZ; + } + + break; + + case '\'': + case '"': + delim = c; + + value = 0; + + for (;;) + { + c = next_char (INSTRING_WARN); + if (c == '\0') + { + token = FMT_END; + break; + } + + if (c == delim) + { + c = next_char (NONSTRING); + + if (c == '\0') + { + token = FMT_END; + break; + } + + if (c != delim) + { + unget_char (); + token = FMT_CHAR; + break; + } + } + value++; + } + break; + + case 'P': + token = FMT_P; + break; + + case 'I': + case 'O': + case 'Z': + token = FMT_IBOZ; + break; + + case 'F': + token = FMT_F; + break; + + case 'E': + c = next_char_not_space (); + if (c == 'N' ) + token = FMT_EN; + else if (c == 'S') + token = FMT_ES; + else + { + token = FMT_E; + unget_char (); + } + + break; + + case 'G': + token = FMT_G; + break; + + case 'H': + token = FMT_H; + break; + + case 'L': + token = FMT_L; + break; + + case 'A': + token = FMT_A; + break; + + case 'D': + c = next_char_not_space (); + if (c == 'P') + { + if (!gfc_notify_std (GFC_STD_F2003, "DP format " + "specifier not allowed at %C")) + return FMT_ERROR; + token = FMT_DP; + } + else if (c == 'C') + { + if (!gfc_notify_std (GFC_STD_F2003, "DC format " + "specifier not allowed at %C")) + return FMT_ERROR; + token = FMT_DC; + } + else if (c == 'T') + { + if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format " + "specifier not allowed at %C")) + return FMT_ERROR; + token = FMT_DT; + c = next_char_not_space (); + if (c == '\'' || c == '"') + { + delim = c; + value = 0; + + for (;;) + { + c = next_char (INSTRING_WARN); + if (c == '\0') + { + token = FMT_END; + break; + } + + if (c == delim) + { + c = next_char (NONSTRING); + if (c == '\0') + { + token = FMT_END; + break; + } + if (c == '/') + { + token = FMT_SLASH; + break; + } + if (c == delim) + continue; + unget_char (); + break; + } + } + } + else if (c == '/') + { + token = FMT_SLASH; + break; + } + else + unget_char (); + } + else + { + token = FMT_D; + unget_char (); + } + break; + + case 'R': + c = next_char_not_space (); + switch (c) + { + case 'C': + token = FMT_RC; + break; + case 'D': + token = FMT_RD; + break; + case 'N': + token = FMT_RN; + break; + case 'P': + token = FMT_RP; + break; + case 'U': + token = FMT_RU; + break; + case 'Z': + token = FMT_RZ; + break; + default: + token = FMT_UNKNOWN; + unget_char (); + break; + } + break; + + case '\0': + token = FMT_END; + break; + + case '*': + token = FMT_STAR; + break; + + default: + token = FMT_UNKNOWN; + break; + } + + return token; +} + + +static const char * +token_to_string (format_token t) +{ + switch (t) + { + case FMT_D: + return "D"; + case FMT_G: + return "G"; + case FMT_E: + return "E"; + case FMT_EN: + return "EN"; + case FMT_ES: + return "ES"; + default: + return ""; + } +} + +/* Check a format statement. The format string, either from a FORMAT + statement or a constant in an I/O statement has already been parsed + by itself, and we are checking it for validity. The dual origin + means that the warning message is a little less than great. */ + +static bool +check_format (bool is_input) +{ + const char *posint_required + = G_("Positive width required in format string at %L"); + const char *nonneg_required + = G_("Nonnegative width required in format string at %L"); + const char *unexpected_element + = G_("Unexpected element %qc in format string at %L"); + const char *unexpected_end + = G_("Unexpected end of format string in format string at %L"); + const char *zero_width + = G_("Zero width in format descriptor in format string at %L"); + + const char *error = NULL; + format_token t, u; + int level; + int repeat; + bool rv; + + use_last_char = 0; + saved_token = FMT_NONE; + level = 0; + repeat = 0; + rv = true; + format_string_pos = 0; + + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_LPAREN) + { + error = G_("Missing leading left parenthesis in format string at %L"); + goto syntax; + } + + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t == FMT_RPAREN) + goto finished; /* Empty format is legal */ + saved_token = t; + +format_item: + /* In this state, the next thing has to be a format item. */ + t = format_lex (); + if (t == FMT_ERROR) + goto fail; +format_item_1: + switch (t) + { + case FMT_STAR: + repeat = -1; + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t == FMT_LPAREN) + { + level++; + goto format_item; + } + error = G_("Left parenthesis required after %<*%> in format string " + "at %L"); + goto syntax; + + case FMT_POSINT: + repeat = value; + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t == FMT_LPAREN) + { + level++; + goto format_item; + } + + if (t == FMT_SLASH) + goto optional_comma; + + goto data_desc; + + case FMT_LPAREN: + level++; + goto format_item; + + case FMT_SIGNED_INT: + case FMT_ZERO: + /* Signed integer can only precede a P format. */ + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_P) + { + error = G_("Expected P edit descriptor in format string at %L"); + goto syntax; + } + + goto data_desc; + + case FMT_P: + /* P requires a prior number. */ + error = G_("P descriptor requires leading scale factor in format " + "string at %L"); + goto syntax; + + case FMT_X: + /* X requires a prior number if we're being pedantic. */ + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + if (!gfc_notify_std (GFC_STD_GNU, "X descriptor requires leading " + "space count at %L", &format_locus)) + return false; + goto between_desc; + + case FMT_SIGN: + case FMT_BLANK: + case FMT_DP: + case FMT_DC: + case FMT_RC: + case FMT_RD: + case FMT_RN: + case FMT_RP: + case FMT_RU: + case FMT_RZ: + goto between_desc; + + case FMT_CHAR: + goto extension_optional_comma; + + case FMT_COLON: + case FMT_SLASH: + goto optional_comma; + + case FMT_DOLLAR: + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + + if (!gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus)) + return false; + if (t != FMT_RPAREN || level > 0) + { + gfc_warning (0, "$ should be the last specifier in format at %L", + &format_locus); + goto optional_comma_1; + } + + goto finished; + + case FMT_T: + case FMT_TL: + case FMT_TR: + case FMT_IBOZ: + case FMT_F: + case FMT_E: + case FMT_EN: + case FMT_ES: + case FMT_G: + case FMT_L: + case FMT_A: + case FMT_D: + case FMT_H: + case FMT_DT: + goto data_desc; + + case FMT_END: + error = unexpected_end; + goto syntax; + + case FMT_RPAREN: + if (flag_dec_blank_format_item) + goto finished; + else + { + error = G_("Missing item in format string at %L"); + goto syntax; + } + + default: + error = unexpected_element; + goto syntax; + } + +data_desc: + /* In this state, t must currently be a data descriptor. + Deal with things that can/must follow the descriptor. */ + switch (t) + { + case FMT_SIGN: + case FMT_BLANK: + case FMT_DP: + case FMT_DC: + case FMT_X: + break; + + case FMT_P: + /* No comma after P allowed only for F, E, EN, ES, D, or G. + 10.1.1 (1). */ + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (!(gfc_option.allow_std & GFC_STD_F2003) && t != FMT_COMMA + && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES + && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) + { + error = G_("Comma required after P descriptor in format string " + "at %L"); + goto syntax; + } + if (t != FMT_COMMA) + { + if (t == FMT_POSINT) + { + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + } + if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES + && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH) + { + error = G_("Comma required after P descriptor in format string " + "at %L"); + goto syntax; + } + } + + saved_token = t; + goto optional_comma; + + case FMT_T: + case FMT_TL: + case FMT_TR: + t = format_lex (); + if (t != FMT_POSINT) + { + error = G_("Positive width required with T descriptor in format " + "string at %L"); + goto syntax; + } + break; + + case FMT_L: + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t == FMT_POSINT) + break; + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + if (t == FMT_ZERO) + { + switch (gfc_notification_std (GFC_STD_GNU)) + { + case WARNING: + gfc_warning (0, "Extension: Zero width after L " + "descriptor at %L", &format_locus); + break; + case ERROR: + gfc_error ("Extension: Zero width after L " + "descriptor at %L", &format_locus); + goto fail; + case SILENT: + break; + default: + gcc_unreachable (); + } + } + else + { + saved_token = t; + gfc_notify_std (GFC_STD_GNU, "Missing positive width after " + "L descriptor at %L", &format_locus); + } + break; + + case FMT_A: + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t == FMT_ZERO) + { + error = zero_width; + goto syntax; + } + if (t != FMT_POSINT) + saved_token = t; + break; + + case FMT_D: + case FMT_E: + case FMT_G: + case FMT_EN: + case FMT_ES: + u = format_lex (); + if (t == FMT_G && u == FMT_ZERO) + { + if (is_input) + { + error = zero_width; + goto syntax; + } + if (!gfc_notify_std (GFC_STD_F2008, "% in format at %L", + &format_locus)) + return false; + u = format_lex (); + if (u != FMT_PERIOD) + { + saved_token = u; + break; + } + u = format_lex (); + if (u != FMT_POSINT) + { + error = posint_required; + goto syntax; + } + u = format_lex (); + if (u == FMT_E) + { + error = G_("E specifier not allowed with g0 descriptor in " + "format string at %L"); + goto syntax; + } + saved_token = u; + break; + } + + if (u != FMT_POSINT) + { + if (flag_dec) + { + if (flag_dec_format_defaults) + { + /* Assume a default width based on the variable size. */ + saved_token = u; + break; + } + else + { + gfc_error ("Positive width required in format " + "specifier %s at %L", token_to_string (t), + &format_locus); + saved_token = u; + goto fail; + } + } + + format_locus.nextc += format_string_pos; + if (!gfc_notify_std (GFC_STD_F2018, + "positive width required at %L", + &format_locus)) + { + saved_token = u; + goto fail; + } + if (flag_dec_format_defaults) + { + /* Assume a default width based on the variable size. */ + saved_token = u; + break; + } + } + + u = format_lex (); + if (u == FMT_ERROR) + goto fail; + if (u != FMT_PERIOD) + { + /* Warn if -std=legacy, otherwise error. */ + format_locus.nextc += format_string_pos; + if (gfc_option.warn_std != 0) + { + gfc_error ("Period required in format " + "specifier %s at %L", token_to_string (t), + &format_locus); + saved_token = u; + goto fail; + } + else + gfc_warning (0, "Period required in format " + "specifier %s at %L", token_to_string (t), + &format_locus); + /* If we go to finished, we need to unwind this + before the next round. */ + format_locus.nextc -= format_string_pos; + saved_token = u; + break; + } + + u = format_lex (); + if (u == FMT_ERROR) + goto fail; + if (u != FMT_ZERO && u != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + + if (t == FMT_D) + break; + + /* Look for optional exponent. */ + u = format_lex (); + if (u == FMT_ERROR) + goto fail; + if (u != FMT_E) + saved_token = u; + else + { + u = format_lex (); + if (u == FMT_ERROR) + goto fail; + if (u != FMT_POSINT) + { + if (u == FMT_ZERO) + { + if (!gfc_notify_std (GFC_STD_F2018, + "Positive exponent width required in " + "format string at %L", &format_locus)) + { + saved_token = u; + goto fail; + } + } + else + { + error = G_("Positive exponent width required in format " + "string at %L"); + goto syntax; + } + } + } + + break; + + case FMT_DT: + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + switch (t) + { + case FMT_RPAREN: + level--; + if (level < 0) + goto finished; + goto between_desc; + + case FMT_COMMA: + goto format_item; + + case FMT_COLON: + goto format_item_1; + + case FMT_LPAREN: + + dtio_vlist: + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + + if (t != FMT_POSINT) + { + error = posint_required; + goto syntax; + } + + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + + if (t == FMT_COMMA) + goto dtio_vlist; + if (t != FMT_RPAREN) + { + error = G_("Right parenthesis expected at %C in format string " + "at %L"); + goto syntax; + } + goto between_desc; + + default: + error = unexpected_element; + goto syntax; + } + break; + + case FMT_F: + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_ZERO && t != FMT_POSINT) + { + if (flag_dec_format_defaults) + { + /* Assume the default width is expected here and continue lexing. */ + value = 0; /* It doesn't matter what we set the value to here. */ + saved_token = t; + break; + } + error = nonneg_required; + goto syntax; + } + else if (is_input && t == FMT_ZERO) + { + error = posint_required; + goto syntax; + } + + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_PERIOD) + { + /* Warn if -std=legacy, otherwise error. */ + if (gfc_option.warn_std != 0) + { + error = G_("Period required in format specifier in format " + "string at %L"); + goto syntax; + } + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + gfc_warning (0, "Period required in format specifier at %L", + &format_locus); + saved_token = t; + break; + } + + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_ZERO && t != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + + break; + + case FMT_H: + if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) + { + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + gfc_warning (0, "The H format specifier at %L is" + " a Fortran 95 deleted feature", &format_locus); + } + if (mode == MODE_STRING) + { + format_string += value; + format_length -= value; + format_string_pos += repeat; + } + else + { + while (repeat >0) + { + next_char (INSTRING_WARN); + repeat -- ; + } + } + break; + + case FMT_IBOZ: + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_ZERO && t != FMT_POSINT) + { + if (flag_dec_format_defaults) + { + /* Assume the default width is expected here and continue lexing. */ + value = 0; /* It doesn't matter what we set the value to here. */ + saved_token = t; + } + else + { + error = nonneg_required; + goto syntax; + } + } + else if (is_input && t == FMT_ZERO) + { + error = posint_required; + goto syntax; + } + + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_PERIOD) + saved_token = t; + else + { + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t != FMT_ZERO && t != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + } + + break; + + default: + error = unexpected_element; + goto syntax; + } + +between_desc: + /* Between a descriptor and what comes next. */ + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + switch (t) + { + + case FMT_COMMA: + goto format_item; + + case FMT_RPAREN: + level--; + if (level < 0) + goto finished; + goto between_desc; + + case FMT_COLON: + case FMT_SLASH: + goto optional_comma; + + case FMT_END: + error = unexpected_end; + goto syntax; + + default: + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos - 1; + if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) + return false; + /* If we do not actually return a failure, we need to unwind this + before the next round. */ + if (mode != MODE_FORMAT) + format_locus.nextc -= format_string_pos; + goto format_item_1; + } + +optional_comma: + /* Optional comma is a weird between state where we've just finished + reading a colon, slash, dollar or P descriptor. */ + t = format_lex (); + if (t == FMT_ERROR) + goto fail; +optional_comma_1: + switch (t) + { + case FMT_COMMA: + break; + + case FMT_RPAREN: + level--; + if (level < 0) + goto finished; + goto between_desc; + + default: + /* Assume that we have another format item. */ + saved_token = t; + break; + } + + goto format_item; + +extension_optional_comma: + /* As a GNU extension, permit a missing comma after a string literal. */ + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + switch (t) + { + case FMT_COMMA: + break; + + case FMT_RPAREN: + level--; + if (level < 0) + goto finished; + goto between_desc; + + case FMT_COLON: + case FMT_SLASH: + goto optional_comma; + + case FMT_END: + error = unexpected_end; + goto syntax; + + default: + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) + return false; + /* If we do not actually return a failure, we need to unwind this + before the next round. */ + if (mode != MODE_FORMAT) + format_locus.nextc -= format_string_pos; + saved_token = t; + break; + } + + goto format_item; + +syntax: + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + if (error == unexpected_element) + gfc_error (error, error_element, &format_locus); + else + gfc_error (error, &format_locus); +fail: + rv = false; + +finished: + return rv; +} + + +/* Given an expression node that is a constant string, see if it looks + like a format string. */ + +static bool +check_format_string (gfc_expr *e, bool is_input) +{ + bool rv; + int i; + if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) + return true; + + mode = MODE_STRING; + format_string = e->value.character.string; + + /* More elaborate measures are needed to show where a problem is within a + format string that has been calculated, but that's probably not worth the + effort. */ + format_locus = e->where; + rv = check_format (is_input); + /* check for extraneous characters at the end of an otherwise valid format + string, like '(A10,I3)F5' + start at the end and move back to the last character processed, + spaces are OK */ + if (rv && e->value.character.length > format_string_pos) + for (i=e->value.character.length-1;i>format_string_pos-1;i--) + if (e->value.character.string[i] != ' ') + { + format_locus.nextc += format_length + 1; + gfc_warning (0, + "Extraneous characters in format at %L", &format_locus); + break; + } + return rv; +} + + +/************ Fortran I/O statement matchers *************/ + +/* Match a FORMAT statement. This amounts to actually parsing the + format descriptors in order to correctly locate the end of the + format string. */ + +match +gfc_match_format (void) +{ + gfc_expr *e; + locus start; + + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) + { + gfc_error ("Format statement in module main block at %C"); + return MATCH_ERROR; + } + + /* Before parsing the rest of a FORMAT statement, check F2008:c1206. */ + if ((gfc_current_state () == COMP_FUNCTION + || gfc_current_state () == COMP_SUBROUTINE) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("FORMAT statement at %C cannot appear within an INTERFACE"); + return MATCH_ERROR; + } + + if (gfc_statement_label == NULL) + { + gfc_error ("Missing format label at %C"); + return MATCH_ERROR; + } + gfc_gobble_whitespace (); + + mode = MODE_FORMAT; + format_length = 0; + + start = gfc_current_locus; + + if (!check_format (false)) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_FORMAT); + return MATCH_ERROR; + } + + /* The label doesn't get created until after the statement is done + being matched, so we have to leave the string for later. */ + + gfc_current_locus = start; /* Back to the beginning */ + + new_st.loc = start; + new_st.op = EXEC_NOP; + + e = gfc_get_character_expr (gfc_default_character_kind, &start, + NULL, format_length); + format_string = e->value.character.string; + gfc_statement_label->format = e; + + mode = MODE_COPY; + check_format (false); /* Guaranteed to succeed */ + gfc_match_eos (); /* Guaranteed to succeed */ + + return MATCH_YES; +} + + +/* Match an expression I/O tag of some sort. */ + +static match +match_etag (const io_tag *tag, gfc_expr **v) +{ + gfc_expr *result; + match m; + + m = gfc_match (tag->spec); + if (m != MATCH_YES) + return m; + + m = gfc_match (tag->value, &result); + if (m != MATCH_YES) + { + gfc_error ("Invalid value for %s specification at %C", tag->name); + return MATCH_ERROR; + } + + if (*v != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + gfc_free_expr (result); + return MATCH_ERROR; + } + + *v = result; + return MATCH_YES; +} + + +/* Match a variable I/O tag of some sort. */ + +static match +match_vtag (const io_tag *tag, gfc_expr **v) +{ + gfc_expr *result; + match m; + + m = gfc_match (tag->spec); + if (m != MATCH_YES) + return m; + + m = gfc_match (tag->value, &result); + if (m != MATCH_YES) + { + gfc_error ("Invalid value for %s specification at %C", tag->name); + return MATCH_ERROR; + } + + if (*v != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + gfc_free_expr (result); + return MATCH_ERROR; + } + + if (result->symtree) + { + bool impure; + + if (result->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name); + gfc_free_expr (result); + return MATCH_ERROR; + } + + impure = gfc_impure_variable (result->symtree->n.sym); + if (impure && gfc_pure (NULL)) + { + gfc_error ("Variable %s cannot be assigned in PURE procedure at %C", + tag->name); + gfc_free_expr (result); + return MATCH_ERROR; + } + + if (impure) + gfc_unset_implicit_pure (NULL); + } + + *v = result; + return MATCH_YES; +} + + +/* Match I/O tags that cause variables to become redefined. */ + +static match +match_out_tag (const io_tag *tag, gfc_expr **result) +{ + match m; + + m = match_vtag (tag, result); + if (m == MATCH_YES) + { + if ((*result)->symtree) + gfc_check_do_variable ((*result)->symtree); + + if ((*result)->expr_type == EXPR_CONSTANT) + { + gfc_error ("Expecting a variable at %L", &(*result)->where); + return MATCH_ERROR; + } + } + + return m; +} + + +/* Match a label I/O tag. */ + +static match +match_ltag (const io_tag *tag, gfc_st_label ** label) +{ + match m; + gfc_st_label *old; + + old = *label; + m = gfc_match (tag->spec); + if (m != MATCH_YES) + return m; + + m = gfc_match (tag->value, label); + if (m != MATCH_YES) + { + gfc_error ("Invalid value for %s specification at %C", tag->name); + return MATCH_ERROR; + } + + if (old) + { + gfc_error ("Duplicate %s label specification at %C", tag->name); + return MATCH_ERROR; + } + + if (!gfc_reference_st_label (*label, ST_LABEL_TARGET)) + return MATCH_ERROR; + + return m; +} + + +/* Match a tag using match_etag, but only if -fdec is enabled. */ +static match +match_dec_etag (const io_tag *tag, gfc_expr **e) +{ + match m = match_etag (tag, e); + if (flag_dec && m != MATCH_NO) + return m; + else if (m != MATCH_NO) + { + gfc_error ("%s at %C is a DEC extension, enable with " + "%<-fdec%>", tag->name); + return MATCH_ERROR; + } + return m; +} + + +/* Match a tag using match_vtag, but only if -fdec is enabled. */ +static match +match_dec_vtag (const io_tag *tag, gfc_expr **e) +{ + match m = match_vtag(tag, e); + if (flag_dec && m != MATCH_NO) + return m; + else if (m != MATCH_NO) + { + gfc_error ("%s at %C is a DEC extension, enable with " + "%<-fdec%>", tag->name); + return MATCH_ERROR; + } + return m; +} + + +/* Match a DEC I/O flag tag - a tag with no expression such as READONLY. */ + +static match +match_dec_ftag (const io_tag *tag, gfc_open *o) +{ + match m; + + m = gfc_match (tag->spec); + if (m != MATCH_YES) + return m; + + if (!flag_dec) + { + gfc_error ("%s at %C is a DEC extension, enable with " + "%<-fdec%>", tag->name); + return MATCH_ERROR; + } + + /* Just set the READONLY flag, which we use at runtime to avoid delete on + close. */ + if (tag == &tag_readonly) + { + o->readonly |= 1; + return MATCH_YES; + } + + /* Interpret SHARED as SHARE='DENYNONE' (read lock). */ + else if (tag == &tag_shared) + { + if (o->share != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + return MATCH_ERROR; + } + o->share = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, "denynone", 8); + return MATCH_YES; + } + + /* Interpret NOSHARED as SHARE='DENYRW' (exclusive lock). */ + else if (tag == &tag_noshared) + { + if (o->share != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + return MATCH_ERROR; + } + o->share = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, "denyrw", 6); + return MATCH_YES; + } + + /* We handle all DEC tags above. */ + gcc_unreachable (); +} + + +/* Resolution of the FORMAT tag, to be called from resolve_tag. */ + +static bool +resolve_tag_format (gfc_expr *e) +{ + if (e->expr_type == EXPR_CONSTANT + && (e->ts.type != BT_CHARACTER + || e->ts.kind != gfc_default_character_kind)) + { + gfc_error ("Constant expression in FORMAT tag at %L must be " + "of type default CHARACTER", &e->where); + return false; + } + + /* Concatenate a constant character array into a single character + expression. */ + + if ((e->expr_type == EXPR_ARRAY || e->rank > 0) + && e->ts.type == BT_CHARACTER + && gfc_is_constant_expr (e)) + { + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor == FL_PARAMETER) + gfc_simplify_expr (e, 1); + + if (e->expr_type == EXPR_ARRAY) + { + gfc_constructor *c; + gfc_charlen_t n, len; + gfc_expr *r; + gfc_char_t *dest, *src; + + if (e->value.constructor == NULL) + { + gfc_error ("FORMAT tag at %L cannot be a zero-sized array", + &e->where); + return false; + } + + n = 0; + c = gfc_constructor_first (e->value.constructor); + len = c->expr->value.character.length; + + for ( ; c; c = gfc_constructor_next (c)) + n += len; + + r = gfc_get_character_expr (e->ts.kind, &e->where, NULL, n); + dest = r->value.character.string; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + src = c->expr->value.character.string; + for (gfc_charlen_t i = 0 ; i < len; i++) + *dest++ = *src++; + } + + gfc_replace_expr (e, r); + return true; + } + } + + /* If e's rank is zero and e is not an element of an array, it should be + of integer or character type. The integer variable should be + ASSIGNED. */ + if (e->rank == 0 + && (e->expr_type != EXPR_VARIABLE + || e->symtree == NULL + || e->symtree->n.sym->as == NULL + || e->symtree->n.sym->as->rank == 0)) + { + if ((e->ts.type != BT_CHARACTER + || e->ts.kind != gfc_default_character_kind) + && e->ts.type != BT_INTEGER) + { + gfc_error ("FORMAT tag at %L must be of type default-kind CHARACTER " + "or of INTEGER", &e->where); + return false; + } + else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) + { + if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED variable in " + "FORMAT tag at %L", &e->where)) + return false; + if (e->symtree->n.sym->attr.assign != 1) + { + gfc_error ("Variable %qs at %L has not been assigned a " + "format label", e->symtree->n.sym->name, &e->where); + return false; + } + } + else if (e->ts.type == BT_INTEGER) + { + gfc_error ("Scalar %qs in FORMAT tag at %L is not an ASSIGNED " + "variable", gfc_basic_typename (e->ts.type), &e->where); + return false; + } + + return true; + } + + /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY. + It may be assigned an Hollerith constant. */ + if (e->ts.type != BT_CHARACTER) + { + if (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS + || e->ts.type == BT_VOID || e->ts.type == BT_UNKNOWN) + { + gfc_error ("Non-character non-Hollerith in FORMAT tag at %L", + &e->where); + return false; + } + if (!gfc_notify_std (GFC_STD_LEGACY, "Non-character in FORMAT tag " + "at %L", &e->where)) + return false; + + if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Non-character assumed shape array element in FORMAT" + " tag at %L", &e->where); + return false; + } + + if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Non-character assumed size array element in FORMAT" + " tag at %L", &e->where); + return false; + } + + if (e->rank == 0 && e->symtree->n.sym->attr.pointer) + { + gfc_error ("Non-character pointer array element in FORMAT tag at %L", + &e->where); + return false; + } + } + + return true; +} + + +/* Do expression resolution and type-checking on an expression tag. */ + +static bool +resolve_tag (const io_tag *tag, gfc_expr *e) +{ + if (e == NULL) + return true; + + if (!gfc_resolve_expr (e)) + return false; + + if (tag == &tag_format) + return resolve_tag_format (e); + + if (e->ts.type != tag->type) + { + gfc_error ("%s tag at %L must be of type %s", tag->name, + &e->where, gfc_basic_typename (tag->type)); + return false; + } + + if (e->ts.type == BT_CHARACTER && e->ts.kind != gfc_default_character_kind) + { + gfc_error ("%s tag at %L must be a character string of default kind", + tag->name, &e->where); + return false; + } + + if (e->rank != 0) + { + gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); + return false; + } + + if (tag == &tag_iomsg) + { + if (!gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where)) + return false; + } + + if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength + || tag == &tag_number || tag == &tag_nextrec || tag == &tag_s_recl) + && e->ts.kind != gfc_default_integer_kind) + { + if (!gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default " + "INTEGER in %s tag at %L", tag->name, &e->where)) + return false; + } + + if (e->ts.kind != gfc_default_logical_kind && + (tag == &tag_exist || tag == &tag_named || tag == &tag_opened + || tag == &tag_pending)) + { + if (!gfc_notify_std (GFC_STD_F2008, "Non-default LOGICAL kind " + "in %s tag at %L", tag->name, &e->where)) + return false; + } + + if (tag == &tag_newunit) + { + if (!gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier at %L", + &e->where)) + return false; + } + + /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */ + if (tag == &tag_newunit || tag == &tag_iostat + || tag == &tag_size || tag == &tag_iomsg) + { + char context[64]; + + sprintf (context, _("%s tag"), tag->name); + if (!gfc_check_vardef_context (e, false, false, false, context)) + return false; + } + + if (tag == &tag_convert) + { + if (!gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where)) + return false; + } + + return true; +} + + +/* Match a single tag of an OPEN statement. */ + +static match +match_open_element (gfc_open *open) +{ + match m; + + m = match_etag (&tag_e_async, &open->asynchronous); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_unit, &open->unit); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_iomsg, &open->iomsg); + if (m != MATCH_NO) + return m; + m = match_out_tag (&tag_iostat, &open->iostat); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_file, &open->file); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_status, &open->status); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_access, &open->access); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_form, &open->form); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_recl, &open->recl); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_blank, &open->blank); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_position, &open->position); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_action, &open->action); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_delim, &open->delim); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_pad, &open->pad); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_decimal, &open->decimal); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_encoding, &open->encoding); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_round, &open->round); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_sign, &open->sign); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &open->err); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_convert, &open->convert); + if (m != MATCH_NO) + return m; + m = match_out_tag (&tag_newunit, &open->newunit); + if (m != MATCH_NO) + return m; + + /* The following are extensions enabled with -fdec. */ + m = match_dec_etag (&tag_e_share, &open->share); + if (m != MATCH_NO) + return m; + m = match_dec_etag (&tag_cc, &open->cc); + if (m != MATCH_NO) + return m; + m = match_dec_ftag (&tag_readonly, open); + if (m != MATCH_NO) + return m; + m = match_dec_ftag (&tag_shared, open); + if (m != MATCH_NO) + return m; + m = match_dec_ftag (&tag_noshared, open); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Free the gfc_open structure and all the expressions it contains. */ + +void +gfc_free_open (gfc_open *open) +{ + if (open == NULL) + return; + + gfc_free_expr (open->unit); + gfc_free_expr (open->iomsg); + gfc_free_expr (open->iostat); + gfc_free_expr (open->file); + gfc_free_expr (open->status); + gfc_free_expr (open->access); + gfc_free_expr (open->form); + gfc_free_expr (open->recl); + gfc_free_expr (open->blank); + gfc_free_expr (open->position); + gfc_free_expr (open->action); + gfc_free_expr (open->delim); + gfc_free_expr (open->pad); + gfc_free_expr (open->decimal); + gfc_free_expr (open->encoding); + gfc_free_expr (open->round); + gfc_free_expr (open->sign); + gfc_free_expr (open->convert); + gfc_free_expr (open->asynchronous); + gfc_free_expr (open->newunit); + gfc_free_expr (open->share); + gfc_free_expr (open->cc); + free (open); +} + + +static int +compare_to_allowed_values (const char *specifier, const char *allowed[], + const char *allowed_f2003[], + const char *allowed_gnu[], gfc_char_t *value, + const char *statement, bool warn, locus *where, + int *num = NULL); + + +static bool +check_open_constraints (gfc_open *open, locus *where); + +/* Resolve everything in a gfc_open structure. */ + +bool +gfc_resolve_open (gfc_open *open, locus *where) +{ + RESOLVE_TAG (&tag_unit, open->unit); + RESOLVE_TAG (&tag_iomsg, open->iomsg); + RESOLVE_TAG (&tag_iostat, open->iostat); + RESOLVE_TAG (&tag_file, open->file); + RESOLVE_TAG (&tag_status, open->status); + RESOLVE_TAG (&tag_e_access, open->access); + RESOLVE_TAG (&tag_e_form, open->form); + RESOLVE_TAG (&tag_e_recl, open->recl); + RESOLVE_TAG (&tag_e_blank, open->blank); + RESOLVE_TAG (&tag_e_position, open->position); + RESOLVE_TAG (&tag_e_action, open->action); + RESOLVE_TAG (&tag_e_delim, open->delim); + RESOLVE_TAG (&tag_e_pad, open->pad); + RESOLVE_TAG (&tag_e_decimal, open->decimal); + RESOLVE_TAG (&tag_e_encoding, open->encoding); + RESOLVE_TAG (&tag_e_async, open->asynchronous); + RESOLVE_TAG (&tag_e_round, open->round); + RESOLVE_TAG (&tag_e_sign, open->sign); + RESOLVE_TAG (&tag_convert, open->convert); + RESOLVE_TAG (&tag_newunit, open->newunit); + RESOLVE_TAG (&tag_e_share, open->share); + RESOLVE_TAG (&tag_cc, open->cc); + + if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) + return false; + + return check_open_constraints (open, where); +} + + +/* Check if a given value for a SPECIFIER is either in the list of values + allowed in F95 or F2003, issuing an error message and returning a zero + value if it is not allowed. */ + + +static int +compare_to_allowed_values (const char *specifier, const char *allowed[], + const char *allowed_f2003[], + const char *allowed_gnu[], gfc_char_t *value, + const char *statement, bool warn, locus *where, + int *num) +{ + int i; + unsigned int len; + + len = gfc_wide_strlen (value); + if (len > 0) + { + for (len--; len > 0; len--) + if (value[len] != ' ') + break; + len++; + } + + for (i = 0; allowed[i]; i++) + if (len == strlen (allowed[i]) + && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) + { + if (num) + *num = i; + return 1; + } + + if (!where) + where = &gfc_current_locus; + + for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) + if (len == strlen (allowed_f2003[i]) + && gfc_wide_strncasecmp (value, allowed_f2003[i], + strlen (allowed_f2003[i])) == 0) + { + notification n = gfc_notification_std (GFC_STD_F2003); + + if (n == WARNING || (warn && n == ERROR)) + { + gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L " + "has value %qs", specifier, statement, where, + allowed_f2003[i]); + return 1; + } + else + if (n == ERROR) + { + gfc_notify_std (GFC_STD_F2003, "%s specifier in " + "%s statement at %L has value %qs", specifier, + statement, where, allowed_f2003[i]); + return 0; + } + + /* n == SILENT */ + return 1; + } + + for (i = 0; allowed_gnu && allowed_gnu[i]; i++) + if (len == strlen (allowed_gnu[i]) + && gfc_wide_strncasecmp (value, allowed_gnu[i], + strlen (allowed_gnu[i])) == 0) + { + notification n = gfc_notification_std (GFC_STD_GNU); + + if (n == WARNING || (warn && n == ERROR)) + { + gfc_warning (0, "Extension: %s specifier in %s statement at %L " + "has value %qs", specifier, statement, where, + allowed_gnu[i]); + return 1; + } + else + if (n == ERROR) + { + gfc_notify_std (GFC_STD_GNU, "%s specifier in " + "%s statement at %L has value %qs", specifier, + statement, where, allowed_gnu[i]); + return 0; + } + + /* n == SILENT */ + return 1; + } + + if (warn) + { + char *s = gfc_widechar_to_char (value, -1); + gfc_warning (0, + "%s specifier in %s statement at %L has invalid value %qs", + specifier, statement, where, s); + free (s); + return 1; + } + else + { + char *s = gfc_widechar_to_char (value, -1); + gfc_error ("%s specifier in %s statement at %L has invalid value %qs", + specifier, statement, where, s); + free (s); + return 0; + } +} + + +/* Check constraints on the OPEN statement. + Similar to check_io_constraints for data transfer statements. + At this point all tags have already been resolved via resolve_tag, which, + among other things, verifies that BT_CHARACTER tags are of default kind. */ + +static bool +check_open_constraints (gfc_open *open, locus *where) +{ +#define warn_or_error(...) \ +{ \ + if (warn) \ + gfc_warning (0, __VA_ARGS__); \ + else \ + { \ + gfc_error (__VA_ARGS__); \ + return false; \ + } \ +} + + bool warn = (open->err || open->iostat) ? true : false; + + /* Checks on the ACCESS specifier. */ + if (open->access && open->access->expr_type == EXPR_CONSTANT) + { + static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL }; + static const char *access_f2003[] = { "STREAM", NULL }; + static const char *access_gnu[] = { "APPEND", NULL }; + + if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, + access_gnu, + open->access->value.character.string, + "OPEN", warn, &open->access->where)) + return false; + } + + /* Checks on the ACTION specifier. */ + if (open->action && open->action->expr_type == EXPR_CONSTANT) + { + gfc_char_t *str = open->action->value.character.string; + static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; + + if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, + str, "OPEN", warn, &open->action->where)) + return false; + + /* With READONLY, only allow ACTION='READ'. */ + if (open->readonly && (gfc_wide_strlen (str) != 4 + || gfc_wide_strncasecmp (str, "READ", 4) != 0)) + { + gfc_error ("ACTION type conflicts with READONLY specifier at %L", + &open->action->where); + return false; + } + } + + /* If we see READONLY and no ACTION, set ACTION='READ'. */ + else if (open->readonly && open->action == NULL) + { + open->action = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, "read", 4); + } + + /* Checks on the ASYNCHRONOUS specifier. */ + if (open->asynchronous) + { + if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L " + "not allowed in Fortran 95", + &open->asynchronous->where)) + return false; + + if (open->asynchronous->expr_type == EXPR_CONSTANT) + { + static const char * asynchronous[] = { "YES", "NO", NULL }; + + if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, + NULL, NULL, open->asynchronous->value.character.string, + "OPEN", warn, &open->asynchronous->where)) + return false; + } + } + + /* Checks on the BLANK specifier. */ + if (open->blank) + { + if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " + "not allowed in Fortran 95", &open->blank->where)) + return false; + + if (open->blank->expr_type == EXPR_CONSTANT) + { + static const char *blank[] = { "ZERO", "NULL", NULL }; + + if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, + open->blank->value.character.string, + "OPEN", warn, &open->blank->where)) + return false; + } + } + + /* Checks on the CARRIAGECONTROL specifier. */ + if (open->cc && open->cc->expr_type == EXPR_CONSTANT) + { + static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; + if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, + open->cc->value.character.string, + "OPEN", warn, &open->cc->where)) + return false; + } + + /* Checks on the DECIMAL specifier. */ + if (open->decimal) + { + if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " + "not allowed in Fortran 95", &open->decimal->where)) + return false; + + if (open->decimal->expr_type == EXPR_CONSTANT) + { + static const char * decimal[] = { "COMMA", "POINT", NULL }; + + if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, + open->decimal->value.character.string, + "OPEN", warn, &open->decimal->where)) + return false; + } + } + + /* Checks on the DELIM specifier. */ + if (open->delim) + { + if (open->delim->expr_type == EXPR_CONSTANT) + { + static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; + + if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, + open->delim->value.character.string, + "OPEN", warn, &open->delim->where)) + return false; + } + } + + /* Checks on the ENCODING specifier. */ + if (open->encoding) + { + if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L " + "not allowed in Fortran 95", &open->encoding->where)) + return false; + + if (open->encoding->expr_type == EXPR_CONSTANT) + { + static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; + + if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, + open->encoding->value.character.string, + "OPEN", warn, &open->encoding->where)) + return false; + } + } + + /* Checks on the FORM specifier. */ + if (open->form && open->form->expr_type == EXPR_CONSTANT) + { + static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; + + if (!compare_to_allowed_values ("FORM", form, NULL, NULL, + open->form->value.character.string, + "OPEN", warn, &open->form->where)) + return false; + } + + /* Checks on the PAD specifier. */ + if (open->pad && open->pad->expr_type == EXPR_CONSTANT) + { + static const char *pad[] = { "YES", "NO", NULL }; + + if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, + open->pad->value.character.string, + "OPEN", warn, &open->pad->where)) + return false; + } + + /* Checks on the POSITION specifier. */ + if (open->position && open->position->expr_type == EXPR_CONSTANT) + { + static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; + + if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, + open->position->value.character.string, + "OPEN", warn, &open->position->where)) + return false; + } + + /* Checks on the ROUND specifier. */ + if (open->round) + { + if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " + "not allowed in Fortran 95", &open->round->where)) + return false; + + if (open->round->expr_type == EXPR_CONSTANT) + { + static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", + "COMPATIBLE", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, + open->round->value.character.string, + "OPEN", warn, &open->round->where)) + return false; + } + } + + /* Checks on the SHARE specifier. */ + if (open->share && open->share->expr_type == EXPR_CONSTANT) + { + static const char *share[] = { "DENYNONE", "DENYRW", NULL }; + if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, + open->share->value.character.string, + "OPEN", warn, &open->share->where)) + return false; + } + + /* Checks on the SIGN specifier. */ + if (open->sign) + { + if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " + "not allowed in Fortran 95", &open->sign->where)) + return false; + + if (open->sign->expr_type == EXPR_CONSTANT) + { + static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, + open->sign->value.character.string, + "OPEN", warn, &open->sign->where)) + return false; + } + } + + /* Checks on the RECL specifier. */ + if (open->recl && open->recl->expr_type == EXPR_CONSTANT + && open->recl->ts.type == BT_INTEGER + && mpz_sgn (open->recl->value.integer) != 1) + { + warn_or_error (G_("RECL in OPEN statement at %L must be positive"), + &open->recl->where); + } + + /* Checks on the STATUS specifier. */ + if (open->status && open->status->expr_type == EXPR_CONSTANT) + { + static const char *status[] = { "OLD", "NEW", "SCRATCH", + "REPLACE", "UNKNOWN", NULL }; + + if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, + open->status->value.character.string, + "OPEN", warn, &open->status->where)) + return false; + + /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, + the FILE= specifier shall appear. */ + if (open->file == NULL + && (gfc_wide_strncasecmp (open->status->value.character.string, + "replace", 7) == 0 + || gfc_wide_strncasecmp (open->status->value.character.string, + "new", 3) == 0)) + { + char *s = gfc_widechar_to_char (open->status->value.character.string, + -1); + warn_or_error (G_("The STATUS specified in OPEN statement at %L is " + "%qs and no FILE specifier is present"), + &open->status->where, s); + free (s); + } + + /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, + the FILE= specifier shall not appear. */ + if (gfc_wide_strncasecmp (open->status->value.character.string, + "scratch", 7) == 0 && open->file) + { + warn_or_error (G_("The STATUS specified in OPEN statement at %L " + "cannot have the value SCRATCH if a FILE specifier " + "is present"), &open->status->where); + } + } + + /* Checks on NEWUNIT specifier. */ + if (open->newunit) + { + if (open->unit) + { + gfc_error ("UNIT specifier not allowed with NEWUNIT at %L", + &open->newunit->where); + return false; + } + + if (!open->file && + (!open->status || + (open->status->expr_type == EXPR_CONSTANT + && gfc_wide_strncasecmp (open->status->value.character.string, + "scratch", 7) != 0))) + { + gfc_error ("NEWUNIT specifier must have FILE= " + "or STATUS='scratch' at %L", &open->newunit->where); + return false; + } + } + else if (!open->unit) + { + gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified", + where); + return false; + } + + /* Things that are not allowed for unformatted I/O. */ + if (open->form && open->form->expr_type == EXPR_CONSTANT + && (open->delim || open->decimal || open->encoding || open->round + || open->sign || open->pad || open->blank) + && gfc_wide_strncasecmp (open->form->value.character.string, + "unformatted", 11) == 0) + { + locus *loc; + const char *spec; + if (open->delim) + { + loc = &open->delim->where; + spec = "DELIM "; + } + else if (open->pad) + { + loc = &open->pad->where; + spec = "PAD "; + } + else if (open->blank) + { + loc = &open->blank->where; + spec = "BLANK "; + } + else + { + loc = where; + spec = ""; + } + + warn_or_error (G_("%s specifier at %L not allowed in OPEN statement for " + "unformatted I/O"), spec, loc); + } + + if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT + && gfc_wide_strncasecmp (open->access->value.character.string, + "stream", 6) == 0) + { + warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for " + "stream I/O"), &open->recl->where); + } + + if (open->position + && open->access && open->access->expr_type == EXPR_CONSTANT + && !(gfc_wide_strncasecmp (open->access->value.character.string, + "sequential", 10) == 0 + || gfc_wide_strncasecmp (open->access->value.character.string, + "stream", 6) == 0 + || gfc_wide_strncasecmp (open->access->value.character.string, + "append", 6) == 0)) + { + warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed " + "for stream or sequential ACCESS"), &open->position->where); + } + + return true; +#undef warn_or_error +} + + +/* Match an OPEN statement. */ + +match +gfc_match_open (void) +{ + gfc_open *open; + match m; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + open = XCNEW (gfc_open); + + m = match_open_element (open); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&open->unit); + if (m == MATCH_ERROR) + goto cleanup; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_open_element (open); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + if (gfc_match_eos () == MATCH_NO) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("OPEN statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + gfc_unset_implicit_pure (NULL); + + new_st.op = EXEC_OPEN; + new_st.ext.open = open; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_OPEN); + +cleanup: + gfc_free_open (open); + return MATCH_ERROR; +} + + +/* Free a gfc_close structure an all its expressions. */ + +void +gfc_free_close (gfc_close *close) +{ + if (close == NULL) + return; + + gfc_free_expr (close->unit); + gfc_free_expr (close->iomsg); + gfc_free_expr (close->iostat); + gfc_free_expr (close->status); + free (close); +} + + +/* Match elements of a CLOSE statement. */ + +static match +match_close_element (gfc_close *close) +{ + match m; + + m = match_etag (&tag_unit, &close->unit); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_status, &close->status); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_iomsg, &close->iomsg); + if (m != MATCH_NO) + return m; + m = match_out_tag (&tag_iostat, &close->iostat); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &close->err); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Match a CLOSE statement. */ + +match +gfc_match_close (void) +{ + gfc_close *close; + match m; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + close = XCNEW (gfc_close); + + m = match_close_element (close); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&close->unit); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_close_element (close); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + if (gfc_match_eos () == MATCH_NO) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("CLOSE statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + gfc_unset_implicit_pure (NULL); + + new_st.op = EXEC_CLOSE; + new_st.ext.close = close; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_CLOSE); + +cleanup: + gfc_free_close (close); + return MATCH_ERROR; +} + + +static bool +check_close_constraints (gfc_close *close, locus *where) +{ + bool warn = (close->iostat || close->err) ? true : false; + + if (close->unit == NULL) + { + gfc_error ("CLOSE statement at %L requires a UNIT number", where); + return false; + } + + if (close->unit->expr_type == EXPR_CONSTANT + && close->unit->ts.type == BT_INTEGER + && mpz_sgn (close->unit->value.integer) < 0) + { + gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", + &close->unit->where); + } + + /* Checks on the STATUS specifier. */ + if (close->status && close->status->expr_type == EXPR_CONSTANT) + { + static const char *status[] = { "KEEP", "DELETE", NULL }; + + if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, + close->status->value.character.string, + "CLOSE", warn, &close->status->where)) + return false; + } + + return true; +} + +/* Resolve everything in a gfc_close structure. */ + +bool +gfc_resolve_close (gfc_close *close, locus *where) +{ + RESOLVE_TAG (&tag_unit, close->unit); + RESOLVE_TAG (&tag_iomsg, close->iomsg); + RESOLVE_TAG (&tag_iostat, close->iostat); + RESOLVE_TAG (&tag_status, close->status); + + if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) + return false; + + return check_close_constraints (close, where); +} + + +/* Free a gfc_filepos structure. */ + +void +gfc_free_filepos (gfc_filepos *fp) +{ + gfc_free_expr (fp->unit); + gfc_free_expr (fp->iomsg); + gfc_free_expr (fp->iostat); + free (fp); +} + + +/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement. */ + +static match +match_file_element (gfc_filepos *fp) +{ + match m; + + m = match_etag (&tag_unit, &fp->unit); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_iomsg, &fp->iomsg); + if (m != MATCH_NO) + return m; + m = match_out_tag (&tag_iostat, &fp->iostat); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &fp->err); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Match the second half of the file-positioning statements, REWIND, + BACKSPACE, ENDFILE, or the FLUSH statement. */ + +static match +match_filepos (gfc_statement st, gfc_exec_op op) +{ + gfc_filepos *fp; + match m; + + fp = XCNEW (gfc_filepos); + + if (gfc_match_char ('(') == MATCH_NO) + { + m = gfc_match_expr (&fp->unit); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + goto done; + } + + m = match_file_element (fp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&fp->unit); + if (m == MATCH_ERROR || m == MATCH_NO) + goto syntax; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_file_element (fp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + +done: + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("%s statement not allowed in PURE procedure at %C", + gfc_ascii_statement (st)); + + goto cleanup; + } + + gfc_unset_implicit_pure (NULL); + + new_st.op = op; + new_st.ext.filepos = fp; + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + gfc_free_filepos (fp); + return MATCH_ERROR; +} + + +bool +gfc_resolve_filepos (gfc_filepos *fp, locus *where) +{ + RESOLVE_TAG (&tag_unit, fp->unit); + RESOLVE_TAG (&tag_iostat, fp->iostat); + RESOLVE_TAG (&tag_iomsg, fp->iomsg); + + if (!fp->unit && (fp->iostat || fp->iomsg || fp->err)) + { + gfc_error ("UNIT number missing in statement at %L", where); + return false; + } + + if (!gfc_reference_st_label (fp->err, ST_LABEL_TARGET)) + return false; + + if (fp->unit->expr_type == EXPR_CONSTANT + && fp->unit->ts.type == BT_INTEGER + && mpz_sgn (fp->unit->value.integer) < 0) + { + gfc_error ("UNIT number in statement at %L must be non-negative", + &fp->unit->where); + return false; + } + + return true; +} + + +/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND, + and the FLUSH statement. */ + +match +gfc_match_endfile (void) +{ + return match_filepos (ST_END_FILE, EXEC_ENDFILE); +} + +match +gfc_match_backspace (void) +{ + return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE); +} + +match +gfc_match_rewind (void) +{ + return match_filepos (ST_REWIND, EXEC_REWIND); +} + +match +gfc_match_flush (void) +{ + if (!gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C")) + return MATCH_ERROR; + + return match_filepos (ST_FLUSH, EXEC_FLUSH); +} + +/******************** Data Transfer Statements *********************/ + +/* Return a default unit number. */ + +static gfc_expr * +default_unit (io_kind k) +{ + int unit; + + if (k == M_READ) + unit = 5; + else + unit = 6; + + return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit); +} + + +/* Match a unit specification for a data transfer statement. */ + +static match +match_dt_unit (io_kind k, gfc_dt *dt) +{ + gfc_expr *e; + char c; + + if (gfc_match_char ('*') == MATCH_YES) + { + if (dt->io_unit != NULL) + goto conflict; + + dt->io_unit = default_unit (k); + + c = gfc_peek_ascii_char (); + if (c == ')') + gfc_error_now ("Missing format with default unit at %C"); + + return MATCH_YES; + } + + if (gfc_match_expr (&e) == MATCH_YES) + { + if (dt->io_unit != NULL) + { + gfc_free_expr (e); + goto conflict; + } + + dt->io_unit = e; + return MATCH_YES; + } + + return MATCH_NO; + +conflict: + gfc_error ("Duplicate UNIT specification at %C"); + return MATCH_ERROR; +} + + +/* Match a format specification. */ + +static match +match_dt_format (gfc_dt *dt) +{ + locus where; + gfc_expr *e; + gfc_st_label *label; + match m; + + where = gfc_current_locus; + + if (gfc_match_char ('*') == MATCH_YES) + { + if (dt->format_expr != NULL || dt->format_label != NULL) + goto conflict; + + dt->format_label = &format_asterisk; + return MATCH_YES; + } + + if ((m = gfc_match_st_label (&label)) == MATCH_YES) + { + char c; + + /* Need to check if the format label is actually either an operand + to a user-defined operator or is a kind type parameter. That is, + print 2.ip.8 ! .ip. is a user-defined operator return CHARACTER. + print 1_'(I0)', i ! 1_'(I0)' is a default character string. */ + + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c == '.' || c == '_') + gfc_current_locus = where; + else + { + if (dt->format_expr != NULL || dt->format_label != NULL) + { + gfc_free_st_label (label); + goto conflict; + } + + if (!gfc_reference_st_label (label, ST_LABEL_FORMAT)) + return MATCH_ERROR; + + dt->format_label = label; + return MATCH_YES; + } + } + else if (m == MATCH_ERROR) + /* The label was zero or too large. Emit the correct diagnosis. */ + return MATCH_ERROR; + + if (gfc_match_expr (&e) == MATCH_YES) + { + if (dt->format_expr != NULL || dt->format_label != NULL) + { + gfc_free_expr (e); + goto conflict; + } + dt->format_expr = e; + return MATCH_YES; + } + + gfc_current_locus = where; /* The only case where we have to restore */ + + return MATCH_NO; + +conflict: + gfc_error ("Duplicate format specification at %C"); + return MATCH_ERROR; +} + +/* Check for formatted read and write DTIO procedures. */ + +static bool +dtio_procs_present (gfc_symbol *sym, io_kind k) +{ + gfc_symbol *derived; + + if (sym && sym->ts.u.derived) + { + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + derived = CLASS_DATA (sym)->ts.u.derived; + else if (sym->ts.type == BT_DERIVED) + derived = sym->ts.u.derived; + else + return false; + if ((k == M_WRITE || k == M_PRINT) && + (gfc_find_specific_dtio_proc (derived, true, true) != NULL)) + return true; + if ((k == M_READ) && + (gfc_find_specific_dtio_proc (derived, false, true) != NULL)) + return true; + } + return false; +} + +/* Traverse a namelist that is part of a READ statement to make sure + that none of the variables in the namelist are INTENT(IN). Returns + nonzero if we find such a variable. */ + +static int +check_namelist (gfc_symbol *sym) +{ + gfc_namelist *p; + + for (p = sym->namelist; p; p = p->next) + if (p->sym->attr.intent == INTENT_IN) + { + gfc_error ("Symbol %qs in namelist %qs is INTENT(IN) at %C", + p->sym->name, sym->name); + return 1; + } + + return 0; +} + + +/* Match a single data transfer element. */ + +static match +match_dt_element (io_kind k, gfc_dt *dt) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + if (gfc_match (" unit =") == MATCH_YES) + { + m = match_dt_unit (k, dt); + if (m != MATCH_NO) + return m; + } + + if (gfc_match (" fmt =") == MATCH_YES) + { + m = match_dt_format (dt); + if (m != MATCH_NO) + return m; + } + + if (gfc_match (" nml = %n", name) == MATCH_YES) + { + if (dt->namelist != NULL) + { + gfc_error ("Duplicate NML specification at %C"); + return MATCH_ERROR; + } + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym == NULL || sym->attr.flavor != FL_NAMELIST) + { + gfc_error ("Symbol %qs at %C must be a NAMELIST group name", + sym != NULL ? sym->name : name); + return MATCH_ERROR; + } + + dt->namelist = sym; + if (k == M_READ && check_namelist (sym)) + return MATCH_ERROR; + + return MATCH_YES; + } + + m = match_etag (&tag_e_async, &dt->asynchronous); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_blank, &dt->blank); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_delim, &dt->delim); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_pad, &dt->pad); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_sign, &dt->sign); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_round, &dt->round); + if (m != MATCH_NO) + return m; + m = match_out_tag (&tag_id, &dt->id); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_decimal, &dt->decimal); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_rec, &dt->rec); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_spos, &dt->pos); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_iomsg, &dt->iomsg); + if (m != MATCH_NO) + return m; + + m = match_out_tag (&tag_iostat, &dt->iostat); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &dt->err); + if (m == MATCH_YES) + dt->err_where = gfc_current_locus; + if (m != MATCH_NO) + return m; + m = match_etag (&tag_advance, &dt->advance); + if (m != MATCH_NO) + return m; + m = match_out_tag (&tag_size, &dt->size); + if (m != MATCH_NO) + return m; + + m = match_ltag (&tag_end, &dt->end); + if (m == MATCH_YES) + { + if (k == M_WRITE) + { + gfc_error ("END tag at %C not allowed in output statement"); + return MATCH_ERROR; + } + dt->end_where = gfc_current_locus; + } + if (m != MATCH_NO) + return m; + + m = match_ltag (&tag_eor, &dt->eor); + if (m == MATCH_YES) + dt->eor_where = gfc_current_locus; + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Free a data transfer structure and everything below it. */ + +void +gfc_free_dt (gfc_dt *dt) +{ + if (dt == NULL) + return; + + gfc_free_expr (dt->io_unit); + gfc_free_expr (dt->format_expr); + gfc_free_expr (dt->rec); + gfc_free_expr (dt->advance); + gfc_free_expr (dt->iomsg); + gfc_free_expr (dt->iostat); + gfc_free_expr (dt->size); + gfc_free_expr (dt->pad); + gfc_free_expr (dt->delim); + gfc_free_expr (dt->sign); + gfc_free_expr (dt->round); + gfc_free_expr (dt->blank); + gfc_free_expr (dt->decimal); + gfc_free_expr (dt->pos); + gfc_free_expr (dt->dt_io_kind); + /* dt->extra_comma is a link to dt_io_kind if it is set. */ + free (dt); +} + + +static const char * +io_kind_name (io_kind k); + +static bool +check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, + locus *spec_end); + +/* Resolve everything in a gfc_dt structure. */ + +bool +gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc) +{ + gfc_expr *e; + io_kind k; + + /* This is set in any case. */ + gcc_assert (dt->dt_io_kind); + k = dt->dt_io_kind->value.iokind; + + RESOLVE_TAG (&tag_format, dt->format_expr); + RESOLVE_TAG (&tag_rec, dt->rec); + RESOLVE_TAG (&tag_spos, dt->pos); + RESOLVE_TAG (&tag_advance, dt->advance); + RESOLVE_TAG (&tag_id, dt->id); + RESOLVE_TAG (&tag_iomsg, dt->iomsg); + RESOLVE_TAG (&tag_iostat, dt->iostat); + RESOLVE_TAG (&tag_size, dt->size); + RESOLVE_TAG (&tag_e_pad, dt->pad); + RESOLVE_TAG (&tag_e_delim, dt->delim); + RESOLVE_TAG (&tag_e_sign, dt->sign); + RESOLVE_TAG (&tag_e_round, dt->round); + RESOLVE_TAG (&tag_e_blank, dt->blank); + RESOLVE_TAG (&tag_e_decimal, dt->decimal); + RESOLVE_TAG (&tag_e_async, dt->asynchronous); + + /* Check I/O constraints. + To validate NAMELIST we need to check if we were also given an I/O list, + which is stored in code->block->next with op EXEC_TRANSFER. + Note that the I/O list was already resolved from resolve_transfer. */ + gfc_code *io_code = NULL; + if (dt_code && dt_code->block && dt_code->block->next + && dt_code->block->next->op == EXEC_TRANSFER) + io_code = dt_code->block->next; + + if (!check_io_constraints (k, dt, io_code, loc)) + return false; + + e = dt->io_unit; + if (e == NULL) + { + gfc_error ("UNIT not specified at %L", loc); + return false; + } + + if (e->symtree && e->symtree->n.sym->attr.flavor == FL_PARAMETER + && e->ts.type == BT_CHARACTER) + { + gfc_error ("UNIT specification at %L must " + "not be a character PARAMETER", &e->where); + return false; + } + + if (gfc_resolve_expr (e) + && (e->ts.type != BT_INTEGER + && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE))) + { + /* If there is no extra comma signifying the "format" form of the IO + statement, then this must be an error. */ + if (!dt->extra_comma) + { + gfc_error ("UNIT specification at %L must be an INTEGER expression " + "or a CHARACTER variable", &e->where); + return false; + } + else + { + /* At this point, we have an extra comma. If io_unit has arrived as + type character, we assume its really the "format" form of the I/O + statement. We set the io_unit to the default unit and format to + the character expression. See F95 Standard section 9.4. */ + if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) + { + dt->format_expr = dt->io_unit; + dt->io_unit = default_unit (k); + + /* Nullify this pointer now so that a warning/error is not + triggered below for the "Extension". */ + dt->extra_comma = NULL; + } + + if (k == M_WRITE) + { + gfc_error ("Invalid form of WRITE statement at %L, UNIT required", + &dt->extra_comma->where); + return false; + } + } + } + + if (e->ts.type == BT_CHARACTER) + { + if (gfc_has_vector_index (e)) + { + gfc_error ("Internal unit with vector subscript at %L", &e->where); + return false; + } + + /* If we are writing, make sure the internal unit can be changed. */ + gcc_assert (k != M_PRINT); + if (k == M_WRITE + && !gfc_check_vardef_context (e, false, false, false, + _("internal unit in WRITE"))) + return false; + } + + if (e->rank && e->ts.type != BT_CHARACTER) + { + gfc_error ("External IO UNIT cannot be an array at %L", &e->where); + return false; + } + + if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER + && mpz_sgn (e->value.integer) < 0) + { + gfc_error ("UNIT number in statement at %L must be non-negative", + &e->where); + return false; + } + + /* If we are reading and have a namelist, check that all namelist symbols + can appear in a variable definition context. */ + if (dt->namelist) + { + gfc_namelist* n; + for (n = dt->namelist->namelist; n; n = n->next) + { + gfc_expr* e; + bool t; + + if (k == M_READ) + { + e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); + t = gfc_check_vardef_context (e, false, false, false, NULL); + gfc_free_expr (e); + + if (!t) + { + gfc_error ("NAMELIST %qs in READ statement at %L contains" + " the symbol %qs which may not appear in a" + " variable definition context", + dt->namelist->name, loc, n->sym->name); + return false; + } + } + + t = dtio_procs_present (n->sym, k); + + if (n->sym->ts.type == BT_CLASS && !t) + { + gfc_error ("NAMELIST object %qs in namelist %qs at %L is " + "polymorphic and requires a defined input/output " + "procedure", n->sym->name, dt->namelist->name, loc); + return false; + } + + if ((n->sym->ts.type == BT_DERIVED) + && (n->sym->ts.u.derived->attr.alloc_comp + || n->sym->ts.u.derived->attr.pointer_comp)) + { + if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " + "namelist %qs at %L with ALLOCATABLE " + "or POINTER components", n->sym->name, + dt->namelist->name, loc)) + return false; + + if (!t) + { + gfc_error ("NAMELIST object %qs in namelist %qs at %L has " + "ALLOCATABLE or POINTER components and thus requires " + "a defined input/output procedure", n->sym->name, + dt->namelist->name, loc); + return false; + } + } + } + } + + if (dt->extra_comma + && !gfc_notify_std (GFC_STD_LEGACY, "Comma before i/o item list at %L", + &dt->extra_comma->where)) + return false; + + if (dt->err) + { + if (!gfc_reference_st_label (dt->err, ST_LABEL_TARGET)) + return false; + if (dt->err->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("ERR tag label %d at %L not defined", + dt->err->value, &dt->err_where); + return false; + } + } + + if (dt->end) + { + if (!gfc_reference_st_label (dt->end, ST_LABEL_TARGET)) + return false; + if (dt->end->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("END tag label %d at %L not defined", + dt->end->value, &dt->end_where); + return false; + } + } + + if (dt->eor) + { + if (!gfc_reference_st_label (dt->eor, ST_LABEL_TARGET)) + return false; + if (dt->eor->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("EOR tag label %d at %L not defined", + dt->eor->value, &dt->eor_where); + return false; + } + } + + /* Check the format label actually exists. */ + if (dt->format_label && dt->format_label != &format_asterisk + && dt->format_label->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value, + loc); + return false; + } + + return true; +} + + +/* Given an io_kind, return its name. */ + +static const char * +io_kind_name (io_kind k) +{ + const char *name; + + switch (k) + { + case M_READ: + name = "READ"; + break; + case M_WRITE: + name = "WRITE"; + break; + case M_PRINT: + name = "PRINT"; + break; + case M_INQUIRE: + name = "INQUIRE"; + break; + default: + gfc_internal_error ("io_kind_name(): bad I/O-kind"); + } + + return name; +} + + +/* Match an IO iteration statement of the form: + + ( [ ,] , I = , [, ] ) + + which is equivalent to a single IO element. This function is + mutually recursive with match_io_element(). */ + +static match match_io_element (io_kind, gfc_code **); + +static match +match_io_iterator (io_kind k, gfc_code **result) +{ + gfc_code *head, *tail, *new_code; + gfc_iterator *iter; + locus old_loc; + match m; + int n; + + iter = NULL; + head = NULL; + old_loc = gfc_current_locus; + + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; + + m = match_io_element (k, &head); + tail = head; + + if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + /* Can't be anything but an IO iterator. Build a list. */ + iter = gfc_get_iterator (); + + for (n = 1;; n++) + { + m = gfc_match_iterator (iter, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + gfc_check_do_variable (iter->var->symtree); + break; + } + + m = match_io_element (k, &new_code); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + if (n > 2) + goto syntax; + goto cleanup; + } + + tail = gfc_append_code (tail, new_code); + + if (gfc_match_char (',') != MATCH_YES) + { + if (n > 2) + goto syntax; + m = MATCH_NO; + goto cleanup; + } + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + new_code = gfc_get_code (EXEC_DO); + new_code->ext.iterator = iter; + + new_code->block = gfc_get_code (EXEC_DO); + new_code->block->next = head; + + *result = new_code; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in I/O iterator at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_iterator (iter, 1); + gfc_free_statements (head); + gfc_current_locus = old_loc; + return m; +} + + +/* Match a single element of an IO list, which is either a single + expression or an IO Iterator. */ + +static match +match_io_element (io_kind k, gfc_code **cpp) +{ + gfc_expr *expr; + gfc_code *cp; + match m; + + expr = NULL; + + m = match_io_iterator (k, cpp); + if (m == MATCH_YES) + return MATCH_YES; + + if (k == M_READ) + { + m = gfc_match_variable (&expr, 0); + if (m == MATCH_NO) + { + gfc_error ("Expecting variable in READ statement at %C"); + m = MATCH_ERROR; + } + + if (m == MATCH_YES && expr->expr_type == EXPR_CONSTANT) + { + gfc_error ("Expecting variable or io-implied-do in READ statement " + "at %L", &expr->where); + m = MATCH_ERROR; + } + + if (m == MATCH_YES + && expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->attr.external) + { + gfc_error ("Expecting variable or io-implied-do at %L", + &expr->where); + m = MATCH_ERROR; + } + } + else + { + m = gfc_match_expr (&expr); + if (m == MATCH_NO) + gfc_error ("Expected expression in %s statement at %C", + io_kind_name (k)); + + if (m == MATCH_YES && expr->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in" + " an output IO list"), &gfc_current_locus)) + return MATCH_ERROR; + if (!gfc_boz2int (expr, gfc_max_integer_kind)) + return MATCH_ERROR; + }; + } + + if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree)) + m = MATCH_ERROR; + + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + cp = gfc_get_code (EXEC_TRANSFER); + cp->expr1 = expr; + if (k != M_INQUIRE) + cp->ext.dt = current_dt; + + *cpp = cp; + return MATCH_YES; +} + + +/* Match an I/O list, building gfc_code structures as we go. */ + +static match +match_io_list (io_kind k, gfc_code **head_p) +{ + gfc_code *head, *tail, *new_code; + match m; + + *head_p = head = tail = NULL; + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + for (;;) + { + m = match_io_element (k, &new_code); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + tail = gfc_append_code (tail, new_code); + if (head == NULL) + head = new_code; + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + *head_p = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); + +cleanup: + gfc_free_statements (head); + return MATCH_ERROR; +} + + +/* Attach the data transfer end node. */ + +static void +terminate_io (gfc_code *io_code) +{ + gfc_code *c; + + if (io_code == NULL) + io_code = new_st.block; + + c = gfc_get_code (EXEC_DT_END); + + /* Point to structure that is already there */ + c->ext.dt = new_st.ext.dt; + gfc_append_code (io_code, c); +} + + +/* Check the constraints for a data transfer statement. The majority of the + constraints appearing in 9.4 of the standard appear here. + + Tag expressions are already resolved by resolve_tag, which includes + verifying the type, that they are scalar, and verifying that BT_CHARACTER + tags are of default kind. */ + +static bool +check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, + locus *spec_end) +{ +#define io_constraint(condition, msg, arg)\ +if (condition) \ + {\ + if ((arg)->lb != NULL)\ + gfc_error ((msg), (arg));\ + else\ + gfc_error ((msg), spec_end);\ + return false;\ + } + + gfc_expr *expr; + gfc_symbol *sym = NULL; + bool warn, unformatted; + + warn = (dt->err || dt->iostat) ? true : false; + unformatted = dt->format_expr == NULL && dt->format_label == NULL + && dt->namelist == NULL; + + expr = dt->io_unit; + if (expr && expr->expr_type == EXPR_VARIABLE + && expr->ts.type == BT_CHARACTER) + { + sym = expr->symtree->n.sym; + + io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN, + "Internal file at %L must not be INTENT(IN)", + &expr->where); + + io_constraint (gfc_has_vector_index (dt->io_unit), + "Internal file incompatible with vector subscript at %L", + &expr->where); + + io_constraint (dt->rec != NULL, + "REC tag at %L is incompatible with internal file", + &dt->rec->where); + + io_constraint (dt->pos != NULL, + "POS tag at %L is incompatible with internal file", + &dt->pos->where); + + io_constraint (unformatted, + "Unformatted I/O not allowed with internal unit at %L", + &dt->io_unit->where); + + io_constraint (dt->asynchronous != NULL, + "ASYNCHRONOUS tag at %L not allowed with internal file", + &dt->asynchronous->where); + + if (dt->namelist != NULL) + { + if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " + "namelist", &expr->where)) + return false; + } + + io_constraint (dt->advance != NULL, + "ADVANCE tag at %L is incompatible with internal file", + &dt->advance->where); + } + + if (expr && expr->ts.type != BT_CHARACTER) + { + + if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE)) + { + gfc_error ("IO UNIT in %s statement at %L must be " + "an internal file in a PURE procedure", + io_kind_name (k), &expr->where); + return false; + } + + if (k == M_READ || k == M_WRITE) + gfc_unset_implicit_pure (NULL); + } + + if (dt->asynchronous) + { + int num = -1; + static const char * asynchronous[] = { "YES", "NO", NULL }; + + /* Note: gfc_reduce_init_expr reports an error if not init-expr. */ + if (!gfc_reduce_init_expr (dt->asynchronous)) + return false; + + if (!compare_to_allowed_values + ("ASYNCHRONOUS", asynchronous, NULL, NULL, + dt->asynchronous->value.character.string, + io_kind_name (k), warn, &dt->asynchronous->where, &num)) + return false; + + gcc_checking_assert (num != -1); + + /* For "YES", mark related symbols as asynchronous. */ + if (num == 0) + { + /* SIZE variable. */ + if (dt->size) + dt->size->symtree->n.sym->attr.asynchronous = 1; + + /* Variables in a NAMELIST. */ + if (dt->namelist) + for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next) + nl->sym->attr.asynchronous = 1; + + /* Variables in an I/O list. */ + for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER; + xfer = xfer->next) + { + gfc_expr *expr = xfer->expr1; + while (expr != NULL && expr->expr_type == EXPR_OP + && expr->value.op.op == INTRINSIC_PARENTHESES) + expr = expr->value.op.op1; + + if (expr && expr->expr_type == EXPR_VARIABLE) + expr->symtree->n.sym->attr.asynchronous = 1; + } + } + } + + if (dt->id) + { + bool not_yes + = !dt->asynchronous + || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 + || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, + "yes", 3) != 0; + io_constraint (not_yes, + "ID= specifier at %L must be with ASYNCHRONOUS='yes' " + "specifier", &dt->id->where); + } + + if (dt->decimal) + { + if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " + "not allowed in Fortran 95", &dt->decimal->where)) + return false; + + if (dt->decimal->expr_type == EXPR_CONSTANT) + { + static const char * decimal[] = { "COMMA", "POINT", NULL }; + + if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, + dt->decimal->value.character.string, + io_kind_name (k), warn, + &dt->decimal->where)) + return false; + + io_constraint (unformatted, + "the DECIMAL= specifier at %L must be with an " + "explicit format expression", &dt->decimal->where); + } + } + + if (dt->blank) + { + if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " + "not allowed in Fortran 95", &dt->blank->where)) + return false; + + if (dt->blank->expr_type == EXPR_CONSTANT) + { + static const char * blank[] = { "NULL", "ZERO", NULL }; + + + if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, + dt->blank->value.character.string, + io_kind_name (k), warn, + &dt->blank->where)) + return false; + + io_constraint (unformatted, + "the BLANK= specifier at %L must be with an " + "explicit format expression", &dt->blank->where); + } + } + + if (dt->pad) + { + if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L " + "not allowed in Fortran 95", &dt->pad->where)) + return false; + + if (dt->pad->expr_type == EXPR_CONSTANT) + { + static const char * pad[] = { "YES", "NO", NULL }; + + if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, + dt->pad->value.character.string, + io_kind_name (k), warn, + &dt->pad->where)) + return false; + + io_constraint (unformatted, + "the PAD= specifier at %L must be with an " + "explicit format expression", &dt->pad->where); + } + } + + if (dt->round) + { + if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " + "not allowed in Fortran 95", &dt->round->where)) + return false; + + if (dt->round->expr_type == EXPR_CONSTANT) + { + static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", + "COMPATIBLE", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, + dt->round->value.character.string, + io_kind_name (k), warn, + &dt->round->where)) + return false; + } + } + + if (dt->sign) + { + /* When implemented, change the following to use gfc_notify_std F2003. + if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " + "not allowed in Fortran 95", &dt->sign->where) == false) + return false; */ + + if (dt->sign->expr_type == EXPR_CONSTANT) + { + static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, + dt->sign->value.character.string, + io_kind_name (k), warn, &dt->sign->where)) + return false; + + io_constraint (unformatted, + "SIGN= specifier at %L must be with an " + "explicit format expression", &dt->sign->where); + + io_constraint (k == M_READ, + "SIGN= specifier at %L not allowed in a " + "READ statement", &dt->sign->where); + } + } + + if (dt->delim) + { + if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L " + "not allowed in Fortran 95", &dt->delim->where)) + return false; + + if (dt->delim->expr_type == EXPR_CONSTANT) + { + static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; + + if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, + dt->delim->value.character.string, + io_kind_name (k), warn, + &dt->delim->where)) + return false; + + io_constraint (k == M_READ, + "DELIM= specifier at %L not allowed in a " + "READ statement", &dt->delim->where); + + io_constraint (dt->format_label != &format_asterisk + && dt->namelist == NULL, + "DELIM= specifier at %L must have FMT=*", + &dt->delim->where); + + io_constraint (unformatted && dt->namelist == NULL, + "DELIM= specifier at %L must be with FMT=* or " + "NML= specifier", &dt->delim->where); + } + } + + if (dt->namelist) + { + io_constraint (io_code && dt->namelist, + "NAMELIST cannot be followed by IO-list at %L", + &io_code->loc); + + io_constraint (dt->format_expr, + "IO spec-list cannot contain both NAMELIST group name " + "and format specification at %L", + &dt->format_expr->where); + + io_constraint (dt->format_label, + "IO spec-list cannot contain both NAMELIST group name " + "and format label at %L", spec_end); + + io_constraint (dt->rec, + "NAMELIST IO is not allowed with a REC= specifier " + "at %L", &dt->rec->where); + + io_constraint (dt->advance, + "NAMELIST IO is not allowed with a ADVANCE= specifier " + "at %L", &dt->advance->where); + } + + if (dt->rec) + { + io_constraint (dt->end, + "An END tag is not allowed with a " + "REC= specifier at %L", &dt->end_where); + + io_constraint (dt->format_label == &format_asterisk, + "FMT=* is not allowed with a REC= specifier " + "at %L", spec_end); + + io_constraint (dt->pos, + "POS= is not allowed with REC= specifier " + "at %L", &dt->pos->where); + } + + if (dt->advance) + { + int not_yes, not_no; + expr = dt->advance; + + io_constraint (dt->format_label == &format_asterisk, + "List directed format(*) is not allowed with a " + "ADVANCE= specifier at %L.", &expr->where); + + io_constraint (unformatted, + "the ADVANCE= specifier at %L must appear with an " + "explicit format expression", &expr->where); + + if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) + { + const gfc_char_t *advance = expr->value.character.string; + not_no = gfc_wide_strlen (advance) != 2 + || gfc_wide_strncasecmp (advance, "no", 2) != 0; + not_yes = gfc_wide_strlen (advance) != 3 + || gfc_wide_strncasecmp (advance, "yes", 3) != 0; + } + else + { + not_no = 0; + not_yes = 0; + } + + io_constraint (not_no && not_yes, + "ADVANCE= specifier at %L must have value = " + "YES or NO.", &expr->where); + + io_constraint (dt->size && not_no && k == M_READ, + "SIZE tag at %L requires an ADVANCE = %", + &dt->size->where); + + io_constraint (dt->eor && not_no && k == M_READ, + "EOR tag at %L requires an ADVANCE = %", + &dt->eor_where); + } + + if (k != M_READ) + { + io_constraint (dt->end, "END tag not allowed with output at %L", + &dt->end_where); + + io_constraint (dt->eor, "EOR tag not allowed with output at %L", + &dt->eor_where); + + io_constraint (dt->blank, + "BLANK= specifier not allowed with output at %L", + &dt->blank->where); + + io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", + &dt->pad->where); + + io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", + &dt->size->where); + } + else + { + io_constraint (dt->size && dt->advance == NULL, + "SIZE tag at %L requires an ADVANCE tag", + &dt->size->where); + + io_constraint (dt->eor && dt->advance == NULL, + "EOR tag at %L requires an ADVANCE tag", + &dt->eor_where); + } + + return true; +#undef io_constraint +} + + +/* Match a READ, WRITE or PRINT statement. */ + +static match +match_io (io_kind k) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_code *io_code; + gfc_symbol *sym; + int comma_flag; + locus where; + locus control; + gfc_dt *dt; + match m; + + where = gfc_current_locus; + comma_flag = 0; + current_dt = dt = XCNEW (gfc_dt); + m = gfc_match_char ('('); + if (m == MATCH_NO) + { + where = gfc_current_locus; + if (k == M_WRITE) + goto syntax; + else if (k == M_PRINT) + { + /* Treat the non-standard case of PRINT namelist. */ + if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') + && gfc_match_name (name) == MATCH_YES) + { + gfc_find_symbol (name, NULL, 1, &sym); + if (sym && sym->attr.flavor == FL_NAMELIST) + { + if (!gfc_notify_std (GFC_STD_GNU, "PRINT namelist at " + "%C is an extension")) + { + m = MATCH_ERROR; + goto cleanup; + } + + dt->io_unit = default_unit (k); + dt->namelist = sym; + goto get_io_list; + } + else + gfc_current_locus = where; + } + + if (gfc_match_char ('*') == MATCH_YES + && gfc_match_char(',') == MATCH_YES) + { + locus where2 = gfc_current_locus; + if (gfc_match_eos () == MATCH_YES) + { + gfc_current_locus = where2; + gfc_error ("Comma after * at %C not allowed without I/O list"); + m = MATCH_ERROR; + goto cleanup; + } + else + gfc_current_locus = where; + } + else + gfc_current_locus = where; + } + + if (gfc_current_form == FORM_FREE) + { + char c = gfc_peek_ascii_char (); + if (c != ' ' && c != '*' && c != '\'' && c != '"') + { + m = MATCH_NO; + goto cleanup; + } + } + + m = match_dt_format (dt); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + comma_flag = 1; + dt->io_unit = default_unit (k); + goto get_io_list; + } + else + { + /* Before issuing an error for a malformed 'print (1,*)' type of + error, check for a default-char-expr of the form ('(I0)'). */ + if (m == MATCH_YES) + { + control = gfc_current_locus; + if (k == M_PRINT) + { + /* Reset current locus to get the initial '(' in an expression. */ + gfc_current_locus = where; + dt->format_expr = NULL; + m = match_dt_format (dt); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO || dt->format_expr == NULL) + goto syntax; + + comma_flag = 1; + dt->io_unit = default_unit (k); + goto get_io_list; + } + if (k == M_READ) + { + /* Commit any pending symbols now so that when we undo + symbols later we wont lose them. */ + gfc_commit_symbols (); + /* Reset current locus to get the initial '(' in an expression. */ + gfc_current_locus = where; + dt->format_expr = NULL; + m = gfc_match_expr (&dt->format_expr); + if (m == MATCH_YES) + { + if (dt->format_expr + && dt->format_expr->ts.type == BT_CHARACTER) + { + comma_flag = 1; + dt->io_unit = default_unit (k); + goto get_io_list; + } + else + { + gfc_free_expr (dt->format_expr); + dt->format_expr = NULL; + gfc_current_locus = control; + } + } + else + { + gfc_clear_error (); + gfc_undo_symbols (); + gfc_free_expr (dt->format_expr); + dt->format_expr = NULL; + gfc_current_locus = control; + } + } + } + } + + /* Match a control list */ + if (match_dt_element (k, dt) == MATCH_YES) + goto next; + if (match_dt_unit (k, dt) != MATCH_YES) + goto loop; + + if (gfc_match_char (')') == MATCH_YES) + goto get_io_list; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_dt_element (k, dt); + if (m == MATCH_YES) + goto next; + if (m == MATCH_ERROR) + goto cleanup; + + m = match_dt_format (dt); + if (m == MATCH_YES) + goto next; + if (m == MATCH_ERROR) + goto cleanup; + + where = gfc_current_locus; + + m = gfc_match_name (name); + if (m == MATCH_YES) + { + gfc_find_symbol (name, NULL, 1, &sym); + if (sym && sym->attr.flavor == FL_NAMELIST) + { + dt->namelist = sym; + if (k == M_READ && check_namelist (sym)) + { + m = MATCH_ERROR; + goto cleanup; + } + goto next; + } + } + + gfc_current_locus = where; + + goto loop; /* No matches, try regular elements */ + +next: + if (gfc_match_char (')') == MATCH_YES) + goto get_io_list; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + +loop: + for (;;) + { + m = match_dt_element (k, dt); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + +get_io_list: + + /* Save the IO kind for later use. */ + dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); + + /* Optional leading comma (non-standard). We use a gfc_expr structure here + to save the locus. This is used later when resolving transfer statements + that might have a format expression without unit number. */ + if (!comma_flag && gfc_match_char (',') == MATCH_YES) + dt->extra_comma = dt->dt_io_kind; + + io_code = NULL; + if (gfc_match_eos () != MATCH_YES) + { + if (comma_flag && gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected comma in I/O list at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + m = match_io_list (k, &io_code); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + /* See if we want to use defaults for missing exponents in real transfers + and other DEC runtime extensions. */ + if (flag_dec_format_defaults) + dt->dec_ext = 1; + + /* Check the format string now. */ + if (dt->format_expr + && (!gfc_simplify_expr (dt->format_expr, 0) + || !check_format_string (dt->format_expr, k == M_READ))) + return MATCH_ERROR; + + new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; + new_st.ext.dt = dt; + new_st.block = gfc_get_code (new_st.op); + new_st.block->next = io_code; + + terminate_io (io_code); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); + m = MATCH_ERROR; + +cleanup: + gfc_free_dt (dt); + return m; +} + + +match +gfc_match_read (void) +{ + return match_io (M_READ); +} + + +match +gfc_match_write (void) +{ + return match_io (M_WRITE); +} + + +match +gfc_match_print (void) +{ + match m; + + m = match_io (M_PRINT); + if (m != MATCH_YES) + return m; + + if (gfc_pure (NULL)) + { + gfc_error ("PRINT statement at %C not allowed within PURE procedure"); + return MATCH_ERROR; + } + + gfc_unset_implicit_pure (NULL); + + return MATCH_YES; +} + + +/* Free a gfc_inquire structure. */ + +void +gfc_free_inquire (gfc_inquire *inquire) +{ + + if (inquire == NULL) + return; + + gfc_free_expr (inquire->unit); + gfc_free_expr (inquire->file); + gfc_free_expr (inquire->iomsg); + gfc_free_expr (inquire->iostat); + gfc_free_expr (inquire->exist); + gfc_free_expr (inquire->opened); + gfc_free_expr (inquire->number); + gfc_free_expr (inquire->named); + gfc_free_expr (inquire->name); + gfc_free_expr (inquire->access); + gfc_free_expr (inquire->sequential); + gfc_free_expr (inquire->direct); + gfc_free_expr (inquire->form); + gfc_free_expr (inquire->formatted); + gfc_free_expr (inquire->unformatted); + gfc_free_expr (inquire->recl); + gfc_free_expr (inquire->nextrec); + gfc_free_expr (inquire->blank); + gfc_free_expr (inquire->position); + gfc_free_expr (inquire->action); + gfc_free_expr (inquire->read); + gfc_free_expr (inquire->write); + gfc_free_expr (inquire->readwrite); + gfc_free_expr (inquire->delim); + gfc_free_expr (inquire->encoding); + gfc_free_expr (inquire->pad); + gfc_free_expr (inquire->iolength); + gfc_free_expr (inquire->convert); + gfc_free_expr (inquire->strm_pos); + gfc_free_expr (inquire->asynchronous); + gfc_free_expr (inquire->decimal); + gfc_free_expr (inquire->pending); + gfc_free_expr (inquire->id); + gfc_free_expr (inquire->sign); + gfc_free_expr (inquire->size); + gfc_free_expr (inquire->round); + gfc_free_expr (inquire->share); + gfc_free_expr (inquire->cc); + free (inquire); +} + + +/* Match an element of an INQUIRE statement. */ + +#define RETM if (m != MATCH_NO) return m; + +static match +match_inquire_element (gfc_inquire *inquire) +{ + match m; + + m = match_etag (&tag_unit, &inquire->unit); + RETM m = match_etag (&tag_file, &inquire->file); + RETM m = match_ltag (&tag_err, &inquire->err); + RETM m = match_etag (&tag_iomsg, &inquire->iomsg); + RETM m = match_out_tag (&tag_iostat, &inquire->iostat); + RETM m = match_vtag (&tag_exist, &inquire->exist); + RETM m = match_vtag (&tag_opened, &inquire->opened); + RETM m = match_vtag (&tag_named, &inquire->named); + RETM m = match_vtag (&tag_name, &inquire->name); + RETM m = match_out_tag (&tag_number, &inquire->number); + RETM m = match_vtag (&tag_s_access, &inquire->access); + RETM m = match_vtag (&tag_sequential, &inquire->sequential); + RETM m = match_vtag (&tag_direct, &inquire->direct); + RETM m = match_vtag (&tag_s_form, &inquire->form); + RETM m = match_vtag (&tag_formatted, &inquire->formatted); + RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); + RETM m = match_out_tag (&tag_s_recl, &inquire->recl); + RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec); + RETM m = match_vtag (&tag_s_blank, &inquire->blank); + RETM m = match_vtag (&tag_s_position, &inquire->position); + RETM m = match_vtag (&tag_s_action, &inquire->action); + RETM m = match_vtag (&tag_read, &inquire->read); + RETM m = match_vtag (&tag_write, &inquire->write); + RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); + RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); + RETM m = match_vtag (&tag_s_delim, &inquire->delim); + RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); + RETM m = match_out_tag (&tag_size, &inquire->size); + RETM m = match_vtag (&tag_s_encoding, &inquire->encoding); + RETM m = match_vtag (&tag_s_round, &inquire->round); + RETM m = match_vtag (&tag_s_sign, &inquire->sign); + RETM m = match_vtag (&tag_s_pad, &inquire->pad); + RETM m = match_out_tag (&tag_iolength, &inquire->iolength); + RETM m = match_vtag (&tag_convert, &inquire->convert); + RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos); + RETM m = match_vtag (&tag_pending, &inquire->pending); + RETM m = match_vtag (&tag_id, &inquire->id); + RETM m = match_vtag (&tag_s_iqstream, &inquire->iqstream); + RETM m = match_dec_vtag (&tag_v_share, &inquire->share); + RETM m = match_dec_vtag (&tag_v_cc, &inquire->cc); + RETM return MATCH_NO; +} + +#undef RETM + + +match +gfc_match_inquire (void) +{ + gfc_inquire *inquire; + gfc_code *code; + match m; + locus loc; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + inquire = XCNEW (gfc_inquire); + + loc = gfc_current_locus; + + m = match_inquire_element (inquire); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&inquire->unit); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + /* See if we have the IOLENGTH form of the inquire statement. */ + if (inquire->iolength != NULL) + { + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_io_list (M_INQUIRE, &code); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + for (gfc_code *c = code; c; c = c->next) + if (c->expr1 && c->expr1->expr_type == EXPR_FUNCTION + && c->expr1->symtree && c->expr1->symtree->n.sym->attr.function + && !c->expr1->symtree->n.sym->attr.external + && strcmp (c->expr1->symtree->name, "null") == 0) + { + gfc_error ("NULL() near %L cannot appear in INQUIRE statement", + &c->expr1->where); + goto cleanup; + } + + new_st.op = EXEC_IOLENGTH; + new_st.expr1 = inquire->iolength; + new_st.ext.inquire = inquire; + + if (gfc_pure (NULL)) + { + gfc_free_statements (code); + gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); + return MATCH_ERROR; + } + + gfc_unset_implicit_pure (NULL); + + new_st.block = gfc_get_code (EXEC_IOLENGTH); + terminate_io (code); + new_st.block->next = code; + return MATCH_YES; + } + + /* At this point, we have the non-IOLENGTH inquire statement. */ + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_inquire_element (inquire); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (inquire->iolength != NULL) + { + gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C"); + goto cleanup; + } + } + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + if (inquire->unit != NULL && inquire->file != NULL) + { + gfc_error ("INQUIRE statement at %L cannot contain both FILE and " + "UNIT specifiers", &loc); + goto cleanup; + } + + if (inquire->unit == NULL && inquire->file == NULL) + { + gfc_error ("INQUIRE statement at %L requires either FILE or " + "UNIT specifier", &loc); + goto cleanup; + } + + if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT + && inquire->unit->ts.type == BT_INTEGER + && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4) + || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT))) + { + gfc_error ("UNIT number in INQUIRE statement at %L cannot " + "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer)); + goto cleanup; + } + + if (gfc_pure (NULL)) + { + gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + gfc_unset_implicit_pure (NULL); + + if (inquire->id != NULL && inquire->pending == NULL) + { + gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with " + "the ID= specifier", &loc); + goto cleanup; + } + + new_st.op = EXEC_INQUIRE; + new_st.ext.inquire = inquire; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_INQUIRE); + +cleanup: + gfc_free_inquire (inquire); + return MATCH_ERROR; +} + + +/* Resolve everything in a gfc_inquire structure. */ + +bool +gfc_resolve_inquire (gfc_inquire *inquire) +{ + RESOLVE_TAG (&tag_unit, inquire->unit); + RESOLVE_TAG (&tag_file, inquire->file); + RESOLVE_TAG (&tag_id, inquire->id); + + /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition + contexts. Thus, use an extended RESOLVE_TAG macro for that. */ +#define INQUIRE_RESOLVE_TAG(tag, expr) \ + RESOLVE_TAG (tag, expr); \ + if (expr) \ + { \ + char context[64]; \ + sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \ + if (gfc_check_vardef_context ((expr), false, false, false, \ + context) == false) \ + return false; \ + } + INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg); + INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat); + INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist); + INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened); + INQUIRE_RESOLVE_TAG (&tag_number, inquire->number); + INQUIRE_RESOLVE_TAG (&tag_named, inquire->named); + INQUIRE_RESOLVE_TAG (&tag_name, inquire->name); + INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access); + INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential); + INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct); + INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form); + INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted); + INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted); + INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl); + INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec); + INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank); + INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position); + INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action); + INQUIRE_RESOLVE_TAG (&tag_read, inquire->read); + INQUIRE_RESOLVE_TAG (&tag_write, inquire->write); + INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite); + INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim); + INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad); + INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding); + INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); + INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength); + INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert); + INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); + INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous); + INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign); + INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); + INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending); + INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); + INQUIRE_RESOLVE_TAG (&tag_s_decimal, inquire->decimal); + INQUIRE_RESOLVE_TAG (&tag_s_iqstream, inquire->iqstream); + INQUIRE_RESOLVE_TAG (&tag_v_share, inquire->share); + INQUIRE_RESOLVE_TAG (&tag_v_cc, inquire->cc); +#undef INQUIRE_RESOLVE_TAG + + if (!gfc_reference_st_label (inquire->err, ST_LABEL_TARGET)) + return false; + + return true; +} + + +void +gfc_free_wait (gfc_wait *wait) +{ + if (wait == NULL) + return; + + gfc_free_expr (wait->unit); + gfc_free_expr (wait->iostat); + gfc_free_expr (wait->iomsg); + gfc_free_expr (wait->id); + free (wait); +} + + +bool +gfc_resolve_wait (gfc_wait *wait) +{ + RESOLVE_TAG (&tag_unit, wait->unit); + RESOLVE_TAG (&tag_iomsg, wait->iomsg); + RESOLVE_TAG (&tag_iostat, wait->iostat); + RESOLVE_TAG (&tag_id, wait->id); + + if (!gfc_reference_st_label (wait->err, ST_LABEL_TARGET)) + return false; + + if (!gfc_reference_st_label (wait->end, ST_LABEL_TARGET)) + return false; + + return true; +} + +/* Match an element of a WAIT statement. */ + +#define RETM if (m != MATCH_NO) return m; + +static match +match_wait_element (gfc_wait *wait) +{ + match m; + + m = match_etag (&tag_unit, &wait->unit); + RETM m = match_ltag (&tag_err, &wait->err); + RETM m = match_ltag (&tag_end, &wait->end); + RETM m = match_ltag (&tag_eor, &wait->eor); + RETM m = match_etag (&tag_iomsg, &wait->iomsg); + RETM m = match_out_tag (&tag_iostat, &wait->iostat); + RETM m = match_etag (&tag_id, &wait->id); + RETM return MATCH_NO; +} + +#undef RETM + + +match +gfc_match_wait (void) +{ + gfc_wait *wait; + match m; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + wait = XCNEW (gfc_wait); + + m = match_wait_element (wait); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&wait->unit); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_wait_element (wait); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + if (!gfc_notify_std (GFC_STD_F2003, "WAIT at %C " + "not allowed in Fortran 95")) + goto cleanup; + + if (gfc_pure (NULL)) + { + gfc_error ("WAIT statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + gfc_unset_implicit_pure (NULL); + + new_st.op = EXEC_WAIT; + new_st.ext.wait = wait; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_WAIT); + +cleanup: + gfc_free_wait (wait); + return MATCH_ERROR; +} diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c deleted file mode 100644 index 97ac4eb..0000000 --- a/gcc/fortran/iresolve.c +++ /dev/null @@ -1,4050 +0,0 @@ -/* Intrinsic function resolution. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught & Katherine Holcomb - -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 -. */ - - -/* Assign name and types to intrinsic procedures. For functions, the - first argument to a resolution function is an expression pointer to - the original function node and the rest are pointers to the - arguments of the function call. For subroutines, a pointer to the - code node is passed. The result type and library subroutine name - are generally set according to the function arguments. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "gfortran.h" -#include "stringpool.h" -#include "intrinsic.h" -#include "constructor.h" -#include "arith.h" -#include "trans.h" - -/* Given printf-like arguments, return a stable version of the result string. - - We already have a working, optimized string hashing table in the form of - the identifier table. Reusing this table is likely not to be wasted, - since if the function name makes it to the gimple output of the frontend, - we'll have to create the identifier anyway. */ - -const char * -gfc_get_string (const char *format, ...) -{ - /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */ - char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1]; - const char *str; - va_list ap; - tree ident; - - /* Handle common case without vsnprintf and temporary buffer. */ - if (format[0] == '%' && format[1] == 's' && format[2] == '\0') - { - va_start (ap, format); - str = va_arg (ap, const char *); - va_end (ap); - } - else - { - int ret; - va_start (ap, format); - ret = vsnprintf (temp_name, sizeof (temp_name), format, ap); - va_end (ap); - if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */ - gfc_internal_error ("identifier overflow: %d", ret); - temp_name[sizeof (temp_name) - 1] = 0; - str = temp_name; - } - - ident = get_identifier (str); - return IDENTIFIER_POINTER (ident); -} - -/* MERGE and SPREAD need to have source charlen's present for passing - to the result expression. */ -static void -check_charlen_present (gfc_expr *source) -{ - if (source->ts.u.cl == NULL) - source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - - if (source->expr_type == EXPR_CONSTANT) - { - source->ts.u.cl->length - = gfc_get_int_expr (gfc_charlen_int_kind, NULL, - source->value.character.length); - source->rank = 0; - } - else if (source->expr_type == EXPR_ARRAY) - { - gfc_constructor *c = gfc_constructor_first (source->value.constructor); - source->ts.u.cl->length - = gfc_get_int_expr (gfc_charlen_int_kind, NULL, - c->expr->value.character.length); - } -} - -/* Helper function for resolving the "mask" argument. */ - -static void -resolve_mask_arg (gfc_expr *mask) -{ - - gfc_typespec ts; - gfc_clear_ts (&ts); - - if (mask->rank == 0) - { - /* For the scalar case, coerce the mask to kind=4 unconditionally - (because this is the only kind we have a library function - for). */ - - if (mask->ts.kind != 4) - { - ts.type = BT_LOGICAL; - ts.kind = 4; - gfc_convert_type (mask, &ts, 2); - } - } - else - { - /* In the library, we access the mask with a GFC_LOGICAL_1 - argument. No need to waste memory if we are about to create - a temporary array. */ - if (mask->expr_type == EXPR_OP && mask->ts.kind != 1) - { - ts.type = BT_LOGICAL; - ts.kind = 1; - gfc_convert_type_warn (mask, &ts, 2, 0); - } - } -} - - -static void -resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, - const char *name, bool coarray) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - - if (dim == NULL) - { - f->rank = 1; - if (array->rank != -1) - { - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) - : array->rank); - } - } - - f->value.function.name = gfc_get_string ("%s", name); -} - - -static void -resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array, - gfc_expr *dim, gfc_expr *mask) -{ - const char *prefix; - - f->ts = array->ts; - - if (mask) - { - if (mask->rank == 0) - prefix = "s"; - else - prefix = "m"; - - resolve_mask_arg (mask); - } - else - prefix = ""; - - if (dim != NULL) - { - f->rank = array->rank - 1; - f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); - gfc_resolve_dim_arg (dim); - } - - f->value.function.name - = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name, - gfc_type_letter (array->ts.type), - gfc_type_abi_kind (&array->ts)); -} - - -/********************** Resolution functions **********************/ - - -void -gfc_resolve_abs (gfc_expr *f, gfc_expr *a) -{ - f->ts = a->ts; - if (f->ts.type == BT_COMPLEX) - f->ts.type = BT_REAL; - - f->value.function.name - = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED, - gfc_expr *mode ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_c_int_kind; - f->value.function.name = PREFIX ("access_func"); -} - - -void -gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string) -{ - f->ts.type = BT_CHARACTER; - f->ts.kind = string->ts.kind; - if (string->ts.u.cl) - f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); - - f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind); -} - - -void -gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string) -{ - f->ts.type = BT_CHARACTER; - f->ts.kind = string->ts.kind; - if (string->ts.u.cl) - f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); - - f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind); -} - - -static void -gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind, - bool is_achar) -{ - f->ts.type = BT_CHARACTER; - f->ts.kind = (kind == NULL) - ? gfc_default_character_kind : mpz_get_si (kind->value.integer); - f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); - - f->value.function.name - = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind, - gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind) -{ - gfc_resolve_char_achar (f, x, kind, true); -} - - -void -gfc_resolve_acos (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_acosh (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_aimag (gfc_expr *f, gfc_expr *x) -{ - f->ts.type = BT_REAL; - f->ts.kind = x->ts.kind; - f->value.function.name - = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j) -{ - f->ts.type = i->ts.type; - f->ts.kind = gfc_kind_max (i, j); - - if (i->ts.kind != j->ts.kind) - { - if (i->ts.kind == gfc_kind_max (i, j)) - gfc_convert_type (j, &i->ts, 2); - else - gfc_convert_type (i, &j->ts, 2); - } - - f->value.function.name - = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = a->ts.type; - f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); - - if (a->ts.kind != f->ts.kind) - { - ts.type = f->ts.type; - ts.kind = f->ts.kind; - gfc_convert_type (a, &ts, 2); - } - /* The resolved name is only used for specific intrinsics where - the return kind is the same as the arg kind. */ - f->value.function.name - = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_dint (gfc_expr *f, gfc_expr *a) -{ - gfc_resolve_aint (f, a, NULL); -} - - -void -gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim) -{ - f->ts = mask->ts; - - if (dim != NULL) - { - gfc_resolve_dim_arg (dim); - f->rank = mask->rank - 1; - f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); - } - - f->value.function.name - = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type), - gfc_type_abi_kind (&mask->ts)); -} - - -void -gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = a->ts.type; - f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); - - if (a->ts.kind != f->ts.kind) - { - ts.type = f->ts.type; - ts.kind = f->ts.kind; - gfc_convert_type (a, &ts, 2); - } - - /* The resolved name is only used for specific intrinsics where - the return kind is the same as the arg kind. */ - f->value.function.name - = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_dnint (gfc_expr *f, gfc_expr *a) -{ - gfc_resolve_anint (f, a, NULL); -} - - -void -gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim) -{ - f->ts = mask->ts; - - if (dim != NULL) - { - gfc_resolve_dim_arg (dim); - f->rank = mask->rank - 1; - f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); - } - - f->value.function.name - = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type), - gfc_type_abi_kind (&mask->ts)); -} - - -void -gfc_resolve_asin (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - -void -gfc_resolve_asinh (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - -void -gfc_resolve_atan (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - -void -gfc_resolve_atanh (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - -void -gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -/* Resolve the BESYN and BESJN intrinsics. */ - -void -gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts = x->ts; - if (n->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - gfc_convert_type (n, &ts, 2); - } - f->value.function.name = gfc_get_string (""); -} - - -void -gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts = x->ts; - f->rank = 1; - if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT) - { - f->shape = gfc_get_shape (1); - mpz_init (f->shape[0]); - mpz_sub (f->shape[0], n2->value.integer, n1->value.integer); - mpz_add_ui (f->shape[0], f->shape[0], 1); - } - - if (n1->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - gfc_convert_type (n1, &ts, 2); - } - - if (n2->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - gfc_convert_type (n2, &ts, 2); - } - - if (f->value.function.isym->id == GFC_ISYM_JN2) - f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"), - gfc_type_abi_kind (&f->ts)); - else - f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"), - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos) -{ - f->ts.type = BT_LOGICAL; - f->ts.kind = gfc_default_logical_kind; - f->value.function.name - = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind); -} - - -void -gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED) -{ - f->ts = f->value.function.isym->ts; -} - - -void -gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED) -{ - f->ts = f->value.function.isym->ts; -} - - -void -gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = (kind == NULL) - ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); - f->value.function.name - = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - gfc_resolve_char_achar (f, a, kind, false); -} - - -void -gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind); -} - - -void -gfc_resolve_chdir_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->expr != NULL) - kind = c->ext.actual->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED, - gfc_expr *mode ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_c_int_kind; - f->value.function.name = PREFIX ("chmod_func"); -} - - -void -gfc_resolve_chmod_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->next->expr != NULL) - kind = c->ext.actual->next->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind) -{ - f->ts.type = BT_COMPLEX; - f->ts.kind = (kind == NULL) - ? gfc_default_real_kind : mpz_get_si (kind->value.integer); - - if (y == NULL) - f->value.function.name - = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind, - gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); - else - f->value.function.name - = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, - gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts), - gfc_type_letter (y->ts.type), - gfc_type_abi_kind (&y->ts)); -} - - -void -gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y) -{ - gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL, - gfc_default_double_kind)); -} - - -void -gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y) -{ - int kind; - - if (x->ts.type == BT_INTEGER) - { - if (y->ts.type == BT_INTEGER) - kind = gfc_default_real_kind; - else - kind = y->ts.kind; - } - else - { - if (y->ts.type == BT_REAL) - kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; - else - kind = x->ts.kind; - } - - f->ts.type = BT_COMPLEX; - f->ts.kind = kind; - f->value.function.name - = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, - gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts), - gfc_type_letter (y->ts.type), - gfc_type_abi_kind (&y->ts)); -} - - -void -gfc_resolve_conjg (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind); -} - - -void -gfc_resolve_cos (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_cosh (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - - if (dim != NULL) - { - f->rank = mask->rank - 1; - gfc_resolve_dim_arg (dim); - f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); - } - - resolve_mask_arg (mask); - - f->value.function.name - = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f->ts), - gfc_type_letter (mask->ts.type)); -} - - -void -gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, - gfc_expr *dim) -{ - int n, m; - - if (array->ts.type == BT_CHARACTER && array->ref) - gfc_resolve_substring_charlen (array); - - f->ts = array->ts; - f->rank = array->rank; - f->shape = gfc_copy_shape (array->shape, array->rank); - - if (shift->rank > 0) - n = 1; - else - n = 0; - - /* If dim kind is greater than default integer we need to use the larger. */ - m = gfc_default_integer_kind; - if (dim != NULL) - m = m < dim->ts.kind ? dim->ts.kind : m; - - /* Convert shift to at least m, so we don't need - kind=1 and kind=2 versions of the library functions. */ - if (shift->ts.kind < m) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = m; - gfc_convert_type_warn (shift, &ts, 2, 0); - } - - if (dim != NULL) - { - if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL - && dim->symtree->n.sym->attr.optional) - { - /* Mark this for later setting the type in gfc_conv_missing_dummy. */ - dim->representation.length = shift->ts.kind; - } - else - { - gfc_resolve_dim_arg (dim); - /* Convert dim to shift's kind to reduce variations. */ - if (dim->ts.kind != shift->ts.kind) - gfc_convert_type_warn (dim, &shift->ts, 2, 0); - } - } - - if (array->ts.type == BT_CHARACTER) - { - if (array->ts.kind == gfc_default_character_kind) - f->value.function.name - = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind); - else - f->value.function.name - = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind, - array->ts.kind); - } - else - f->value.function.name - = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind); -} - - -void -gfc_resolve_ctime (gfc_expr *f, gfc_expr *time) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = BT_CHARACTER; - f->ts.kind = gfc_default_character_kind; - - /* ctime TIME argument is a INTEGER(KIND=8), says the doc */ - if (time->ts.kind != 8) - { - ts.type = BT_INTEGER; - ts.kind = 8; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (time, &ts, 2); - } - - f->value.function.name = gfc_get_string (PREFIX ("ctime")); -} - - -void -gfc_resolve_dble (gfc_expr *f, gfc_expr *a) -{ - f->ts.type = BT_REAL; - f->ts.kind = gfc_default_double_kind; - f->value.function.name - = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p) -{ - f->ts.type = a->ts.type; - if (p != NULL) - f->ts.kind = gfc_kind_max (a,p); - else - f->ts.kind = a->ts.kind; - - if (p != NULL && a->ts.kind != p->ts.kind) - { - if (a->ts.kind == gfc_kind_max (a,p)) - gfc_convert_type (p, &a->ts, 2); - else - gfc_convert_type (a, &p->ts, 2); - } - - f->value.function.name - = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b) -{ - gfc_expr temp; - - temp.expr_type = EXPR_OP; - gfc_clear_ts (&temp.ts); - temp.value.op.op = INTRINSIC_NONE; - temp.value.op.op1 = a; - temp.value.op.op2 = b; - gfc_type_convert_binary (&temp, 1); - f->ts = temp.ts; - f->value.function.name - = gfc_get_string (PREFIX ("dot_product_%c%d"), - gfc_type_letter (f->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, - gfc_expr *b ATTRIBUTE_UNUSED) -{ - f->ts.kind = gfc_default_double_kind; - f->ts.type = BT_REAL; - f->value.function.name = gfc_get_string ("__dprod_r%d", - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED, - gfc_expr *shift ATTRIBUTE_UNUSED) -{ - f->ts = i->ts; - if (f->value.function.isym->id == GFC_ISYM_DSHIFTL) - f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind); - else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR) - f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind); - else - gcc_unreachable (); -} - - -void -gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, - gfc_expr *boundary, gfc_expr *dim) -{ - int n, m; - - if (array->ts.type == BT_CHARACTER && array->ref) - gfc_resolve_substring_charlen (array); - - f->ts = array->ts; - f->rank = array->rank; - f->shape = gfc_copy_shape (array->shape, array->rank); - - n = 0; - if (shift->rank > 0) - n = n | 1; - if (boundary && boundary->rank > 0) - n = n | 2; - - /* If dim kind is greater than default integer we need to use the larger. */ - m = gfc_default_integer_kind; - if (dim != NULL) - m = m < dim->ts.kind ? dim->ts.kind : m; - - /* Convert shift to at least m, so we don't need - kind=1 and kind=2 versions of the library functions. */ - if (shift->ts.kind < m) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = m; - gfc_convert_type_warn (shift, &ts, 2, 0); - } - - if (dim != NULL) - { - if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL - && dim->symtree->n.sym->attr.optional) - { - /* Mark this for later setting the type in gfc_conv_missing_dummy. */ - dim->representation.length = shift->ts.kind; - } - else - { - gfc_resolve_dim_arg (dim); - /* Convert dim to shift's kind to reduce variations. */ - if (dim->ts.kind != shift->ts.kind) - gfc_convert_type_warn (dim, &shift->ts, 2, 0); - } - } - - if (array->ts.type == BT_CHARACTER) - { - if (array->ts.kind == gfc_default_character_kind) - f->value.function.name - = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind); - else - f->value.function.name - = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind, - array->ts.kind); - } - else - f->value.function.name - = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind); -} - - -void -gfc_resolve_exp (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_exponent (gfc_expr *f, gfc_expr *x) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind); -} - - -/* Resolve the EXTENDS_TYPE_OF intrinsic function. */ - -void -gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) -{ - gfc_symbol *vtab; - gfc_symtree *st; - - /* Prevent double resolution. */ - if (f->ts.type == BT_LOGICAL) - return; - - /* Replace the first argument with the corresponding vtab. */ - if (a->ts.type == BT_CLASS) - gfc_add_vptr_component (a); - else if (a->ts.type == BT_DERIVED) - { - locus where; - - vtab = gfc_find_derived_vtab (a->ts.u.derived); - /* Clear the old expr. */ - gfc_free_ref_list (a->ref); - where = a->where; - memset (a, '\0', sizeof (gfc_expr)); - /* Construct a new one. */ - a->expr_type = EXPR_VARIABLE; - st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); - a->symtree = st; - a->ts = vtab->ts; - a->where = where; - } - - /* Replace the second argument with the corresponding vtab. */ - if (mo->ts.type == BT_CLASS) - gfc_add_vptr_component (mo); - else if (mo->ts.type == BT_DERIVED) - { - locus where; - - vtab = gfc_find_derived_vtab (mo->ts.u.derived); - /* Clear the old expr. */ - where = mo->where; - gfc_free_ref_list (mo->ref); - memset (mo, '\0', sizeof (gfc_expr)); - /* Construct a new one. */ - mo->expr_type = EXPR_VARIABLE; - st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); - mo->symtree = st; - mo->ts = vtab->ts; - mo->where = where; - } - - f->ts.type = BT_LOGICAL; - f->ts.kind = 4; - - f->value.function.isym->formal->ts = a->ts; - f->value.function.isym->formal->next->ts = mo->ts; - - /* Call library function. */ - f->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); -} - - -void -gfc_resolve_fdate (gfc_expr *f) -{ - f->ts.type = BT_CHARACTER; - f->ts.kind = gfc_default_character_kind; - f->value.function.name = gfc_get_string (PREFIX ("fdate")); -} - - -void -gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = (kind == NULL) - ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); - f->value.function.name - = gfc_get_string ("__floor%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_fnum (gfc_expr *f, gfc_expr *n) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - if (n->ts.kind != f->ts.kind) - gfc_convert_type (n, &f->ts, 2); - f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind); -} - - -void -gfc_resolve_fraction (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind); -} - - -/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */ - -void -gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string (""); -} - - -void -gfc_resolve_gamma (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__tgamma_%d", x->ts.kind); -} - - -void -gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("getcwd")); -} - - -void -gfc_resolve_getgid (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("getgid")); -} - - -void -gfc_resolve_getpid (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("getpid")); -} - - -void -gfc_resolve_getuid (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("getuid")); -} - - -void -gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("hostnm")); -} - - -void -gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string ("__hypot_r%d", - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - resolve_transformational ("iall", f, array, dim, mask); -} - - -void -gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) -{ - /* If the kind of i and j are different, then g77 cross-promoted the - kinds to the largest value. The Fortran 95 standard requires the - kinds to match. */ - if (i->ts.kind != j->ts.kind) - { - if (i->ts.kind == gfc_kind_max (i, j)) - gfc_convert_type (j, &i->ts, 2); - else - gfc_convert_type (i, &j->ts, 2); - } - - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind); -} - - -void -gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - resolve_transformational ("iany", f, array, dim, mask); -} - - -void -gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) -{ - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind); -} - - -void -gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED, - gfc_expr *len ATTRIBUTE_UNUSED) -{ - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind); -} - - -void -gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) -{ - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind); -} - - -void -gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); -} - - -void -gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); -} - - -void -gfc_resolve_idnint (gfc_expr *f, gfc_expr *a) -{ - gfc_resolve_nint (f, a, NULL); -} - - -void -gfc_resolve_ierrno (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind); -} - - -void -gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j) -{ - /* If the kind of i and j are different, then g77 cross-promoted the - kinds to the largest value. The Fortran 95 standard requires the - kinds to match. */ - if (i->ts.kind != j->ts.kind) - { - if (i->ts.kind == gfc_kind_max (i, j)) - gfc_convert_type (j, &i->ts, 2); - else - gfc_convert_type (i, &j->ts, 2); - } - - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind); -} - - -void -gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) -{ - /* If the kind of i and j are different, then g77 cross-promoted the - kinds to the largest value. The Fortran 95 standard requires the - kinds to match. */ - if (i->ts.kind != j->ts.kind) - { - if (i->ts.kind == gfc_kind_max (i, j)) - gfc_convert_type (j, &i->ts, 2); - else - gfc_convert_type (i, &j->ts, 2); - } - - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind); -} - - -void -gfc_resolve_index_func (gfc_expr *f, gfc_expr *str, - gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back, - gfc_expr *kind) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - - if (back && back->ts.kind != gfc_default_integer_kind) - { - ts.type = BT_LOGICAL; - ts.kind = gfc_default_integer_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (back, &ts, 2); - } - - f->value.function.name - = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind); -} - - -void -gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = (kind == NULL) - ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); - f->value.function.name - = gfc_get_string ("__int_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_int2 (gfc_expr *f, gfc_expr *a) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 2; - f->value.function.name - = gfc_get_string ("__int_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_int8 (gfc_expr *f, gfc_expr *a) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 8; - f->value.function.name - = gfc_get_string ("__int_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_long (gfc_expr *f, gfc_expr *a) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name - = gfc_get_string ("__int_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - resolve_transformational ("iparity", f, array, dim, mask); -} - - -void -gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = BT_LOGICAL; - f->ts.kind = gfc_default_integer_kind; - if (u->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (u, &ts, 2); - } - - f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind); -} - - -void -gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_LOGICAL; - f->ts.kind = gfc_default_logical_kind; - f->value.function.name = gfc_get_string ("__is_contiguous"); -} - - -void -gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift) -{ - f->ts = i->ts; - f->value.function.name - = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind); -} - - -void -gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift) -{ - f->ts = i->ts; - f->value.function.name - = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind); -} - - -void -gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift) -{ - f->ts = i->ts; - f->value.function.name - = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind); -} - - -void -gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size) -{ - int s_kind; - - s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind; - - f->ts = i->ts; - f->value.function.name - = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind); -} - - -void -gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - resolve_bound (f, array, dim, kind, "__lbound", false); -} - - -void -gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - resolve_bound (f, array, dim, kind, "__lcobound", true); -} - - -void -gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - f->value.function.name - = gfc_get_string ("__len_%d_i%d", string->ts.kind, - gfc_default_integer_kind); -} - - -void -gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind); -} - - -void -gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__lgamma_%d", x->ts.kind); -} - - -void -gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, - gfc_expr *p2 ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind); -} - - -void -gfc_resolve_loc (gfc_expr *f, gfc_expr *x) -{ - f->ts.type= BT_INTEGER; - f->ts.kind = gfc_index_integer_kind; - f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind); -} - - -void -gfc_resolve_log (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_log10 (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - f->ts.type = BT_LOGICAL; - f->ts.kind = (kind == NULL) - ? gfc_default_logical_kind : mpz_get_si (kind->value.integer); - f->rank = a->rank; - - f->value.function.name - = gfc_get_string ("__logical_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b) -{ - gfc_expr temp; - - if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) - { - f->ts.type = BT_LOGICAL; - f->ts.kind = gfc_default_logical_kind; - } - else - { - temp.expr_type = EXPR_OP; - gfc_clear_ts (&temp.ts); - temp.value.op.op = INTRINSIC_NONE; - temp.value.op.op1 = a; - temp.value.op.op2 = b; - gfc_type_convert_binary (&temp, 1); - f->ts = temp.ts; - } - - f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1; - - if (a->rank == 2 && b->rank == 2) - { - if (a->shape && b->shape) - { - f->shape = gfc_get_shape (f->rank); - mpz_init_set (f->shape[0], a->shape[0]); - mpz_init_set (f->shape[1], b->shape[1]); - } - } - else if (a->rank == 1) - { - if (b->shape) - { - f->shape = gfc_get_shape (f->rank); - mpz_init_set (f->shape[0], b->shape[1]); - } - } - else - { - /* b->rank == 1 and a->rank == 2 here, all other cases have - been caught in check.c. */ - if (a->shape) - { - f->shape = gfc_get_shape (f->rank); - mpz_init_set (f->shape[0], a->shape[0]); - } - } - - f->value.function.name - = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -static void -gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args) -{ - gfc_actual_arglist *a; - - f->ts.type = args->expr->ts.type; - f->ts.kind = args->expr->ts.kind; - /* Find the largest type kind. */ - for (a = args->next; a; a = a->next) - { - if (a->expr->ts.kind > f->ts.kind) - f->ts.kind = a->expr->ts.kind; - } - - /* Convert all parameters to the required kind. */ - for (a = args; a; a = a->next) - { - if (a->expr->ts.kind != f->ts.kind) - gfc_convert_type (a->expr, &f->ts, 2); - } - - f->value.function.name - = gfc_get_string (name, gfc_type_letter (f->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args) -{ - gfc_resolve_minmax ("__max_%c%d", f, args); -} - -/* The smallest kind for which a minloc and maxloc implementation exists. */ - -#define MINMAXLOC_MIN_KIND 4 - -void -gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask, gfc_expr *kind, gfc_expr *back) -{ - const char *name; - int i, j, idim; - int fkind; - int d_num; - - f->ts.type = BT_INTEGER; - - /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, - we do a type conversion further down. */ - if (kind) - fkind = mpz_get_si (kind->value.integer); - else - fkind = gfc_default_integer_kind; - - if (fkind < MINMAXLOC_MIN_KIND) - f->ts.kind = MINMAXLOC_MIN_KIND; - else - f->ts.kind = fkind; - - if (dim == NULL) - { - f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_si (f->shape[0], array->rank); - } - else - { - f->rank = array->rank - 1; - gfc_resolve_dim_arg (dim); - if (array->shape && dim->expr_type == EXPR_CONSTANT) - { - idim = (int) mpz_get_si (dim->value.integer); - f->shape = gfc_get_shape (f->rank); - for (i = 0, j = 0; i < f->rank; i++, j++) - { - if (i == (idim - 1)) - j++; - mpz_init_set (f->shape[i], array->shape[j]); - } - } - } - - if (mask) - { - if (mask->rank == 0) - name = "smaxloc"; - else - name = "mmaxloc"; - - resolve_mask_arg (mask); - } - else - name = "maxloc"; - - if (dim) - { - if (array->ts.type != BT_CHARACTER || f->rank != 0) - d_num = 1; - else - d_num = 2; - } - else - d_num = 0; - - f->value.function.name - = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind, - gfc_type_letter (array->ts.type), - gfc_type_abi_kind (&array->ts)); - - if (kind) - fkind = mpz_get_si (kind->value.integer); - else - fkind = gfc_default_integer_kind; - - if (fkind != f->ts.kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - - ts.type = BT_INTEGER; - ts.kind = fkind; - gfc_convert_type_warn (f, &ts, 2, 0); - } - - if (back->ts.kind != gfc_logical_4_kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_LOGICAL; - ts.kind = gfc_logical_4_kind; - gfc_convert_type_warn (back, &ts, 2, 0); - } -} - - -void -gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value, - gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, - gfc_expr *back) -{ - const char *name; - int i, j, idim; - int fkind; - int d_num; - - /* See at the end of the function for why this is necessary. */ - - if (f->do_not_resolve_again) - return; - - f->ts.type = BT_INTEGER; - - /* We have a single library version, which uses index_type. */ - - if (kind) - fkind = mpz_get_si (kind->value.integer); - else - fkind = gfc_default_integer_kind; - - f->ts.kind = gfc_index_integer_kind; - - /* Convert value. If array is not LOGICAL and value is, we already - issued an error earlier. */ - - if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL) - || array->ts.kind != value->ts.kind) - gfc_convert_type_warn (value, &array->ts, 2, 0); - - if (dim == NULL) - { - f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_si (f->shape[0], array->rank); - } - else - { - f->rank = array->rank - 1; - gfc_resolve_dim_arg (dim); - if (array->shape && dim->expr_type == EXPR_CONSTANT) - { - idim = (int) mpz_get_si (dim->value.integer); - f->shape = gfc_get_shape (f->rank); - for (i = 0, j = 0; i < f->rank; i++, j++) - { - if (i == (idim - 1)) - j++; - mpz_init_set (f->shape[i], array->shape[j]); - } - } - } - - if (mask) - { - if (mask->rank == 0) - name = "sfindloc"; - else - name = "mfindloc"; - - resolve_mask_arg (mask); - } - else - name = "findloc"; - - if (dim) - { - if (f->rank > 0) - d_num = 1; - else - d_num = 2; - } - else - d_num = 0; - - if (back->ts.kind != gfc_logical_4_kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_LOGICAL; - ts.kind = gfc_logical_4_kind; - gfc_convert_type_warn (back, &ts, 2, 0); - } - - f->value.function.name - = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num, - gfc_type_letter (array->ts.type, true), - gfc_type_abi_kind (&array->ts)); - - /* We only have a single library function, so we need to convert - here. If the function is resolved from within a convert - function generated on a previous round of resolution, endless - recursion could occur. Guard against that here. */ - - if (f->ts.kind != fkind) - { - f->do_not_resolve_again = 1; - gfc_typespec ts; - gfc_clear_ts (&ts); - - ts.type = BT_INTEGER; - ts.kind = fkind; - gfc_convert_type_warn (f, &ts, 2, 0); - } - -} - -void -gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) -{ - const char *name; - int i, j, idim; - - f->ts = array->ts; - - if (dim != NULL) - { - f->rank = array->rank - 1; - gfc_resolve_dim_arg (dim); - - if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) - { - idim = (int) mpz_get_si (dim->value.integer); - f->shape = gfc_get_shape (f->rank); - for (i = 0, j = 0; i < f->rank; i++, j++) - { - if (i == (idim - 1)) - j++; - mpz_init_set (f->shape[i], array->shape[j]); - } - } - } - - if (mask) - { - if (mask->rank == 0) - name = "smaxval"; - else - name = "mmaxval"; - - resolve_mask_arg (mask); - } - else - name = "maxval"; - - if (array->ts.type != BT_CHARACTER) - f->value.function.name - = gfc_get_string (PREFIX ("%s_%c%d"), name, - gfc_type_letter (array->ts.type), - gfc_type_abi_kind (&array->ts)); - else - f->value.function.name - = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0, - gfc_type_letter (array->ts.type), - gfc_type_abi_kind (&array->ts)); -} - - -void -gfc_resolve_mclock (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = PREFIX ("mclock"); -} - - -void -gfc_resolve_mclock8 (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 8; - f->value.function.name = PREFIX ("mclock8"); -} - - -void -gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED, - gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = kind ? mpz_get_si (kind->value.integer) - : gfc_default_integer_kind; - - if (f->value.function.isym->id == GFC_ISYM_MASKL) - f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind); - else - f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind); -} - - -void -gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource, - gfc_expr *fsource ATTRIBUTE_UNUSED, - gfc_expr *mask ATTRIBUTE_UNUSED) -{ - if (tsource->ts.type == BT_CHARACTER && tsource->ref) - gfc_resolve_substring_charlen (tsource); - - if (fsource->ts.type == BT_CHARACTER && fsource->ref) - gfc_resolve_substring_charlen (fsource); - - if (tsource->ts.type == BT_CHARACTER) - check_charlen_present (tsource); - - f->ts = tsource->ts; - f->value.function.name - = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type), - gfc_type_abi_kind (&tsource->ts)); -} - - -void -gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i, - gfc_expr *j ATTRIBUTE_UNUSED, - gfc_expr *mask ATTRIBUTE_UNUSED) -{ - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind); -} - - -void -gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args) -{ - gfc_resolve_minmax ("__min_%c%d", f, args); -} - - -void -gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask, gfc_expr *kind, gfc_expr *back) -{ - const char *name; - int i, j, idim; - int fkind; - int d_num; - - f->ts.type = BT_INTEGER; - - /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, - we do a type conversion further down. */ - if (kind) - fkind = mpz_get_si (kind->value.integer); - else - fkind = gfc_default_integer_kind; - - if (fkind < MINMAXLOC_MIN_KIND) - f->ts.kind = MINMAXLOC_MIN_KIND; - else - f->ts.kind = fkind; - - if (dim == NULL) - { - f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_si (f->shape[0], array->rank); - } - else - { - f->rank = array->rank - 1; - gfc_resolve_dim_arg (dim); - if (array->shape && dim->expr_type == EXPR_CONSTANT) - { - idim = (int) mpz_get_si (dim->value.integer); - f->shape = gfc_get_shape (f->rank); - for (i = 0, j = 0; i < f->rank; i++, j++) - { - if (i == (idim - 1)) - j++; - mpz_init_set (f->shape[i], array->shape[j]); - } - } - } - - if (mask) - { - if (mask->rank == 0) - name = "sminloc"; - else - name = "mminloc"; - - resolve_mask_arg (mask); - } - else - name = "minloc"; - - if (dim) - { - if (array->ts.type != BT_CHARACTER || f->rank != 0) - d_num = 1; - else - d_num = 2; - } - else - d_num = 0; - - f->value.function.name - = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind, - gfc_type_letter (array->ts.type), - gfc_type_abi_kind (&array->ts)); - - if (fkind != f->ts.kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - - ts.type = BT_INTEGER; - ts.kind = fkind; - gfc_convert_type_warn (f, &ts, 2, 0); - } - - if (back->ts.kind != gfc_logical_4_kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - ts.type = BT_LOGICAL; - ts.kind = gfc_logical_4_kind; - gfc_convert_type_warn (back, &ts, 2, 0); - } -} - - -void -gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) -{ - const char *name; - int i, j, idim; - - f->ts = array->ts; - - if (dim != NULL) - { - f->rank = array->rank - 1; - gfc_resolve_dim_arg (dim); - - if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) - { - idim = (int) mpz_get_si (dim->value.integer); - f->shape = gfc_get_shape (f->rank); - for (i = 0, j = 0; i < f->rank; i++, j++) - { - if (i == (idim - 1)) - j++; - mpz_init_set (f->shape[i], array->shape[j]); - } - } - } - - if (mask) - { - if (mask->rank == 0) - name = "sminval"; - else - name = "mminval"; - - resolve_mask_arg (mask); - } - else - name = "minval"; - - if (array->ts.type != BT_CHARACTER) - f->value.function.name - = gfc_get_string (PREFIX ("%s_%c%d"), name, - gfc_type_letter (array->ts.type), - gfc_type_abi_kind (&array->ts)); - else - f->value.function.name - = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0, - gfc_type_letter (array->ts.type), - gfc_type_abi_kind (&array->ts)); -} - - -void -gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p) -{ - f->ts.type = a->ts.type; - if (p != NULL) - f->ts.kind = gfc_kind_max (a,p); - else - f->ts.kind = a->ts.kind; - - if (p != NULL && a->ts.kind != p->ts.kind) - { - if (a->ts.kind == gfc_kind_max (a,p)) - gfc_convert_type (p, &a->ts, 2); - else - gfc_convert_type (a, &p->ts, 2); - } - - f->value.function.name - = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p) -{ - f->ts.type = a->ts.type; - if (p != NULL) - f->ts.kind = gfc_kind_max (a,p); - else - f->ts.kind = a->ts.kind; - - if (p != NULL && a->ts.kind != p->ts.kind) - { - if (a->ts.kind == gfc_kind_max (a,p)) - gfc_convert_type (p, &a->ts, 2); - else - gfc_convert_type (a, &p->ts, 2); - } - - f->value.function.name - = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type), - gfc_type_abi_kind (&f->ts)); -} - -void -gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p) -{ - if (p->ts.kind != a->ts.kind) - gfc_convert_type (p, &a->ts, 2); - - f->ts = a->ts; - f->value.function.name - = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - -void -gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = (kind == NULL) - ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); - f->value.function.name - = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind); -} - - -void -gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim) -{ - resolve_transformational ("norm2", f, array, dim, NULL); -} - - -void -gfc_resolve_not (gfc_expr *f, gfc_expr *i) -{ - f->ts = i->ts; - f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind); -} - - -void -gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j) -{ - f->ts.type = i->ts.type; - f->ts.kind = gfc_kind_max (i, j); - - if (i->ts.kind != j->ts.kind) - { - if (i->ts.kind == gfc_kind_max (i, j)) - gfc_convert_type (j, &i->ts, 2); - else - gfc_convert_type (i, &j->ts, 2); - } - - f->value.function.name - = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -void -gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, - gfc_expr *vector ATTRIBUTE_UNUSED) -{ - if (array->ts.type == BT_CHARACTER && array->ref) - gfc_resolve_substring_charlen (array); - - f->ts = array->ts; - f->rank = 1; - - resolve_mask_arg (mask); - - if (mask->rank != 0) - { - if (array->ts.type == BT_CHARACTER) - f->value.function.name - = array->ts.kind == 1 ? PREFIX ("pack_char") - : gfc_get_string - (PREFIX ("pack_char%d"), - array->ts.kind); - else - f->value.function.name = PREFIX ("pack"); - } - else - { - if (array->ts.type == BT_CHARACTER) - f->value.function.name - = array->ts.kind == 1 ? PREFIX ("pack_s_char") - : gfc_get_string - (PREFIX ("pack_s_char%d"), - array->ts.kind); - else - f->value.function.name = PREFIX ("pack_s"); - } -} - - -void -gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim) -{ - resolve_transformational ("parity", f, array, dim, NULL); -} - - -void -gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) -{ - resolve_transformational ("product", f, array, dim, mask); -} - - -void -gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string ("__rank"); -} - - -void -gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind) -{ - f->ts.type = BT_REAL; - - if (kind != NULL) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = (a->ts.type == BT_COMPLEX) - ? a->ts.kind : gfc_default_real_kind; - - f->value.function.name - = gfc_get_string ("__real_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_realpart (gfc_expr *f, gfc_expr *a) -{ - f->ts.type = BT_REAL; - f->ts.kind = a->ts.kind; - f->value.function.name - = gfc_get_string ("__real_%d_%c%d", f->ts.kind, - gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, - gfc_expr *p2 ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind); -} - - -void -gfc_resolve_repeat (gfc_expr *f, gfc_expr *string, - gfc_expr *ncopies) -{ - gfc_expr *tmp; - f->ts.type = BT_CHARACTER; - f->ts.kind = string->ts.kind; - f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind); - - /* If possible, generate a character length. */ - if (f->ts.u.cl == NULL) - f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - - tmp = NULL; - if (string->expr_type == EXPR_CONSTANT) - { - tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL, - string->value.character.length); - } - else if (string->ts.u.cl && string->ts.u.cl->length) - { - tmp = gfc_copy_expr (string->ts.u.cl->length); - } - - if (tmp) - f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies)); -} - - -void -gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape, - gfc_expr *pad ATTRIBUTE_UNUSED, - gfc_expr *order ATTRIBUTE_UNUSED) -{ - mpz_t rank; - int kind; - int i; - - if (source->ts.type == BT_CHARACTER && source->ref) - gfc_resolve_substring_charlen (source); - - f->ts = source->ts; - - gfc_array_size (shape, &rank); - f->rank = mpz_get_si (rank); - mpz_clear (rank); - switch (source->ts.type) - { - case BT_COMPLEX: - case BT_REAL: - case BT_INTEGER: - case BT_LOGICAL: - case BT_CHARACTER: - kind = source->ts.kind; - break; - - default: - kind = 0; - break; - } - - switch (kind) - { - case 4: - case 8: - case 10: - case 16: - if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL) - f->value.function.name - = gfc_get_string (PREFIX ("reshape_%c%d"), - gfc_type_letter (source->ts.type), - gfc_type_abi_kind (&source->ts)); - else if (source->ts.type == BT_CHARACTER) - f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"), - kind); - else - f->value.function.name - = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind); - break; - - default: - f->value.function.name = (source->ts.type == BT_CHARACTER - ? PREFIX ("reshape_char") : PREFIX ("reshape")); - break; - } - - if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape)) - { - gfc_constructor *c; - f->shape = gfc_get_shape (f->rank); - c = gfc_constructor_first (shape->value.constructor); - for (i = 0; i < f->rank; i++) - { - mpz_init_set (f->shape[i], c->expr->value.integer); - c = gfc_constructor_next (c); - } - } - - /* Force-convert both SHAPE and ORDER to index_kind so that we don't need - so many runtime variations. */ - if (shape->ts.kind != gfc_index_integer_kind) - { - gfc_typespec ts = shape->ts; - ts.kind = gfc_index_integer_kind; - gfc_convert_type_warn (shape, &ts, 2, 0); - } - if (order && order->ts.kind != gfc_index_integer_kind) - gfc_convert_type_warn (order, &shape->ts, 2, 0); -} - - -void -gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind); -} - -void -gfc_resolve_fe_runtime_error (gfc_code *c) -{ - const char *name; - gfc_actual_arglist *a; - - name = gfc_get_string (PREFIX ("runtime_error")); - - for (a = c->ext.actual->next; a; a = a->next) - a->name = "%VAL"; - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); - /* We set the backend_decl here because runtime_error is a - variadic function and we would use the wrong calling - convention otherwise. */ - c->resolved_sym->backend_decl = gfor_fndecl_runtime_error; -} - -void -gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind); -} - - -void -gfc_resolve_scan (gfc_expr *f, gfc_expr *string, - gfc_expr *set ATTRIBUTE_UNUSED, - gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind); -} - - -void -gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0) -{ - t1->ts = t0->ts; - t1->value.function.name = gfc_get_string (PREFIX ("secnds")); -} - - -void -gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, - gfc_expr *i ATTRIBUTE_UNUSED) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind); -} - - -void -gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - - f->rank = 1; - if (array->rank != -1) - { - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); - } - - f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind); -} - - -void -gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED) -{ - f->ts = i->ts; - if (f->value.function.isym->id == GFC_ISYM_SHIFTA) - f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind); - else if (f->value.function.isym->id == GFC_ISYM_SHIFTL) - f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind); - else if (f->value.function.isym->id == GFC_ISYM_SHIFTR) - f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind); - else - gcc_unreachable (); -} - - -void -gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED) -{ - f->ts = a->ts; - f->value.function.name - = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), - gfc_type_abi_kind (&a->ts)); -} - - -void -gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_c_int_kind; - - /* handler can be either BT_INTEGER or BT_PROCEDURE */ - if (handler->ts.type == BT_INTEGER) - { - if (handler->ts.kind != gfc_c_int_kind) - gfc_convert_type (handler, &f->ts, 2); - f->value.function.name = gfc_get_string (PREFIX ("signal_func_int")); - } - else - f->value.function.name = gfc_get_string (PREFIX ("signal_func")); - - if (number->ts.kind != gfc_c_int_kind) - gfc_convert_type (number, &f->ts, 2); -} - - -void -gfc_resolve_sin (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_sinh (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, - gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; -} - - -void -gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, - gfc_expr *dim ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_index_integer_kind; -} - - -void -gfc_resolve_spacing (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind); -} - - -void -gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim, - gfc_expr *ncopies) -{ - if (source->ts.type == BT_CHARACTER && source->ref) - gfc_resolve_substring_charlen (source); - - if (source->ts.type == BT_CHARACTER) - check_charlen_present (source); - - f->ts = source->ts; - f->rank = source->rank + 1; - if (source->rank == 0) - { - if (source->ts.type == BT_CHARACTER) - f->value.function.name - = source->ts.kind == 1 ? PREFIX ("spread_char_scalar") - : gfc_get_string - (PREFIX ("spread_char%d_scalar"), - source->ts.kind); - else - f->value.function.name = PREFIX ("spread_scalar"); - } - else - { - if (source->ts.type == BT_CHARACTER) - f->value.function.name - = source->ts.kind == 1 ? PREFIX ("spread_char") - : gfc_get_string - (PREFIX ("spread_char%d"), - source->ts.kind); - else - f->value.function.name = PREFIX ("spread"); - } - - if (dim && gfc_is_constant_expr (dim) - && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0]) - { - int i, idim; - idim = mpz_get_ui (dim->value.integer); - f->shape = gfc_get_shape (f->rank); - for (i = 0; i < (idim - 1); i++) - mpz_init_set (f->shape[i], source->shape[i]); - - mpz_init_set (f->shape[idim - 1], ncopies->value.integer); - - for (i = idim; i < f->rank ; i++) - mpz_init_set (f->shape[i], source->shape[i-1]); - } - - - gfc_resolve_dim_arg (dim); - gfc_resolve_index (ncopies, 1); -} - - -void -gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -/* Resolve the g77 compatibility function STAT AND FSTAT. */ - -void -gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, - gfc_expr *a ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind); -} - - -void -gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, - gfc_expr *a ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind); -} - - -void -gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - if (n->ts.kind != f->ts.kind) - gfc_convert_type (n, &f->ts, 2); - - f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind); -} - - -void -gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_c_int_kind; - if (u->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (u, &ts, 2); - } - - f->value.function.name = gfc_get_string (PREFIX ("fgetc")); -} - - -void -gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_c_int_kind; - f->value.function.name = gfc_get_string (PREFIX ("fget")); -} - - -void -gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_c_int_kind; - if (u->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (u, &ts, 2); - } - - f->value.function.name = gfc_get_string (PREFIX ("fputc")); -} - - -void -gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_c_int_kind; - f->value.function.name = gfc_get_string (PREFIX ("fput")); -} - - -void -gfc_resolve_ftell (gfc_expr *f, gfc_expr *u) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_intio_kind; - if (u->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (u, &ts, 2); - } - - f->value.function.name = gfc_get_string (PREFIX ("ftell")); -} - - -void -gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, - gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; -} - - -void -gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - resolve_transformational ("sum", f, array, dim, mask); -} - - -void -gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, - gfc_expr *p2 ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind); -} - - -/* Resolve the g77 compatibility function SYSTEM. */ - -void -gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("system")); -} - - -void -gfc_resolve_tan (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_tanh (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -/* Resolve failed_images (team, kind). */ - -void -gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, - gfc_expr *kind) -{ - static char failed_images[] = "_gfortran_caf_failed_images"; - f->rank = 1; - f->ts.type = BT_INTEGER; - if (kind == NULL) - f->ts.kind = gfc_default_integer_kind; - else - gfc_extract_int (kind, &f->ts.kind); - f->value.function.name = failed_images; -} - - -/* Resolve image_status (image, team). */ - -void -gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED, - gfc_expr *team ATTRIBUTE_UNUSED) -{ - static char image_status[] = "_gfortran_caf_image_status"; - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = image_status; -} - - -/* Resolve get_team (). */ - -void -gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED) -{ - static char get_team[] = "_gfortran_caf_get_team"; - f->rank = 0; - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = get_team; -} - - -/* Resolve image_index (...). */ - -void -gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, - gfc_expr *sub ATTRIBUTE_UNUSED) -{ - static char image_index[] = "__image_index"; - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = image_index; -} - - -/* Resolve stopped_images (team, kind). */ - -void -gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, - gfc_expr *kind) -{ - static char stopped_images[] = "_gfortran_caf_stopped_images"; - f->rank = 1; - f->ts.type = BT_INTEGER; - if (kind == NULL) - f->ts.kind = gfc_default_integer_kind; - else - gfc_extract_int (kind, &f->ts.kind); - f->value.function.name = stopped_images; -} - - -/* Resolve team_number (team). */ - -void -gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED) -{ - static char team_number[] = "_gfortran_caf_team_number"; - f->rank = 0; - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = team_number; -} - - -void -gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) -{ - static char this_image[] = "__this_image"; - if (array && gfc_is_coarray (array)) - resolve_bound (f, array, dim, NULL, "__this_image", true); - else - { - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = this_image; - } -} - - -void -gfc_resolve_time (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("time_func")); -} - - -void -gfc_resolve_time8 (gfc_expr *f) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 8; - f->value.function.name = gfc_get_string (PREFIX ("time8_func")); -} - - -void -gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED, - gfc_expr *mold, gfc_expr *size) -{ - /* TODO: Make this do something meaningful. */ - static char transfer0[] = "__transfer0", transfer1[] = "__transfer1"; - - if (mold->ts.type == BT_CHARACTER - && !mold->ts.u.cl->length - && gfc_is_constant_expr (mold)) - { - int len; - if (mold->expr_type == EXPR_CONSTANT) - { - len = mold->value.character.length; - mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, len); - } - else - { - gfc_constructor *c = gfc_constructor_first (mold->value.constructor); - len = c->expr->value.character.length; - mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, len); - } - } - - f->ts = mold->ts; - - if (size == NULL && mold->rank == 0) - { - f->rank = 0; - f->value.function.name = transfer0; - } - else - { - f->rank = 1; - f->value.function.name = transfer1; - if (size && gfc_is_constant_expr (size)) - { - f->shape = gfc_get_shape (1); - mpz_init_set (f->shape[0], size->value.integer); - } - } -} - - -void -gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix) -{ - - if (matrix->ts.type == BT_CHARACTER && matrix->ref) - gfc_resolve_substring_charlen (matrix); - - f->ts = matrix->ts; - f->rank = 2; - if (matrix->shape) - { - f->shape = gfc_get_shape (2); - mpz_init_set (f->shape[0], matrix->shape[1]); - mpz_init_set (f->shape[1], matrix->shape[0]); - } - - switch (matrix->ts.kind) - { - case 4: - case 8: - case 10: - case 16: - switch (matrix->ts.type) - { - case BT_REAL: - case BT_COMPLEX: - f->value.function.name - = gfc_get_string (PREFIX ("transpose_%c%d"), - gfc_type_letter (matrix->ts.type), - gfc_type_abi_kind (&matrix->ts)); - break; - - case BT_INTEGER: - case BT_LOGICAL: - /* Use the integer routines for real and logical cases. This - assumes they all have the same alignment requirements. */ - f->value.function.name - = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind); - break; - - default: - if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4) - f->value.function.name = PREFIX ("transpose_char4"); - else - f->value.function.name = PREFIX ("transpose"); - break; - } - break; - - default: - f->value.function.name = (matrix->ts.type == BT_CHARACTER - ? PREFIX ("transpose_char") - : PREFIX ("transpose")); - break; - } -} - - -void -gfc_resolve_trim (gfc_expr *f, gfc_expr *string) -{ - f->ts.type = BT_CHARACTER; - f->ts.kind = string->ts.kind; - f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); -} - - -/* Resolve the degree trignometric functions. This amounts to setting - the function return type-spec from its argument and building a - library function names of the form _gfortran_sind_r4. */ - -void -gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) -{ - f->ts = x->ts; - f->value.function.name - = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name, - gfc_type_letter (x->ts.type), - gfc_type_abi_kind (&x->ts)); -} - - -void -gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) -{ - f->ts = y->ts; - f->value.function.name - = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name, - x->ts.kind); -} - - -void -gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - resolve_bound (f, array, dim, kind, "__ubound", false); -} - - -void -gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - resolve_bound (f, array, dim, kind, "__ucobound", true); -} - - -/* Resolve the g77 compatibility function UMASK. */ - -void -gfc_resolve_umask (gfc_expr *f, gfc_expr *n) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = n->ts.kind; - f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind); -} - - -/* Resolve the g77 compatibility function UNLINK. */ - -void -gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) -{ - f->ts.type = BT_INTEGER; - f->ts.kind = 4; - f->value.function.name = gfc_get_string (PREFIX ("unlink")); -} - - -void -gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - f->ts.type = BT_CHARACTER; - f->ts.kind = gfc_default_character_kind; - - if (unit->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (unit, &ts, 2); - } - - f->value.function.name = gfc_get_string (PREFIX ("ttynam")); -} - - -void -gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask, - gfc_expr *field ATTRIBUTE_UNUSED) -{ - if (vector->ts.type == BT_CHARACTER && vector->ref) - gfc_resolve_substring_charlen (vector); - - f->ts = vector->ts; - f->rank = mask->rank; - resolve_mask_arg (mask); - - if (vector->ts.type == BT_CHARACTER) - { - if (vector->ts.kind == 1) - f->value.function.name - = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0); - else - f->value.function.name - = gfc_get_string (PREFIX ("unpack%d_char%d"), - field->rank > 0 ? 1 : 0, vector->ts.kind); - } - else - f->value.function.name - = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0); -} - - -void -gfc_resolve_verify (gfc_expr *f, gfc_expr *string, - gfc_expr *set ATTRIBUTE_UNUSED, - gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind) -{ - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind); -} - - -void -gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j) -{ - f->ts.type = i->ts.type; - f->ts.kind = gfc_kind_max (i, j); - - if (i->ts.kind != j->ts.kind) - { - if (i->ts.kind == gfc_kind_max (i, j)) - gfc_convert_type (j, &i->ts, 2); - else - gfc_convert_type (i, &j->ts, 2); - } - - f->value.function.name - = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), - gfc_type_abi_kind (&f->ts)); -} - - -/* Intrinsic subroutine resolution. */ - -void -gfc_resolve_alarm_sub (gfc_code *c) -{ - const char *name; - gfc_expr *seconds, *handler; - gfc_typespec ts; - gfc_clear_ts (&ts); - - seconds = c->ext.actual->expr; - handler = c->ext.actual->next->expr; - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - - /* handler can be either BT_INTEGER or BT_PROCEDURE. - In all cases, the status argument is of default integer kind - (enforced in check.c) so that the function suffix is fixed. */ - if (handler->ts.type == BT_INTEGER) - { - if (handler->ts.kind != gfc_c_int_kind) - gfc_convert_type (handler, &ts, 2); - name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"), - gfc_default_integer_kind); - } - else - name = gfc_get_string (PREFIX ("alarm_sub_i%d"), - gfc_default_integer_kind); - - if (seconds->ts.kind != gfc_c_int_kind) - gfc_convert_type (seconds, &ts, 2); - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - -void -gfc_resolve_cpu_time (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Create a formal arglist based on an actual one and set the INTENTs given. */ - -static gfc_formal_arglist* -create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints) -{ - gfc_formal_arglist* head; - gfc_formal_arglist* tail; - int i; - - if (!actual) - return NULL; - - head = tail = gfc_get_formal_arglist (); - for (i = 0; actual; actual = actual->next, tail = tail->next, ++i) - { - gfc_symbol* sym; - - sym = gfc_new_symbol ("dummyarg", NULL); - sym->ts = actual->expr->ts; - - sym->attr.intent = ints[i]; - tail->sym = sym; - - if (actual->next) - tail->next = gfc_get_formal_arglist (); - } - - return head; -} - - -void -gfc_resolve_atomic_def (gfc_code *c) -{ - const char *name = "atomic_define"; - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_atomic_ref (gfc_code *c) -{ - const char *name = "atomic_ref"; - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - -void -gfc_resolve_event_query (gfc_code *c) -{ - const char *name = "event_query"; - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - -void -gfc_resolve_mvbits (gfc_code *c) -{ - static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN, - INTENT_INOUT, INTENT_IN}; - const char *name; - - /* TO and FROM are guaranteed to have the same kind parameter. */ - name = gfc_get_string (PREFIX ("mvbits_i%d"), - c->ext.actual->expr->ts.kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); - /* Mark as elemental subroutine as this does not happen automatically. */ - c->resolved_sym->attr.elemental = 1; - - /* Create a dummy formal arglist so the INTENTs are known later for purpose - of creating temporaries. */ - c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS); -} - - -/* Set up the call to RANDOM_INIT. */ - -void -gfc_resolve_random_init (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("random_init")); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_random_number (gfc_code *c) -{ - const char *name; - int kind; - - kind = gfc_type_abi_kind (&c->ext.actual->expr->ts); - if (c->ext.actual->expr->rank == 0) - name = gfc_get_string (PREFIX ("random_r%d"), kind); - else - name = gfc_get_string (PREFIX ("arandom_r%d"), kind); - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_random_seed (gfc_code *c) -{ - const char *name; - - name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_rename_sub (gfc_code *c) -{ - const char *name; - int kind; - - /* Find the type of status. If not present use default integer kind. */ - if (c->ext.actual->next->next->expr != NULL) - kind = c->ext.actual->next->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_link_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->next->expr != NULL) - kind = c->ext.actual->next->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("link_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_symlnk_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->next->expr != NULL) - kind = c->ext.actual->next->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* G77 compatibility subroutines dtime() and etime(). */ - -void -gfc_resolve_dtime_sub (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("dtime_sub")); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - -void -gfc_resolve_etime_sub (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("etime_sub")); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */ - -void -gfc_resolve_itime (gfc_code *c) -{ - c->resolved_sym - = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"), - gfc_default_integer_kind)); -} - -void -gfc_resolve_idate (gfc_code *c) -{ - c->resolved_sym - = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"), - gfc_default_integer_kind)); -} - -void -gfc_resolve_ltime (gfc_code *c) -{ - c->resolved_sym - = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"), - gfc_default_integer_kind)); -} - -void -gfc_resolve_gmtime (gfc_code *c) -{ - c->resolved_sym - = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"), - gfc_default_integer_kind)); -} - - -/* G77 compatibility subroutine second(). */ - -void -gfc_resolve_second_sub (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("second_sub")); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_sleep_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->expr != NULL) - kind = c->ext.actual->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* G77 compatibility function srand(). */ - -void -gfc_resolve_srand (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("srand")); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the getarg intrinsic subroutine. */ - -void -gfc_resolve_getarg (gfc_code *c) -{ - const char *name; - - if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind) - { - gfc_typespec ts; - gfc_clear_ts (&ts); - - ts.type = BT_INTEGER; - ts.kind = gfc_default_integer_kind; - - gfc_convert_type (c->ext.actual->expr, &ts, 2); - } - - name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the getcwd intrinsic subroutine. */ - -void -gfc_resolve_getcwd_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->expr != NULL) - kind = c->ext.actual->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the get_command intrinsic subroutine. */ - -void -gfc_resolve_get_command (gfc_code *c) -{ - const char *name; - int kind; - kind = gfc_default_integer_kind; - name = gfc_get_string (PREFIX ("get_command_i%d"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the get_command_argument intrinsic subroutine. */ - -void -gfc_resolve_get_command_argument (gfc_code *c) -{ - const char *name; - int kind; - kind = gfc_default_integer_kind; - name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the get_environment_variable intrinsic subroutine. */ - -void -gfc_resolve_get_environment_variable (gfc_code *code) -{ - const char *name; - int kind; - kind = gfc_default_integer_kind; - name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind); - code->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_signal_sub (gfc_code *c) -{ - const char *name; - gfc_expr *number, *handler, *status; - gfc_typespec ts; - gfc_clear_ts (&ts); - - number = c->ext.actual->expr; - handler = c->ext.actual->next->expr; - status = c->ext.actual->next->next->expr; - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - - /* handler can be either BT_INTEGER or BT_PROCEDURE */ - if (handler->ts.type == BT_INTEGER) - { - if (handler->ts.kind != gfc_c_int_kind) - gfc_convert_type (handler, &ts, 2); - name = gfc_get_string (PREFIX ("signal_sub_int")); - } - else - name = gfc_get_string (PREFIX ("signal_sub")); - - if (number->ts.kind != gfc_c_int_kind) - gfc_convert_type (number, &ts, 2); - if (status != NULL && status->ts.kind != gfc_c_int_kind) - gfc_convert_type (status, &ts, 2); - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the SYSTEM intrinsic subroutine. */ - -void -gfc_resolve_system_sub (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("system_sub")); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */ - -void -gfc_resolve_system_clock (gfc_code *c) -{ - const char *name; - int kind; - gfc_expr *count = c->ext.actual->expr; - gfc_expr *count_max = c->ext.actual->next->next->expr; - - /* The INTEGER(8) version has higher precision, it is used if both COUNT - and COUNT_MAX can hold 64-bit values, or are absent. */ - if ((!count || count->ts.kind >= 8) - && (!count_max || count_max->ts.kind >= 8)) - kind = 8; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("system_clock_%d"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */ -void -gfc_resolve_execute_command_line (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("execute_command_line_i%d"), - gfc_default_integer_kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the EXIT intrinsic subroutine. */ - -void -gfc_resolve_exit (gfc_code *c) -{ - const char *name; - gfc_typespec ts; - gfc_expr *n; - gfc_clear_ts (&ts); - - /* The STATUS argument has to be of default kind. If it is not, - we convert it. */ - ts.type = BT_INTEGER; - ts.kind = gfc_default_integer_kind; - n = c->ext.actual->expr; - if (n != NULL && n->ts.kind != ts.kind) - gfc_convert_type (n, &ts, 2); - - name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -/* Resolve the FLUSH intrinsic subroutine. */ - -void -gfc_resolve_flush (gfc_code *c) -{ - const char *name; - gfc_typespec ts; - gfc_expr *n; - gfc_clear_ts (&ts); - - ts.type = BT_INTEGER; - ts.kind = gfc_default_integer_kind; - n = c->ext.actual->expr; - if (n != NULL && n->ts.kind != ts.kind) - gfc_convert_type (n, &ts, 2); - - name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_ctime_sub (gfc_code *c) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - /* ctime TIME argument is a INTEGER(KIND=8), says the doc */ - if (c->ext.actual->expr->ts.kind != 8) - { - ts.type = BT_INTEGER; - ts.kind = 8; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (c->ext.actual->expr, &ts, 2); - } - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub")); -} - - -void -gfc_resolve_fdate_sub (gfc_code *c) -{ - c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub")); -} - - -void -gfc_resolve_gerror (gfc_code *c) -{ - c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror")); -} - - -void -gfc_resolve_getlog (gfc_code *c) -{ - c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog")); -} - - -void -gfc_resolve_hostnm_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->expr != NULL) - kind = c->ext.actual->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_perror (gfc_code *c) -{ - c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub")); -} - -/* Resolve the STAT and FSTAT intrinsic subroutines. */ - -void -gfc_resolve_stat_sub (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_lstat_sub (gfc_code *c) -{ - const char *name; - name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_fstat_sub (gfc_code *c) -{ - const char *name; - gfc_expr *u; - gfc_typespec *ts; - - u = c->ext.actual->expr; - ts = &c->ext.actual->next->expr->ts; - if (u->ts.kind != ts->kind) - gfc_convert_type (u, ts, 2); - name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_fgetc_sub (gfc_code *c) -{ - const char *name; - gfc_typespec ts; - gfc_expr *u, *st; - gfc_clear_ts (&ts); - - u = c->ext.actual->expr; - st = c->ext.actual->next->next->expr; - - if (u->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (u, &ts, 2); - } - - if (st != NULL) - name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind); - else - name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind); - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_fget_sub (gfc_code *c) -{ - const char *name; - gfc_expr *st; - - st = c->ext.actual->next->expr; - if (st != NULL) - name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind); - else - name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind); - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_fputc_sub (gfc_code *c) -{ - const char *name; - gfc_typespec ts; - gfc_expr *u, *st; - gfc_clear_ts (&ts); - - u = c->ext.actual->expr; - st = c->ext.actual->next->next->expr; - - if (u->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (u, &ts, 2); - } - - if (st != NULL) - name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind); - else - name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind); - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_fput_sub (gfc_code *c) -{ - const char *name; - gfc_expr *st; - - st = c->ext.actual->next->expr; - if (st != NULL) - name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind); - else - name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind); - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_fseek_sub (gfc_code *c) -{ - gfc_expr *unit; - gfc_expr *offset; - gfc_expr *whence; - gfc_typespec ts; - gfc_clear_ts (&ts); - - unit = c->ext.actual->expr; - offset = c->ext.actual->next->expr; - whence = c->ext.actual->next->next->expr; - - if (unit->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (unit, &ts, 2); - } - - if (offset->ts.kind != gfc_intio_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_intio_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (offset, &ts, 2); - } - - if (whence->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (whence, &ts, 2); - } - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub")); -} - -void -gfc_resolve_ftell_sub (gfc_code *c) -{ - const char *name; - gfc_expr *unit; - gfc_expr *offset; - gfc_typespec ts; - gfc_clear_ts (&ts); - - unit = c->ext.actual->expr; - offset = c->ext.actual->next->expr; - - if (unit->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (unit, &ts, 2); - } - - name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - - -void -gfc_resolve_ttynam_sub (gfc_code *c) -{ - gfc_typespec ts; - gfc_clear_ts (&ts); - - if (c->ext.actual->expr->ts.kind != gfc_c_int_kind) - { - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - ts.u.derived = NULL; - ts.u.cl = NULL; - gfc_convert_type (c->ext.actual->expr, &ts, 2); - } - - c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub")); -} - - -/* Resolve the UMASK intrinsic subroutine. */ - -void -gfc_resolve_umask_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->expr != NULL) - kind = c->ext.actual->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} - -/* Resolve the UNLINK intrinsic subroutine. */ - -void -gfc_resolve_unlink_sub (gfc_code *c) -{ - const char *name; - int kind; - - if (c->ext.actual->next->expr != NULL) - kind = c->ext.actual->next->expr->ts.kind; - else - kind = gfc_default_integer_kind; - - name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind); - c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); -} diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc new file mode 100644 index 0000000..97ac4eb --- /dev/null +++ b/gcc/fortran/iresolve.cc @@ -0,0 +1,4050 @@ +/* Intrinsic function resolution. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +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 +. */ + + +/* Assign name and types to intrinsic procedures. For functions, the + first argument to a resolution function is an expression pointer to + the original function node and the rest are pointers to the + arguments of the function call. For subroutines, a pointer to the + code node is passed. The result type and library subroutine name + are generally set according to the function arguments. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "gfortran.h" +#include "stringpool.h" +#include "intrinsic.h" +#include "constructor.h" +#include "arith.h" +#include "trans.h" + +/* Given printf-like arguments, return a stable version of the result string. + + We already have a working, optimized string hashing table in the form of + the identifier table. Reusing this table is likely not to be wasted, + since if the function name makes it to the gimple output of the frontend, + we'll have to create the identifier anyway. */ + +const char * +gfc_get_string (const char *format, ...) +{ + /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */ + char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1]; + const char *str; + va_list ap; + tree ident; + + /* Handle common case without vsnprintf and temporary buffer. */ + if (format[0] == '%' && format[1] == 's' && format[2] == '\0') + { + va_start (ap, format); + str = va_arg (ap, const char *); + va_end (ap); + } + else + { + int ret; + va_start (ap, format); + ret = vsnprintf (temp_name, sizeof (temp_name), format, ap); + va_end (ap); + if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */ + gfc_internal_error ("identifier overflow: %d", ret); + temp_name[sizeof (temp_name) - 1] = 0; + str = temp_name; + } + + ident = get_identifier (str); + return IDENTIFIER_POINTER (ident); +} + +/* MERGE and SPREAD need to have source charlen's present for passing + to the result expression. */ +static void +check_charlen_present (gfc_expr *source) +{ + if (source->ts.u.cl == NULL) + source->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + if (source->expr_type == EXPR_CONSTANT) + { + source->ts.u.cl->length + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, + source->value.character.length); + source->rank = 0; + } + else if (source->expr_type == EXPR_ARRAY) + { + gfc_constructor *c = gfc_constructor_first (source->value.constructor); + source->ts.u.cl->length + = gfc_get_int_expr (gfc_charlen_int_kind, NULL, + c->expr->value.character.length); + } +} + +/* Helper function for resolving the "mask" argument. */ + +static void +resolve_mask_arg (gfc_expr *mask) +{ + + gfc_typespec ts; + gfc_clear_ts (&ts); + + if (mask->rank == 0) + { + /* For the scalar case, coerce the mask to kind=4 unconditionally + (because this is the only kind we have a library function + for). */ + + if (mask->ts.kind != 4) + { + ts.type = BT_LOGICAL; + ts.kind = 4; + gfc_convert_type (mask, &ts, 2); + } + } + else + { + /* In the library, we access the mask with a GFC_LOGICAL_1 + argument. No need to waste memory if we are about to create + a temporary array. */ + if (mask->expr_type == EXPR_OP && mask->ts.kind != 1) + { + ts.type = BT_LOGICAL; + ts.kind = 1; + gfc_convert_type_warn (mask, &ts, 2, 0); + } + } +} + + +static void +resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, + const char *name, bool coarray) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (dim == NULL) + { + f->rank = 1; + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) + : array->rank); + } + } + + f->value.function.name = gfc_get_string ("%s", name); +} + + +static void +resolve_transformational (const char *name, gfc_expr *f, gfc_expr *array, + gfc_expr *dim, gfc_expr *mask) +{ + const char *prefix; + + f->ts = array->ts; + + if (mask) + { + if (mask->rank == 0) + prefix = "s"; + else + prefix = "m"; + + resolve_mask_arg (mask); + } + else + prefix = ""; + + if (dim != NULL) + { + f->rank = array->rank - 1; + f->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + gfc_resolve_dim_arg (dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("%s%s_%c%d"), prefix, name, + gfc_type_letter (array->ts.type), + gfc_type_abi_kind (&array->ts)); +} + + +/********************** Resolution functions **********************/ + + +void +gfc_resolve_abs (gfc_expr *f, gfc_expr *a) +{ + f->ts = a->ts; + if (f->ts.type == BT_COMPLEX) + f->ts.type = BT_REAL; + + f->value.function.name + = gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED, + gfc_expr *mode ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = PREFIX ("access_func"); +} + + +void +gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + if (string->ts.u.cl) + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); + + f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind); +} + + +void +gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + if (string->ts.u.cl) + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); + + f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind); +} + + +static void +gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind, + bool is_achar) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = (kind == NULL) + ? gfc_default_character_kind : mpz_get_si (kind->value.integer); + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + f->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); + + f->value.function.name + = gfc_get_string ("__%schar_%d_%c%d", is_achar ? "a" : "", f->ts.kind, + gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind) +{ + gfc_resolve_char_achar (f, x, kind, true); +} + + +void +gfc_resolve_acos (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_acosh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__acosh_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_aimag (gfc_expr *f, gfc_expr *x) +{ + f->ts.type = BT_REAL; + f->ts.kind = x->ts.kind; + f->value.function.name + = gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_and (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + f->ts.type = i->ts.type; + f->ts.kind = gfc_kind_max (i, j); + + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__and_%c%d", gfc_type_letter (i->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_aint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = a->ts.type; + f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); + + if (a->ts.kind != f->ts.kind) + { + ts.type = f->ts.type; + ts.kind = f->ts.kind; + gfc_convert_type (a, &ts, 2); + } + /* The resolved name is only used for specific intrinsics where + the return kind is the same as the arg kind. */ + f->value.function.name + = gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_dint (gfc_expr *f, gfc_expr *a) +{ + gfc_resolve_aint (f, a, NULL); +} + + +void +gfc_resolve_all (gfc_expr *f, gfc_expr *mask, gfc_expr *dim) +{ + f->ts = mask->ts; + + if (dim != NULL) + { + gfc_resolve_dim_arg (dim); + f->rank = mask->rank - 1; + f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("all_%c%d"), gfc_type_letter (mask->ts.type), + gfc_type_abi_kind (&mask->ts)); +} + + +void +gfc_resolve_anint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = a->ts.type; + f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); + + if (a->ts.kind != f->ts.kind) + { + ts.type = f->ts.type; + ts.kind = f->ts.kind; + gfc_convert_type (a, &ts, 2); + } + + /* The resolved name is only used for specific intrinsics where + the return kind is the same as the arg kind. */ + f->value.function.name + = gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_dnint (gfc_expr *f, gfc_expr *a) +{ + gfc_resolve_anint (f, a, NULL); +} + + +void +gfc_resolve_any (gfc_expr *f, gfc_expr *mask, gfc_expr *dim) +{ + f->ts = mask->ts; + + if (dim != NULL) + { + gfc_resolve_dim_arg (dim); + f->rank = mask->rank - 1; + f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); + } + + f->value.function.name + = gfc_get_string (PREFIX ("any_%c%d"), gfc_type_letter (mask->ts.type), + gfc_type_abi_kind (&mask->ts)); +} + + +void +gfc_resolve_asin (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + +void +gfc_resolve_asinh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__asinh_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + +void +gfc_resolve_atan (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + +void +gfc_resolve_atanh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__atanh_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + +void +gfc_resolve_atan2 (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +/* Resolve the BESYN and BESJN intrinsics. */ + +void +gfc_resolve_besn (gfc_expr *f, gfc_expr *n, gfc_expr *x) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts = x->ts; + if (n->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n, &ts, 2); + } + f->value.function.name = gfc_get_string (""); +} + + +void +gfc_resolve_bessel_n2 (gfc_expr *f, gfc_expr *n1, gfc_expr *n2, gfc_expr *x) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts = x->ts; + f->rank = 1; + if (n1->expr_type == EXPR_CONSTANT && n2->expr_type == EXPR_CONSTANT) + { + f->shape = gfc_get_shape (1); + mpz_init (f->shape[0]); + mpz_sub (f->shape[0], n2->value.integer, n1->value.integer); + mpz_add_ui (f->shape[0], f->shape[0], 1); + } + + if (n1->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n1, &ts, 2); + } + + if (n2->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (n2, &ts, 2); + } + + if (f->value.function.isym->id == GFC_ISYM_JN2) + f->value.function.name = gfc_get_string (PREFIX ("bessel_jn_r%d"), + gfc_type_abi_kind (&f->ts)); + else + f->value.function.name = gfc_get_string (PREFIX ("bessel_yn_r%d"), + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos) +{ + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind; + f->value.function.name + = gfc_get_string ("__btest_%d_%d", i->ts.kind, pos->ts.kind); +} + + +void +gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED) +{ + f->ts = f->value.function.isym->ts; +} + + +void +gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED) +{ + f->ts = f->value.function.isym->ts; +} + + +void +gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + gfc_resolve_char_achar (f, a, kind, false); +} + + +void +gfc_resolve_chdir (gfc_expr *f, gfc_expr *d ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("chdir_i%d"), f->ts.kind); +} + + +void +gfc_resolve_chdir_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("chdir_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_chmod (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED, + gfc_expr *mode ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = PREFIX ("chmod_func"); +} + + +void +gfc_resolve_chmod_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("chmod_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind) +{ + f->ts.type = BT_COMPLEX; + f->ts.kind = (kind == NULL) + ? gfc_default_real_kind : mpz_get_si (kind->value.integer); + + if (y == NULL) + f->value.function.name + = gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); + else + f->value.function.name + = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts), + gfc_type_letter (y->ts.type), + gfc_type_abi_kind (&y->ts)); +} + + +void +gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y) +{ + gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL, + gfc_default_double_kind)); +} + + +void +gfc_resolve_complex (gfc_expr *f, gfc_expr *x, gfc_expr *y) +{ + int kind; + + if (x->ts.type == BT_INTEGER) + { + if (y->ts.type == BT_INTEGER) + kind = gfc_default_real_kind; + else + kind = y->ts.kind; + } + else + { + if (y->ts.type == BT_REAL) + kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; + else + kind = x->ts.kind; + } + + f->ts.type = BT_COMPLEX; + f->ts.kind = kind; + f->value.function.name + = gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts), + gfc_type_letter (y->ts.type), + gfc_type_abi_kind (&y->ts)); +} + + +void +gfc_resolve_conjg (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind); +} + + +void +gfc_resolve_cos (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_cosh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (dim != NULL) + { + f->rank = mask->rank - 1; + gfc_resolve_dim_arg (dim); + f->shape = gfc_copy_shape_excluding (mask->shape, mask->rank, dim); + } + + resolve_mask_arg (mask); + + f->value.function.name + = gfc_get_string (PREFIX ("count_%d_%c"), gfc_type_abi_kind (&f->ts), + gfc_type_letter (mask->ts.type)); +} + + +void +gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, + gfc_expr *dim) +{ + int n, m; + + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + f->rank = array->rank; + f->shape = gfc_copy_shape (array->shape, array->rank); + + if (shift->rank > 0) + n = 1; + else + n = 0; + + /* If dim kind is greater than default integer we need to use the larger. */ + m = gfc_default_integer_kind; + if (dim != NULL) + m = m < dim->ts.kind ? dim->ts.kind : m; + + /* Convert shift to at least m, so we don't need + kind=1 and kind=2 versions of the library functions. */ + if (shift->ts.kind < m) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = m; + gfc_convert_type_warn (shift, &ts, 2, 0); + } + + if (dim != NULL) + { + if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL + && dim->symtree->n.sym->attr.optional) + { + /* Mark this for later setting the type in gfc_conv_missing_dummy. */ + dim->representation.length = shift->ts.kind; + } + else + { + gfc_resolve_dim_arg (dim); + /* Convert dim to shift's kind to reduce variations. */ + if (dim->ts.kind != shift->ts.kind) + gfc_convert_type_warn (dim, &shift->ts, 2, 0); + } + } + + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("cshift%d_%d"), n, shift->ts.kind); +} + + +void +gfc_resolve_ctime (gfc_expr *f, gfc_expr *time) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_CHARACTER; + f->ts.kind = gfc_default_character_kind; + + /* ctime TIME argument is a INTEGER(KIND=8), says the doc */ + if (time->ts.kind != 8) + { + ts.type = BT_INTEGER; + ts.kind = 8; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (time, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("ctime")); +} + + +void +gfc_resolve_dble (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_REAL; + f->ts.kind = gfc_default_double_kind; + f->value.function.name + = gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type (p, &a->ts, 2); + else + gfc_convert_type (a, &p->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_dot_product (gfc_expr *f, gfc_expr *a, gfc_expr *b) +{ + gfc_expr temp; + + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.value.op.op = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; + gfc_type_convert_binary (&temp, 1); + f->ts = temp.ts; + f->value.function.name + = gfc_get_string (PREFIX ("dot_product_%c%d"), + gfc_type_letter (f->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, + gfc_expr *b ATTRIBUTE_UNUSED) +{ + f->ts.kind = gfc_default_double_kind; + f->ts.type = BT_REAL; + f->value.function.name = gfc_get_string ("__dprod_r%d", + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED, + gfc_expr *shift ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + if (f->value.function.isym->id == GFC_ISYM_DSHIFTL) + f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR) + f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind); + else + gcc_unreachable (); +} + + +void +gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift, + gfc_expr *boundary, gfc_expr *dim) +{ + int n, m; + + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + f->rank = array->rank; + f->shape = gfc_copy_shape (array->shape, array->rank); + + n = 0; + if (shift->rank > 0) + n = n | 1; + if (boundary && boundary->rank > 0) + n = n | 2; + + /* If dim kind is greater than default integer we need to use the larger. */ + m = gfc_default_integer_kind; + if (dim != NULL) + m = m < dim->ts.kind ? dim->ts.kind : m; + + /* Convert shift to at least m, so we don't need + kind=1 and kind=2 versions of the library functions. */ + if (shift->ts.kind < m) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = m; + gfc_convert_type_warn (shift, &ts, 2, 0); + } + + if (dim != NULL) + { + if (dim->expr_type != EXPR_CONSTANT && dim->symtree != NULL + && dim->symtree->n.sym->attr.optional) + { + /* Mark this for later setting the type in gfc_conv_missing_dummy. */ + dim->representation.length = shift->ts.kind; + } + else + { + gfc_resolve_dim_arg (dim); + /* Convert dim to shift's kind to reduce variations. */ + if (dim->ts.kind != shift->ts.kind) + gfc_convert_type_warn (dim, &shift->ts, 2, 0); + } + } + + if (array->ts.type == BT_CHARACTER) + { + if (array->ts.kind == gfc_default_character_kind) + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char"), n, shift->ts.kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d_char%d"), n, shift->ts.kind, + array->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("eoshift%d_%d"), n, shift->ts.kind); +} + + +void +gfc_resolve_exp (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_exponent (gfc_expr *f, gfc_expr *x) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind); +} + + +/* Resolve the EXTENDS_TYPE_OF intrinsic function. */ + +void +gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) +{ + gfc_symbol *vtab; + gfc_symtree *st; + + /* Prevent double resolution. */ + if (f->ts.type == BT_LOGICAL) + return; + + /* Replace the first argument with the corresponding vtab. */ + if (a->ts.type == BT_CLASS) + gfc_add_vptr_component (a); + else if (a->ts.type == BT_DERIVED) + { + locus where; + + vtab = gfc_find_derived_vtab (a->ts.u.derived); + /* Clear the old expr. */ + gfc_free_ref_list (a->ref); + where = a->where; + memset (a, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + a->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + a->symtree = st; + a->ts = vtab->ts; + a->where = where; + } + + /* Replace the second argument with the corresponding vtab. */ + if (mo->ts.type == BT_CLASS) + gfc_add_vptr_component (mo); + else if (mo->ts.type == BT_DERIVED) + { + locus where; + + vtab = gfc_find_derived_vtab (mo->ts.u.derived); + /* Clear the old expr. */ + where = mo->where; + gfc_free_ref_list (mo->ref); + memset (mo, '\0', sizeof (gfc_expr)); + /* Construct a new one. */ + mo->expr_type = EXPR_VARIABLE; + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + mo->symtree = st; + mo->ts = vtab->ts; + mo->where = where; + } + + f->ts.type = BT_LOGICAL; + f->ts.kind = 4; + + f->value.function.isym->formal->ts = a->ts; + f->value.function.isym->formal->next->ts = mo->ts; + + /* Call library function. */ + f->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); +} + + +void +gfc_resolve_fdate (gfc_expr *f) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = gfc_default_character_kind; + f->value.function.name = gfc_get_string (PREFIX ("fdate")); +} + + +void +gfc_resolve_floor (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__floor%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_fnum (gfc_expr *f, gfc_expr *n) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + if (n->ts.kind != f->ts.kind) + gfc_convert_type (n, &f->ts, 2); + f->value.function.name = gfc_get_string (PREFIX ("fnum_i%d"), f->ts.kind); +} + + +void +gfc_resolve_fraction (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind); +} + + +/* Resolve single-argument g77 math intrinsics, eg BESY0, ERF. */ + +void +gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string (""); +} + + +void +gfc_resolve_gamma (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__tgamma_%d", x->ts.kind); +} + + +void +gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getcwd")); +} + + +void +gfc_resolve_getgid (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getgid")); +} + + +void +gfc_resolve_getpid (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getpid")); +} + + +void +gfc_resolve_getuid (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("getuid")); +} + + +void +gfc_resolve_hostnm (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("hostnm")); +} + + +void +gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__hypot_r%d", + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iall", f, array, dim, mask); +} + + +void +gfc_resolve_iand (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind); +} + + +void +gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iany", f, array, dim, mask); +} + + +void +gfc_resolve_ibclr (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind); +} + + +void +gfc_resolve_ibits (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED, + gfc_expr *len ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind); +} + + +void +gfc_resolve_ibset (gfc_expr *f, gfc_expr *i, gfc_expr *pos ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind); +} + + +void +gfc_resolve_iachar (gfc_expr *f, gfc_expr *c, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); +} + + +void +gfc_resolve_ichar (gfc_expr *f, gfc_expr *c, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); +} + + +void +gfc_resolve_idnint (gfc_expr *f, gfc_expr *a) +{ + gfc_resolve_nint (f, a, NULL); +} + + +void +gfc_resolve_ierrno (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("ierrno_i%d"), f->ts.kind); +} + + +void +gfc_resolve_ieor (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind); +} + + +void +gfc_resolve_ior (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + /* If the kind of i and j are different, then g77 cross-promoted the + kinds to the largest value. The Fortran 95 standard requires the + kinds to match. */ + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind); +} + + +void +gfc_resolve_index_func (gfc_expr *f, gfc_expr *str, + gfc_expr *sub_str ATTRIBUTE_UNUSED, gfc_expr *back, + gfc_expr *kind) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (back && back->ts.kind != gfc_default_integer_kind) + { + ts.type = BT_LOGICAL; + ts.kind = gfc_default_integer_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (back, &ts, 2); + } + + f->value.function.name + = gfc_get_string ("__index_%d_i%d", str->ts.kind, f->ts.kind); +} + + +void +gfc_resolve_int (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_int2 (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 2; + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_int8 (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 8; + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_long (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name + = gfc_get_string ("__int_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("iparity", f, array, dim, mask); +} + + +void +gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_integer_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("isatty_l%d"), f->ts.kind); +} + + +void +gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind; + f->value.function.name = gfc_get_string ("__is_contiguous"); +} + + +void +gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift) +{ + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind); +} + + +void +gfc_resolve_rshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift) +{ + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__rshift_%d_%d", i->ts.kind, shift->ts.kind); +} + + +void +gfc_resolve_lshift (gfc_expr *f, gfc_expr *i, gfc_expr *shift) +{ + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__lshift_%d_%d", i->ts.kind, shift->ts.kind); +} + + +void +gfc_resolve_ishftc (gfc_expr *f, gfc_expr *i, gfc_expr *shift, gfc_expr *size) +{ + int s_kind; + + s_kind = (size == NULL) ? gfc_default_integer_kind : size->ts.kind; + + f->ts = i->ts; + f->value.function.name + = gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind); +} + + +void +gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__lbound", false); +} + + +void +gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__lcobound", true); +} + + +void +gfc_resolve_len (gfc_expr *f, gfc_expr *string, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name + = gfc_get_string ("__len_%d_i%d", string->ts.kind, + gfc_default_integer_kind); +} + + +void +gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind); +} + + +void +gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__lgamma_%d", x->ts.kind); +} + + +void +gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, + gfc_expr *p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("link_i%d"), f->ts.kind); +} + + +void +gfc_resolve_loc (gfc_expr *f, gfc_expr *x) +{ + f->ts.type= BT_INTEGER; + f->ts.kind = gfc_index_integer_kind; + f->value.function.name = gfc_get_string ("__loc_%d", x->ts.kind); +} + + +void +gfc_resolve_log (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_log10 (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_logical (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_LOGICAL; + f->ts.kind = (kind == NULL) + ? gfc_default_logical_kind : mpz_get_si (kind->value.integer); + f->rank = a->rank; + + f->value.function.name + = gfc_get_string ("__logical_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b) +{ + gfc_expr temp; + + if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) + { + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind; + } + else + { + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.value.op.op = INTRINSIC_NONE; + temp.value.op.op1 = a; + temp.value.op.op2 = b; + gfc_type_convert_binary (&temp, 1); + f->ts = temp.ts; + } + + f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1; + + if (a->rank == 2 && b->rank == 2) + { + if (a->shape && b->shape) + { + f->shape = gfc_get_shape (f->rank); + mpz_init_set (f->shape[0], a->shape[0]); + mpz_init_set (f->shape[1], b->shape[1]); + } + } + else if (a->rank == 1) + { + if (b->shape) + { + f->shape = gfc_get_shape (f->rank); + mpz_init_set (f->shape[0], b->shape[1]); + } + } + else + { + /* b->rank == 1 and a->rank == 2 here, all other cases have + been caught in check.c. */ + if (a->shape) + { + f->shape = gfc_get_shape (f->rank); + mpz_init_set (f->shape[0], a->shape[0]); + } + } + + f->value.function.name + = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +static void +gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args) +{ + gfc_actual_arglist *a; + + f->ts.type = args->expr->ts.type; + f->ts.kind = args->expr->ts.kind; + /* Find the largest type kind. */ + for (a = args->next; a; a = a->next) + { + if (a->expr->ts.kind > f->ts.kind) + f->ts.kind = a->expr->ts.kind; + } + + /* Convert all parameters to the required kind. */ + for (a = args; a; a = a->next) + { + if (a->expr->ts.kind != f->ts.kind) + gfc_convert_type (a->expr, &f->ts, 2); + } + + f->value.function.name + = gfc_get_string (name, gfc_type_letter (f->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args) +{ + gfc_resolve_minmax ("__max_%c%d", f, args); +} + +/* The smallest kind for which a minloc and maxloc implementation exists. */ + +#define MINMAXLOC_MIN_KIND 4 + +void +gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask, gfc_expr *kind, gfc_expr *back) +{ + const char *name; + int i, j, idim; + int fkind; + int d_num; + + f->ts.type = BT_INTEGER; + + /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, + we do a type conversion further down. */ + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind < MINMAXLOC_MIN_KIND) + f->ts.kind = MINMAXLOC_MIN_KIND; + else + f->ts.kind = fkind; + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_si (f->shape[0], array->rank); + } + else + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + if (array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "smaxloc"; + else + name = "mmaxloc"; + + resolve_mask_arg (mask); + } + else + name = "maxloc"; + + if (dim) + { + if (array->ts.type != BT_CHARACTER || f->rank != 0) + d_num = 1; + else + d_num = 2; + } + else + d_num = 0; + + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind, + gfc_type_letter (array->ts.type), + gfc_type_abi_kind (&array->ts)); + + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind != f->ts.kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = fkind; + gfc_convert_type_warn (f, &ts, 2, 0); + } + + if (back->ts.kind != gfc_logical_4_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_LOGICAL; + ts.kind = gfc_logical_4_kind; + gfc_convert_type_warn (back, &ts, 2, 0); + } +} + + +void +gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value, + gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, + gfc_expr *back) +{ + const char *name; + int i, j, idim; + int fkind; + int d_num; + + /* See at the end of the function for why this is necessary. */ + + if (f->do_not_resolve_again) + return; + + f->ts.type = BT_INTEGER; + + /* We have a single library version, which uses index_type. */ + + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + f->ts.kind = gfc_index_integer_kind; + + /* Convert value. If array is not LOGICAL and value is, we already + issued an error earlier. */ + + if ((array->ts.type != value->ts.type && value->ts.type != BT_LOGICAL) + || array->ts.kind != value->ts.kind) + gfc_convert_type_warn (value, &array->ts, 2, 0); + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_si (f->shape[0], array->rank); + } + else + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + if (array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "sfindloc"; + else + name = "mfindloc"; + + resolve_mask_arg (mask); + } + else + name = "findloc"; + + if (dim) + { + if (f->rank > 0) + d_num = 1; + else + d_num = 2; + } + else + d_num = 0; + + if (back->ts.kind != gfc_logical_4_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_LOGICAL; + ts.kind = gfc_logical_4_kind; + gfc_convert_type_warn (back, &ts, 2, 0); + } + + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num, + gfc_type_letter (array->ts.type, true), + gfc_type_abi_kind (&array->ts)); + + /* We only have a single library function, so we need to convert + here. If the function is resolved from within a convert + function generated on a previous round of resolution, endless + recursion could occur. Guard against that here. */ + + if (f->ts.kind != fkind) + { + f->do_not_resolve_again = 1; + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = fkind; + gfc_convert_type_warn (f, &ts, 2, 0); + } + +} + +void +gfc_resolve_maxval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + const char *name; + int i, j, idim; + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + + if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "smaxval"; + else + name = "mmaxval"; + + resolve_mask_arg (mask); + } + else + name = "maxval"; + + if (array->ts.type != BT_CHARACTER) + f->value.function.name + = gfc_get_string (PREFIX ("%s_%c%d"), name, + gfc_type_letter (array->ts.type), + gfc_type_abi_kind (&array->ts)); + else + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0, + gfc_type_letter (array->ts.type), + gfc_type_abi_kind (&array->ts)); +} + + +void +gfc_resolve_mclock (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = PREFIX ("mclock"); +} + + +void +gfc_resolve_mclock8 (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 8; + f->value.function.name = PREFIX ("mclock8"); +} + + +void +gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = kind ? mpz_get_si (kind->value.integer) + : gfc_default_integer_kind; + + if (f->value.function.isym->id == GFC_ISYM_MASKL) + f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind); + else + f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind); +} + + +void +gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource, + gfc_expr *fsource ATTRIBUTE_UNUSED, + gfc_expr *mask ATTRIBUTE_UNUSED) +{ + if (tsource->ts.type == BT_CHARACTER && tsource->ref) + gfc_resolve_substring_charlen (tsource); + + if (fsource->ts.type == BT_CHARACTER && fsource->ref) + gfc_resolve_substring_charlen (fsource); + + if (tsource->ts.type == BT_CHARACTER) + check_charlen_present (tsource); + + f->ts = tsource->ts; + f->value.function.name + = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type), + gfc_type_abi_kind (&tsource->ts)); +} + + +void +gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i, + gfc_expr *j ATTRIBUTE_UNUSED, + gfc_expr *mask ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind); +} + + +void +gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args) +{ + gfc_resolve_minmax ("__min_%c%d", f, args); +} + + +void +gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask, gfc_expr *kind, gfc_expr *back) +{ + const char *name; + int i, j, idim; + int fkind; + int d_num; + + f->ts.type = BT_INTEGER; + + /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, + we do a type conversion further down. */ + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind < MINMAXLOC_MIN_KIND) + f->ts.kind = MINMAXLOC_MIN_KIND; + else + f->ts.kind = fkind; + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_si (f->shape[0], array->rank); + } + else + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + if (array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "sminloc"; + else + name = "mminloc"; + + resolve_mask_arg (mask); + } + else + name = "minloc"; + + if (dim) + { + if (array->ts.type != BT_CHARACTER || f->rank != 0) + d_num = 1; + else + d_num = 2; + } + else + d_num = 0; + + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, d_num, f->ts.kind, + gfc_type_letter (array->ts.type), + gfc_type_abi_kind (&array->ts)); + + if (fkind != f->ts.kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = fkind; + gfc_convert_type_warn (f, &ts, 2, 0); + } + + if (back->ts.kind != gfc_logical_4_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + ts.type = BT_LOGICAL; + ts.kind = gfc_logical_4_kind; + gfc_convert_type_warn (back, &ts, 2, 0); + } +} + + +void +gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + const char *name; + int i, j, idim; + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_dim_arg (dim); + + if (f->rank && array->shape && dim->expr_type == EXPR_CONSTANT) + { + idim = (int) mpz_get_si (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0, j = 0; i < f->rank; i++, j++) + { + if (i == (idim - 1)) + j++; + mpz_init_set (f->shape[i], array->shape[j]); + } + } + } + + if (mask) + { + if (mask->rank == 0) + name = "sminval"; + else + name = "mminval"; + + resolve_mask_arg (mask); + } + else + name = "minval"; + + if (array->ts.type != BT_CHARACTER) + f->value.function.name + = gfc_get_string (PREFIX ("%s_%c%d"), name, + gfc_type_letter (array->ts.type), + gfc_type_abi_kind (&array->ts)); + else + f->value.function.name + = gfc_get_string (PREFIX ("%s%d_%c%d"), name, f->rank != 0, + gfc_type_letter (array->ts.type), + gfc_type_abi_kind (&array->ts)); +} + + +void +gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type (p, &a->ts, 2); + else + gfc_convert_type (a, &p->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + f->ts.type = a->ts.type; + if (p != NULL) + f->ts.kind = gfc_kind_max (a,p); + else + f->ts.kind = a->ts.kind; + + if (p != NULL && a->ts.kind != p->ts.kind) + { + if (a->ts.kind == gfc_kind_max (a,p)) + gfc_convert_type (p, &a->ts, 2); + else + gfc_convert_type (a, &p->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type), + gfc_type_abi_kind (&f->ts)); +} + +void +gfc_resolve_nearest (gfc_expr *f, gfc_expr *a, gfc_expr *p) +{ + if (p->ts.kind != a->ts.kind) + gfc_convert_type (p, &a->ts, 2); + + f->ts = a->ts; + f->value.function.name + = gfc_get_string ("__nearest_%c%d", gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + +void +gfc_resolve_nint (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) + ? gfc_default_integer_kind : mpz_get_si (kind->value.integer); + f->value.function.name + = gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind); +} + + +void +gfc_resolve_norm2 (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + resolve_transformational ("norm2", f, array, dim, NULL); +} + + +void +gfc_resolve_not (gfc_expr *f, gfc_expr *i) +{ + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind); +} + + +void +gfc_resolve_or (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + f->ts.type = i->ts.type; + f->ts.kind = gfc_kind_max (i, j); + + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__or_%c%d", gfc_type_letter (i->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +void +gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask, + gfc_expr *vector ATTRIBUTE_UNUSED) +{ + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + f->rank = 1; + + resolve_mask_arg (mask); + + if (mask->rank != 0) + { + if (array->ts.type == BT_CHARACTER) + f->value.function.name + = array->ts.kind == 1 ? PREFIX ("pack_char") + : gfc_get_string + (PREFIX ("pack_char%d"), + array->ts.kind); + else + f->value.function.name = PREFIX ("pack"); + } + else + { + if (array->ts.type == BT_CHARACTER) + f->value.function.name + = array->ts.kind == 1 ? PREFIX ("pack_s_char") + : gfc_get_string + (PREFIX ("pack_s_char%d"), + array->ts.kind); + else + f->value.function.name = PREFIX ("pack_s"); + } +} + + +void +gfc_resolve_parity (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + resolve_transformational ("parity", f, array, dim, NULL); +} + + +void +gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask) +{ + resolve_transformational ("product", f, array, dim, mask); +} + + +void +gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__rank"); +} + + +void +gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind) +{ + f->ts.type = BT_REAL; + + if (kind != NULL) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = (a->ts.type == BT_COMPLEX) + ? a->ts.kind : gfc_default_real_kind; + + f->value.function.name + = gfc_get_string ("__real_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_realpart (gfc_expr *f, gfc_expr *a) +{ + f->ts.type = BT_REAL; + f->ts.kind = a->ts.kind; + f->value.function.name + = gfc_get_string ("__real_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, + gfc_expr *p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("rename_i%d"), f->ts.kind); +} + + +void +gfc_resolve_repeat (gfc_expr *f, gfc_expr *string, + gfc_expr *ncopies) +{ + gfc_expr *tmp; + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind); + + /* If possible, generate a character length. */ + if (f->ts.u.cl == NULL) + f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + tmp = NULL; + if (string->expr_type == EXPR_CONSTANT) + { + tmp = gfc_get_int_expr (gfc_charlen_int_kind, NULL, + string->value.character.length); + } + else if (string->ts.u.cl && string->ts.u.cl->length) + { + tmp = gfc_copy_expr (string->ts.u.cl->length); + } + + if (tmp) + f->ts.u.cl->length = gfc_multiply (tmp, gfc_copy_expr (ncopies)); +} + + +void +gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape, + gfc_expr *pad ATTRIBUTE_UNUSED, + gfc_expr *order ATTRIBUTE_UNUSED) +{ + mpz_t rank; + int kind; + int i; + + if (source->ts.type == BT_CHARACTER && source->ref) + gfc_resolve_substring_charlen (source); + + f->ts = source->ts; + + gfc_array_size (shape, &rank); + f->rank = mpz_get_si (rank); + mpz_clear (rank); + switch (source->ts.type) + { + case BT_COMPLEX: + case BT_REAL: + case BT_INTEGER: + case BT_LOGICAL: + case BT_CHARACTER: + kind = source->ts.kind; + break; + + default: + kind = 0; + break; + } + + switch (kind) + { + case 4: + case 8: + case 10: + case 16: + if (source->ts.type == BT_COMPLEX || source->ts.type == BT_REAL) + f->value.function.name + = gfc_get_string (PREFIX ("reshape_%c%d"), + gfc_type_letter (source->ts.type), + gfc_type_abi_kind (&source->ts)); + else if (source->ts.type == BT_CHARACTER) + f->value.function.name = gfc_get_string (PREFIX ("reshape_char%d"), + kind); + else + f->value.function.name + = gfc_get_string (PREFIX ("reshape_%d"), source->ts.kind); + break; + + default: + f->value.function.name = (source->ts.type == BT_CHARACTER + ? PREFIX ("reshape_char") : PREFIX ("reshape")); + break; + } + + if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape)) + { + gfc_constructor *c; + f->shape = gfc_get_shape (f->rank); + c = gfc_constructor_first (shape->value.constructor); + for (i = 0; i < f->rank; i++) + { + mpz_init_set (f->shape[i], c->expr->value.integer); + c = gfc_constructor_next (c); + } + } + + /* Force-convert both SHAPE and ORDER to index_kind so that we don't need + so many runtime variations. */ + if (shape->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts = shape->ts; + ts.kind = gfc_index_integer_kind; + gfc_convert_type_warn (shape, &ts, 2, 0); + } + if (order && order->ts.kind != gfc_index_integer_kind) + gfc_convert_type_warn (order, &shape->ts, 2, 0); +} + + +void +gfc_resolve_rrspacing (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind); +} + +void +gfc_resolve_fe_runtime_error (gfc_code *c) +{ + const char *name; + gfc_actual_arglist *a; + + name = gfc_get_string (PREFIX ("runtime_error")); + + for (a = c->ext.actual->next; a; a = a->next) + a->name = "%VAL"; + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); + /* We set the backend_decl here because runtime_error is a + variadic function and we would use the wrong calling + convention otherwise. */ + c->resolved_sym->backend_decl = gfor_fndecl_runtime_error; +} + +void +gfc_resolve_scale (gfc_expr *f, gfc_expr *x, gfc_expr *i ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__scale_%d", x->ts.kind); +} + + +void +gfc_resolve_scan (gfc_expr *f, gfc_expr *string, + gfc_expr *set ATTRIBUTE_UNUSED, + gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind); +} + + +void +gfc_resolve_secnds (gfc_expr *t1, gfc_expr *t0) +{ + t1->ts = t0->ts; + t1->value.function.name = gfc_get_string (PREFIX ("secnds")); +} + + +void +gfc_resolve_set_exponent (gfc_expr *f, gfc_expr *x, + gfc_expr *i ATTRIBUTE_UNUSED) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__set_exponent_%d", x->ts.kind); +} + + +void +gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + f->rank = 1; + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], array->rank); + } + + f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind); +} + + +void +gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED) +{ + f->ts = i->ts; + if (f->value.function.isym->id == GFC_ISYM_SHIFTA) + f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_SHIFTL) + f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind); + else if (f->value.function.isym->id == GFC_ISYM_SHIFTR) + f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind); + else + gcc_unreachable (); +} + + +void +gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED) +{ + f->ts = a->ts; + f->value.function.name + = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), + gfc_type_abi_kind (&a->ts)); +} + + +void +gfc_resolve_signal (gfc_expr *f, gfc_expr *number, gfc_expr *handler) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &f->ts, 2); + f->value.function.name = gfc_get_string (PREFIX ("signal_func_int")); + } + else + f->value.function.name = gfc_get_string (PREFIX ("signal_func")); + + if (number->ts.kind != gfc_c_int_kind) + gfc_convert_type (number, &f->ts, 2); +} + + +void +gfc_resolve_sin (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_sinh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_size (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *dim ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; +} + + +void +gfc_resolve_stride (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *dim ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_index_integer_kind; +} + + +void +gfc_resolve_spacing (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind); +} + + +void +gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim, + gfc_expr *ncopies) +{ + if (source->ts.type == BT_CHARACTER && source->ref) + gfc_resolve_substring_charlen (source); + + if (source->ts.type == BT_CHARACTER) + check_charlen_present (source); + + f->ts = source->ts; + f->rank = source->rank + 1; + if (source->rank == 0) + { + if (source->ts.type == BT_CHARACTER) + f->value.function.name + = source->ts.kind == 1 ? PREFIX ("spread_char_scalar") + : gfc_get_string + (PREFIX ("spread_char%d_scalar"), + source->ts.kind); + else + f->value.function.name = PREFIX ("spread_scalar"); + } + else + { + if (source->ts.type == BT_CHARACTER) + f->value.function.name + = source->ts.kind == 1 ? PREFIX ("spread_char") + : gfc_get_string + (PREFIX ("spread_char%d"), + source->ts.kind); + else + f->value.function.name = PREFIX ("spread"); + } + + if (dim && gfc_is_constant_expr (dim) + && ncopies && gfc_is_constant_expr (ncopies) && source->shape[0]) + { + int i, idim; + idim = mpz_get_ui (dim->value.integer); + f->shape = gfc_get_shape (f->rank); + for (i = 0; i < (idim - 1); i++) + mpz_init_set (f->shape[i], source->shape[i]); + + mpz_init_set (f->shape[idim - 1], ncopies->value.integer); + + for (i = idim; i < f->rank ; i++) + mpz_init_set (f->shape[i], source->shape[i-1]); + } + + + gfc_resolve_dim_arg (dim); + gfc_resolve_index (ncopies, 1); +} + + +void +gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +/* Resolve the g77 compatibility function STAT AND FSTAT. */ + +void +gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, + gfc_expr *a ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind); +} + + +void +gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, + gfc_expr *a ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind); +} + + +void +gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + if (n->ts.kind != f->ts.kind) + gfc_convert_type (n, &f->ts, 2); + + f->value.function.name = gfc_get_string (PREFIX ("fstat_i%d"), f->ts.kind); +} + + +void +gfc_resolve_fgetc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("fgetc")); +} + + +void +gfc_resolve_fget (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = gfc_get_string (PREFIX ("fget")); +} + + +void +gfc_resolve_fputc (gfc_expr *f, gfc_expr *u, gfc_expr *c ATTRIBUTE_UNUSED) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("fputc")); +} + + +void +gfc_resolve_fput (gfc_expr *f, gfc_expr *c ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_c_int_kind; + f->value.function.name = gfc_get_string (PREFIX ("fput")); +} + + +void +gfc_resolve_ftell (gfc_expr *f, gfc_expr *u) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_intio_kind; + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("ftell")); +} + + +void +gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; +} + + +void +gfc_resolve_sum (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + resolve_transformational ("sum", f, array, dim, mask); +} + + +void +gfc_resolve_symlnk (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, + gfc_expr *p2 ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string (PREFIX ("symlnk_i%d"), f->ts.kind); +} + + +/* Resolve the g77 compatibility function SYSTEM. */ + +void +gfc_resolve_system (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("system")); +} + + +void +gfc_resolve_tan (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_tanh (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +/* Resolve failed_images (team, kind). */ + +void +gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + static char failed_images[] = "_gfortran_caf_failed_images"; + f->rank = 1; + f->ts.type = BT_INTEGER; + if (kind == NULL) + f->ts.kind = gfc_default_integer_kind; + else + gfc_extract_int (kind, &f->ts.kind); + f->value.function.name = failed_images; +} + + +/* Resolve image_status (image, team). */ + +void +gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED, + gfc_expr *team ATTRIBUTE_UNUSED) +{ + static char image_status[] = "_gfortran_caf_image_status"; + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = image_status; +} + + +/* Resolve get_team (). */ + +void +gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED) +{ + static char get_team[] = "_gfortran_caf_get_team"; + f->rank = 0; + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = get_team; +} + + +/* Resolve image_index (...). */ + +void +gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *sub ATTRIBUTE_UNUSED) +{ + static char image_index[] = "__image_index"; + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = image_index; +} + + +/* Resolve stopped_images (team, kind). */ + +void +gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + static char stopped_images[] = "_gfortran_caf_stopped_images"; + f->rank = 1; + f->ts.type = BT_INTEGER; + if (kind == NULL) + f->ts.kind = gfc_default_integer_kind; + else + gfc_extract_int (kind, &f->ts.kind); + f->value.function.name = stopped_images; +} + + +/* Resolve team_number (team). */ + +void +gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED) +{ + static char team_number[] = "_gfortran_caf_team_number"; + f->rank = 0; + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = team_number; +} + + +void +gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + gfc_expr *distance ATTRIBUTE_UNUSED) +{ + static char this_image[] = "__this_image"; + if (array && gfc_is_coarray (array)) + resolve_bound (f, array, dim, NULL, "__this_image", true); + else + { + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; + } +} + + +void +gfc_resolve_time (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("time_func")); +} + + +void +gfc_resolve_time8 (gfc_expr *f) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 8; + f->value.function.name = gfc_get_string (PREFIX ("time8_func")); +} + + +void +gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED, + gfc_expr *mold, gfc_expr *size) +{ + /* TODO: Make this do something meaningful. */ + static char transfer0[] = "__transfer0", transfer1[] = "__transfer1"; + + if (mold->ts.type == BT_CHARACTER + && !mold->ts.u.cl->length + && gfc_is_constant_expr (mold)) + { + int len; + if (mold->expr_type == EXPR_CONSTANT) + { + len = mold->value.character.length; + mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, len); + } + else + { + gfc_constructor *c = gfc_constructor_first (mold->value.constructor); + len = c->expr->value.character.length; + mold->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, len); + } + } + + f->ts = mold->ts; + + if (size == NULL && mold->rank == 0) + { + f->rank = 0; + f->value.function.name = transfer0; + } + else + { + f->rank = 1; + f->value.function.name = transfer1; + if (size && gfc_is_constant_expr (size)) + { + f->shape = gfc_get_shape (1); + mpz_init_set (f->shape[0], size->value.integer); + } + } +} + + +void +gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix) +{ + + if (matrix->ts.type == BT_CHARACTER && matrix->ref) + gfc_resolve_substring_charlen (matrix); + + f->ts = matrix->ts; + f->rank = 2; + if (matrix->shape) + { + f->shape = gfc_get_shape (2); + mpz_init_set (f->shape[0], matrix->shape[1]); + mpz_init_set (f->shape[1], matrix->shape[0]); + } + + switch (matrix->ts.kind) + { + case 4: + case 8: + case 10: + case 16: + switch (matrix->ts.type) + { + case BT_REAL: + case BT_COMPLEX: + f->value.function.name + = gfc_get_string (PREFIX ("transpose_%c%d"), + gfc_type_letter (matrix->ts.type), + gfc_type_abi_kind (&matrix->ts)); + break; + + case BT_INTEGER: + case BT_LOGICAL: + /* Use the integer routines for real and logical cases. This + assumes they all have the same alignment requirements. */ + f->value.function.name + = gfc_get_string (PREFIX ("transpose_i%d"), matrix->ts.kind); + break; + + default: + if (matrix->ts.type == BT_CHARACTER && matrix->ts.kind == 4) + f->value.function.name = PREFIX ("transpose_char4"); + else + f->value.function.name = PREFIX ("transpose"); + break; + } + break; + + default: + f->value.function.name = (matrix->ts.type == BT_CHARACTER + ? PREFIX ("transpose_char") + : PREFIX ("transpose")); + break; + } +} + + +void +gfc_resolve_trim (gfc_expr *f, gfc_expr *string) +{ + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); +} + + +/* Resolve the degree trignometric functions. This amounts to setting + the function return type-spec from its argument and building a + library function names of the form _gfortran_sind_r4. */ + +void +gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) +{ + f->ts = x->ts; + f->value.function.name + = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name, + gfc_type_letter (x->ts.type), + gfc_type_abi_kind (&x->ts)); +} + + +void +gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) +{ + f->ts = y->ts; + f->value.function.name + = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name, + x->ts.kind); +} + + +void +gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__ubound", false); +} + + +void +gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + resolve_bound (f, array, dim, kind, "__ucobound", true); +} + + +/* Resolve the g77 compatibility function UMASK. */ + +void +gfc_resolve_umask (gfc_expr *f, gfc_expr *n) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = n->ts.kind; + f->value.function.name = gfc_get_string (PREFIX ("umask_i%d"), n->ts.kind); +} + + +/* Resolve the g77 compatibility function UNLINK. */ + +void +gfc_resolve_unlink (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_INTEGER; + f->ts.kind = 4; + f->value.function.name = gfc_get_string (PREFIX ("unlink")); +} + + +void +gfc_resolve_ttynam (gfc_expr *f, gfc_expr *unit) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + f->ts.type = BT_CHARACTER; + f->ts.kind = gfc_default_character_kind; + + if (unit->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (unit, &ts, 2); + } + + f->value.function.name = gfc_get_string (PREFIX ("ttynam")); +} + + +void +gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask, + gfc_expr *field ATTRIBUTE_UNUSED) +{ + if (vector->ts.type == BT_CHARACTER && vector->ref) + gfc_resolve_substring_charlen (vector); + + f->ts = vector->ts; + f->rank = mask->rank; + resolve_mask_arg (mask); + + if (vector->ts.type == BT_CHARACTER) + { + if (vector->ts.kind == 1) + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d_char"), field->rank > 0 ? 1 : 0); + else + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d_char%d"), + field->rank > 0 ? 1 : 0, vector->ts.kind); + } + else + f->value.function.name + = gfc_get_string (PREFIX ("unpack%d"), field->rank > 0 ? 1 : 0); +} + + +void +gfc_resolve_verify (gfc_expr *f, gfc_expr *string, + gfc_expr *set ATTRIBUTE_UNUSED, + gfc_expr *back ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind); +} + + +void +gfc_resolve_xor (gfc_expr *f, gfc_expr *i, gfc_expr *j) +{ + f->ts.type = i->ts.type; + f->ts.kind = gfc_kind_max (i, j); + + if (i->ts.kind != j->ts.kind) + { + if (i->ts.kind == gfc_kind_max (i, j)) + gfc_convert_type (j, &i->ts, 2); + else + gfc_convert_type (i, &j->ts, 2); + } + + f->value.function.name + = gfc_get_string ("__xor_%c%d", gfc_type_letter (i->ts.type), + gfc_type_abi_kind (&f->ts)); +} + + +/* Intrinsic subroutine resolution. */ + +void +gfc_resolve_alarm_sub (gfc_code *c) +{ + const char *name; + gfc_expr *seconds, *handler; + gfc_typespec ts; + gfc_clear_ts (&ts); + + seconds = c->ext.actual->expr; + handler = c->ext.actual->next->expr; + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE. + In all cases, the status argument is of default integer kind + (enforced in check.c) so that the function suffix is fixed. */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &ts, 2); + name = gfc_get_string (PREFIX ("alarm_sub_int_i%d"), + gfc_default_integer_kind); + } + else + name = gfc_get_string (PREFIX ("alarm_sub_i%d"), + gfc_default_integer_kind); + + if (seconds->ts.kind != gfc_c_int_kind) + gfc_convert_type (seconds, &ts, 2); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +void +gfc_resolve_cpu_time (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("cpu_time_%d"), c->ext.actual->expr->ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Create a formal arglist based on an actual one and set the INTENTs given. */ + +static gfc_formal_arglist* +create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints) +{ + gfc_formal_arglist* head; + gfc_formal_arglist* tail; + int i; + + if (!actual) + return NULL; + + head = tail = gfc_get_formal_arglist (); + for (i = 0; actual; actual = actual->next, tail = tail->next, ++i) + { + gfc_symbol* sym; + + sym = gfc_new_symbol ("dummyarg", NULL); + sym->ts = actual->expr->ts; + + sym->attr.intent = ints[i]; + tail->sym = sym; + + if (actual->next) + tail->next = gfc_get_formal_arglist (); + } + + return head; +} + + +void +gfc_resolve_atomic_def (gfc_code *c) +{ + const char *name = "atomic_define"; + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_atomic_ref (gfc_code *c) +{ + const char *name = "atomic_ref"; + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +void +gfc_resolve_event_query (gfc_code *c) +{ + const char *name = "event_query"; + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +void +gfc_resolve_mvbits (gfc_code *c) +{ + static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN, + INTENT_INOUT, INTENT_IN}; + const char *name; + + /* TO and FROM are guaranteed to have the same kind parameter. */ + name = gfc_get_string (PREFIX ("mvbits_i%d"), + c->ext.actual->expr->ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); + /* Mark as elemental subroutine as this does not happen automatically. */ + c->resolved_sym->attr.elemental = 1; + + /* Create a dummy formal arglist so the INTENTs are known later for purpose + of creating temporaries. */ + c->resolved_sym->formal = create_formal_for_intents (c->ext.actual, INTENTS); +} + + +/* Set up the call to RANDOM_INIT. */ + +void +gfc_resolve_random_init (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("random_init")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_random_number (gfc_code *c) +{ + const char *name; + int kind; + + kind = gfc_type_abi_kind (&c->ext.actual->expr->ts); + if (c->ext.actual->expr->rank == 0) + name = gfc_get_string (PREFIX ("random_r%d"), kind); + else + name = gfc_get_string (PREFIX ("arandom_r%d"), kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_random_seed (gfc_code *c) +{ + const char *name; + + name = gfc_get_string (PREFIX ("random_seed_i%d"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_rename_sub (gfc_code *c) +{ + const char *name; + int kind; + + /* Find the type of status. If not present use default integer kind. */ + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("rename_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_link_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("link_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_symlnk_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->next->expr != NULL) + kind = c->ext.actual->next->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("symlnk_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility subroutines dtime() and etime(). */ + +void +gfc_resolve_dtime_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("dtime_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +void +gfc_resolve_etime_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("etime_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility subroutines itime(), idate(), ltime() and gmtime(). */ + +void +gfc_resolve_itime (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("itime_i%d"), + gfc_default_integer_kind)); +} + +void +gfc_resolve_idate (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("idate_i%d"), + gfc_default_integer_kind)); +} + +void +gfc_resolve_ltime (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("ltime_i%d"), + gfc_default_integer_kind)); +} + +void +gfc_resolve_gmtime (gfc_code *c) +{ + c->resolved_sym + = gfc_get_intrinsic_sub_symbol (gfc_get_string (PREFIX ("gmtime_i%d"), + gfc_default_integer_kind)); +} + + +/* G77 compatibility subroutine second(). */ + +void +gfc_resolve_second_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("second_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_sleep_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->expr != NULL) + kind = c->ext.actual->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("sleep_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* G77 compatibility function srand(). */ + +void +gfc_resolve_srand (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("srand")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the getarg intrinsic subroutine. */ + +void +gfc_resolve_getarg (gfc_code *c) +{ + const char *name; + + if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the getcwd intrinsic subroutine. */ + +void +gfc_resolve_getcwd_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("getcwd_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the get_command intrinsic subroutine. */ + +void +gfc_resolve_get_command (gfc_code *c) +{ + const char *name; + int kind; + kind = gfc_default_integer_kind; + name = gfc_get_string (PREFIX ("get_command_i%d"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the get_command_argument intrinsic subroutine. */ + +void +gfc_resolve_get_command_argument (gfc_code *c) +{ + const char *name; + int kind; + kind = gfc_default_integer_kind; + name = gfc_get_string (PREFIX ("get_command_argument_i%d"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the get_environment_variable intrinsic subroutine. */ + +void +gfc_resolve_get_environment_variable (gfc_code *code) +{ + const char *name; + int kind; + kind = gfc_default_integer_kind; + name = gfc_get_string (PREFIX ("get_environment_variable_i%d"), kind); + code->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_signal_sub (gfc_code *c) +{ + const char *name; + gfc_expr *number, *handler, *status; + gfc_typespec ts; + gfc_clear_ts (&ts); + + number = c->ext.actual->expr; + handler = c->ext.actual->next->expr; + status = c->ext.actual->next->next->expr; + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + + /* handler can be either BT_INTEGER or BT_PROCEDURE */ + if (handler->ts.type == BT_INTEGER) + { + if (handler->ts.kind != gfc_c_int_kind) + gfc_convert_type (handler, &ts, 2); + name = gfc_get_string (PREFIX ("signal_sub_int")); + } + else + name = gfc_get_string (PREFIX ("signal_sub")); + + if (number->ts.kind != gfc_c_int_kind) + gfc_convert_type (number, &ts, 2); + if (status != NULL && status->ts.kind != gfc_c_int_kind) + gfc_convert_type (status, &ts, 2); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the SYSTEM intrinsic subroutine. */ + +void +gfc_resolve_system_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("system_sub")); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */ + +void +gfc_resolve_system_clock (gfc_code *c) +{ + const char *name; + int kind; + gfc_expr *count = c->ext.actual->expr; + gfc_expr *count_max = c->ext.actual->next->next->expr; + + /* The INTEGER(8) version has higher precision, it is used if both COUNT + and COUNT_MAX can hold 64-bit values, or are absent. */ + if ((!count || count->ts.kind >= 8) + && (!count_max || count_max->ts.kind >= 8)) + kind = 8; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("system_clock_%d"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the EXECUTE_COMMAND_LINE intrinsic subroutine. */ +void +gfc_resolve_execute_command_line (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("execute_command_line_i%d"), + gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the EXIT intrinsic subroutine. */ + +void +gfc_resolve_exit (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *n; + gfc_clear_ts (&ts); + + /* The STATUS argument has to be of default kind. If it is not, + we convert it. */ + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + n = c->ext.actual->expr; + if (n != NULL && n->ts.kind != ts.kind) + gfc_convert_type (n, &ts, 2); + + name = gfc_get_string (PREFIX ("exit_i%d"), ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +/* Resolve the FLUSH intrinsic subroutine. */ + +void +gfc_resolve_flush (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *n; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + n = c->ext.actual->expr; + if (n != NULL && n->ts.kind != ts.kind) + gfc_convert_type (n, &ts, 2); + + name = gfc_get_string (PREFIX ("flush_i%d"), ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_ctime_sub (gfc_code *c) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + /* ctime TIME argument is a INTEGER(KIND=8), says the doc */ + if (c->ext.actual->expr->ts.kind != 8) + { + ts.type = BT_INTEGER; + ts.kind = 8; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub")); +} + + +void +gfc_resolve_fdate_sub (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub")); +} + + +void +gfc_resolve_gerror (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror")); +} + + +void +gfc_resolve_getlog (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog")); +} + + +void +gfc_resolve_hostnm_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("hostnm_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_perror (gfc_code *c) +{ + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub")); +} + +/* Resolve the STAT and FSTAT intrinsic subroutines. */ + +void +gfc_resolve_stat_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_lstat_sub (gfc_code *c) +{ + const char *name; + name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fstat_sub (gfc_code *c) +{ + const char *name; + gfc_expr *u; + gfc_typespec *ts; + + u = c->ext.actual->expr; + ts = &c->ext.actual->next->expr->ts; + if (u->ts.kind != ts->kind) + gfc_convert_type (u, ts, 2); + name = gfc_get_string (PREFIX ("fstat_i%d_sub"), ts->kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fgetc_sub (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *u, *st; + gfc_clear_ts (&ts); + + u = c->ext.actual->expr; + st = c->ext.actual->next->next->expr; + + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + if (st != NULL) + name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fgetc_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fget_sub (gfc_code *c) +{ + const char *name; + gfc_expr *st; + + st = c->ext.actual->next->expr; + if (st != NULL) + name = gfc_get_string (PREFIX ("fget_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fget_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fputc_sub (gfc_code *c) +{ + const char *name; + gfc_typespec ts; + gfc_expr *u, *st; + gfc_clear_ts (&ts); + + u = c->ext.actual->expr; + st = c->ext.actual->next->next->expr; + + if (u->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (u, &ts, 2); + } + + if (st != NULL) + name = gfc_get_string (PREFIX ("fputc_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fputc_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fput_sub (gfc_code *c) +{ + const char *name; + gfc_expr *st; + + st = c->ext.actual->next->expr; + if (st != NULL) + name = gfc_get_string (PREFIX ("fput_i%d_sub"), st->ts.kind); + else + name = gfc_get_string (PREFIX ("fput_i%d_sub"), gfc_default_integer_kind); + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_fseek_sub (gfc_code *c) +{ + gfc_expr *unit; + gfc_expr *offset; + gfc_expr *whence; + gfc_typespec ts; + gfc_clear_ts (&ts); + + unit = c->ext.actual->expr; + offset = c->ext.actual->next->expr; + whence = c->ext.actual->next->next->expr; + + if (unit->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (unit, &ts, 2); + } + + if (offset->ts.kind != gfc_intio_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_intio_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (offset, &ts, 2); + } + + if (whence->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (whence, &ts, 2); + } + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub")); +} + +void +gfc_resolve_ftell_sub (gfc_code *c) +{ + const char *name; + gfc_expr *unit; + gfc_expr *offset; + gfc_typespec ts; + gfc_clear_ts (&ts); + + unit = c->ext.actual->expr; + offset = c->ext.actual->next->expr; + + if (unit->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (unit, &ts, 2); + } + + name = gfc_get_string (PREFIX ("ftell_i%d_sub"), offset->ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_ttynam_sub (gfc_code *c) +{ + gfc_typespec ts; + gfc_clear_ts (&ts); + + if (c->ext.actual->expr->ts.kind != gfc_c_int_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + ts.u.derived = NULL; + ts.u.cl = NULL; + gfc_convert_type (c->ext.actual->expr, &ts, 2); + } + + c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub")); +} + + +/* Resolve the UMASK intrinsic subroutine. */ + +void +gfc_resolve_umask_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("umask_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + +/* Resolve the UNLINK intrinsic subroutine. */ + +void +gfc_resolve_unlink_sub (gfc_code *c) +{ + const char *name; + int kind; + + if (c->ext.actual->next->expr != NULL) + kind = c->ext.actual->next->expr->ts.kind; + else + kind = gfc_default_integer_kind; + + name = gfc_get_string (PREFIX ("unlink_i%d_sub"), kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c deleted file mode 100644 index 1afc555..0000000 --- a/gcc/fortran/match.c +++ /dev/null @@ -1,7264 +0,0 @@ -/* Matching subroutines in all sizes, shapes and colors. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "match.h" -#include "parse.h" - -int gfc_matching_ptr_assignment = 0; -int gfc_matching_procptr_assignment = 0; -bool gfc_matching_prefix = false; - -/* Stack of SELECT TYPE statements. */ -gfc_select_type_stack *select_type_stack = NULL; - -/* List of type parameter expressions. */ -gfc_actual_arglist *type_param_spec_list; - -/* For debugging and diagnostic purposes. Return the textual representation - of the intrinsic operator OP. */ -const char * -gfc_op2string (gfc_intrinsic_op op) -{ - switch (op) - { - case INTRINSIC_UPLUS: - case INTRINSIC_PLUS: - return "+"; - - case INTRINSIC_UMINUS: - case INTRINSIC_MINUS: - return "-"; - - case INTRINSIC_POWER: - return "**"; - case INTRINSIC_CONCAT: - return "//"; - case INTRINSIC_TIMES: - return "*"; - case INTRINSIC_DIVIDE: - return "/"; - - case INTRINSIC_AND: - return ".and."; - case INTRINSIC_OR: - return ".or."; - case INTRINSIC_EQV: - return ".eqv."; - case INTRINSIC_NEQV: - return ".neqv."; - - case INTRINSIC_EQ_OS: - return ".eq."; - case INTRINSIC_EQ: - return "=="; - case INTRINSIC_NE_OS: - return ".ne."; - case INTRINSIC_NE: - return "/="; - case INTRINSIC_GE_OS: - return ".ge."; - case INTRINSIC_GE: - return ">="; - case INTRINSIC_LE_OS: - return ".le."; - case INTRINSIC_LE: - return "<="; - case INTRINSIC_LT_OS: - return ".lt."; - case INTRINSIC_LT: - return "<"; - case INTRINSIC_GT_OS: - return ".gt."; - case INTRINSIC_GT: - return ">"; - case INTRINSIC_NOT: - return ".not."; - - case INTRINSIC_ASSIGN: - return "="; - - case INTRINSIC_PARENTHESES: - return "parens"; - - case INTRINSIC_NONE: - return "none"; - - /* DTIO */ - case INTRINSIC_FORMATTED: - return "formatted"; - case INTRINSIC_UNFORMATTED: - return "unformatted"; - - default: - break; - } - - gfc_internal_error ("gfc_op2string(): Bad code"); - /* Not reached. */ -} - - -/******************** Generic matching subroutines ************************/ - -/* Matches a member separator. With standard FORTRAN this is '%', but with - DEC structures we must carefully match dot ('.'). - Because operators are spelled ".op.", a dotted string such as "x.y.z..." - can be either a component reference chain or a combination of binary - operations. - There is no real way to win because the string may be grammatically - ambiguous. The following rules help avoid ambiguities - they match - some behavior of other (older) compilers. If the rules here are changed - the test cases should be updated. If the user has problems with these rules - they probably deserve the consequences. Consider "x.y.z": - (1) If any user defined operator ".y." exists, this is always y(x,z) - (even if ".y." is the wrong type and/or x has a member y). - (2) Otherwise if x has a member y, and y is itself a derived type, - this is (x->y)->z, even if an intrinsic operator exists which - can handle (x,z). - (3) If x has no member y or (x->y) is not a derived type but ".y." - is an intrinsic operator (such as ".eq."), this is y(x,z). - (4) Lastly if there is no operator ".y." and x has no member "y", it is an - error. - It is worth noting that the logic here does not support mixed use of member - accessors within a single string. That is, even if x has component y and y - has component z, the following are all syntax errors: - "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z" - */ - -match -gfc_match_member_sep(gfc_symbol *sym) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus dot_loc, start_loc; - gfc_intrinsic_op iop; - match m; - gfc_symbol *tsym; - gfc_component *c = NULL; - - /* What a relief: '%' is an unambiguous member separator. */ - if (gfc_match_char ('%') == MATCH_YES) - return MATCH_YES; - - /* Beware ye who enter here. */ - if (!flag_dec_structure || !sym) - return MATCH_NO; - - tsym = NULL; - - /* We may be given either a derived type variable or the derived type - declaration itself (which actually contains the components); - we need the latter to search for components. */ - if (gfc_fl_struct (sym->attr.flavor)) - tsym = sym; - else if (gfc_bt_struct (sym->ts.type)) - tsym = sym->ts.u.derived; - - iop = INTRINSIC_NONE; - name[0] = '\0'; - m = MATCH_NO; - - /* If we have to reject come back here later. */ - start_loc = gfc_current_locus; - - /* Look for a component access next. */ - if (gfc_match_char ('.') != MATCH_YES) - return MATCH_NO; - - /* If we accept, come back here. */ - dot_loc = gfc_current_locus; - - /* Try to match a symbol name following the dot. */ - if (gfc_match_name (name) != MATCH_YES) - { - gfc_error ("Expected structure component or operator name " - "after '.' at %C"); - goto error; - } - - /* If no dot follows we have "x.y" which should be a component access. */ - if (gfc_match_char ('.') != MATCH_YES) - goto yes; - - /* Now we have a string "x.y.z" which could be a nested member access - (x->y)->z or a binary operation y on x and z. */ - - /* First use any user-defined operators ".y." */ - if (gfc_find_uop (name, sym->ns) != NULL) - goto no; - - /* Match accesses to existing derived-type components for - derived-type vars: "x.y.z" = (x->y)->z */ - c = gfc_find_component(tsym, name, false, true, NULL); - if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS)) - goto yes; - - /* If y is not a component or has no members, try intrinsic operators. */ - gfc_current_locus = start_loc; - if (gfc_match_intrinsic_op (&iop) != MATCH_YES) - { - /* If ".y." is not an intrinsic operator but y was a valid non- - structure component, match and leave the trailing dot to be - dealt with later. */ - if (c) - goto yes; - - gfc_error ("%qs is neither a defined operator nor a " - "structure component in dotted string at %C", name); - goto error; - } - - /* .y. is an intrinsic operator, overriding any possible member access. */ - goto no; - - /* Return keeping the current locus consistent with the match result. */ -error: - m = MATCH_ERROR; -no: - gfc_current_locus = start_loc; - return m; -yes: - gfc_current_locus = dot_loc; - return MATCH_YES; -} - - -/* This function scans the current statement counting the opened and closed - parenthesis to make sure they are balanced. */ - -match -gfc_match_parens (void) -{ - locus old_loc, where; - int count; - gfc_instring instring; - gfc_char_t c, quote; - - old_loc = gfc_current_locus; - count = 0; - instring = NONSTRING; - quote = ' '; - - for (;;) - { - if (count > 0) - where = gfc_current_locus; - c = gfc_next_char_literal (instring); - if (c == '\n') - break; - if (quote == ' ' && ((c == '\'') || (c == '"'))) - { - quote = c; - instring = INSTRING_WARN; - continue; - } - if (quote != ' ' && c == quote) - { - quote = ' '; - instring = NONSTRING; - continue; - } - - if (c == '(' && quote == ' ') - { - count++; - } - if (c == ')' && quote == ' ') - { - count--; - where = gfc_current_locus; - } - } - - gfc_current_locus = old_loc; - - if (count != 0) - { - gfc_error ("Missing %qs in statement at or before %L", - count > 0? ")":"(", &where); - return MATCH_ERROR; - } - - return MATCH_YES; -} - - -/* See if the next character is a special character that has - escaped by a \ via the -fbackslash option. */ - -match -gfc_match_special_char (gfc_char_t *res) -{ - int len, i; - gfc_char_t c, n; - match m; - - m = MATCH_YES; - - switch ((c = gfc_next_char_literal (INSTRING_WARN))) - { - case 'a': - *res = '\a'; - break; - case 'b': - *res = '\b'; - break; - case 't': - *res = '\t'; - break; - case 'f': - *res = '\f'; - break; - case 'n': - *res = '\n'; - break; - case 'r': - *res = '\r'; - break; - case 'v': - *res = '\v'; - break; - case '\\': - *res = '\\'; - break; - case '0': - *res = '\0'; - break; - - case 'x': - case 'u': - case 'U': - /* Hexadecimal form of wide characters. */ - len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8)); - n = 0; - for (i = 0; i < len; i++) - { - char buf[2] = { '\0', '\0' }; - - c = gfc_next_char_literal (INSTRING_WARN); - if (!gfc_wide_fits_in_byte (c) - || !gfc_check_digit ((unsigned char) c, 16)) - return MATCH_NO; - - buf[0] = (unsigned char) c; - n = n << 4; - n += strtol (buf, NULL, 16); - } - *res = n; - break; - - default: - /* Unknown backslash codes are simply not expanded. */ - m = MATCH_NO; - break; - } - - return m; -} - - -/* In free form, match at least one space. Always matches in fixed - form. */ - -match -gfc_match_space (void) -{ - locus old_loc; - char c; - - if (gfc_current_form == FORM_FIXED) - return MATCH_YES; - - old_loc = gfc_current_locus; - - c = gfc_next_ascii_char (); - if (!gfc_is_whitespace (c)) - { - gfc_current_locus = old_loc; - return MATCH_NO; - } - - gfc_gobble_whitespace (); - - return MATCH_YES; -} - - -/* Match an end of statement. End of statement is optional - whitespace, followed by a ';' or '\n' or comment '!'. If a - semicolon is found, we continue to eat whitespace and semicolons. */ - -match -gfc_match_eos (void) -{ - locus old_loc; - int flag; - char c; - - flag = 0; - - for (;;) - { - old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - - c = gfc_next_ascii_char (); - switch (c) - { - case '!': - do - { - c = gfc_next_ascii_char (); - } - while (c != '\n'); - - /* Fall through. */ - - case '\n': - return MATCH_YES; - - case ';': - flag = 1; - continue; - } - - break; - } - - gfc_current_locus = old_loc; - return (flag) ? MATCH_YES : MATCH_NO; -} - - -/* Match a literal integer on the input, setting the value on - MATCH_YES. Literal ints occur in kind-parameters as well as - old-style character length specifications. If cnt is non-NULL it - will be set to the number of digits. */ - -match -gfc_match_small_literal_int (int *value, int *cnt) -{ - locus old_loc; - char c; - int i, j; - - old_loc = gfc_current_locus; - - *value = -1; - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - if (cnt) - *cnt = 0; - - if (!ISDIGIT (c)) - { - gfc_current_locus = old_loc; - return MATCH_NO; - } - - i = c - '0'; - j = 1; - - for (;;) - { - old_loc = gfc_current_locus; - c = gfc_next_ascii_char (); - - if (!ISDIGIT (c)) - break; - - i = 10 * i + c - '0'; - j++; - - if (i > 99999999) - { - gfc_error ("Integer too large at %C"); - return MATCH_ERROR; - } - } - - gfc_current_locus = old_loc; - - *value = i; - if (cnt) - *cnt = j; - return MATCH_YES; -} - - -/* Match a small, constant integer expression, like in a kind - statement. On MATCH_YES, 'value' is set. */ - -match -gfc_match_small_int (int *value) -{ - gfc_expr *expr; - match m; - int i; - - m = gfc_match_expr (&expr); - if (m != MATCH_YES) - return m; - - if (gfc_extract_int (expr, &i, 1)) - m = MATCH_ERROR; - gfc_free_expr (expr); - - *value = i; - return m; -} - - -/* Matches a statement label. Uses gfc_match_small_literal_int() to - do most of the work. */ - -match -gfc_match_st_label (gfc_st_label **label) -{ - locus old_loc; - match m; - int i, cnt; - - old_loc = gfc_current_locus; - - m = gfc_match_small_literal_int (&i, &cnt); - if (m != MATCH_YES) - return m; - - if (cnt > 5) - { - gfc_error ("Too many digits in statement label at %C"); - goto cleanup; - } - - if (i == 0) - { - gfc_error ("Statement label at %C is zero"); - goto cleanup; - } - - *label = gfc_get_st_label (i); - return MATCH_YES; - -cleanup: - - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - - -/* Match and validate a label associated with a named IF, DO or SELECT - statement. If the symbol does not have the label attribute, we add - it. We also make sure the symbol does not refer to another - (active) block. A matched label is pointed to by gfc_new_block. */ - -static match -gfc_match_label (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - match m; - - gfc_new_block = NULL; - - m = gfc_match (" %n :", name); - if (m != MATCH_YES) - return m; - - if (gfc_get_symbol (name, NULL, &gfc_new_block)) - { - gfc_error ("Label name %qs at %C is ambiguous", name); - return MATCH_ERROR; - } - - if (gfc_new_block->attr.flavor == FL_LABEL) - { - gfc_error ("Duplicate construct label %qs at %C", name); - return MATCH_ERROR; - } - - if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, - gfc_new_block->name, NULL)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* See if the current input looks like a name of some sort. Modifies - the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. - Note that options.c restricts max_identifier_length to not more - than GFC_MAX_SYMBOL_LEN. */ - -match -gfc_match_name (char *buffer) -{ - locus old_loc; - int i; - char c; - - old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - - c = gfc_next_ascii_char (); - if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) - { - /* Special cases for unary minus and plus, which allows for a sensible - error message for code of the form 'c = exp(-a*b) )' where an - extra ')' appears at the end of statement. */ - if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+') - gfc_error ("Invalid character in name at %C"); - gfc_current_locus = old_loc; - return MATCH_NO; - } - - i = 0; - - do - { - buffer[i++] = c; - - if (i > gfc_option.max_identifier_length) - { - gfc_error ("Name at %C is too long"); - return MATCH_ERROR; - } - - old_loc = gfc_current_locus; - c = gfc_next_ascii_char (); - } - while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$')); - - if (c == '$' && !flag_dollar_ok) - { - gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to " - "allow it as an extension", &old_loc); - return MATCH_ERROR; - } - - buffer[i] = '\0'; - gfc_current_locus = old_loc; - - return MATCH_YES; -} - - -/* Match a symbol on the input. Modifies the pointer to the symbol - pointer if successful. */ - -match -gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) -{ - char buffer[GFC_MAX_SYMBOL_LEN + 1]; - match m; - - m = gfc_match_name (buffer); - if (m != MATCH_YES) - return m; - - if (host_assoc) - return (gfc_get_ha_sym_tree (buffer, matched_symbol)) - ? MATCH_ERROR : MATCH_YES; - - if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -match -gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) -{ - gfc_symtree *st; - match m; - - m = gfc_match_sym_tree (&st, host_assoc); - - if (m == MATCH_YES) - { - if (st) - *matched_symbol = st->n.sym; - else - *matched_symbol = NULL; - } - else - *matched_symbol = NULL; - return m; -} - - -/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, - we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this - in matchexp.c. */ - -match -gfc_match_intrinsic_op (gfc_intrinsic_op *result) -{ - locus orig_loc = gfc_current_locus; - char ch; - - gfc_gobble_whitespace (); - ch = gfc_next_ascii_char (); - switch (ch) - { - case '+': - /* Matched "+". */ - *result = INTRINSIC_PLUS; - return MATCH_YES; - - case '-': - /* Matched "-". */ - *result = INTRINSIC_MINUS; - return MATCH_YES; - - case '=': - if (gfc_next_ascii_char () == '=') - { - /* Matched "==". */ - *result = INTRINSIC_EQ; - return MATCH_YES; - } - break; - - case '<': - if (gfc_peek_ascii_char () == '=') - { - /* Matched "<=". */ - gfc_next_ascii_char (); - *result = INTRINSIC_LE; - return MATCH_YES; - } - /* Matched "<". */ - *result = INTRINSIC_LT; - return MATCH_YES; - - case '>': - if (gfc_peek_ascii_char () == '=') - { - /* Matched ">=". */ - gfc_next_ascii_char (); - *result = INTRINSIC_GE; - return MATCH_YES; - } - /* Matched ">". */ - *result = INTRINSIC_GT; - return MATCH_YES; - - case '*': - if (gfc_peek_ascii_char () == '*') - { - /* Matched "**". */ - gfc_next_ascii_char (); - *result = INTRINSIC_POWER; - return MATCH_YES; - } - /* Matched "*". */ - *result = INTRINSIC_TIMES; - return MATCH_YES; - - case '/': - ch = gfc_peek_ascii_char (); - if (ch == '=') - { - /* Matched "/=". */ - gfc_next_ascii_char (); - *result = INTRINSIC_NE; - return MATCH_YES; - } - else if (ch == '/') - { - /* Matched "//". */ - gfc_next_ascii_char (); - *result = INTRINSIC_CONCAT; - return MATCH_YES; - } - /* Matched "/". */ - *result = INTRINSIC_DIVIDE; - return MATCH_YES; - - case '.': - ch = gfc_next_ascii_char (); - switch (ch) - { - case 'a': - if (gfc_next_ascii_char () == 'n' - && gfc_next_ascii_char () == 'd' - && gfc_next_ascii_char () == '.') - { - /* Matched ".and.". */ - *result = INTRINSIC_AND; - return MATCH_YES; - } - break; - - case 'e': - if (gfc_next_ascii_char () == 'q') - { - ch = gfc_next_ascii_char (); - if (ch == '.') - { - /* Matched ".eq.". */ - *result = INTRINSIC_EQ_OS; - return MATCH_YES; - } - else if (ch == 'v') - { - if (gfc_next_ascii_char () == '.') - { - /* Matched ".eqv.". */ - *result = INTRINSIC_EQV; - return MATCH_YES; - } - } - } - break; - - case 'g': - ch = gfc_next_ascii_char (); - if (ch == 'e') - { - if (gfc_next_ascii_char () == '.') - { - /* Matched ".ge.". */ - *result = INTRINSIC_GE_OS; - return MATCH_YES; - } - } - else if (ch == 't') - { - if (gfc_next_ascii_char () == '.') - { - /* Matched ".gt.". */ - *result = INTRINSIC_GT_OS; - return MATCH_YES; - } - } - break; - - case 'l': - ch = gfc_next_ascii_char (); - if (ch == 'e') - { - if (gfc_next_ascii_char () == '.') - { - /* Matched ".le.". */ - *result = INTRINSIC_LE_OS; - return MATCH_YES; - } - } - else if (ch == 't') - { - if (gfc_next_ascii_char () == '.') - { - /* Matched ".lt.". */ - *result = INTRINSIC_LT_OS; - return MATCH_YES; - } - } - break; - - case 'n': - ch = gfc_next_ascii_char (); - if (ch == 'e') - { - ch = gfc_next_ascii_char (); - if (ch == '.') - { - /* Matched ".ne.". */ - *result = INTRINSIC_NE_OS; - return MATCH_YES; - } - else if (ch == 'q') - { - if (gfc_next_ascii_char () == 'v' - && gfc_next_ascii_char () == '.') - { - /* Matched ".neqv.". */ - *result = INTRINSIC_NEQV; - return MATCH_YES; - } - } - } - else if (ch == 'o') - { - if (gfc_next_ascii_char () == 't' - && gfc_next_ascii_char () == '.') - { - /* Matched ".not.". */ - *result = INTRINSIC_NOT; - return MATCH_YES; - } - } - break; - - case 'o': - if (gfc_next_ascii_char () == 'r' - && gfc_next_ascii_char () == '.') - { - /* Matched ".or.". */ - *result = INTRINSIC_OR; - return MATCH_YES; - } - break; - - case 'x': - if (gfc_next_ascii_char () == 'o' - && gfc_next_ascii_char () == 'r' - && gfc_next_ascii_char () == '.') - { - if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C")) - return MATCH_ERROR; - /* Matched ".xor." - equivalent to ".neqv.". */ - *result = INTRINSIC_NEQV; - return MATCH_YES; - } - break; - - default: - break; - } - break; - - default: - break; - } - - gfc_current_locus = orig_loc; - return MATCH_NO; -} - - -/* Match a loop control phrase: - - = , [, ] - - If the final integer expression is not present, a constant unity - expression is returned. We don't return MATCH_ERROR until after - the equals sign is seen. */ - -match -gfc_match_iterator (gfc_iterator *iter, int init_flag) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_expr *var, *e1, *e2, *e3; - locus start; - match m; - - e1 = e2 = e3 = NULL; - - /* Match the start of an iterator without affecting the symbol table. */ - - start = gfc_current_locus; - m = gfc_match (" %n =", name); - gfc_current_locus = start; - - if (m != MATCH_YES) - return MATCH_NO; - - m = gfc_match_variable (&var, 0); - if (m != MATCH_YES) - return MATCH_NO; - - if (var->symtree->n.sym->attr.dimension) - { - gfc_error ("Loop variable at %C cannot be an array"); - goto cleanup; - } - - /* F2008, C617 & C565. */ - if (var->symtree->n.sym->attr.codimension) - { - gfc_error ("Loop variable at %C cannot be a coarray"); - goto cleanup; - } - - if (var->ref != NULL) - { - gfc_error ("Loop variable at %C cannot be a sub-component"); - goto cleanup; - } - - gfc_match_char ('='); - - var->symtree->n.sym->attr.implied_index = 1; - - m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_char (',') != MATCH_YES) - { - e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - goto done; - } - - m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - gfc_error ("Expected a step value in iterator at %C"); - goto cleanup; - } - -done: - iter->var = var; - iter->start = e1; - iter->end = e2; - iter->step = e3; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in iterator at %C"); - -cleanup: - gfc_free_expr (e1); - gfc_free_expr (e2); - gfc_free_expr (e3); - - return MATCH_ERROR; -} - - -/* Tries to match the next non-whitespace character on the input. - This subroutine does not return MATCH_ERROR. */ - -match -gfc_match_char (char c) -{ - locus where; - - where = gfc_current_locus; - gfc_gobble_whitespace (); - - if (gfc_next_ascii_char () == c) - return MATCH_YES; - - gfc_current_locus = where; - return MATCH_NO; -} - - -/* General purpose matching subroutine. The target string is a - scanf-like format string in which spaces correspond to arbitrary - whitespace (including no whitespace), characters correspond to - themselves. The %-codes are: - - %% Literal percent sign - %e Expression, pointer to a pointer is set - %s Symbol, pointer to the symbol is set - %n Name, character buffer is set to name - %t Matches end of statement. - %o Matches an intrinsic operator, returned as an INTRINSIC enum. - %l Matches a statement label - %v Matches a variable expression (an lvalue, except function references - having a data pointer result) - % Matches a required space (in free form) and optional spaces. */ - -match -gfc_match (const char *target, ...) -{ - gfc_st_label **label; - int matches, *ip; - locus old_loc; - va_list argp; - char c, *np; - match m, n; - void **vp; - const char *p; - - old_loc = gfc_current_locus; - va_start (argp, target); - m = MATCH_NO; - matches = 0; - p = target; - -loop: - c = *p++; - switch (c) - { - case ' ': - gfc_gobble_whitespace (); - goto loop; - case '\0': - m = MATCH_YES; - break; - - case '%': - c = *p++; - switch (c) - { - case 'e': - vp = va_arg (argp, void **); - n = gfc_match_expr ((gfc_expr **) vp); - if (n != MATCH_YES) - { - m = n; - goto not_yes; - } - - matches++; - goto loop; - - case 'v': - vp = va_arg (argp, void **); - n = gfc_match_variable ((gfc_expr **) vp, 0); - if (n != MATCH_YES) - { - m = n; - goto not_yes; - } - - matches++; - goto loop; - - case 's': - vp = va_arg (argp, void **); - n = gfc_match_symbol ((gfc_symbol **) vp, 0); - if (n != MATCH_YES) - { - m = n; - goto not_yes; - } - - matches++; - goto loop; - - case 'n': - np = va_arg (argp, char *); - n = gfc_match_name (np); - if (n != MATCH_YES) - { - m = n; - goto not_yes; - } - - matches++; - goto loop; - - case 'l': - label = va_arg (argp, gfc_st_label **); - n = gfc_match_st_label (label); - if (n != MATCH_YES) - { - m = n; - goto not_yes; - } - - matches++; - goto loop; - - case 'o': - ip = va_arg (argp, int *); - n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip); - if (n != MATCH_YES) - { - m = n; - goto not_yes; - } - - matches++; - goto loop; - - case 't': - if (gfc_match_eos () != MATCH_YES) - { - m = MATCH_NO; - goto not_yes; - } - goto loop; - - case ' ': - if (gfc_match_space () == MATCH_YES) - goto loop; - m = MATCH_NO; - goto not_yes; - - case '%': - break; /* Fall through to character matcher. */ - - default: - gfc_internal_error ("gfc_match(): Bad match code %c", c); - } - /* FALLTHRU */ - - default: - - /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't - expect an upper case character here! */ - gcc_assert (TOLOWER (c) == c); - - if (c == gfc_next_ascii_char ()) - goto loop; - break; - } - -not_yes: - va_end (argp); - - if (m != MATCH_YES) - { - /* Clean up after a failed match. */ - gfc_current_locus = old_loc; - va_start (argp, target); - - p = target; - for (; matches > 0; matches--) - { - while (*p++ != '%'); - - switch (*p++) - { - case '%': - matches++; - break; /* Skip. */ - - /* Matches that don't have to be undone */ - case 'o': - case 'l': - case 'n': - case 's': - (void) va_arg (argp, void **); - break; - - case 'e': - case 'v': - vp = va_arg (argp, void **); - gfc_free_expr ((struct gfc_expr *)*vp); - *vp = NULL; - break; - } - } - - va_end (argp); - } - - return m; -} - - -/*********************** Statement level matching **********************/ - -/* Matches the start of a program unit, which is the program keyword - followed by an obligatory symbol. */ - -match -gfc_match_program (void) -{ - gfc_symbol *sym; - match m; - - m = gfc_match ("% %s%t", &sym); - - if (m == MATCH_NO) - { - gfc_error ("Invalid form of PROGRAM statement at %C"); - m = MATCH_ERROR; - } - - if (m == MATCH_ERROR) - return m; - - if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL)) - return MATCH_ERROR; - - gfc_new_block = sym; - - return MATCH_YES; -} - - -/* Match a simple assignment statement. */ - -match -gfc_match_assignment (void) -{ - gfc_expr *lvalue, *rvalue; - locus old_loc; - match m; - - old_loc = gfc_current_locus; - - lvalue = NULL; - m = gfc_match (" %v =", &lvalue); - if (m != MATCH_YES) - { - gfc_current_locus = old_loc; - gfc_free_expr (lvalue); - return MATCH_NO; - } - - rvalue = NULL; - m = gfc_match (" %e%t", &rvalue); - - if (m == MATCH_YES - && rvalue->ts.type == BT_BOZ - && lvalue->ts.type == BT_CLASS) - { - m = MATCH_ERROR; - gfc_error ("BOZ literal constant at %L is neither a DATA statement " - "value nor an actual argument of INT/REAL/DBLE/CMPLX " - "intrinsic subprogram", &rvalue->where); - } - - if (lvalue->expr_type == EXPR_CONSTANT) - { - /* This clobbers %len and %kind. */ - m = MATCH_ERROR; - gfc_error ("Assignment to a constant expression at %C"); - } - - if (m != MATCH_YES) - { - gfc_current_locus = old_loc; - gfc_free_expr (lvalue); - gfc_free_expr (rvalue); - return m; - } - - if (!lvalue->symtree) - { - gfc_free_expr (lvalue); - gfc_free_expr (rvalue); - return MATCH_ERROR; - } - - - gfc_set_sym_referenced (lvalue->symtree->n.sym); - - new_st.op = EXEC_ASSIGN; - new_st.expr1 = lvalue; - new_st.expr2 = rvalue; - - gfc_check_do_variable (lvalue->symtree); - - return MATCH_YES; -} - - -/* Match a pointer assignment statement. */ - -match -gfc_match_pointer_assignment (void) -{ - gfc_expr *lvalue, *rvalue; - locus old_loc; - match m; - - old_loc = gfc_current_locus; - - lvalue = rvalue = NULL; - gfc_matching_ptr_assignment = 0; - gfc_matching_procptr_assignment = 0; - - m = gfc_match (" %v =>", &lvalue); - if (m != MATCH_YES || !lvalue->symtree) - { - m = MATCH_NO; - goto cleanup; - } - - if (lvalue->symtree->n.sym->attr.proc_pointer - || gfc_is_proc_ptr_comp (lvalue)) - gfc_matching_procptr_assignment = 1; - else - gfc_matching_ptr_assignment = 1; - - m = gfc_match (" %e%t", &rvalue); - gfc_matching_ptr_assignment = 0; - gfc_matching_procptr_assignment = 0; - if (m != MATCH_YES) - goto cleanup; - - new_st.op = EXEC_POINTER_ASSIGN; - new_st.expr1 = lvalue; - new_st.expr2 = rvalue; - - return MATCH_YES; - -cleanup: - gfc_current_locus = old_loc; - gfc_free_expr (lvalue); - gfc_free_expr (rvalue); - return m; -} - - -/* We try to match an easy arithmetic IF statement. This only happens - when just after having encountered a simple IF statement. This code - is really duplicate with parts of the gfc_match_if code, but this is - *much* easier. */ - -static match -match_arithmetic_if (void) -{ - gfc_st_label *l1, *l2, *l3; - gfc_expr *expr; - match m; - - m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3); - if (m != MATCH_YES) - return m; - - if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) - || !gfc_reference_st_label (l2, ST_LABEL_TARGET) - || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) - { - gfc_free_expr (expr); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, - "Arithmetic IF statement at %C")) - return MATCH_ERROR; - - new_st.op = EXEC_ARITHMETIC_IF; - new_st.expr1 = expr; - new_st.label1 = l1; - new_st.label2 = l2; - new_st.label3 = l3; - - return MATCH_YES; -} - - -/* The IF statement is a bit of a pain. First of all, there are three - forms of it, the simple IF, the IF that starts a block and the - arithmetic IF. - - There is a problem with the simple IF and that is the fact that we - only have a single level of undo information on symbols. What this - means is for a simple IF, we must re-match the whole IF statement - multiple times in order to guarantee that the symbol table ends up - in the proper state. */ - -static match match_simple_forall (void); -static match match_simple_where (void); - -match -gfc_match_if (gfc_statement *if_type) -{ - gfc_expr *expr; - gfc_st_label *l1, *l2, *l3; - locus old_loc, old_loc2; - gfc_code *p; - match m, n; - - n = gfc_match_label (); - if (n == MATCH_ERROR) - return n; - - old_loc = gfc_current_locus; - - m = gfc_match (" if ", &expr); - if (m != MATCH_YES) - return m; - - if (gfc_match_char ('(') != MATCH_YES) - { - gfc_error ("Missing %<(%> in IF-expression at %C"); - return MATCH_ERROR; - } - - m = gfc_match ("%e", &expr); - if (m != MATCH_YES) - return m; - - old_loc2 = gfc_current_locus; - gfc_current_locus = old_loc; - - if (gfc_match_parens () == MATCH_ERROR) - return MATCH_ERROR; - - gfc_current_locus = old_loc2; - - if (gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Syntax error in IF-expression at %C"); - gfc_free_expr (expr); - return MATCH_ERROR; - } - - m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3); - - if (m == MATCH_YES) - { - if (n == MATCH_YES) - { - gfc_error ("Block label not appropriate for arithmetic IF " - "statement at %C"); - gfc_free_expr (expr); - return MATCH_ERROR; - } - - if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) - || !gfc_reference_st_label (l2, ST_LABEL_TARGET) - || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) - { - gfc_free_expr (expr); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, - "Arithmetic IF statement at %C")) - return MATCH_ERROR; - - new_st.op = EXEC_ARITHMETIC_IF; - new_st.expr1 = expr; - new_st.label1 = l1; - new_st.label2 = l2; - new_st.label3 = l3; - - *if_type = ST_ARITHMETIC_IF; - return MATCH_YES; - } - - if (gfc_match (" then%t") == MATCH_YES) - { - new_st.op = EXEC_IF; - new_st.expr1 = expr; - *if_type = ST_IF_BLOCK; - return MATCH_YES; - } - - if (n == MATCH_YES) - { - gfc_error ("Block label is not appropriate for IF statement at %C"); - gfc_free_expr (expr); - return MATCH_ERROR; - } - - /* At this point the only thing left is a simple IF statement. At - this point, n has to be MATCH_NO, so we don't have to worry about - re-matching a block label. From what we've got so far, try - matching an assignment. */ - - *if_type = ST_SIMPLE_IF; - - m = gfc_match_assignment (); - if (m == MATCH_YES) - goto got_match; - - gfc_free_expr (expr); - gfc_undo_symbols (); - gfc_current_locus = old_loc; - - /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled - assignment was found. For MATCH_NO, continue to call the various - matchers. */ - if (m == MATCH_ERROR) - return MATCH_ERROR; - - gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ - - m = gfc_match_pointer_assignment (); - if (m == MATCH_YES) - goto got_match; - - gfc_free_expr (expr); - gfc_undo_symbols (); - gfc_current_locus = old_loc; - - gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ - - /* Look at the next keyword to see which matcher to call. Matching - the keyword doesn't affect the symbol table, so we don't have to - restore between tries. */ - -#define match(string, subr, statement) \ - if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; } - - gfc_clear_error (); - - match ("allocate", gfc_match_allocate, ST_ALLOCATE) - match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) - match ("backspace", gfc_match_backspace, ST_BACKSPACE) - match ("call", gfc_match_call, ST_CALL) - match ("change team", gfc_match_change_team, ST_CHANGE_TEAM) - match ("close", gfc_match_close, ST_CLOSE) - match ("continue", gfc_match_continue, ST_CONTINUE) - match ("cycle", gfc_match_cycle, ST_CYCLE) - match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) - match ("end file", gfc_match_endfile, ST_END_FILE) - match ("end team", gfc_match_end_team, ST_END_TEAM) - match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) - match ("event post", gfc_match_event_post, ST_EVENT_POST) - match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) - match ("exit", gfc_match_exit, ST_EXIT) - match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE) - match ("flush", gfc_match_flush, ST_FLUSH) - match ("forall", match_simple_forall, ST_FORALL) - match ("form team", gfc_match_form_team, ST_FORM_TEAM) - match ("go to", gfc_match_goto, ST_GOTO) - match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) - match ("inquire", gfc_match_inquire, ST_INQUIRE) - match ("lock", gfc_match_lock, ST_LOCK) - match ("nullify", gfc_match_nullify, ST_NULLIFY) - match ("open", gfc_match_open, ST_OPEN) - match ("pause", gfc_match_pause, ST_NONE) - match ("print", gfc_match_print, ST_WRITE) - match ("read", gfc_match_read, ST_READ) - match ("return", gfc_match_return, ST_RETURN) - match ("rewind", gfc_match_rewind, ST_REWIND) - match ("stop", gfc_match_stop, ST_STOP) - match ("wait", gfc_match_wait, ST_WAIT) - match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); - match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); - match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); - match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM) - match ("unlock", gfc_match_unlock, ST_UNLOCK) - match ("where", match_simple_where, ST_WHERE) - match ("write", gfc_match_write, ST_WRITE) - - if (flag_dec) - match ("type", gfc_match_print, ST_WRITE) - - /* All else has failed, so give up. See if any of the matchers has - stored an error message of some sort. */ - if (!gfc_error_check ()) - gfc_error ("Syntax error in IF-clause after %C"); - - gfc_free_expr (expr); - return MATCH_ERROR; - -got_match: - if (m == MATCH_NO) - gfc_error ("Syntax error in IF-clause after %C"); - if (m != MATCH_YES) - { - gfc_free_expr (expr); - return MATCH_ERROR; - } - - /* At this point, we've matched the single IF and the action clause - is in new_st. Rearrange things so that the IF statement appears - in new_st. */ - - p = gfc_get_code (EXEC_IF); - p->next = XCNEW (gfc_code); - *p->next = new_st; - p->next->loc = gfc_current_locus; - - p->expr1 = expr; - - gfc_clear_new_st (); - - new_st.op = EXEC_IF; - new_st.block = p; - - return MATCH_YES; -} - -#undef match - - -/* Match an ELSE statement. */ - -match -gfc_match_else (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - - if (gfc_match_name (name) != MATCH_YES - || gfc_current_block () == NULL - || gfc_match_eos () != MATCH_YES) - { - gfc_error ("Invalid character(s) in ELSE statement after %C"); - return MATCH_ERROR; - } - - if (strcmp (name, gfc_current_block ()->name) != 0) - { - gfc_error ("Label %qs at %C doesn't match IF label %qs", - name, gfc_current_block ()->name); - return MATCH_ERROR; - } - - return MATCH_YES; -} - - -/* Match an ELSE IF statement. */ - -match -gfc_match_elseif (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_expr *expr, *then; - locus where; - match m; - - if (gfc_match_char ('(') != MATCH_YES) - { - gfc_error ("Missing %<(%> in ELSE IF expression at %C"); - return MATCH_ERROR; - } - - m = gfc_match (" %e ", &expr); - if (m != MATCH_YES) - return m; - - if (gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Missing %<)%> in ELSE IF expression at %C"); - goto cleanup; - } - - m = gfc_match (" then ", &then); - - where = gfc_current_locus; - - if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES - || (gfc_current_block () - && gfc_match_name (name) == MATCH_YES))) - goto done; - - if (gfc_match_eos () == MATCH_YES) - { - gfc_error ("Missing THEN in ELSE IF statement after %L", &where); - goto cleanup; - } - - if (gfc_match_name (name) != MATCH_YES - || gfc_current_block () == NULL - || gfc_match_eos () != MATCH_YES) - { - gfc_error ("Syntax error in ELSE IF statement after %L", &where); - goto cleanup; - } - - if (strcmp (name, gfc_current_block ()->name) != 0) - { - gfc_error ("Label %qs after %L doesn't match IF label %qs", - name, &where, gfc_current_block ()->name); - goto cleanup; - } - - if (m != MATCH_YES) - return m; - -done: - new_st.op = EXEC_IF; - new_st.expr1 = expr; - return MATCH_YES; - -cleanup: - gfc_free_expr (expr); - return MATCH_ERROR; -} - - -/* Free a gfc_iterator structure. */ - -void -gfc_free_iterator (gfc_iterator *iter, int flag) -{ - - if (iter == NULL) - return; - - gfc_free_expr (iter->var); - gfc_free_expr (iter->start); - gfc_free_expr (iter->end); - gfc_free_expr (iter->step); - - if (flag) - free (iter); -} - - -/* Match a CRITICAL statement. */ -match -gfc_match_critical (void) -{ - gfc_st_label *label = NULL; - - if (gfc_match_label () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" critical") != MATCH_YES) - return MATCH_NO; - - if (gfc_match_st_label (&label) == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match_eos () != MATCH_YES) - { - gfc_syntax_error (ST_CRITICAL); - return MATCH_ERROR; - } - - if (gfc_pure (NULL)) - { - gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT " - "block"); - return MATCH_ERROR; - } - - gfc_unset_implicit_pure (NULL); - - if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")) - return MATCH_ERROR; - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " - "enable"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("Nested CRITICAL block at %C"); - return MATCH_ERROR; - } - - new_st.op = EXEC_CRITICAL; - - if (label != NULL - && !gfc_reference_st_label (label, ST_LABEL_TARGET)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* Match a BLOCK statement. */ - -match -gfc_match_block (void) -{ - match m; - - if (gfc_match_label () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" block") != MATCH_YES) - return MATCH_NO; - - /* For this to be a correct BLOCK statement, the line must end now. */ - m = gfc_match_eos (); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - return MATCH_NO; - - return MATCH_YES; -} - - -/* Match an ASSOCIATE statement. */ - -match -gfc_match_associate (void) -{ - if (gfc_match_label () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" associate") != MATCH_YES) - return MATCH_NO; - - /* Match the association list. */ - if (gfc_match_char ('(') != MATCH_YES) - { - gfc_error ("Expected association list at %C"); - return MATCH_ERROR; - } - new_st.ext.block.assoc = NULL; - while (true) - { - gfc_association_list* newAssoc = gfc_get_association_list (); - gfc_association_list* a; - - /* Match the next association. */ - if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES) - { - gfc_error ("Expected association at %C"); - goto assocListError; - } - - if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) - { - /* Have another go, allowing for procedure pointer selectors. */ - gfc_matching_procptr_assignment = 1; - if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) - { - gfc_error ("Invalid association target at %C"); - goto assocListError; - } - gfc_matching_procptr_assignment = 0; - } - newAssoc->where = gfc_current_locus; - - /* Check that the current name is not yet in the list. */ - for (a = new_st.ext.block.assoc; a; a = a->next) - if (!strcmp (a->name, newAssoc->name)) - { - gfc_error ("Duplicate name %qs in association at %C", - newAssoc->name); - goto assocListError; - } - - /* The target expression must not be coindexed. */ - if (gfc_is_coindexed (newAssoc->target)) - { - gfc_error ("Association target at %C must not be coindexed"); - goto assocListError; - } - - /* The target expression cannot be a BOZ literal constant. */ - if (newAssoc->target->ts.type == BT_BOZ) - { - gfc_error ("Association target at %L cannot be a BOZ literal " - "constant", &newAssoc->target->where); - goto assocListError; - } - - /* The `variable' field is left blank for now; because the target is not - yet resolved, we can't use gfc_has_vector_subscript to determine it - for now. This is set during resolution. */ - - /* Put it into the list. */ - newAssoc->next = new_st.ext.block.assoc; - new_st.ext.block.assoc = newAssoc; - - /* Try next one or end if closing parenthesis is found. */ - gfc_gobble_whitespace (); - if (gfc_peek_char () == ')') - break; - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expected %<)%> or %<,%> at %C"); - return MATCH_ERROR; - } - - continue; - -assocListError: - free (newAssoc); - goto error; - } - if (gfc_match_char (')') != MATCH_YES) - { - /* This should never happen as we peek above. */ - gcc_unreachable (); - } - - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after ASSOCIATE statement at %C"); - goto error; - } - - return MATCH_YES; - -error: - gfc_free_association_list (new_st.ext.block.assoc); - return MATCH_ERROR; -} - - -/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of - an accessible derived type. */ - -static match -match_derived_type_spec (gfc_typespec *ts) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; - gfc_symbol *derived, *der_type; - match m = MATCH_YES; - gfc_actual_arglist *decl_type_param_list = NULL; - bool is_pdt_template = false; - - old_locus = gfc_current_locus; - - if (gfc_match ("%n", name) != MATCH_YES) - { - gfc_current_locus = old_locus; - return MATCH_NO; - } - - gfc_find_symbol (name, NULL, 1, &derived); - - /* Match the PDT spec list, if there. */ - if (derived && derived->attr.flavor == FL_PROCEDURE) - { - gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type); - is_pdt_template = der_type - && der_type->attr.flavor == FL_DERIVED - && der_type->attr.pdt_template; - } - - if (is_pdt_template) - m = gfc_match_actual_arglist (1, &decl_type_param_list, true); - - if (m == MATCH_ERROR) - { - gfc_free_actual_arglist (decl_type_param_list); - return m; - } - - if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic) - derived = gfc_find_dt_in_generic (derived); - - /* If this is a PDT, find the specific instance. */ - if (m == MATCH_YES && is_pdt_template) - { - gfc_namespace *old_ns; - - old_ns = gfc_current_ns; - while (gfc_current_ns && gfc_current_ns->parent) - gfc_current_ns = gfc_current_ns->parent; - - if (type_param_spec_list) - gfc_free_actual_arglist (type_param_spec_list); - m = gfc_get_pdt_instance (decl_type_param_list, &der_type, - &type_param_spec_list); - gfc_free_actual_arglist (decl_type_param_list); - - if (m != MATCH_YES) - return m; - derived = der_type; - gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type); - gfc_set_sym_referenced (derived); - - gfc_current_ns = old_ns; - } - - if (derived && derived->attr.flavor == FL_DERIVED) - { - ts->type = BT_DERIVED; - ts->u.derived = derived; - return MATCH_YES; - } - - gfc_current_locus = old_locus; - return MATCH_NO; -} - - -/* Match a Fortran 2003 type-spec (F03:R401). This is similar to - gfc_match_decl_type_spec() from decl.c, with the following exceptions: - It only includes the intrinsic types from the Fortran 2003 standard - (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, - the implicit_flag is not needed, so it was removed. Derived types are - identified by their name alone. */ - -match -gfc_match_type_spec (gfc_typespec *ts) -{ - match m; - locus old_locus; - char c, name[GFC_MAX_SYMBOL_LEN + 1]; - - gfc_clear_ts (ts); - gfc_gobble_whitespace (); - old_locus = gfc_current_locus; - - /* If c isn't [a-z], then return immediately. */ - c = gfc_peek_ascii_char (); - if (!ISALPHA(c)) - return MATCH_NO; - - type_param_spec_list = NULL; - - if (match_derived_type_spec (ts) == MATCH_YES) - { - /* Enforce F03:C401. */ - if (ts->u.derived->attr.abstract) - { - gfc_error ("Derived type %qs at %L may not be ABSTRACT", - ts->u.derived->name, &old_locus); - return MATCH_ERROR; - } - return MATCH_YES; - } - - if (gfc_match ("integer") == MATCH_YES) - { - ts->type = BT_INTEGER; - ts->kind = gfc_default_integer_kind; - goto kind_selector; - } - - if (gfc_match ("double precision") == MATCH_YES) - { - ts->type = BT_REAL; - ts->kind = gfc_default_double_kind; - return MATCH_YES; - } - - if (gfc_match ("complex") == MATCH_YES) - { - ts->type = BT_COMPLEX; - ts->kind = gfc_default_complex_kind; - goto kind_selector; - } - - if (gfc_match ("character") == MATCH_YES) - { - ts->type = BT_CHARACTER; - - m = gfc_match_char_spec (ts); - - if (m == MATCH_NO) - m = MATCH_YES; - - return m; - } - - /* REAL is a real pain because it can be a type, intrinsic subprogram, - or list item in a type-list of an OpenMP reduction clause. Need to - differentiate REAL([KIND]=scalar-int-initialization-expr) from - REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was - written the use of LOGICAL as a type-spec or intrinsic subprogram - was overlooked. */ - - m = gfc_match (" %n", name); - if (m == MATCH_YES - && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0)) - { - char c; - gfc_expr *e; - locus where; - - if (*name == 'r') - { - ts->type = BT_REAL; - ts->kind = gfc_default_real_kind; - } - else - { - ts->type = BT_LOGICAL; - ts->kind = gfc_default_logical_kind; - } - - gfc_gobble_whitespace (); - - /* Prevent REAL*4, etc. */ - c = gfc_peek_ascii_char (); - if (c == '*') - { - gfc_error ("Invalid type-spec at %C"); - return MATCH_ERROR; - } - - /* Found leading colon in REAL::, a trailing ')' in for example - TYPE IS (REAL), or REAL, for an OpenMP list-item. */ - if (c == ':' || c == ')' || (flag_openmp && c == ',')) - return MATCH_YES; - - /* Found something other than the opening '(' in REAL(... */ - if (c != '(') - return MATCH_NO; - else - gfc_next_char (); /* Burn the '('. */ - - /* Look for the optional KIND=. */ - where = gfc_current_locus; - m = gfc_match ("%n", name); - if (m == MATCH_YES) - { - gfc_gobble_whitespace (); - c = gfc_next_char (); - if (c == '=') - { - if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0) - return MATCH_NO; - else if (strcmp(name, "kind") == 0) - goto found; - else - return MATCH_ERROR; - } - else - gfc_current_locus = where; - } - else - gfc_current_locus = where; - -found: - - m = gfc_match_expr (&e); - if (m == MATCH_NO || m == MATCH_ERROR) - return m; - - /* If a comma appears, it is an intrinsic subprogram. */ - gfc_gobble_whitespace (); - c = gfc_peek_ascii_char (); - if (c == ',') - { - gfc_free_expr (e); - return MATCH_NO; - } - - /* If ')' appears, we have REAL(initialization-expr), here check for - a scalar integer initialization-expr and valid kind parameter. */ - if (c == ')') - { - bool ok = true; - if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE) - ok = gfc_reduce_init_expr (e); - if (!ok || e->ts.type != BT_INTEGER || e->rank > 0) - { - gfc_free_expr (e); - return MATCH_NO; - } - - if (e->expr_type != EXPR_CONSTANT) - goto ohno; - - gfc_next_char (); /* Burn the ')'. */ - ts->kind = (int) mpz_get_si (e->value.integer); - if (gfc_validate_kind (ts->type, ts->kind , true) == -1) - { - gfc_error ("Invalid type-spec at %C"); - return MATCH_ERROR; - } - - gfc_free_expr (e); - - return MATCH_YES; - } - } - -ohno: - - /* If a type is not matched, simply return MATCH_NO. */ - gfc_current_locus = old_locus; - return MATCH_NO; - -kind_selector: - - gfc_gobble_whitespace (); - - /* This prevents INTEGER*4, etc. */ - if (gfc_peek_ascii_char () == '*') - { - gfc_error ("Invalid type-spec at %C"); - return MATCH_ERROR; - } - - m = gfc_match_kind_spec (ts, false); - - /* No kind specifier found. */ - if (m == MATCH_NO) - m = MATCH_YES; - - return m; -} - - -/******************** FORALL subroutines ********************/ - -/* Free a list of FORALL iterators. */ - -void -gfc_free_forall_iterator (gfc_forall_iterator *iter) -{ - gfc_forall_iterator *next; - - while (iter) - { - next = iter->next; - gfc_free_expr (iter->var); - gfc_free_expr (iter->start); - gfc_free_expr (iter->end); - gfc_free_expr (iter->stride); - free (iter); - iter = next; - } -} - - -/* Match an iterator as part of a FORALL statement. The format is: - - = :[:] - - On MATCH_NO, the caller tests for the possibility that there is a - scalar mask expression. */ - -static match -match_forall_iterator (gfc_forall_iterator **result) -{ - gfc_forall_iterator *iter; - locus where; - match m; - - where = gfc_current_locus; - iter = XCNEW (gfc_forall_iterator); - - m = gfc_match_expr (&iter->var); - if (m != MATCH_YES) - goto cleanup; - - if (gfc_match_char ('=') != MATCH_YES - || iter->var->expr_type != EXPR_VARIABLE) - { - m = MATCH_NO; - goto cleanup; - } - - m = gfc_match_expr (&iter->start); - if (m != MATCH_YES) - goto cleanup; - - if (gfc_match_char (':') != MATCH_YES) - goto syntax; - - m = gfc_match_expr (&iter->end); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_char (':') == MATCH_NO) - iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - else - { - m = gfc_match_expr (&iter->stride); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - } - - /* Mark the iteration variable's symbol as used as a FORALL index. */ - iter->var->symtree->n.sym->forall_index = true; - - *result = iter; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in FORALL iterator at %C"); - m = MATCH_ERROR; - -cleanup: - - gfc_current_locus = where; - gfc_free_forall_iterator (iter); - return m; -} - - -/* Match the header of a FORALL statement. */ - -static match -match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) -{ - gfc_forall_iterator *head, *tail, *new_iter; - gfc_expr *msk; - match m; - - gfc_gobble_whitespace (); - - head = tail = NULL; - msk = NULL; - - if (gfc_match_char ('(') != MATCH_YES) - return MATCH_NO; - - m = match_forall_iterator (&new_iter); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - head = tail = new_iter; - - for (;;) - { - if (gfc_match_char (',') != MATCH_YES) - break; - - m = match_forall_iterator (&new_iter); - if (m == MATCH_ERROR) - goto cleanup; - - if (m == MATCH_YES) - { - tail->next = new_iter; - tail = new_iter; - continue; - } - - /* Have to have a mask expression. */ - - m = gfc_match_expr (&msk); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - break; - } - - if (gfc_match_char (')') == MATCH_NO) - goto syntax; - - *phead = head; - *mask = msk; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FORALL); - -cleanup: - gfc_free_expr (msk); - gfc_free_forall_iterator (head); - - return MATCH_ERROR; -} - -/* Match the rest of a simple FORALL statement that follows an - IF statement. */ - -static match -match_simple_forall (void) -{ - gfc_forall_iterator *head; - gfc_expr *mask; - gfc_code *c; - match m; - - mask = NULL; - head = NULL; - c = NULL; - - m = match_forall_header (&head, &mask); - - if (m == MATCH_NO) - goto syntax; - if (m != MATCH_YES) - goto cleanup; - - m = gfc_match_assignment (); - - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_pointer_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - c = XCNEW (gfc_code); - *c = new_st; - c->loc = gfc_current_locus; - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - - gfc_clear_new_st (); - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - new_st.block = gfc_get_code (EXEC_FORALL); - new_st.block->next = c; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FORALL); - -cleanup: - gfc_free_forall_iterator (head); - gfc_free_expr (mask); - - return MATCH_ERROR; -} - - -/* Match a FORALL statement. */ - -match -gfc_match_forall (gfc_statement *st) -{ - gfc_forall_iterator *head; - gfc_expr *mask; - gfc_code *c; - match m0, m; - - head = NULL; - mask = NULL; - c = NULL; - - m0 = gfc_match_label (); - if (m0 == MATCH_ERROR) - return MATCH_ERROR; - - m = gfc_match (" forall"); - if (m != MATCH_YES) - return m; - - m = match_forall_header (&head, &mask); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (gfc_match_eos () == MATCH_YES) - { - *st = ST_FORALL_BLOCK; - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - return MATCH_YES; - } - - m = gfc_match_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_pointer_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - c = XCNEW (gfc_code); - *c = new_st; - c->loc = gfc_current_locus; - - gfc_clear_new_st (); - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - new_st.block = gfc_get_code (EXEC_FORALL); - new_st.block->next = c; - - *st = ST_FORALL; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FORALL); - -cleanup: - gfc_free_forall_iterator (head); - gfc_free_expr (mask); - gfc_free_statements (c); - return MATCH_NO; -} - - -/* Match a DO statement. */ - -match -gfc_match_do (void) -{ - gfc_iterator iter, *ip; - locus old_loc; - gfc_st_label *label; - match m; - - old_loc = gfc_current_locus; - - memset (&iter, '\0', sizeof (gfc_iterator)); - label = NULL; - - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; - - if (gfc_match (" do") != MATCH_YES) - return MATCH_NO; - - m = gfc_match_st_label (&label); - if (m == MATCH_ERROR) - goto cleanup; - - /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ - - if (gfc_match_eos () == MATCH_YES) - { - iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); - new_st.op = EXEC_DO_WHILE; - goto done; - } - - /* Match an optional comma, if no comma is found, a space is obligatory. */ - if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) - return MATCH_NO; - - /* Check for balanced parens. */ - - if (gfc_match_parens () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" concurrent") == MATCH_YES) - { - gfc_forall_iterator *head; - gfc_expr *mask; - - if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C")) - return MATCH_ERROR; - - - mask = NULL; - head = NULL; - m = match_forall_header (&head, &mask); - - if (m == MATCH_NO) - return m; - if (m == MATCH_ERROR) - goto concurr_cleanup; - - if (gfc_match_eos () != MATCH_YES) - goto concurr_cleanup; - - if (label != NULL - && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) - goto concurr_cleanup; - - new_st.label1 = label; - new_st.op = EXEC_DO_CONCURRENT; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - - return MATCH_YES; - -concurr_cleanup: - gfc_syntax_error (ST_DO); - gfc_free_expr (mask); - gfc_free_forall_iterator (head); - return MATCH_ERROR; - } - - /* See if we have a DO WHILE. */ - if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) - { - new_st.op = EXEC_DO_WHILE; - goto done; - } - - /* The abortive DO WHILE may have done something to the symbol - table, so we start over. */ - gfc_undo_symbols (); - gfc_current_locus = old_loc; - - gfc_match_label (); /* This won't error. */ - gfc_match (" do "); /* This will work. */ - - gfc_match_st_label (&label); /* Can't error out. */ - gfc_match_char (','); /* Optional comma. */ - - m = gfc_match_iterator (&iter, 0); - if (m == MATCH_NO) - return MATCH_NO; - if (m == MATCH_ERROR) - goto cleanup; - - iter.var->symtree->n.sym->attr.implied_index = 0; - gfc_check_do_variable (iter.var->symtree); - - if (gfc_match_eos () != MATCH_YES) - { - gfc_syntax_error (ST_DO); - goto cleanup; - } - - new_st.op = EXEC_DO; - -done: - if (label != NULL - && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) - goto cleanup; - - new_st.label1 = label; - - if (new_st.op == EXEC_DO_WHILE) - new_st.expr1 = iter.end; - else - { - new_st.ext.iterator = ip = gfc_get_iterator (); - *ip = iter; - } - - return MATCH_YES; - -cleanup: - gfc_free_iterator (&iter, 0); - - return MATCH_ERROR; -} - - -/* Match an EXIT or CYCLE statement. */ - -static match -match_exit_cycle (gfc_statement st, gfc_exec_op op) -{ - gfc_state_data *p, *o; - gfc_symbol *sym; - match m; - int cnt; - - if (gfc_match_eos () == MATCH_YES) - sym = NULL; - else - { - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symtree* stree; - - m = gfc_match ("% %n%t", name); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - { - gfc_syntax_error (st); - return MATCH_ERROR; - } - - /* Find the corresponding symbol. If there's a BLOCK statement - between here and the label, it is not in gfc_current_ns but a parent - namespace! */ - stree = gfc_find_symtree_in_proc (name, gfc_current_ns); - if (!stree) - { - gfc_error ("Name %qs in %s statement at %C is unknown", - name, gfc_ascii_statement (st)); - return MATCH_ERROR; - } - - sym = stree->n.sym; - if (sym->attr.flavor != FL_LABEL) - { - gfc_error ("Name %qs in %s statement at %C is not a construct name", - name, gfc_ascii_statement (st)); - return MATCH_ERROR; - } - } - - /* Find the loop specified by the label (or lack of a label). */ - for (o = NULL, p = gfc_state_stack; p; p = p->previous) - if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) - o = p; - else if (p->state == COMP_CRITICAL) - { - gfc_error("%s statement at %C leaves CRITICAL construct", - gfc_ascii_statement (st)); - return MATCH_ERROR; - } - else if (p->state == COMP_DO_CONCURRENT - && (op == EXEC_EXIT || (sym && sym != p->sym))) - { - /* F2008, C821 & C845. */ - gfc_error("%s statement at %C leaves DO CONCURRENT construct", - gfc_ascii_statement (st)); - return MATCH_ERROR; - } - else if ((sym && sym == p->sym) - || (!sym && (p->state == COMP_DO - || p->state == COMP_DO_CONCURRENT))) - break; - - if (p == NULL) - { - if (sym == NULL) - gfc_error ("%s statement at %C is not within a construct", - gfc_ascii_statement (st)); - else - gfc_error ("%s statement at %C is not within construct %qs", - gfc_ascii_statement (st), sym->name); - - return MATCH_ERROR; - } - - /* Special checks for EXIT from non-loop constructs. */ - switch (p->state) - { - case COMP_DO: - case COMP_DO_CONCURRENT: - break; - - case COMP_CRITICAL: - /* This is already handled above. */ - gcc_unreachable (); - - case COMP_ASSOCIATE: - case COMP_BLOCK: - case COMP_IF: - case COMP_SELECT: - case COMP_SELECT_TYPE: - case COMP_SELECT_RANK: - gcc_assert (sym); - if (op == EXEC_CYCLE) - { - gfc_error ("CYCLE statement at %C is not applicable to non-loop" - " construct %qs", sym->name); - return MATCH_ERROR; - } - gcc_assert (op == EXEC_EXIT); - if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no" - " do-construct-name at %C")) - return MATCH_ERROR; - break; - - default: - gfc_error ("%s statement at %C is not applicable to construct %qs", - gfc_ascii_statement (st), sym->name); - return MATCH_ERROR; - } - - if (o != NULL) - { - gfc_error (is_oacc (p) - ? G_("%s statement at %C leaving OpenACC structured block") - : G_("%s statement at %C leaving OpenMP structured block"), - gfc_ascii_statement (st)); - return MATCH_ERROR; - } - - for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) - o = o->previous; - if (cnt > 0 - && o != NULL - && o->state == COMP_OMP_STRUCTURED_BLOCK - && (o->head->op == EXEC_OACC_LOOP - || o->head->op == EXEC_OACC_KERNELS_LOOP - || o->head->op == EXEC_OACC_PARALLEL_LOOP - || o->head->op == EXEC_OACC_SERIAL_LOOP)) - { - int collapse = 1; - gcc_assert (o->head->next != NULL - && (o->head->next->op == EXEC_DO - || o->head->next->op == EXEC_DO_WHILE) - && o->previous != NULL - && o->previous->tail->op == o->head->op); - if (o->previous->tail->ext.omp_clauses != NULL) - { - /* Both collapsed and tiled loops are lowered the same way, but are not - compatible. In gfc_trans_omp_do, the tile is prioritized. */ - if (o->previous->tail->ext.omp_clauses->tile_list) - { - collapse = 0; - gfc_expr_list *el = o->previous->tail->ext.omp_clauses->tile_list; - for ( ; el; el = el->next) - ++collapse; - } - else if (o->previous->tail->ext.omp_clauses->collapse > 1) - collapse = o->previous->tail->ext.omp_clauses->collapse; - } - if (st == ST_EXIT && cnt <= collapse) - { - gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop"); - return MATCH_ERROR; - } - if (st == ST_CYCLE && cnt < collapse) - { - gfc_error (o->previous->tail->ext.omp_clauses->tile_list - ? G_("CYCLE statement at %C to non-innermost tiled" - " !$ACC LOOP loop") - : G_("CYCLE statement at %C to non-innermost collapsed" - " !$ACC LOOP loop")); - return MATCH_ERROR; - } - } - if (cnt > 0 - && o != NULL - && (o->state == COMP_OMP_STRUCTURED_BLOCK) - && (o->head->op == EXEC_OMP_DO - || o->head->op == EXEC_OMP_PARALLEL_DO - || o->head->op == EXEC_OMP_SIMD - || o->head->op == EXEC_OMP_DO_SIMD - || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD)) - { - int count = 1; - gcc_assert (o->head->next != NULL - && (o->head->next->op == EXEC_DO - || o->head->next->op == EXEC_DO_WHILE) - && o->previous != NULL - && o->previous->tail->op == o->head->op); - if (o->previous->tail->ext.omp_clauses != NULL) - { - if (o->previous->tail->ext.omp_clauses->collapse > 1) - count = o->previous->tail->ext.omp_clauses->collapse; - if (o->previous->tail->ext.omp_clauses->orderedc) - count = o->previous->tail->ext.omp_clauses->orderedc; - } - if (st == ST_EXIT && cnt <= count) - { - gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); - return MATCH_ERROR; - } - if (st == ST_CYCLE && cnt < count) - { - gfc_error ("CYCLE statement at %C to non-innermost collapsed" - " !$OMP DO loop"); - return MATCH_ERROR; - } - } - - /* Save the first statement in the construct - needed by the backend. */ - new_st.ext.which_construct = p->construct; - - new_st.op = op; - - return MATCH_YES; -} - - -/* Match the EXIT statement. */ - -match -gfc_match_exit (void) -{ - return match_exit_cycle (ST_EXIT, EXEC_EXIT); -} - - -/* Match the CYCLE statement. */ - -match -gfc_match_cycle (void) -{ - return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); -} - - -/* Match a stop-code after an (ERROR) STOP or PAUSE statement. The - requirements for a stop-code differ in the standards. - -Fortran 95 has - - R840 stop-stmt is STOP [ stop-code ] - R841 stop-code is scalar-char-constant - or digit [ digit [ digit [ digit [ digit ] ] ] ] - -Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850. -Fortran 2008 has - - R855 stop-stmt is STOP [ stop-code ] - R856 allstop-stmt is ALL STOP [ stop-code ] - R857 stop-code is scalar-default-char-constant-expr - or scalar-int-constant-expr - -For free-form source code, all standards contain a statement of the form: - - A blank shall be used to separate names, constants, or labels from - adjacent keywords, names, constants, or labels. - -A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003, - - STOP123 - -is valid, but it is invalid Fortran 2008. */ - -static match -gfc_match_stopcode (gfc_statement st) -{ - gfc_expr *e = NULL; - match m; - bool f95, f03, f08; - - /* Set f95 for -std=f95. */ - f95 = (gfc_option.allow_std == GFC_STD_OPT_F95); - - /* Set f03 for -std=f2003. */ - f03 = (gfc_option.allow_std == GFC_STD_OPT_F03); - - /* Set f08 for -std=f2008. */ - f08 = (gfc_option.allow_std == GFC_STD_OPT_F08); - - /* Look for a blank between STOP and the stop-code for F2008 or later. */ - if (gfc_current_form != FORM_FIXED && !(f95 || f03)) - { - char c = gfc_peek_ascii_char (); - - /* Look for end-of-statement. There is no stop-code. */ - if (c == '\n' || c == '!' || c == ';') - goto done; - - if (c != ' ') - { - gfc_error ("Blank required in %s statement near %C", - gfc_ascii_statement (st)); - return MATCH_ERROR; - } - } - - if (gfc_match_eos () != MATCH_YES) - { - int stopcode; - locus old_locus; - - /* First look for the F95 or F2003 digit [...] construct. */ - old_locus = gfc_current_locus; - m = gfc_match_small_int (&stopcode); - if (m == MATCH_YES && (f95 || f03)) - { - if (stopcode < 0) - { - gfc_error ("STOP code at %C cannot be negative"); - return MATCH_ERROR; - } - - if (stopcode > 99999) - { - gfc_error ("STOP code at %C contains too many digits"); - return MATCH_ERROR; - } - } - - /* Reset the locus and now load gfc_expr. */ - gfc_current_locus = old_locus; - m = gfc_match_expr (&e); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - } - - if (gfc_pure (NULL)) - { - if (st == ST_ERROR_STOP) - { - if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE " - "procedure", gfc_ascii_statement (st))) - goto cleanup; - } - else - { - gfc_error ("%s statement not allowed in PURE procedure at %C", - gfc_ascii_statement (st)); - goto cleanup; - } - } - - gfc_unset_implicit_pure (NULL); - - if (st == ST_STOP && gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("Image control statement STOP at %C in CRITICAL block"); - goto cleanup; - } - if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("Image control statement STOP at %C in DO CONCURRENT block"); - goto cleanup; - } - - if (e != NULL) - { - if (!gfc_simplify_expr (e, 0)) - goto cleanup; - - /* Test for F95 and F2003 style STOP stop-code. */ - if (e->expr_type != EXPR_CONSTANT && (f95 || f03)) - { - gfc_error ("STOP code at %L must be a scalar CHARACTER constant " - "or digit[digit[digit[digit[digit]]]]", &e->where); - goto cleanup; - } - - /* Use the machinery for an initialization expression to reduce the - stop-code to a constant. */ - gfc_reduce_init_expr (e); - - /* Test for F2008 style STOP stop-code. */ - if (e->expr_type != EXPR_CONSTANT && f08) - { - gfc_error ("STOP code at %L must be a scalar default CHARACTER or " - "INTEGER constant expression", &e->where); - goto cleanup; - } - - if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) - { - gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", - &e->where); - goto cleanup; - } - - if (e->rank != 0) - { - gfc_error ("STOP code at %L must be scalar", &e->where); - goto cleanup; - } - - if (e->ts.type == BT_CHARACTER - && e->ts.kind != gfc_default_character_kind) - { - gfc_error ("STOP code at %L must be default character KIND=%d", - &e->where, (int) gfc_default_character_kind); - goto cleanup; - } - - if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind) - { - gfc_error ("STOP code at %L must be default integer KIND=%d", - &e->where, (int) gfc_default_integer_kind); - goto cleanup; - } - } - -done: - - switch (st) - { - case ST_STOP: - new_st.op = EXEC_STOP; - break; - case ST_ERROR_STOP: - new_st.op = EXEC_ERROR_STOP; - break; - case ST_PAUSE: - new_st.op = EXEC_PAUSE; - break; - default: - gcc_unreachable (); - } - - new_st.expr1 = e; - new_st.ext.stop_code = -1; - - return MATCH_YES; - -syntax: - gfc_syntax_error (st); - -cleanup: - - gfc_free_expr (e); - return MATCH_ERROR; -} - - -/* Match the (deprecated) PAUSE statement. */ - -match -gfc_match_pause (void) -{ - match m; - - m = gfc_match_stopcode (ST_PAUSE); - if (m == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C")) - m = MATCH_ERROR; - } - return m; -} - - -/* Match the STOP statement. */ - -match -gfc_match_stop (void) -{ - return gfc_match_stopcode (ST_STOP); -} - - -/* Match the ERROR STOP statement. */ - -match -gfc_match_error_stop (void) -{ - if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C")) - return MATCH_ERROR; - - return gfc_match_stopcode (ST_ERROR_STOP); -} - -/* Match EVENT POST/WAIT statement. Syntax: - EVENT POST ( event-variable [, sync-stat-list] ) - EVENT WAIT ( event-variable [, wait-spec-list] ) - with - wait-spec-list is sync-stat-list or until-spec - until-spec is UNTIL_COUNT = scalar-int-expr - sync-stat is STAT= or ERRMSG=. */ - -static match -event_statement (gfc_statement st) -{ - match m; - gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg; - bool saw_until_count, saw_stat, saw_errmsg; - - tmp = eventvar = until_count = stat = errmsg = NULL; - saw_until_count = saw_stat = saw_errmsg = false; - - if (gfc_pure (NULL)) - { - gfc_error ("Image control statement EVENT %s at %C in PURE procedure", - st == ST_EVENT_POST ? "POST" : "WAIT"); - return MATCH_ERROR; - } - - gfc_unset_implicit_pure (NULL); - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("Image control statement EVENT %s at %C in CRITICAL block", - st == ST_EVENT_POST ? "POST" : "WAIT"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT " - "block", st == ST_EVENT_POST ? "POST" : "WAIT"); - return MATCH_ERROR; - } - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - if (gfc_match ("%e", &eventvar) != MATCH_YES) - goto syntax; - m = gfc_match_char (','); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_NO) - { - m = gfc_match_char (')'); - if (m == MATCH_YES) - goto done; - goto syntax; - } - - for (;;) - { - m = gfc_match (" stat = %v", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L", &tmp->where); - goto cleanup; - } - stat = tmp; - saw_stat = true; - - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - m = gfc_match (" errmsg = %v", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); - goto cleanup; - } - errmsg = tmp; - saw_errmsg = true; - - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - m = gfc_match (" until_count = %e", &tmp); - if (m == MATCH_ERROR || st == ST_EVENT_POST) - goto syntax; - if (m == MATCH_YES) - { - if (saw_until_count) - { - gfc_error ("Redundant UNTIL_COUNT tag found at %L", - &tmp->where); - goto cleanup; - } - until_count = tmp; - saw_until_count = true; - - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - break; - } - - if (m == MATCH_ERROR) - goto syntax; - - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; - -done: - switch (st) - { - case ST_EVENT_POST: - new_st.op = EXEC_EVENT_POST; - break; - case ST_EVENT_WAIT: - new_st.op = EXEC_EVENT_WAIT; - break; - default: - gcc_unreachable (); - } - - new_st.expr1 = eventvar; - new_st.expr2 = stat; - new_st.expr3 = errmsg; - new_st.expr4 = until_count; - - return MATCH_YES; - -syntax: - gfc_syntax_error (st); - -cleanup: - if (until_count != tmp) - gfc_free_expr (until_count); - if (errmsg != tmp) - gfc_free_expr (errmsg); - if (stat != tmp) - gfc_free_expr (stat); - - gfc_free_expr (tmp); - gfc_free_expr (eventvar); - - return MATCH_ERROR; - -} - - -match -gfc_match_event_post (void) -{ - if (!gfc_notify_std (GFC_STD_F2018, "EVENT POST statement at %C")) - return MATCH_ERROR; - - return event_statement (ST_EVENT_POST); -} - - -match -gfc_match_event_wait (void) -{ - if (!gfc_notify_std (GFC_STD_F2018, "EVENT WAIT statement at %C")) - return MATCH_ERROR; - - return event_statement (ST_EVENT_WAIT); -} - - -/* Match a FAIL IMAGE statement. */ - -match -gfc_match_fail_image (void) -{ - if (!gfc_notify_std (GFC_STD_F2018, "FAIL IMAGE statement at %C")) - return MATCH_ERROR; - - if (gfc_match_char ('(') == MATCH_YES) - goto syntax; - - new_st.op = EXEC_FAIL_IMAGE; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FAIL_IMAGE); - - return MATCH_ERROR; -} - -/* Match a FORM TEAM statement. */ - -match -gfc_match_form_team (void) -{ - match m; - gfc_expr *teamid,*team; - - if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C")) - return MATCH_ERROR; - - if (gfc_match_char ('(') == MATCH_NO) - goto syntax; - - new_st.op = EXEC_FORM_TEAM; - - if (gfc_match ("%e", &teamid) != MATCH_YES) - goto syntax; - m = gfc_match_char (','); - if (m == MATCH_ERROR) - goto syntax; - if (gfc_match ("%e", &team) != MATCH_YES) - goto syntax; - - m = gfc_match_char (')'); - if (m == MATCH_NO) - goto syntax; - - new_st.expr1 = teamid; - new_st.expr2 = team; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_FORM_TEAM); - - return MATCH_ERROR; -} - -/* Match a CHANGE TEAM statement. */ - -match -gfc_match_change_team (void) -{ - match m; - gfc_expr *team; - - if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C")) - return MATCH_ERROR; - - if (gfc_match_char ('(') == MATCH_NO) - goto syntax; - - new_st.op = EXEC_CHANGE_TEAM; - - if (gfc_match ("%e", &team) != MATCH_YES) - goto syntax; - - m = gfc_match_char (')'); - if (m == MATCH_NO) - goto syntax; - - new_st.expr1 = team; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_CHANGE_TEAM); - - return MATCH_ERROR; -} - -/* Match a END TEAM statement. */ - -match -gfc_match_end_team (void) -{ - if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C")) - return MATCH_ERROR; - - if (gfc_match_char ('(') == MATCH_YES) - goto syntax; - - new_st.op = EXEC_END_TEAM; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_END_TEAM); - - return MATCH_ERROR; -} - -/* Match a SYNC TEAM statement. */ - -match -gfc_match_sync_team (void) -{ - match m; - gfc_expr *team; - - if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C")) - return MATCH_ERROR; - - if (gfc_match_char ('(') == MATCH_NO) - goto syntax; - - new_st.op = EXEC_SYNC_TEAM; - - if (gfc_match ("%e", &team) != MATCH_YES) - goto syntax; - - m = gfc_match_char (')'); - if (m == MATCH_NO) - goto syntax; - - new_st.expr1 = team; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_SYNC_TEAM); - - return MATCH_ERROR; -} - -/* Match LOCK/UNLOCK statement. Syntax: - LOCK ( lock-variable [ , lock-stat-list ] ) - UNLOCK ( lock-variable [ , sync-stat-list ] ) - where lock-stat is ACQUIRED_LOCK or sync-stat - and sync-stat is STAT= or ERRMSG=. */ - -static match -lock_unlock_statement (gfc_statement st) -{ - match m; - gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; - bool saw_acq_lock, saw_stat, saw_errmsg; - - tmp = lockvar = acq_lock = stat = errmsg = NULL; - saw_acq_lock = saw_stat = saw_errmsg = false; - - if (gfc_pure (NULL)) - { - gfc_error ("Image control statement %s at %C in PURE procedure", - st == ST_LOCK ? "LOCK" : "UNLOCK"); - return MATCH_ERROR; - } - - gfc_unset_implicit_pure (NULL); - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("Image control statement %s at %C in CRITICAL block", - st == ST_LOCK ? "LOCK" : "UNLOCK"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("Image control statement %s at %C in DO CONCURRENT block", - st == ST_LOCK ? "LOCK" : "UNLOCK"); - return MATCH_ERROR; - } - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - if (gfc_match ("%e", &lockvar) != MATCH_YES) - goto syntax; - m = gfc_match_char (','); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_NO) - { - m = gfc_match_char (')'); - if (m == MATCH_YES) - goto done; - goto syntax; - } - - for (;;) - { - m = gfc_match (" stat = %v", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L", &tmp->where); - goto cleanup; - } - stat = tmp; - saw_stat = true; - - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - m = gfc_match (" errmsg = %v", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); - goto cleanup; - } - errmsg = tmp; - saw_errmsg = true; - - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - m = gfc_match (" acquired_lock = %v", &tmp); - if (m == MATCH_ERROR || st == ST_UNLOCK) - goto syntax; - if (m == MATCH_YES) - { - if (saw_acq_lock) - { - gfc_error ("Redundant ACQUIRED_LOCK tag found at %L", - &tmp->where); - goto cleanup; - } - acq_lock = tmp; - saw_acq_lock = true; - - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - break; - } - - if (m == MATCH_ERROR) - goto syntax; - - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; - -done: - switch (st) - { - case ST_LOCK: - new_st.op = EXEC_LOCK; - break; - case ST_UNLOCK: - new_st.op = EXEC_UNLOCK; - break; - default: - gcc_unreachable (); - } - - new_st.expr1 = lockvar; - new_st.expr2 = stat; - new_st.expr3 = errmsg; - new_st.expr4 = acq_lock; - - return MATCH_YES; - -syntax: - gfc_syntax_error (st); - -cleanup: - if (acq_lock != tmp) - gfc_free_expr (acq_lock); - if (errmsg != tmp) - gfc_free_expr (errmsg); - if (stat != tmp) - gfc_free_expr (stat); - - gfc_free_expr (tmp); - gfc_free_expr (lockvar); - - return MATCH_ERROR; -} - - -match -gfc_match_lock (void) -{ - if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C")) - return MATCH_ERROR; - - return lock_unlock_statement (ST_LOCK); -} - - -match -gfc_match_unlock (void) -{ - if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C")) - return MATCH_ERROR; - - return lock_unlock_statement (ST_UNLOCK); -} - - -/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: - SYNC ALL [(sync-stat-list)] - SYNC MEMORY [(sync-stat-list)] - SYNC IMAGES (image-set [, sync-stat-list] ) - with sync-stat is int-expr or *. */ - -static match -sync_statement (gfc_statement st) -{ - match m; - gfc_expr *tmp, *imageset, *stat, *errmsg; - bool saw_stat, saw_errmsg; - - tmp = imageset = stat = errmsg = NULL; - saw_stat = saw_errmsg = false; - - if (gfc_pure (NULL)) - { - gfc_error ("Image control statement SYNC at %C in PURE procedure"); - return MATCH_ERROR; - } - - gfc_unset_implicit_pure (NULL); - - if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C")) - return MATCH_ERROR; - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " - "enable"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("Image control statement SYNC at %C in CRITICAL block"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block"); - return MATCH_ERROR; - } - - if (gfc_match_eos () == MATCH_YES) - { - if (st == ST_SYNC_IMAGES) - goto syntax; - goto done; - } - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - if (st == ST_SYNC_IMAGES) - { - /* Denote '*' as imageset == NULL. */ - m = gfc_match_char ('*'); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_NO) - { - if (gfc_match ("%e", &imageset) != MATCH_YES) - goto syntax; - } - m = gfc_match_char (','); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_NO) - { - m = gfc_match_char (')'); - if (m == MATCH_YES) - goto done; - goto syntax; - } - } - - for (;;) - { - m = gfc_match (" stat = %e", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L", &tmp->where); - goto cleanup; - } - stat = tmp; - saw_stat = true; - - if (gfc_match_char (',') == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - m = gfc_match (" errmsg = %e", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); - goto cleanup; - } - errmsg = tmp; - saw_errmsg = true; - - if (gfc_match_char (',') == MATCH_YES) - continue; - - tmp = NULL; - break; - } - - break; - } - - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; - -done: - switch (st) - { - case ST_SYNC_ALL: - new_st.op = EXEC_SYNC_ALL; - break; - case ST_SYNC_IMAGES: - new_st.op = EXEC_SYNC_IMAGES; - break; - case ST_SYNC_MEMORY: - new_st.op = EXEC_SYNC_MEMORY; - break; - default: - gcc_unreachable (); - } - - new_st.expr1 = imageset; - new_st.expr2 = stat; - new_st.expr3 = errmsg; - - return MATCH_YES; - -syntax: - gfc_syntax_error (st); - -cleanup: - if (stat != tmp) - gfc_free_expr (stat); - if (errmsg != tmp) - gfc_free_expr (errmsg); - - gfc_free_expr (tmp); - gfc_free_expr (imageset); - - return MATCH_ERROR; -} - - -/* Match SYNC ALL statement. */ - -match -gfc_match_sync_all (void) -{ - return sync_statement (ST_SYNC_ALL); -} - - -/* Match SYNC IMAGES statement. */ - -match -gfc_match_sync_images (void) -{ - return sync_statement (ST_SYNC_IMAGES); -} - - -/* Match SYNC MEMORY statement. */ - -match -gfc_match_sync_memory (void) -{ - return sync_statement (ST_SYNC_MEMORY); -} - - -/* Match a CONTINUE statement. */ - -match -gfc_match_continue (void) -{ - if (gfc_match_eos () != MATCH_YES) - { - gfc_syntax_error (ST_CONTINUE); - return MATCH_ERROR; - } - - new_st.op = EXEC_CONTINUE; - return MATCH_YES; -} - - -/* Match the (deprecated) ASSIGN statement. */ - -match -gfc_match_assign (void) -{ - gfc_expr *expr; - gfc_st_label *label; - - if (gfc_match (" %l", &label) == MATCH_YES) - { - if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN)) - return MATCH_ERROR; - if (gfc_match (" to %v%t", &expr) == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C")) - return MATCH_ERROR; - - expr->symtree->n.sym->attr.assign = 1; - - new_st.op = EXEC_LABEL_ASSIGN; - new_st.label1 = label; - new_st.expr1 = expr; - return MATCH_YES; - } - } - return MATCH_NO; -} - - -/* Match the GO TO statement. As a computed GOTO statement is - matched, it is transformed into an equivalent SELECT block. No - tree is necessary, and the resulting jumps-to-jumps are - specifically optimized away by the back end. */ - -match -gfc_match_goto (void) -{ - gfc_code *head, *tail; - gfc_expr *expr; - gfc_case *cp; - gfc_st_label *label; - int i; - match m; - - if (gfc_match (" %l%t", &label) == MATCH_YES) - { - if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) - return MATCH_ERROR; - - new_st.op = EXEC_GOTO; - new_st.label1 = label; - return MATCH_YES; - } - - /* The assigned GO TO statement. */ - - if (gfc_match_variable (&expr, 0) == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C")) - return MATCH_ERROR; - - new_st.op = EXEC_GOTO; - new_st.expr1 = expr; - - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - - /* Match label list. */ - gfc_match_char (','); - if (gfc_match_char ('(') != MATCH_YES) - { - gfc_syntax_error (ST_GOTO); - return MATCH_ERROR; - } - head = tail = NULL; - - do - { - m = gfc_match_st_label (&label); - if (m != MATCH_YES) - goto syntax; - - if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) - goto cleanup; - - if (head == NULL) - head = tail = gfc_get_code (EXEC_GOTO); - else - { - tail->block = gfc_get_code (EXEC_GOTO); - tail = tail->block; - } - - tail->label1 = label; - } - while (gfc_match_char (',') == MATCH_YES); - - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; - - if (head == NULL) - { - gfc_error ("Statement label list in GOTO at %C cannot be empty"); - goto syntax; - } - new_st.block = head; - - return MATCH_YES; - } - - /* Last chance is a computed GO TO statement. */ - if (gfc_match_char ('(') != MATCH_YES) - { - gfc_syntax_error (ST_GOTO); - return MATCH_ERROR; - } - - head = tail = NULL; - i = 1; - - do - { - m = gfc_match_st_label (&label); - if (m != MATCH_YES) - goto syntax; - - if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) - goto cleanup; - - if (head == NULL) - head = tail = gfc_get_code (EXEC_SELECT); - else - { - tail->block = gfc_get_code (EXEC_SELECT); - tail = tail->block; - } - - cp = gfc_get_case (); - cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, - NULL, i++); - - tail->ext.block.case_list = cp; - - tail->next = gfc_get_code (EXEC_GOTO); - tail->next->label1 = label; - } - while (gfc_match_char (',') == MATCH_YES); - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - if (head == NULL) - { - gfc_error ("Statement label list in GOTO at %C cannot be empty"); - goto syntax; - } - - /* Get the rest of the statement. */ - gfc_match_char (','); - - if (gfc_match (" %e%t", &expr) != MATCH_YES) - goto syntax; - - if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C")) - return MATCH_ERROR; - - /* At this point, a computed GOTO has been fully matched and an - equivalent SELECT statement constructed. */ - - new_st.op = EXEC_SELECT; - new_st.expr1 = NULL; - - /* Hack: For a "real" SELECT, the expression is in expr. We put - it in expr2 so we can distinguish then and produce the correct - diagnostics. */ - new_st.expr2 = expr; - new_st.block = head; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_GOTO); -cleanup: - gfc_free_statements (head); - return MATCH_ERROR; -} - - -/* Frees a list of gfc_alloc structures. */ - -void -gfc_free_alloc_list (gfc_alloc *p) -{ - gfc_alloc *q; - - for (; p; p = q) - { - q = p->next; - gfc_free_expr (p->expr); - free (p); - } -} - - -/* Match an ALLOCATE statement. */ - -match -gfc_match_allocate (void) -{ - gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp, *source, *mold; - gfc_typespec ts; - gfc_symbol *sym; - match m; - locus old_locus, deferred_locus, assumed_locus; - bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; - bool saw_unlimited = false, saw_assumed = false; - - head = tail = NULL; - stat = errmsg = source = mold = tmp = NULL; - saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false; - - if (gfc_match_char ('(') != MATCH_YES) - { - gfc_syntax_error (ST_ALLOCATE); - return MATCH_ERROR; - } - - /* Match an optional type-spec. */ - old_locus = gfc_current_locus; - m = gfc_match_type_spec (&ts); - if (m == MATCH_ERROR) - goto cleanup; - else if (m == MATCH_NO) - { - char name[GFC_MAX_SYMBOL_LEN + 3]; - - if (gfc_match ("%n :: ", name) == MATCH_YES) - { - gfc_error ("Error in type-spec at %L", &old_locus); - goto cleanup; - } - - ts.type = BT_UNKNOWN; - } - else - { - /* Needed for the F2008:C631 check below. */ - assumed_locus = gfc_current_locus; - - if (gfc_match (" :: ") == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L", - &old_locus)) - goto cleanup; - - if (ts.deferred) - { - gfc_error ("Type-spec at %L cannot contain a deferred " - "type parameter", &old_locus); - goto cleanup; - } - - if (ts.type == BT_CHARACTER) - { - if (!ts.u.cl->length) - saw_assumed = true; - else - ts.u.cl->length_from_typespec = true; - } - - if (type_param_spec_list - && gfc_spec_list_type (type_param_spec_list, NULL) - == SPEC_DEFERRED) - { - gfc_error ("The type parameter spec list in the type-spec at " - "%L cannot contain DEFERRED parameters", &old_locus); - goto cleanup; - } - } - else - { - ts.type = BT_UNKNOWN; - gfc_current_locus = old_locus; - } - } - - for (;;) - { - if (head == NULL) - head = tail = gfc_get_alloc (); - else - { - tail->next = gfc_get_alloc (); - tail = tail->next; - } - - m = gfc_match_variable (&tail->expr, 0); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (tail->expr->expr_type == EXPR_CONSTANT) - { - gfc_error ("Unexpected constant at %C"); - goto cleanup; - } - - if (gfc_check_do_variable (tail->expr->symtree)) - goto cleanup; - - bool impure = gfc_impure_variable (tail->expr->symtree->n.sym); - if (impure && gfc_pure (NULL)) - { - gfc_error ("Bad allocate-object at %C for a PURE procedure"); - goto cleanup; - } - - if (impure) - gfc_unset_implicit_pure (NULL); - - /* F2008:C631 (R626) A type-param-value in a type-spec shall be an - asterisk if and only if each allocate-object is a dummy argument - for which the corresponding type parameter is assumed. */ - if (saw_assumed - && (tail->expr->ts.deferred - || (tail->expr->ts.u.cl && tail->expr->ts.u.cl->length) - || tail->expr->symtree->n.sym->attr.dummy == 0)) - { - gfc_error ("Incompatible allocate-object at %C for CHARACTER " - "type-spec at %L", &assumed_locus); - goto cleanup; - } - - if (tail->expr->ts.deferred) - { - saw_deferred = true; - deferred_locus = tail->expr->where; - } - - if (gfc_find_state (COMP_DO_CONCURRENT) - || gfc_find_state (COMP_CRITICAL)) - { - gfc_ref *ref; - bool coarray = tail->expr->symtree->n.sym->attr.codimension; - for (ref = tail->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - coarray = ref->u.c.component->attr.codimension; - - if (coarray && gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block"); - goto cleanup; - } - if (coarray && gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("ALLOCATE of coarray at %C in CRITICAL block"); - goto cleanup; - } - } - - /* Check for F08:C628. */ - sym = tail->expr->symtree->n.sym; - b1 = !(tail->expr->ref - && (tail->expr->ref->type == REF_COMPONENT - || tail->expr->ref->type == REF_ARRAY)); - if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok) - b2 = !(CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.class_pointer); - else - b2 = sym && !(sym->attr.allocatable || sym->attr.pointer - || sym->attr.proc_pointer); - b3 = sym && sym->ns && sym->ns->proc_name - && (sym->ns->proc_name->attr.allocatable - || sym->ns->proc_name->attr.pointer - || sym->ns->proc_name->attr.proc_pointer); - if (b1 && b2 && !b3) - { - gfc_error ("Allocate-object at %L is neither a data pointer " - "nor an allocatable variable", &tail->expr->where); - goto cleanup; - } - - /* The ALLOCATE statement had an optional typespec. Check the - constraints. */ - if (ts.type != BT_UNKNOWN) - { - /* Enforce F03:C624. */ - if (!gfc_type_compatible (&tail->expr->ts, &ts)) - { - gfc_error ("Type of entity at %L is type incompatible with " - "typespec", &tail->expr->where); - goto cleanup; - } - - /* Enforce F03:C627. */ - if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr)) - { - gfc_error ("Kind type parameter for entity at %L differs from " - "the kind type parameter of the typespec", - &tail->expr->where); - goto cleanup; - } - } - - if (tail->expr->ts.type == BT_DERIVED) - tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); - - if (type_param_spec_list) - tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list); - - saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr); - - if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) - { - gfc_error ("Shape specification for allocatable scalar at %C"); - goto cleanup; - } - - if (gfc_match_char (',') != MATCH_YES) - break; - -alloc_opt_list: - - m = gfc_match (" stat = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - /* Enforce C630. */ - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L", &tmp->where); - goto cleanup; - } - - stat = tmp; - tmp = NULL; - saw_stat = true; - - if (stat->expr_type == EXPR_CONSTANT) - { - gfc_error ("STAT tag at %L cannot be a constant", &stat->where); - goto cleanup; - } - - if (gfc_check_do_variable (stat->symtree)) - goto cleanup; - - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } - - m = gfc_match (" errmsg = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where)) - goto cleanup; - - /* Enforce C630. */ - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); - goto cleanup; - } - - errmsg = tmp; - tmp = NULL; - saw_errmsg = true; - - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } - - m = gfc_match (" source = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where)) - goto cleanup; - - /* Enforce C630. */ - if (saw_source) - { - gfc_error ("Redundant SOURCE tag found at %L", &tmp->where); - goto cleanup; - } - - /* The next 2 conditionals check C631. */ - if (ts.type != BT_UNKNOWN) - { - gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", - &tmp->where, &old_locus); - goto cleanup; - } - - if (head->next - && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L" - " with more than a single allocate object", - &tmp->where)) - goto cleanup; - - source = tmp; - tmp = NULL; - saw_source = true; - - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } - - m = gfc_match (" mold = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where)) - goto cleanup; - - /* Check F08:C636. */ - if (saw_mold) - { - gfc_error ("Redundant MOLD tag found at %L", &tmp->where); - goto cleanup; - } - - /* Check F08:C637. */ - if (ts.type != BT_UNKNOWN) - { - gfc_error ("MOLD tag at %L conflicts with the typespec at %L", - &tmp->where, &old_locus); - goto cleanup; - } - - mold = tmp; - tmp = NULL; - saw_mold = true; - mold->mold = 1; - - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } - - gfc_gobble_whitespace (); - - if (gfc_peek_char () == ')') - break; - } - - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; - - /* Check F08:C637. */ - if (source && mold) - { - gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", - &mold->where, &source->where); - goto cleanup; - } - - /* Check F03:C623, */ - if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) - { - gfc_error ("Allocate-object at %L with a deferred type parameter " - "requires either a type-spec or SOURCE tag or a MOLD tag", - &deferred_locus); - goto cleanup; - } - - /* Check F03:C625, */ - if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold) - { - for (tail = head; tail; tail = tail->next) - { - if (UNLIMITED_POLY (tail->expr)) - gfc_error ("Unlimited polymorphic allocate-object at %L " - "requires either a type-spec or SOURCE tag " - "or a MOLD tag", &tail->expr->where); - } - goto cleanup; - } - - new_st.op = EXEC_ALLOCATE; - new_st.expr1 = stat; - new_st.expr2 = errmsg; - if (source) - new_st.expr3 = source; - else - new_st.expr3 = mold; - new_st.ext.alloc.list = head; - new_st.ext.alloc.ts = ts; - - if (type_param_spec_list) - gfc_free_actual_arglist (type_param_spec_list); - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_ALLOCATE); - -cleanup: - gfc_free_expr (errmsg); - gfc_free_expr (source); - gfc_free_expr (stat); - gfc_free_expr (mold); - if (tmp && tmp->expr_type) gfc_free_expr (tmp); - gfc_free_alloc_list (head); - if (type_param_spec_list) - gfc_free_actual_arglist (type_param_spec_list); - return MATCH_ERROR; -} - - -/* Match a NULLIFY statement. A NULLIFY statement is transformed into - a set of pointer assignments to intrinsic NULL(). */ - -match -gfc_match_nullify (void) -{ - gfc_code *tail; - gfc_expr *e, *p; - match m; - - tail = NULL; - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - for (;;) - { - m = gfc_match_variable (&p, 0); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (gfc_check_do_variable (p->symtree)) - goto cleanup; - - /* F2008, C1242. */ - if (gfc_is_coindexed (p)) - { - gfc_error ("Pointer object at %C shall not be coindexed"); - goto cleanup; - } - - /* Check for valid array pointer object. Bounds remapping is not - allowed with NULLIFY. */ - if (p->ref) - { - gfc_ref *remap = p->ref; - for (; remap; remap = remap->next) - if (!remap->next && remap->type == REF_ARRAY - && remap->u.ar.type != AR_FULL) - break; - if (remap) - { - gfc_error ("NULLIFY does not allow bounds remapping for " - "pointer object at %C"); - goto cleanup; - } - } - - /* build ' => NULL() '. */ - e = gfc_get_null_expr (&gfc_current_locus); - - /* Chain to list. */ - if (tail == NULL) - { - tail = &new_st; - tail->op = EXEC_POINTER_ASSIGN; - } - else - { - tail->next = gfc_get_code (EXEC_POINTER_ASSIGN); - tail = tail->next; - } - - tail->expr1 = p; - tail->expr2 = e; - - if (gfc_match (" )%t") == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_NULLIFY); - -cleanup: - gfc_free_statements (new_st.next); - new_st.next = NULL; - gfc_free_expr (new_st.expr1); - new_st.expr1 = NULL; - gfc_free_expr (new_st.expr2); - new_st.expr2 = NULL; - return MATCH_ERROR; -} - - -/* Match a DEALLOCATE statement. */ - -match -gfc_match_deallocate (void) -{ - gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp; - gfc_symbol *sym; - match m; - bool saw_stat, saw_errmsg, b1, b2; - - head = tail = NULL; - stat = errmsg = tmp = NULL; - saw_stat = saw_errmsg = false; - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - for (;;) - { - if (head == NULL) - head = tail = gfc_get_alloc (); - else - { - tail->next = gfc_get_alloc (); - tail = tail->next; - } - - m = gfc_match_variable (&tail->expr, 0); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (tail->expr->expr_type == EXPR_CONSTANT) - { - gfc_error ("Unexpected constant at %C"); - goto cleanup; - } - - if (gfc_check_do_variable (tail->expr->symtree)) - goto cleanup; - - sym = tail->expr->symtree->n.sym; - - bool impure = gfc_impure_variable (sym); - if (impure && gfc_pure (NULL)) - { - gfc_error ("Illegal allocate-object at %C for a PURE procedure"); - goto cleanup; - } - - if (impure) - gfc_unset_implicit_pure (NULL); - - if (gfc_is_coarray (tail->expr) - && gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block"); - goto cleanup; - } - - if (gfc_is_coarray (tail->expr) - && gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block"); - goto cleanup; - } - - /* FIXME: disable the checking on derived types. */ - b1 = !(tail->expr->ref - && (tail->expr->ref->type == REF_COMPONENT - || tail->expr->ref->type == REF_ARRAY)); - if (sym && sym->ts.type == BT_CLASS) - b2 = !(CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.class_pointer)); - else - b2 = sym && !(sym->attr.allocatable || sym->attr.pointer - || sym->attr.proc_pointer); - if (b1 && b2) - { - gfc_error ("Allocate-object at %C is not a nonprocedure pointer " - "nor an allocatable variable"); - goto cleanup; - } - - if (gfc_match_char (',') != MATCH_YES) - break; - -dealloc_opt_list: - - m = gfc_match (" stat = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L", &tmp->where); - gfc_free_expr (tmp); - goto cleanup; - } - - stat = tmp; - saw_stat = true; - - if (gfc_check_do_variable (stat->symtree)) - goto cleanup; - - if (gfc_match_char (',') == MATCH_YES) - goto dealloc_opt_list; - } - - m = gfc_match (" errmsg = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where)) - goto cleanup; - - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); - gfc_free_expr (tmp); - goto cleanup; - } - - errmsg = tmp; - saw_errmsg = true; - - if (gfc_match_char (',') == MATCH_YES) - goto dealloc_opt_list; - } - - gfc_gobble_whitespace (); - - if (gfc_peek_char () == ')') - break; - } - - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; - - new_st.op = EXEC_DEALLOCATE; - new_st.expr1 = stat; - new_st.expr2 = errmsg; - new_st.ext.alloc.list = head; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_DEALLOCATE); - -cleanup: - gfc_free_expr (errmsg); - gfc_free_expr (stat); - gfc_free_alloc_list (head); - return MATCH_ERROR; -} - - -/* Match a RETURN statement. */ - -match -gfc_match_return (void) -{ - gfc_expr *e; - match m; - gfc_compile_state s; - - e = NULL; - - if (gfc_find_state (COMP_CRITICAL)) - { - gfc_error ("Image control statement RETURN at %C in CRITICAL block"); - return MATCH_ERROR; - } - - if (gfc_find_state (COMP_DO_CONCURRENT)) - { - gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block"); - return MATCH_ERROR; - } - - if (gfc_match_eos () == MATCH_YES) - goto done; - - if (!gfc_find_state (COMP_SUBROUTINE)) - { - gfc_error ("Alternate RETURN statement at %C is only allowed within " - "a SUBROUTINE"); - goto cleanup; - } - - if (gfc_current_form == FORM_FREE) - { - /* The following are valid, so we can't require a blank after the - RETURN keyword: - return+1 - return(1) */ - char c = gfc_peek_ascii_char (); - if (ISALPHA (c) || ISDIGIT (c)) - return MATCH_NO; - } - - m = gfc_match (" %e%t", &e); - if (m == MATCH_YES) - goto done; - if (m == MATCH_ERROR) - goto cleanup; - - gfc_syntax_error (ST_RETURN); - -cleanup: - gfc_free_expr (e); - return MATCH_ERROR; - -done: - gfc_enclosing_unit (&s); - if (s == COMP_PROGRAM - && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in " - "main program at %C")) - return MATCH_ERROR; - - new_st.op = EXEC_RETURN; - new_st.expr1 = e; - - return MATCH_YES; -} - - -/* Match the call of a type-bound procedure, if CALL%var has already been - matched and var found to be a derived-type variable. */ - -static match -match_typebound_call (gfc_symtree* varst) -{ - gfc_expr* base; - match m; - - base = gfc_get_expr (); - base->expr_type = EXPR_VARIABLE; - base->symtree = varst; - base->where = gfc_current_locus; - gfc_set_sym_referenced (varst->n.sym); - - m = gfc_match_varspec (base, 0, true, true); - if (m == MATCH_NO) - gfc_error ("Expected component reference at %C"); - if (m != MATCH_YES) - { - gfc_free_expr (base); - return MATCH_ERROR; - } - - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after CALL at %C"); - gfc_free_expr (base); - return MATCH_ERROR; - } - - if (base->expr_type == EXPR_COMPCALL) - new_st.op = EXEC_COMPCALL; - else if (base->expr_type == EXPR_PPC) - new_st.op = EXEC_CALL_PPC; - else - { - gfc_error ("Expected type-bound procedure or procedure pointer component " - "at %C"); - gfc_free_expr (base); - return MATCH_ERROR; - } - new_st.expr1 = base; - - return MATCH_YES; -} - - -/* Match a CALL statement. The tricky part here are possible - alternate return specifiers. We handle these by having all - "subroutines" actually return an integer via a register that gives - the return number. If the call specifies alternate returns, we - generate code for a SELECT statement whose case clauses contain - GOTOs to the various labels. */ - -match -gfc_match_call (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_actual_arglist *a, *arglist; - gfc_case *new_case; - gfc_symbol *sym; - gfc_symtree *st; - gfc_code *c; - match m; - int i; - - arglist = NULL; - - m = gfc_match ("% %n", name); - if (m == MATCH_NO) - goto syntax; - if (m != MATCH_YES) - return m; - - if (gfc_get_ha_sym_tree (name, &st)) - return MATCH_ERROR; - - sym = st->n.sym; - - /* If this is a variable of derived-type, it probably starts a type-bound - procedure call. Associate variable targets have to be resolved for the - target type. */ - if (((sym->attr.flavor != FL_PROCEDURE - || gfc_is_function_return_value (sym, gfc_current_ns)) - && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) - || - (sym->assoc && sym->assoc->target - && gfc_resolve_expr (sym->assoc->target) - && (sym->assoc->target->ts.type == BT_DERIVED - || sym->assoc->target->ts.type == BT_CLASS))) - return match_typebound_call (st); - - /* If it does not seem to be callable (include functions so that the - right association is made. They are thrown out in resolution.) - ... */ - if (!sym->attr.generic - && !sym->attr.subroutine - && !sym->attr.function) - { - if (!(sym->attr.external && !sym->attr.referenced)) - { - /* ...create a symbol in this scope... */ - if (sym->ns != gfc_current_ns - && gfc_get_sym_tree (name, NULL, &st, false) == 1) - return MATCH_ERROR; - - if (sym != st->n.sym) - sym = st->n.sym; - } - - /* ...and then to try to make the symbol into a subroutine. */ - if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) - return MATCH_ERROR; - } - - gfc_set_sym_referenced (sym); - - if (gfc_match_eos () != MATCH_YES) - { - m = gfc_match_actual_arglist (1, &arglist); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - } - - /* Walk the argument list looking for invalid BOZ. */ - for (a = arglist; a; a = a->next) - if (a->expr && a->expr->ts.type == BT_BOZ) - { - gfc_error ("A BOZ literal constant at %L cannot appear as an actual " - "argument in a subroutine reference", &a->expr->where); - goto cleanup; - } - - - /* If any alternate return labels were found, construct a SELECT - statement that will jump to the right place. */ - - i = 0; - for (a = arglist; a; a = a->next) - if (a->expr == NULL) - { - i = 1; - break; - } - - if (i) - { - gfc_symtree *select_st; - gfc_symbol *select_sym; - char name[GFC_MAX_SYMBOL_LEN + 1]; - - new_st.next = c = gfc_get_code (EXEC_SELECT); - sprintf (name, "_result_%s", sym->name); - gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */ - - select_sym = select_st->n.sym; - select_sym->ts.type = BT_INTEGER; - select_sym->ts.kind = gfc_default_integer_kind; - gfc_set_sym_referenced (select_sym); - c->expr1 = gfc_get_expr (); - c->expr1->expr_type = EXPR_VARIABLE; - c->expr1->symtree = select_st; - c->expr1->ts = select_sym->ts; - c->expr1->where = gfc_current_locus; - - i = 0; - for (a = arglist; a; a = a->next) - { - if (a->expr != NULL) - continue; - - if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET)) - continue; - - i++; - - c->block = gfc_get_code (EXEC_SELECT); - c = c->block; - - new_case = gfc_get_case (); - new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); - new_case->low = new_case->high; - c->ext.block.case_list = new_case; - - c->next = gfc_get_code (EXEC_GOTO); - c->next->label1 = a->label; - } - } - - new_st.op = EXEC_CALL; - new_st.symtree = st; - new_st.ext.actual = arglist; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_CALL); - -cleanup: - gfc_free_actual_arglist (arglist); - return MATCH_ERROR; -} - - -/* Given a name, return a pointer to the common head structure, - creating it if it does not exist. If FROM_MODULE is nonzero, we - mangle the name so that it doesn't interfere with commons defined - in the using namespace. - TODO: Add to global symbol tree. */ - -gfc_common_head * -gfc_get_common (const char *name, int from_module) -{ - gfc_symtree *st; - static int serial = 0; - char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; - - if (from_module) - { - /* A use associated common block is only needed to correctly layout - the variables it contains. */ - snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); - st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); - } - else - { - st = gfc_find_symtree (gfc_current_ns->common_root, name); - - if (st == NULL) - st = gfc_new_symtree (&gfc_current_ns->common_root, name); - } - - if (st->n.common == NULL) - { - st->n.common = gfc_get_common_head (); - st->n.common->where = gfc_current_locus; - strcpy (st->n.common->name, name); - } - - return st->n.common; -} - - -/* Match a common block name. */ - -match -gfc_match_common_name (char *name) -{ - match m; - - if (gfc_match_char ('/') == MATCH_NO) - { - name[0] = '\0'; - return MATCH_YES; - } - - if (gfc_match_char ('/') == MATCH_YES) - { - name[0] = '\0'; - return MATCH_YES; - } - - m = gfc_match_name (name); - - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) - return MATCH_YES; - - gfc_error ("Syntax error in common block name at %C"); - return MATCH_ERROR; -} - - -/* Match a COMMON statement. */ - -match -gfc_match_common (void) -{ - gfc_symbol *sym, **head, *tail, *other; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_common_head *t; - gfc_array_spec *as; - gfc_equiv *e1, *e2; - match m; - char c; - - /* COMMON has been matched. In free form source code, the next character - needs to be whitespace or '/'. Check that here. Fixed form source - code needs to be checked below. */ - c = gfc_peek_ascii_char (); - if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '/') - return MATCH_NO; - - as = NULL; - - for (;;) - { - m = gfc_match_common_name (name); - if (m == MATCH_ERROR) - goto cleanup; - - if (name[0] == '\0') - { - t = &gfc_current_ns->blank_common; - if (t->head == NULL) - t->where = gfc_current_locus; - } - else - { - t = gfc_get_common (name, 0); - } - head = &t->head; - - if (*head == NULL) - tail = NULL; - else - { - tail = *head; - while (tail->common_next) - tail = tail->common_next; - } - - /* Grab the list of symbols. */ - for (;;) - { - m = gfc_match_symbol (&sym, 0); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - /* See if we know the current common block is bind(c), and if - so, then see if we can check if the symbol is (which it'll - need to be). This can happen if the bind(c) attr stmt was - applied to the common block, and the variable(s) already - defined, before declaring the common block. */ - if (t->is_bind_c == 1) - { - if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) - { - /* If we find an error, just print it and continue, - cause it's just semantic, and we can see if there - are more errors. */ - gfc_error_now ("Variable %qs at %L in common block %qs " - "at %C must be declared with a C " - "interoperable kind since common block " - "%qs is bind(c)", - sym->name, &(sym->declared_at), t->name, - t->name); - } - - if (sym->attr.is_bind_c == 1) - gfc_error_now ("Variable %qs in common block %qs at %C cannot " - "be bind(c) since it is not global", sym->name, - t->name); - } - - if (sym->attr.in_common) - { - gfc_error ("Symbol %qs at %C is already in a COMMON block", - sym->name); - goto cleanup; - } - - if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) - || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) - { - if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at " - "%C can only be COMMON in BLOCK DATA", - sym->name)) - goto cleanup; - } - - /* Deal with an optional array specification after the - symbol name. */ - m = gfc_match_array_spec (&as, true, true); - if (m == MATCH_ERROR) - goto cleanup; - - if (m == MATCH_YES) - { - if (as->type != AS_EXPLICIT) - { - gfc_error ("Array specification for symbol %qs in COMMON " - "at %C must be explicit", sym->name); - goto cleanup; - } - - if (as->corank) - { - gfc_error ("Symbol %qs in COMMON at %C cannot be a " - "coarray", sym->name); - goto cleanup; - } - - if (!gfc_add_dimension (&sym->attr, sym->name, NULL)) - goto cleanup; - - if (sym->attr.pointer) - { - gfc_error ("Symbol %qs in COMMON at %C cannot be a " - "POINTER array", sym->name); - goto cleanup; - } - - sym->as = as; - as = NULL; - - } - - /* Add the in_common attribute, but ignore the reported errors - if any, and continue matching. */ - gfc_add_in_common (&sym->attr, sym->name, NULL); - - sym->common_block = t; - sym->common_block->refs++; - - if (tail != NULL) - tail->common_next = sym; - else - *head = sym; - - tail = sym; - - sym->common_head = t; - - /* Check to see if the symbol is already in an equivalence group. - If it is, set the other members as being in common. */ - if (sym->attr.in_equivalence) - { - for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) - { - for (e2 = e1; e2; e2 = e2->eq) - if (e2->expr->symtree->n.sym == sym) - goto equiv_found; - - continue; - - equiv_found: - - for (e2 = e1; e2; e2 = e2->eq) - { - other = e2->expr->symtree->n.sym; - if (other->common_head - && other->common_head != sym->common_head) - { - gfc_error ("Symbol %qs, in COMMON block %qs at " - "%C is being indirectly equivalenced to " - "another COMMON block %qs", - sym->name, sym->common_head->name, - other->common_head->name); - goto cleanup; - } - other->attr.in_common = 1; - other->common_head = t; - } - } - } - - - gfc_gobble_whitespace (); - if (gfc_match_eos () == MATCH_YES) - goto done; - c = gfc_peek_ascii_char (); - if (c == '/') - break; - if (c != ',') - { - /* In Fixed form source code, gfortran can end up here for an - expression of the form COMMONI = RHS. This may not be an - error, so return MATCH_NO. */ - if (gfc_current_form == FORM_FIXED && c == '=') - { - gfc_free_array_spec (as); - return MATCH_NO; - } - goto syntax; - } - else - gfc_match_char (','); - - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () == '/') - break; - } - } - -done: - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_COMMON); - -cleanup: - gfc_free_array_spec (as); - return MATCH_ERROR; -} - - -/* Match a BLOCK DATA program unit. */ - -match -gfc_match_block_data (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - - if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L", - &gfc_current_locus)) - return MATCH_ERROR; - - if (gfc_match_eos () == MATCH_YES) - { - gfc_new_block = NULL; - return MATCH_YES; - } - - m = gfc_match ("% %n%t", name); - if (m != MATCH_YES) - return MATCH_ERROR; - - if (gfc_get_symbol (name, NULL, &sym)) - return MATCH_ERROR; - - if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL)) - return MATCH_ERROR; - - gfc_new_block = sym; - - return MATCH_YES; -} - - -/* Free a namelist structure. */ - -void -gfc_free_namelist (gfc_namelist *name) -{ - gfc_namelist *n; - - for (; name; name = n) - { - n = name->next; - free (name); - } -} - - -/* Free an OpenMP namelist structure. */ - -void -gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns) -{ - gfc_omp_namelist *n; - - for (; name; name = n) - { - gfc_free_expr (name->expr); - if (free_ns) - gfc_free_namespace (name->u2.ns); - else if (name->u2.udr) - { - if (name->u2.udr->combiner) - gfc_free_statement (name->u2.udr->combiner); - if (name->u2.udr->initializer) - gfc_free_statement (name->u2.udr->initializer); - free (name->u2.udr); - } - n = name->next; - free (name); - } -} - - -/* Match a NAMELIST statement. */ - -match -gfc_match_namelist (void) -{ - gfc_symbol *group_name, *sym; - gfc_namelist *nl; - match m, m2; - - m = gfc_match (" / %s /", &group_name); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto error; - - for (;;) - { - if (group_name->ts.type != BT_UNKNOWN) - { - gfc_error ("Namelist group name %qs at %C already has a basic " - "type of %s", group_name->name, - gfc_typename (&group_name->ts)); - return MATCH_ERROR; - } - - if (group_name->attr.flavor == FL_NAMELIST - && group_name->attr.use_assoc - && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs " - "at %C already is USE associated and can" - "not be respecified.", group_name->name)) - return MATCH_ERROR; - - if (group_name->attr.flavor != FL_NAMELIST - && !gfc_add_flavor (&group_name->attr, FL_NAMELIST, - group_name->name, NULL)) - return MATCH_ERROR; - - for (;;) - { - m = gfc_match_symbol (&sym, 1); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto error; - - if (sym->ts.type == BT_UNKNOWN) - { - if (gfc_current_ns->seen_implicit_none) - { - /* It is required that members of a namelist be declared - before the namelist. We check this by checking if the - symbol has a defined type for IMPLICIT NONE. */ - gfc_error ("Symbol %qs in namelist %qs at %C must be " - "declared before the namelist is declared.", - sym->name, group_name->name); - gfc_error_check (); - } - else - /* If the type is not set already, we set it here to the - implicit default type. It is not allowed to set it - later to any other type. */ - gfc_set_default_type (sym, 0, gfc_current_ns); - } - if (sym->attr.in_namelist == 0 - && !gfc_add_in_namelist (&sym->attr, sym->name, NULL)) - goto error; - - /* Use gfc_error_check here, rather than goto error, so that - these are the only errors for the next two lines. */ - if (sym->as && sym->as->type == AS_ASSUMED_SIZE) - { - gfc_error ("Assumed size array %qs in namelist %qs at " - "%C is not allowed", sym->name, group_name->name); - gfc_error_check (); - } - - nl = gfc_get_namelist (); - nl->sym = sym; - sym->refs++; - - if (group_name->namelist == NULL) - group_name->namelist = group_name->namelist_tail = nl; - else - { - group_name->namelist_tail->next = nl; - group_name->namelist_tail = nl; - } - - if (gfc_match_eos () == MATCH_YES) - goto done; - - m = gfc_match_char (','); - - if (gfc_match_char ('/') == MATCH_YES) - { - m2 = gfc_match (" %s /", &group_name); - if (m2 == MATCH_YES) - break; - if (m2 == MATCH_ERROR) - goto error; - goto syntax; - } - - if (m != MATCH_YES) - goto syntax; - } - } - -done: - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_NAMELIST); - -error: - return MATCH_ERROR; -} - - -/* Match a MODULE statement. */ - -match -gfc_match_module (void) -{ - match m; - - m = gfc_match (" %s%t", &gfc_new_block); - if (m != MATCH_YES) - return m; - - if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, - gfc_new_block->name, NULL)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* Free equivalence sets and lists. Recursively is the easiest way to - do this. */ - -void -gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) -{ - if (eq == stop) - return; - - gfc_free_equiv (eq->eq); - gfc_free_equiv_until (eq->next, stop); - gfc_free_expr (eq->expr); - free (eq); -} - - -void -gfc_free_equiv (gfc_equiv *eq) -{ - gfc_free_equiv_until (eq, NULL); -} - - -/* Match an EQUIVALENCE statement. */ - -match -gfc_match_equivalence (void) -{ - gfc_equiv *eq, *set, *tail; - gfc_ref *ref; - gfc_symbol *sym; - match m; - gfc_common_head *common_head = NULL; - bool common_flag; - int cnt; - char c; - - /* EQUIVALENCE has been matched. After gobbling any possible whitespace, - the next character needs to be '('. Check that here, and return - MATCH_NO for a variable of the form equivalencej. */ - gfc_gobble_whitespace (); - c = gfc_peek_ascii_char (); - if (c != '(') - return MATCH_NO; - - tail = NULL; - - for (;;) - { - eq = gfc_get_equiv (); - if (tail == NULL) - tail = eq; - - eq->next = gfc_current_ns->equiv; - gfc_current_ns->equiv = eq; - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - set = eq; - common_flag = FALSE; - cnt = 0; - - for (;;) - { - m = gfc_match_equiv_variable (&set->expr); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - /* count the number of objects. */ - cnt++; - - if (gfc_match_char ('%') == MATCH_YES) - { - gfc_error ("Derived type component %C is not a " - "permitted EQUIVALENCE member"); - goto cleanup; - } - - for (ref = set->expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) - { - gfc_error ("Array reference in EQUIVALENCE at %C cannot " - "be an array section"); - goto cleanup; - } - - sym = set->expr->symtree->n.sym; - - if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) - goto cleanup; - if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym) - && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, - sym->name, NULL)) - goto cleanup; - - if (sym->attr.in_common) - { - common_flag = TRUE; - common_head = sym->common_head; - } - - if (gfc_match_char (')') == MATCH_YES) - break; - - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - set->eq = gfc_get_equiv (); - set = set->eq; - } - - if (cnt < 2) - { - gfc_error ("EQUIVALENCE at %C requires two or more objects"); - goto cleanup; - } - - /* If one of the members of an equivalence is in common, then - mark them all as being in common. Before doing this, check - that members of the equivalence group are not in different - common blocks. */ - if (common_flag) - for (set = eq; set; set = set->eq) - { - sym = set->expr->symtree->n.sym; - if (sym->common_head && sym->common_head != common_head) - { - gfc_error ("Attempt to indirectly overlap COMMON " - "blocks %s and %s by EQUIVALENCE at %C", - sym->common_head->name, common_head->name); - goto cleanup; - } - sym->attr.in_common = 1; - sym->common_head = common_head; - } - - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expecting a comma in EQUIVALENCE at %C"); - goto cleanup; - } - } - - if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C")) - return MATCH_ERROR; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_EQUIVALENCE); - -cleanup: - eq = tail->next; - tail->next = NULL; - - gfc_free_equiv (gfc_current_ns->equiv); - gfc_current_ns->equiv = eq; - - return MATCH_ERROR; -} - - -/* Check that a statement function is not recursive. This is done by looking - for the statement function symbol(sym) by looking recursively through its - expression(e). If a reference to sym is found, true is returned. - 12.5.4 requires that any variable of function that is implicitly typed - shall have that type confirmed by any subsequent type declaration. The - implicit typing is conveniently done here. */ -static bool -recursive_stmt_fcn (gfc_expr *, gfc_symbol *); - -static bool -check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) -{ - - if (e == NULL) - return false; - - switch (e->expr_type) - { - case EXPR_FUNCTION: - if (e->symtree == NULL) - return false; - - /* Check the name before testing for nested recursion! */ - if (sym->name == e->symtree->n.sym->name) - return true; - - /* Catch recursion via other statement functions. */ - if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION - && e->symtree->n.sym->value - && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) - return true; - - if (e->symtree->n.sym->ts.type == BT_UNKNOWN) - gfc_set_default_type (e->symtree->n.sym, 0, NULL); - - break; - - case EXPR_VARIABLE: - if (e->symtree && sym->name == e->symtree->n.sym->name) - return true; - - if (e->symtree->n.sym->ts.type == BT_UNKNOWN) - gfc_set_default_type (e->symtree->n.sym, 0, NULL); - break; - - default: - break; - } - - return false; -} - - -static bool -recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) -{ - return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); -} - - -/* Match a statement function declaration. It is so easy to match - non-statement function statements with a MATCH_ERROR as opposed to - MATCH_NO that we suppress error message in most cases. */ - -match -gfc_match_st_function (void) -{ - gfc_error_buffer old_error; - gfc_symbol *sym; - gfc_expr *expr; - match m; - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; - bool fcn; - gfc_formal_arglist *ptr; - - /* Read the possible statement function name, and then check to see if - a symbol is already present in the namespace. Record if it is a - function and whether it has been referenced. */ - fcn = false; - ptr = NULL; - old_locus = gfc_current_locus; - m = gfc_match_name (name); - if (m == MATCH_YES) - { - gfc_find_symbol (name, NULL, 1, &sym); - if (sym && sym->attr.function && !sym->attr.referenced) - { - fcn = true; - ptr = sym->formal; - } - } - - gfc_current_locus = old_locus; - m = gfc_match_symbol (&sym, 0); - if (m != MATCH_YES) - return m; - - gfc_push_error (&old_error); - - if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) - goto undo_error; - - if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) - goto undo_error; - - m = gfc_match (" = %e%t", &expr); - if (m == MATCH_NO) - goto undo_error; - - gfc_free_error (&old_error); - - if (m == MATCH_ERROR) - return m; - - if (recursive_stmt_fcn (expr, sym)) - { - gfc_error ("Statement function at %L is recursive", &expr->where); - return MATCH_ERROR; - } - - if (fcn && ptr != sym->formal) - { - gfc_error ("Statement function %qs at %L conflicts with function name", - sym->name, &expr->where); - return MATCH_ERROR; - } - - sym->value = expr; - - if ((gfc_current_state () == COMP_FUNCTION - || gfc_current_state () == COMP_SUBROUTINE) - && gfc_state_stack->previous->state == COMP_INTERFACE) - { - gfc_error ("Statement function at %L cannot appear within an INTERFACE", - &expr->where); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C")) - return MATCH_ERROR; - - return MATCH_YES; - -undo_error: - gfc_pop_error (&old_error); - return MATCH_NO; -} - - -/* Match an assignment to a pointer function (F2008). This could, in - general be ambiguous with a statement function. In this implementation - it remains so if it is the first statement after the specification - block. */ - -match -gfc_match_ptr_fcn_assign (void) -{ - gfc_error_buffer old_error; - locus old_loc; - gfc_symbol *sym; - gfc_expr *expr; - match m; - char name[GFC_MAX_SYMBOL_LEN + 1]; - - old_loc = gfc_current_locus; - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - gfc_find_symbol (name, NULL, 1, &sym); - if (sym && sym->attr.flavor != FL_PROCEDURE) - return MATCH_NO; - - gfc_push_error (&old_error); - - if (sym && sym->attr.function) - goto match_actual_arglist; - - gfc_current_locus = old_loc; - m = gfc_match_symbol (&sym, 0); - if (m != MATCH_YES) - return m; - - if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL)) - goto undo_error; - -match_actual_arglist: - gfc_current_locus = old_loc; - m = gfc_match (" %e", &expr); - if (m != MATCH_YES) - goto undo_error; - - new_st.op = EXEC_ASSIGN; - new_st.expr1 = expr; - expr = NULL; - - m = gfc_match (" = %e%t", &expr); - if (m != MATCH_YES) - goto undo_error; - - new_st.expr2 = expr; - return MATCH_YES; - -undo_error: - gfc_pop_error (&old_error); - return MATCH_NO; -} - - -/***************** SELECT CASE subroutines ******************/ - -/* Free a single case structure. */ - -static void -free_case (gfc_case *p) -{ - if (p->low == p->high) - p->high = NULL; - gfc_free_expr (p->low); - gfc_free_expr (p->high); - free (p); -} - - -/* Free a list of case structures. */ - -void -gfc_free_case_list (gfc_case *p) -{ - gfc_case *q; - - for (; p; p = q) - { - q = p->next; - free_case (p); - } -} - - -/* Match a single case selector. Combining the requirements of F08:C830 - and F08:C832 (R838) means that the case-value must have either CHARACTER, - INTEGER, or LOGICAL type. */ - -static match -match_case_selector (gfc_case **cp) -{ - gfc_case *c; - match m; - - c = gfc_get_case (); - c->where = gfc_current_locus; - - if (gfc_match_char (':') == MATCH_YES) - { - m = gfc_match_init_expr (&c->high); - if (m == MATCH_NO) - goto need_expr; - if (m == MATCH_ERROR) - goto cleanup; - - if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER - && c->high->ts.type != BT_CHARACTER) - { - gfc_error ("Expression in CASE selector at %L cannot be %s", - &c->high->where, gfc_typename (&c->high->ts)); - goto cleanup; - } - } - else - { - m = gfc_match_init_expr (&c->low); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto need_expr; - - if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER - && c->low->ts.type != BT_CHARACTER) - { - gfc_error ("Expression in CASE selector at %L cannot be %s", - &c->low->where, gfc_typename (&c->low->ts)); - goto cleanup; - } - - /* If we're not looking at a ':' now, make a range out of a single - target. Else get the upper bound for the case range. */ - if (gfc_match_char (':') != MATCH_YES) - c->high = c->low; - else - { - m = gfc_match_init_expr (&c->high); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES - && c->high->ts.type != BT_LOGICAL - && c->high->ts.type != BT_INTEGER - && c->high->ts.type != BT_CHARACTER) - { - gfc_error ("Expression in CASE selector at %L cannot be %s", - &c->high->where, gfc_typename (c->high)); - goto cleanup; - } - /* MATCH_NO is fine. It's OK if nothing is there! */ - } - } - - if (c->low && c->low->rank != 0) - { - gfc_error ("Expression in CASE selector at %L must be scalar", - &c->low->where); - goto cleanup; - } - if (c->high && c->high->rank != 0) - { - gfc_error ("Expression in CASE selector at %L must be scalar", - &c->high->where); - goto cleanup; - } - - *cp = c; - return MATCH_YES; - -need_expr: - gfc_error ("Expected initialization expression in CASE at %C"); - -cleanup: - free_case (c); - return MATCH_ERROR; -} - - -/* Match the end of a case statement. */ - -static match -match_case_eos (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - match m; - - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - - /* If the case construct doesn't have a case-construct-name, we - should have matched the EOS. */ - if (!gfc_current_block ()) - return MATCH_NO; - - gfc_gobble_whitespace (); - - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - if (strcmp (name, gfc_current_block ()->name) != 0) - { - gfc_error ("Expected block name %qs of SELECT construct at %C", - gfc_current_block ()->name); - return MATCH_ERROR; - } - - return gfc_match_eos (); -} - - -/* Match a SELECT statement. */ - -match -gfc_match_select (void) -{ - gfc_expr *expr; - match m; - - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; - - m = gfc_match (" select case ( %e )%t", &expr); - if (m != MATCH_YES) - return m; - - new_st.op = EXEC_SELECT; - new_st.expr1 = expr; - - return MATCH_YES; -} - - -/* Transfer the selector typespec to the associate name. */ - -static void -copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) -{ - gfc_ref *ref; - gfc_symbol *assoc_sym; - int rank = 0; - - assoc_sym = associate->symtree->n.sym; - - /* At this stage the expression rank and arrayspec dimensions have - not been completely sorted out. We must get the expr2->rank - right here, so that the correct class container is obtained. */ - ref = selector->ref; - while (ref && ref->next) - ref = ref->next; - - if (selector->ts.type == BT_CLASS - && CLASS_DATA (selector) - && CLASS_DATA (selector)->as - && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK) - { - assoc_sym->attr.dimension = 1; - assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); - goto build_class_sym; - } - else if (selector->ts.type == BT_CLASS - && CLASS_DATA (selector) - && CLASS_DATA (selector)->as - && ref && ref->type == REF_ARRAY) - { - /* Ensure that the array reference type is set. We cannot use - gfc_resolve_expr at this point, so the usable parts of - resolve.c(resolve_array_ref) are employed to do it. */ - if (ref->u.ar.type == AR_UNKNOWN) - { - ref->u.ar.type = AR_ELEMENT; - for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_RANGE - || ref->u.ar.dimen_type[i] == DIMEN_VECTOR - || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN - && ref->u.ar.start[i] && ref->u.ar.start[i]->rank)) - { - ref->u.ar.type = AR_SECTION; - break; - } - } - - if (ref->u.ar.type == AR_FULL) - selector->rank = CLASS_DATA (selector)->as->rank; - else if (ref->u.ar.type == AR_SECTION) - selector->rank = ref->u.ar.dimen; - else - selector->rank = 0; - - rank = selector->rank; - } - - if (rank) - { - for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT - || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN - && ref->u.ar.end[i] == NULL - && ref->u.ar.stride[i] == NULL)) - rank--; - - if (rank) - { - assoc_sym->attr.dimension = 1; - assoc_sym->as = gfc_get_array_spec (); - assoc_sym->as->rank = rank; - assoc_sym->as->type = AS_DEFERRED; - } - else - assoc_sym->as = NULL; - } - else - assoc_sym->as = NULL; - -build_class_sym: - if (selector->ts.type == BT_CLASS) - { - /* The correct class container has to be available. */ - assoc_sym->ts.type = BT_CLASS; - assoc_sym->ts.u.derived = CLASS_DATA (selector) - ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived; - assoc_sym->attr.pointer = 1; - gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); - } -} - - -/* Push the current selector onto the SELECT TYPE stack. */ - -static void -select_type_push (gfc_symbol *sel) -{ - gfc_select_type_stack *top = gfc_get_select_type_stack (); - top->selector = sel; - top->tmp = NULL; - top->prev = select_type_stack; - - select_type_stack = top; -} - - -/* Set the temporary for the current intrinsic SELECT TYPE selector. */ - -static gfc_symtree * -select_intrinsic_set_tmp (gfc_typespec *ts) -{ - char name[GFC_MAX_SYMBOL_LEN]; - gfc_symtree *tmp; - HOST_WIDE_INT charlen = 0; - gfc_symbol *selector = select_type_stack->selector; - gfc_symbol *sym; - - if (ts->type == BT_CLASS || ts->type == BT_DERIVED) - return NULL; - - if (selector->ts.type == BT_CLASS && !selector->attr.class_ok) - return NULL; - - /* Case value == NULL corresponds to SELECT TYPE cases otherwise - the values correspond to SELECT rank cases. */ - if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT) - charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); - - if (ts->type != BT_CHARACTER) - sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), - ts->kind); - else - snprintf (name, sizeof (name), - "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (ts->type), charlen, ts->kind); - - gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); - sym = tmp->n.sym; - gfc_add_type (sym, ts, NULL); - - /* Copy across the array spec to the selector. */ - if (selector->ts.type == BT_CLASS - && (CLASS_DATA (selector)->attr.dimension - || CLASS_DATA (selector)->attr.codimension)) - { - sym->attr.pointer = 1; - sym->attr.dimension = CLASS_DATA (selector)->attr.dimension; - sym->attr.codimension = CLASS_DATA (selector)->attr.codimension; - sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); - } - - gfc_set_sym_referenced (sym); - gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); - sym->attr.select_type_temporary = 1; - - return tmp; -} - - -/* Set up a temporary for the current TYPE IS / CLASS IS branch . */ - -static void -select_type_set_tmp (gfc_typespec *ts) -{ - char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; - gfc_symtree *tmp = NULL; - gfc_symbol *selector = select_type_stack->selector; - gfc_symbol *sym; - - if (!ts) - { - select_type_stack->tmp = NULL; - return; - } - - tmp = select_intrinsic_set_tmp (ts); - - if (tmp == NULL) - { - if (!ts->u.derived) - return; - - if (ts->type == BT_CLASS) - sprintf (name, "__tmp_class_%s", ts->u.derived->name); - else - sprintf (name, "__tmp_type_%s", ts->u.derived->name); - - gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); - sym = tmp->n.sym; - gfc_add_type (sym, ts, NULL); - - if (selector->ts.type == BT_CLASS && selector->attr.class_ok - && selector->ts.u.derived && CLASS_DATA (selector)) - { - sym->attr.pointer - = CLASS_DATA (selector)->attr.class_pointer; - - /* Copy across the array spec to the selector. */ - if (CLASS_DATA (selector)->attr.dimension - || CLASS_DATA (selector)->attr.codimension) - { - sym->attr.dimension - = CLASS_DATA (selector)->attr.dimension; - sym->attr.codimension - = CLASS_DATA (selector)->attr.codimension; - if (CLASS_DATA (selector)->as->type != AS_EXPLICIT) - sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); - else - { - sym->as = gfc_get_array_spec(); - sym->as->rank = CLASS_DATA (selector)->as->rank; - sym->as->type = AS_DEFERRED; - } - } - } - - gfc_set_sym_referenced (sym); - gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); - sym->attr.select_type_temporary = 1; - - if (ts->type == BT_CLASS) - gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); - } - else - sym = tmp->n.sym; - - - /* Add an association for it, so the rest of the parser knows it is - an associate-name. The target will be set during resolution. */ - sym->assoc = gfc_get_association_list (); - sym->assoc->dangling = 1; - sym->assoc->st = tmp; - - select_type_stack->tmp = tmp; -} - - -/* Match a SELECT TYPE statement. */ - -match -gfc_match_select_type (void) -{ - gfc_expr *expr1, *expr2 = NULL; - match m; - char name[GFC_MAX_SYMBOL_LEN + 1]; - bool class_array; - gfc_symbol *sym; - gfc_namespace *ns = gfc_current_ns; - - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; - - m = gfc_match (" select type ( "); - if (m != MATCH_YES) - return m; - - if (gfc_current_state() == COMP_MODULE - || gfc_current_state() == COMP_SUBMODULE) - { - gfc_error ("SELECT TYPE at %C cannot appear in this scope"); - return MATCH_ERROR; - } - - gfc_current_ns = gfc_build_block_ns (ns); - m = gfc_match (" %n => %e", name, &expr2); - if (m == MATCH_YES) - { - expr1 = gfc_get_expr (); - expr1->expr_type = EXPR_VARIABLE; - expr1->where = expr2->where; - if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) - { - m = MATCH_ERROR; - goto cleanup; - } - - sym = expr1->symtree->n.sym; - if (expr2->ts.type == BT_UNKNOWN) - sym->attr.untyped = 1; - else - copy_ts_from_selector_to_associate (expr1, expr2); - - sym->attr.flavor = FL_VARIABLE; - sym->attr.referenced = 1; - sym->attr.class_ok = 1; - } - else - { - m = gfc_match (" %e ", &expr1); - if (m != MATCH_YES) - { - std::swap (ns, gfc_current_ns); - gfc_free_namespace (ns); - return m; - } - } - - m = gfc_match (" )%t"); - if (m != MATCH_YES) - { - gfc_error ("parse error in SELECT TYPE statement at %C"); - goto cleanup; - } - - /* This ghastly expression seems to be needed to distinguish a CLASS - array, which can have a reference, from other expressions that - have references, such as derived type components, and are not - allowed by the standard. - TODO: see if it is sufficient to exclude component and substring - references. */ - class_array = (expr1->expr_type == EXPR_VARIABLE - && expr1->ts.type == BT_CLASS - && CLASS_DATA (expr1) - && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) - && (CLASS_DATA (expr1)->attr.dimension - || CLASS_DATA (expr1)->attr.codimension) - && expr1->ref - && expr1->ref->type == REF_ARRAY - && expr1->ref->u.ar.type == AR_FULL - && expr1->ref->next == NULL); - - /* Check for F03:C811 (F08:C835). */ - if (!expr2 && (expr1->expr_type != EXPR_VARIABLE - || (!class_array && expr1->ref != NULL))) - { - gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " - "use associate-name=>"); - m = MATCH_ERROR; - goto cleanup; - } - - new_st.op = EXEC_SELECT_TYPE; - new_st.expr1 = expr1; - new_st.expr2 = expr2; - new_st.ext.block.ns = gfc_current_ns; - - select_type_push (expr1->symtree->n.sym); - gfc_current_ns = ns; - - return MATCH_YES; - -cleanup: - gfc_free_expr (expr1); - gfc_free_expr (expr2); - gfc_undo_symbols (); - std::swap (ns, gfc_current_ns); - gfc_free_namespace (ns); - return m; -} - - -/* Set the temporary for the current intrinsic SELECT RANK selector. */ - -static void -select_rank_set_tmp (gfc_typespec *ts, int *case_value) -{ - char name[2 * GFC_MAX_SYMBOL_LEN]; - char tname[GFC_MAX_SYMBOL_LEN + 7]; - gfc_symtree *tmp; - gfc_symbol *selector = select_type_stack->selector; - gfc_symbol *sym; - gfc_symtree *st; - HOST_WIDE_INT charlen = 0; - - if (case_value == NULL) - return; - - if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT) - charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); - - if (ts->type == BT_CLASS) - sprintf (tname, "class_%s", ts->u.derived->name); - else if (ts->type == BT_DERIVED) - sprintf (tname, "type_%s", ts->u.derived->name); - else if (ts->type != BT_CHARACTER) - sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind); - else - sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (ts->type), charlen, ts->kind); - - /* Case value == NULL corresponds to SELECT TYPE cases otherwise - the values correspond to SELECT rank cases. */ - if (*case_value >=0) - sprintf (name, "__tmp_%s_rank_%d", tname, *case_value); - else - sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value); - - gfc_find_sym_tree (name, gfc_current_ns, 0, &st); - if (st) - return; - - gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); - sym = tmp->n.sym; - gfc_add_type (sym, ts, NULL); - - /* Copy across the array spec to the selector. */ - if (selector->ts.type == BT_CLASS) - { - sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; - sym->attr.pointer = CLASS_DATA (selector)->attr.pointer; - sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable; - sym->attr.target = CLASS_DATA (selector)->attr.target; - sym->attr.class_ok = 0; - if (case_value && *case_value != 0) - { - sym->attr.dimension = 1; - sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); - if (*case_value > 0) - { - sym->as->type = AS_DEFERRED; - sym->as->rank = *case_value; - } - else if (*case_value == -1) - { - sym->as->type = AS_ASSUMED_SIZE; - sym->as->rank = 1; - } - } - } - else - { - sym->attr.pointer = selector->attr.pointer; - sym->attr.allocatable = selector->attr.allocatable; - sym->attr.target = selector->attr.target; - if (case_value && *case_value != 0) - { - sym->attr.dimension = 1; - sym->as = gfc_copy_array_spec (selector->as); - if (*case_value > 0) - { - sym->as->type = AS_DEFERRED; - sym->as->rank = *case_value; - } - else if (*case_value == -1) - { - sym->as->type = AS_ASSUMED_SIZE; - sym->as->rank = 1; - } - } - } - - gfc_set_sym_referenced (sym); - gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); - sym->attr.select_type_temporary = 1; - if (case_value) - sym->attr.select_rank_temporary = 1; - - if (ts->type == BT_CLASS) - gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); - - /* Add an association for it, so the rest of the parser knows it is - an associate-name. The target will be set during resolution. */ - sym->assoc = gfc_get_association_list (); - sym->assoc->dangling = 1; - sym->assoc->st = tmp; - - select_type_stack->tmp = tmp; -} - - -/* Match a SELECT RANK statement. */ - -match -gfc_match_select_rank (void) -{ - gfc_expr *expr1, *expr2 = NULL; - match m; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym, *sym2; - gfc_namespace *ns = gfc_current_ns; - gfc_array_spec *as = NULL; - - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; - - m = gfc_match (" select rank ( "); - if (m != MATCH_YES) - return m; - - if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C")) - return MATCH_NO; - - gfc_current_ns = gfc_build_block_ns (ns); - m = gfc_match (" %n => %e", name, &expr2); - if (m == MATCH_YES) - { - expr1 = gfc_get_expr (); - expr1->expr_type = EXPR_VARIABLE; - expr1->where = expr2->where; - expr1->ref = gfc_copy_ref (expr2->ref); - if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) - { - m = MATCH_ERROR; - goto cleanup; - } - - sym = expr1->symtree->n.sym; - - if (expr2->symtree) - { - sym2 = expr2->symtree->n.sym; - as = (sym2->ts.type == BT_CLASS - && CLASS_DATA (sym2)) ? CLASS_DATA (sym2)->as : sym2->as; - } - - if (expr2->expr_type != EXPR_VARIABLE - || !(as && as->type == AS_ASSUMED_RANK)) - { - gfc_error ("The SELECT RANK selector at %C must be an assumed " - "rank variable"); - m = MATCH_ERROR; - goto cleanup; - } - - if (expr2->ts.type == BT_CLASS && CLASS_DATA (sym2)) - { - copy_ts_from_selector_to_associate (expr1, expr2); - - sym->attr.flavor = FL_VARIABLE; - sym->attr.referenced = 1; - sym->attr.class_ok = 1; - CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable; - CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer; - CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target; - sym->attr.pointer = 1; - } - else - { - sym->ts = sym2->ts; - sym->as = gfc_copy_array_spec (sym2->as); - sym->attr.dimension = 1; - - sym->attr.flavor = FL_VARIABLE; - sym->attr.referenced = 1; - sym->attr.class_ok = sym2->attr.class_ok; - sym->attr.allocatable = sym2->attr.allocatable; - sym->attr.pointer = sym2->attr.pointer; - sym->attr.target = sym2->attr.target; - } - } - else - { - m = gfc_match (" %e ", &expr1); - - if (m != MATCH_YES) - { - gfc_undo_symbols (); - std::swap (ns, gfc_current_ns); - gfc_free_namespace (ns); - return m; - } - - if (expr1->symtree) - { - sym = expr1->symtree->n.sym; - as = (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)) ? CLASS_DATA (sym)->as : sym->as; - } - - if (expr1->expr_type != EXPR_VARIABLE - || !(as && as->type == AS_ASSUMED_RANK)) - { - gfc_error("The SELECT RANK selector at %C must be an assumed " - "rank variable"); - m = MATCH_ERROR; - goto cleanup; - } - } - - m = gfc_match (" )%t"); - if (m != MATCH_YES) - { - gfc_error ("parse error in SELECT RANK statement at %C"); - goto cleanup; - } - - new_st.op = EXEC_SELECT_RANK; - new_st.expr1 = expr1; - new_st.expr2 = expr2; - new_st.ext.block.ns = gfc_current_ns; - - select_type_push (expr1->symtree->n.sym); - gfc_current_ns = ns; - - return MATCH_YES; - -cleanup: - gfc_free_expr (expr1); - gfc_free_expr (expr2); - gfc_undo_symbols (); - std::swap (ns, gfc_current_ns); - gfc_free_namespace (ns); - return m; -} - - -/* Match a CASE statement. */ - -match -gfc_match_case (void) -{ - gfc_case *c, *head, *tail; - match m; - - head = tail = NULL; - - if (gfc_current_state () != COMP_SELECT) - { - gfc_error ("Unexpected CASE statement at %C"); - return MATCH_ERROR; - } - - if (gfc_match ("% default") == MATCH_YES) - { - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT; - c = gfc_get_case (); - c->where = gfc_current_locus; - new_st.ext.block.case_list = c; - return MATCH_YES; - } - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - for (;;) - { - if (match_case_selector (&c) == MATCH_ERROR) - goto cleanup; - - if (head == NULL) - head = c; - else - tail->next = c; - - tail = c; - - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT; - new_st.ext.block.case_list = head; - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in CASE specification at %C"); - -cleanup: - gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ - return MATCH_ERROR; -} - - -/* Match a TYPE IS statement. */ - -match -gfc_match_type_is (void) -{ - gfc_case *c = NULL; - match m; - - if (gfc_current_state () != COMP_SELECT_TYPE) - { - gfc_error ("Unexpected TYPE IS statement at %C"); - return MATCH_ERROR; - } - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - c = gfc_get_case (); - c->where = gfc_current_locus; - - m = gfc_match_type_spec (&c->ts); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT_TYPE; - new_st.ext.block.case_list = c; - - if (c->ts.type == BT_DERIVED && c->ts.u.derived - && (c->ts.u.derived->attr.sequence - || c->ts.u.derived->attr.is_bind_c)) - { - gfc_error ("The type-spec shall not specify a sequence derived " - "type or a type with the BIND attribute in SELECT " - "TYPE at %C [F2003:C815]"); - return MATCH_ERROR; - } - - if (c->ts.type == BT_DERIVED - && c->ts.u.derived && c->ts.u.derived->attr.pdt_type - && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived) - != SPEC_ASSUMED) - { - gfc_error ("All the LEN type parameters in the TYPE IS statement " - "at %C must be ASSUMED"); - return MATCH_ERROR; - } - - /* Create temporary variable. */ - select_type_set_tmp (&c->ts); - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in TYPE IS specification at %C"); - -cleanup: - if (c != NULL) - gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ - return MATCH_ERROR; -} - - -/* Match a CLASS IS or CLASS DEFAULT statement. */ - -match -gfc_match_class_is (void) -{ - gfc_case *c = NULL; - match m; - - if (gfc_current_state () != COMP_SELECT_TYPE) - return MATCH_NO; - - if (gfc_match ("% default") == MATCH_YES) - { - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT_TYPE; - c = gfc_get_case (); - c->where = gfc_current_locus; - c->ts.type = BT_UNKNOWN; - new_st.ext.block.case_list = c; - select_type_set_tmp (NULL); - return MATCH_YES; - } - - m = gfc_match ("% is"); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - c = gfc_get_case (); - c->where = gfc_current_locus; - - m = match_derived_type_spec (&c->ts); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (c->ts.type == BT_DERIVED) - c->ts.type = BT_CLASS; - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT_TYPE; - new_st.ext.block.case_list = c; - - /* Create temporary variable. */ - select_type_set_tmp (&c->ts); - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in CLASS IS specification at %C"); - -cleanup: - if (c != NULL) - gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ - return MATCH_ERROR; -} - - -/* Match a RANK statement. */ - -match -gfc_match_rank_is (void) -{ - gfc_case *c = NULL; - match m; - int case_value; - - if (gfc_current_state () != COMP_SELECT_RANK) - { - gfc_error ("Unexpected RANK statement at %C"); - return MATCH_ERROR; - } - - if (gfc_match ("% default") == MATCH_YES) - { - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT_RANK; - c = gfc_get_case (); - c->ts.type = BT_UNKNOWN; - c->where = gfc_current_locus; - new_st.ext.block.case_list = c; - select_type_stack->tmp = NULL; - return MATCH_YES; - } - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - c = gfc_get_case (); - c->where = gfc_current_locus; - c->ts = select_type_stack->selector->ts; - - m = gfc_match_expr (&c->low); - if (m == MATCH_NO) - { - if (gfc_match_char ('*') == MATCH_YES) - c->low = gfc_get_int_expr (gfc_default_integer_kind, - NULL, -1); - else - goto syntax; - - case_value = -1; - } - else if (m == MATCH_YES) - { - /* F2018: R1150 */ - if (c->low->expr_type != EXPR_CONSTANT - || c->low->ts.type != BT_INTEGER - || c->low->rank) - { - gfc_error ("The SELECT RANK CASE expression at %C must be a " - "scalar, integer constant"); - goto cleanup; - } - - case_value = (int) mpz_get_si (c->low->value.integer); - /* F2018: C1151 */ - if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS)) - { - gfc_error ("The value of the SELECT RANK CASE expression at " - "%C must not be less than zero or greater than %d", - GFC_MAX_DIMENSIONS); - goto cleanup; - } - } - else - goto cleanup; - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT_RANK; - new_st.ext.block.case_list = c; - - /* Create temporary variable. Recycle the select type code. */ - select_rank_set_tmp (&c->ts, &case_value); - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in RANK specification at %C"); - -cleanup: - if (c != NULL) - gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ - return MATCH_ERROR; -} - -/********************* WHERE subroutines ********************/ - -/* Match the rest of a simple WHERE statement that follows an IF statement. - */ - -static match -match_simple_where (void) -{ - gfc_expr *expr; - gfc_code *c; - match m; - - m = gfc_match (" ( %e )", &expr); - if (m != MATCH_YES) - return m; - - m = gfc_match_assignment (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - - c = gfc_get_code (EXEC_WHERE); - c->expr1 = expr; - - c->next = XCNEW (gfc_code); - *c->next = new_st; - c->next->loc = gfc_current_locus; - gfc_clear_new_st (); - - new_st.op = EXEC_WHERE; - new_st.block = c; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_WHERE); - -cleanup: - gfc_free_expr (expr); - return MATCH_ERROR; -} - - -/* Match a WHERE statement. */ - -match -gfc_match_where (gfc_statement *st) -{ - gfc_expr *expr; - match m0, m; - gfc_code *c; - - m0 = gfc_match_label (); - if (m0 == MATCH_ERROR) - return m0; - - m = gfc_match (" where ( %e )", &expr); - if (m != MATCH_YES) - return m; - - if (gfc_match_eos () == MATCH_YES) - { - *st = ST_WHERE_BLOCK; - new_st.op = EXEC_WHERE; - new_st.expr1 = expr; - return MATCH_YES; - } - - m = gfc_match_assignment (); - if (m == MATCH_NO) - gfc_syntax_error (ST_WHERE); - - if (m != MATCH_YES) - { - gfc_free_expr (expr); - return MATCH_ERROR; - } - - /* We've got a simple WHERE statement. */ - *st = ST_WHERE; - c = gfc_get_code (EXEC_WHERE); - c->expr1 = expr; - - /* Put in the assignment. It will not be processed by add_statement, so we - need to copy the location here. */ - - c->next = XCNEW (gfc_code); - *c->next = new_st; - c->next->loc = gfc_current_locus; - gfc_clear_new_st (); - - new_st.op = EXEC_WHERE; - new_st.block = c; - - return MATCH_YES; -} - - -/* Match an ELSEWHERE statement. We leave behind a WHERE node in - new_st if successful. */ - -match -gfc_match_elsewhere (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_expr *expr; - match m; - - if (gfc_current_state () != COMP_WHERE) - { - gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); - return MATCH_ERROR; - } - - expr = NULL; - - if (gfc_match_char ('(') == MATCH_YES) - { - m = gfc_match_expr (&expr); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - } - - if (gfc_match_eos () != MATCH_YES) - { - /* Only makes sense if we have a where-construct-name. */ - if (!gfc_current_block ()) - { - m = MATCH_ERROR; - goto cleanup; - } - /* Better be a name at this point. */ - m = gfc_match_name (name); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - if (gfc_match_eos () != MATCH_YES) - goto syntax; - - if (strcmp (name, gfc_current_block ()->name) != 0) - { - gfc_error ("Label %qs at %C doesn't match WHERE label %qs", - name, gfc_current_block ()->name); - goto cleanup; - } - } - - new_st.op = EXEC_WHERE; - new_st.expr1 = expr; - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_ELSEWHERE); - -cleanup: - gfc_free_expr (expr); - return MATCH_ERROR; -} diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc new file mode 100644 index 0000000..1afc555 --- /dev/null +++ b/gcc/fortran/match.cc @@ -0,0 +1,7264 @@ +/* Matching subroutines in all sizes, shapes and colors. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "match.h" +#include "parse.h" + +int gfc_matching_ptr_assignment = 0; +int gfc_matching_procptr_assignment = 0; +bool gfc_matching_prefix = false; + +/* Stack of SELECT TYPE statements. */ +gfc_select_type_stack *select_type_stack = NULL; + +/* List of type parameter expressions. */ +gfc_actual_arglist *type_param_spec_list; + +/* For debugging and diagnostic purposes. Return the textual representation + of the intrinsic operator OP. */ +const char * +gfc_op2string (gfc_intrinsic_op op) +{ + switch (op) + { + case INTRINSIC_UPLUS: + case INTRINSIC_PLUS: + return "+"; + + case INTRINSIC_UMINUS: + case INTRINSIC_MINUS: + return "-"; + + case INTRINSIC_POWER: + return "**"; + case INTRINSIC_CONCAT: + return "//"; + case INTRINSIC_TIMES: + return "*"; + case INTRINSIC_DIVIDE: + return "/"; + + case INTRINSIC_AND: + return ".and."; + case INTRINSIC_OR: + return ".or."; + case INTRINSIC_EQV: + return ".eqv."; + case INTRINSIC_NEQV: + return ".neqv."; + + case INTRINSIC_EQ_OS: + return ".eq."; + case INTRINSIC_EQ: + return "=="; + case INTRINSIC_NE_OS: + return ".ne."; + case INTRINSIC_NE: + return "/="; + case INTRINSIC_GE_OS: + return ".ge."; + case INTRINSIC_GE: + return ">="; + case INTRINSIC_LE_OS: + return ".le."; + case INTRINSIC_LE: + return "<="; + case INTRINSIC_LT_OS: + return ".lt."; + case INTRINSIC_LT: + return "<"; + case INTRINSIC_GT_OS: + return ".gt."; + case INTRINSIC_GT: + return ">"; + case INTRINSIC_NOT: + return ".not."; + + case INTRINSIC_ASSIGN: + return "="; + + case INTRINSIC_PARENTHESES: + return "parens"; + + case INTRINSIC_NONE: + return "none"; + + /* DTIO */ + case INTRINSIC_FORMATTED: + return "formatted"; + case INTRINSIC_UNFORMATTED: + return "unformatted"; + + default: + break; + } + + gfc_internal_error ("gfc_op2string(): Bad code"); + /* Not reached. */ +} + + +/******************** Generic matching subroutines ************************/ + +/* Matches a member separator. With standard FORTRAN this is '%', but with + DEC structures we must carefully match dot ('.'). + Because operators are spelled ".op.", a dotted string such as "x.y.z..." + can be either a component reference chain or a combination of binary + operations. + There is no real way to win because the string may be grammatically + ambiguous. The following rules help avoid ambiguities - they match + some behavior of other (older) compilers. If the rules here are changed + the test cases should be updated. If the user has problems with these rules + they probably deserve the consequences. Consider "x.y.z": + (1) If any user defined operator ".y." exists, this is always y(x,z) + (even if ".y." is the wrong type and/or x has a member y). + (2) Otherwise if x has a member y, and y is itself a derived type, + this is (x->y)->z, even if an intrinsic operator exists which + can handle (x,z). + (3) If x has no member y or (x->y) is not a derived type but ".y." + is an intrinsic operator (such as ".eq."), this is y(x,z). + (4) Lastly if there is no operator ".y." and x has no member "y", it is an + error. + It is worth noting that the logic here does not support mixed use of member + accessors within a single string. That is, even if x has component y and y + has component z, the following are all syntax errors: + "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z" + */ + +match +gfc_match_member_sep(gfc_symbol *sym) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus dot_loc, start_loc; + gfc_intrinsic_op iop; + match m; + gfc_symbol *tsym; + gfc_component *c = NULL; + + /* What a relief: '%' is an unambiguous member separator. */ + if (gfc_match_char ('%') == MATCH_YES) + return MATCH_YES; + + /* Beware ye who enter here. */ + if (!flag_dec_structure || !sym) + return MATCH_NO; + + tsym = NULL; + + /* We may be given either a derived type variable or the derived type + declaration itself (which actually contains the components); + we need the latter to search for components. */ + if (gfc_fl_struct (sym->attr.flavor)) + tsym = sym; + else if (gfc_bt_struct (sym->ts.type)) + tsym = sym->ts.u.derived; + + iop = INTRINSIC_NONE; + name[0] = '\0'; + m = MATCH_NO; + + /* If we have to reject come back here later. */ + start_loc = gfc_current_locus; + + /* Look for a component access next. */ + if (gfc_match_char ('.') != MATCH_YES) + return MATCH_NO; + + /* If we accept, come back here. */ + dot_loc = gfc_current_locus; + + /* Try to match a symbol name following the dot. */ + if (gfc_match_name (name) != MATCH_YES) + { + gfc_error ("Expected structure component or operator name " + "after '.' at %C"); + goto error; + } + + /* If no dot follows we have "x.y" which should be a component access. */ + if (gfc_match_char ('.') != MATCH_YES) + goto yes; + + /* Now we have a string "x.y.z" which could be a nested member access + (x->y)->z or a binary operation y on x and z. */ + + /* First use any user-defined operators ".y." */ + if (gfc_find_uop (name, sym->ns) != NULL) + goto no; + + /* Match accesses to existing derived-type components for + derived-type vars: "x.y.z" = (x->y)->z */ + c = gfc_find_component(tsym, name, false, true, NULL); + if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS)) + goto yes; + + /* If y is not a component or has no members, try intrinsic operators. */ + gfc_current_locus = start_loc; + if (gfc_match_intrinsic_op (&iop) != MATCH_YES) + { + /* If ".y." is not an intrinsic operator but y was a valid non- + structure component, match and leave the trailing dot to be + dealt with later. */ + if (c) + goto yes; + + gfc_error ("%qs is neither a defined operator nor a " + "structure component in dotted string at %C", name); + goto error; + } + + /* .y. is an intrinsic operator, overriding any possible member access. */ + goto no; + + /* Return keeping the current locus consistent with the match result. */ +error: + m = MATCH_ERROR; +no: + gfc_current_locus = start_loc; + return m; +yes: + gfc_current_locus = dot_loc; + return MATCH_YES; +} + + +/* This function scans the current statement counting the opened and closed + parenthesis to make sure they are balanced. */ + +match +gfc_match_parens (void) +{ + locus old_loc, where; + int count; + gfc_instring instring; + gfc_char_t c, quote; + + old_loc = gfc_current_locus; + count = 0; + instring = NONSTRING; + quote = ' '; + + for (;;) + { + if (count > 0) + where = gfc_current_locus; + c = gfc_next_char_literal (instring); + if (c == '\n') + break; + if (quote == ' ' && ((c == '\'') || (c == '"'))) + { + quote = c; + instring = INSTRING_WARN; + continue; + } + if (quote != ' ' && c == quote) + { + quote = ' '; + instring = NONSTRING; + continue; + } + + if (c == '(' && quote == ' ') + { + count++; + } + if (c == ')' && quote == ' ') + { + count--; + where = gfc_current_locus; + } + } + + gfc_current_locus = old_loc; + + if (count != 0) + { + gfc_error ("Missing %qs in statement at or before %L", + count > 0? ")":"(", &where); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* See if the next character is a special character that has + escaped by a \ via the -fbackslash option. */ + +match +gfc_match_special_char (gfc_char_t *res) +{ + int len, i; + gfc_char_t c, n; + match m; + + m = MATCH_YES; + + switch ((c = gfc_next_char_literal (INSTRING_WARN))) + { + case 'a': + *res = '\a'; + break; + case 'b': + *res = '\b'; + break; + case 't': + *res = '\t'; + break; + case 'f': + *res = '\f'; + break; + case 'n': + *res = '\n'; + break; + case 'r': + *res = '\r'; + break; + case 'v': + *res = '\v'; + break; + case '\\': + *res = '\\'; + break; + case '0': + *res = '\0'; + break; + + case 'x': + case 'u': + case 'U': + /* Hexadecimal form of wide characters. */ + len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8)); + n = 0; + for (i = 0; i < len; i++) + { + char buf[2] = { '\0', '\0' }; + + c = gfc_next_char_literal (INSTRING_WARN); + if (!gfc_wide_fits_in_byte (c) + || !gfc_check_digit ((unsigned char) c, 16)) + return MATCH_NO; + + buf[0] = (unsigned char) c; + n = n << 4; + n += strtol (buf, NULL, 16); + } + *res = n; + break; + + default: + /* Unknown backslash codes are simply not expanded. */ + m = MATCH_NO; + break; + } + + return m; +} + + +/* In free form, match at least one space. Always matches in fixed + form. */ + +match +gfc_match_space (void) +{ + locus old_loc; + char c; + + if (gfc_current_form == FORM_FIXED) + return MATCH_YES; + + old_loc = gfc_current_locus; + + c = gfc_next_ascii_char (); + if (!gfc_is_whitespace (c)) + { + gfc_current_locus = old_loc; + return MATCH_NO; + } + + gfc_gobble_whitespace (); + + return MATCH_YES; +} + + +/* Match an end of statement. End of statement is optional + whitespace, followed by a ';' or '\n' or comment '!'. If a + semicolon is found, we continue to eat whitespace and semicolons. */ + +match +gfc_match_eos (void) +{ + locus old_loc; + int flag; + char c; + + flag = 0; + + for (;;) + { + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + c = gfc_next_ascii_char (); + switch (c) + { + case '!': + do + { + c = gfc_next_ascii_char (); + } + while (c != '\n'); + + /* Fall through. */ + + case '\n': + return MATCH_YES; + + case ';': + flag = 1; + continue; + } + + break; + } + + gfc_current_locus = old_loc; + return (flag) ? MATCH_YES : MATCH_NO; +} + + +/* Match a literal integer on the input, setting the value on + MATCH_YES. Literal ints occur in kind-parameters as well as + old-style character length specifications. If cnt is non-NULL it + will be set to the number of digits. */ + +match +gfc_match_small_literal_int (int *value, int *cnt) +{ + locus old_loc; + char c; + int i, j; + + old_loc = gfc_current_locus; + + *value = -1; + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + if (cnt) + *cnt = 0; + + if (!ISDIGIT (c)) + { + gfc_current_locus = old_loc; + return MATCH_NO; + } + + i = c - '0'; + j = 1; + + for (;;) + { + old_loc = gfc_current_locus; + c = gfc_next_ascii_char (); + + if (!ISDIGIT (c)) + break; + + i = 10 * i + c - '0'; + j++; + + if (i > 99999999) + { + gfc_error ("Integer too large at %C"); + return MATCH_ERROR; + } + } + + gfc_current_locus = old_loc; + + *value = i; + if (cnt) + *cnt = j; + return MATCH_YES; +} + + +/* Match a small, constant integer expression, like in a kind + statement. On MATCH_YES, 'value' is set. */ + +match +gfc_match_small_int (int *value) +{ + gfc_expr *expr; + match m; + int i; + + m = gfc_match_expr (&expr); + if (m != MATCH_YES) + return m; + + if (gfc_extract_int (expr, &i, 1)) + m = MATCH_ERROR; + gfc_free_expr (expr); + + *value = i; + return m; +} + + +/* Matches a statement label. Uses gfc_match_small_literal_int() to + do most of the work. */ + +match +gfc_match_st_label (gfc_st_label **label) +{ + locus old_loc; + match m; + int i, cnt; + + old_loc = gfc_current_locus; + + m = gfc_match_small_literal_int (&i, &cnt); + if (m != MATCH_YES) + return m; + + if (cnt > 5) + { + gfc_error ("Too many digits in statement label at %C"); + goto cleanup; + } + + if (i == 0) + { + gfc_error ("Statement label at %C is zero"); + goto cleanup; + } + + *label = gfc_get_st_label (i); + return MATCH_YES; + +cleanup: + + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + + +/* Match and validate a label associated with a named IF, DO or SELECT + statement. If the symbol does not have the label attribute, we add + it. We also make sure the symbol does not refer to another + (active) block. A matched label is pointed to by gfc_new_block. */ + +static match +gfc_match_label (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + gfc_new_block = NULL; + + m = gfc_match (" %n :", name); + if (m != MATCH_YES) + return m; + + if (gfc_get_symbol (name, NULL, &gfc_new_block)) + { + gfc_error ("Label name %qs at %C is ambiguous", name); + return MATCH_ERROR; + } + + if (gfc_new_block->attr.flavor == FL_LABEL) + { + gfc_error ("Duplicate construct label %qs at %C", name); + return MATCH_ERROR; + } + + if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, + gfc_new_block->name, NULL)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* See if the current input looks like a name of some sort. Modifies + the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. + Note that options.c restricts max_identifier_length to not more + than GFC_MAX_SYMBOL_LEN. */ + +match +gfc_match_name (char *buffer) +{ + locus old_loc; + int i; + char c; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + c = gfc_next_ascii_char (); + if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) + { + /* Special cases for unary minus and plus, which allows for a sensible + error message for code of the form 'c = exp(-a*b) )' where an + extra ')' appears at the end of statement. */ + if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+') + gfc_error ("Invalid character in name at %C"); + gfc_current_locus = old_loc; + return MATCH_NO; + } + + i = 0; + + do + { + buffer[i++] = c; + + if (i > gfc_option.max_identifier_length) + { + gfc_error ("Name at %C is too long"); + return MATCH_ERROR; + } + + old_loc = gfc_current_locus; + c = gfc_next_ascii_char (); + } + while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$')); + + if (c == '$' && !flag_dollar_ok) + { + gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to " + "allow it as an extension", &old_loc); + return MATCH_ERROR; + } + + buffer[i] = '\0'; + gfc_current_locus = old_loc; + + return MATCH_YES; +} + + +/* Match a symbol on the input. Modifies the pointer to the symbol + pointer if successful. */ + +match +gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) +{ + char buffer[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + m = gfc_match_name (buffer); + if (m != MATCH_YES) + return m; + + if (host_assoc) + return (gfc_get_ha_sym_tree (buffer, matched_symbol)) + ? MATCH_ERROR : MATCH_YES; + + if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +match +gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) +{ + gfc_symtree *st; + match m; + + m = gfc_match_sym_tree (&st, host_assoc); + + if (m == MATCH_YES) + { + if (st) + *matched_symbol = st->n.sym; + else + *matched_symbol = NULL; + } + else + *matched_symbol = NULL; + return m; +} + + +/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, + we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this + in matchexp.c. */ + +match +gfc_match_intrinsic_op (gfc_intrinsic_op *result) +{ + locus orig_loc = gfc_current_locus; + char ch; + + gfc_gobble_whitespace (); + ch = gfc_next_ascii_char (); + switch (ch) + { + case '+': + /* Matched "+". */ + *result = INTRINSIC_PLUS; + return MATCH_YES; + + case '-': + /* Matched "-". */ + *result = INTRINSIC_MINUS; + return MATCH_YES; + + case '=': + if (gfc_next_ascii_char () == '=') + { + /* Matched "==". */ + *result = INTRINSIC_EQ; + return MATCH_YES; + } + break; + + case '<': + if (gfc_peek_ascii_char () == '=') + { + /* Matched "<=". */ + gfc_next_ascii_char (); + *result = INTRINSIC_LE; + return MATCH_YES; + } + /* Matched "<". */ + *result = INTRINSIC_LT; + return MATCH_YES; + + case '>': + if (gfc_peek_ascii_char () == '=') + { + /* Matched ">=". */ + gfc_next_ascii_char (); + *result = INTRINSIC_GE; + return MATCH_YES; + } + /* Matched ">". */ + *result = INTRINSIC_GT; + return MATCH_YES; + + case '*': + if (gfc_peek_ascii_char () == '*') + { + /* Matched "**". */ + gfc_next_ascii_char (); + *result = INTRINSIC_POWER; + return MATCH_YES; + } + /* Matched "*". */ + *result = INTRINSIC_TIMES; + return MATCH_YES; + + case '/': + ch = gfc_peek_ascii_char (); + if (ch == '=') + { + /* Matched "/=". */ + gfc_next_ascii_char (); + *result = INTRINSIC_NE; + return MATCH_YES; + } + else if (ch == '/') + { + /* Matched "//". */ + gfc_next_ascii_char (); + *result = INTRINSIC_CONCAT; + return MATCH_YES; + } + /* Matched "/". */ + *result = INTRINSIC_DIVIDE; + return MATCH_YES; + + case '.': + ch = gfc_next_ascii_char (); + switch (ch) + { + case 'a': + if (gfc_next_ascii_char () == 'n' + && gfc_next_ascii_char () == 'd' + && gfc_next_ascii_char () == '.') + { + /* Matched ".and.". */ + *result = INTRINSIC_AND; + return MATCH_YES; + } + break; + + case 'e': + if (gfc_next_ascii_char () == 'q') + { + ch = gfc_next_ascii_char (); + if (ch == '.') + { + /* Matched ".eq.". */ + *result = INTRINSIC_EQ_OS; + return MATCH_YES; + } + else if (ch == 'v') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".eqv.". */ + *result = INTRINSIC_EQV; + return MATCH_YES; + } + } + } + break; + + case 'g': + ch = gfc_next_ascii_char (); + if (ch == 'e') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".ge.". */ + *result = INTRINSIC_GE_OS; + return MATCH_YES; + } + } + else if (ch == 't') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".gt.". */ + *result = INTRINSIC_GT_OS; + return MATCH_YES; + } + } + break; + + case 'l': + ch = gfc_next_ascii_char (); + if (ch == 'e') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".le.". */ + *result = INTRINSIC_LE_OS; + return MATCH_YES; + } + } + else if (ch == 't') + { + if (gfc_next_ascii_char () == '.') + { + /* Matched ".lt.". */ + *result = INTRINSIC_LT_OS; + return MATCH_YES; + } + } + break; + + case 'n': + ch = gfc_next_ascii_char (); + if (ch == 'e') + { + ch = gfc_next_ascii_char (); + if (ch == '.') + { + /* Matched ".ne.". */ + *result = INTRINSIC_NE_OS; + return MATCH_YES; + } + else if (ch == 'q') + { + if (gfc_next_ascii_char () == 'v' + && gfc_next_ascii_char () == '.') + { + /* Matched ".neqv.". */ + *result = INTRINSIC_NEQV; + return MATCH_YES; + } + } + } + else if (ch == 'o') + { + if (gfc_next_ascii_char () == 't' + && gfc_next_ascii_char () == '.') + { + /* Matched ".not.". */ + *result = INTRINSIC_NOT; + return MATCH_YES; + } + } + break; + + case 'o': + if (gfc_next_ascii_char () == 'r' + && gfc_next_ascii_char () == '.') + { + /* Matched ".or.". */ + *result = INTRINSIC_OR; + return MATCH_YES; + } + break; + + case 'x': + if (gfc_next_ascii_char () == 'o' + && gfc_next_ascii_char () == 'r' + && gfc_next_ascii_char () == '.') + { + if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C")) + return MATCH_ERROR; + /* Matched ".xor." - equivalent to ".neqv.". */ + *result = INTRINSIC_NEQV; + return MATCH_YES; + } + break; + + default: + break; + } + break; + + default: + break; + } + + gfc_current_locus = orig_loc; + return MATCH_NO; +} + + +/* Match a loop control phrase: + + = , [, ] + + If the final integer expression is not present, a constant unity + expression is returned. We don't return MATCH_ERROR until after + the equals sign is seen. */ + +match +gfc_match_iterator (gfc_iterator *iter, int init_flag) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *var, *e1, *e2, *e3; + locus start; + match m; + + e1 = e2 = e3 = NULL; + + /* Match the start of an iterator without affecting the symbol table. */ + + start = gfc_current_locus; + m = gfc_match (" %n =", name); + gfc_current_locus = start; + + if (m != MATCH_YES) + return MATCH_NO; + + m = gfc_match_variable (&var, 0); + if (m != MATCH_YES) + return MATCH_NO; + + if (var->symtree->n.sym->attr.dimension) + { + gfc_error ("Loop variable at %C cannot be an array"); + goto cleanup; + } + + /* F2008, C617 & C565. */ + if (var->symtree->n.sym->attr.codimension) + { + gfc_error ("Loop variable at %C cannot be a coarray"); + goto cleanup; + } + + if (var->ref != NULL) + { + gfc_error ("Loop variable at %C cannot be a sub-component"); + goto cleanup; + } + + gfc_match_char ('='); + + var->symtree->n.sym->attr.implied_index = 1; + + m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') != MATCH_YES) + { + e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + goto done; + } + + m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + gfc_error ("Expected a step value in iterator at %C"); + goto cleanup; + } + +done: + iter->var = var; + iter->start = e1; + iter->end = e2; + iter->step = e3; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in iterator at %C"); + +cleanup: + gfc_free_expr (e1); + gfc_free_expr (e2); + gfc_free_expr (e3); + + return MATCH_ERROR; +} + + +/* Tries to match the next non-whitespace character on the input. + This subroutine does not return MATCH_ERROR. */ + +match +gfc_match_char (char c) +{ + locus where; + + where = gfc_current_locus; + gfc_gobble_whitespace (); + + if (gfc_next_ascii_char () == c) + return MATCH_YES; + + gfc_current_locus = where; + return MATCH_NO; +} + + +/* General purpose matching subroutine. The target string is a + scanf-like format string in which spaces correspond to arbitrary + whitespace (including no whitespace), characters correspond to + themselves. The %-codes are: + + %% Literal percent sign + %e Expression, pointer to a pointer is set + %s Symbol, pointer to the symbol is set + %n Name, character buffer is set to name + %t Matches end of statement. + %o Matches an intrinsic operator, returned as an INTRINSIC enum. + %l Matches a statement label + %v Matches a variable expression (an lvalue, except function references + having a data pointer result) + % Matches a required space (in free form) and optional spaces. */ + +match +gfc_match (const char *target, ...) +{ + gfc_st_label **label; + int matches, *ip; + locus old_loc; + va_list argp; + char c, *np; + match m, n; + void **vp; + const char *p; + + old_loc = gfc_current_locus; + va_start (argp, target); + m = MATCH_NO; + matches = 0; + p = target; + +loop: + c = *p++; + switch (c) + { + case ' ': + gfc_gobble_whitespace (); + goto loop; + case '\0': + m = MATCH_YES; + break; + + case '%': + c = *p++; + switch (c) + { + case 'e': + vp = va_arg (argp, void **); + n = gfc_match_expr ((gfc_expr **) vp); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'v': + vp = va_arg (argp, void **); + n = gfc_match_variable ((gfc_expr **) vp, 0); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 's': + vp = va_arg (argp, void **); + n = gfc_match_symbol ((gfc_symbol **) vp, 0); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'n': + np = va_arg (argp, char *); + n = gfc_match_name (np); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'l': + label = va_arg (argp, gfc_st_label **); + n = gfc_match_st_label (label); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'o': + ip = va_arg (argp, int *); + n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 't': + if (gfc_match_eos () != MATCH_YES) + { + m = MATCH_NO; + goto not_yes; + } + goto loop; + + case ' ': + if (gfc_match_space () == MATCH_YES) + goto loop; + m = MATCH_NO; + goto not_yes; + + case '%': + break; /* Fall through to character matcher. */ + + default: + gfc_internal_error ("gfc_match(): Bad match code %c", c); + } + /* FALLTHRU */ + + default: + + /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't + expect an upper case character here! */ + gcc_assert (TOLOWER (c) == c); + + if (c == gfc_next_ascii_char ()) + goto loop; + break; + } + +not_yes: + va_end (argp); + + if (m != MATCH_YES) + { + /* Clean up after a failed match. */ + gfc_current_locus = old_loc; + va_start (argp, target); + + p = target; + for (; matches > 0; matches--) + { + while (*p++ != '%'); + + switch (*p++) + { + case '%': + matches++; + break; /* Skip. */ + + /* Matches that don't have to be undone */ + case 'o': + case 'l': + case 'n': + case 's': + (void) va_arg (argp, void **); + break; + + case 'e': + case 'v': + vp = va_arg (argp, void **); + gfc_free_expr ((struct gfc_expr *)*vp); + *vp = NULL; + break; + } + } + + va_end (argp); + } + + return m; +} + + +/*********************** Statement level matching **********************/ + +/* Matches the start of a program unit, which is the program keyword + followed by an obligatory symbol. */ + +match +gfc_match_program (void) +{ + gfc_symbol *sym; + match m; + + m = gfc_match ("% %s%t", &sym); + + if (m == MATCH_NO) + { + gfc_error ("Invalid form of PROGRAM statement at %C"); + m = MATCH_ERROR; + } + + if (m == MATCH_ERROR) + return m; + + if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL)) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Match a simple assignment statement. */ + +match +gfc_match_assignment (void) +{ + gfc_expr *lvalue, *rvalue; + locus old_loc; + match m; + + old_loc = gfc_current_locus; + + lvalue = NULL; + m = gfc_match (" %v =", &lvalue); + if (m != MATCH_YES) + { + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + return MATCH_NO; + } + + rvalue = NULL; + m = gfc_match (" %e%t", &rvalue); + + if (m == MATCH_YES + && rvalue->ts.type == BT_BOZ + && lvalue->ts.type == BT_CLASS) + { + m = MATCH_ERROR; + gfc_error ("BOZ literal constant at %L is neither a DATA statement " + "value nor an actual argument of INT/REAL/DBLE/CMPLX " + "intrinsic subprogram", &rvalue->where); + } + + if (lvalue->expr_type == EXPR_CONSTANT) + { + /* This clobbers %len and %kind. */ + m = MATCH_ERROR; + gfc_error ("Assignment to a constant expression at %C"); + } + + if (m != MATCH_YES) + { + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return m; + } + + if (!lvalue->symtree) + { + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return MATCH_ERROR; + } + + + gfc_set_sym_referenced (lvalue->symtree->n.sym); + + new_st.op = EXEC_ASSIGN; + new_st.expr1 = lvalue; + new_st.expr2 = rvalue; + + gfc_check_do_variable (lvalue->symtree); + + return MATCH_YES; +} + + +/* Match a pointer assignment statement. */ + +match +gfc_match_pointer_assignment (void) +{ + gfc_expr *lvalue, *rvalue; + locus old_loc; + match m; + + old_loc = gfc_current_locus; + + lvalue = rvalue = NULL; + gfc_matching_ptr_assignment = 0; + gfc_matching_procptr_assignment = 0; + + m = gfc_match (" %v =>", &lvalue); + if (m != MATCH_YES || !lvalue->symtree) + { + m = MATCH_NO; + goto cleanup; + } + + if (lvalue->symtree->n.sym->attr.proc_pointer + || gfc_is_proc_ptr_comp (lvalue)) + gfc_matching_procptr_assignment = 1; + else + gfc_matching_ptr_assignment = 1; + + m = gfc_match (" %e%t", &rvalue); + gfc_matching_ptr_assignment = 0; + gfc_matching_procptr_assignment = 0; + if (m != MATCH_YES) + goto cleanup; + + new_st.op = EXEC_POINTER_ASSIGN; + new_st.expr1 = lvalue; + new_st.expr2 = rvalue; + + return MATCH_YES; + +cleanup: + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return m; +} + + +/* We try to match an easy arithmetic IF statement. This only happens + when just after having encountered a simple IF statement. This code + is really duplicate with parts of the gfc_match_if code, but this is + *much* easier. */ + +static match +match_arithmetic_if (void) +{ + gfc_st_label *l1, *l2, *l3; + gfc_expr *expr; + match m; + + m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3); + if (m != MATCH_YES) + return m; + + if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) + || !gfc_reference_st_label (l2, ST_LABEL_TARGET) + || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, + "Arithmetic IF statement at %C")) + return MATCH_ERROR; + + new_st.op = EXEC_ARITHMETIC_IF; + new_st.expr1 = expr; + new_st.label1 = l1; + new_st.label2 = l2; + new_st.label3 = l3; + + return MATCH_YES; +} + + +/* The IF statement is a bit of a pain. First of all, there are three + forms of it, the simple IF, the IF that starts a block and the + arithmetic IF. + + There is a problem with the simple IF and that is the fact that we + only have a single level of undo information on symbols. What this + means is for a simple IF, we must re-match the whole IF statement + multiple times in order to guarantee that the symbol table ends up + in the proper state. */ + +static match match_simple_forall (void); +static match match_simple_where (void); + +match +gfc_match_if (gfc_statement *if_type) +{ + gfc_expr *expr; + gfc_st_label *l1, *l2, *l3; + locus old_loc, old_loc2; + gfc_code *p; + match m, n; + + n = gfc_match_label (); + if (n == MATCH_ERROR) + return n; + + old_loc = gfc_current_locus; + + m = gfc_match (" if ", &expr); + if (m != MATCH_YES) + return m; + + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Missing %<(%> in IF-expression at %C"); + return MATCH_ERROR; + } + + m = gfc_match ("%e", &expr); + if (m != MATCH_YES) + return m; + + old_loc2 = gfc_current_locus; + gfc_current_locus = old_loc; + + if (gfc_match_parens () == MATCH_ERROR) + return MATCH_ERROR; + + gfc_current_locus = old_loc2; + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Syntax error in IF-expression at %C"); + gfc_free_expr (expr); + return MATCH_ERROR; + } + + m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3); + + if (m == MATCH_YES) + { + if (n == MATCH_YES) + { + gfc_error ("Block label not appropriate for arithmetic IF " + "statement at %C"); + gfc_free_expr (expr); + return MATCH_ERROR; + } + + if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) + || !gfc_reference_st_label (l2, ST_LABEL_TARGET) + || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, + "Arithmetic IF statement at %C")) + return MATCH_ERROR; + + new_st.op = EXEC_ARITHMETIC_IF; + new_st.expr1 = expr; + new_st.label1 = l1; + new_st.label2 = l2; + new_st.label3 = l3; + + *if_type = ST_ARITHMETIC_IF; + return MATCH_YES; + } + + if (gfc_match (" then%t") == MATCH_YES) + { + new_st.op = EXEC_IF; + new_st.expr1 = expr; + *if_type = ST_IF_BLOCK; + return MATCH_YES; + } + + if (n == MATCH_YES) + { + gfc_error ("Block label is not appropriate for IF statement at %C"); + gfc_free_expr (expr); + return MATCH_ERROR; + } + + /* At this point the only thing left is a simple IF statement. At + this point, n has to be MATCH_NO, so we don't have to worry about + re-matching a block label. From what we've got so far, try + matching an assignment. */ + + *if_type = ST_SIMPLE_IF; + + m = gfc_match_assignment (); + if (m == MATCH_YES) + goto got_match; + + gfc_free_expr (expr); + gfc_undo_symbols (); + gfc_current_locus = old_loc; + + /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled + assignment was found. For MATCH_NO, continue to call the various + matchers. */ + if (m == MATCH_ERROR) + return MATCH_ERROR; + + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ + + m = gfc_match_pointer_assignment (); + if (m == MATCH_YES) + goto got_match; + + gfc_free_expr (expr); + gfc_undo_symbols (); + gfc_current_locus = old_loc; + + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ + + /* Look at the next keyword to see which matcher to call. Matching + the keyword doesn't affect the symbol table, so we don't have to + restore between tries. */ + +#define match(string, subr, statement) \ + if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; } + + gfc_clear_error (); + + match ("allocate", gfc_match_allocate, ST_ALLOCATE) + match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) + match ("backspace", gfc_match_backspace, ST_BACKSPACE) + match ("call", gfc_match_call, ST_CALL) + match ("change team", gfc_match_change_team, ST_CHANGE_TEAM) + match ("close", gfc_match_close, ST_CLOSE) + match ("continue", gfc_match_continue, ST_CONTINUE) + match ("cycle", gfc_match_cycle, ST_CYCLE) + match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) + match ("end file", gfc_match_endfile, ST_END_FILE) + match ("end team", gfc_match_end_team, ST_END_TEAM) + match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) + match ("event post", gfc_match_event_post, ST_EVENT_POST) + match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) + match ("exit", gfc_match_exit, ST_EXIT) + match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE) + match ("flush", gfc_match_flush, ST_FLUSH) + match ("forall", match_simple_forall, ST_FORALL) + match ("form team", gfc_match_form_team, ST_FORM_TEAM) + match ("go to", gfc_match_goto, ST_GOTO) + match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) + match ("inquire", gfc_match_inquire, ST_INQUIRE) + match ("lock", gfc_match_lock, ST_LOCK) + match ("nullify", gfc_match_nullify, ST_NULLIFY) + match ("open", gfc_match_open, ST_OPEN) + match ("pause", gfc_match_pause, ST_NONE) + match ("print", gfc_match_print, ST_WRITE) + match ("read", gfc_match_read, ST_READ) + match ("return", gfc_match_return, ST_RETURN) + match ("rewind", gfc_match_rewind, ST_REWIND) + match ("stop", gfc_match_stop, ST_STOP) + match ("wait", gfc_match_wait, ST_WAIT) + match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); + match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); + match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM) + match ("unlock", gfc_match_unlock, ST_UNLOCK) + match ("where", match_simple_where, ST_WHERE) + match ("write", gfc_match_write, ST_WRITE) + + if (flag_dec) + match ("type", gfc_match_print, ST_WRITE) + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. */ + if (!gfc_error_check ()) + gfc_error ("Syntax error in IF-clause after %C"); + + gfc_free_expr (expr); + return MATCH_ERROR; + +got_match: + if (m == MATCH_NO) + gfc_error ("Syntax error in IF-clause after %C"); + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + /* At this point, we've matched the single IF and the action clause + is in new_st. Rearrange things so that the IF statement appears + in new_st. */ + + p = gfc_get_code (EXEC_IF); + p->next = XCNEW (gfc_code); + *p->next = new_st; + p->next->loc = gfc_current_locus; + + p->expr1 = expr; + + gfc_clear_new_st (); + + new_st.op = EXEC_IF; + new_st.block = p; + + return MATCH_YES; +} + +#undef match + + +/* Match an ELSE statement. */ + +match +gfc_match_else (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + if (gfc_match_name (name) != MATCH_YES + || gfc_current_block () == NULL + || gfc_match_eos () != MATCH_YES) + { + gfc_error ("Invalid character(s) in ELSE statement after %C"); + return MATCH_ERROR; + } + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Label %qs at %C doesn't match IF label %qs", + name, gfc_current_block ()->name); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Match an ELSE IF statement. */ + +match +gfc_match_elseif (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *expr, *then; + locus where; + match m; + + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Missing %<(%> in ELSE IF expression at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" %e ", &expr); + if (m != MATCH_YES) + return m; + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Missing %<)%> in ELSE IF expression at %C"); + goto cleanup; + } + + m = gfc_match (" then ", &then); + + where = gfc_current_locus; + + if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES + || (gfc_current_block () + && gfc_match_name (name) == MATCH_YES))) + goto done; + + if (gfc_match_eos () == MATCH_YES) + { + gfc_error ("Missing THEN in ELSE IF statement after %L", &where); + goto cleanup; + } + + if (gfc_match_name (name) != MATCH_YES + || gfc_current_block () == NULL + || gfc_match_eos () != MATCH_YES) + { + gfc_error ("Syntax error in ELSE IF statement after %L", &where); + goto cleanup; + } + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Label %qs after %L doesn't match IF label %qs", + name, &where, gfc_current_block ()->name); + goto cleanup; + } + + if (m != MATCH_YES) + return m; + +done: + new_st.op = EXEC_IF; + new_st.expr1 = expr; + return MATCH_YES; + +cleanup: + gfc_free_expr (expr); + return MATCH_ERROR; +} + + +/* Free a gfc_iterator structure. */ + +void +gfc_free_iterator (gfc_iterator *iter, int flag) +{ + + if (iter == NULL) + return; + + gfc_free_expr (iter->var); + gfc_free_expr (iter->start); + gfc_free_expr (iter->end); + gfc_free_expr (iter->step); + + if (flag) + free (iter); +} + + +/* Match a CRITICAL statement. */ +match +gfc_match_critical (void) +{ + gfc_st_label *label = NULL; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" critical") != MATCH_YES) + return MATCH_NO; + + if (gfc_match_st_label (&label) == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_CRITICAL); + return MATCH_ERROR; + } + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT " + "block"); + return MATCH_ERROR; + } + + gfc_unset_implicit_pure (NULL); + + if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")) + return MATCH_ERROR; + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " + "enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("Nested CRITICAL block at %C"); + return MATCH_ERROR; + } + + new_st.op = EXEC_CRITICAL; + + if (label != NULL + && !gfc_reference_st_label (label, ST_LABEL_TARGET)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Match a BLOCK statement. */ + +match +gfc_match_block (void) +{ + match m; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" block") != MATCH_YES) + return MATCH_NO; + + /* For this to be a correct BLOCK statement, the line must end now. */ + m = gfc_match_eos (); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + return MATCH_NO; + + return MATCH_YES; +} + + +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + new_st.ext.block.assoc = NULL; + while (true) + { + gfc_association_list* newAssoc = gfc_get_association_list (); + gfc_association_list* a; + + /* Match the next association. */ + if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES) + { + gfc_error ("Expected association at %C"); + goto assocListError; + } + + if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + { + /* Have another go, allowing for procedure pointer selectors. */ + gfc_matching_procptr_assignment = 1; + if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + { + gfc_error ("Invalid association target at %C"); + goto assocListError; + } + gfc_matching_procptr_assignment = 0; + } + newAssoc->where = gfc_current_locus; + + /* Check that the current name is not yet in the list. */ + for (a = new_st.ext.block.assoc; a; a = a->next) + if (!strcmp (a->name, newAssoc->name)) + { + gfc_error ("Duplicate name %qs in association at %C", + newAssoc->name); + goto assocListError; + } + + /* The target expression must not be coindexed. */ + if (gfc_is_coindexed (newAssoc->target)) + { + gfc_error ("Association target at %C must not be coindexed"); + goto assocListError; + } + + /* The target expression cannot be a BOZ literal constant. */ + if (newAssoc->target->ts.type == BT_BOZ) + { + gfc_error ("Association target at %L cannot be a BOZ literal " + "constant", &newAssoc->target->where); + goto assocListError; + } + + /* The `variable' field is left blank for now; because the target is not + yet resolved, we can't use gfc_has_vector_subscript to determine it + for now. This is set during resolution. */ + + /* Put it into the list. */ + newAssoc->next = new_st.ext.block.assoc; + new_st.ext.block.assoc = newAssoc; + + /* Try next one or end if closing parenthesis is found. */ + gfc_gobble_whitespace (); + if (gfc_peek_char () == ')') + break; + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected %<)%> or %<,%> at %C"); + return MATCH_ERROR; + } + + continue; + +assocListError: + free (newAssoc); + goto error; + } + if (gfc_match_char (')') != MATCH_YES) + { + /* This should never happen as we peek above. */ + gcc_unreachable (); + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after ASSOCIATE statement at %C"); + goto error; + } + + return MATCH_YES; + +error: + gfc_free_association_list (new_st.ext.block.assoc); + return MATCH_ERROR; +} + + +/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of + an accessible derived type. */ + +static match +match_derived_type_spec (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + gfc_symbol *derived, *der_type; + match m = MATCH_YES; + gfc_actual_arglist *decl_type_param_list = NULL; + bool is_pdt_template = false; + + old_locus = gfc_current_locus; + + if (gfc_match ("%n", name) != MATCH_YES) + { + gfc_current_locus = old_locus; + return MATCH_NO; + } + + gfc_find_symbol (name, NULL, 1, &derived); + + /* Match the PDT spec list, if there. */ + if (derived && derived->attr.flavor == FL_PROCEDURE) + { + gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type); + is_pdt_template = der_type + && der_type->attr.flavor == FL_DERIVED + && der_type->attr.pdt_template; + } + + if (is_pdt_template) + m = gfc_match_actual_arglist (1, &decl_type_param_list, true); + + if (m == MATCH_ERROR) + { + gfc_free_actual_arglist (decl_type_param_list); + return m; + } + + if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic) + derived = gfc_find_dt_in_generic (derived); + + /* If this is a PDT, find the specific instance. */ + if (m == MATCH_YES && is_pdt_template) + { + gfc_namespace *old_ns; + + old_ns = gfc_current_ns; + while (gfc_current_ns && gfc_current_ns->parent) + gfc_current_ns = gfc_current_ns->parent; + + if (type_param_spec_list) + gfc_free_actual_arglist (type_param_spec_list); + m = gfc_get_pdt_instance (decl_type_param_list, &der_type, + &type_param_spec_list); + gfc_free_actual_arglist (decl_type_param_list); + + if (m != MATCH_YES) + return m; + derived = der_type; + gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type); + gfc_set_sym_referenced (derived); + + gfc_current_ns = old_ns; + } + + if (derived && derived->attr.flavor == FL_DERIVED) + { + ts->type = BT_DERIVED; + ts->u.derived = derived; + return MATCH_YES; + } + + gfc_current_locus = old_locus; + return MATCH_NO; +} + + +/* Match a Fortran 2003 type-spec (F03:R401). This is similar to + gfc_match_decl_type_spec() from decl.c, with the following exceptions: + It only includes the intrinsic types from the Fortran 2003 standard + (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, + the implicit_flag is not needed, so it was removed. Derived types are + identified by their name alone. */ + +match +gfc_match_type_spec (gfc_typespec *ts) +{ + match m; + locus old_locus; + char c, name[GFC_MAX_SYMBOL_LEN + 1]; + + gfc_clear_ts (ts); + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + + /* If c isn't [a-z], then return immediately. */ + c = gfc_peek_ascii_char (); + if (!ISALPHA(c)) + return MATCH_NO; + + type_param_spec_list = NULL; + + if (match_derived_type_spec (ts) == MATCH_YES) + { + /* Enforce F03:C401. */ + if (ts->u.derived->attr.abstract) + { + gfc_error ("Derived type %qs at %L may not be ABSTRACT", + ts->u.derived->name, &old_locus); + return MATCH_ERROR; + } + return MATCH_YES; + } + + if (gfc_match ("integer") == MATCH_YES) + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + goto kind_selector; + } + + if (gfc_match ("double precision") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_double_kind; + return MATCH_YES; + } + + if (gfc_match ("complex") == MATCH_YES) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_complex_kind; + goto kind_selector; + } + + if (gfc_match ("character") == MATCH_YES) + { + ts->type = BT_CHARACTER; + + m = gfc_match_char_spec (ts); + + if (m == MATCH_NO) + m = MATCH_YES; + + return m; + } + + /* REAL is a real pain because it can be a type, intrinsic subprogram, + or list item in a type-list of an OpenMP reduction clause. Need to + differentiate REAL([KIND]=scalar-int-initialization-expr) from + REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was + written the use of LOGICAL as a type-spec or intrinsic subprogram + was overlooked. */ + + m = gfc_match (" %n", name); + if (m == MATCH_YES + && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0)) + { + char c; + gfc_expr *e; + locus where; + + if (*name == 'r') + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + } + else + { + ts->type = BT_LOGICAL; + ts->kind = gfc_default_logical_kind; + } + + gfc_gobble_whitespace (); + + /* Prevent REAL*4, etc. */ + c = gfc_peek_ascii_char (); + if (c == '*') + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + /* Found leading colon in REAL::, a trailing ')' in for example + TYPE IS (REAL), or REAL, for an OpenMP list-item. */ + if (c == ':' || c == ')' || (flag_openmp && c == ',')) + return MATCH_YES; + + /* Found something other than the opening '(' in REAL(... */ + if (c != '(') + return MATCH_NO; + else + gfc_next_char (); /* Burn the '('. */ + + /* Look for the optional KIND=. */ + where = gfc_current_locus; + m = gfc_match ("%n", name); + if (m == MATCH_YES) + { + gfc_gobble_whitespace (); + c = gfc_next_char (); + if (c == '=') + { + if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0) + return MATCH_NO; + else if (strcmp(name, "kind") == 0) + goto found; + else + return MATCH_ERROR; + } + else + gfc_current_locus = where; + } + else + gfc_current_locus = where; + +found: + + m = gfc_match_expr (&e); + if (m == MATCH_NO || m == MATCH_ERROR) + return m; + + /* If a comma appears, it is an intrinsic subprogram. */ + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c == ',') + { + gfc_free_expr (e); + return MATCH_NO; + } + + /* If ')' appears, we have REAL(initialization-expr), here check for + a scalar integer initialization-expr and valid kind parameter. */ + if (c == ')') + { + bool ok = true; + if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE) + ok = gfc_reduce_init_expr (e); + if (!ok || e->ts.type != BT_INTEGER || e->rank > 0) + { + gfc_free_expr (e); + return MATCH_NO; + } + + if (e->expr_type != EXPR_CONSTANT) + goto ohno; + + gfc_next_char (); /* Burn the ')'. */ + ts->kind = (int) mpz_get_si (e->value.integer); + if (gfc_validate_kind (ts->type, ts->kind , true) == -1) + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + gfc_free_expr (e); + + return MATCH_YES; + } + } + +ohno: + + /* If a type is not matched, simply return MATCH_NO. */ + gfc_current_locus = old_locus; + return MATCH_NO; + +kind_selector: + + gfc_gobble_whitespace (); + + /* This prevents INTEGER*4, etc. */ + if (gfc_peek_ascii_char () == '*') + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + m = gfc_match_kind_spec (ts, false); + + /* No kind specifier found. */ + if (m == MATCH_NO) + m = MATCH_YES; + + return m; +} + + +/******************** FORALL subroutines ********************/ + +/* Free a list of FORALL iterators. */ + +void +gfc_free_forall_iterator (gfc_forall_iterator *iter) +{ + gfc_forall_iterator *next; + + while (iter) + { + next = iter->next; + gfc_free_expr (iter->var); + gfc_free_expr (iter->start); + gfc_free_expr (iter->end); + gfc_free_expr (iter->stride); + free (iter); + iter = next; + } +} + + +/* Match an iterator as part of a FORALL statement. The format is: + + = :[:] + + On MATCH_NO, the caller tests for the possibility that there is a + scalar mask expression. */ + +static match +match_forall_iterator (gfc_forall_iterator **result) +{ + gfc_forall_iterator *iter; + locus where; + match m; + + where = gfc_current_locus; + iter = XCNEW (gfc_forall_iterator); + + m = gfc_match_expr (&iter->var); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char ('=') != MATCH_YES + || iter->var->expr_type != EXPR_VARIABLE) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match_expr (&iter->start); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char (':') != MATCH_YES) + goto syntax; + + m = gfc_match_expr (&iter->end); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (':') == MATCH_NO) + iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + else + { + m = gfc_match_expr (&iter->stride); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + /* Mark the iteration variable's symbol as used as a FORALL index. */ + iter->var->symtree->n.sym->forall_index = true; + + *result = iter; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in FORALL iterator at %C"); + m = MATCH_ERROR; + +cleanup: + + gfc_current_locus = where; + gfc_free_forall_iterator (iter); + return m; +} + + +/* Match the header of a FORALL statement. */ + +static match +match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) +{ + gfc_forall_iterator *head, *tail, *new_iter; + gfc_expr *msk; + match m; + + gfc_gobble_whitespace (); + + head = tail = NULL; + msk = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; + + m = match_forall_iterator (&new_iter); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + head = tail = new_iter; + + for (;;) + { + if (gfc_match_char (',') != MATCH_YES) + break; + + m = match_forall_iterator (&new_iter); + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_YES) + { + tail->next = new_iter; + tail = new_iter; + continue; + } + + /* Have to have a mask expression. */ + + m = gfc_match_expr (&msk); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + break; + } + + if (gfc_match_char (')') == MATCH_NO) + goto syntax; + + *phead = head; + *mask = msk; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORALL); + +cleanup: + gfc_free_expr (msk); + gfc_free_forall_iterator (head); + + return MATCH_ERROR; +} + +/* Match the rest of a simple FORALL statement that follows an + IF statement. */ + +static match +match_simple_forall (void) +{ + gfc_forall_iterator *head; + gfc_expr *mask; + gfc_code *c; + match m; + + mask = NULL; + head = NULL; + c = NULL; + + m = match_forall_header (&head, &mask); + + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + goto cleanup; + + m = gfc_match_assignment (); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_pointer_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + c = XCNEW (gfc_code); + *c = new_st; + c->loc = gfc_current_locus; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + gfc_clear_new_st (); + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (EXEC_FORALL); + new_st.block->next = c; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORALL); + +cleanup: + gfc_free_forall_iterator (head); + gfc_free_expr (mask); + + return MATCH_ERROR; +} + + +/* Match a FORALL statement. */ + +match +gfc_match_forall (gfc_statement *st) +{ + gfc_forall_iterator *head; + gfc_expr *mask; + gfc_code *c; + match m0, m; + + head = NULL; + mask = NULL; + c = NULL; + + m0 = gfc_match_label (); + if (m0 == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match (" forall"); + if (m != MATCH_YES) + return m; + + m = match_forall_header (&head, &mask); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_FORALL_BLOCK; + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + return MATCH_YES; + } + + m = gfc_match_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_pointer_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + c = XCNEW (gfc_code); + *c = new_st; + c->loc = gfc_current_locus; + + gfc_clear_new_st (); + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (EXEC_FORALL); + new_st.block->next = c; + + *st = ST_FORALL; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORALL); + +cleanup: + gfc_free_forall_iterator (head); + gfc_free_expr (mask); + gfc_free_statements (c); + return MATCH_NO; +} + + +/* Match a DO statement. */ + +match +gfc_match_do (void) +{ + gfc_iterator iter, *ip; + locus old_loc; + gfc_st_label *label; + match m; + + old_loc = gfc_current_locus; + + memset (&iter, '\0', sizeof (gfc_iterator)); + label = NULL; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + if (gfc_match (" do") != MATCH_YES) + return MATCH_NO; + + m = gfc_match_st_label (&label); + if (m == MATCH_ERROR) + goto cleanup; + + /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ + + if (gfc_match_eos () == MATCH_YES) + { + iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); + new_st.op = EXEC_DO_WHILE; + goto done; + } + + /* Match an optional comma, if no comma is found, a space is obligatory. */ + if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) + return MATCH_NO; + + /* Check for balanced parens. */ + + if (gfc_match_parens () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" concurrent") == MATCH_YES) + { + gfc_forall_iterator *head; + gfc_expr *mask; + + if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C")) + return MATCH_ERROR; + + + mask = NULL; + head = NULL; + m = match_forall_header (&head, &mask); + + if (m == MATCH_NO) + return m; + if (m == MATCH_ERROR) + goto concurr_cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto concurr_cleanup; + + if (label != NULL + && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) + goto concurr_cleanup; + + new_st.label1 = label; + new_st.op = EXEC_DO_CONCURRENT; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + + return MATCH_YES; + +concurr_cleanup: + gfc_syntax_error (ST_DO); + gfc_free_expr (mask); + gfc_free_forall_iterator (head); + return MATCH_ERROR; + } + + /* See if we have a DO WHILE. */ + if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) + { + new_st.op = EXEC_DO_WHILE; + goto done; + } + + /* The abortive DO WHILE may have done something to the symbol + table, so we start over. */ + gfc_undo_symbols (); + gfc_current_locus = old_loc; + + gfc_match_label (); /* This won't error. */ + gfc_match (" do "); /* This will work. */ + + gfc_match_st_label (&label); /* Can't error out. */ + gfc_match_char (','); /* Optional comma. */ + + m = gfc_match_iterator (&iter, 0); + if (m == MATCH_NO) + return MATCH_NO; + if (m == MATCH_ERROR) + goto cleanup; + + iter.var->symtree->n.sym->attr.implied_index = 0; + gfc_check_do_variable (iter.var->symtree); + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_DO); + goto cleanup; + } + + new_st.op = EXEC_DO; + +done: + if (label != NULL + && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) + goto cleanup; + + new_st.label1 = label; + + if (new_st.op == EXEC_DO_WHILE) + new_st.expr1 = iter.end; + else + { + new_st.ext.iterator = ip = gfc_get_iterator (); + *ip = iter; + } + + return MATCH_YES; + +cleanup: + gfc_free_iterator (&iter, 0); + + return MATCH_ERROR; +} + + +/* Match an EXIT or CYCLE statement. */ + +static match +match_exit_cycle (gfc_statement st, gfc_exec_op op) +{ + gfc_state_data *p, *o; + gfc_symbol *sym; + match m; + int cnt; + + if (gfc_match_eos () == MATCH_YES) + sym = NULL; + else + { + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree* stree; + + m = gfc_match ("% %n%t", name); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + { + gfc_syntax_error (st); + return MATCH_ERROR; + } + + /* Find the corresponding symbol. If there's a BLOCK statement + between here and the label, it is not in gfc_current_ns but a parent + namespace! */ + stree = gfc_find_symtree_in_proc (name, gfc_current_ns); + if (!stree) + { + gfc_error ("Name %qs in %s statement at %C is unknown", + name, gfc_ascii_statement (st)); + return MATCH_ERROR; + } + + sym = stree->n.sym; + if (sym->attr.flavor != FL_LABEL) + { + gfc_error ("Name %qs in %s statement at %C is not a construct name", + name, gfc_ascii_statement (st)); + return MATCH_ERROR; + } + } + + /* Find the loop specified by the label (or lack of a label). */ + for (o = NULL, p = gfc_state_stack; p; p = p->previous) + if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) + o = p; + else if (p->state == COMP_CRITICAL) + { + gfc_error("%s statement at %C leaves CRITICAL construct", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if (p->state == COMP_DO_CONCURRENT + && (op == EXEC_EXIT || (sym && sym != p->sym))) + { + /* F2008, C821 & C845. */ + gfc_error("%s statement at %C leaves DO CONCURRENT construct", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if ((sym && sym == p->sym) + || (!sym && (p->state == COMP_DO + || p->state == COMP_DO_CONCURRENT))) + break; + + if (p == NULL) + { + if (sym == NULL) + gfc_error ("%s statement at %C is not within a construct", + gfc_ascii_statement (st)); + else + gfc_error ("%s statement at %C is not within construct %qs", + gfc_ascii_statement (st), sym->name); + + return MATCH_ERROR; + } + + /* Special checks for EXIT from non-loop constructs. */ + switch (p->state) + { + case COMP_DO: + case COMP_DO_CONCURRENT: + break; + + case COMP_CRITICAL: + /* This is already handled above. */ + gcc_unreachable (); + + case COMP_ASSOCIATE: + case COMP_BLOCK: + case COMP_IF: + case COMP_SELECT: + case COMP_SELECT_TYPE: + case COMP_SELECT_RANK: + gcc_assert (sym); + if (op == EXEC_CYCLE) + { + gfc_error ("CYCLE statement at %C is not applicable to non-loop" + " construct %qs", sym->name); + return MATCH_ERROR; + } + gcc_assert (op == EXEC_EXIT); + if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no" + " do-construct-name at %C")) + return MATCH_ERROR; + break; + + default: + gfc_error ("%s statement at %C is not applicable to construct %qs", + gfc_ascii_statement (st), sym->name); + return MATCH_ERROR; + } + + if (o != NULL) + { + gfc_error (is_oacc (p) + ? G_("%s statement at %C leaving OpenACC structured block") + : G_("%s statement at %C leaving OpenMP structured block"), + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + + for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) + o = o->previous; + if (cnt > 0 + && o != NULL + && o->state == COMP_OMP_STRUCTURED_BLOCK + && (o->head->op == EXEC_OACC_LOOP + || o->head->op == EXEC_OACC_KERNELS_LOOP + || o->head->op == EXEC_OACC_PARALLEL_LOOP + || o->head->op == EXEC_OACC_SERIAL_LOOP)) + { + int collapse = 1; + gcc_assert (o->head->next != NULL + && (o->head->next->op == EXEC_DO + || o->head->next->op == EXEC_DO_WHILE) + && o->previous != NULL + && o->previous->tail->op == o->head->op); + if (o->previous->tail->ext.omp_clauses != NULL) + { + /* Both collapsed and tiled loops are lowered the same way, but are not + compatible. In gfc_trans_omp_do, the tile is prioritized. */ + if (o->previous->tail->ext.omp_clauses->tile_list) + { + collapse = 0; + gfc_expr_list *el = o->previous->tail->ext.omp_clauses->tile_list; + for ( ; el; el = el->next) + ++collapse; + } + else if (o->previous->tail->ext.omp_clauses->collapse > 1) + collapse = o->previous->tail->ext.omp_clauses->collapse; + } + if (st == ST_EXIT && cnt <= collapse) + { + gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop"); + return MATCH_ERROR; + } + if (st == ST_CYCLE && cnt < collapse) + { + gfc_error (o->previous->tail->ext.omp_clauses->tile_list + ? G_("CYCLE statement at %C to non-innermost tiled" + " !$ACC LOOP loop") + : G_("CYCLE statement at %C to non-innermost collapsed" + " !$ACC LOOP loop")); + return MATCH_ERROR; + } + } + if (cnt > 0 + && o != NULL + && (o->state == COMP_OMP_STRUCTURED_BLOCK) + && (o->head->op == EXEC_OMP_DO + || o->head->op == EXEC_OMP_PARALLEL_DO + || o->head->op == EXEC_OMP_SIMD + || o->head->op == EXEC_OMP_DO_SIMD + || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD)) + { + int count = 1; + gcc_assert (o->head->next != NULL + && (o->head->next->op == EXEC_DO + || o->head->next->op == EXEC_DO_WHILE) + && o->previous != NULL + && o->previous->tail->op == o->head->op); + if (o->previous->tail->ext.omp_clauses != NULL) + { + if (o->previous->tail->ext.omp_clauses->collapse > 1) + count = o->previous->tail->ext.omp_clauses->collapse; + if (o->previous->tail->ext.omp_clauses->orderedc) + count = o->previous->tail->ext.omp_clauses->orderedc; + } + if (st == ST_EXIT && cnt <= count) + { + gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); + return MATCH_ERROR; + } + if (st == ST_CYCLE && cnt < count) + { + gfc_error ("CYCLE statement at %C to non-innermost collapsed" + " !$OMP DO loop"); + return MATCH_ERROR; + } + } + + /* Save the first statement in the construct - needed by the backend. */ + new_st.ext.which_construct = p->construct; + + new_st.op = op; + + return MATCH_YES; +} + + +/* Match the EXIT statement. */ + +match +gfc_match_exit (void) +{ + return match_exit_cycle (ST_EXIT, EXEC_EXIT); +} + + +/* Match the CYCLE statement. */ + +match +gfc_match_cycle (void) +{ + return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); +} + + +/* Match a stop-code after an (ERROR) STOP or PAUSE statement. The + requirements for a stop-code differ in the standards. + +Fortran 95 has + + R840 stop-stmt is STOP [ stop-code ] + R841 stop-code is scalar-char-constant + or digit [ digit [ digit [ digit [ digit ] ] ] ] + +Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850. +Fortran 2008 has + + R855 stop-stmt is STOP [ stop-code ] + R856 allstop-stmt is ALL STOP [ stop-code ] + R857 stop-code is scalar-default-char-constant-expr + or scalar-int-constant-expr + +For free-form source code, all standards contain a statement of the form: + + A blank shall be used to separate names, constants, or labels from + adjacent keywords, names, constants, or labels. + +A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003, + + STOP123 + +is valid, but it is invalid Fortran 2008. */ + +static match +gfc_match_stopcode (gfc_statement st) +{ + gfc_expr *e = NULL; + match m; + bool f95, f03, f08; + + /* Set f95 for -std=f95. */ + f95 = (gfc_option.allow_std == GFC_STD_OPT_F95); + + /* Set f03 for -std=f2003. */ + f03 = (gfc_option.allow_std == GFC_STD_OPT_F03); + + /* Set f08 for -std=f2008. */ + f08 = (gfc_option.allow_std == GFC_STD_OPT_F08); + + /* Look for a blank between STOP and the stop-code for F2008 or later. */ + if (gfc_current_form != FORM_FIXED && !(f95 || f03)) + { + char c = gfc_peek_ascii_char (); + + /* Look for end-of-statement. There is no stop-code. */ + if (c == '\n' || c == '!' || c == ';') + goto done; + + if (c != ' ') + { + gfc_error ("Blank required in %s statement near %C", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + } + + if (gfc_match_eos () != MATCH_YES) + { + int stopcode; + locus old_locus; + + /* First look for the F95 or F2003 digit [...] construct. */ + old_locus = gfc_current_locus; + m = gfc_match_small_int (&stopcode); + if (m == MATCH_YES && (f95 || f03)) + { + if (stopcode < 0) + { + gfc_error ("STOP code at %C cannot be negative"); + return MATCH_ERROR; + } + + if (stopcode > 99999) + { + gfc_error ("STOP code at %C contains too many digits"); + return MATCH_ERROR; + } + } + + /* Reset the locus and now load gfc_expr. */ + gfc_current_locus = old_locus; + m = gfc_match_expr (&e); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + } + + if (gfc_pure (NULL)) + { + if (st == ST_ERROR_STOP) + { + if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE " + "procedure", gfc_ascii_statement (st))) + goto cleanup; + } + else + { + gfc_error ("%s statement not allowed in PURE procedure at %C", + gfc_ascii_statement (st)); + goto cleanup; + } + } + + gfc_unset_implicit_pure (NULL); + + if (st == ST_STOP && gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("Image control statement STOP at %C in CRITICAL block"); + goto cleanup; + } + if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("Image control statement STOP at %C in DO CONCURRENT block"); + goto cleanup; + } + + if (e != NULL) + { + if (!gfc_simplify_expr (e, 0)) + goto cleanup; + + /* Test for F95 and F2003 style STOP stop-code. */ + if (e->expr_type != EXPR_CONSTANT && (f95 || f03)) + { + gfc_error ("STOP code at %L must be a scalar CHARACTER constant " + "or digit[digit[digit[digit[digit]]]]", &e->where); + goto cleanup; + } + + /* Use the machinery for an initialization expression to reduce the + stop-code to a constant. */ + gfc_reduce_init_expr (e); + + /* Test for F2008 style STOP stop-code. */ + if (e->expr_type != EXPR_CONSTANT && f08) + { + gfc_error ("STOP code at %L must be a scalar default CHARACTER or " + "INTEGER constant expression", &e->where); + goto cleanup; + } + + if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) + { + gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", + &e->where); + goto cleanup; + } + + if (e->rank != 0) + { + gfc_error ("STOP code at %L must be scalar", &e->where); + goto cleanup; + } + + if (e->ts.type == BT_CHARACTER + && e->ts.kind != gfc_default_character_kind) + { + gfc_error ("STOP code at %L must be default character KIND=%d", + &e->where, (int) gfc_default_character_kind); + goto cleanup; + } + + if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind) + { + gfc_error ("STOP code at %L must be default integer KIND=%d", + &e->where, (int) gfc_default_integer_kind); + goto cleanup; + } + } + +done: + + switch (st) + { + case ST_STOP: + new_st.op = EXEC_STOP; + break; + case ST_ERROR_STOP: + new_st.op = EXEC_ERROR_STOP; + break; + case ST_PAUSE: + new_st.op = EXEC_PAUSE; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = e; + new_st.ext.stop_code = -1; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + + gfc_free_expr (e); + return MATCH_ERROR; +} + + +/* Match the (deprecated) PAUSE statement. */ + +match +gfc_match_pause (void) +{ + match m; + + m = gfc_match_stopcode (ST_PAUSE); + if (m == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C")) + m = MATCH_ERROR; + } + return m; +} + + +/* Match the STOP statement. */ + +match +gfc_match_stop (void) +{ + return gfc_match_stopcode (ST_STOP); +} + + +/* Match the ERROR STOP statement. */ + +match +gfc_match_error_stop (void) +{ + if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C")) + return MATCH_ERROR; + + return gfc_match_stopcode (ST_ERROR_STOP); +} + +/* Match EVENT POST/WAIT statement. Syntax: + EVENT POST ( event-variable [, sync-stat-list] ) + EVENT WAIT ( event-variable [, wait-spec-list] ) + with + wait-spec-list is sync-stat-list or until-spec + until-spec is UNTIL_COUNT = scalar-int-expr + sync-stat is STAT= or ERRMSG=. */ + +static match +event_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg; + bool saw_until_count, saw_stat, saw_errmsg; + + tmp = eventvar = until_count = stat = errmsg = NULL; + saw_until_count = saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement EVENT %s at %C in PURE procedure", + st == ST_EVENT_POST ? "POST" : "WAIT"); + return MATCH_ERROR; + } + + gfc_unset_implicit_pure (NULL); + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("Image control statement EVENT %s at %C in CRITICAL block", + st == ST_EVENT_POST ? "POST" : "WAIT"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT " + "block", st == ST_EVENT_POST ? "POST" : "WAIT"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (gfc_match ("%e", &eventvar) != MATCH_YES) + goto syntax; + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" until_count = %e", &tmp); + if (m == MATCH_ERROR || st == ST_EVENT_POST) + goto syntax; + if (m == MATCH_YES) + { + if (saw_until_count) + { + gfc_error ("Redundant UNTIL_COUNT tag found at %L", + &tmp->where); + goto cleanup; + } + until_count = tmp; + saw_until_count = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) + { + case ST_EVENT_POST: + new_st.op = EXEC_EVENT_POST; + break; + case ST_EVENT_WAIT: + new_st.op = EXEC_EVENT_WAIT; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = eventvar; + new_st.expr2 = stat; + new_st.expr3 = errmsg; + new_st.expr4 = until_count; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + if (until_count != tmp) + gfc_free_expr (until_count); + if (errmsg != tmp) + gfc_free_expr (errmsg); + if (stat != tmp) + gfc_free_expr (stat); + + gfc_free_expr (tmp); + gfc_free_expr (eventvar); + + return MATCH_ERROR; + +} + + +match +gfc_match_event_post (void) +{ + if (!gfc_notify_std (GFC_STD_F2018, "EVENT POST statement at %C")) + return MATCH_ERROR; + + return event_statement (ST_EVENT_POST); +} + + +match +gfc_match_event_wait (void) +{ + if (!gfc_notify_std (GFC_STD_F2018, "EVENT WAIT statement at %C")) + return MATCH_ERROR; + + return event_statement (ST_EVENT_WAIT); +} + + +/* Match a FAIL IMAGE statement. */ + +match +gfc_match_fail_image (void) +{ + if (!gfc_notify_std (GFC_STD_F2018, "FAIL IMAGE statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_YES) + goto syntax; + + new_st.op = EXEC_FAIL_IMAGE; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FAIL_IMAGE); + + return MATCH_ERROR; +} + +/* Match a FORM TEAM statement. */ + +match +gfc_match_form_team (void) +{ + match m; + gfc_expr *teamid,*team; + + if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + new_st.op = EXEC_FORM_TEAM; + + if (gfc_match ("%e", &teamid) != MATCH_YES) + goto syntax; + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (gfc_match ("%e", &team) != MATCH_YES) + goto syntax; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + + new_st.expr1 = teamid; + new_st.expr2 = team; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORM_TEAM); + + return MATCH_ERROR; +} + +/* Match a CHANGE TEAM statement. */ + +match +gfc_match_change_team (void) +{ + match m; + gfc_expr *team; + + if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + new_st.op = EXEC_CHANGE_TEAM; + + if (gfc_match ("%e", &team) != MATCH_YES) + goto syntax; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + + new_st.expr1 = team; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_CHANGE_TEAM); + + return MATCH_ERROR; +} + +/* Match a END TEAM statement. */ + +match +gfc_match_end_team (void) +{ + if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_YES) + goto syntax; + + new_st.op = EXEC_END_TEAM; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_END_TEAM); + + return MATCH_ERROR; +} + +/* Match a SYNC TEAM statement. */ + +match +gfc_match_sync_team (void) +{ + match m; + gfc_expr *team; + + if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C")) + return MATCH_ERROR; + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + new_st.op = EXEC_SYNC_TEAM; + + if (gfc_match ("%e", &team) != MATCH_YES) + goto syntax; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + + new_st.expr1 = team; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_SYNC_TEAM); + + return MATCH_ERROR; +} + +/* Match LOCK/UNLOCK statement. Syntax: + LOCK ( lock-variable [ , lock-stat-list ] ) + UNLOCK ( lock-variable [ , sync-stat-list ] ) + where lock-stat is ACQUIRED_LOCK or sync-stat + and sync-stat is STAT= or ERRMSG=. */ + +static match +lock_unlock_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; + bool saw_acq_lock, saw_stat, saw_errmsg; + + tmp = lockvar = acq_lock = stat = errmsg = NULL; + saw_acq_lock = saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement %s at %C in PURE procedure", + st == ST_LOCK ? "LOCK" : "UNLOCK"); + return MATCH_ERROR; + } + + gfc_unset_implicit_pure (NULL); + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("Image control statement %s at %C in CRITICAL block", + st == ST_LOCK ? "LOCK" : "UNLOCK"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("Image control statement %s at %C in DO CONCURRENT block", + st == ST_LOCK ? "LOCK" : "UNLOCK"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (gfc_match ("%e", &lockvar) != MATCH_YES) + goto syntax; + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" acquired_lock = %v", &tmp); + if (m == MATCH_ERROR || st == ST_UNLOCK) + goto syntax; + if (m == MATCH_YES) + { + if (saw_acq_lock) + { + gfc_error ("Redundant ACQUIRED_LOCK tag found at %L", + &tmp->where); + goto cleanup; + } + acq_lock = tmp; + saw_acq_lock = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) + { + case ST_LOCK: + new_st.op = EXEC_LOCK; + break; + case ST_UNLOCK: + new_st.op = EXEC_UNLOCK; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = lockvar; + new_st.expr2 = stat; + new_st.expr3 = errmsg; + new_st.expr4 = acq_lock; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + if (acq_lock != tmp) + gfc_free_expr (acq_lock); + if (errmsg != tmp) + gfc_free_expr (errmsg); + if (stat != tmp) + gfc_free_expr (stat); + + gfc_free_expr (tmp); + gfc_free_expr (lockvar); + + return MATCH_ERROR; +} + + +match +gfc_match_lock (void) +{ + if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C")) + return MATCH_ERROR; + + return lock_unlock_statement (ST_LOCK); +} + + +match +gfc_match_unlock (void) +{ + if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C")) + return MATCH_ERROR; + + return lock_unlock_statement (ST_UNLOCK); +} + + +/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: + SYNC ALL [(sync-stat-list)] + SYNC MEMORY [(sync-stat-list)] + SYNC IMAGES (image-set [, sync-stat-list] ) + with sync-stat is int-expr or *. */ + +static match +sync_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *imageset, *stat, *errmsg; + bool saw_stat, saw_errmsg; + + tmp = imageset = stat = errmsg = NULL; + saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement SYNC at %C in PURE procedure"); + return MATCH_ERROR; + } + + gfc_unset_implicit_pure (NULL); + + if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C")) + return MATCH_ERROR; + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " + "enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("Image control statement SYNC at %C in CRITICAL block"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block"); + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + { + if (st == ST_SYNC_IMAGES) + goto syntax; + goto done; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (st == ST_SYNC_IMAGES) + { + /* Denote '*' as imageset == NULL. */ + m = gfc_match_char ('*'); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + if (gfc_match ("%e", &imageset) != MATCH_YES) + goto syntax; + } + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + } + + for (;;) + { + m = gfc_match (" stat = %e", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" errmsg = %e", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) + { + case ST_SYNC_ALL: + new_st.op = EXEC_SYNC_ALL; + break; + case ST_SYNC_IMAGES: + new_st.op = EXEC_SYNC_IMAGES; + break; + case ST_SYNC_MEMORY: + new_st.op = EXEC_SYNC_MEMORY; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = imageset; + new_st.expr2 = stat; + new_st.expr3 = errmsg; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + if (stat != tmp) + gfc_free_expr (stat); + if (errmsg != tmp) + gfc_free_expr (errmsg); + + gfc_free_expr (tmp); + gfc_free_expr (imageset); + + return MATCH_ERROR; +} + + +/* Match SYNC ALL statement. */ + +match +gfc_match_sync_all (void) +{ + return sync_statement (ST_SYNC_ALL); +} + + +/* Match SYNC IMAGES statement. */ + +match +gfc_match_sync_images (void) +{ + return sync_statement (ST_SYNC_IMAGES); +} + + +/* Match SYNC MEMORY statement. */ + +match +gfc_match_sync_memory (void) +{ + return sync_statement (ST_SYNC_MEMORY); +} + + +/* Match a CONTINUE statement. */ + +match +gfc_match_continue (void) +{ + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_CONTINUE); + return MATCH_ERROR; + } + + new_st.op = EXEC_CONTINUE; + return MATCH_YES; +} + + +/* Match the (deprecated) ASSIGN statement. */ + +match +gfc_match_assign (void) +{ + gfc_expr *expr; + gfc_st_label *label; + + if (gfc_match (" %l", &label) == MATCH_YES) + { + if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN)) + return MATCH_ERROR; + if (gfc_match (" to %v%t", &expr) == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C")) + return MATCH_ERROR; + + expr->symtree->n.sym->attr.assign = 1; + + new_st.op = EXEC_LABEL_ASSIGN; + new_st.label1 = label; + new_st.expr1 = expr; + return MATCH_YES; + } + } + return MATCH_NO; +} + + +/* Match the GO TO statement. As a computed GOTO statement is + matched, it is transformed into an equivalent SELECT block. No + tree is necessary, and the resulting jumps-to-jumps are + specifically optimized away by the back end. */ + +match +gfc_match_goto (void) +{ + gfc_code *head, *tail; + gfc_expr *expr; + gfc_case *cp; + gfc_st_label *label; + int i; + match m; + + if (gfc_match (" %l%t", &label) == MATCH_YES) + { + if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) + return MATCH_ERROR; + + new_st.op = EXEC_GOTO; + new_st.label1 = label; + return MATCH_YES; + } + + /* The assigned GO TO statement. */ + + if (gfc_match_variable (&expr, 0) == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C")) + return MATCH_ERROR; + + new_st.op = EXEC_GOTO; + new_st.expr1 = expr; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + /* Match label list. */ + gfc_match_char (','); + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_syntax_error (ST_GOTO); + return MATCH_ERROR; + } + head = tail = NULL; + + do + { + m = gfc_match_st_label (&label); + if (m != MATCH_YES) + goto syntax; + + if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) + goto cleanup; + + if (head == NULL) + head = tail = gfc_get_code (EXEC_GOTO); + else + { + tail->block = gfc_get_code (EXEC_GOTO); + tail = tail->block; + } + + tail->label1 = label; + } + while (gfc_match_char (',') == MATCH_YES); + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + + if (head == NULL) + { + gfc_error ("Statement label list in GOTO at %C cannot be empty"); + goto syntax; + } + new_st.block = head; + + return MATCH_YES; + } + + /* Last chance is a computed GO TO statement. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_syntax_error (ST_GOTO); + return MATCH_ERROR; + } + + head = tail = NULL; + i = 1; + + do + { + m = gfc_match_st_label (&label); + if (m != MATCH_YES) + goto syntax; + + if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) + goto cleanup; + + if (head == NULL) + head = tail = gfc_get_code (EXEC_SELECT); + else + { + tail->block = gfc_get_code (EXEC_SELECT); + tail = tail->block; + } + + cp = gfc_get_case (); + cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, + NULL, i++); + + tail->ext.block.case_list = cp; + + tail->next = gfc_get_code (EXEC_GOTO); + tail->next->label1 = label; + } + while (gfc_match_char (',') == MATCH_YES); + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + if (head == NULL) + { + gfc_error ("Statement label list in GOTO at %C cannot be empty"); + goto syntax; + } + + /* Get the rest of the statement. */ + gfc_match_char (','); + + if (gfc_match (" %e%t", &expr) != MATCH_YES) + goto syntax; + + if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C")) + return MATCH_ERROR; + + /* At this point, a computed GOTO has been fully matched and an + equivalent SELECT statement constructed. */ + + new_st.op = EXEC_SELECT; + new_st.expr1 = NULL; + + /* Hack: For a "real" SELECT, the expression is in expr. We put + it in expr2 so we can distinguish then and produce the correct + diagnostics. */ + new_st.expr2 = expr; + new_st.block = head; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_GOTO); +cleanup: + gfc_free_statements (head); + return MATCH_ERROR; +} + + +/* Frees a list of gfc_alloc structures. */ + +void +gfc_free_alloc_list (gfc_alloc *p) +{ + gfc_alloc *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + free (p); + } +} + + +/* Match an ALLOCATE statement. */ + +match +gfc_match_allocate (void) +{ + gfc_alloc *head, *tail; + gfc_expr *stat, *errmsg, *tmp, *source, *mold; + gfc_typespec ts; + gfc_symbol *sym; + match m; + locus old_locus, deferred_locus, assumed_locus; + bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; + bool saw_unlimited = false, saw_assumed = false; + + head = tail = NULL; + stat = errmsg = source = mold = tmp = NULL; + saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false; + + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_syntax_error (ST_ALLOCATE); + return MATCH_ERROR; + } + + /* Match an optional type-spec. */ + old_locus = gfc_current_locus; + m = gfc_match_type_spec (&ts); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + { + char name[GFC_MAX_SYMBOL_LEN + 3]; + + if (gfc_match ("%n :: ", name) == MATCH_YES) + { + gfc_error ("Error in type-spec at %L", &old_locus); + goto cleanup; + } + + ts.type = BT_UNKNOWN; + } + else + { + /* Needed for the F2008:C631 check below. */ + assumed_locus = gfc_current_locus; + + if (gfc_match (" :: ") == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L", + &old_locus)) + goto cleanup; + + if (ts.deferred) + { + gfc_error ("Type-spec at %L cannot contain a deferred " + "type parameter", &old_locus); + goto cleanup; + } + + if (ts.type == BT_CHARACTER) + { + if (!ts.u.cl->length) + saw_assumed = true; + else + ts.u.cl->length_from_typespec = true; + } + + if (type_param_spec_list + && gfc_spec_list_type (type_param_spec_list, NULL) + == SPEC_DEFERRED) + { + gfc_error ("The type parameter spec list in the type-spec at " + "%L cannot contain DEFERRED parameters", &old_locus); + goto cleanup; + } + } + else + { + ts.type = BT_UNKNOWN; + gfc_current_locus = old_locus; + } + } + + for (;;) + { + if (head == NULL) + head = tail = gfc_get_alloc (); + else + { + tail->next = gfc_get_alloc (); + tail = tail->next; + } + + m = gfc_match_variable (&tail->expr, 0); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (tail->expr->expr_type == EXPR_CONSTANT) + { + gfc_error ("Unexpected constant at %C"); + goto cleanup; + } + + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; + + bool impure = gfc_impure_variable (tail->expr->symtree->n.sym); + if (impure && gfc_pure (NULL)) + { + gfc_error ("Bad allocate-object at %C for a PURE procedure"); + goto cleanup; + } + + if (impure) + gfc_unset_implicit_pure (NULL); + + /* F2008:C631 (R626) A type-param-value in a type-spec shall be an + asterisk if and only if each allocate-object is a dummy argument + for which the corresponding type parameter is assumed. */ + if (saw_assumed + && (tail->expr->ts.deferred + || (tail->expr->ts.u.cl && tail->expr->ts.u.cl->length) + || tail->expr->symtree->n.sym->attr.dummy == 0)) + { + gfc_error ("Incompatible allocate-object at %C for CHARACTER " + "type-spec at %L", &assumed_locus); + goto cleanup; + } + + if (tail->expr->ts.deferred) + { + saw_deferred = true; + deferred_locus = tail->expr->where; + } + + if (gfc_find_state (COMP_DO_CONCURRENT) + || gfc_find_state (COMP_CRITICAL)) + { + gfc_ref *ref; + bool coarray = tail->expr->symtree->n.sym->attr.codimension; + for (ref = tail->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + coarray = ref->u.c.component->attr.codimension; + + if (coarray && gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block"); + goto cleanup; + } + if (coarray && gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("ALLOCATE of coarray at %C in CRITICAL block"); + goto cleanup; + } + } + + /* Check for F08:C628. */ + sym = tail->expr->symtree->n.sym; + b1 = !(tail->expr->ref + && (tail->expr->ref->type == REF_COMPONENT + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok) + b2 = !(CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + b3 = sym && sym->ns && sym->ns->proc_name + && (sym->ns->proc_name->attr.allocatable + || sym->ns->proc_name->attr.pointer + || sym->ns->proc_name->attr.proc_pointer); + if (b1 && b2 && !b3) + { + gfc_error ("Allocate-object at %L is neither a data pointer " + "nor an allocatable variable", &tail->expr->where); + goto cleanup; + } + + /* The ALLOCATE statement had an optional typespec. Check the + constraints. */ + if (ts.type != BT_UNKNOWN) + { + /* Enforce F03:C624. */ + if (!gfc_type_compatible (&tail->expr->ts, &ts)) + { + gfc_error ("Type of entity at %L is type incompatible with " + "typespec", &tail->expr->where); + goto cleanup; + } + + /* Enforce F03:C627. */ + if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr)) + { + gfc_error ("Kind type parameter for entity at %L differs from " + "the kind type parameter of the typespec", + &tail->expr->where); + goto cleanup; + } + } + + if (tail->expr->ts.type == BT_DERIVED) + tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); + + if (type_param_spec_list) + tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list); + + saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr); + + if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) + { + gfc_error ("Shape specification for allocatable scalar at %C"); + goto cleanup; + } + + if (gfc_match_char (',') != MATCH_YES) + break; + +alloc_opt_list: + + m = gfc_match (" stat = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + /* Enforce C630. */ + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L", &tmp->where); + goto cleanup; + } + + stat = tmp; + tmp = NULL; + saw_stat = true; + + if (stat->expr_type == EXPR_CONSTANT) + { + gfc_error ("STAT tag at %L cannot be a constant", &stat->where); + goto cleanup; + } + + if (gfc_check_do_variable (stat->symtree)) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + m = gfc_match (" errmsg = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where)) + goto cleanup; + + /* Enforce C630. */ + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); + goto cleanup; + } + + errmsg = tmp; + tmp = NULL; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + m = gfc_match (" source = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where)) + goto cleanup; + + /* Enforce C630. */ + if (saw_source) + { + gfc_error ("Redundant SOURCE tag found at %L", &tmp->where); + goto cleanup; + } + + /* The next 2 conditionals check C631. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + if (head->next + && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L" + " with more than a single allocate object", + &tmp->where)) + goto cleanup; + + source = tmp; + tmp = NULL; + saw_source = true; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + m = gfc_match (" mold = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where)) + goto cleanup; + + /* Check F08:C636. */ + if (saw_mold) + { + gfc_error ("Redundant MOLD tag found at %L", &tmp->where); + goto cleanup; + } + + /* Check F08:C637. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + mold = tmp; + tmp = NULL; + saw_mold = true; + mold->mold = 1; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; + } + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + + /* Check F08:C637. */ + if (source && mold) + { + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); + goto cleanup; + } + + /* Check F03:C623, */ + if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) + { + gfc_error ("Allocate-object at %L with a deferred type parameter " + "requires either a type-spec or SOURCE tag or a MOLD tag", + &deferred_locus); + goto cleanup; + } + + /* Check F03:C625, */ + if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold) + { + for (tail = head; tail; tail = tail->next) + { + if (UNLIMITED_POLY (tail->expr)) + gfc_error ("Unlimited polymorphic allocate-object at %L " + "requires either a type-spec or SOURCE tag " + "or a MOLD tag", &tail->expr->where); + } + goto cleanup; + } + + new_st.op = EXEC_ALLOCATE; + new_st.expr1 = stat; + new_st.expr2 = errmsg; + if (source) + new_st.expr3 = source; + else + new_st.expr3 = mold; + new_st.ext.alloc.list = head; + new_st.ext.alloc.ts = ts; + + if (type_param_spec_list) + gfc_free_actual_arglist (type_param_spec_list); + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_ALLOCATE); + +cleanup: + gfc_free_expr (errmsg); + gfc_free_expr (source); + gfc_free_expr (stat); + gfc_free_expr (mold); + if (tmp && tmp->expr_type) gfc_free_expr (tmp); + gfc_free_alloc_list (head); + if (type_param_spec_list) + gfc_free_actual_arglist (type_param_spec_list); + return MATCH_ERROR; +} + + +/* Match a NULLIFY statement. A NULLIFY statement is transformed into + a set of pointer assignments to intrinsic NULL(). */ + +match +gfc_match_nullify (void) +{ + gfc_code *tail; + gfc_expr *e, *p; + match m; + + tail = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) + { + m = gfc_match_variable (&p, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_check_do_variable (p->symtree)) + goto cleanup; + + /* F2008, C1242. */ + if (gfc_is_coindexed (p)) + { + gfc_error ("Pointer object at %C shall not be coindexed"); + goto cleanup; + } + + /* Check for valid array pointer object. Bounds remapping is not + allowed with NULLIFY. */ + if (p->ref) + { + gfc_ref *remap = p->ref; + for (; remap; remap = remap->next) + if (!remap->next && remap->type == REF_ARRAY + && remap->u.ar.type != AR_FULL) + break; + if (remap) + { + gfc_error ("NULLIFY does not allow bounds remapping for " + "pointer object at %C"); + goto cleanup; + } + } + + /* build ' => NULL() '. */ + e = gfc_get_null_expr (&gfc_current_locus); + + /* Chain to list. */ + if (tail == NULL) + { + tail = &new_st; + tail->op = EXEC_POINTER_ASSIGN; + } + else + { + tail->next = gfc_get_code (EXEC_POINTER_ASSIGN); + tail = tail->next; + } + + tail->expr1 = p; + tail->expr2 = e; + + if (gfc_match (" )%t") == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_NULLIFY); + +cleanup: + gfc_free_statements (new_st.next); + new_st.next = NULL; + gfc_free_expr (new_st.expr1); + new_st.expr1 = NULL; + gfc_free_expr (new_st.expr2); + new_st.expr2 = NULL; + return MATCH_ERROR; +} + + +/* Match a DEALLOCATE statement. */ + +match +gfc_match_deallocate (void) +{ + gfc_alloc *head, *tail; + gfc_expr *stat, *errmsg, *tmp; + gfc_symbol *sym; + match m; + bool saw_stat, saw_errmsg, b1, b2; + + head = tail = NULL; + stat = errmsg = tmp = NULL; + saw_stat = saw_errmsg = false; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) + { + if (head == NULL) + head = tail = gfc_get_alloc (); + else + { + tail->next = gfc_get_alloc (); + tail = tail->next; + } + + m = gfc_match_variable (&tail->expr, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (tail->expr->expr_type == EXPR_CONSTANT) + { + gfc_error ("Unexpected constant at %C"); + goto cleanup; + } + + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; + + sym = tail->expr->symtree->n.sym; + + bool impure = gfc_impure_variable (sym); + if (impure && gfc_pure (NULL)) + { + gfc_error ("Illegal allocate-object at %C for a PURE procedure"); + goto cleanup; + } + + if (impure) + gfc_unset_implicit_pure (NULL); + + if (gfc_is_coarray (tail->expr) + && gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block"); + goto cleanup; + } + + if (gfc_is_coarray (tail->expr) + && gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block"); + goto cleanup; + } + + /* FIXME: disable the checking on derived types. */ + b1 = !(tail->expr->ref + && (tail->expr->ref->type == REF_COMPONENT + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer)); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + if (b1 && b2) + { + gfc_error ("Allocate-object at %C is not a nonprocedure pointer " + "nor an allocatable variable"); + goto cleanup; + } + + if (gfc_match_char (',') != MATCH_YES) + break; + +dealloc_opt_list: + + m = gfc_match (" stat = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L", &tmp->where); + gfc_free_expr (tmp); + goto cleanup; + } + + stat = tmp; + saw_stat = true; + + if (gfc_check_do_variable (stat->symtree)) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + goto dealloc_opt_list; + } + + m = gfc_match (" errmsg = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where)) + goto cleanup; + + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); + gfc_free_expr (tmp); + goto cleanup; + } + + errmsg = tmp; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + goto dealloc_opt_list; + } + + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; + } + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + + new_st.op = EXEC_DEALLOCATE; + new_st.expr1 = stat; + new_st.expr2 = errmsg; + new_st.ext.alloc.list = head; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DEALLOCATE); + +cleanup: + gfc_free_expr (errmsg); + gfc_free_expr (stat); + gfc_free_alloc_list (head); + return MATCH_ERROR; +} + + +/* Match a RETURN statement. */ + +match +gfc_match_return (void) +{ + gfc_expr *e; + match m; + gfc_compile_state s; + + e = NULL; + + if (gfc_find_state (COMP_CRITICAL)) + { + gfc_error ("Image control statement RETURN at %C in CRITICAL block"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_DO_CONCURRENT)) + { + gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block"); + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (!gfc_find_state (COMP_SUBROUTINE)) + { + gfc_error ("Alternate RETURN statement at %C is only allowed within " + "a SUBROUTINE"); + goto cleanup; + } + + if (gfc_current_form == FORM_FREE) + { + /* The following are valid, so we can't require a blank after the + RETURN keyword: + return+1 + return(1) */ + char c = gfc_peek_ascii_char (); + if (ISALPHA (c) || ISDIGIT (c)) + return MATCH_NO; + } + + m = gfc_match (" %e%t", &e); + if (m == MATCH_YES) + goto done; + if (m == MATCH_ERROR) + goto cleanup; + + gfc_syntax_error (ST_RETURN); + +cleanup: + gfc_free_expr (e); + return MATCH_ERROR; + +done: + gfc_enclosing_unit (&s); + if (s == COMP_PROGRAM + && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in " + "main program at %C")) + return MATCH_ERROR; + + new_st.op = EXEC_RETURN; + new_st.expr1 = e; + + return MATCH_YES; +} + + +/* Match the call of a type-bound procedure, if CALL%var has already been + matched and var found to be a derived-type variable. */ + +static match +match_typebound_call (gfc_symtree* varst) +{ + gfc_expr* base; + match m; + + base = gfc_get_expr (); + base->expr_type = EXPR_VARIABLE; + base->symtree = varst; + base->where = gfc_current_locus; + gfc_set_sym_referenced (varst->n.sym); + + m = gfc_match_varspec (base, 0, true, true); + if (m == MATCH_NO) + gfc_error ("Expected component reference at %C"); + if (m != MATCH_YES) + { + gfc_free_expr (base); + return MATCH_ERROR; + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after CALL at %C"); + gfc_free_expr (base); + return MATCH_ERROR; + } + + if (base->expr_type == EXPR_COMPCALL) + new_st.op = EXEC_COMPCALL; + else if (base->expr_type == EXPR_PPC) + new_st.op = EXEC_CALL_PPC; + else + { + gfc_error ("Expected type-bound procedure or procedure pointer component " + "at %C"); + gfc_free_expr (base); + return MATCH_ERROR; + } + new_st.expr1 = base; + + return MATCH_YES; +} + + +/* Match a CALL statement. The tricky part here are possible + alternate return specifiers. We handle these by having all + "subroutines" actually return an integer via a register that gives + the return number. If the call specifies alternate returns, we + generate code for a SELECT statement whose case clauses contain + GOTOs to the various labels. */ + +match +gfc_match_call (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_actual_arglist *a, *arglist; + gfc_case *new_case; + gfc_symbol *sym; + gfc_symtree *st; + gfc_code *c; + match m; + int i; + + arglist = NULL; + + m = gfc_match ("% %n", name); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return m; + + if (gfc_get_ha_sym_tree (name, &st)) + return MATCH_ERROR; + + sym = st->n.sym; + + /* If this is a variable of derived-type, it probably starts a type-bound + procedure call. Associate variable targets have to be resolved for the + target type. */ + if (((sym->attr.flavor != FL_PROCEDURE + || gfc_is_function_return_value (sym, gfc_current_ns)) + && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) + || + (sym->assoc && sym->assoc->target + && gfc_resolve_expr (sym->assoc->target) + && (sym->assoc->target->ts.type == BT_DERIVED + || sym->assoc->target->ts.type == BT_CLASS))) + return match_typebound_call (st); + + /* If it does not seem to be callable (include functions so that the + right association is made. They are thrown out in resolution.) + ... */ + if (!sym->attr.generic + && !sym->attr.subroutine + && !sym->attr.function) + { + if (!(sym->attr.external && !sym->attr.referenced)) + { + /* ...create a symbol in this scope... */ + if (sym->ns != gfc_current_ns + && gfc_get_sym_tree (name, NULL, &st, false) == 1) + return MATCH_ERROR; + + if (sym != st->n.sym) + sym = st->n.sym; + } + + /* ...and then to try to make the symbol into a subroutine. */ + if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) + return MATCH_ERROR; + } + + gfc_set_sym_referenced (sym); + + if (gfc_match_eos () != MATCH_YES) + { + m = gfc_match_actual_arglist (1, &arglist); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + } + + /* Walk the argument list looking for invalid BOZ. */ + for (a = arglist; a; a = a->next) + if (a->expr && a->expr->ts.type == BT_BOZ) + { + gfc_error ("A BOZ literal constant at %L cannot appear as an actual " + "argument in a subroutine reference", &a->expr->where); + goto cleanup; + } + + + /* If any alternate return labels were found, construct a SELECT + statement that will jump to the right place. */ + + i = 0; + for (a = arglist; a; a = a->next) + if (a->expr == NULL) + { + i = 1; + break; + } + + if (i) + { + gfc_symtree *select_st; + gfc_symbol *select_sym; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + new_st.next = c = gfc_get_code (EXEC_SELECT); + sprintf (name, "_result_%s", sym->name); + gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */ + + select_sym = select_st->n.sym; + select_sym->ts.type = BT_INTEGER; + select_sym->ts.kind = gfc_default_integer_kind; + gfc_set_sym_referenced (select_sym); + c->expr1 = gfc_get_expr (); + c->expr1->expr_type = EXPR_VARIABLE; + c->expr1->symtree = select_st; + c->expr1->ts = select_sym->ts; + c->expr1->where = gfc_current_locus; + + i = 0; + for (a = arglist; a; a = a->next) + { + if (a->expr != NULL) + continue; + + if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET)) + continue; + + i++; + + c->block = gfc_get_code (EXEC_SELECT); + c = c->block; + + new_case = gfc_get_case (); + new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); + new_case->low = new_case->high; + c->ext.block.case_list = new_case; + + c->next = gfc_get_code (EXEC_GOTO); + c->next->label1 = a->label; + } + } + + new_st.op = EXEC_CALL; + new_st.symtree = st; + new_st.ext.actual = arglist; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_CALL); + +cleanup: + gfc_free_actual_arglist (arglist); + return MATCH_ERROR; +} + + +/* Given a name, return a pointer to the common head structure, + creating it if it does not exist. If FROM_MODULE is nonzero, we + mangle the name so that it doesn't interfere with commons defined + in the using namespace. + TODO: Add to global symbol tree. */ + +gfc_common_head * +gfc_get_common (const char *name, int from_module) +{ + gfc_symtree *st; + static int serial = 0; + char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; + + if (from_module) + { + /* A use associated common block is only needed to correctly layout + the variables it contains. */ + snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); + st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); + } + else + { + st = gfc_find_symtree (gfc_current_ns->common_root, name); + + if (st == NULL) + st = gfc_new_symtree (&gfc_current_ns->common_root, name); + } + + if (st->n.common == NULL) + { + st->n.common = gfc_get_common_head (); + st->n.common->where = gfc_current_locus; + strcpy (st->n.common->name, name); + } + + return st->n.common; +} + + +/* Match a common block name. */ + +match +gfc_match_common_name (char *name) +{ + match m; + + if (gfc_match_char ('/') == MATCH_NO) + { + name[0] = '\0'; + return MATCH_YES; + } + + if (gfc_match_char ('/') == MATCH_YES) + { + name[0] = '\0'; + return MATCH_YES; + } + + m = gfc_match_name (name); + + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) + return MATCH_YES; + + gfc_error ("Syntax error in common block name at %C"); + return MATCH_ERROR; +} + + +/* Match a COMMON statement. */ + +match +gfc_match_common (void) +{ + gfc_symbol *sym, **head, *tail, *other; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_common_head *t; + gfc_array_spec *as; + gfc_equiv *e1, *e2; + match m; + char c; + + /* COMMON has been matched. In free form source code, the next character + needs to be whitespace or '/'. Check that here. Fixed form source + code needs to be checked below. */ + c = gfc_peek_ascii_char (); + if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '/') + return MATCH_NO; + + as = NULL; + + for (;;) + { + m = gfc_match_common_name (name); + if (m == MATCH_ERROR) + goto cleanup; + + if (name[0] == '\0') + { + t = &gfc_current_ns->blank_common; + if (t->head == NULL) + t->where = gfc_current_locus; + } + else + { + t = gfc_get_common (name, 0); + } + head = &t->head; + + if (*head == NULL) + tail = NULL; + else + { + tail = *head; + while (tail->common_next) + tail = tail->common_next; + } + + /* Grab the list of symbols. */ + for (;;) + { + m = gfc_match_symbol (&sym, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + /* See if we know the current common block is bind(c), and if + so, then see if we can check if the symbol is (which it'll + need to be). This can happen if the bind(c) attr stmt was + applied to the common block, and the variable(s) already + defined, before declaring the common block. */ + if (t->is_bind_c == 1) + { + if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) + { + /* If we find an error, just print it and continue, + cause it's just semantic, and we can see if there + are more errors. */ + gfc_error_now ("Variable %qs at %L in common block %qs " + "at %C must be declared with a C " + "interoperable kind since common block " + "%qs is bind(c)", + sym->name, &(sym->declared_at), t->name, + t->name); + } + + if (sym->attr.is_bind_c == 1) + gfc_error_now ("Variable %qs in common block %qs at %C cannot " + "be bind(c) since it is not global", sym->name, + t->name); + } + + if (sym->attr.in_common) + { + gfc_error ("Symbol %qs at %C is already in a COMMON block", + sym->name); + goto cleanup; + } + + if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) + || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) + { + if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at " + "%C can only be COMMON in BLOCK DATA", + sym->name)) + goto cleanup; + } + + /* Deal with an optional array specification after the + symbol name. */ + m = gfc_match_array_spec (&as, true, true); + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_YES) + { + if (as->type != AS_EXPLICIT) + { + gfc_error ("Array specification for symbol %qs in COMMON " + "at %C must be explicit", sym->name); + goto cleanup; + } + + if (as->corank) + { + gfc_error ("Symbol %qs in COMMON at %C cannot be a " + "coarray", sym->name); + goto cleanup; + } + + if (!gfc_add_dimension (&sym->attr, sym->name, NULL)) + goto cleanup; + + if (sym->attr.pointer) + { + gfc_error ("Symbol %qs in COMMON at %C cannot be a " + "POINTER array", sym->name); + goto cleanup; + } + + sym->as = as; + as = NULL; + + } + + /* Add the in_common attribute, but ignore the reported errors + if any, and continue matching. */ + gfc_add_in_common (&sym->attr, sym->name, NULL); + + sym->common_block = t; + sym->common_block->refs++; + + if (tail != NULL) + tail->common_next = sym; + else + *head = sym; + + tail = sym; + + sym->common_head = t; + + /* Check to see if the symbol is already in an equivalence group. + If it is, set the other members as being in common. */ + if (sym->attr.in_equivalence) + { + for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) + { + for (e2 = e1; e2; e2 = e2->eq) + if (e2->expr->symtree->n.sym == sym) + goto equiv_found; + + continue; + + equiv_found: + + for (e2 = e1; e2; e2 = e2->eq) + { + other = e2->expr->symtree->n.sym; + if (other->common_head + && other->common_head != sym->common_head) + { + gfc_error ("Symbol %qs, in COMMON block %qs at " + "%C is being indirectly equivalenced to " + "another COMMON block %qs", + sym->name, sym->common_head->name, + other->common_head->name); + goto cleanup; + } + other->attr.in_common = 1; + other->common_head = t; + } + } + } + + + gfc_gobble_whitespace (); + if (gfc_match_eos () == MATCH_YES) + goto done; + c = gfc_peek_ascii_char (); + if (c == '/') + break; + if (c != ',') + { + /* In Fixed form source code, gfortran can end up here for an + expression of the form COMMONI = RHS. This may not be an + error, so return MATCH_NO. */ + if (gfc_current_form == FORM_FIXED && c == '=') + { + gfc_free_array_spec (as); + return MATCH_NO; + } + goto syntax; + } + else + gfc_match_char (','); + + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '/') + break; + } + } + +done: + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_COMMON); + +cleanup: + gfc_free_array_spec (as); + return MATCH_ERROR; +} + + +/* Match a BLOCK DATA program unit. */ + +match +gfc_match_block_data (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L", + &gfc_current_locus)) + return MATCH_ERROR; + + if (gfc_match_eos () == MATCH_YES) + { + gfc_new_block = NULL; + return MATCH_YES; + } + + m = gfc_match ("% %n%t", name); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_get_symbol (name, NULL, &sym)) + return MATCH_ERROR; + + if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL)) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Free a namelist structure. */ + +void +gfc_free_namelist (gfc_namelist *name) +{ + gfc_namelist *n; + + for (; name; name = n) + { + n = name->next; + free (name); + } +} + + +/* Free an OpenMP namelist structure. */ + +void +gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns) +{ + gfc_omp_namelist *n; + + for (; name; name = n) + { + gfc_free_expr (name->expr); + if (free_ns) + gfc_free_namespace (name->u2.ns); + else if (name->u2.udr) + { + if (name->u2.udr->combiner) + gfc_free_statement (name->u2.udr->combiner); + if (name->u2.udr->initializer) + gfc_free_statement (name->u2.udr->initializer); + free (name->u2.udr); + } + n = name->next; + free (name); + } +} + + +/* Match a NAMELIST statement. */ + +match +gfc_match_namelist (void) +{ + gfc_symbol *group_name, *sym; + gfc_namelist *nl; + match m, m2; + + m = gfc_match (" / %s /", &group_name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto error; + + for (;;) + { + if (group_name->ts.type != BT_UNKNOWN) + { + gfc_error ("Namelist group name %qs at %C already has a basic " + "type of %s", group_name->name, + gfc_typename (&group_name->ts)); + return MATCH_ERROR; + } + + if (group_name->attr.flavor == FL_NAMELIST + && group_name->attr.use_assoc + && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs " + "at %C already is USE associated and can" + "not be respecified.", group_name->name)) + return MATCH_ERROR; + + if (group_name->attr.flavor != FL_NAMELIST + && !gfc_add_flavor (&group_name->attr, FL_NAMELIST, + group_name->name, NULL)) + return MATCH_ERROR; + + for (;;) + { + m = gfc_match_symbol (&sym, 1); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto error; + + if (sym->ts.type == BT_UNKNOWN) + { + if (gfc_current_ns->seen_implicit_none) + { + /* It is required that members of a namelist be declared + before the namelist. We check this by checking if the + symbol has a defined type for IMPLICIT NONE. */ + gfc_error ("Symbol %qs in namelist %qs at %C must be " + "declared before the namelist is declared.", + sym->name, group_name->name); + gfc_error_check (); + } + else + /* If the type is not set already, we set it here to the + implicit default type. It is not allowed to set it + later to any other type. */ + gfc_set_default_type (sym, 0, gfc_current_ns); + } + if (sym->attr.in_namelist == 0 + && !gfc_add_in_namelist (&sym->attr, sym->name, NULL)) + goto error; + + /* Use gfc_error_check here, rather than goto error, so that + these are the only errors for the next two lines. */ + if (sym->as && sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Assumed size array %qs in namelist %qs at " + "%C is not allowed", sym->name, group_name->name); + gfc_error_check (); + } + + nl = gfc_get_namelist (); + nl->sym = sym; + sym->refs++; + + if (group_name->namelist == NULL) + group_name->namelist = group_name->namelist_tail = nl; + else + { + group_name->namelist_tail->next = nl; + group_name->namelist_tail = nl; + } + + if (gfc_match_eos () == MATCH_YES) + goto done; + + m = gfc_match_char (','); + + if (gfc_match_char ('/') == MATCH_YES) + { + m2 = gfc_match (" %s /", &group_name); + if (m2 == MATCH_YES) + break; + if (m2 == MATCH_ERROR) + goto error; + goto syntax; + } + + if (m != MATCH_YES) + goto syntax; + } + } + +done: + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_NAMELIST); + +error: + return MATCH_ERROR; +} + + +/* Match a MODULE statement. */ + +match +gfc_match_module (void) +{ + match m; + + m = gfc_match (" %s%t", &gfc_new_block); + if (m != MATCH_YES) + return m; + + if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, + gfc_new_block->name, NULL)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Free equivalence sets and lists. Recursively is the easiest way to + do this. */ + +void +gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) +{ + if (eq == stop) + return; + + gfc_free_equiv (eq->eq); + gfc_free_equiv_until (eq->next, stop); + gfc_free_expr (eq->expr); + free (eq); +} + + +void +gfc_free_equiv (gfc_equiv *eq) +{ + gfc_free_equiv_until (eq, NULL); +} + + +/* Match an EQUIVALENCE statement. */ + +match +gfc_match_equivalence (void) +{ + gfc_equiv *eq, *set, *tail; + gfc_ref *ref; + gfc_symbol *sym; + match m; + gfc_common_head *common_head = NULL; + bool common_flag; + int cnt; + char c; + + /* EQUIVALENCE has been matched. After gobbling any possible whitespace, + the next character needs to be '('. Check that here, and return + MATCH_NO for a variable of the form equivalencej. */ + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c != '(') + return MATCH_NO; + + tail = NULL; + + for (;;) + { + eq = gfc_get_equiv (); + if (tail == NULL) + tail = eq; + + eq->next = gfc_current_ns->equiv; + gfc_current_ns->equiv = eq; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + set = eq; + common_flag = FALSE; + cnt = 0; + + for (;;) + { + m = gfc_match_equiv_variable (&set->expr); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + /* count the number of objects. */ + cnt++; + + if (gfc_match_char ('%') == MATCH_YES) + { + gfc_error ("Derived type component %C is not a " + "permitted EQUIVALENCE member"); + goto cleanup; + } + + for (ref = set->expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) + { + gfc_error ("Array reference in EQUIVALENCE at %C cannot " + "be an array section"); + goto cleanup; + } + + sym = set->expr->symtree->n.sym; + + if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) + goto cleanup; + if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym) + && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, + sym->name, NULL)) + goto cleanup; + + if (sym->attr.in_common) + { + common_flag = TRUE; + common_head = sym->common_head; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + set->eq = gfc_get_equiv (); + set = set->eq; + } + + if (cnt < 2) + { + gfc_error ("EQUIVALENCE at %C requires two or more objects"); + goto cleanup; + } + + /* If one of the members of an equivalence is in common, then + mark them all as being in common. Before doing this, check + that members of the equivalence group are not in different + common blocks. */ + if (common_flag) + for (set = eq; set; set = set->eq) + { + sym = set->expr->symtree->n.sym; + if (sym->common_head && sym->common_head != common_head) + { + gfc_error ("Attempt to indirectly overlap COMMON " + "blocks %s and %s by EQUIVALENCE at %C", + sym->common_head->name, common_head->name); + goto cleanup; + } + sym->attr.in_common = 1; + sym->common_head = common_head; + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expecting a comma in EQUIVALENCE at %C"); + goto cleanup; + } + } + + if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C")) + return MATCH_ERROR; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_EQUIVALENCE); + +cleanup: + eq = tail->next; + tail->next = NULL; + + gfc_free_equiv (gfc_current_ns->equiv); + gfc_current_ns->equiv = eq; + + return MATCH_ERROR; +} + + +/* Check that a statement function is not recursive. This is done by looking + for the statement function symbol(sym) by looking recursively through its + expression(e). If a reference to sym is found, true is returned. + 12.5.4 requires that any variable of function that is implicitly typed + shall have that type confirmed by any subsequent type declaration. The + implicit typing is conveniently done here. */ +static bool +recursive_stmt_fcn (gfc_expr *, gfc_symbol *); + +static bool +check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) +{ + + if (e == NULL) + return false; + + switch (e->expr_type) + { + case EXPR_FUNCTION: + if (e->symtree == NULL) + return false; + + /* Check the name before testing for nested recursion! */ + if (sym->name == e->symtree->n.sym->name) + return true; + + /* Catch recursion via other statement functions. */ + if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION + && e->symtree->n.sym->value + && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) + return true; + + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); + + break; + + case EXPR_VARIABLE: + if (e->symtree && sym->name == e->symtree->n.sym->name) + return true; + + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); + break; + + default: + break; + } + + return false; +} + + +static bool +recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) +{ + return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); +} + + +/* Match a statement function declaration. It is so easy to match + non-statement function statements with a MATCH_ERROR as opposed to + MATCH_NO that we suppress error message in most cases. */ + +match +gfc_match_st_function (void) +{ + gfc_error_buffer old_error; + gfc_symbol *sym; + gfc_expr *expr; + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + bool fcn; + gfc_formal_arglist *ptr; + + /* Read the possible statement function name, and then check to see if + a symbol is already present in the namespace. Record if it is a + function and whether it has been referenced. */ + fcn = false; + ptr = NULL; + old_locus = gfc_current_locus; + m = gfc_match_name (name); + if (m == MATCH_YES) + { + gfc_find_symbol (name, NULL, 1, &sym); + if (sym && sym->attr.function && !sym->attr.referenced) + { + fcn = true; + ptr = sym->formal; + } + } + + gfc_current_locus = old_locus; + m = gfc_match_symbol (&sym, 0); + if (m != MATCH_YES) + return m; + + gfc_push_error (&old_error); + + if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) + goto undo_error; + + if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) + goto undo_error; + + m = gfc_match (" = %e%t", &expr); + if (m == MATCH_NO) + goto undo_error; + + gfc_free_error (&old_error); + + if (m == MATCH_ERROR) + return m; + + if (recursive_stmt_fcn (expr, sym)) + { + gfc_error ("Statement function at %L is recursive", &expr->where); + return MATCH_ERROR; + } + + if (fcn && ptr != sym->formal) + { + gfc_error ("Statement function %qs at %L conflicts with function name", + sym->name, &expr->where); + return MATCH_ERROR; + } + + sym->value = expr; + + if ((gfc_current_state () == COMP_FUNCTION + || gfc_current_state () == COMP_SUBROUTINE) + && gfc_state_stack->previous->state == COMP_INTERFACE) + { + gfc_error ("Statement function at %L cannot appear within an INTERFACE", + &expr->where); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C")) + return MATCH_ERROR; + + return MATCH_YES; + +undo_error: + gfc_pop_error (&old_error); + return MATCH_NO; +} + + +/* Match an assignment to a pointer function (F2008). This could, in + general be ambiguous with a statement function. In this implementation + it remains so if it is the first statement after the specification + block. */ + +match +gfc_match_ptr_fcn_assign (void) +{ + gfc_error_buffer old_error; + locus old_loc; + gfc_symbol *sym; + gfc_expr *expr; + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + old_loc = gfc_current_locus; + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + gfc_find_symbol (name, NULL, 1, &sym); + if (sym && sym->attr.flavor != FL_PROCEDURE) + return MATCH_NO; + + gfc_push_error (&old_error); + + if (sym && sym->attr.function) + goto match_actual_arglist; + + gfc_current_locus = old_loc; + m = gfc_match_symbol (&sym, 0); + if (m != MATCH_YES) + return m; + + if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL)) + goto undo_error; + +match_actual_arglist: + gfc_current_locus = old_loc; + m = gfc_match (" %e", &expr); + if (m != MATCH_YES) + goto undo_error; + + new_st.op = EXEC_ASSIGN; + new_st.expr1 = expr; + expr = NULL; + + m = gfc_match (" = %e%t", &expr); + if (m != MATCH_YES) + goto undo_error; + + new_st.expr2 = expr; + return MATCH_YES; + +undo_error: + gfc_pop_error (&old_error); + return MATCH_NO; +} + + +/***************** SELECT CASE subroutines ******************/ + +/* Free a single case structure. */ + +static void +free_case (gfc_case *p) +{ + if (p->low == p->high) + p->high = NULL; + gfc_free_expr (p->low); + gfc_free_expr (p->high); + free (p); +} + + +/* Free a list of case structures. */ + +void +gfc_free_case_list (gfc_case *p) +{ + gfc_case *q; + + for (; p; p = q) + { + q = p->next; + free_case (p); + } +} + + +/* Match a single case selector. Combining the requirements of F08:C830 + and F08:C832 (R838) means that the case-value must have either CHARACTER, + INTEGER, or LOGICAL type. */ + +static match +match_case_selector (gfc_case **cp) +{ + gfc_case *c; + match m; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + if (gfc_match_char (':') == MATCH_YES) + { + m = gfc_match_init_expr (&c->high); + if (m == MATCH_NO) + goto need_expr; + if (m == MATCH_ERROR) + goto cleanup; + + if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER + && c->high->ts.type != BT_CHARACTER) + { + gfc_error ("Expression in CASE selector at %L cannot be %s", + &c->high->where, gfc_typename (&c->high->ts)); + goto cleanup; + } + } + else + { + m = gfc_match_init_expr (&c->low); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto need_expr; + + if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER + && c->low->ts.type != BT_CHARACTER) + { + gfc_error ("Expression in CASE selector at %L cannot be %s", + &c->low->where, gfc_typename (&c->low->ts)); + goto cleanup; + } + + /* If we're not looking at a ':' now, make a range out of a single + target. Else get the upper bound for the case range. */ + if (gfc_match_char (':') != MATCH_YES) + c->high = c->low; + else + { + m = gfc_match_init_expr (&c->high); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES + && c->high->ts.type != BT_LOGICAL + && c->high->ts.type != BT_INTEGER + && c->high->ts.type != BT_CHARACTER) + { + gfc_error ("Expression in CASE selector at %L cannot be %s", + &c->high->where, gfc_typename (c->high)); + goto cleanup; + } + /* MATCH_NO is fine. It's OK if nothing is there! */ + } + } + + if (c->low && c->low->rank != 0) + { + gfc_error ("Expression in CASE selector at %L must be scalar", + &c->low->where); + goto cleanup; + } + if (c->high && c->high->rank != 0) + { + gfc_error ("Expression in CASE selector at %L must be scalar", + &c->high->where); + goto cleanup; + } + + *cp = c; + return MATCH_YES; + +need_expr: + gfc_error ("Expected initialization expression in CASE at %C"); + +cleanup: + free_case (c); + return MATCH_ERROR; +} + + +/* Match the end of a case statement. */ + +static match +match_case_eos (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + /* If the case construct doesn't have a case-construct-name, we + should have matched the EOS. */ + if (!gfc_current_block ()) + return MATCH_NO; + + gfc_gobble_whitespace (); + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Expected block name %qs of SELECT construct at %C", + gfc_current_block ()->name); + return MATCH_ERROR; + } + + return gfc_match_eos (); +} + + +/* Match a SELECT statement. */ + +match +gfc_match_select (void) +{ + gfc_expr *expr; + match m; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select case ( %e )%t", &expr); + if (m != MATCH_YES) + return m; + + new_st.op = EXEC_SELECT; + new_st.expr1 = expr; + + return MATCH_YES; +} + + +/* Transfer the selector typespec to the associate name. */ + +static void +copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) +{ + gfc_ref *ref; + gfc_symbol *assoc_sym; + int rank = 0; + + assoc_sym = associate->symtree->n.sym; + + /* At this stage the expression rank and arrayspec dimensions have + not been completely sorted out. We must get the expr2->rank + right here, so that the correct class container is obtained. */ + ref = selector->ref; + while (ref && ref->next) + ref = ref->next; + + if (selector->ts.type == BT_CLASS + && CLASS_DATA (selector) + && CLASS_DATA (selector)->as + && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK) + { + assoc_sym->attr.dimension = 1; + assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); + goto build_class_sym; + } + else if (selector->ts.type == BT_CLASS + && CLASS_DATA (selector) + && CLASS_DATA (selector)->as + && ref && ref->type == REF_ARRAY) + { + /* Ensure that the array reference type is set. We cannot use + gfc_resolve_expr at this point, so the usable parts of + resolve.c(resolve_array_ref) are employed to do it. */ + if (ref->u.ar.type == AR_UNKNOWN) + { + ref->u.ar.type = AR_ELEMENT; + for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_RANGE + || ref->u.ar.dimen_type[i] == DIMEN_VECTOR + || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN + && ref->u.ar.start[i] && ref->u.ar.start[i]->rank)) + { + ref->u.ar.type = AR_SECTION; + break; + } + } + + if (ref->u.ar.type == AR_FULL) + selector->rank = CLASS_DATA (selector)->as->rank; + else if (ref->u.ar.type == AR_SECTION) + selector->rank = ref->u.ar.dimen; + else + selector->rank = 0; + + rank = selector->rank; + } + + if (rank) + { + for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT + || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN + && ref->u.ar.end[i] == NULL + && ref->u.ar.stride[i] == NULL)) + rank--; + + if (rank) + { + assoc_sym->attr.dimension = 1; + assoc_sym->as = gfc_get_array_spec (); + assoc_sym->as->rank = rank; + assoc_sym->as->type = AS_DEFERRED; + } + else + assoc_sym->as = NULL; + } + else + assoc_sym->as = NULL; + +build_class_sym: + if (selector->ts.type == BT_CLASS) + { + /* The correct class container has to be available. */ + assoc_sym->ts.type = BT_CLASS; + assoc_sym->ts.u.derived = CLASS_DATA (selector) + ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived; + assoc_sym->attr.pointer = 1; + gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); + } +} + + +/* Push the current selector onto the SELECT TYPE stack. */ + +static void +select_type_push (gfc_symbol *sel) +{ + gfc_select_type_stack *top = gfc_get_select_type_stack (); + top->selector = sel; + top->tmp = NULL; + top->prev = select_type_stack; + + select_type_stack = top; +} + + +/* Set the temporary for the current intrinsic SELECT TYPE selector. */ + +static gfc_symtree * +select_intrinsic_set_tmp (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + HOST_WIDE_INT charlen = 0; + gfc_symbol *selector = select_type_stack->selector; + gfc_symbol *sym; + + if (ts->type == BT_CLASS || ts->type == BT_DERIVED) + return NULL; + + if (selector->ts.type == BT_CLASS && !selector->attr.class_ok) + return NULL; + + /* Case value == NULL corresponds to SELECT TYPE cases otherwise + the values correspond to SELECT rank cases. */ + if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); + + if (ts->type != BT_CHARACTER) + sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), + ts->kind); + else + snprintf (name, sizeof (name), + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (ts->type), charlen, ts->kind); + + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + sym = tmp->n.sym; + gfc_add_type (sym, ts, NULL); + + /* Copy across the array spec to the selector. */ + if (selector->ts.type == BT_CLASS + && (CLASS_DATA (selector)->attr.dimension + || CLASS_DATA (selector)->attr.codimension)) + { + sym->attr.pointer = 1; + sym->attr.dimension = CLASS_DATA (selector)->attr.dimension; + sym->attr.codimension = CLASS_DATA (selector)->attr.codimension; + sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); + } + + gfc_set_sym_referenced (sym); + gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); + sym->attr.select_type_temporary = 1; + + return tmp; +} + + +/* Set up a temporary for the current TYPE IS / CLASS IS branch . */ + +static void +select_type_set_tmp (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; + gfc_symtree *tmp = NULL; + gfc_symbol *selector = select_type_stack->selector; + gfc_symbol *sym; + + if (!ts) + { + select_type_stack->tmp = NULL; + return; + } + + tmp = select_intrinsic_set_tmp (ts); + + if (tmp == NULL) + { + if (!ts->u.derived) + return; + + if (ts->type == BT_CLASS) + sprintf (name, "__tmp_class_%s", ts->u.derived->name); + else + sprintf (name, "__tmp_type_%s", ts->u.derived->name); + + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + sym = tmp->n.sym; + gfc_add_type (sym, ts, NULL); + + if (selector->ts.type == BT_CLASS && selector->attr.class_ok + && selector->ts.u.derived && CLASS_DATA (selector)) + { + sym->attr.pointer + = CLASS_DATA (selector)->attr.class_pointer; + + /* Copy across the array spec to the selector. */ + if (CLASS_DATA (selector)->attr.dimension + || CLASS_DATA (selector)->attr.codimension) + { + sym->attr.dimension + = CLASS_DATA (selector)->attr.dimension; + sym->attr.codimension + = CLASS_DATA (selector)->attr.codimension; + if (CLASS_DATA (selector)->as->type != AS_EXPLICIT) + sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); + else + { + sym->as = gfc_get_array_spec(); + sym->as->rank = CLASS_DATA (selector)->as->rank; + sym->as->type = AS_DEFERRED; + } + } + } + + gfc_set_sym_referenced (sym); + gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); + sym->attr.select_type_temporary = 1; + + if (ts->type == BT_CLASS) + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); + } + else + sym = tmp->n.sym; + + + /* Add an association for it, so the rest of the parser knows it is + an associate-name. The target will be set during resolution. */ + sym->assoc = gfc_get_association_list (); + sym->assoc->dangling = 1; + sym->assoc->st = tmp; + + select_type_stack->tmp = tmp; +} + + +/* Match a SELECT TYPE statement. */ + +match +gfc_match_select_type (void) +{ + gfc_expr *expr1, *expr2 = NULL; + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + bool class_array; + gfc_symbol *sym; + gfc_namespace *ns = gfc_current_ns; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select type ( "); + if (m != MATCH_YES) + return m; + + if (gfc_current_state() == COMP_MODULE + || gfc_current_state() == COMP_SUBMODULE) + { + gfc_error ("SELECT TYPE at %C cannot appear in this scope"); + return MATCH_ERROR; + } + + gfc_current_ns = gfc_build_block_ns (ns); + m = gfc_match (" %n => %e", name, &expr2); + if (m == MATCH_YES) + { + expr1 = gfc_get_expr (); + expr1->expr_type = EXPR_VARIABLE; + expr1->where = expr2->where; + if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + { + m = MATCH_ERROR; + goto cleanup; + } + + sym = expr1->symtree->n.sym; + if (expr2->ts.type == BT_UNKNOWN) + sym->attr.untyped = 1; + else + copy_ts_from_selector_to_associate (expr1, expr2); + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = 1; + } + else + { + m = gfc_match (" %e ", &expr1); + if (m != MATCH_YES) + { + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); + return m; + } + } + + m = gfc_match (" )%t"); + if (m != MATCH_YES) + { + gfc_error ("parse error in SELECT TYPE statement at %C"); + goto cleanup; + } + + /* This ghastly expression seems to be needed to distinguish a CLASS + array, which can have a reference, from other expressions that + have references, such as derived type components, and are not + allowed by the standard. + TODO: see if it is sufficient to exclude component and substring + references. */ + class_array = (expr1->expr_type == EXPR_VARIABLE + && expr1->ts.type == BT_CLASS + && CLASS_DATA (expr1) + && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) + && (CLASS_DATA (expr1)->attr.dimension + || CLASS_DATA (expr1)->attr.codimension) + && expr1->ref + && expr1->ref->type == REF_ARRAY + && expr1->ref->u.ar.type == AR_FULL + && expr1->ref->next == NULL); + + /* Check for F03:C811 (F08:C835). */ + if (!expr2 && (expr1->expr_type != EXPR_VARIABLE + || (!class_array && expr1->ref != NULL))) + { + gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " + "use associate-name=>"); + m = MATCH_ERROR; + goto cleanup; + } + + new_st.op = EXEC_SELECT_TYPE; + new_st.expr1 = expr1; + new_st.expr2 = expr2; + new_st.ext.block.ns = gfc_current_ns; + + select_type_push (expr1->symtree->n.sym); + gfc_current_ns = ns; + + return MATCH_YES; + +cleanup: + gfc_free_expr (expr1); + gfc_free_expr (expr2); + gfc_undo_symbols (); + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); + return m; +} + + +/* Set the temporary for the current intrinsic SELECT RANK selector. */ + +static void +select_rank_set_tmp (gfc_typespec *ts, int *case_value) +{ + char name[2 * GFC_MAX_SYMBOL_LEN]; + char tname[GFC_MAX_SYMBOL_LEN + 7]; + gfc_symtree *tmp; + gfc_symbol *selector = select_type_stack->selector; + gfc_symbol *sym; + gfc_symtree *st; + HOST_WIDE_INT charlen = 0; + + if (case_value == NULL) + return; + + if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); + + if (ts->type == BT_CLASS) + sprintf (tname, "class_%s", ts->u.derived->name); + else if (ts->type == BT_DERIVED) + sprintf (tname, "type_%s", ts->u.derived->name); + else if (ts->type != BT_CHARACTER) + sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind); + else + sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (ts->type), charlen, ts->kind); + + /* Case value == NULL corresponds to SELECT TYPE cases otherwise + the values correspond to SELECT rank cases. */ + if (*case_value >=0) + sprintf (name, "__tmp_%s_rank_%d", tname, *case_value); + else + sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value); + + gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + if (st) + return; + + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + sym = tmp->n.sym; + gfc_add_type (sym, ts, NULL); + + /* Copy across the array spec to the selector. */ + if (selector->ts.type == BT_CLASS) + { + sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; + sym->attr.pointer = CLASS_DATA (selector)->attr.pointer; + sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable; + sym->attr.target = CLASS_DATA (selector)->attr.target; + sym->attr.class_ok = 0; + if (case_value && *case_value != 0) + { + sym->attr.dimension = 1; + sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); + if (*case_value > 0) + { + sym->as->type = AS_DEFERRED; + sym->as->rank = *case_value; + } + else if (*case_value == -1) + { + sym->as->type = AS_ASSUMED_SIZE; + sym->as->rank = 1; + } + } + } + else + { + sym->attr.pointer = selector->attr.pointer; + sym->attr.allocatable = selector->attr.allocatable; + sym->attr.target = selector->attr.target; + if (case_value && *case_value != 0) + { + sym->attr.dimension = 1; + sym->as = gfc_copy_array_spec (selector->as); + if (*case_value > 0) + { + sym->as->type = AS_DEFERRED; + sym->as->rank = *case_value; + } + else if (*case_value == -1) + { + sym->as->type = AS_ASSUMED_SIZE; + sym->as->rank = 1; + } + } + } + + gfc_set_sym_referenced (sym); + gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); + sym->attr.select_type_temporary = 1; + if (case_value) + sym->attr.select_rank_temporary = 1; + + if (ts->type == BT_CLASS) + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); + + /* Add an association for it, so the rest of the parser knows it is + an associate-name. The target will be set during resolution. */ + sym->assoc = gfc_get_association_list (); + sym->assoc->dangling = 1; + sym->assoc->st = tmp; + + select_type_stack->tmp = tmp; +} + + +/* Match a SELECT RANK statement. */ + +match +gfc_match_select_rank (void) +{ + gfc_expr *expr1, *expr2 = NULL; + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym, *sym2; + gfc_namespace *ns = gfc_current_ns; + gfc_array_spec *as = NULL; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select rank ( "); + if (m != MATCH_YES) + return m; + + if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C")) + return MATCH_NO; + + gfc_current_ns = gfc_build_block_ns (ns); + m = gfc_match (" %n => %e", name, &expr2); + if (m == MATCH_YES) + { + expr1 = gfc_get_expr (); + expr1->expr_type = EXPR_VARIABLE; + expr1->where = expr2->where; + expr1->ref = gfc_copy_ref (expr2->ref); + if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + { + m = MATCH_ERROR; + goto cleanup; + } + + sym = expr1->symtree->n.sym; + + if (expr2->symtree) + { + sym2 = expr2->symtree->n.sym; + as = (sym2->ts.type == BT_CLASS + && CLASS_DATA (sym2)) ? CLASS_DATA (sym2)->as : sym2->as; + } + + if (expr2->expr_type != EXPR_VARIABLE + || !(as && as->type == AS_ASSUMED_RANK)) + { + gfc_error ("The SELECT RANK selector at %C must be an assumed " + "rank variable"); + m = MATCH_ERROR; + goto cleanup; + } + + if (expr2->ts.type == BT_CLASS && CLASS_DATA (sym2)) + { + copy_ts_from_selector_to_associate (expr1, expr2); + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = 1; + CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable; + CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer; + CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target; + sym->attr.pointer = 1; + } + else + { + sym->ts = sym2->ts; + sym->as = gfc_copy_array_spec (sym2->as); + sym->attr.dimension = 1; + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = sym2->attr.class_ok; + sym->attr.allocatable = sym2->attr.allocatable; + sym->attr.pointer = sym2->attr.pointer; + sym->attr.target = sym2->attr.target; + } + } + else + { + m = gfc_match (" %e ", &expr1); + + if (m != MATCH_YES) + { + gfc_undo_symbols (); + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); + return m; + } + + if (expr1->symtree) + { + sym = expr1->symtree->n.sym; + as = (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)) ? CLASS_DATA (sym)->as : sym->as; + } + + if (expr1->expr_type != EXPR_VARIABLE + || !(as && as->type == AS_ASSUMED_RANK)) + { + gfc_error("The SELECT RANK selector at %C must be an assumed " + "rank variable"); + m = MATCH_ERROR; + goto cleanup; + } + } + + m = gfc_match (" )%t"); + if (m != MATCH_YES) + { + gfc_error ("parse error in SELECT RANK statement at %C"); + goto cleanup; + } + + new_st.op = EXEC_SELECT_RANK; + new_st.expr1 = expr1; + new_st.expr2 = expr2; + new_st.ext.block.ns = gfc_current_ns; + + select_type_push (expr1->symtree->n.sym); + gfc_current_ns = ns; + + return MATCH_YES; + +cleanup: + gfc_free_expr (expr1); + gfc_free_expr (expr2); + gfc_undo_symbols (); + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); + return m; +} + + +/* Match a CASE statement. */ + +match +gfc_match_case (void) +{ + gfc_case *c, *head, *tail; + match m; + + head = tail = NULL; + + if (gfc_current_state () != COMP_SELECT) + { + gfc_error ("Unexpected CASE statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT; + c = gfc_get_case (); + c->where = gfc_current_locus; + new_st.ext.block.case_list = c; + return MATCH_YES; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) + { + if (match_case_selector (&c) == MATCH_ERROR) + goto cleanup; + + if (head == NULL) + head = c; + else + tail->next = c; + + tail = c; + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT; + new_st.ext.block.case_list = head; + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in CASE specification at %C"); + +cleanup: + gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + +/* Match a TYPE IS statement. */ + +match +gfc_match_type_is (void) +{ + gfc_case *c = NULL; + match m; + + if (gfc_current_state () != COMP_SELECT_TYPE) + { + gfc_error ("Unexpected TYPE IS statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + m = gfc_match_type_spec (&c->ts); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.block.case_list = c; + + if (c->ts.type == BT_DERIVED && c->ts.u.derived + && (c->ts.u.derived->attr.sequence + || c->ts.u.derived->attr.is_bind_c)) + { + gfc_error ("The type-spec shall not specify a sequence derived " + "type or a type with the BIND attribute in SELECT " + "TYPE at %C [F2003:C815]"); + return MATCH_ERROR; + } + + if (c->ts.type == BT_DERIVED + && c->ts.u.derived && c->ts.u.derived->attr.pdt_type + && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived) + != SPEC_ASSUMED) + { + gfc_error ("All the LEN type parameters in the TYPE IS statement " + "at %C must be ASSUMED"); + return MATCH_ERROR; + } + + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in TYPE IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + +/* Match a CLASS IS or CLASS DEFAULT statement. */ + +match +gfc_match_class_is (void) +{ + gfc_case *c = NULL; + match m; + + if (gfc_current_state () != COMP_SELECT_TYPE) + return MATCH_NO; + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + c = gfc_get_case (); + c->where = gfc_current_locus; + c->ts.type = BT_UNKNOWN; + new_st.ext.block.case_list = c; + select_type_set_tmp (NULL); + return MATCH_YES; + } + + m = gfc_match ("% is"); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + m = match_derived_type_spec (&c->ts); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (c->ts.type == BT_DERIVED) + c->ts.type = BT_CLASS; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.block.case_list = c; + + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in CLASS IS specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + + +/* Match a RANK statement. */ + +match +gfc_match_rank_is (void) +{ + gfc_case *c = NULL; + match m; + int case_value; + + if (gfc_current_state () != COMP_SELECT_RANK) + { + gfc_error ("Unexpected RANK statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_RANK; + c = gfc_get_case (); + c->ts.type = BT_UNKNOWN; + c->where = gfc_current_locus; + new_st.ext.block.case_list = c; + select_type_stack->tmp = NULL; + return MATCH_YES; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + c->ts = select_type_stack->selector->ts; + + m = gfc_match_expr (&c->low); + if (m == MATCH_NO) + { + if (gfc_match_char ('*') == MATCH_YES) + c->low = gfc_get_int_expr (gfc_default_integer_kind, + NULL, -1); + else + goto syntax; + + case_value = -1; + } + else if (m == MATCH_YES) + { + /* F2018: R1150 */ + if (c->low->expr_type != EXPR_CONSTANT + || c->low->ts.type != BT_INTEGER + || c->low->rank) + { + gfc_error ("The SELECT RANK CASE expression at %C must be a " + "scalar, integer constant"); + goto cleanup; + } + + case_value = (int) mpz_get_si (c->low->value.integer); + /* F2018: C1151 */ + if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS)) + { + gfc_error ("The value of the SELECT RANK CASE expression at " + "%C must not be less than zero or greater than %d", + GFC_MAX_DIMENSIONS); + goto cleanup; + } + } + else + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_RANK; + new_st.ext.block.case_list = c; + + /* Create temporary variable. Recycle the select type code. */ + select_rank_set_tmp (&c->ts, &case_value); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in RANK specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + +/********************* WHERE subroutines ********************/ + +/* Match the rest of a simple WHERE statement that follows an IF statement. + */ + +static match +match_simple_where (void) +{ + gfc_expr *expr; + gfc_code *c; + match m; + + m = gfc_match (" ( %e )", &expr); + if (m != MATCH_YES) + return m; + + m = gfc_match_assignment (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + c = gfc_get_code (EXEC_WHERE); + c->expr1 = expr; + + c->next = XCNEW (gfc_code); + *c->next = new_st; + c->next->loc = gfc_current_locus; + gfc_clear_new_st (); + + new_st.op = EXEC_WHERE; + new_st.block = c; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_WHERE); + +cleanup: + gfc_free_expr (expr); + return MATCH_ERROR; +} + + +/* Match a WHERE statement. */ + +match +gfc_match_where (gfc_statement *st) +{ + gfc_expr *expr; + match m0, m; + gfc_code *c; + + m0 = gfc_match_label (); + if (m0 == MATCH_ERROR) + return m0; + + m = gfc_match (" where ( %e )", &expr); + if (m != MATCH_YES) + return m; + + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_WHERE_BLOCK; + new_st.op = EXEC_WHERE; + new_st.expr1 = expr; + return MATCH_YES; + } + + m = gfc_match_assignment (); + if (m == MATCH_NO) + gfc_syntax_error (ST_WHERE); + + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + /* We've got a simple WHERE statement. */ + *st = ST_WHERE; + c = gfc_get_code (EXEC_WHERE); + c->expr1 = expr; + + /* Put in the assignment. It will not be processed by add_statement, so we + need to copy the location here. */ + + c->next = XCNEW (gfc_code); + *c->next = new_st; + c->next->loc = gfc_current_locus; + gfc_clear_new_st (); + + new_st.op = EXEC_WHERE; + new_st.block = c; + + return MATCH_YES; +} + + +/* Match an ELSEWHERE statement. We leave behind a WHERE node in + new_st if successful. */ + +match +gfc_match_elsewhere (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *expr; + match m; + + if (gfc_current_state () != COMP_WHERE) + { + gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); + return MATCH_ERROR; + } + + expr = NULL; + + if (gfc_match_char ('(') == MATCH_YES) + { + m = gfc_match_expr (&expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + } + + if (gfc_match_eos () != MATCH_YES) + { + /* Only makes sense if we have a where-construct-name. */ + if (!gfc_current_block ()) + { + m = MATCH_ERROR; + goto cleanup; + } + /* Better be a name at this point. */ + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Label %qs at %C doesn't match WHERE label %qs", + name, gfc_current_block ()->name); + goto cleanup; + } + } + + new_st.op = EXEC_WHERE; + new_st.expr1 = expr; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_ELSEWHERE); + +cleanup: + gfc_free_expr (expr); + return MATCH_ERROR; +} diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c deleted file mode 100644 index a582f5c..0000000 --- a/gcc/fortran/matchexp.c +++ /dev/null @@ -1,903 +0,0 @@ -/* Expression parser. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "arith.h" -#include "match.h" - -static const char expression_syntax[] = N_("Syntax error in expression at %C"); - - -/* Match a user-defined operator name. This is a normal name with a - few restrictions. The error_flag controls whether an error is - raised if 'true' or 'false' are used or not. */ - -match -gfc_match_defined_op_name (char *result, int error_flag) -{ - static const char * const badops[] = { - "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt", - NULL - }; - - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_loc; - match m; - int i; - - old_loc = gfc_current_locus; - - m = gfc_match (" . %n .", name); - if (m != MATCH_YES) - return m; - - /* .true. and .false. have interpretations as constants. Trying to - use these as operators will fail at a later time. */ - - if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0) - { - if (error_flag) - goto error; - gfc_current_locus = old_loc; - return MATCH_NO; - } - - for (i = 0; badops[i]; i++) - if (strcmp (badops[i], name) == 0) - goto error; - - for (i = 0; name[i]; i++) - if (!ISALPHA (name[i])) - { - gfc_error ("Bad character %qc in OPERATOR name at %C", name[i]); - return MATCH_ERROR; - } - - strcpy (result, name); - return MATCH_YES; - -error: - gfc_error ("The name %qs cannot be used as a defined operator at %C", - name); - - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - - -/* Match a user defined operator. The symbol found must be an - operator already. */ - -static match -match_defined_operator (gfc_user_op **result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - match m; - - m = gfc_match_defined_op_name (name, 0); - if (m != MATCH_YES) - return m; - - *result = gfc_get_uop (name); - return MATCH_YES; -} - - -/* Check to see if the given operator is next on the input. If this - is not the case, the parse pointer remains where it was. */ - -static int -next_operator (gfc_intrinsic_op t) -{ - gfc_intrinsic_op u; - locus old_loc; - - old_loc = gfc_current_locus; - if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u) - return 1; - - gfc_current_locus = old_loc; - return 0; -} - - -/* Call the INTRINSIC_PARENTHESES function. This is both - used explicitly, as below, or by resolve.c to generate - temporaries. */ - -gfc_expr * -gfc_get_parentheses (gfc_expr *e) -{ - gfc_expr *e2; - - e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL); - e2->ts = e->ts; - e2->rank = e->rank; - - return e2; -} - - -/* Match a primary expression. */ - -static match -match_primary (gfc_expr **result) -{ - match m; - gfc_expr *e; - - m = gfc_match_literal_constant (result, 0); - if (m != MATCH_NO) - return m; - - m = gfc_match_array_constructor (result); - if (m != MATCH_NO) - return m; - - m = gfc_match_rvalue (result); - if (m != MATCH_NO) - return m; - - /* Match an expression in parentheses. */ - if (gfc_match_char ('(') != MATCH_YES) - return MATCH_NO; - - m = gfc_match_expr (&e); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - return m; - - m = gfc_match_char (')'); - if (m == MATCH_NO) - gfc_error ("Expected a right parenthesis in expression at %C"); - - /* Now we have the expression inside the parentheses, build the - expression pointing to it. By 7.1.7.2, any expression in - parentheses shall be treated as a data entity. */ - *result = gfc_get_parentheses (e); - - if (m != MATCH_YES) - { - gfc_free_expr (*result); - return MATCH_ERROR; - } - - return MATCH_YES; - -syntax: - gfc_error (expression_syntax); - return MATCH_ERROR; -} - - -/* Match a level 1 expression. */ - -static match -match_level_1 (gfc_expr **result) -{ - gfc_user_op *uop; - gfc_expr *e, *f; - locus where; - match m; - - gfc_gobble_whitespace (); - where = gfc_current_locus; - uop = NULL; - m = match_defined_operator (&uop); - if (m == MATCH_ERROR) - return m; - - m = match_primary (&e); - if (m != MATCH_YES) - return m; - - if (uop == NULL) - *result = e; - else - { - f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL); - f->value.op.uop = uop; - *result = f; - } - - return MATCH_YES; -} - - -/* As a GNU extension we support an expanded level-2 expression syntax. - Via this extension we support (arbitrary) nesting of unary plus and - minus operations following unary and binary operators, such as **. - The grammar of section 7.1.1.3 is effectively rewritten as: - - R704 mult-operand is level-1-expr [ power-op ext-mult-operand ] - R704' ext-mult-operand is add-op ext-mult-operand - or mult-operand - R705 add-operand is add-operand mult-op ext-mult-operand - or mult-operand - R705' ext-add-operand is add-op ext-add-operand - or add-operand - R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand - or add-operand - */ - -static match match_ext_mult_operand (gfc_expr **result); -static match match_ext_add_operand (gfc_expr **result); - -static int -match_add_op (void) -{ - if (next_operator (INTRINSIC_MINUS)) - return -1; - if (next_operator (INTRINSIC_PLUS)) - return 1; - return 0; -} - - -static match -match_mult_operand (gfc_expr **result) -{ - /* Workaround -Wmaybe-uninitialized false positive during - profiledbootstrap by initializing them. */ - gfc_expr *e = NULL, *exp, *r; - locus where; - match m; - - m = match_level_1 (&e); - if (m != MATCH_YES) - return m; - - if (!next_operator (INTRINSIC_POWER)) - { - *result = e; - return MATCH_YES; - } - - where = gfc_current_locus; - - m = match_ext_mult_operand (&exp); - if (m == MATCH_NO) - gfc_error ("Expected exponent in expression at %C"); - if (m != MATCH_YES) - { - gfc_free_expr (e); - return MATCH_ERROR; - } - - r = gfc_power (e, exp); - if (r == NULL) - { - gfc_free_expr (e); - gfc_free_expr (exp); - return MATCH_ERROR; - } - - r->where = where; - *result = r; - - return MATCH_YES; -} - - -static match -match_ext_mult_operand (gfc_expr **result) -{ - gfc_expr *all, *e; - locus where; - match m; - int i; - - where = gfc_current_locus; - i = match_add_op (); - - if (i == 0) - return match_mult_operand (result); - - if (gfc_notification_std (GFC_STD_GNU) == ERROR) - { - gfc_error ("Extension: Unary operator following " - "arithmetic operator (use parentheses) at %C"); - return MATCH_ERROR; - } - else - gfc_warning (0, "Extension: Unary operator following " - "arithmetic operator (use parentheses) at %C"); - - m = match_ext_mult_operand (&e); - if (m != MATCH_YES) - return m; - - if (i == -1) - all = gfc_uminus (e); - else - all = gfc_uplus (e); - - if (all == NULL) - { - gfc_free_expr (e); - return MATCH_ERROR; - } - - all->where = where; - *result = all; - return MATCH_YES; -} - - -static match -match_add_operand (gfc_expr **result) -{ - gfc_expr *all, *e, *total; - locus where, old_loc; - match m; - gfc_intrinsic_op i; - - m = match_mult_operand (&all); - if (m != MATCH_YES) - return m; - - for (;;) - { - /* Build up a string of products or quotients. */ - - old_loc = gfc_current_locus; - - if (next_operator (INTRINSIC_TIMES)) - i = INTRINSIC_TIMES; - else - { - if (next_operator (INTRINSIC_DIVIDE)) - i = INTRINSIC_DIVIDE; - else - break; - } - - where = gfc_current_locus; - - m = match_ext_mult_operand (&e); - if (m == MATCH_NO) - { - gfc_current_locus = old_loc; - break; - } - - if (m == MATCH_ERROR) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - if (i == INTRINSIC_TIMES) - total = gfc_multiply (all, e); - else - total = gfc_divide (all, e); - - if (total == NULL) - { - gfc_free_expr (all); - gfc_free_expr (e); - return MATCH_ERROR; - } - - all = total; - all->where = where; - } - - *result = all; - return MATCH_YES; -} - - -static match -match_ext_add_operand (gfc_expr **result) -{ - gfc_expr *all, *e; - locus where; - match m; - int i; - - where = gfc_current_locus; - i = match_add_op (); - - if (i == 0) - return match_add_operand (result); - - if (gfc_notification_std (GFC_STD_GNU) == ERROR) - { - gfc_error ("Extension: Unary operator following " - "arithmetic operator (use parentheses) at %C"); - return MATCH_ERROR; - } - else - gfc_warning (0, "Extension: Unary operator following " - "arithmetic operator (use parentheses) at %C"); - - m = match_ext_add_operand (&e); - if (m != MATCH_YES) - return m; - - if (i == -1) - all = gfc_uminus (e); - else - all = gfc_uplus (e); - - if (all == NULL) - { - gfc_free_expr (e); - return MATCH_ERROR; - } - - all->where = where; - *result = all; - return MATCH_YES; -} - - -/* Match a level 2 expression. */ - -static match -match_level_2 (gfc_expr **result) -{ - gfc_expr *all, *e, *total; - locus where; - match m; - int i; - - where = gfc_current_locus; - i = match_add_op (); - - if (i != 0) - { - m = match_ext_add_operand (&e); - if (m == MATCH_NO) - { - gfc_error (expression_syntax); - m = MATCH_ERROR; - } - } - else - m = match_add_operand (&e); - - if (m != MATCH_YES) - return m; - - if (i == 0) - all = e; - else - { - if (i == -1) - all = gfc_uminus (e); - else - all = gfc_uplus (e); - - if (all == NULL) - { - gfc_free_expr (e); - return MATCH_ERROR; - } - } - - all->where = where; - - /* Append add-operands to the sum. */ - - for (;;) - { - where = gfc_current_locus; - i = match_add_op (); - if (i == 0) - break; - - m = match_ext_add_operand (&e); - if (m == MATCH_NO) - gfc_error (expression_syntax); - if (m != MATCH_YES) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - if (i == -1) - total = gfc_subtract (all, e); - else - total = gfc_add (all, e); - - if (total == NULL) - { - gfc_free_expr (all); - gfc_free_expr (e); - return MATCH_ERROR; - } - - all = total; - all->where = where; - } - - *result = all; - return MATCH_YES; -} - - -/* Match a level three expression. */ - -static match -match_level_3 (gfc_expr **result) -{ - gfc_expr *all, *e, *total = NULL; - locus where; - match m; - - m = match_level_2 (&all); - if (m != MATCH_YES) - return m; - - for (;;) - { - if (!next_operator (INTRINSIC_CONCAT)) - break; - - where = gfc_current_locus; - - m = match_level_2 (&e); - if (m == MATCH_NO) - gfc_error (expression_syntax); - if (m != MATCH_YES) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - total = gfc_concat (all, e); - if (total == NULL) - { - gfc_free_expr (all); - gfc_free_expr (e); - return MATCH_ERROR; - } - - all = total; - all->where = where; - } - - *result = all; - return MATCH_YES; -} - - -/* Match a level 4 expression. */ - -static match -match_level_4 (gfc_expr **result) -{ - gfc_expr *left, *right, *r; - gfc_intrinsic_op i; - locus old_loc; - locus where; - match m; - - m = match_level_3 (&left); - if (m != MATCH_YES) - return m; - - old_loc = gfc_current_locus; - - if (gfc_match_intrinsic_op (&i) != MATCH_YES) - { - *result = left; - return MATCH_YES; - } - - if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE - && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT - && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS - && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS) - { - gfc_current_locus = old_loc; - *result = left; - return MATCH_YES; - } - - where = gfc_current_locus; - - m = match_level_3 (&right); - if (m == MATCH_NO) - gfc_error (expression_syntax); - if (m != MATCH_YES) - { - gfc_free_expr (left); - return MATCH_ERROR; - } - - switch (i) - { - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - r = gfc_eq (left, right, i); - break; - - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - r = gfc_ne (left, right, i); - break; - - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - r = gfc_lt (left, right, i); - break; - - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - r = gfc_le (left, right, i); - break; - - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - r = gfc_gt (left, right, i); - break; - - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - r = gfc_ge (left, right, i); - break; - - default: - gfc_internal_error ("match_level_4(): Bad operator"); - } - - if (r == NULL) - { - gfc_free_expr (left); - gfc_free_expr (right); - return MATCH_ERROR; - } - - r->where = where; - *result = r; - - return MATCH_YES; -} - - -static match -match_and_operand (gfc_expr **result) -{ - gfc_expr *e, *r; - locus where; - match m; - int i; - - i = next_operator (INTRINSIC_NOT); - where = gfc_current_locus; - - m = match_level_4 (&e); - if (m != MATCH_YES) - return m; - - r = e; - if (i) - { - r = gfc_not (e); - if (r == NULL) - { - gfc_free_expr (e); - return MATCH_ERROR; - } - } - - r->where = where; - *result = r; - - return MATCH_YES; -} - - -static match -match_or_operand (gfc_expr **result) -{ - gfc_expr *all, *e, *total; - locus where; - match m; - - m = match_and_operand (&all); - if (m != MATCH_YES) - return m; - - for (;;) - { - if (!next_operator (INTRINSIC_AND)) - break; - where = gfc_current_locus; - - m = match_and_operand (&e); - if (m == MATCH_NO) - gfc_error (expression_syntax); - if (m != MATCH_YES) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - total = gfc_and (all, e); - if (total == NULL) - { - gfc_free_expr (all); - gfc_free_expr (e); - return MATCH_ERROR; - } - - all = total; - all->where = where; - } - - *result = all; - return MATCH_YES; -} - - -static match -match_equiv_operand (gfc_expr **result) -{ - gfc_expr *all, *e, *total; - locus where; - match m; - - m = match_or_operand (&all); - if (m != MATCH_YES) - return m; - - for (;;) - { - if (!next_operator (INTRINSIC_OR)) - break; - where = gfc_current_locus; - - m = match_or_operand (&e); - if (m == MATCH_NO) - gfc_error (expression_syntax); - if (m != MATCH_YES) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - total = gfc_or (all, e); - if (total == NULL) - { - gfc_free_expr (all); - gfc_free_expr (e); - return MATCH_ERROR; - } - - all = total; - all->where = where; - } - - *result = all; - return MATCH_YES; -} - - -/* Match a level 5 expression. */ - -static match -match_level_5 (gfc_expr **result) -{ - gfc_expr *all, *e, *total; - locus where; - match m; - gfc_intrinsic_op i; - - m = match_equiv_operand (&all); - if (m != MATCH_YES) - return m; - - for (;;) - { - if (next_operator (INTRINSIC_EQV)) - i = INTRINSIC_EQV; - else - { - if (next_operator (INTRINSIC_NEQV)) - i = INTRINSIC_NEQV; - else - break; - } - - where = gfc_current_locus; - - m = match_equiv_operand (&e); - if (m == MATCH_NO) - gfc_error (expression_syntax); - if (m != MATCH_YES) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - if (i == INTRINSIC_EQV) - total = gfc_eqv (all, e); - else - total = gfc_neqv (all, e); - - if (total == NULL) - { - gfc_free_expr (all); - gfc_free_expr (e); - return MATCH_ERROR; - } - - all = total; - all->where = where; - } - - *result = all; - return MATCH_YES; -} - - -/* Match an expression. At this level, we are stringing together - level 5 expressions separated by binary operators. */ - -match -gfc_match_expr (gfc_expr **result) -{ - gfc_expr *all, *e; - gfc_user_op *uop; - locus where; - match m; - - m = match_level_5 (&all); - if (m != MATCH_YES) - return m; - - for (;;) - { - uop = NULL; - m = match_defined_operator (&uop); - if (m == MATCH_NO) - break; - if (m == MATCH_ERROR) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - where = gfc_current_locus; - - m = match_level_5 (&e); - if (m == MATCH_NO) - gfc_error (expression_syntax); - if (m != MATCH_YES) - { - gfc_free_expr (all); - return MATCH_ERROR; - } - - all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e); - all->value.op.uop = uop; - } - - *result = all; - return MATCH_YES; -} diff --git a/gcc/fortran/matchexp.cc b/gcc/fortran/matchexp.cc new file mode 100644 index 0000000..a582f5c --- /dev/null +++ b/gcc/fortran/matchexp.cc @@ -0,0 +1,903 @@ +/* Expression parser. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "arith.h" +#include "match.h" + +static const char expression_syntax[] = N_("Syntax error in expression at %C"); + + +/* Match a user-defined operator name. This is a normal name with a + few restrictions. The error_flag controls whether an error is + raised if 'true' or 'false' are used or not. */ + +match +gfc_match_defined_op_name (char *result, int error_flag) +{ + static const char * const badops[] = { + "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt", + NULL + }; + + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_loc; + match m; + int i; + + old_loc = gfc_current_locus; + + m = gfc_match (" . %n .", name); + if (m != MATCH_YES) + return m; + + /* .true. and .false. have interpretations as constants. Trying to + use these as operators will fail at a later time. */ + + if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0) + { + if (error_flag) + goto error; + gfc_current_locus = old_loc; + return MATCH_NO; + } + + for (i = 0; badops[i]; i++) + if (strcmp (badops[i], name) == 0) + goto error; + + for (i = 0; name[i]; i++) + if (!ISALPHA (name[i])) + { + gfc_error ("Bad character %qc in OPERATOR name at %C", name[i]); + return MATCH_ERROR; + } + + strcpy (result, name); + return MATCH_YES; + +error: + gfc_error ("The name %qs cannot be used as a defined operator at %C", + name); + + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + + +/* Match a user defined operator. The symbol found must be an + operator already. */ + +static match +match_defined_operator (gfc_user_op **result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + m = gfc_match_defined_op_name (name, 0); + if (m != MATCH_YES) + return m; + + *result = gfc_get_uop (name); + return MATCH_YES; +} + + +/* Check to see if the given operator is next on the input. If this + is not the case, the parse pointer remains where it was. */ + +static int +next_operator (gfc_intrinsic_op t) +{ + gfc_intrinsic_op u; + locus old_loc; + + old_loc = gfc_current_locus; + if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u) + return 1; + + gfc_current_locus = old_loc; + return 0; +} + + +/* Call the INTRINSIC_PARENTHESES function. This is both + used explicitly, as below, or by resolve.c to generate + temporaries. */ + +gfc_expr * +gfc_get_parentheses (gfc_expr *e) +{ + gfc_expr *e2; + + e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL); + e2->ts = e->ts; + e2->rank = e->rank; + + return e2; +} + + +/* Match a primary expression. */ + +static match +match_primary (gfc_expr **result) +{ + match m; + gfc_expr *e; + + m = gfc_match_literal_constant (result, 0); + if (m != MATCH_NO) + return m; + + m = gfc_match_array_constructor (result); + if (m != MATCH_NO) + return m; + + m = gfc_match_rvalue (result); + if (m != MATCH_NO) + return m; + + /* Match an expression in parentheses. */ + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; + + m = gfc_match_expr (&e); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return m; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + gfc_error ("Expected a right parenthesis in expression at %C"); + + /* Now we have the expression inside the parentheses, build the + expression pointing to it. By 7.1.7.2, any expression in + parentheses shall be treated as a data entity. */ + *result = gfc_get_parentheses (e); + + if (m != MATCH_YES) + { + gfc_free_expr (*result); + return MATCH_ERROR; + } + + return MATCH_YES; + +syntax: + gfc_error (expression_syntax); + return MATCH_ERROR; +} + + +/* Match a level 1 expression. */ + +static match +match_level_1 (gfc_expr **result) +{ + gfc_user_op *uop; + gfc_expr *e, *f; + locus where; + match m; + + gfc_gobble_whitespace (); + where = gfc_current_locus; + uop = NULL; + m = match_defined_operator (&uop); + if (m == MATCH_ERROR) + return m; + + m = match_primary (&e); + if (m != MATCH_YES) + return m; + + if (uop == NULL) + *result = e; + else + { + f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL); + f->value.op.uop = uop; + *result = f; + } + + return MATCH_YES; +} + + +/* As a GNU extension we support an expanded level-2 expression syntax. + Via this extension we support (arbitrary) nesting of unary plus and + minus operations following unary and binary operators, such as **. + The grammar of section 7.1.1.3 is effectively rewritten as: + + R704 mult-operand is level-1-expr [ power-op ext-mult-operand ] + R704' ext-mult-operand is add-op ext-mult-operand + or mult-operand + R705 add-operand is add-operand mult-op ext-mult-operand + or mult-operand + R705' ext-add-operand is add-op ext-add-operand + or add-operand + R706 level-2-expr is [ level-2-expr ] add-op ext-add-operand + or add-operand + */ + +static match match_ext_mult_operand (gfc_expr **result); +static match match_ext_add_operand (gfc_expr **result); + +static int +match_add_op (void) +{ + if (next_operator (INTRINSIC_MINUS)) + return -1; + if (next_operator (INTRINSIC_PLUS)) + return 1; + return 0; +} + + +static match +match_mult_operand (gfc_expr **result) +{ + /* Workaround -Wmaybe-uninitialized false positive during + profiledbootstrap by initializing them. */ + gfc_expr *e = NULL, *exp, *r; + locus where; + match m; + + m = match_level_1 (&e); + if (m != MATCH_YES) + return m; + + if (!next_operator (INTRINSIC_POWER)) + { + *result = e; + return MATCH_YES; + } + + where = gfc_current_locus; + + m = match_ext_mult_operand (&exp); + if (m == MATCH_NO) + gfc_error ("Expected exponent in expression at %C"); + if (m != MATCH_YES) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + + r = gfc_power (e, exp); + if (r == NULL) + { + gfc_free_expr (e); + gfc_free_expr (exp); + return MATCH_ERROR; + } + + r->where = where; + *result = r; + + return MATCH_YES; +} + + +static match +match_ext_mult_operand (gfc_expr **result) +{ + gfc_expr *all, *e; + locus where; + match m; + int i; + + where = gfc_current_locus; + i = match_add_op (); + + if (i == 0) + return match_mult_operand (result); + + if (gfc_notification_std (GFC_STD_GNU) == ERROR) + { + gfc_error ("Extension: Unary operator following " + "arithmetic operator (use parentheses) at %C"); + return MATCH_ERROR; + } + else + gfc_warning (0, "Extension: Unary operator following " + "arithmetic operator (use parentheses) at %C"); + + m = match_ext_mult_operand (&e); + if (m != MATCH_YES) + return m; + + if (i == -1) + all = gfc_uminus (e); + else + all = gfc_uplus (e); + + if (all == NULL) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + + all->where = where; + *result = all; + return MATCH_YES; +} + + +static match +match_add_operand (gfc_expr **result) +{ + gfc_expr *all, *e, *total; + locus where, old_loc; + match m; + gfc_intrinsic_op i; + + m = match_mult_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + /* Build up a string of products or quotients. */ + + old_loc = gfc_current_locus; + + if (next_operator (INTRINSIC_TIMES)) + i = INTRINSIC_TIMES; + else + { + if (next_operator (INTRINSIC_DIVIDE)) + i = INTRINSIC_DIVIDE; + else + break; + } + + where = gfc_current_locus; + + m = match_ext_mult_operand (&e); + if (m == MATCH_NO) + { + gfc_current_locus = old_loc; + break; + } + + if (m == MATCH_ERROR) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + if (i == INTRINSIC_TIMES) + total = gfc_multiply (all, e); + else + total = gfc_divide (all, e); + + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +static match +match_ext_add_operand (gfc_expr **result) +{ + gfc_expr *all, *e; + locus where; + match m; + int i; + + where = gfc_current_locus; + i = match_add_op (); + + if (i == 0) + return match_add_operand (result); + + if (gfc_notification_std (GFC_STD_GNU) == ERROR) + { + gfc_error ("Extension: Unary operator following " + "arithmetic operator (use parentheses) at %C"); + return MATCH_ERROR; + } + else + gfc_warning (0, "Extension: Unary operator following " + "arithmetic operator (use parentheses) at %C"); + + m = match_ext_add_operand (&e); + if (m != MATCH_YES) + return m; + + if (i == -1) + all = gfc_uminus (e); + else + all = gfc_uplus (e); + + if (all == NULL) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + + all->where = where; + *result = all; + return MATCH_YES; +} + + +/* Match a level 2 expression. */ + +static match +match_level_2 (gfc_expr **result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + int i; + + where = gfc_current_locus; + i = match_add_op (); + + if (i != 0) + { + m = match_ext_add_operand (&e); + if (m == MATCH_NO) + { + gfc_error (expression_syntax); + m = MATCH_ERROR; + } + } + else + m = match_add_operand (&e); + + if (m != MATCH_YES) + return m; + + if (i == 0) + all = e; + else + { + if (i == -1) + all = gfc_uminus (e); + else + all = gfc_uplus (e); + + if (all == NULL) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + } + + all->where = where; + + /* Append add-operands to the sum. */ + + for (;;) + { + where = gfc_current_locus; + i = match_add_op (); + if (i == 0) + break; + + m = match_ext_add_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + if (i == -1) + total = gfc_subtract (all, e); + else + total = gfc_add (all, e); + + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match a level three expression. */ + +static match +match_level_3 (gfc_expr **result) +{ + gfc_expr *all, *e, *total = NULL; + locus where; + match m; + + m = match_level_2 (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (!next_operator (INTRINSIC_CONCAT)) + break; + + where = gfc_current_locus; + + m = match_level_2 (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + total = gfc_concat (all, e); + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match a level 4 expression. */ + +static match +match_level_4 (gfc_expr **result) +{ + gfc_expr *left, *right, *r; + gfc_intrinsic_op i; + locus old_loc; + locus where; + match m; + + m = match_level_3 (&left); + if (m != MATCH_YES) + return m; + + old_loc = gfc_current_locus; + + if (gfc_match_intrinsic_op (&i) != MATCH_YES) + { + *result = left; + return MATCH_YES; + } + + if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE + && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT + && i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS + && i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS) + { + gfc_current_locus = old_loc; + *result = left; + return MATCH_YES; + } + + where = gfc_current_locus; + + m = match_level_3 (&right); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (left); + return MATCH_ERROR; + } + + switch (i) + { + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + r = gfc_eq (left, right, i); + break; + + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + r = gfc_ne (left, right, i); + break; + + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + r = gfc_lt (left, right, i); + break; + + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + r = gfc_le (left, right, i); + break; + + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + r = gfc_gt (left, right, i); + break; + + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + r = gfc_ge (left, right, i); + break; + + default: + gfc_internal_error ("match_level_4(): Bad operator"); + } + + if (r == NULL) + { + gfc_free_expr (left); + gfc_free_expr (right); + return MATCH_ERROR; + } + + r->where = where; + *result = r; + + return MATCH_YES; +} + + +static match +match_and_operand (gfc_expr **result) +{ + gfc_expr *e, *r; + locus where; + match m; + int i; + + i = next_operator (INTRINSIC_NOT); + where = gfc_current_locus; + + m = match_level_4 (&e); + if (m != MATCH_YES) + return m; + + r = e; + if (i) + { + r = gfc_not (e); + if (r == NULL) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + } + + r->where = where; + *result = r; + + return MATCH_YES; +} + + +static match +match_or_operand (gfc_expr **result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + + m = match_and_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (!next_operator (INTRINSIC_AND)) + break; + where = gfc_current_locus; + + m = match_and_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + total = gfc_and (all, e); + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +static match +match_equiv_operand (gfc_expr **result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + + m = match_or_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (!next_operator (INTRINSIC_OR)) + break; + where = gfc_current_locus; + + m = match_or_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + total = gfc_or (all, e); + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match a level 5 expression. */ + +static match +match_level_5 (gfc_expr **result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + gfc_intrinsic_op i; + + m = match_equiv_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (next_operator (INTRINSIC_EQV)) + i = INTRINSIC_EQV; + else + { + if (next_operator (INTRINSIC_NEQV)) + i = INTRINSIC_NEQV; + else + break; + } + + where = gfc_current_locus; + + m = match_equiv_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + if (i == INTRINSIC_EQV) + total = gfc_eqv (all, e); + else + total = gfc_neqv (all, e); + + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match an expression. At this level, we are stringing together + level 5 expressions separated by binary operators. */ + +match +gfc_match_expr (gfc_expr **result) +{ + gfc_expr *all, *e; + gfc_user_op *uop; + locus where; + match m; + + m = match_level_5 (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + uop = NULL; + m = match_defined_operator (&uop); + if (m == MATCH_NO) + break; + if (m == MATCH_ERROR) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + where = gfc_current_locus; + + m = match_level_5 (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e); + all->value.op.uop = uop; + } + + *result = all; + return MATCH_YES; +} diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c deleted file mode 100644 index af36347..0000000 --- a/gcc/fortran/misc.c +++ /dev/null @@ -1,460 +0,0 @@ -/* Miscellaneous stuff that doesn't fit anywhere else. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "spellcheck.h" -#include "tree.h" - - -/* Initialize a typespec to unknown. */ - -void -gfc_clear_ts (gfc_typespec *ts) -{ - ts->type = BT_UNKNOWN; - ts->u.derived = NULL; - ts->kind = 0; - ts->u.cl = NULL; - ts->interface = NULL; - /* flag that says if the type is C interoperable */ - ts->is_c_interop = 0; - /* says what f90 type the C kind interops with */ - ts->f90_type = BT_UNKNOWN; - /* flag that says whether it's from iso_c_binding or not */ - ts->is_iso_c = 0; - ts->deferred = false; -} - - -/* Open a file for reading. */ - -FILE * -gfc_open_file (const char *name) -{ - if (!*name) - return stdin; - - return fopen (name, "r"); -} - - -/* Return a string for each type. */ - -const char * -gfc_basic_typename (bt type) -{ - const char *p; - - switch (type) - { - case BT_INTEGER: - p = "INTEGER"; - break; - case BT_REAL: - p = "REAL"; - break; - case BT_COMPLEX: - p = "COMPLEX"; - break; - case BT_LOGICAL: - p = "LOGICAL"; - break; - case BT_CHARACTER: - p = "CHARACTER"; - break; - case BT_HOLLERITH: - p = "HOLLERITH"; - break; - case BT_UNION: - p = "UNION"; - break; - case BT_DERIVED: - p = "DERIVED"; - break; - case BT_CLASS: - p = "CLASS"; - break; - case BT_PROCEDURE: - p = "PROCEDURE"; - break; - case BT_VOID: - p = "VOID"; - break; - case BT_BOZ: - p = "BOZ"; - break; - case BT_UNKNOWN: - p = "UNKNOWN"; - break; - case BT_ASSUMED: - p = "TYPE(*)"; - break; - default: - gfc_internal_error ("gfc_basic_typename(): Undefined type"); - } - - return p; -} - - -/* Return a string describing the type and kind of a typespec. Because - we return alternating buffers, this subroutine can appear twice in - the argument list of a single statement. */ - -const char * -gfc_typename (gfc_typespec *ts, bool for_hash) -{ - /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0', - or "CLASS()" + '\0'. */ - static char buffer1[GFC_MAX_SYMBOL_LEN + 8]; - static char buffer2[GFC_MAX_SYMBOL_LEN + 8]; - static int flag = 0; - char *buffer; - gfc_charlen_t length = 0; - - buffer = flag ? buffer1 : buffer2; - flag = !flag; - - switch (ts->type) - { - case BT_INTEGER: - sprintf (buffer, "INTEGER(%d)", ts->kind); - break; - case BT_REAL: - sprintf (buffer, "REAL(%d)", ts->kind); - break; - case BT_COMPLEX: - sprintf (buffer, "COMPLEX(%d)", ts->kind); - break; - case BT_LOGICAL: - sprintf (buffer, "LOGICAL(%d)", ts->kind); - break; - case BT_CHARACTER: - if (for_hash) - { - sprintf (buffer, "CHARACTER(%d)", ts->kind); - break; - } - - if (ts->u.cl && ts->u.cl->length) - length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); - if (ts->kind == gfc_default_character_kind) - sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length); - else - sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length, - ts->kind); - break; - case BT_HOLLERITH: - sprintf (buffer, "HOLLERITH"); - break; - case BT_UNION: - sprintf (buffer, "UNION(%s)", ts->u.derived->name); - break; - case BT_DERIVED: - if (ts->u.derived == NULL) - { - sprintf (buffer, "invalid type"); - break; - } - sprintf (buffer, "TYPE(%s)", ts->u.derived->name); - break; - case BT_CLASS: - if (!ts->u.derived || !ts->u.derived->components - || !ts->u.derived->components->ts.u.derived) - { - sprintf (buffer, "invalid class"); - break; - } - if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) - sprintf (buffer, "CLASS(*)"); - else - sprintf (buffer, "CLASS(%s)", - ts->u.derived->components->ts.u.derived->name); - break; - case BT_ASSUMED: - sprintf (buffer, "TYPE(*)"); - break; - case BT_PROCEDURE: - strcpy (buffer, "PROCEDURE"); - break; - case BT_BOZ: - strcpy (buffer, "BOZ"); - break; - case BT_UNKNOWN: - strcpy (buffer, "UNKNOWN"); - break; - default: - gfc_internal_error ("gfc_typename(): Undefined type"); - } - - return buffer; -} - - -const char * -gfc_typename (gfc_expr *ex) -{ - /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters, - add 19 for the extra width and 1 for '\0' */ - static char buffer1[34]; - static char buffer2[34]; - static bool flag = false; - char *buffer; - gfc_charlen_t length; - buffer = flag ? buffer1 : buffer2; - flag = !flag; - - if (ex->ts.type == BT_CHARACTER) - { - if (ex->expr_type == EXPR_CONSTANT) - length = ex->value.character.length; - else if (ex->ts.deferred) - { - if (ex->ts.kind == gfc_default_character_kind) - return "CHARACTER(:)"; - sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind); - return buffer; - } - else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL) - { - if (ex->ts.kind == gfc_default_character_kind) - return "CHARACTER(*)"; - sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind); - return buffer; - } - else if (ex->ts.u.cl == NULL - || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT) - { - if (ex->ts.kind == gfc_default_character_kind) - return "CHARACTER"; - sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind); - return buffer; - } - else - length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer); - if (ex->ts.kind == gfc_default_character_kind) - sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length); - else - sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length, - ex->ts.kind); - return buffer; - } - return gfc_typename(&ex->ts); -} - -/* The type of a dummy variable can also be CHARACTER(*). */ - -const char * -gfc_dummy_typename (gfc_typespec *ts) -{ - static char buffer1[15]; /* 15 for "CHARACTER(*,4)" + '\0'. */ - static char buffer2[15]; - static bool flag = false; - char *buffer; - - buffer = flag ? buffer1 : buffer2; - flag = !flag; - - if (ts->type == BT_CHARACTER) - { - bool has_length = false; - if (ts->u.cl) - has_length = ts->u.cl->length != NULL; - if (!has_length) - { - if (ts->kind == gfc_default_character_kind) - sprintf(buffer, "CHARACTER(*)"); - else if (ts->kind >= 0 && ts->kind < 10) - sprintf(buffer, "CHARACTER(*,%d)", ts->kind); - else - sprintf(buffer, "CHARACTER(*,?)"); - return buffer; - } - } - return gfc_typename(ts); -} - - -/* Given an mstring array and a code, locate the code in the table, - returning a pointer to the string. */ - -const char * -gfc_code2string (const mstring *m, int code) -{ - while (m->string != NULL) - { - if (m->tag == code) - return m->string; - m++; - } - - gfc_internal_error ("gfc_code2string(): Bad code"); - /* Not reached */ -} - - -/* Given an mstring array and a string, returns the value of the tag - field. Returns the final tag if no matches to the string are found. */ - -int -gfc_string2code (const mstring *m, const char *string) -{ - for (; m->string != NULL; m++) - if (strcmp (m->string, string) == 0) - return m->tag; - - return m->tag; -} - - -/* Convert an intent code to a string. */ -/* TODO: move to gfortran.h as define. */ - -const char * -gfc_intent_string (sym_intent i) -{ - return gfc_code2string (intents, i); -} - - -/***************** Initialization functions ****************/ - -/* Top level initialization. */ - -void -gfc_init_1 (void) -{ - gfc_error_init_1 (); - gfc_scanner_init_1 (); - gfc_arith_init_1 (); - gfc_intrinsic_init_1 (); -} - - -/* Per program unit initialization. */ - -void -gfc_init_2 (void) -{ - gfc_symbol_init_2 (); - gfc_module_init_2 (); -} - - -/******************* Destructor functions ******************/ - -/* Call all of the top level destructors. */ - -void -gfc_done_1 (void) -{ - gfc_scanner_done_1 (); - gfc_intrinsic_done_1 (); - gfc_arith_done_1 (); -} - - -/* Per program unit destructors. */ - -void -gfc_done_2 (void) -{ - gfc_symbol_done_2 (); - gfc_module_done_2 (); -} - - -/* Returns the index into the table of C interoperable kinds where the - kind with the given name (c_kind_name) was found. */ - -int -get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[]) -{ - int index = 0; - - for (index = 0; index < ISOCBINDING_LAST; index++) - if (strcmp (kinds_table[index].name, c_kind_name) == 0) - return index; - - return ISOCBINDING_INVALID; -} - - -/* For a given name TYPO, determine the best candidate from CANDIDATES - using get_edit_distance. Frees CANDIDATES before returning. */ - -const char * -gfc_closest_fuzzy_match (const char *typo, char **candidates) -{ - /* Determine closest match. */ - const char *best = NULL; - char **cand = candidates; - edit_distance_t best_distance = MAX_EDIT_DISTANCE; - const size_t tl = strlen (typo); - - while (cand && *cand) - { - edit_distance_t dist = get_edit_distance (typo, tl, *cand, - strlen (*cand)); - if (dist < best_distance) - { - best_distance = dist; - best = *cand; - } - cand++; - } - /* If more than half of the letters were misspelled, the suggestion is - likely to be meaningless. */ - if (best) - { - unsigned int cutoff = MAX (tl, strlen (best)); - - if (best_distance > cutoff) - { - XDELETEVEC (candidates); - return NULL; - } - XDELETEVEC (candidates); - } - return best; -} - -/* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */ - -HOST_WIDE_INT -gfc_mpz_get_hwi (mpz_t op) -{ - /* Using long_long_integer_type_node as that is the integer type - node that closest matches HOST_WIDE_INT; both are guaranteed to - be at least 64 bits. */ - const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true); - return w.to_shwi (); -} - - -void -gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op) -{ - const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT); - wi::to_mpz (w, rop, SIGNED); -} diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc new file mode 100644 index 0000000..af36347 --- /dev/null +++ b/gcc/fortran/misc.cc @@ -0,0 +1,460 @@ +/* Miscellaneous stuff that doesn't fit anywhere else. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "spellcheck.h" +#include "tree.h" + + +/* Initialize a typespec to unknown. */ + +void +gfc_clear_ts (gfc_typespec *ts) +{ + ts->type = BT_UNKNOWN; + ts->u.derived = NULL; + ts->kind = 0; + ts->u.cl = NULL; + ts->interface = NULL; + /* flag that says if the type is C interoperable */ + ts->is_c_interop = 0; + /* says what f90 type the C kind interops with */ + ts->f90_type = BT_UNKNOWN; + /* flag that says whether it's from iso_c_binding or not */ + ts->is_iso_c = 0; + ts->deferred = false; +} + + +/* Open a file for reading. */ + +FILE * +gfc_open_file (const char *name) +{ + if (!*name) + return stdin; + + return fopen (name, "r"); +} + + +/* Return a string for each type. */ + +const char * +gfc_basic_typename (bt type) +{ + const char *p; + + switch (type) + { + case BT_INTEGER: + p = "INTEGER"; + break; + case BT_REAL: + p = "REAL"; + break; + case BT_COMPLEX: + p = "COMPLEX"; + break; + case BT_LOGICAL: + p = "LOGICAL"; + break; + case BT_CHARACTER: + p = "CHARACTER"; + break; + case BT_HOLLERITH: + p = "HOLLERITH"; + break; + case BT_UNION: + p = "UNION"; + break; + case BT_DERIVED: + p = "DERIVED"; + break; + case BT_CLASS: + p = "CLASS"; + break; + case BT_PROCEDURE: + p = "PROCEDURE"; + break; + case BT_VOID: + p = "VOID"; + break; + case BT_BOZ: + p = "BOZ"; + break; + case BT_UNKNOWN: + p = "UNKNOWN"; + break; + case BT_ASSUMED: + p = "TYPE(*)"; + break; + default: + gfc_internal_error ("gfc_basic_typename(): Undefined type"); + } + + return p; +} + + +/* Return a string describing the type and kind of a typespec. Because + we return alternating buffers, this subroutine can appear twice in + the argument list of a single statement. */ + +const char * +gfc_typename (gfc_typespec *ts, bool for_hash) +{ + /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0', + or "CLASS()" + '\0'. */ + static char buffer1[GFC_MAX_SYMBOL_LEN + 8]; + static char buffer2[GFC_MAX_SYMBOL_LEN + 8]; + static int flag = 0; + char *buffer; + gfc_charlen_t length = 0; + + buffer = flag ? buffer1 : buffer2; + flag = !flag; + + switch (ts->type) + { + case BT_INTEGER: + sprintf (buffer, "INTEGER(%d)", ts->kind); + break; + case BT_REAL: + sprintf (buffer, "REAL(%d)", ts->kind); + break; + case BT_COMPLEX: + sprintf (buffer, "COMPLEX(%d)", ts->kind); + break; + case BT_LOGICAL: + sprintf (buffer, "LOGICAL(%d)", ts->kind); + break; + case BT_CHARACTER: + if (for_hash) + { + sprintf (buffer, "CHARACTER(%d)", ts->kind); + break; + } + + if (ts->u.cl && ts->u.cl->length) + length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); + if (ts->kind == gfc_default_character_kind) + sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length); + else + sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length, + ts->kind); + break; + case BT_HOLLERITH: + sprintf (buffer, "HOLLERITH"); + break; + case BT_UNION: + sprintf (buffer, "UNION(%s)", ts->u.derived->name); + break; + case BT_DERIVED: + if (ts->u.derived == NULL) + { + sprintf (buffer, "invalid type"); + break; + } + sprintf (buffer, "TYPE(%s)", ts->u.derived->name); + break; + case BT_CLASS: + if (!ts->u.derived || !ts->u.derived->components + || !ts->u.derived->components->ts.u.derived) + { + sprintf (buffer, "invalid class"); + break; + } + if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) + sprintf (buffer, "CLASS(*)"); + else + sprintf (buffer, "CLASS(%s)", + ts->u.derived->components->ts.u.derived->name); + break; + case BT_ASSUMED: + sprintf (buffer, "TYPE(*)"); + break; + case BT_PROCEDURE: + strcpy (buffer, "PROCEDURE"); + break; + case BT_BOZ: + strcpy (buffer, "BOZ"); + break; + case BT_UNKNOWN: + strcpy (buffer, "UNKNOWN"); + break; + default: + gfc_internal_error ("gfc_typename(): Undefined type"); + } + + return buffer; +} + + +const char * +gfc_typename (gfc_expr *ex) +{ + /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters, + add 19 for the extra width and 1 for '\0' */ + static char buffer1[34]; + static char buffer2[34]; + static bool flag = false; + char *buffer; + gfc_charlen_t length; + buffer = flag ? buffer1 : buffer2; + flag = !flag; + + if (ex->ts.type == BT_CHARACTER) + { + if (ex->expr_type == EXPR_CONSTANT) + length = ex->value.character.length; + else if (ex->ts.deferred) + { + if (ex->ts.kind == gfc_default_character_kind) + return "CHARACTER(:)"; + sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind); + return buffer; + } + else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL) + { + if (ex->ts.kind == gfc_default_character_kind) + return "CHARACTER(*)"; + sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind); + return buffer; + } + else if (ex->ts.u.cl == NULL + || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT) + { + if (ex->ts.kind == gfc_default_character_kind) + return "CHARACTER"; + sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind); + return buffer; + } + else + length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer); + if (ex->ts.kind == gfc_default_character_kind) + sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length); + else + sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length, + ex->ts.kind); + return buffer; + } + return gfc_typename(&ex->ts); +} + +/* The type of a dummy variable can also be CHARACTER(*). */ + +const char * +gfc_dummy_typename (gfc_typespec *ts) +{ + static char buffer1[15]; /* 15 for "CHARACTER(*,4)" + '\0'. */ + static char buffer2[15]; + static bool flag = false; + char *buffer; + + buffer = flag ? buffer1 : buffer2; + flag = !flag; + + if (ts->type == BT_CHARACTER) + { + bool has_length = false; + if (ts->u.cl) + has_length = ts->u.cl->length != NULL; + if (!has_length) + { + if (ts->kind == gfc_default_character_kind) + sprintf(buffer, "CHARACTER(*)"); + else if (ts->kind >= 0 && ts->kind < 10) + sprintf(buffer, "CHARACTER(*,%d)", ts->kind); + else + sprintf(buffer, "CHARACTER(*,?)"); + return buffer; + } + } + return gfc_typename(ts); +} + + +/* Given an mstring array and a code, locate the code in the table, + returning a pointer to the string. */ + +const char * +gfc_code2string (const mstring *m, int code) +{ + while (m->string != NULL) + { + if (m->tag == code) + return m->string; + m++; + } + + gfc_internal_error ("gfc_code2string(): Bad code"); + /* Not reached */ +} + + +/* Given an mstring array and a string, returns the value of the tag + field. Returns the final tag if no matches to the string are found. */ + +int +gfc_string2code (const mstring *m, const char *string) +{ + for (; m->string != NULL; m++) + if (strcmp (m->string, string) == 0) + return m->tag; + + return m->tag; +} + + +/* Convert an intent code to a string. */ +/* TODO: move to gfortran.h as define. */ + +const char * +gfc_intent_string (sym_intent i) +{ + return gfc_code2string (intents, i); +} + + +/***************** Initialization functions ****************/ + +/* Top level initialization. */ + +void +gfc_init_1 (void) +{ + gfc_error_init_1 (); + gfc_scanner_init_1 (); + gfc_arith_init_1 (); + gfc_intrinsic_init_1 (); +} + + +/* Per program unit initialization. */ + +void +gfc_init_2 (void) +{ + gfc_symbol_init_2 (); + gfc_module_init_2 (); +} + + +/******************* Destructor functions ******************/ + +/* Call all of the top level destructors. */ + +void +gfc_done_1 (void) +{ + gfc_scanner_done_1 (); + gfc_intrinsic_done_1 (); + gfc_arith_done_1 (); +} + + +/* Per program unit destructors. */ + +void +gfc_done_2 (void) +{ + gfc_symbol_done_2 (); + gfc_module_done_2 (); +} + + +/* Returns the index into the table of C interoperable kinds where the + kind with the given name (c_kind_name) was found. */ + +int +get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[]) +{ + int index = 0; + + for (index = 0; index < ISOCBINDING_LAST; index++) + if (strcmp (kinds_table[index].name, c_kind_name) == 0) + return index; + + return ISOCBINDING_INVALID; +} + + +/* For a given name TYPO, determine the best candidate from CANDIDATES + using get_edit_distance. Frees CANDIDATES before returning. */ + +const char * +gfc_closest_fuzzy_match (const char *typo, char **candidates) +{ + /* Determine closest match. */ + const char *best = NULL; + char **cand = candidates; + edit_distance_t best_distance = MAX_EDIT_DISTANCE; + const size_t tl = strlen (typo); + + while (cand && *cand) + { + edit_distance_t dist = get_edit_distance (typo, tl, *cand, + strlen (*cand)); + if (dist < best_distance) + { + best_distance = dist; + best = *cand; + } + cand++; + } + /* If more than half of the letters were misspelled, the suggestion is + likely to be meaningless. */ + if (best) + { + unsigned int cutoff = MAX (tl, strlen (best)); + + if (best_distance > cutoff) + { + XDELETEVEC (candidates); + return NULL; + } + XDELETEVEC (candidates); + } + return best; +} + +/* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */ + +HOST_WIDE_INT +gfc_mpz_get_hwi (mpz_t op) +{ + /* Using long_long_integer_type_node as that is the integer type + node that closest matches HOST_WIDE_INT; both are guaranteed to + be at least 64 bits. */ + const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true); + return w.to_shwi (); +} + + +void +gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op) +{ + const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT); + wi::to_mpz (w, rop, SIGNED); +} diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c deleted file mode 100644 index 352e613..0000000 --- a/gcc/fortran/module.c +++ /dev/null @@ -1,7581 +0,0 @@ -/* Handle modules, which amounts to loading and saving symbols and - their attendant structures. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -/* The syntax of gfortran modules resembles that of lisp lists, i.e. a - sequence of atoms, which can be left or right parenthesis, names, - integers or strings. Parenthesis are always matched which allows - us to skip over sections at high speed without having to know - anything about the internal structure of the lists. A "name" is - usually a fortran 95 identifier, but can also start with '@' in - order to reference a hidden symbol. - - The first line of a module is an informational message about what - created the module, the file it came from and when it was created. - The second line is a warning for people not to edit the module. - The rest of the module looks like: - - ( ( ) - ( ) - ... - ) - ( ( ... ) - ... - ) - ( ( ... ) - ... - ) - ( ( ) - ... - ) - - ( equivalence list ) - - ( - - - ( ) - ... - ) - ( - - - ... - ) - - In general, symbols refer to other symbols by their symbol number, - which are zero based. Symbols are written to the module in no - particular order. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "tree.h" -#include "gfortran.h" -#include "stringpool.h" -#include "arith.h" -#include "match.h" -#include "parse.h" /* FIXME */ -#include "constructor.h" -#include "cpp.h" -#include "scanner.h" -#include - -#define MODULE_EXTENSION ".mod" -#define SUBMODULE_EXTENSION ".smod" - -/* Don't put any single quote (') in MOD_VERSION, if you want it to be - recognized. */ -#define MOD_VERSION "15" - - -/* Structure that describes a position within a module file. */ - -typedef struct -{ - int column, line; - long pos; -} -module_locus; - -/* Structure for list of symbols of intrinsic modules. */ -typedef struct -{ - int id; - const char *name; - int value; - int standard; -} -intmod_sym; - - -typedef enum -{ - P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL -} -pointer_t; - -/* The fixup structure lists pointers to pointers that have to - be updated when a pointer value becomes known. */ - -typedef struct fixup_t -{ - void **pointer; - struct fixup_t *next; -} -fixup_t; - - -/* Structure for holding extra info needed for pointers being read. */ - -enum gfc_rsym_state -{ - UNUSED, - NEEDED, - USED -}; - -enum gfc_wsym_state -{ - UNREFERENCED = 0, - NEEDS_WRITE, - WRITTEN -}; - -typedef struct pointer_info -{ - BBT_HEADER (pointer_info); - HOST_WIDE_INT integer; - pointer_t type; - - /* The first component of each member of the union is the pointer - being stored. */ - - fixup_t *fixup; - - union - { - void *pointer; /* Member for doing pointer searches. */ - - struct - { - gfc_symbol *sym; - char *true_name, *module, *binding_label; - fixup_t *stfixup; - gfc_symtree *symtree; - enum gfc_rsym_state state; - int ns, referenced, renamed; - module_locus where; - } - rsym; - - struct - { - gfc_symbol *sym; - enum gfc_wsym_state state; - } - wsym; - } - u; - -} -pointer_info; - -#define gfc_get_pointer_info() XCNEW (pointer_info) - - -/* Local variables */ - -/* The gzFile for the module we're reading or writing. */ -static gzFile module_fp; - -/* Fully qualified module path */ -static char *module_fullpath = NULL; - -/* The name of the module we're reading (USE'ing) or writing. */ -static const char *module_name; -/* The name of the .smod file that the submodule will write to. */ -static const char *submodule_name; - -static gfc_use_list *module_list; - -/* If we're reading an intrinsic module, this is its ID. */ -static intmod_id current_intmod; - -/* Content of module. */ -static char* module_content; - -static long module_pos; -static int module_line, module_column, only_flag; -static int prev_module_line, prev_module_column; - -static enum -{ IO_INPUT, IO_OUTPUT } -iomode; - -static gfc_use_rename *gfc_rename_list; -static pointer_info *pi_root; -static int symbol_number; /* Counter for assigning symbol numbers */ - -/* Tells mio_expr_ref to make symbols for unused equivalence members. */ -static bool in_load_equiv; - - - -/*****************************************************************/ - -/* Pointer/integer conversion. Pointers between structures are stored - as integers in the module file. The next couple of subroutines - handle this translation for reading and writing. */ - -/* Recursively free the tree of pointer structures. */ - -static void -free_pi_tree (pointer_info *p) -{ - if (p == NULL) - return; - - if (p->fixup != NULL) - gfc_internal_error ("free_pi_tree(): Unresolved fixup"); - - free_pi_tree (p->left); - free_pi_tree (p->right); - - if (iomode == IO_INPUT) - { - XDELETEVEC (p->u.rsym.true_name); - XDELETEVEC (p->u.rsym.module); - XDELETEVEC (p->u.rsym.binding_label); - } - - free (p); -} - - -/* Compare pointers when searching by pointer. Used when writing a - module. */ - -static int -compare_pointers (void *_sn1, void *_sn2) -{ - pointer_info *sn1, *sn2; - - sn1 = (pointer_info *) _sn1; - sn2 = (pointer_info *) _sn2; - - if (sn1->u.pointer < sn2->u.pointer) - return -1; - if (sn1->u.pointer > sn2->u.pointer) - return 1; - - return 0; -} - - -/* Compare integers when searching by integer. Used when reading a - module. */ - -static int -compare_integers (void *_sn1, void *_sn2) -{ - pointer_info *sn1, *sn2; - - sn1 = (pointer_info *) _sn1; - sn2 = (pointer_info *) _sn2; - - if (sn1->integer < sn2->integer) - return -1; - if (sn1->integer > sn2->integer) - return 1; - - return 0; -} - - -/* Initialize the pointer_info tree. */ - -static void -init_pi_tree (void) -{ - compare_fn compare; - pointer_info *p; - - pi_root = NULL; - compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers; - - /* Pointer 0 is the NULL pointer. */ - p = gfc_get_pointer_info (); - p->u.pointer = NULL; - p->integer = 0; - p->type = P_OTHER; - - gfc_insert_bbt (&pi_root, p, compare); - - /* Pointer 1 is the current namespace. */ - p = gfc_get_pointer_info (); - p->u.pointer = gfc_current_ns; - p->integer = 1; - p->type = P_NAMESPACE; - - gfc_insert_bbt (&pi_root, p, compare); - - symbol_number = 2; -} - - -/* During module writing, call here with a pointer to something, - returning the pointer_info node. */ - -static pointer_info * -find_pointer (void *gp) -{ - pointer_info *p; - - p = pi_root; - while (p != NULL) - { - if (p->u.pointer == gp) - break; - p = (gp < p->u.pointer) ? p->left : p->right; - } - - return p; -} - - -/* Given a pointer while writing, returns the pointer_info tree node, - creating it if it doesn't exist. */ - -static pointer_info * -get_pointer (void *gp) -{ - pointer_info *p; - - p = find_pointer (gp); - if (p != NULL) - return p; - - /* Pointer doesn't have an integer. Give it one. */ - p = gfc_get_pointer_info (); - - p->u.pointer = gp; - p->integer = symbol_number++; - - gfc_insert_bbt (&pi_root, p, compare_pointers); - - return p; -} - - -/* Given an integer during reading, find it in the pointer_info tree, - creating the node if not found. */ - -static pointer_info * -get_integer (HOST_WIDE_INT integer) -{ - pointer_info *p, t; - int c; - - t.integer = integer; - - p = pi_root; - while (p != NULL) - { - c = compare_integers (&t, p); - if (c == 0) - break; - - p = (c < 0) ? p->left : p->right; - } - - if (p != NULL) - return p; - - p = gfc_get_pointer_info (); - p->integer = integer; - p->u.pointer = NULL; - - gfc_insert_bbt (&pi_root, p, compare_integers); - - return p; -} - - -/* Resolve any fixups using a known pointer. */ - -static void -resolve_fixups (fixup_t *f, void *gp) -{ - fixup_t *next; - - for (; f; f = next) - { - next = f->next; - *(f->pointer) = gp; - free (f); - } -} - - -/* Convert a string such that it starts with a lower-case character. Used - to convert the symtree name of a derived-type to the symbol name or to - the name of the associated generic function. */ - -const char * -gfc_dt_lower_string (const char *name) -{ - if (name[0] != (char) TOLOWER ((unsigned char) name[0])) - return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]), - &name[1]); - return gfc_get_string ("%s", name); -} - - -/* Convert a string such that it starts with an upper-case character. Used to - return the symtree-name for a derived type; the symbol name itself and the - symtree/symbol name of the associated generic function start with a lower- - case character. */ - -const char * -gfc_dt_upper_string (const char *name) -{ - if (name[0] != (char) TOUPPER ((unsigned char) name[0])) - return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]), - &name[1]); - return gfc_get_string ("%s", name); -} - -/* Call here during module reading when we know what pointer to - associate with an integer. Any fixups that exist are resolved at - this time. */ - -static void -associate_integer_pointer (pointer_info *p, void *gp) -{ - if (p->u.pointer != NULL) - gfc_internal_error ("associate_integer_pointer(): Already associated"); - - p->u.pointer = gp; - - resolve_fixups (p->fixup, gp); - - p->fixup = NULL; -} - - -/* During module reading, given an integer and a pointer to a pointer, - either store the pointer from an already-known value or create a - fixup structure in order to store things later. Returns zero if - the reference has been actually stored, or nonzero if the reference - must be fixed later (i.e., associate_integer_pointer must be called - sometime later. Returns the pointer_info structure. */ - -static pointer_info * -add_fixup (HOST_WIDE_INT integer, void *gp) -{ - pointer_info *p; - fixup_t *f; - char **cp; - - p = get_integer (integer); - - if (p->integer == 0 || p->u.pointer != NULL) - { - cp = (char **) gp; - *cp = (char *) p->u.pointer; - } - else - { - f = XCNEW (fixup_t); - - f->next = p->fixup; - p->fixup = f; - - f->pointer = (void **) gp; - } - - return p; -} - - -/*****************************************************************/ - -/* Parser related subroutines */ - -/* Free the rename list left behind by a USE statement. */ - -static void -free_rename (gfc_use_rename *list) -{ - gfc_use_rename *next; - - for (; list; list = next) - { - next = list->next; - free (list); - } -} - - -/* Match a USE statement. */ - -match -gfc_match_use (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1]; - gfc_use_rename *tail = NULL, *new_use; - interface_type type, type2; - gfc_intrinsic_op op; - match m; - gfc_use_list *use_list; - gfc_symtree *st; - locus loc; - - use_list = gfc_get_use_list (); - - if (gfc_match (" , ") == MATCH_YES) - { - if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_F2003, "module " - "nature in USE statement at %C")) - goto cleanup; - - if (strcmp (module_nature, "intrinsic") == 0) - use_list->intrinsic = true; - else - { - if (strcmp (module_nature, "non_intrinsic") == 0) - use_list->non_intrinsic = true; - else - { - gfc_error ("Module nature in USE statement at %C shall " - "be either INTRINSIC or NON_INTRINSIC"); - goto cleanup; - } - } - } - else - { - /* Help output a better error message than "Unclassifiable - statement". */ - gfc_match (" %n", module_nature); - if (strcmp (module_nature, "intrinsic") == 0 - || strcmp (module_nature, "non_intrinsic") == 0) - gfc_error ("\"::\" was expected after module nature at %C " - "but was not found"); - free (use_list); - return m; - } - } - else - { - m = gfc_match (" ::"); - if (m == MATCH_YES && - !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C")) - goto cleanup; - - if (m != MATCH_YES) - { - m = gfc_match ("% "); - if (m != MATCH_YES) - { - free (use_list); - return m; - } - } - } - - use_list->where = gfc_current_locus; - - m = gfc_match_name (name); - if (m != MATCH_YES) - { - free (use_list); - return m; - } - - use_list->module_name = gfc_get_string ("%s", name); - - if (gfc_match_eos () == MATCH_YES) - goto done; - - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - if (gfc_match (" only :") == MATCH_YES) - use_list->only_flag = true; - - if (gfc_match_eos () == MATCH_YES) - goto done; - - for (;;) - { - /* Get a new rename struct and add it to the rename list. */ - new_use = gfc_get_use_rename (); - new_use->where = gfc_current_locus; - new_use->found = 0; - - if (use_list->rename == NULL) - use_list->rename = new_use; - else - tail->next = new_use; - tail = new_use; - - /* See what kind of interface we're dealing with. Assume it is - not an operator. */ - new_use->op = INTRINSIC_NONE; - if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) - goto cleanup; - - switch (type) - { - case INTERFACE_NAMELESS: - gfc_error ("Missing generic specification in USE statement at %C"); - goto cleanup; - - case INTERFACE_USER_OP: - case INTERFACE_GENERIC: - case INTERFACE_DTIO: - loc = gfc_current_locus; - - m = gfc_match (" =>"); - - if (type == INTERFACE_USER_OP && m == MATCH_YES - && (!gfc_notify_std(GFC_STD_F2003, "Renaming " - "operators in USE statements at %C"))) - goto cleanup; - - if (type == INTERFACE_USER_OP) - new_use->op = INTRINSIC_USER; - - if (use_list->only_flag) - { - if (m != MATCH_YES) - strcpy (new_use->use_name, name); - else - { - strcpy (new_use->local_name, name); - m = gfc_match_generic_spec (&type2, new_use->use_name, &op); - if (type != type2) - goto syntax; - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - } - } - else - { - if (m != MATCH_YES) - goto syntax; - strcpy (new_use->local_name, name); - - m = gfc_match_generic_spec (&type2, new_use->use_name, &op); - if (type != type2) - goto syntax; - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - } - - st = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (st && type != INTERFACE_USER_OP - && (st->n.sym->module != use_list->module_name - || strcmp (st->n.sym->name, new_use->use_name) != 0)) - { - if (m == MATCH_YES) - gfc_error ("Symbol %qs at %L conflicts with the rename symbol " - "at %L", name, &st->n.sym->declared_at, &loc); - else - gfc_error ("Symbol %qs at %L conflicts with the symbol " - "at %L", name, &st->n.sym->declared_at, &loc); - goto cleanup; - } - - if (strcmp (new_use->use_name, use_list->module_name) == 0 - || strcmp (new_use->local_name, use_list->module_name) == 0) - { - gfc_error ("The name %qs at %C has already been used as " - "an external module name", use_list->module_name); - goto cleanup; - } - break; - - case INTERFACE_INTRINSIC_OP: - new_use->op = op; - break; - - default: - gcc_unreachable (); - } - - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - -done: - if (module_list) - { - gfc_use_list *last = module_list; - while (last->next) - last = last->next; - last->next = use_list; - } - else - module_list = use_list; - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_USE); - -cleanup: - free_rename (use_list->rename); - free (use_list); - return MATCH_ERROR; -} - - -/* Match a SUBMODULE statement. - - According to F2008:11.2.3.2, "The submodule identifier is the - ordered pair whose first element is the ancestor module name and - whose second element is the submodule name. 'Submodule_name' is - used for the submodule filename and uses '@' as a separator, whilst - the name of the symbol for the module uses '.' as a separator. - The reasons for these choices are: - (i) To follow another leading brand in the submodule filenames; - (ii) Since '.' is not particularly visible in the filenames; and - (iii) The linker does not permit '@' in mnemonics. */ - -match -gfc_match_submodule (void) -{ - match m; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_use_list *use_list; - bool seen_colon = false; - - if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C")) - return MATCH_ERROR; - - if (gfc_current_state () != COMP_NONE) - { - gfc_error ("SUBMODULE declaration at %C cannot appear within " - "another scoping unit"); - return MATCH_ERROR; - } - - gfc_new_block = NULL; - gcc_assert (module_list == NULL); - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - while (1) - { - m = gfc_match (" %n", name); - if (m != MATCH_YES) - goto syntax; - - use_list = gfc_get_use_list (); - use_list->where = gfc_current_locus; - - if (module_list) - { - gfc_use_list *last = module_list; - while (last->next) - last = last->next; - last->next = use_list; - use_list->module_name - = gfc_get_string ("%s.%s", module_list->module_name, name); - use_list->submodule_name - = gfc_get_string ("%s@%s", module_list->module_name, name); - } - else - { - module_list = use_list; - use_list->module_name = gfc_get_string ("%s", name); - use_list->submodule_name = use_list->module_name; - } - - if (gfc_match_char (')') == MATCH_YES) - break; - - if (gfc_match_char (':') != MATCH_YES - || seen_colon) - goto syntax; - - seen_colon = true; - } - - m = gfc_match (" %s%t", &gfc_new_block); - if (m != MATCH_YES) - goto syntax; - - submodule_name = gfc_get_string ("%s@%s", module_list->module_name, - gfc_new_block->name); - - gfc_new_block->name = gfc_get_string ("%s.%s", - module_list->module_name, - gfc_new_block->name); - - if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, - gfc_new_block->name, NULL)) - return MATCH_ERROR; - - /* Just retain the ultimate .(s)mod file for reading, since it - contains all the information in its ancestors. */ - use_list = module_list; - for (; module_list->next; use_list = module_list) - { - module_list = use_list->next; - free (use_list); - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in SUBMODULE statement at %C"); - return MATCH_ERROR; -} - - -/* Given a name and a number, inst, return the inst name - under which to load this symbol. Returns NULL if this - symbol shouldn't be loaded. If inst is zero, returns - the number of instances of this name. If interface is - true, a user-defined operator is sought, otherwise only - non-operators are sought. */ - -static const char * -find_use_name_n (const char *name, int *inst, bool interface) -{ - gfc_use_rename *u; - const char *low_name = NULL; - int i; - - /* For derived types. */ - if (name[0] != (char) TOLOWER ((unsigned char) name[0])) - low_name = gfc_dt_lower_string (name); - - i = 0; - for (u = gfc_rename_list; u; u = u->next) - { - if ((!low_name && strcmp (u->use_name, name) != 0) - || (low_name && strcmp (u->use_name, low_name) != 0) - || (u->op == INTRINSIC_USER && !interface) - || (u->op != INTRINSIC_USER && interface)) - continue; - if (++i == *inst) - break; - } - - if (!*inst) - { - *inst = i; - return NULL; - } - - if (u == NULL) - return only_flag ? NULL : name; - - u->found = 1; - - if (low_name) - { - if (u->local_name[0] == '\0') - return name; - return gfc_dt_upper_string (u->local_name); - } - - return (u->local_name[0] != '\0') ? u->local_name : name; -} - - -/* Given a name, return the name under which to load this symbol. - Returns NULL if this symbol shouldn't be loaded. */ - -static const char * -find_use_name (const char *name, bool interface) -{ - int i = 1; - return find_use_name_n (name, &i, interface); -} - - -/* Given a real name, return the number of use names associated with it. */ - -static int -number_use_names (const char *name, bool interface) -{ - int i = 0; - find_use_name_n (name, &i, interface); - return i; -} - - -/* Try to find the operator in the current list. */ - -static gfc_use_rename * -find_use_operator (gfc_intrinsic_op op) -{ - gfc_use_rename *u; - - for (u = gfc_rename_list; u; u = u->next) - if (u->op == op) - return u; - - return NULL; -} - - -/*****************************************************************/ - -/* The next couple of subroutines maintain a tree used to avoid a - brute-force search for a combination of true name and module name. - While symtree names, the name that a particular symbol is known by - can changed with USE statements, we still have to keep track of the - true names to generate the correct reference, and also avoid - loading the same real symbol twice in a program unit. - - When we start reading, the true name tree is built and maintained - as symbols are read. The tree is searched as we load new symbols - to see if it already exists someplace in the namespace. */ - -typedef struct true_name -{ - BBT_HEADER (true_name); - const char *name; - gfc_symbol *sym; -} -true_name; - -static true_name *true_name_root; - - -/* Compare two true_name structures. */ - -static int -compare_true_names (void *_t1, void *_t2) -{ - true_name *t1, *t2; - int c; - - t1 = (true_name *) _t1; - t2 = (true_name *) _t2; - - c = ((t1->sym->module > t2->sym->module) - - (t1->sym->module < t2->sym->module)); - if (c != 0) - return c; - - return strcmp (t1->name, t2->name); -} - - -/* Given a true name, search the true name tree to see if it exists - within the main namespace. */ - -static gfc_symbol * -find_true_name (const char *name, const char *module) -{ - true_name t, *p; - gfc_symbol sym; - int c; - - t.name = gfc_get_string ("%s", name); - if (module != NULL) - sym.module = gfc_get_string ("%s", module); - else - sym.module = NULL; - t.sym = &sym; - - p = true_name_root; - while (p != NULL) - { - c = compare_true_names ((void *) (&t), (void *) p); - if (c == 0) - return p->sym; - - p = (c < 0) ? p->left : p->right; - } - - return NULL; -} - - -/* Given a gfc_symbol pointer that is not in the true name tree, add it. */ - -static void -add_true_name (gfc_symbol *sym) -{ - true_name *t; - - t = XCNEW (true_name); - t->sym = sym; - if (gfc_fl_struct (sym->attr.flavor)) - t->name = gfc_dt_upper_string (sym->name); - else - t->name = sym->name; - - gfc_insert_bbt (&true_name_root, t, compare_true_names); -} - - -/* Recursive function to build the initial true name tree by - recursively traversing the current namespace. */ - -static void -build_tnt (gfc_symtree *st) -{ - const char *name; - if (st == NULL) - return; - - build_tnt (st->left); - build_tnt (st->right); - - if (gfc_fl_struct (st->n.sym->attr.flavor)) - name = gfc_dt_upper_string (st->n.sym->name); - else - name = st->n.sym->name; - - if (find_true_name (name, st->n.sym->module) != NULL) - return; - - add_true_name (st->n.sym); -} - - -/* Initialize the true name tree with the current namespace. */ - -static void -init_true_name_tree (void) -{ - true_name_root = NULL; - build_tnt (gfc_current_ns->sym_root); -} - - -/* Recursively free a true name tree node. */ - -static void -free_true_name (true_name *t) -{ - if (t == NULL) - return; - free_true_name (t->left); - free_true_name (t->right); - - free (t); -} - - -/*****************************************************************/ - -/* Module reading and writing. */ - -/* The following are versions similar to the ones in scanner.c, but - for dealing with compressed module files. */ - -static gzFile -gzopen_included_file_1 (const char *name, gfc_directorylist *list, - bool module, bool system) -{ - char *fullname; - gfc_directorylist *p; - gzFile f; - - for (p = list; p; p = p->next) - { - if (module && !p->use_for_modules) - continue; - - fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); - strcpy (fullname, p->path); - strcat (fullname, name); - - f = gzopen (fullname, "r"); - if (f != NULL) - { - if (gfc_cpp_makedep ()) - gfc_cpp_add_dep (fullname, system); - - free (module_fullpath); - module_fullpath = xstrdup (fullname); - return f; - } - } - - return NULL; -} - -static gzFile -gzopen_included_file (const char *name, bool include_cwd, bool module) -{ - gzFile f = NULL; - - if (IS_ABSOLUTE_PATH (name) || include_cwd) - { - f = gzopen (name, "r"); - if (f) - { - if (gfc_cpp_makedep ()) - gfc_cpp_add_dep (name, false); - - free (module_fullpath); - module_fullpath = xstrdup (name); - } - } - - if (!f) - f = gzopen_included_file_1 (name, include_dirs, module, false); - - return f; -} - -static gzFile -gzopen_intrinsic_module (const char* name) -{ - gzFile f = NULL; - - if (IS_ABSOLUTE_PATH (name)) - { - f = gzopen (name, "r"); - if (f) - { - if (gfc_cpp_makedep ()) - gfc_cpp_add_dep (name, true); - - free (module_fullpath); - module_fullpath = xstrdup (name); - } - } - - if (!f) - f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true); - - return f; -} - - -enum atom_type -{ - ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING -}; - -static atom_type last_atom; - - -/* The name buffer must be at least as long as a symbol name. Right - now it's not clear how we're going to store numeric constants-- - probably as a hexadecimal string, since this will allow the exact - number to be preserved (this can't be done by a decimal - representation). Worry about that later. TODO! */ - -#define MAX_ATOM_SIZE 100 - -static HOST_WIDE_INT atom_int; -static char *atom_string, atom_name[MAX_ATOM_SIZE]; - - -/* Report problems with a module. Error reporting is not very - elaborate, since this sorts of errors shouldn't really happen. - This subroutine never returns. */ - -static void bad_module (const char *) ATTRIBUTE_NORETURN; - -static void -bad_module (const char *msgid) -{ - XDELETEVEC (module_content); - module_content = NULL; - - switch (iomode) - { - case IO_INPUT: - gfc_fatal_error ("Reading module %qs at line %d column %d: %s", - module_fullpath, module_line, module_column, msgid); - break; - case IO_OUTPUT: - gfc_fatal_error ("Writing module %qs at line %d column %d: %s", - module_name, module_line, module_column, msgid); - break; - default: - gfc_fatal_error ("Module %qs at line %d column %d: %s", - module_name, module_line, module_column, msgid); - break; - } -} - - -/* Set the module's input pointer. */ - -static void -set_module_locus (module_locus *m) -{ - module_column = m->column; - module_line = m->line; - module_pos = m->pos; -} - - -/* Get the module's input pointer so that we can restore it later. */ - -static void -get_module_locus (module_locus *m) -{ - m->column = module_column; - m->line = module_line; - m->pos = module_pos; -} - -/* Peek at the next character in the module. */ - -static int -module_peek_char (void) -{ - return module_content[module_pos]; -} - -/* Get the next character in the module, updating our reckoning of - where we are. */ - -static int -module_char (void) -{ - const char c = module_content[module_pos++]; - if (c == '\0') - bad_module ("Unexpected EOF"); - - prev_module_line = module_line; - prev_module_column = module_column; - - if (c == '\n') - { - module_line++; - module_column = 0; - } - - module_column++; - return c; -} - -/* Unget a character while remembering the line and column. Works for - a single character only. */ - -static void -module_unget_char (void) -{ - module_line = prev_module_line; - module_column = prev_module_column; - module_pos--; -} - -/* Parse a string constant. The delimiter is guaranteed to be a - single quote. */ - -static void -parse_string (void) -{ - int c; - size_t cursz = 30; - size_t len = 0; - - atom_string = XNEWVEC (char, cursz); - - for ( ; ; ) - { - c = module_char (); - - if (c == '\'') - { - int c2 = module_char (); - if (c2 != '\'') - { - module_unget_char (); - break; - } - } - - if (len >= cursz) - { - cursz *= 2; - atom_string = XRESIZEVEC (char, atom_string, cursz); - } - atom_string[len] = c; - len++; - } - - atom_string = XRESIZEVEC (char, atom_string, len + 1); - atom_string[len] = '\0'; /* C-style string for debug purposes. */ -} - - -/* Parse an integer. Should fit in a HOST_WIDE_INT. */ - -static void -parse_integer (int c) -{ - int sign = 1; - - atom_int = 0; - switch (c) - { - case ('-'): - sign = -1; - case ('+'): - break; - default: - atom_int = c - '0'; - break; - } - - for (;;) - { - c = module_char (); - if (!ISDIGIT (c)) - { - module_unget_char (); - break; - } - - atom_int = 10 * atom_int + c - '0'; - } - - atom_int *= sign; -} - - -/* Parse a name. */ - -static void -parse_name (int c) -{ - char *p; - int len; - - p = atom_name; - - *p++ = c; - len = 1; - - for (;;) - { - c = module_char (); - if (!ISALNUM (c) && c != '_' && c != '-') - { - module_unget_char (); - break; - } - - *p++ = c; - if (++len > GFC_MAX_SYMBOL_LEN) - bad_module ("Name too long"); - } - - *p = '\0'; - -} - - -/* Read the next atom in the module's input stream. */ - -static atom_type -parse_atom (void) -{ - int c; - - do - { - c = module_char (); - } - while (c == ' ' || c == '\r' || c == '\n'); - - switch (c) - { - case '(': - return ATOM_LPAREN; - - case ')': - return ATOM_RPAREN; - - case '\'': - parse_string (); - return ATOM_STRING; - - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - parse_integer (c); - return ATOM_INTEGER; - - case '+': - case '-': - if (ISDIGIT (module_peek_char ())) - { - parse_integer (c); - return ATOM_INTEGER; - } - else - bad_module ("Bad name"); - - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - case 'g': - case 'h': - case 'i': - case 'j': - case 'k': - case 'l': - case 'm': - case 'n': - case 'o': - case 'p': - case 'q': - case 'r': - case 's': - case 't': - case 'u': - case 'v': - case 'w': - case 'x': - case 'y': - case 'z': - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - case 'G': - case 'H': - case 'I': - case 'J': - case 'K': - case 'L': - case 'M': - case 'N': - case 'O': - case 'P': - case 'Q': - case 'R': - case 'S': - case 'T': - case 'U': - case 'V': - case 'W': - case 'X': - case 'Y': - case 'Z': - parse_name (c); - return ATOM_NAME; - - default: - bad_module ("Bad name"); - } - - /* Not reached. */ -} - - -/* Peek at the next atom on the input. */ - -static atom_type -peek_atom (void) -{ - int c; - - do - { - c = module_char (); - } - while (c == ' ' || c == '\r' || c == '\n'); - - switch (c) - { - case '(': - module_unget_char (); - return ATOM_LPAREN; - - case ')': - module_unget_char (); - return ATOM_RPAREN; - - case '\'': - module_unget_char (); - return ATOM_STRING; - - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - module_unget_char (); - return ATOM_INTEGER; - - case '+': - case '-': - if (ISDIGIT (module_peek_char ())) - { - module_unget_char (); - return ATOM_INTEGER; - } - else - bad_module ("Bad name"); - - case 'a': - case 'b': - case 'c': - case 'd': - case 'e': - case 'f': - case 'g': - case 'h': - case 'i': - case 'j': - case 'k': - case 'l': - case 'm': - case 'n': - case 'o': - case 'p': - case 'q': - case 'r': - case 's': - case 't': - case 'u': - case 'v': - case 'w': - case 'x': - case 'y': - case 'z': - case 'A': - case 'B': - case 'C': - case 'D': - case 'E': - case 'F': - case 'G': - case 'H': - case 'I': - case 'J': - case 'K': - case 'L': - case 'M': - case 'N': - case 'O': - case 'P': - case 'Q': - case 'R': - case 'S': - case 'T': - case 'U': - case 'V': - case 'W': - case 'X': - case 'Y': - case 'Z': - module_unget_char (); - return ATOM_NAME; - - default: - bad_module ("Bad name"); - } -} - - -/* Read the next atom from the input, requiring that it be a - particular kind. */ - -static void -require_atom (atom_type type) -{ - atom_type t; - const char *p; - int column, line; - - column = module_column; - line = module_line; - - t = parse_atom (); - if (t != type) - { - switch (type) - { - case ATOM_NAME: - p = _("Expected name"); - break; - case ATOM_LPAREN: - p = _("Expected left parenthesis"); - break; - case ATOM_RPAREN: - p = _("Expected right parenthesis"); - break; - case ATOM_INTEGER: - p = _("Expected integer"); - break; - case ATOM_STRING: - p = _("Expected string"); - break; - default: - gfc_internal_error ("require_atom(): bad atom type required"); - } - - module_column = column; - module_line = line; - bad_module (p); - } -} - - -/* Given a pointer to an mstring array, require that the current input - be one of the strings in the array. We return the enum value. */ - -static int -find_enum (const mstring *m) -{ - int i; - - i = gfc_string2code (m, atom_name); - if (i >= 0) - return i; - - bad_module ("find_enum(): Enum not found"); - - /* Not reached. */ -} - - -/* Read a string. The caller is responsible for freeing. */ - -static char* -read_string (void) -{ - char* p; - require_atom (ATOM_STRING); - p = atom_string; - atom_string = NULL; - return p; -} - - -/**************** Module output subroutines ***************************/ - -/* Output a character to a module file. */ - -static void -write_char (char out) -{ - if (gzputc (module_fp, out) == EOF) - gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno)); - - if (out != '\n') - module_column++; - else - { - module_column = 1; - module_line++; - } -} - - -/* Write an atom to a module. The line wrapping isn't perfect, but it - should work most of the time. This isn't that big of a deal, since - the file really isn't meant to be read by people anyway. */ - -static void -write_atom (atom_type atom, const void *v) -{ - char buffer[32]; - - /* Workaround -Wmaybe-uninitialized false positive during - profiledbootstrap by initializing them. */ - int len; - HOST_WIDE_INT i = 0; - const char *p; - - switch (atom) - { - case ATOM_STRING: - case ATOM_NAME: - p = (const char *) v; - break; - - case ATOM_LPAREN: - p = "("; - break; - - case ATOM_RPAREN: - p = ")"; - break; - - case ATOM_INTEGER: - i = *((const HOST_WIDE_INT *) v); - - snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i); - p = buffer; - break; - - default: - gfc_internal_error ("write_atom(): Trying to write dab atom"); - - } - - if(p == NULL || *p == '\0') - len = 0; - else - len = strlen (p); - - if (atom != ATOM_RPAREN) - { - if (module_column + len > 72) - write_char ('\n'); - else - { - - if (last_atom != ATOM_LPAREN && module_column != 1) - write_char (' '); - } - } - - if (atom == ATOM_STRING) - write_char ('\''); - - while (p != NULL && *p) - { - if (atom == ATOM_STRING && *p == '\'') - write_char ('\''); - write_char (*p++); - } - - if (atom == ATOM_STRING) - write_char ('\''); - - last_atom = atom; -} - - - -/***************** Mid-level I/O subroutines *****************/ - -/* These subroutines let their caller read or write atoms without - caring about which of the two is actually happening. This lets a - subroutine concentrate on the actual format of the data being - written. */ - -static void mio_expr (gfc_expr **); -pointer_info *mio_symbol_ref (gfc_symbol **); -pointer_info *mio_interface_rest (gfc_interface **); -static void mio_symtree_ref (gfc_symtree **); - -/* Read or write an enumerated value. On writing, we return the input - value for the convenience of callers. We avoid using an integer - pointer because enums are sometimes inside bitfields. */ - -static int -mio_name (int t, const mstring *m) -{ - if (iomode == IO_OUTPUT) - write_atom (ATOM_NAME, gfc_code2string (m, t)); - else - { - require_atom (ATOM_NAME); - t = find_enum (m); - } - - return t; -} - -/* Specialization of mio_name. */ - -#define DECL_MIO_NAME(TYPE) \ - static inline TYPE \ - MIO_NAME(TYPE) (TYPE t, const mstring *m) \ - { \ - return (TYPE) mio_name ((int) t, m); \ - } -#define MIO_NAME(TYPE) mio_name_##TYPE - -static void -mio_lparen (void) -{ - if (iomode == IO_OUTPUT) - write_atom (ATOM_LPAREN, NULL); - else - require_atom (ATOM_LPAREN); -} - - -static void -mio_rparen (void) -{ - if (iomode == IO_OUTPUT) - write_atom (ATOM_RPAREN, NULL); - else - require_atom (ATOM_RPAREN); -} - - -static void -mio_integer (int *ip) -{ - if (iomode == IO_OUTPUT) - { - HOST_WIDE_INT hwi = *ip; - write_atom (ATOM_INTEGER, &hwi); - } - else - { - require_atom (ATOM_INTEGER); - *ip = atom_int; - } -} - -static void -mio_hwi (HOST_WIDE_INT *hwi) -{ - if (iomode == IO_OUTPUT) - write_atom (ATOM_INTEGER, hwi); - else - { - require_atom (ATOM_INTEGER); - *hwi = atom_int; - } -} - - -/* Read or write a gfc_intrinsic_op value. */ - -static void -mio_intrinsic_op (gfc_intrinsic_op* op) -{ - /* FIXME: Would be nicer to do this via the operators symbolic name. */ - if (iomode == IO_OUTPUT) - { - HOST_WIDE_INT converted = (HOST_WIDE_INT) *op; - write_atom (ATOM_INTEGER, &converted); - } - else - { - require_atom (ATOM_INTEGER); - *op = (gfc_intrinsic_op) atom_int; - } -} - - -/* Read or write a character pointer that points to a string on the heap. */ - -static const char * -mio_allocated_string (const char *s) -{ - if (iomode == IO_OUTPUT) - { - write_atom (ATOM_STRING, s); - return s; - } - else - { - require_atom (ATOM_STRING); - return atom_string; - } -} - - -/* Functions for quoting and unquoting strings. */ - -static char * -quote_string (const gfc_char_t *s, const size_t slength) -{ - const gfc_char_t *p; - char *res, *q; - size_t len = 0, i; - - /* Calculate the length we'll need: a backslash takes two ("\\"), - non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */ - for (p = s, i = 0; i < slength; p++, i++) - { - if (*p == '\\') - len += 2; - else if (!gfc_wide_is_printable (*p)) - len += 10; - else - len++; - } - - q = res = XCNEWVEC (char, len + 1); - for (p = s, i = 0; i < slength; p++, i++) - { - if (*p == '\\') - *q++ = '\\', *q++ = '\\'; - else if (!gfc_wide_is_printable (*p)) - { - sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x", - (unsigned HOST_WIDE_INT) *p); - q += 10; - } - else - *q++ = (unsigned char) *p; - } - - res[len] = '\0'; - return res; -} - -static gfc_char_t * -unquote_string (const char *s) -{ - size_t len, i; - const char *p; - gfc_char_t *res; - - for (p = s, len = 0; *p; p++, len++) - { - if (*p != '\\') - continue; - - if (p[1] == '\\') - p++; - else if (p[1] == 'U') - p += 9; /* That is a "\U????????". */ - else - gfc_internal_error ("unquote_string(): got bad string"); - } - - res = gfc_get_wide_string (len + 1); - for (i = 0, p = s; i < len; i++, p++) - { - gcc_assert (*p); - - if (*p != '\\') - res[i] = (unsigned char) *p; - else if (p[1] == '\\') - { - res[i] = (unsigned char) '\\'; - p++; - } - else - { - /* We read the 8-digits hexadecimal constant that follows. */ - int j; - unsigned n; - gfc_char_t c = 0; - - gcc_assert (p[1] == 'U'); - for (j = 0; j < 8; j++) - { - c = c << 4; - gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1); - c += n; - } - - res[i] = c; - p += 9; - } - } - - res[len] = '\0'; - return res; -} - - -/* Read or write a character pointer that points to a wide string on the - heap, performing quoting/unquoting of nonprintable characters using the - form \U???????? (where each ? is a hexadecimal digit). - Length is the length of the string, only known and used in output mode. */ - -static const gfc_char_t * -mio_allocated_wide_string (const gfc_char_t *s, const size_t length) -{ - if (iomode == IO_OUTPUT) - { - char *quoted = quote_string (s, length); - write_atom (ATOM_STRING, quoted); - free (quoted); - return s; - } - else - { - gfc_char_t *unquoted; - - require_atom (ATOM_STRING); - unquoted = unquote_string (atom_string); - free (atom_string); - return unquoted; - } -} - - -/* Read or write a string that is in static memory. */ - -static void -mio_pool_string (const char **stringp) -{ - /* TODO: one could write the string only once, and refer to it via a - fixup pointer. */ - - /* As a special case we have to deal with a NULL string. This - happens for the 'module' member of 'gfc_symbol's that are not in a - module. We read / write these as the empty string. */ - if (iomode == IO_OUTPUT) - { - const char *p = *stringp == NULL ? "" : *stringp; - write_atom (ATOM_STRING, p); - } - else - { - require_atom (ATOM_STRING); - *stringp = (atom_string[0] == '\0' - ? NULL : gfc_get_string ("%s", atom_string)); - free (atom_string); - } -} - - -/* Read or write a string that is inside of some already-allocated - structure. */ - -static void -mio_internal_string (char *string) -{ - if (iomode == IO_OUTPUT) - write_atom (ATOM_STRING, string); - else - { - require_atom (ATOM_STRING); - strcpy (string, atom_string); - free (atom_string); - } -} - - -enum ab_attribute -{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL, - AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA, - AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, - AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, - AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, - AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP, - AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP, - AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, - AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, - AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, - AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, - AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, - AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, - AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, - AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, - AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, - AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, - AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, - AB_OACC_ROUTINE_NOHOST, - AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS, - AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS, - AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, - AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST, - AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY -}; - -static const mstring attr_bits[] = -{ - minit ("ALLOCATABLE", AB_ALLOCATABLE), - minit ("ARTIFICIAL", AB_ARTIFICIAL), - minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), - minit ("DIMENSION", AB_DIMENSION), - minit ("CODIMENSION", AB_CODIMENSION), - minit ("CONTIGUOUS", AB_CONTIGUOUS), - minit ("EXTERNAL", AB_EXTERNAL), - minit ("INTRINSIC", AB_INTRINSIC), - minit ("OPTIONAL", AB_OPTIONAL), - minit ("POINTER", AB_POINTER), - minit ("VOLATILE", AB_VOLATILE), - minit ("TARGET", AB_TARGET), - minit ("THREADPRIVATE", AB_THREADPRIVATE), - minit ("DUMMY", AB_DUMMY), - minit ("RESULT", AB_RESULT), - minit ("DATA", AB_DATA), - minit ("IN_NAMELIST", AB_IN_NAMELIST), - minit ("IN_COMMON", AB_IN_COMMON), - minit ("FUNCTION", AB_FUNCTION), - minit ("SUBROUTINE", AB_SUBROUTINE), - minit ("SEQUENCE", AB_SEQUENCE), - minit ("ELEMENTAL", AB_ELEMENTAL), - minit ("PURE", AB_PURE), - minit ("RECURSIVE", AB_RECURSIVE), - minit ("GENERIC", AB_GENERIC), - minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), - minit ("CRAY_POINTER", AB_CRAY_POINTER), - minit ("CRAY_POINTEE", AB_CRAY_POINTEE), - minit ("IS_BIND_C", AB_IS_BIND_C), - minit ("IS_C_INTEROP", AB_IS_C_INTEROP), - minit ("IS_ISO_C", AB_IS_ISO_C), - minit ("VALUE", AB_VALUE), - minit ("ALLOC_COMP", AB_ALLOC_COMP), - minit ("COARRAY_COMP", AB_COARRAY_COMP), - minit ("LOCK_COMP", AB_LOCK_COMP), - minit ("EVENT_COMP", AB_EVENT_COMP), - minit ("POINTER_COMP", AB_POINTER_COMP), - minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP), - minit ("PRIVATE_COMP", AB_PRIVATE_COMP), - minit ("ZERO_COMP", AB_ZERO_COMP), - minit ("PROTECTED", AB_PROTECTED), - minit ("ABSTRACT", AB_ABSTRACT), - minit ("IS_CLASS", AB_IS_CLASS), - minit ("PROCEDURE", AB_PROCEDURE), - minit ("PROC_POINTER", AB_PROC_POINTER), - minit ("VTYPE", AB_VTYPE), - minit ("VTAB", AB_VTAB), - minit ("CLASS_POINTER", AB_CLASS_POINTER), - minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), - minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), - minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET), - minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY), - minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE), - minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE), - minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN), - minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR), - minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), - minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), - minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), - minit ("PDT_KIND", AB_PDT_KIND), - minit ("PDT_LEN", AB_PDT_LEN), - minit ("PDT_TYPE", AB_PDT_TYPE), - minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE), - minit ("PDT_ARRAY", AB_PDT_ARRAY), - minit ("PDT_STRING", AB_PDT_STRING), - minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG), - minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), - minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), - minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ), - minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST), - minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD), - minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS), - minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY), - minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS), - minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST), - minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL), - minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED), - minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST), - minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST), - minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY), - minit (NULL, -1) -}; - -/* For binding attributes. */ -static const mstring binding_passing[] = -{ - minit ("PASS", 0), - minit ("NOPASS", 1), - minit (NULL, -1) -}; -static const mstring binding_overriding[] = -{ - minit ("OVERRIDABLE", 0), - minit ("NON_OVERRIDABLE", 1), - minit ("DEFERRED", 2), - minit (NULL, -1) -}; -static const mstring binding_generic[] = -{ - minit ("SPECIFIC", 0), - minit ("GENERIC", 1), - minit (NULL, -1) -}; -static const mstring binding_ppc[] = -{ - minit ("NO_PPC", 0), - minit ("PPC", 1), - minit (NULL, -1) -}; - -/* Specialization of mio_name. */ -DECL_MIO_NAME (ab_attribute) -DECL_MIO_NAME (ar_type) -DECL_MIO_NAME (array_type) -DECL_MIO_NAME (bt) -DECL_MIO_NAME (expr_t) -DECL_MIO_NAME (gfc_access) -DECL_MIO_NAME (gfc_intrinsic_op) -DECL_MIO_NAME (ifsrc) -DECL_MIO_NAME (save_state) -DECL_MIO_NAME (procedure_type) -DECL_MIO_NAME (ref_type) -DECL_MIO_NAME (sym_flavor) -DECL_MIO_NAME (sym_intent) -DECL_MIO_NAME (inquiry_type) -#undef DECL_MIO_NAME - -/* Verify OACC_ROUTINE_LOP_NONE. */ - -static void -verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop) -{ - if (lop != OACC_ROUTINE_LOP_NONE) - bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism"); -} - -/* Symbol attributes are stored in list with the first three elements - being the enumerated fields, while the remaining elements (if any) - indicate the individual attribute bits. The access field is not - saved-- it controls what symbols are exported when a module is - written. */ - -static void -mio_symbol_attribute (symbol_attribute *attr) -{ - atom_type t; - unsigned ext_attr,extension_level; - - mio_lparen (); - - attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors); - attr->intent = MIO_NAME (sym_intent) (attr->intent, intents); - attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures); - attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types); - attr->save = MIO_NAME (save_state) (attr->save, save_status); - - ext_attr = attr->ext_attr; - mio_integer ((int *) &ext_attr); - attr->ext_attr = ext_attr; - - extension_level = attr->extension; - mio_integer ((int *) &extension_level); - attr->extension = extension_level; - - if (iomode == IO_OUTPUT) - { - if (attr->allocatable) - MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits); - if (attr->artificial) - MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits); - if (attr->asynchronous) - MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits); - if (attr->dimension) - MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); - if (attr->codimension) - MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); - if (attr->contiguous) - MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits); - if (attr->external) - MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); - if (attr->intrinsic) - MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits); - if (attr->optional) - MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits); - if (attr->pointer) - MIO_NAME (ab_attribute) (AB_POINTER, attr_bits); - if (attr->class_pointer) - MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits); - if (attr->is_protected) - MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits); - if (attr->value) - MIO_NAME (ab_attribute) (AB_VALUE, attr_bits); - if (attr->volatile_) - MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits); - if (attr->target) - MIO_NAME (ab_attribute) (AB_TARGET, attr_bits); - if (attr->threadprivate) - MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits); - if (attr->dummy) - MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits); - if (attr->result) - MIO_NAME (ab_attribute) (AB_RESULT, attr_bits); - /* We deliberately don't preserve the "entry" flag. */ - - if (attr->data) - MIO_NAME (ab_attribute) (AB_DATA, attr_bits); - if (attr->in_namelist) - MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits); - if (attr->in_common) - MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits); - - if (attr->function) - MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits); - if (attr->subroutine) - MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits); - if (attr->generic) - MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits); - if (attr->abstract) - MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits); - - if (attr->sequence) - MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits); - if (attr->elemental) - MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits); - if (attr->pure) - MIO_NAME (ab_attribute) (AB_PURE, attr_bits); - if (attr->implicit_pure) - MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits); - if (attr->unlimited_polymorphic) - MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits); - if (attr->recursive) - MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits); - if (attr->always_explicit) - MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits); - if (attr->cray_pointer) - MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits); - if (attr->cray_pointee) - MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits); - if (attr->is_bind_c) - MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits); - if (attr->is_c_interop) - MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits); - if (attr->is_iso_c) - MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits); - if (attr->alloc_comp) - MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits); - if (attr->pointer_comp) - MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits); - if (attr->proc_pointer_comp) - MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits); - if (attr->private_comp) - MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); - if (attr->coarray_comp) - MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits); - if (attr->lock_comp) - MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits); - if (attr->event_comp) - MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits); - if (attr->zero_comp) - MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); - if (attr->is_class) - MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits); - if (attr->procedure) - MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits); - if (attr->proc_pointer) - MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits); - if (attr->vtype) - MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits); - if (attr->vtab) - MIO_NAME (ab_attribute) (AB_VTAB, attr_bits); - if (attr->omp_declare_target) - MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits); - if (attr->array_outer_dependency) - MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits); - if (attr->module_procedure) - MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits); - if (attr->oacc_declare_create) - MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits); - if (attr->oacc_declare_copyin) - MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits); - if (attr->oacc_declare_deviceptr) - MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits); - if (attr->oacc_declare_device_resident) - MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits); - if (attr->oacc_declare_link) - MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); - if (attr->omp_declare_target_link) - MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); - if (attr->pdt_kind) - MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); - if (attr->pdt_len) - MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits); - if (attr->pdt_type) - MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits); - if (attr->pdt_template) - MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits); - if (attr->pdt_array) - MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits); - if (attr->pdt_string) - MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits); - switch (attr->oacc_routine_lop) - { - case OACC_ROUTINE_LOP_NONE: - /* This is the default anyway, and for maintaining compatibility with - the current MOD_VERSION, we're not emitting anything in that - case. */ - break; - case OACC_ROUTINE_LOP_GANG: - MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits); - break; - case OACC_ROUTINE_LOP_WORKER: - MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits); - break; - case OACC_ROUTINE_LOP_VECTOR: - MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits); - break; - case OACC_ROUTINE_LOP_SEQ: - MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits); - break; - case OACC_ROUTINE_LOP_ERROR: - /* ... intentionally omitted here; it's only unsed internally. */ - default: - gcc_unreachable (); - } - if (attr->oacc_routine_nohost) - MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_NOHOST, attr_bits); - - if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires) - { - if (gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD) - MIO_NAME (ab_attribute) (AB_OMP_REQ_REVERSE_OFFLOAD, attr_bits); - if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS) - MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_ADDRESS, attr_bits); - if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) - MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY, attr_bits); - if (gfc_current_ns->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) - MIO_NAME (ab_attribute) (AB_OMP_REQ_DYNAMIC_ALLOCATORS, attr_bits); - if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) - MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_SEQ_CST, attr_bits); - if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) - MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQ_REL, attr_bits); - if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) - MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits); - } - switch (attr->omp_device_type) - { - case OMP_DEVICE_TYPE_UNSET: - break; - case OMP_DEVICE_TYPE_HOST: - MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_HOST, attr_bits); - break; - case OMP_DEVICE_TYPE_NOHOST: - MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits); - break; - case OMP_DEVICE_TYPE_ANY: - MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits); - break; - default: - gcc_unreachable (); - } - mio_rparen (); - } - else - { - for (;;) - { - t = parse_atom (); - if (t == ATOM_RPAREN) - break; - if (t != ATOM_NAME) - bad_module ("Expected attribute bit name"); - - switch ((ab_attribute) find_enum (attr_bits)) - { - case AB_ALLOCATABLE: - attr->allocatable = 1; - break; - case AB_ARTIFICIAL: - attr->artificial = 1; - break; - case AB_ASYNCHRONOUS: - attr->asynchronous = 1; - break; - case AB_DIMENSION: - attr->dimension = 1; - break; - case AB_CODIMENSION: - attr->codimension = 1; - break; - case AB_CONTIGUOUS: - attr->contiguous = 1; - break; - case AB_EXTERNAL: - attr->external = 1; - break; - case AB_INTRINSIC: - attr->intrinsic = 1; - break; - case AB_OPTIONAL: - attr->optional = 1; - break; - case AB_POINTER: - attr->pointer = 1; - break; - case AB_CLASS_POINTER: - attr->class_pointer = 1; - break; - case AB_PROTECTED: - attr->is_protected = 1; - break; - case AB_VALUE: - attr->value = 1; - break; - case AB_VOLATILE: - attr->volatile_ = 1; - break; - case AB_TARGET: - attr->target = 1; - break; - case AB_THREADPRIVATE: - attr->threadprivate = 1; - break; - case AB_DUMMY: - attr->dummy = 1; - break; - case AB_RESULT: - attr->result = 1; - break; - case AB_DATA: - attr->data = 1; - break; - case AB_IN_NAMELIST: - attr->in_namelist = 1; - break; - case AB_IN_COMMON: - attr->in_common = 1; - break; - case AB_FUNCTION: - attr->function = 1; - break; - case AB_SUBROUTINE: - attr->subroutine = 1; - break; - case AB_GENERIC: - attr->generic = 1; - break; - case AB_ABSTRACT: - attr->abstract = 1; - break; - case AB_SEQUENCE: - attr->sequence = 1; - break; - case AB_ELEMENTAL: - attr->elemental = 1; - break; - case AB_PURE: - attr->pure = 1; - break; - case AB_IMPLICIT_PURE: - attr->implicit_pure = 1; - break; - case AB_UNLIMITED_POLY: - attr->unlimited_polymorphic = 1; - break; - case AB_RECURSIVE: - attr->recursive = 1; - break; - case AB_ALWAYS_EXPLICIT: - attr->always_explicit = 1; - break; - case AB_CRAY_POINTER: - attr->cray_pointer = 1; - break; - case AB_CRAY_POINTEE: - attr->cray_pointee = 1; - break; - case AB_IS_BIND_C: - attr->is_bind_c = 1; - break; - case AB_IS_C_INTEROP: - attr->is_c_interop = 1; - break; - case AB_IS_ISO_C: - attr->is_iso_c = 1; - break; - case AB_ALLOC_COMP: - attr->alloc_comp = 1; - break; - case AB_COARRAY_COMP: - attr->coarray_comp = 1; - break; - case AB_LOCK_COMP: - attr->lock_comp = 1; - break; - case AB_EVENT_COMP: - attr->event_comp = 1; - break; - case AB_POINTER_COMP: - attr->pointer_comp = 1; - break; - case AB_PROC_POINTER_COMP: - attr->proc_pointer_comp = 1; - break; - case AB_PRIVATE_COMP: - attr->private_comp = 1; - break; - case AB_ZERO_COMP: - attr->zero_comp = 1; - break; - case AB_IS_CLASS: - attr->is_class = 1; - break; - case AB_PROCEDURE: - attr->procedure = 1; - break; - case AB_PROC_POINTER: - attr->proc_pointer = 1; - break; - case AB_VTYPE: - attr->vtype = 1; - break; - case AB_VTAB: - attr->vtab = 1; - break; - case AB_OMP_DECLARE_TARGET: - attr->omp_declare_target = 1; - break; - case AB_OMP_DECLARE_TARGET_LINK: - attr->omp_declare_target_link = 1; - break; - case AB_ARRAY_OUTER_DEPENDENCY: - attr->array_outer_dependency =1; - break; - case AB_MODULE_PROCEDURE: - attr->module_procedure =1; - break; - case AB_OACC_DECLARE_CREATE: - attr->oacc_declare_create = 1; - break; - case AB_OACC_DECLARE_COPYIN: - attr->oacc_declare_copyin = 1; - break; - case AB_OACC_DECLARE_DEVICEPTR: - attr->oacc_declare_deviceptr = 1; - break; - case AB_OACC_DECLARE_DEVICE_RESIDENT: - attr->oacc_declare_device_resident = 1; - break; - case AB_OACC_DECLARE_LINK: - attr->oacc_declare_link = 1; - break; - case AB_PDT_KIND: - attr->pdt_kind = 1; - break; - case AB_PDT_LEN: - attr->pdt_len = 1; - break; - case AB_PDT_TYPE: - attr->pdt_type = 1; - break; - case AB_PDT_TEMPLATE: - attr->pdt_template = 1; - break; - case AB_PDT_ARRAY: - attr->pdt_array = 1; - break; - case AB_PDT_STRING: - attr->pdt_string = 1; - break; - case AB_OACC_ROUTINE_LOP_GANG: - verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); - attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG; - break; - case AB_OACC_ROUTINE_LOP_WORKER: - verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); - attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER; - break; - case AB_OACC_ROUTINE_LOP_VECTOR: - verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); - attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR; - break; - case AB_OACC_ROUTINE_LOP_SEQ: - verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); - attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ; - break; - case AB_OACC_ROUTINE_NOHOST: - attr->oacc_routine_nohost = 1; - break; - case AB_OMP_REQ_REVERSE_OFFLOAD: - gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD, - "reverse_offload", - &gfc_current_locus, - module_name); - break; - case AB_OMP_REQ_UNIFIED_ADDRESS: - gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS, - "unified_address", - &gfc_current_locus, - module_name); - break; - case AB_OMP_REQ_UNIFIED_SHARED_MEMORY: - gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY, - "unified_shared_memory", - &gfc_current_locus, - module_name); - break; - case AB_OMP_REQ_DYNAMIC_ALLOCATORS: - gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS, - "dynamic_allocators", - &gfc_current_locus, - module_name); - break; - case AB_OMP_REQ_MEM_ORDER_SEQ_CST: - gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST, - "seq_cst", &gfc_current_locus, - module_name); - break; - case AB_OMP_REQ_MEM_ORDER_ACQ_REL: - gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL, - "acq_rel", &gfc_current_locus, - module_name); - break; - case AB_OMP_REQ_MEM_ORDER_RELAXED: - gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED, - "relaxed", &gfc_current_locus, - module_name); - break; - case AB_OMP_DEVICE_TYPE_HOST: - attr->omp_device_type = OMP_DEVICE_TYPE_HOST; - break; - case AB_OMP_DEVICE_TYPE_NOHOST: - attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST; - break; - case AB_OMP_DEVICE_TYPE_ANY: - attr->omp_device_type = OMP_DEVICE_TYPE_ANY; - break; - } - } - } -} - - -static const mstring bt_types[] = { - minit ("INTEGER", BT_INTEGER), - minit ("REAL", BT_REAL), - minit ("COMPLEX", BT_COMPLEX), - minit ("LOGICAL", BT_LOGICAL), - minit ("CHARACTER", BT_CHARACTER), - minit ("UNION", BT_UNION), - minit ("DERIVED", BT_DERIVED), - minit ("CLASS", BT_CLASS), - minit ("PROCEDURE", BT_PROCEDURE), - minit ("UNKNOWN", BT_UNKNOWN), - minit ("VOID", BT_VOID), - minit ("ASSUMED", BT_ASSUMED), - minit (NULL, -1) -}; - - -static void -mio_charlen (gfc_charlen **clp) -{ - gfc_charlen *cl; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - cl = *clp; - if (cl != NULL) - mio_expr (&cl->length); - } - else - { - if (peek_atom () != ATOM_RPAREN) - { - cl = gfc_new_charlen (gfc_current_ns, NULL); - mio_expr (&cl->length); - *clp = cl; - } - } - - mio_rparen (); -} - - -/* See if a name is a generated name. */ - -static int -check_unique_name (const char *name) -{ - return *name == '@'; -} - - -static void -mio_typespec (gfc_typespec *ts) -{ - mio_lparen (); - - ts->type = MIO_NAME (bt) (ts->type, bt_types); - - if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS) - mio_integer (&ts->kind); - else - mio_symbol_ref (&ts->u.derived); - - mio_symbol_ref (&ts->interface); - - /* Add info for C interop and is_iso_c. */ - mio_integer (&ts->is_c_interop); - mio_integer (&ts->is_iso_c); - - /* If the typespec is for an identifier either from iso_c_binding, or - a constant that was initialized to an identifier from it, use the - f90_type. Otherwise, use the ts->type, since it shouldn't matter. */ - if (ts->is_iso_c) - ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types); - else - ts->f90_type = MIO_NAME (bt) (ts->type, bt_types); - - if (ts->type != BT_CHARACTER) - { - /* ts->u.cl is only valid for BT_CHARACTER. */ - mio_lparen (); - mio_rparen (); - } - else - mio_charlen (&ts->u.cl); - - /* So as not to disturb the existing API, use an ATOM_NAME to - transmit deferred characteristic for characters (F2003). */ - if (iomode == IO_OUTPUT) - { - if (ts->type == BT_CHARACTER && ts->deferred) - write_atom (ATOM_NAME, "DEFERRED_CL"); - } - else if (peek_atom () != ATOM_RPAREN) - { - if (parse_atom () != ATOM_NAME) - bad_module ("Expected string"); - ts->deferred = 1; - } - - mio_rparen (); -} - - -static const mstring array_spec_types[] = { - minit ("EXPLICIT", AS_EXPLICIT), - minit ("ASSUMED_RANK", AS_ASSUMED_RANK), - minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE), - minit ("DEFERRED", AS_DEFERRED), - minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE), - minit (NULL, -1) -}; - - -static void -mio_array_spec (gfc_array_spec **asp) -{ - gfc_array_spec *as; - int i; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - int rank; - - if (*asp == NULL) - goto done; - as = *asp; - - /* mio_integer expects nonnegative values. */ - rank = as->rank > 0 ? as->rank : 0; - mio_integer (&rank); - } - else - { - if (peek_atom () == ATOM_RPAREN) - { - *asp = NULL; - goto done; - } - - *asp = as = gfc_get_array_spec (); - mio_integer (&as->rank); - } - - mio_integer (&as->corank); - as->type = MIO_NAME (array_type) (as->type, array_spec_types); - - if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK) - as->rank = -1; - if (iomode == IO_INPUT && as->corank) - as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT; - - if (as->rank + as->corank > 0) - for (i = 0; i < as->rank + as->corank; i++) - { - mio_expr (&as->lower[i]); - mio_expr (&as->upper[i]); - } - -done: - mio_rparen (); -} - - -/* Given a pointer to an array reference structure (which lives in a - gfc_ref structure), find the corresponding array specification - structure. Storing the pointer in the ref structure doesn't quite - work when loading from a module. Generating code for an array - reference also needs more information than just the array spec. */ - -static const mstring array_ref_types[] = { - minit ("FULL", AR_FULL), - minit ("ELEMENT", AR_ELEMENT), - minit ("SECTION", AR_SECTION), - minit (NULL, -1) -}; - - -static void -mio_array_ref (gfc_array_ref *ar) -{ - int i; - - mio_lparen (); - ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types); - mio_integer (&ar->dimen); - - switch (ar->type) - { - case AR_FULL: - break; - - case AR_ELEMENT: - for (i = 0; i < ar->dimen; i++) - mio_expr (&ar->start[i]); - - break; - - case AR_SECTION: - for (i = 0; i < ar->dimen; i++) - { - mio_expr (&ar->start[i]); - mio_expr (&ar->end[i]); - mio_expr (&ar->stride[i]); - } - - break; - - case AR_UNKNOWN: - gfc_internal_error ("mio_array_ref(): Unknown array ref"); - } - - /* Unfortunately, ar->dimen_type is an anonymous enumerated type so - we can't call mio_integer directly. Instead loop over each element - and cast it to/from an integer. */ - if (iomode == IO_OUTPUT) - { - for (i = 0; i < ar->dimen; i++) - { - HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i]; - write_atom (ATOM_INTEGER, &tmp); - } - } - else - { - for (i = 0; i < ar->dimen; i++) - { - require_atom (ATOM_INTEGER); - ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int; - } - } - - if (iomode == IO_INPUT) - { - ar->where = gfc_current_locus; - - for (i = 0; i < ar->dimen; i++) - ar->c_where[i] = gfc_current_locus; - } - - mio_rparen (); -} - - -/* Saves or restores a pointer. The pointer is converted back and - forth from an integer. We return the pointer_info pointer so that - the caller can take additional action based on the pointer type. */ - -static pointer_info * -mio_pointer_ref (void *gp) -{ - pointer_info *p; - - if (iomode == IO_OUTPUT) - { - p = get_pointer (*((char **) gp)); - HOST_WIDE_INT hwi = p->integer; - write_atom (ATOM_INTEGER, &hwi); - } - else - { - require_atom (ATOM_INTEGER); - p = add_fixup (atom_int, gp); - } - - return p; -} - - -/* Save and load references to components that occur within - expressions. We have to describe these references by a number and - by name. The number is necessary for forward references during - reading, and the name is necessary if the symbol already exists in - the namespace and is not loaded again. */ - -static void -mio_component_ref (gfc_component **cp) -{ - pointer_info *p; - - p = mio_pointer_ref (cp); - if (p->type == P_UNKNOWN) - p->type = P_COMPONENT; -} - - -static void mio_namespace_ref (gfc_namespace **nsp); -static void mio_formal_arglist (gfc_formal_arglist **formal); -static void mio_typebound_proc (gfc_typebound_proc** proc); -static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt); - -static void -mio_component (gfc_component *c, int vtype) -{ - pointer_info *p; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - p = get_pointer (c); - mio_hwi (&p->integer); - } - else - { - HOST_WIDE_INT n; - mio_hwi (&n); - p = get_integer (n); - associate_integer_pointer (p, c); - } - - if (p->type == P_UNKNOWN) - p->type = P_COMPONENT; - - mio_pool_string (&c->name); - mio_typespec (&c->ts); - mio_array_spec (&c->as); - - /* PDT templates store the expression for the kind of a component here. */ - mio_expr (&c->kind_expr); - - /* PDT types store the component specification list here. */ - mio_actual_arglist (&c->param_list, true); - - mio_symbol_attribute (&c->attr); - if (c->ts.type == BT_CLASS) - c->attr.class_ok = 1; - c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); - - if (!vtype || strcmp (c->name, "_final") == 0 - || strcmp (c->name, "_hash") == 0) - mio_expr (&c->initializer); - - if (c->attr.proc_pointer) - mio_typebound_proc (&c->tb); - - c->loc = gfc_current_locus; - - mio_rparen (); -} - - -static void -mio_component_list (gfc_component **cp, int vtype) -{ - gfc_component *c, *tail; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - for (c = *cp; c; c = c->next) - mio_component (c, vtype); - } - else - { - *cp = NULL; - tail = NULL; - - for (;;) - { - if (peek_atom () == ATOM_RPAREN) - break; - - c = gfc_get_component (); - mio_component (c, vtype); - - if (tail == NULL) - *cp = c; - else - tail->next = c; - - tail = c; - } - } - - mio_rparen (); -} - - -static void -mio_actual_arg (gfc_actual_arglist *a, bool pdt) -{ - mio_lparen (); - mio_pool_string (&a->name); - mio_expr (&a->expr); - if (pdt) - mio_integer ((int *)&a->spec_type); - mio_rparen (); -} - - -static void -mio_actual_arglist (gfc_actual_arglist **ap, bool pdt) -{ - gfc_actual_arglist *a, *tail; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - for (a = *ap; a; a = a->next) - mio_actual_arg (a, pdt); - - } - else - { - tail = NULL; - - for (;;) - { - if (peek_atom () != ATOM_LPAREN) - break; - - a = gfc_get_actual_arglist (); - - if (tail == NULL) - *ap = a; - else - tail->next = a; - - tail = a; - mio_actual_arg (a, pdt); - } - } - - mio_rparen (); -} - - -/* Read and write formal argument lists. */ - -static void -mio_formal_arglist (gfc_formal_arglist **formal) -{ - gfc_formal_arglist *f, *tail; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - for (f = *formal; f; f = f->next) - mio_symbol_ref (&f->sym); - } - else - { - *formal = tail = NULL; - - while (peek_atom () != ATOM_RPAREN) - { - f = gfc_get_formal_arglist (); - mio_symbol_ref (&f->sym); - - if (*formal == NULL) - *formal = f; - else - tail->next = f; - - tail = f; - } - } - - mio_rparen (); -} - - -/* Save or restore a reference to a symbol node. */ - -pointer_info * -mio_symbol_ref (gfc_symbol **symp) -{ - pointer_info *p; - - p = mio_pointer_ref (symp); - if (p->type == P_UNKNOWN) - p->type = P_SYMBOL; - - if (iomode == IO_OUTPUT) - { - if (p->u.wsym.state == UNREFERENCED) - p->u.wsym.state = NEEDS_WRITE; - } - else - { - if (p->u.rsym.state == UNUSED) - p->u.rsym.state = NEEDED; - } - return p; -} - - -/* Save or restore a reference to a symtree node. */ - -static void -mio_symtree_ref (gfc_symtree **stp) -{ - pointer_info *p; - fixup_t *f; - - if (iomode == IO_OUTPUT) - mio_symbol_ref (&(*stp)->n.sym); - else - { - require_atom (ATOM_INTEGER); - p = get_integer (atom_int); - - /* An unused equivalence member; make a symbol and a symtree - for it. */ - if (in_load_equiv && p->u.rsym.symtree == NULL) - { - /* Since this is not used, it must have a unique name. */ - p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns); - - /* Make the symbol. */ - if (p->u.rsym.sym == NULL) - { - p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name, - gfc_current_ns); - p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module); - } - - p->u.rsym.symtree->n.sym = p->u.rsym.sym; - p->u.rsym.symtree->n.sym->refs++; - p->u.rsym.referenced = 1; - - /* If the symbol is PRIVATE and in COMMON, load_commons will - generate a fixup symbol, which must be associated. */ - if (p->fixup) - resolve_fixups (p->fixup, p->u.rsym.sym); - p->fixup = NULL; - } - - if (p->type == P_UNKNOWN) - p->type = P_SYMBOL; - - if (p->u.rsym.state == UNUSED) - p->u.rsym.state = NEEDED; - - if (p->u.rsym.symtree != NULL) - { - *stp = p->u.rsym.symtree; - } - else - { - f = XCNEW (fixup_t); - - f->next = p->u.rsym.stfixup; - p->u.rsym.stfixup = f; - - f->pointer = (void **) stp; - } - } -} - - -static void -mio_iterator (gfc_iterator **ip) -{ - gfc_iterator *iter; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - if (*ip == NULL) - goto done; - } - else - { - if (peek_atom () == ATOM_RPAREN) - { - *ip = NULL; - goto done; - } - - *ip = gfc_get_iterator (); - } - - iter = *ip; - - mio_expr (&iter->var); - mio_expr (&iter->start); - mio_expr (&iter->end); - mio_expr (&iter->step); - -done: - mio_rparen (); -} - - -static void -mio_constructor (gfc_constructor_base *cp) -{ - gfc_constructor *c; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c)) - { - mio_lparen (); - mio_expr (&c->expr); - mio_iterator (&c->iterator); - mio_rparen (); - } - } - else - { - while (peek_atom () != ATOM_RPAREN) - { - c = gfc_constructor_append_expr (cp, NULL, NULL); - - mio_lparen (); - mio_expr (&c->expr); - mio_iterator (&c->iterator); - mio_rparen (); - } - } - - mio_rparen (); -} - - -static const mstring ref_types[] = { - minit ("ARRAY", REF_ARRAY), - minit ("COMPONENT", REF_COMPONENT), - minit ("SUBSTRING", REF_SUBSTRING), - minit ("INQUIRY", REF_INQUIRY), - minit (NULL, -1) -}; - -static const mstring inquiry_types[] = { - minit ("RE", INQUIRY_RE), - minit ("IM", INQUIRY_IM), - minit ("KIND", INQUIRY_KIND), - minit ("LEN", INQUIRY_LEN), - minit (NULL, -1) -}; - - -static void -mio_ref (gfc_ref **rp) -{ - gfc_ref *r; - - mio_lparen (); - - r = *rp; - r->type = MIO_NAME (ref_type) (r->type, ref_types); - - switch (r->type) - { - case REF_ARRAY: - mio_array_ref (&r->u.ar); - break; - - case REF_COMPONENT: - mio_symbol_ref (&r->u.c.sym); - mio_component_ref (&r->u.c.component); - break; - - case REF_SUBSTRING: - mio_expr (&r->u.ss.start); - mio_expr (&r->u.ss.end); - mio_charlen (&r->u.ss.length); - break; - - case REF_INQUIRY: - r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types); - break; - } - - mio_rparen (); -} - - -static void -mio_ref_list (gfc_ref **rp) -{ - gfc_ref *ref, *head, *tail; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - for (ref = *rp; ref; ref = ref->next) - mio_ref (&ref); - } - else - { - head = tail = NULL; - - while (peek_atom () != ATOM_RPAREN) - { - if (head == NULL) - head = tail = gfc_get_ref (); - else - { - tail->next = gfc_get_ref (); - tail = tail->next; - } - - mio_ref (&tail); - } - - *rp = head; - } - - mio_rparen (); -} - - -/* Read and write an integer value. */ - -static void -mio_gmp_integer (mpz_t *integer) -{ - char *p; - - if (iomode == IO_INPUT) - { - if (parse_atom () != ATOM_STRING) - bad_module ("Expected integer string"); - - mpz_init (*integer); - if (mpz_set_str (*integer, atom_string, 10)) - bad_module ("Error converting integer"); - - free (atom_string); - } - else - { - p = mpz_get_str (NULL, 10, *integer); - write_atom (ATOM_STRING, p); - free (p); - } -} - - -static void -mio_gmp_real (mpfr_t *real) -{ - mpfr_exp_t exponent; - char *p; - - if (iomode == IO_INPUT) - { - if (parse_atom () != ATOM_STRING) - bad_module ("Expected real string"); - - mpfr_init (*real); - mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE); - free (atom_string); - } - else - { - p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE); - - if (mpfr_nan_p (*real) || mpfr_inf_p (*real)) - { - write_atom (ATOM_STRING, p); - free (p); - return; - } - - atom_string = XCNEWVEC (char, strlen (p) + 20); - - sprintf (atom_string, "0.%s@%ld", p, exponent); - - /* Fix negative numbers. */ - if (atom_string[2] == '-') - { - atom_string[0] = '-'; - atom_string[1] = '0'; - atom_string[2] = '.'; - } - - write_atom (ATOM_STRING, atom_string); - - free (atom_string); - free (p); - } -} - - -/* Save and restore the shape of an array constructor. */ - -static void -mio_shape (mpz_t **pshape, int rank) -{ - mpz_t *shape; - atom_type t; - int n; - - /* A NULL shape is represented by (). */ - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - shape = *pshape; - if (!shape) - { - mio_rparen (); - return; - } - } - else - { - t = peek_atom (); - if (t == ATOM_RPAREN) - { - *pshape = NULL; - mio_rparen (); - return; - } - - shape = gfc_get_shape (rank); - *pshape = shape; - } - - for (n = 0; n < rank; n++) - mio_gmp_integer (&shape[n]); - - mio_rparen (); -} - - -static const mstring expr_types[] = { - minit ("OP", EXPR_OP), - minit ("FUNCTION", EXPR_FUNCTION), - minit ("CONSTANT", EXPR_CONSTANT), - minit ("VARIABLE", EXPR_VARIABLE), - minit ("SUBSTRING", EXPR_SUBSTRING), - minit ("STRUCTURE", EXPR_STRUCTURE), - minit ("ARRAY", EXPR_ARRAY), - minit ("NULL", EXPR_NULL), - minit ("COMPCALL", EXPR_COMPCALL), - minit (NULL, -1) -}; - -/* INTRINSIC_ASSIGN is missing because it is used as an index for - generic operators, not in expressions. INTRINSIC_USER is also - replaced by the correct function name by the time we see it. */ - -static const mstring intrinsics[] = -{ - minit ("UPLUS", INTRINSIC_UPLUS), - minit ("UMINUS", INTRINSIC_UMINUS), - minit ("PLUS", INTRINSIC_PLUS), - minit ("MINUS", INTRINSIC_MINUS), - minit ("TIMES", INTRINSIC_TIMES), - minit ("DIVIDE", INTRINSIC_DIVIDE), - minit ("POWER", INTRINSIC_POWER), - minit ("CONCAT", INTRINSIC_CONCAT), - minit ("AND", INTRINSIC_AND), - minit ("OR", INTRINSIC_OR), - minit ("EQV", INTRINSIC_EQV), - minit ("NEQV", INTRINSIC_NEQV), - minit ("EQ_SIGN", INTRINSIC_EQ), - minit ("EQ", INTRINSIC_EQ_OS), - minit ("NE_SIGN", INTRINSIC_NE), - minit ("NE", INTRINSIC_NE_OS), - minit ("GT_SIGN", INTRINSIC_GT), - minit ("GT", INTRINSIC_GT_OS), - minit ("GE_SIGN", INTRINSIC_GE), - minit ("GE", INTRINSIC_GE_OS), - minit ("LT_SIGN", INTRINSIC_LT), - minit ("LT", INTRINSIC_LT_OS), - minit ("LE_SIGN", INTRINSIC_LE), - minit ("LE", INTRINSIC_LE_OS), - minit ("NOT", INTRINSIC_NOT), - minit ("PARENTHESES", INTRINSIC_PARENTHESES), - minit ("USER", INTRINSIC_USER), - minit (NULL, -1) -}; - - -/* Remedy a couple of situations where the gfc_expr's can be defective. */ - -static void -fix_mio_expr (gfc_expr *e) -{ - gfc_symtree *ns_st = NULL; - const char *fname; - - if (iomode != IO_OUTPUT) - return; - - if (e->symtree) - { - /* If this is a symtree for a symbol that came from a contained module - namespace, it has a unique name and we should look in the current - namespace to see if the required, non-contained symbol is available - yet. If so, the latter should be written. */ - if (e->symtree->n.sym && check_unique_name (e->symtree->name)) - { - const char *name = e->symtree->n.sym->name; - if (gfc_fl_struct (e->symtree->n.sym->attr.flavor)) - name = gfc_dt_upper_string (name); - ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name); - } - - /* On the other hand, if the existing symbol is the module name or the - new symbol is a dummy argument, do not do the promotion. */ - if (ns_st && ns_st->n.sym - && ns_st->n.sym->attr.flavor != FL_MODULE - && !e->symtree->n.sym->attr.dummy) - e->symtree = ns_st; - } - else if (e->expr_type == EXPR_FUNCTION - && (e->value.function.name || e->value.function.isym)) - { - gfc_symbol *sym; - - /* In some circumstances, a function used in an initialization - expression, in one use associated module, can fail to be - coupled to its symtree when used in a specification - expression in another module. */ - fname = e->value.function.esym ? e->value.function.esym->name - : e->value.function.isym->name; - e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); - - if (e->symtree) - return; - - /* This is probably a reference to a private procedure from another - module. To prevent a segfault, make a generic with no specific - instances. If this module is used, without the required - specific coming from somewhere, the appropriate error message - is issued. */ - gfc_get_symbol (fname, gfc_current_ns, &sym); - sym->attr.flavor = FL_PROCEDURE; - sym->attr.generic = 1; - e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); - gfc_commit_symbol (sym); - } -} - - -/* Read and write expressions. The form "()" is allowed to indicate a - NULL expression. */ - -static void -mio_expr (gfc_expr **ep) -{ - HOST_WIDE_INT hwi; - gfc_expr *e; - atom_type t; - int flag; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - if (*ep == NULL) - { - mio_rparen (); - return; - } - - e = *ep; - MIO_NAME (expr_t) (e->expr_type, expr_types); - } - else - { - t = parse_atom (); - if (t == ATOM_RPAREN) - { - *ep = NULL; - return; - } - - if (t != ATOM_NAME) - bad_module ("Expected expression type"); - - e = *ep = gfc_get_expr (); - e->where = gfc_current_locus; - e->expr_type = (expr_t) find_enum (expr_types); - } - - mio_typespec (&e->ts); - mio_integer (&e->rank); - - fix_mio_expr (e); - - switch (e->expr_type) - { - case EXPR_OP: - e->value.op.op - = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics); - - switch (e->value.op.op) - { - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - case INTRINSIC_NOT: - case INTRINSIC_PARENTHESES: - mio_expr (&e->value.op.op1); - break; - - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: - case INTRINSIC_CONCAT: - case INTRINSIC_AND: - case INTRINSIC_OR: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - mio_expr (&e->value.op.op1); - mio_expr (&e->value.op.op2); - break; - - case INTRINSIC_USER: - /* INTRINSIC_USER should not appear in resolved expressions, - though for UDRs we need to stream unresolved ones. */ - if (iomode == IO_OUTPUT) - write_atom (ATOM_STRING, e->value.op.uop->name); - else - { - char *name = read_string (); - const char *uop_name = find_use_name (name, true); - if (uop_name == NULL) - { - size_t len = strlen (name); - char *name2 = XCNEWVEC (char, len + 2); - memcpy (name2, name, len); - name2[len] = ' '; - name2[len + 1] = '\0'; - free (name); - uop_name = name = name2; - } - e->value.op.uop = gfc_get_uop (uop_name); - free (name); - } - mio_expr (&e->value.op.op1); - mio_expr (&e->value.op.op2); - break; - - default: - bad_module ("Bad operator"); - } - - break; - - case EXPR_FUNCTION: - mio_symtree_ref (&e->symtree); - mio_actual_arglist (&e->value.function.actual, false); - - if (iomode == IO_OUTPUT) - { - e->value.function.name - = mio_allocated_string (e->value.function.name); - if (e->value.function.esym) - flag = 1; - else if (e->ref) - flag = 2; - else if (e->value.function.isym == NULL) - flag = 3; - else - flag = 0; - mio_integer (&flag); - switch (flag) - { - case 1: - mio_symbol_ref (&e->value.function.esym); - break; - case 2: - mio_ref_list (&e->ref); - break; - case 3: - break; - default: - write_atom (ATOM_STRING, e->value.function.isym->name); - } - } - else - { - require_atom (ATOM_STRING); - if (atom_string[0] == '\0') - e->value.function.name = NULL; - else - e->value.function.name = gfc_get_string ("%s", atom_string); - free (atom_string); - - mio_integer (&flag); - switch (flag) - { - case 1: - mio_symbol_ref (&e->value.function.esym); - break; - case 2: - mio_ref_list (&e->ref); - break; - case 3: - break; - default: - require_atom (ATOM_STRING); - e->value.function.isym = gfc_find_function (atom_string); - free (atom_string); - } - } - - break; - - case EXPR_VARIABLE: - mio_symtree_ref (&e->symtree); - mio_ref_list (&e->ref); - break; - - case EXPR_SUBSTRING: - e->value.character.string - = CONST_CAST (gfc_char_t *, - mio_allocated_wide_string (e->value.character.string, - e->value.character.length)); - mio_ref_list (&e->ref); - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - mio_constructor (&e->value.constructor); - mio_shape (&e->shape, e->rank); - break; - - case EXPR_CONSTANT: - switch (e->ts.type) - { - case BT_INTEGER: - mio_gmp_integer (&e->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (e->ts.kind); - mio_gmp_real (&e->value.real); - break; - - case BT_COMPLEX: - gfc_set_model_kind (e->ts.kind); - mio_gmp_real (&mpc_realref (e->value.complex)); - mio_gmp_real (&mpc_imagref (e->value.complex)); - break; - - case BT_LOGICAL: - mio_integer (&e->value.logical); - break; - - case BT_CHARACTER: - hwi = e->value.character.length; - mio_hwi (&hwi); - e->value.character.length = hwi; - e->value.character.string - = CONST_CAST (gfc_char_t *, - mio_allocated_wide_string (e->value.character.string, - e->value.character.length)); - break; - - default: - bad_module ("Bad type in constant expression"); - } - - break; - - case EXPR_NULL: - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - case EXPR_UNKNOWN: - gcc_unreachable (); - break; - } - - /* PDT types store the expression specification list here. */ - mio_actual_arglist (&e->param_list, true); - - mio_rparen (); -} - - -/* Read and write namelists. */ - -static void -mio_namelist (gfc_symbol *sym) -{ - gfc_namelist *n, *m; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - for (n = sym->namelist; n; n = n->next) - mio_symbol_ref (&n->sym); - } - else - { - m = NULL; - while (peek_atom () != ATOM_RPAREN) - { - n = gfc_get_namelist (); - mio_symbol_ref (&n->sym); - - if (sym->namelist == NULL) - sym->namelist = n; - else - m->next = n; - - m = n; - } - sym->namelist_tail = m; - } - - mio_rparen (); -} - - -/* Save/restore lists of gfc_interface structures. When loading an - interface, we are really appending to the existing list of - interfaces. Checking for duplicate and ambiguous interfaces has to - be done later when all symbols have been loaded. */ - -pointer_info * -mio_interface_rest (gfc_interface **ip) -{ - gfc_interface *tail, *p; - pointer_info *pi = NULL; - - if (iomode == IO_OUTPUT) - { - if (ip != NULL) - for (p = *ip; p; p = p->next) - mio_symbol_ref (&p->sym); - } - else - { - if (*ip == NULL) - tail = NULL; - else - { - tail = *ip; - while (tail->next) - tail = tail->next; - } - - for (;;) - { - if (peek_atom () == ATOM_RPAREN) - break; - - p = gfc_get_interface (); - p->where = gfc_current_locus; - pi = mio_symbol_ref (&p->sym); - - if (tail == NULL) - *ip = p; - else - tail->next = p; - - tail = p; - } - } - - mio_rparen (); - return pi; -} - - -/* Save/restore a nameless operator interface. */ - -static void -mio_interface (gfc_interface **ip) -{ - mio_lparen (); - mio_interface_rest (ip); -} - - -/* Save/restore a named operator interface. */ - -static void -mio_symbol_interface (const char **name, const char **module, - gfc_interface **ip) -{ - mio_lparen (); - mio_pool_string (name); - mio_pool_string (module); - mio_interface_rest (ip); -} - - -static void -mio_namespace_ref (gfc_namespace **nsp) -{ - gfc_namespace *ns; - pointer_info *p; - - p = mio_pointer_ref (nsp); - - if (p->type == P_UNKNOWN) - p->type = P_NAMESPACE; - - if (iomode == IO_INPUT && p->integer != 0) - { - ns = (gfc_namespace *) p->u.pointer; - if (ns == NULL) - { - ns = gfc_get_namespace (NULL, 0); - associate_integer_pointer (p, ns); - } - else - ns->refs++; - } -} - - -/* Save/restore the f2k_derived namespace of a derived-type symbol. */ - -static gfc_namespace* current_f2k_derived; - -static void -mio_typebound_proc (gfc_typebound_proc** proc) -{ - int flag; - int overriding_flag; - - if (iomode == IO_INPUT) - { - *proc = gfc_get_typebound_proc (NULL); - (*proc)->where = gfc_current_locus; - } - gcc_assert (*proc); - - mio_lparen (); - - (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types); - - /* IO the NON_OVERRIDABLE/DEFERRED combination. */ - gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); - overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable; - overriding_flag = mio_name (overriding_flag, binding_overriding); - (*proc)->deferred = ((overriding_flag & 2) != 0); - (*proc)->non_overridable = ((overriding_flag & 1) != 0); - gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); - - (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing); - (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic); - (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc); - - mio_pool_string (&((*proc)->pass_arg)); - - flag = (int) (*proc)->pass_arg_num; - mio_integer (&flag); - (*proc)->pass_arg_num = (unsigned) flag; - - if ((*proc)->is_generic) - { - gfc_tbp_generic* g; - int iop; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - for (g = (*proc)->u.generic; g; g = g->next) - { - iop = (int) g->is_operator; - mio_integer (&iop); - mio_allocated_string (g->specific_st->name); - } - else - { - (*proc)->u.generic = NULL; - while (peek_atom () != ATOM_RPAREN) - { - gfc_symtree** sym_root; - - g = gfc_get_tbp_generic (); - g->specific = NULL; - - mio_integer (&iop); - g->is_operator = (bool) iop; - - require_atom (ATOM_STRING); - sym_root = ¤t_f2k_derived->tb_sym_root; - g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string); - free (atom_string); - - g->next = (*proc)->u.generic; - (*proc)->u.generic = g; - } - } - - mio_rparen (); - } - else if (!(*proc)->ppc) - mio_symtree_ref (&(*proc)->u.specific); - - mio_rparen (); -} - -/* Walker-callback function for this purpose. */ -static void -mio_typebound_symtree (gfc_symtree* st) -{ - if (iomode == IO_OUTPUT && !st->n.tb) - return; - - if (iomode == IO_OUTPUT) - { - mio_lparen (); - mio_allocated_string (st->name); - } - /* For IO_INPUT, the above is done in mio_f2k_derived. */ - - mio_typebound_proc (&st->n.tb); - mio_rparen (); -} - -/* IO a full symtree (in all depth). */ -static void -mio_full_typebound_tree (gfc_symtree** root) -{ - mio_lparen (); - - if (iomode == IO_OUTPUT) - gfc_traverse_symtree (*root, &mio_typebound_symtree); - else - { - while (peek_atom () == ATOM_LPAREN) - { - gfc_symtree* st; - - mio_lparen (); - - require_atom (ATOM_STRING); - st = gfc_get_tbp_symtree (root, atom_string); - free (atom_string); - - mio_typebound_symtree (st); - } - } - - mio_rparen (); -} - -static void -mio_finalizer (gfc_finalizer **f) -{ - if (iomode == IO_OUTPUT) - { - gcc_assert (*f); - gcc_assert ((*f)->proc_tree); /* Should already be resolved. */ - mio_symtree_ref (&(*f)->proc_tree); - } - else - { - *f = gfc_get_finalizer (); - (*f)->where = gfc_current_locus; /* Value should not matter. */ - (*f)->next = NULL; - - mio_symtree_ref (&(*f)->proc_tree); - (*f)->proc_sym = NULL; - } -} - -static void -mio_f2k_derived (gfc_namespace *f2k) -{ - current_f2k_derived = f2k; - - /* Handle the list of finalizer procedures. */ - mio_lparen (); - if (iomode == IO_OUTPUT) - { - gfc_finalizer *f; - for (f = f2k->finalizers; f; f = f->next) - mio_finalizer (&f); - } - else - { - f2k->finalizers = NULL; - while (peek_atom () != ATOM_RPAREN) - { - gfc_finalizer *cur = NULL; - mio_finalizer (&cur); - cur->next = f2k->finalizers; - f2k->finalizers = cur; - } - } - mio_rparen (); - - /* Handle type-bound procedures. */ - mio_full_typebound_tree (&f2k->tb_sym_root); - - /* Type-bound user operators. */ - mio_full_typebound_tree (&f2k->tb_uop_root); - - /* Type-bound intrinsic operators. */ - mio_lparen (); - if (iomode == IO_OUTPUT) - { - int op; - for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) - { - gfc_intrinsic_op realop; - - if (op == INTRINSIC_USER || !f2k->tb_op[op]) - continue; - - mio_lparen (); - realop = (gfc_intrinsic_op) op; - mio_intrinsic_op (&realop); - mio_typebound_proc (&f2k->tb_op[op]); - mio_rparen (); - } - } - else - while (peek_atom () != ATOM_RPAREN) - { - gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */ - - mio_lparen (); - mio_intrinsic_op (&op); - mio_typebound_proc (&f2k->tb_op[op]); - mio_rparen (); - } - mio_rparen (); -} - -static void -mio_full_f2k_derived (gfc_symbol *sym) -{ - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - if (sym->f2k_derived) - mio_f2k_derived (sym->f2k_derived); - } - else - { - if (peek_atom () != ATOM_RPAREN) - { - gfc_namespace *ns; - - sym->f2k_derived = gfc_get_namespace (NULL, 0); - - /* PDT templates make use of the mechanisms for formal args - and so the parameter symbols are stored in the formal - namespace. Transfer the sym_root to f2k_derived and then - free the formal namespace since it is uneeded. */ - if (sym->attr.pdt_template && sym->formal && sym->formal->sym) - { - ns = sym->formal->sym->ns; - sym->f2k_derived->sym_root = ns->sym_root; - ns->sym_root = NULL; - ns->refs++; - gfc_free_namespace (ns); - ns = NULL; - } - - mio_f2k_derived (sym->f2k_derived); - } - else - gcc_assert (!sym->f2k_derived); - } - - mio_rparen (); -} - -static const mstring omp_declare_simd_clauses[] = -{ - minit ("INBRANCH", 0), - minit ("NOTINBRANCH", 1), - minit ("SIMDLEN", 2), - minit ("UNIFORM", 3), - minit ("LINEAR", 4), - minit ("ALIGNED", 5), - minit ("LINEAR_REF", 33), - minit ("LINEAR_VAL", 34), - minit ("LINEAR_UVAL", 35), - minit (NULL, -1) -}; - -/* Handle !$omp declare simd. */ - -static void -mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp) -{ - if (iomode == IO_OUTPUT) - { - if (*odsp == NULL) - return; - } - else if (peek_atom () != ATOM_LPAREN) - return; - - gfc_omp_declare_simd *ods = *odsp; - - mio_lparen (); - if (iomode == IO_OUTPUT) - { - write_atom (ATOM_NAME, "OMP_DECLARE_SIMD"); - if (ods->clauses) - { - gfc_omp_namelist *n; - - if (ods->clauses->inbranch) - mio_name (0, omp_declare_simd_clauses); - if (ods->clauses->notinbranch) - mio_name (1, omp_declare_simd_clauses); - if (ods->clauses->simdlen_expr) - { - mio_name (2, omp_declare_simd_clauses); - mio_expr (&ods->clauses->simdlen_expr); - } - for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next) - { - mio_name (3, omp_declare_simd_clauses); - mio_symbol_ref (&n->sym); - } - for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next) - { - if (n->u.linear_op == OMP_LINEAR_DEFAULT) - mio_name (4, omp_declare_simd_clauses); - else - mio_name (32 + n->u.linear_op, omp_declare_simd_clauses); - mio_symbol_ref (&n->sym); - mio_expr (&n->expr); - } - for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) - { - mio_name (5, omp_declare_simd_clauses); - mio_symbol_ref (&n->sym); - mio_expr (&n->expr); - } - } - } - else - { - gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL }; - - require_atom (ATOM_NAME); - *odsp = ods = gfc_get_omp_declare_simd (); - ods->where = gfc_current_locus; - ods->proc_name = ns->proc_name; - if (peek_atom () == ATOM_NAME) - { - ods->clauses = gfc_get_omp_clauses (); - ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM]; - ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR]; - ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED]; - } - while (peek_atom () == ATOM_NAME) - { - gfc_omp_namelist *n; - int t = mio_name (0, omp_declare_simd_clauses); - - switch (t) - { - case 0: ods->clauses->inbranch = true; break; - case 1: ods->clauses->notinbranch = true; break; - case 2: mio_expr (&ods->clauses->simdlen_expr); break; - case 3: - case 4: - case 5: - *ptrs[t - 3] = n = gfc_get_omp_namelist (); - finish_namelist: - n->where = gfc_current_locus; - ptrs[t - 3] = &n->next; - mio_symbol_ref (&n->sym); - if (t != 3) - mio_expr (&n->expr); - break; - case 33: - case 34: - case 35: - *ptrs[1] = n = gfc_get_omp_namelist (); - n->u.linear_op = (enum gfc_omp_linear_op) (t - 32); - t = 4; - goto finish_namelist; - } - } - } - - mio_omp_declare_simd (ns, &ods->next); - - mio_rparen (); -} - - -static const mstring omp_declare_reduction_stmt[] = -{ - minit ("ASSIGN", 0), - minit ("CALL", 1), - minit (NULL, -1) -}; - - -static void -mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2, - gfc_namespace *ns, bool is_initializer) -{ - if (iomode == IO_OUTPUT) - { - if ((*sym1)->module == NULL) - { - (*sym1)->module = module_name; - (*sym2)->module = module_name; - } - mio_symbol_ref (sym1); - mio_symbol_ref (sym2); - if (ns->code->op == EXEC_ASSIGN) - { - mio_name (0, omp_declare_reduction_stmt); - mio_expr (&ns->code->expr1); - mio_expr (&ns->code->expr2); - } - else - { - int flag; - mio_name (1, omp_declare_reduction_stmt); - mio_symtree_ref (&ns->code->symtree); - mio_actual_arglist (&ns->code->ext.actual, false); - - flag = ns->code->resolved_isym != NULL; - mio_integer (&flag); - if (flag) - write_atom (ATOM_STRING, ns->code->resolved_isym->name); - else - mio_symbol_ref (&ns->code->resolved_sym); - } - } - else - { - pointer_info *p1 = mio_symbol_ref (sym1); - pointer_info *p2 = mio_symbol_ref (sym2); - gfc_symbol *sym; - gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns); - gcc_assert (p1->u.rsym.sym == NULL); - /* Add hidden symbols to the symtree. */ - pointer_info *q = get_integer (p1->u.rsym.ns); - q->u.pointer = (void *) ns; - sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns); - sym->ts = udr->ts; - sym->module = gfc_get_string ("%s", p1->u.rsym.module); - associate_integer_pointer (p1, sym); - sym->attr.omp_udr_artificial_var = 1; - gcc_assert (p2->u.rsym.sym == NULL); - sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns); - sym->ts = udr->ts; - sym->module = gfc_get_string ("%s", p2->u.rsym.module); - associate_integer_pointer (p2, sym); - sym->attr.omp_udr_artificial_var = 1; - if (mio_name (0, omp_declare_reduction_stmt) == 0) - { - ns->code = gfc_get_code (EXEC_ASSIGN); - mio_expr (&ns->code->expr1); - mio_expr (&ns->code->expr2); - } - else - { - int flag; - ns->code = gfc_get_code (EXEC_CALL); - mio_symtree_ref (&ns->code->symtree); - mio_actual_arglist (&ns->code->ext.actual, false); - - mio_integer (&flag); - if (flag) - { - require_atom (ATOM_STRING); - ns->code->resolved_isym = gfc_find_subroutine (atom_string); - free (atom_string); - } - else - mio_symbol_ref (&ns->code->resolved_sym); - } - ns->code->loc = gfc_current_locus; - ns->omp_udr_ns = 1; - } -} - - -/* Unlike most other routines, the address of the symbol node is already - fixed on input and the name/module has already been filled in. - If you update the symbol format here, don't forget to update read_module - as well (look for "seek to the symbol's component list"). */ - -static void -mio_symbol (gfc_symbol *sym) -{ - int intmod = INTMOD_NONE; - - mio_lparen (); - - mio_symbol_attribute (&sym->attr); - - if (sym->attr.pdt_type) - sym->name = gfc_dt_upper_string (sym->name); - - /* Note that components are always saved, even if they are supposed - to be private. Component access is checked during searching. */ - mio_component_list (&sym->components, sym->attr.vtype); - if (sym->components != NULL) - sym->component_access - = MIO_NAME (gfc_access) (sym->component_access, access_types); - - mio_typespec (&sym->ts); - if (sym->ts.type == BT_CLASS) - sym->attr.class_ok = 1; - - if (iomode == IO_OUTPUT) - mio_namespace_ref (&sym->formal_ns); - else - { - mio_namespace_ref (&sym->formal_ns); - if (sym->formal_ns) - sym->formal_ns->proc_name = sym; - } - - /* Save/restore common block links. */ - mio_symbol_ref (&sym->common_next); - - mio_formal_arglist (&sym->formal); - - if (sym->attr.flavor == FL_PARAMETER) - mio_expr (&sym->value); - - mio_array_spec (&sym->as); - - mio_symbol_ref (&sym->result); - - if (sym->attr.cray_pointee) - mio_symbol_ref (&sym->cp_pointer); - - /* Load/save the f2k_derived namespace of a derived-type symbol. */ - mio_full_f2k_derived (sym); - - /* PDT types store the symbol specification list here. */ - mio_actual_arglist (&sym->param_list, true); - - mio_namelist (sym); - - /* Add the fields that say whether this is from an intrinsic module, - and if so, what symbol it is within the module. */ -/* mio_integer (&(sym->from_intmod)); */ - if (iomode == IO_OUTPUT) - { - intmod = sym->from_intmod; - mio_integer (&intmod); - } - else - { - mio_integer (&intmod); - if (current_intmod) - sym->from_intmod = current_intmod; - else - sym->from_intmod = (intmod_id) intmod; - } - - mio_integer (&(sym->intmod_sym_id)); - - if (gfc_fl_struct (sym->attr.flavor)) - mio_integer (&(sym->hash_value)); - - if (sym->formal_ns - && sym->formal_ns->proc_name == sym - && sym->formal_ns->entries == NULL) - mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd); - - mio_rparen (); -} - - -/************************* Top level subroutines *************************/ - -/* A recursive function to look for a specific symbol by name and by - module. Whilst several symtrees might point to one symbol, its - is sufficient for the purposes here than one exist. Note that - generic interfaces are distinguished as are symbols that have been - renamed in another module. */ -static gfc_symtree * -find_symbol (gfc_symtree *st, const char *name, - const char *module, int generic) -{ - int c; - gfc_symtree *retval, *s; - - if (st == NULL || st->n.sym == NULL) - return NULL; - - c = strcmp (name, st->n.sym->name); - if (c == 0 && st->n.sym->module - && strcmp (module, st->n.sym->module) == 0 - && !check_unique_name (st->name)) - { - s = gfc_find_symtree (gfc_current_ns->sym_root, name); - - /* Detect symbols that are renamed by use association in another - module by the absence of a symtree and null attr.use_rename, - since the latter is not transmitted in the module file. */ - if (((!generic && !st->n.sym->attr.generic) - || (generic && st->n.sym->attr.generic)) - && !(s == NULL && !st->n.sym->attr.use_rename)) - return st; - } - - retval = find_symbol (st->left, name, module, generic); - - if (retval == NULL) - retval = find_symbol (st->right, name, module, generic); - - return retval; -} - - -/* Skip a list between balanced left and right parens. - By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens - have been already parsed by hand, and the remaining of the content is to be - skipped here. The default value is 0 (balanced parens). */ - -static void -skip_list (int nest_level = 0) -{ - int level; - - level = nest_level; - do - { - switch (parse_atom ()) - { - case ATOM_LPAREN: - level++; - break; - - case ATOM_RPAREN: - level--; - break; - - case ATOM_STRING: - free (atom_string); - break; - - case ATOM_NAME: - case ATOM_INTEGER: - break; - } - } - while (level > 0); -} - - -/* Load operator interfaces from the module. Interfaces are unusual - in that they attach themselves to existing symbols. */ - -static void -load_operator_interfaces (void) -{ - const char *p; - /* "module" must be large enough for the case of submodules in which the name - has the form module.submodule */ - char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2]; - gfc_user_op *uop; - pointer_info *pi = NULL; - int n, i; - - mio_lparen (); - - while (peek_atom () != ATOM_RPAREN) - { - mio_lparen (); - - mio_internal_string (name); - mio_internal_string (module); - - n = number_use_names (name, true); - n = n ? n : 1; - - for (i = 1; i <= n; i++) - { - /* Decide if we need to load this one or not. */ - p = find_use_name_n (name, &i, true); - - if (p == NULL) - { - while (parse_atom () != ATOM_RPAREN); - continue; - } - - if (i == 1) - { - uop = gfc_get_uop (p); - pi = mio_interface_rest (&uop->op); - } - else - { - if (gfc_find_uop (p, NULL)) - continue; - uop = gfc_get_uop (p); - uop->op = gfc_get_interface (); - uop->op->where = gfc_current_locus; - add_fixup (pi->integer, &uop->op->sym); - } - } - } - - mio_rparen (); -} - - -/* Load interfaces from the module. Interfaces are unusual in that - they attach themselves to existing symbols. */ - -static void -load_generic_interfaces (void) -{ - const char *p; - /* "module" must be large enough for the case of submodules in which the name - has the form module.submodule */ - char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2]; - gfc_symbol *sym; - gfc_interface *generic = NULL, *gen = NULL; - int n, i, renamed; - bool ambiguous_set = false; - - mio_lparen (); - - while (peek_atom () != ATOM_RPAREN) - { - mio_lparen (); - - mio_internal_string (name); - mio_internal_string (module); - - n = number_use_names (name, false); - renamed = n ? 1 : 0; - n = n ? n : 1; - - for (i = 1; i <= n; i++) - { - gfc_symtree *st; - /* Decide if we need to load this one or not. */ - p = find_use_name_n (name, &i, false); - - if (!p || gfc_find_symbol (p, NULL, 0, &sym)) - { - /* Skip the specific names for these cases. */ - while (i == 1 && parse_atom () != ATOM_RPAREN); - - continue; - } - - st = find_symbol (gfc_current_ns->sym_root, - name, module_name, 1); - - /* If the symbol exists already and is being USEd without being - in an ONLY clause, do not load a new symtree(11.3.2). */ - if (!only_flag && st) - sym = st->n.sym; - - if (!sym) - { - if (st) - { - sym = st->n.sym; - if (strcmp (st->name, p) != 0) - { - st = gfc_new_symtree (&gfc_current_ns->sym_root, p); - st->n.sym = sym; - sym->refs++; - } - } - - /* Since we haven't found a valid generic interface, we had - better make one. */ - if (!sym) - { - gfc_get_symbol (p, NULL, &sym); - sym->name = gfc_get_string ("%s", name); - sym->module = module_name; - sym->attr.flavor = FL_PROCEDURE; - sym->attr.generic = 1; - sym->attr.use_assoc = 1; - } - } - else - { - /* Unless sym is a generic interface, this reference - is ambiguous. */ - if (st == NULL) - st = gfc_find_symtree (gfc_current_ns->sym_root, p); - - sym = st->n.sym; - - if (st && !sym->attr.generic - && !st->ambiguous - && sym->module - && strcmp (module, sym->module)) - { - ambiguous_set = true; - st->ambiguous = 1; - } - } - - sym->attr.use_only = only_flag; - sym->attr.use_rename = renamed; - - if (i == 1) - { - mio_interface_rest (&sym->generic); - generic = sym->generic; - } - else if (!sym->generic) - { - sym->generic = generic; - sym->attr.generic_copy = 1; - } - - /* If a procedure that is not generic has generic interfaces - that include itself, it is generic! We need to take care - to retain symbols ambiguous that were already so. */ - if (sym->attr.use_assoc - && !sym->attr.generic - && sym->attr.flavor == FL_PROCEDURE) - { - for (gen = generic; gen; gen = gen->next) - { - if (gen->sym == sym) - { - sym->attr.generic = 1; - if (ambiguous_set) - st->ambiguous = 0; - break; - } - } - } - - } - } - - mio_rparen (); -} - - -/* Load common blocks. */ - -static void -load_commons (void) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_common_head *p; - - mio_lparen (); - - while (peek_atom () != ATOM_RPAREN) - { - int flags = 0; - char* label; - mio_lparen (); - mio_internal_string (name); - - p = gfc_get_common (name, 1); - - mio_symbol_ref (&p->head); - mio_integer (&flags); - if (flags & 1) - p->saved = 1; - if (flags & 2) - p->threadprivate = 1; - p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3); - p->use_assoc = 1; - - /* Get whether this was a bind(c) common or not. */ - mio_integer (&p->is_bind_c); - /* Get the binding label. */ - label = read_string (); - if (strlen (label)) - p->binding_label = IDENTIFIER_POINTER (get_identifier (label)); - XDELETEVEC (label); - - mio_rparen (); - } - - mio_rparen (); -} - - -/* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this - so that unused variables are not loaded and so that the expression can - be safely freed. */ - -static void -load_equiv (void) -{ - gfc_equiv *head, *tail, *end, *eq, *equiv; - bool duplicate; - - mio_lparen (); - in_load_equiv = true; - - end = gfc_current_ns->equiv; - while (end != NULL && end->next != NULL) - end = end->next; - - while (peek_atom () != ATOM_RPAREN) { - mio_lparen (); - head = tail = NULL; - - while(peek_atom () != ATOM_RPAREN) - { - if (head == NULL) - head = tail = gfc_get_equiv (); - else - { - tail->eq = gfc_get_equiv (); - tail = tail->eq; - } - - mio_pool_string (&tail->module); - mio_expr (&tail->expr); - } - - /* Check for duplicate equivalences being loaded from different modules */ - duplicate = false; - for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next) - { - if (equiv->module && head->module - && strcmp (equiv->module, head->module) == 0) - { - duplicate = true; - break; - } - } - - if (duplicate) - { - for (eq = head; eq; eq = head) - { - head = eq->eq; - gfc_free_expr (eq->expr); - free (eq); - } - } - - if (end == NULL) - gfc_current_ns->equiv = head; - else - end->next = head; - - if (head != NULL) - end = head; - - mio_rparen (); - } - - mio_rparen (); - in_load_equiv = false; -} - - -/* This function loads OpenMP user defined reductions. */ -static void -load_omp_udrs (void) -{ - mio_lparen (); - while (peek_atom () != ATOM_RPAREN) - { - const char *name = NULL, *newname; - char *altname; - gfc_typespec ts; - gfc_symtree *st; - gfc_omp_reduction_op rop = OMP_REDUCTION_USER; - - mio_lparen (); - mio_pool_string (&name); - gfc_clear_ts (&ts); - mio_typespec (&ts); - if (startswith (name, "operator ")) - { - const char *p = name + sizeof ("operator ") - 1; - if (strcmp (p, "+") == 0) - rop = OMP_REDUCTION_PLUS; - else if (strcmp (p, "*") == 0) - rop = OMP_REDUCTION_TIMES; - else if (strcmp (p, "-") == 0) - rop = OMP_REDUCTION_MINUS; - else if (strcmp (p, ".and.") == 0) - rop = OMP_REDUCTION_AND; - else if (strcmp (p, ".or.") == 0) - rop = OMP_REDUCTION_OR; - else if (strcmp (p, ".eqv.") == 0) - rop = OMP_REDUCTION_EQV; - else if (strcmp (p, ".neqv.") == 0) - rop = OMP_REDUCTION_NEQV; - } - altname = NULL; - if (rop == OMP_REDUCTION_USER && name[0] == '.') - { - size_t len = strlen (name + 1); - altname = XALLOCAVEC (char, len); - gcc_assert (name[len] == '.'); - memcpy (altname, name + 1, len - 1); - altname[len - 1] = '\0'; - } - newname = name; - if (rop == OMP_REDUCTION_USER) - newname = find_use_name (altname ? altname : name, !!altname); - else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL) - newname = NULL; - if (newname == NULL) - { - skip_list (1); - continue; - } - if (altname && newname != altname) - { - size_t len = strlen (newname); - altname = XALLOCAVEC (char, len + 3); - altname[0] = '.'; - memcpy (altname + 1, newname, len); - altname[len + 1] = '.'; - altname[len + 2] = '\0'; - name = gfc_get_string ("%s", altname); - } - st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); - gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts); - if (udr) - { - require_atom (ATOM_INTEGER); - pointer_info *p = get_integer (atom_int); - if (strcmp (p->u.rsym.module, udr->omp_out->module)) - { - gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from " - "module %s at %L", - p->u.rsym.module, &gfc_current_locus); - gfc_error ("Previous !$OMP DECLARE REDUCTION from module " - "%s at %L", - udr->omp_out->module, &udr->where); - } - skip_list (1); - continue; - } - udr = gfc_get_omp_udr (); - udr->name = name; - udr->rop = rop; - udr->ts = ts; - udr->where = gfc_current_locus; - udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1); - udr->combiner_ns->proc_name = gfc_current_ns->proc_name; - mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, - false); - if (peek_atom () != ATOM_RPAREN) - { - udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1); - udr->initializer_ns->proc_name = gfc_current_ns->proc_name; - mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, - udr->initializer_ns, true); - } - if (st) - { - udr->next = st->n.omp_udr; - st->n.omp_udr = udr; - } - else - { - st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); - st->n.omp_udr = udr; - } - mio_rparen (); - } - mio_rparen (); -} - - -/* Recursive function to traverse the pointer_info tree and load a - needed symbol. We return nonzero if we load a symbol and stop the - traversal, because the act of loading can alter the tree. */ - -static int -load_needed (pointer_info *p) -{ - gfc_namespace *ns; - pointer_info *q; - gfc_symbol *sym; - int rv; - - rv = 0; - if (p == NULL) - return rv; - - rv |= load_needed (p->left); - rv |= load_needed (p->right); - - if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED) - return rv; - - p->u.rsym.state = USED; - - set_module_locus (&p->u.rsym.where); - - sym = p->u.rsym.sym; - if (sym == NULL) - { - q = get_integer (p->u.rsym.ns); - - ns = (gfc_namespace *) q->u.pointer; - if (ns == NULL) - { - /* Create an interface namespace if necessary. These are - the namespaces that hold the formal parameters of module - procedures. */ - - ns = gfc_get_namespace (NULL, 0); - associate_integer_pointer (q, ns); - } - - /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl - doesn't go pear-shaped if the symbol is used. */ - if (!ns->proc_name) - gfc_find_symbol (p->u.rsym.module, gfc_current_ns, - 1, &ns->proc_name); - - sym = gfc_new_symbol (p->u.rsym.true_name, ns); - sym->name = gfc_dt_lower_string (p->u.rsym.true_name); - sym->module = gfc_get_string ("%s", p->u.rsym.module); - if (p->u.rsym.binding_label) - sym->binding_label = IDENTIFIER_POINTER (get_identifier - (p->u.rsym.binding_label)); - - associate_integer_pointer (p, sym); - } - - mio_symbol (sym); - sym->attr.use_assoc = 1; - - /* Unliked derived types, a STRUCTURE may share names with other symbols. - We greedily converted the symbol name to lowercase before we knew its - type, so now we must fix it. */ - if (sym->attr.flavor == FL_STRUCT) - sym->name = gfc_dt_upper_string (sym->name); - - /* Mark as only or rename for later diagnosis for explicitly imported - but not used warnings; don't mark internal symbols such as __vtab, - __def_init etc. Only mark them if they have been explicitly loaded. */ - - if (only_flag && sym->name[0] != '_' && sym->name[1] != '_') - { - gfc_use_rename *u; - - /* Search the use/rename list for the variable; if the variable is - found, mark it. */ - for (u = gfc_rename_list; u; u = u->next) - { - if (strcmp (u->use_name, sym->name) == 0) - { - sym->attr.use_only = 1; - break; - } - } - } - - if (p->u.rsym.renamed) - sym->attr.use_rename = 1; - - return 1; -} - - -/* Recursive function for cleaning up things after a module has been read. */ - -static void -read_cleanup (pointer_info *p) -{ - gfc_symtree *st; - pointer_info *q; - - if (p == NULL) - return; - - read_cleanup (p->left); - read_cleanup (p->right); - - if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced) - { - gfc_namespace *ns; - /* Add hidden symbols to the symtree. */ - q = get_integer (p->u.rsym.ns); - ns = (gfc_namespace *) q->u.pointer; - - if (!p->u.rsym.sym->attr.vtype - && !p->u.rsym.sym->attr.vtab) - st = gfc_get_unique_symtree (ns); - else - { - /* There is no reason to use 'unique_symtrees' for vtabs or - vtypes - their name is fine for a symtree and reduces the - namespace pollution. */ - st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name); - if (!st) - st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name); - } - - st->n.sym = p->u.rsym.sym; - st->n.sym->refs++; - - /* Fixup any symtree references. */ - p->u.rsym.symtree = st; - resolve_fixups (p->u.rsym.stfixup, st); - p->u.rsym.stfixup = NULL; - } - - /* Free unused symbols. */ - if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED) - gfc_free_symbol (p->u.rsym.sym); -} - - -/* It is not quite enough to check for ambiguity in the symbols by - the loaded symbol and the new symbol not being identical. */ -static bool -check_for_ambiguous (gfc_symtree *st, pointer_info *info) -{ - gfc_symbol *rsym; - module_locus locus; - symbol_attribute attr; - gfc_symbol *st_sym; - - if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name) - { - gfc_error ("%qs of module %qs, imported at %C, is also the name of the " - "current program unit", st->name, module_name); - return true; - } - - st_sym = st->n.sym; - rsym = info->u.rsym.sym; - if (st_sym == rsym) - return false; - - if (st_sym->attr.vtab || st_sym->attr.vtype) - return false; - - /* If the existing symbol is generic from a different module and - the new symbol is generic there can be no ambiguity. */ - if (st_sym->attr.generic - && st_sym->module - && st_sym->module != module_name) - { - /* The new symbol's attributes have not yet been read. Since - we need attr.generic, read it directly. */ - get_module_locus (&locus); - set_module_locus (&info->u.rsym.where); - mio_lparen (); - attr.generic = 0; - mio_symbol_attribute (&attr); - set_module_locus (&locus); - if (attr.generic) - return false; - } - - return true; -} - - -/* Read a module file. */ - -static void -read_module (void) -{ - module_locus operator_interfaces, user_operators, omp_udrs; - const char *p; - char name[GFC_MAX_SYMBOL_LEN + 1]; - int i; - /* Workaround -Wmaybe-uninitialized false positive during - profiledbootstrap by initializing them. */ - int ambiguous = 0, j, nuse, symbol = 0; - pointer_info *info, *q; - gfc_use_rename *u = NULL; - gfc_symtree *st; - gfc_symbol *sym; - - get_module_locus (&operator_interfaces); /* Skip these for now. */ - skip_list (); - - get_module_locus (&user_operators); - skip_list (); - skip_list (); - - /* Skip commons and equivalences for now. */ - skip_list (); - skip_list (); - - /* Skip OpenMP UDRs. */ - get_module_locus (&omp_udrs); - skip_list (); - - mio_lparen (); - - /* Create the fixup nodes for all the symbols. */ - - while (peek_atom () != ATOM_RPAREN) - { - char* bind_label; - require_atom (ATOM_INTEGER); - info = get_integer (atom_int); - - info->type = P_SYMBOL; - info->u.rsym.state = UNUSED; - - info->u.rsym.true_name = read_string (); - info->u.rsym.module = read_string (); - bind_label = read_string (); - if (strlen (bind_label)) - info->u.rsym.binding_label = bind_label; - else - XDELETEVEC (bind_label); - - require_atom (ATOM_INTEGER); - info->u.rsym.ns = atom_int; - - get_module_locus (&info->u.rsym.where); - - /* See if the symbol has already been loaded by a previous module. - If so, we reference the existing symbol and prevent it from - being loaded again. This should not happen if the symbol being - read is an index for an assumed shape dummy array (ns != 1). */ - - sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module); - - if (sym == NULL - || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1)) - { - skip_list (); - continue; - } - - info->u.rsym.state = USED; - info->u.rsym.sym = sym; - /* The current symbol has already been loaded, so we can avoid loading - it again. However, if it is a derived type, some of its components - can be used in expressions in the module. To avoid the module loading - failing, we need to associate the module's component pointer indexes - with the existing symbol's component pointers. */ - if (gfc_fl_struct (sym->attr.flavor)) - { - gfc_component *c; - - /* First seek to the symbol's component list. */ - mio_lparen (); /* symbol opening. */ - skip_list (); /* skip symbol attribute. */ - - mio_lparen (); /* component list opening. */ - for (c = sym->components; c; c = c->next) - { - pointer_info *p; - const char *comp_name = NULL; - int n = 0; - - mio_lparen (); /* component opening. */ - mio_integer (&n); - p = get_integer (n); - if (p->u.pointer == NULL) - associate_integer_pointer (p, c); - mio_pool_string (&comp_name); - if (comp_name != c->name) - { - gfc_fatal_error ("Mismatch in components of derived type " - "%qs from %qs at %C: expecting %qs, " - "but got %qs", sym->name, sym->module, - c->name, comp_name); - } - skip_list (1); /* component end. */ - } - mio_rparen (); /* component list closing. */ - - skip_list (1); /* symbol end. */ - } - else - skip_list (); - - /* Some symbols do not have a namespace (eg. formal arguments), - so the automatic "unique symtree" mechanism must be suppressed - by marking them as referenced. */ - q = get_integer (info->u.rsym.ns); - if (q->u.pointer == NULL) - { - info->u.rsym.referenced = 1; - continue; - } - } - - mio_rparen (); - - /* Parse the symtree lists. This lets us mark which symbols need to - be loaded. Renaming is also done at this point by replacing the - symtree name. */ - - mio_lparen (); - - while (peek_atom () != ATOM_RPAREN) - { - mio_internal_string (name); - mio_integer (&ambiguous); - mio_integer (&symbol); - - info = get_integer (symbol); - - /* See how many use names there are. If none, go through the start - of the loop at least once. */ - nuse = number_use_names (name, false); - info->u.rsym.renamed = nuse ? 1 : 0; - - if (nuse == 0) - nuse = 1; - - for (j = 1; j <= nuse; j++) - { - /* Get the jth local name for this symbol. */ - p = find_use_name_n (name, &j, false); - - if (p == NULL && strcmp (name, module_name) == 0) - p = name; - - /* Exception: Always import vtabs & vtypes. */ - if (p == NULL && name[0] == '_' - && (startswith (name, "__vtab_") - || startswith (name, "__vtype_"))) - p = name; - - /* Skip symtree nodes not in an ONLY clause, unless there - is an existing symtree loaded from another USE statement. */ - if (p == NULL) - { - st = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (st != NULL - && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0 - && st->n.sym->module != NULL - && strcmp (st->n.sym->module, info->u.rsym.module) == 0) - { - info->u.rsym.symtree = st; - info->u.rsym.sym = st->n.sym; - } - continue; - } - - /* If a symbol of the same name and module exists already, - this symbol, which is not in an ONLY clause, must not be - added to the namespace(11.3.2). Note that find_symbol - only returns the first occurrence that it finds. */ - if (!only_flag && !info->u.rsym.renamed - && strcmp (name, module_name) != 0 - && find_symbol (gfc_current_ns->sym_root, name, - module_name, 0)) - continue; - - st = gfc_find_symtree (gfc_current_ns->sym_root, p); - - if (st != NULL - && !(st->n.sym && st->n.sym->attr.used_in_submodule)) - { - /* Check for ambiguous symbols. */ - if (check_for_ambiguous (st, info)) - st->ambiguous = 1; - else - info->u.rsym.symtree = st; - } - else - { - if (st) - { - /* This symbol is host associated from a module in a - submodule. Hide it with a unique symtree. */ - gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); - s->n.sym = st->n.sym; - st->n.sym = NULL; - } - else - { - /* Create a symtree node in the current namespace for this - symbol. */ - st = check_unique_name (p) - ? gfc_get_unique_symtree (gfc_current_ns) - : gfc_new_symtree (&gfc_current_ns->sym_root, p); - st->ambiguous = ambiguous; - } - - sym = info->u.rsym.sym; - - /* Create a symbol node if it doesn't already exist. */ - if (sym == NULL) - { - info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, - gfc_current_ns); - info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name); - sym = info->u.rsym.sym; - sym->module = gfc_get_string ("%s", info->u.rsym.module); - - if (info->u.rsym.binding_label) - { - tree id = get_identifier (info->u.rsym.binding_label); - sym->binding_label = IDENTIFIER_POINTER (id); - } - } - - st->n.sym = sym; - st->n.sym->refs++; - - if (strcmp (name, p) != 0) - sym->attr.use_rename = 1; - - if (name[0] != '_' - || (!startswith (name, "__vtab_") - && !startswith (name, "__vtype_"))) - sym->attr.use_only = only_flag; - - /* Store the symtree pointing to this symbol. */ - info->u.rsym.symtree = st; - - if (info->u.rsym.state == UNUSED) - info->u.rsym.state = NEEDED; - info->u.rsym.referenced = 1; - } - } - } - - mio_rparen (); - - /* Load intrinsic operator interfaces. */ - set_module_locus (&operator_interfaces); - mio_lparen (); - - for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) - { - gfc_use_rename *u = NULL, *v = NULL; - int j = i; - - if (i == INTRINSIC_USER) - continue; - - if (only_flag) - { - u = find_use_operator ((gfc_intrinsic_op) i); - - /* F2018:10.1.5.5.1 requires same interpretation of old and new-style - relational operators. Special handling for USE, ONLY. */ - switch (i) - { - case INTRINSIC_EQ: - j = INTRINSIC_EQ_OS; - break; - case INTRINSIC_EQ_OS: - j = INTRINSIC_EQ; - break; - case INTRINSIC_NE: - j = INTRINSIC_NE_OS; - break; - case INTRINSIC_NE_OS: - j = INTRINSIC_NE; - break; - case INTRINSIC_GT: - j = INTRINSIC_GT_OS; - break; - case INTRINSIC_GT_OS: - j = INTRINSIC_GT; - break; - case INTRINSIC_GE: - j = INTRINSIC_GE_OS; - break; - case INTRINSIC_GE_OS: - j = INTRINSIC_GE; - break; - case INTRINSIC_LT: - j = INTRINSIC_LT_OS; - break; - case INTRINSIC_LT_OS: - j = INTRINSIC_LT; - break; - case INTRINSIC_LE: - j = INTRINSIC_LE_OS; - break; - case INTRINSIC_LE_OS: - j = INTRINSIC_LE; - break; - default: - break; - } - - if (j != i) - v = find_use_operator ((gfc_intrinsic_op) j); - - if (u == NULL && v == NULL) - { - skip_list (); - continue; - } - - if (u) - u->found = 1; - if (v) - v->found = 1; - } - - mio_interface (&gfc_current_ns->op[i]); - if (!gfc_current_ns->op[i] && !gfc_current_ns->op[j]) - { - if (u) - u->found = 0; - if (v) - v->found = 0; - } - } - - mio_rparen (); - - /* Load generic and user operator interfaces. These must follow the - loading of symtree because otherwise symbols can be marked as - ambiguous. */ - - set_module_locus (&user_operators); - - load_operator_interfaces (); - load_generic_interfaces (); - - load_commons (); - load_equiv (); - - /* Load OpenMP user defined reductions. */ - set_module_locus (&omp_udrs); - load_omp_udrs (); - - /* At this point, we read those symbols that are needed but haven't - been loaded yet. If one symbol requires another, the other gets - marked as NEEDED if its previous state was UNUSED. */ - - while (load_needed (pi_root)); - - /* Make sure all elements of the rename-list were found in the module. */ - - for (u = gfc_rename_list; u; u = u->next) - { - if (u->found) - continue; - - if (u->op == INTRINSIC_NONE) - { - gfc_error ("Symbol %qs referenced at %L not found in module %qs", - u->use_name, &u->where, module_name); - continue; - } - - if (u->op == INTRINSIC_USER) - { - gfc_error ("User operator %qs referenced at %L not found " - "in module %qs", u->use_name, &u->where, module_name); - continue; - } - - gfc_error ("Intrinsic operator %qs referenced at %L not found " - "in module %qs", gfc_op2string (u->op), &u->where, - module_name); - } - - /* Clean up symbol nodes that were never loaded, create references - to hidden symbols. */ - - read_cleanup (pi_root); -} - - -/* Given an access type that is specific to an entity and the default - access, return nonzero if the entity is publicly accessible. If the - element is declared as PUBLIC, then it is public; if declared - PRIVATE, then private, and otherwise it is public unless the default - access in this context has been declared PRIVATE. */ - -static bool dump_smod = false; - -static bool -check_access (gfc_access specific_access, gfc_access default_access) -{ - if (dump_smod) - return true; - - if (specific_access == ACCESS_PUBLIC) - return TRUE; - if (specific_access == ACCESS_PRIVATE) - return FALSE; - - if (flag_module_private) - return default_access == ACCESS_PUBLIC; - else - return default_access != ACCESS_PRIVATE; -} - - -bool -gfc_check_symbol_access (gfc_symbol *sym) -{ - if (sym->attr.vtab || sym->attr.vtype) - return true; - else - return check_access (sym->attr.access, sym->ns->default_access); -} - - -/* A structure to remember which commons we've already written. */ - -struct written_common -{ - BBT_HEADER(written_common); - const char *name, *label; -}; - -static struct written_common *written_commons = NULL; - -/* Comparison function used for balancing the binary tree. */ - -static int -compare_written_commons (void *a1, void *b1) -{ - const char *aname = ((struct written_common *) a1)->name; - const char *alabel = ((struct written_common *) a1)->label; - const char *bname = ((struct written_common *) b1)->name; - const char *blabel = ((struct written_common *) b1)->label; - int c = strcmp (aname, bname); - - return (c != 0 ? c : strcmp (alabel, blabel)); -} - -/* Free a list of written commons. */ - -static void -free_written_common (struct written_common *w) -{ - if (!w) - return; - - if (w->left) - free_written_common (w->left); - if (w->right) - free_written_common (w->right); - - free (w); -} - -/* Write a common block to the module -- recursive helper function. */ - -static void -write_common_0 (gfc_symtree *st, bool this_module) -{ - gfc_common_head *p; - const char * name; - int flags; - const char *label; - struct written_common *w; - bool write_me = true; - - if (st == NULL) - return; - - write_common_0 (st->left, this_module); - - /* We will write out the binding label, or "" if no label given. */ - name = st->n.common->name; - p = st->n.common; - label = (p->is_bind_c && p->binding_label) ? p->binding_label : ""; - - /* Check if we've already output this common. */ - w = written_commons; - while (w) - { - int c = strcmp (name, w->name); - c = (c != 0 ? c : strcmp (label, w->label)); - if (c == 0) - write_me = false; - - w = (c < 0) ? w->left : w->right; - } - - if (this_module && p->use_assoc) - write_me = false; - - if (write_me) - { - /* Write the common to the module. */ - mio_lparen (); - mio_pool_string (&name); - - mio_symbol_ref (&p->head); - flags = p->saved ? 1 : 0; - if (p->threadprivate) - flags |= 2; - flags |= p->omp_device_type << 2; - mio_integer (&flags); - - /* Write out whether the common block is bind(c) or not. */ - mio_integer (&(p->is_bind_c)); - - mio_pool_string (&label); - mio_rparen (); - - /* Record that we have written this common. */ - w = XCNEW (struct written_common); - w->name = p->name; - w->label = label; - gfc_insert_bbt (&written_commons, w, compare_written_commons); - } - - write_common_0 (st->right, this_module); -} - - -/* Write a common, by initializing the list of written commons, calling - the recursive function write_common_0() and cleaning up afterwards. */ - -static void -write_common (gfc_symtree *st) -{ - written_commons = NULL; - write_common_0 (st, true); - write_common_0 (st, false); - free_written_common (written_commons); - written_commons = NULL; -} - - -/* Write the blank common block to the module. */ - -static void -write_blank_common (void) -{ - const char * name = BLANK_COMMON_NAME; - int saved; - /* TODO: Blank commons are not bind(c). The F2003 standard probably says - this, but it hasn't been checked. Just making it so for now. */ - int is_bind_c = 0; - - if (gfc_current_ns->blank_common.head == NULL) - return; - - mio_lparen (); - - mio_pool_string (&name); - - mio_symbol_ref (&gfc_current_ns->blank_common.head); - saved = gfc_current_ns->blank_common.saved; - mio_integer (&saved); - - /* Write out whether the common block is bind(c) or not. */ - mio_integer (&is_bind_c); - - /* Write out an empty binding label. */ - write_atom (ATOM_STRING, ""); - - mio_rparen (); -} - - -/* Write equivalences to the module. */ - -static void -write_equiv (void) -{ - gfc_equiv *eq, *e; - int num; - - num = 0; - for (eq = gfc_current_ns->equiv; eq; eq = eq->next) - { - mio_lparen (); - - for (e = eq; e; e = e->eq) - { - if (e->module == NULL) - e->module = gfc_get_string ("%s.eq.%d", module_name, num); - mio_allocated_string (e->module); - mio_expr (&e->expr); - } - - num++; - mio_rparen (); - } -} - - -/* Write a symbol to the module. */ - -static void -write_symbol (int n, gfc_symbol *sym) -{ - const char *label; - - if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL) - gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name); - - mio_integer (&n); - - if (gfc_fl_struct (sym->attr.flavor)) - { - const char *name; - name = gfc_dt_upper_string (sym->name); - mio_pool_string (&name); - } - else - mio_pool_string (&sym->name); - - mio_pool_string (&sym->module); - if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label) - { - label = sym->binding_label; - mio_pool_string (&label); - } - else - write_atom (ATOM_STRING, ""); - - mio_pointer_ref (&sym->ns); - - mio_symbol (sym); - write_char ('\n'); -} - - -/* Recursive traversal function to write the initial set of symbols to - the module. We check to see if the symbol should be written - according to the access specification. */ - -static void -write_symbol0 (gfc_symtree *st) -{ - gfc_symbol *sym; - pointer_info *p; - bool dont_write = false; - - if (st == NULL) - return; - - write_symbol0 (st->left); - - sym = st->n.sym; - if (sym->module == NULL) - sym->module = module_name; - - if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic - && !sym->attr.subroutine && !sym->attr.function) - dont_write = true; - - if (!gfc_check_symbol_access (sym)) - dont_write = true; - - if (!dont_write) - { - p = get_pointer (sym); - if (p->type == P_UNKNOWN) - p->type = P_SYMBOL; - - if (p->u.wsym.state != WRITTEN) - { - write_symbol (p->integer, sym); - p->u.wsym.state = WRITTEN; - } - } - - write_symbol0 (st->right); -} - - -static void -write_omp_udr (gfc_omp_udr *udr) -{ - switch (udr->rop) - { - case OMP_REDUCTION_USER: - /* Non-operators can't be used outside of the module. */ - if (udr->name[0] != '.') - return; - else - { - gfc_symtree *st; - size_t len = strlen (udr->name + 1); - char *name = XALLOCAVEC (char, len); - memcpy (name, udr->name, len - 1); - name[len - 1] = '\0'; - st = gfc_find_symtree (gfc_current_ns->uop_root, name); - /* If corresponding user operator is private, don't write - the UDR. */ - if (st != NULL) - { - gfc_user_op *uop = st->n.uop; - if (!check_access (uop->access, uop->ns->default_access)) - return; - } - } - break; - case OMP_REDUCTION_PLUS: - case OMP_REDUCTION_MINUS: - case OMP_REDUCTION_TIMES: - case OMP_REDUCTION_AND: - case OMP_REDUCTION_OR: - case OMP_REDUCTION_EQV: - case OMP_REDUCTION_NEQV: - /* If corresponding operator is private, don't write the UDR. */ - if (!check_access (gfc_current_ns->operator_access[udr->rop], - gfc_current_ns->default_access)) - return; - break; - default: - break; - } - if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS) - { - /* If derived type is private, don't write the UDR. */ - if (!gfc_check_symbol_access (udr->ts.u.derived)) - return; - } - - mio_lparen (); - mio_pool_string (&udr->name); - mio_typespec (&udr->ts); - mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false); - if (udr->initializer_ns) - mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, - udr->initializer_ns, true); - mio_rparen (); -} - - -static void -write_omp_udrs (gfc_symtree *st) -{ - if (st == NULL) - return; - - write_omp_udrs (st->left); - gfc_omp_udr *udr; - for (udr = st->n.omp_udr; udr; udr = udr->next) - write_omp_udr (udr); - write_omp_udrs (st->right); -} - - -/* Type for the temporary tree used when writing secondary symbols. */ - -struct sorted_pointer_info -{ - BBT_HEADER (sorted_pointer_info); - - pointer_info *p; -}; - -#define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info) - -/* Recursively traverse the temporary tree, free its contents. */ - -static void -free_sorted_pointer_info_tree (sorted_pointer_info *p) -{ - if (!p) - return; - - free_sorted_pointer_info_tree (p->left); - free_sorted_pointer_info_tree (p->right); - - free (p); -} - -/* Comparison function for the temporary tree. */ - -static int -compare_sorted_pointer_info (void *_spi1, void *_spi2) -{ - sorted_pointer_info *spi1, *spi2; - spi1 = (sorted_pointer_info *)_spi1; - spi2 = (sorted_pointer_info *)_spi2; - - if (spi1->p->integer < spi2->p->integer) - return -1; - if (spi1->p->integer > spi2->p->integer) - return 1; - return 0; -} - - -/* Finds the symbols that need to be written and collects them in the - sorted_pi tree so that they can be traversed in an order - independent of memory addresses. */ - -static void -find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p) -{ - if (!p) - return; - - if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE) - { - sorted_pointer_info *sp = gfc_get_sorted_pointer_info(); - sp->p = p; - - gfc_insert_bbt (tree, sp, compare_sorted_pointer_info); - } - - find_symbols_to_write (tree, p->left); - find_symbols_to_write (tree, p->right); -} - - -/* Recursive function that traverses the tree of symbols that need to be - written and writes them in order. */ - -static void -write_symbol1_recursion (sorted_pointer_info *sp) -{ - if (!sp) - return; - - write_symbol1_recursion (sp->left); - - pointer_info *p1 = sp->p; - gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE); - - p1->u.wsym.state = WRITTEN; - write_symbol (p1->integer, p1->u.wsym.sym); - p1->u.wsym.sym->attr.public_used = 1; - - write_symbol1_recursion (sp->right); -} - - -/* Write the secondary set of symbols to the module file. These are - symbols that were not public yet are needed by the public symbols - or another dependent symbol. The act of writing a symbol can add - symbols to the pointer_info tree, so we return nonzero if a symbol - was written and pass that information upwards. The caller will - then call this function again until nothing was written. It uses - the utility functions and a temporary tree to ensure a reproducible - ordering of the symbol output and thus the module file. */ - -static int -write_symbol1 (pointer_info *p) -{ - if (!p) - return 0; - - /* Put symbols that need to be written into a tree sorted on the - integer field. */ - - sorted_pointer_info *spi_root = NULL; - find_symbols_to_write (&spi_root, p); - - /* No symbols to write, return. */ - if (!spi_root) - return 0; - - /* Otherwise, write and free the tree again. */ - write_symbol1_recursion (spi_root); - free_sorted_pointer_info_tree (spi_root); - - return 1; -} - - -/* Write operator interfaces associated with a symbol. */ - -static void -write_operator (gfc_user_op *uop) -{ - static char nullstring[] = ""; - const char *p = nullstring; - - if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access)) - return; - - mio_symbol_interface (&uop->name, &p, &uop->op); -} - - -/* Write generic interfaces from the namespace sym_root. */ - -static void -write_generic (gfc_symtree *st) -{ - gfc_symbol *sym; - - if (st == NULL) - return; - - write_generic (st->left); - - sym = st->n.sym; - if (sym && !check_unique_name (st->name) - && sym->generic && gfc_check_symbol_access (sym)) - { - if (!sym->module) - sym->module = module_name; - - mio_symbol_interface (&st->name, &sym->module, &sym->generic); - } - - write_generic (st->right); -} - - -static void -write_symtree (gfc_symtree *st) -{ - gfc_symbol *sym; - pointer_info *p; - - sym = st->n.sym; - - /* A symbol in an interface body must not be visible in the - module file. */ - if (sym->ns != gfc_current_ns - && sym->ns->proc_name - && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY) - return; - - if (!gfc_check_symbol_access (sym) - || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic - && !sym->attr.subroutine && !sym->attr.function)) - return; - - if (check_unique_name (st->name)) - return; - - /* From F2003 onwards, intrinsic procedures are no longer subject to - the restriction, "that an elemental intrinsic function here be of - type integer or character and each argument must be an initialization - expr of type integer or character" is lifted so that intrinsic - procedures can be over-ridden. This requires that the intrinsic - symbol not appear in the module file, thereby preventing ambiguity - when USEd. */ - if (strcmp (sym->module, "(intrinsic)") == 0 - && (gfc_option.allow_std & GFC_STD_F2003)) - return; - - p = find_pointer (sym); - if (p == NULL) - gfc_internal_error ("write_symtree(): Symbol not written"); - - mio_pool_string (&st->name); - mio_integer (&st->ambiguous); - mio_hwi (&p->integer); -} - - -static void -write_module (void) -{ - int i; - - /* Initialize the column counter. */ - module_column = 1; - - /* Write the operator interfaces. */ - mio_lparen (); - - for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) - { - if (i == INTRINSIC_USER) - continue; - - mio_interface (check_access (gfc_current_ns->operator_access[i], - gfc_current_ns->default_access) - ? &gfc_current_ns->op[i] : NULL); - } - - mio_rparen (); - write_char ('\n'); - write_char ('\n'); - - mio_lparen (); - gfc_traverse_user_op (gfc_current_ns, write_operator); - mio_rparen (); - write_char ('\n'); - write_char ('\n'); - - mio_lparen (); - write_generic (gfc_current_ns->sym_root); - mio_rparen (); - write_char ('\n'); - write_char ('\n'); - - mio_lparen (); - write_blank_common (); - write_common (gfc_current_ns->common_root); - mio_rparen (); - write_char ('\n'); - write_char ('\n'); - - mio_lparen (); - write_equiv (); - mio_rparen (); - write_char ('\n'); - write_char ('\n'); - - mio_lparen (); - write_omp_udrs (gfc_current_ns->omp_udr_root); - mio_rparen (); - write_char ('\n'); - write_char ('\n'); - - /* Write symbol information. First we traverse all symbols in the - primary namespace, writing those that need to be written. - Sometimes writing one symbol will cause another to need to be - written. A list of these symbols ends up on the write stack, and - we end by popping the bottom of the stack and writing the symbol - until the stack is empty. */ - - mio_lparen (); - - write_symbol0 (gfc_current_ns->sym_root); - while (write_symbol1 (pi_root)) - /* Nothing. */; - - mio_rparen (); - - write_char ('\n'); - write_char ('\n'); - - mio_lparen (); - gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree); - mio_rparen (); -} - - -/* Read a CRC32 sum from the gzip trailer of a module file. Returns - true on success, false on failure. */ - -static bool -read_crc32_from_module_file (const char* filename, uLong* crc) -{ - FILE *file; - char buf[4]; - unsigned int val; - - /* Open the file in binary mode. */ - if ((file = fopen (filename, "rb")) == NULL) - return false; - - /* The gzip crc32 value is found in the [END-8, END-4] bytes of the - file. See RFC 1952. */ - if (fseek (file, -8, SEEK_END) != 0) - { - fclose (file); - return false; - } - - /* Read the CRC32. */ - if (fread (buf, 1, 4, file) != 4) - { - fclose (file); - return false; - } - - /* Close the file. */ - fclose (file); - - val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16) - + ((buf[3] & 0xFF) << 24); - *crc = val; - - /* For debugging, the CRC value printed in hexadecimal should match - the CRC printed by "zcat -l -v filename". - printf("CRC of file %s is %x\n", filename, val); */ - - return true; -} - - -/* Given module, dump it to disk. If there was an error while - processing the module, dump_flag will be set to zero and we delete - the module file, even if it was already there. */ - -static void -dump_module (const char *name, int dump_flag) -{ - int n; - char *filename, *filename_tmp; - uLong crc, crc_old; - - module_name = gfc_get_string ("%s", name); - - if (dump_smod) - { - name = submodule_name; - n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1; - } - else - n = strlen (name) + strlen (MODULE_EXTENSION) + 1; - - if (gfc_option.module_dir != NULL) - { - n += strlen (gfc_option.module_dir); - filename = (char *) alloca (n); - strcpy (filename, gfc_option.module_dir); - strcat (filename, name); - } - else - { - filename = (char *) alloca (n); - strcpy (filename, name); - } - - if (dump_smod) - strcat (filename, SUBMODULE_EXTENSION); - else - strcat (filename, MODULE_EXTENSION); - - /* Name of the temporary file used to write the module. */ - filename_tmp = (char *) alloca (n + 1); - strcpy (filename_tmp, filename); - strcat (filename_tmp, "0"); - - /* There was an error while processing the module. We delete the - module file, even if it was already there. */ - if (!dump_flag) - { - remove (filename); - return; - } - - if (gfc_cpp_makedep ()) - gfc_cpp_add_target (filename); - - /* Write the module to the temporary file. */ - module_fp = gzopen (filename_tmp, "w"); - if (module_fp == NULL) - gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s", - filename_tmp, xstrerror (errno)); - - /* Use lbasename to ensure module files are reproducible regardless - of the build path (see the reproducible builds project). */ - gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n", - MOD_VERSION, lbasename (gfc_source_file)); - - /* Write the module itself. */ - iomode = IO_OUTPUT; - - init_pi_tree (); - - write_module (); - - free_pi_tree (pi_root); - pi_root = NULL; - - write_char ('\n'); - - if (gzclose (module_fp)) - gfc_fatal_error ("Error writing module file %qs for writing: %s", - filename_tmp, xstrerror (errno)); - - /* Read the CRC32 from the gzip trailers of the module files and - compare. */ - if (!read_crc32_from_module_file (filename_tmp, &crc) - || !read_crc32_from_module_file (filename, &crc_old) - || crc_old != crc) - { - /* Module file have changed, replace the old one. */ - if (remove (filename) && errno != ENOENT) - gfc_fatal_error ("Cannot delete module file %qs: %s", filename, - xstrerror (errno)); - if (rename (filename_tmp, filename)) - gfc_fatal_error ("Cannot rename module file %qs to %qs: %s", - filename_tmp, filename, xstrerror (errno)); - } - else - { - if (remove (filename_tmp)) - gfc_fatal_error ("Cannot delete temporary module file %qs: %s", - filename_tmp, xstrerror (errno)); - } -} - - -/* Suppress the output of a .smod file by module, if no module - procedures have been seen. */ -static bool no_module_procedures; - -static void -check_for_module_procedures (gfc_symbol *sym) -{ - if (sym && sym->attr.module_procedure) - no_module_procedures = false; -} - - -void -gfc_dump_module (const char *name, int dump_flag) -{ - if (gfc_state_stack->state == COMP_SUBMODULE) - dump_smod = true; - else - dump_smod =false; - - no_module_procedures = true; - gfc_traverse_ns (gfc_current_ns, check_for_module_procedures); - - dump_module (name, dump_flag); - - if (no_module_procedures || dump_smod) - return; - - /* Write a submodule file from a module. The 'dump_smod' flag switches - off the check for PRIVATE entities. */ - dump_smod = true; - submodule_name = module_name; - dump_module (name, dump_flag); - dump_smod = false; -} - -static void -create_intrinsic_function (const char *name, int id, - const char *modname, intmod_id module, - bool subroutine, gfc_symbol *result_type) -{ - gfc_intrinsic_sym *isym; - gfc_symtree *tmp_symtree; - gfc_symbol *sym; - - tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (tmp_symtree) - { - if (tmp_symtree->n.sym && tmp_symtree->n.sym->module - && strcmp (modname, tmp_symtree->n.sym->module) == 0) - return; - gfc_error ("Symbol %qs at %C already declared", name); - return; - } - - gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); - sym = tmp_symtree->n.sym; - - if (subroutine) - { - gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); - isym = gfc_intrinsic_subroutine_by_id (isym_id); - sym->attr.subroutine = 1; - } - else - { - gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); - isym = gfc_intrinsic_function_by_id (isym_id); - - sym->attr.function = 1; - if (result_type) - { - sym->ts.type = BT_DERIVED; - sym->ts.u.derived = result_type; - sym->ts.is_c_interop = 1; - isym->ts.f90_type = BT_VOID; - isym->ts.type = BT_DERIVED; - isym->ts.f90_type = BT_VOID; - isym->ts.u.derived = result_type; - isym->ts.is_c_interop = 1; - } - } - gcc_assert (isym); - - sym->attr.flavor = FL_PROCEDURE; - sym->attr.intrinsic = 1; - - sym->module = gfc_get_string ("%s", modname); - sym->attr.use_assoc = 1; - sym->from_intmod = module; - sym->intmod_sym_id = id; -} - - -/* Import the intrinsic ISO_C_BINDING module, generating symbols in - the current namespace for all named constants, pointer types, and - procedures in the module unless the only clause was used or a rename - list was provided. */ - -static void -import_iso_c_binding_module (void) -{ - gfc_symbol *mod_sym = NULL, *return_type; - gfc_symtree *mod_symtree = NULL, *tmp_symtree; - gfc_symtree *c_ptr = NULL, *c_funptr = NULL; - const char *iso_c_module_name = "__iso_c_binding"; - gfc_use_rename *u; - int i; - bool want_c_ptr = false, want_c_funptr = false; - - /* Look only in the current namespace. */ - mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name); - - if (mod_symtree == NULL) - { - /* symtree doesn't already exist in current namespace. */ - gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree, - false); - - if (mod_symtree != NULL) - mod_sym = mod_symtree->n.sym; - else - gfc_internal_error ("import_iso_c_binding_module(): Unable to " - "create symbol for %s", iso_c_module_name); - - mod_sym->attr.flavor = FL_MODULE; - mod_sym->attr.intrinsic = 1; - mod_sym->module = gfc_get_string ("%s", iso_c_module_name); - mod_sym->from_intmod = INTMOD_ISO_C_BINDING; - } - - /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it; - check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which - need C_(FUN)PTR. */ - for (u = gfc_rename_list; u; u = u->next) - { - if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name, - u->use_name) == 0) - want_c_ptr = true; - else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name, - u->use_name) == 0) - want_c_ptr = true; - else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name, - u->use_name) == 0) - want_c_funptr = true; - else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name, - u->use_name) == 0) - want_c_funptr = true; - else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name, - u->use_name) == 0) - { - c_ptr = generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) - ISOCBINDING_PTR, - u->local_name[0] ? u->local_name - : u->use_name, - NULL, false); - } - else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name, - u->use_name) == 0) - { - c_funptr - = generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) - ISOCBINDING_FUNPTR, - u->local_name[0] ? u->local_name - : u->use_name, - NULL, false); - } - } - - if ((want_c_ptr || !only_flag) && !c_ptr) - c_ptr = generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) - ISOCBINDING_PTR, - NULL, NULL, only_flag); - if ((want_c_funptr || !only_flag) && !c_funptr) - c_funptr = generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) - ISOCBINDING_FUNPTR, - NULL, NULL, only_flag); - - /* Generate the symbols for the named constants representing - the kinds for intrinsic data types. */ - for (i = 0; i < ISOCBINDING_NUMBER; i++) - { - bool found = false; - for (u = gfc_rename_list; u; u = u->next) - if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0) - { - bool not_in_std; - const char *name; - u->found = 1; - found = true; - - switch (i) - { -#define NAMED_FUNCTION(a,b,c,d) \ - case a: \ - not_in_std = (gfc_option.allow_std & d) == 0; \ - name = b; \ - break; -#define NAMED_SUBROUTINE(a,b,c,d) \ - case a: \ - not_in_std = (gfc_option.allow_std & d) == 0; \ - name = b; \ - break; -#define NAMED_INTCST(a,b,c,d) \ - case a: \ - not_in_std = (gfc_option.allow_std & d) == 0; \ - name = b; \ - break; -#define NAMED_REALCST(a,b,c,d) \ - case a: \ - not_in_std = (gfc_option.allow_std & d) == 0; \ - name = b; \ - break; -#define NAMED_CMPXCST(a,b,c,d) \ - case a: \ - not_in_std = (gfc_option.allow_std & d) == 0; \ - name = b; \ - break; -#include "iso-c-binding.def" - default: - not_in_std = false; - name = ""; - } - - if (not_in_std) - { - gfc_error ("The symbol %qs, referenced at %L, is not " - "in the selected standard", name, &u->where); - continue; - } - - switch (i) - { -#define NAMED_FUNCTION(a,b,c,d) \ - case a: \ - if (a == ISOCBINDING_LOC) \ - return_type = c_ptr->n.sym; \ - else if (a == ISOCBINDING_FUNLOC) \ - return_type = c_funptr->n.sym; \ - else \ - return_type = NULL; \ - create_intrinsic_function (u->local_name[0] \ - ? u->local_name : u->use_name, \ - a, iso_c_module_name, \ - INTMOD_ISO_C_BINDING, false, \ - return_type); \ - break; -#define NAMED_SUBROUTINE(a,b,c,d) \ - case a: \ - create_intrinsic_function (u->local_name[0] ? u->local_name \ - : u->use_name, \ - a, iso_c_module_name, \ - INTMOD_ISO_C_BINDING, true, NULL); \ - break; -#include "iso-c-binding.def" - - case ISOCBINDING_PTR: - case ISOCBINDING_FUNPTR: - /* Already handled above. */ - break; - default: - if (i == ISOCBINDING_NULL_PTR) - tmp_symtree = c_ptr; - else if (i == ISOCBINDING_NULL_FUNPTR) - tmp_symtree = c_funptr; - else - tmp_symtree = NULL; - generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) i, - u->local_name[0] - ? u->local_name : u->use_name, - tmp_symtree, false); - } - } - - if (!found && !only_flag) - { - /* Skip, if the symbol is not in the enabled standard. */ - switch (i) - { -#define NAMED_FUNCTION(a,b,c,d) \ - case a: \ - if ((gfc_option.allow_std & d) == 0) \ - continue; \ - break; -#define NAMED_SUBROUTINE(a,b,c,d) \ - case a: \ - if ((gfc_option.allow_std & d) == 0) \ - continue; \ - break; -#define NAMED_INTCST(a,b,c,d) \ - case a: \ - if ((gfc_option.allow_std & d) == 0) \ - continue; \ - break; -#define NAMED_REALCST(a,b,c,d) \ - case a: \ - if ((gfc_option.allow_std & d) == 0) \ - continue; \ - break; -#define NAMED_CMPXCST(a,b,c,d) \ - case a: \ - if ((gfc_option.allow_std & d) == 0) \ - continue; \ - break; -#include "iso-c-binding.def" - default: - ; /* Not GFC_STD_* versioned. */ - } - - switch (i) - { -#define NAMED_FUNCTION(a,b,c,d) \ - case a: \ - if (a == ISOCBINDING_LOC) \ - return_type = c_ptr->n.sym; \ - else if (a == ISOCBINDING_FUNLOC) \ - return_type = c_funptr->n.sym; \ - else \ - return_type = NULL; \ - create_intrinsic_function (b, a, iso_c_module_name, \ - INTMOD_ISO_C_BINDING, false, \ - return_type); \ - break; -#define NAMED_SUBROUTINE(a,b,c,d) \ - case a: \ - create_intrinsic_function (b, a, iso_c_module_name, \ - INTMOD_ISO_C_BINDING, true, NULL); \ - break; -#include "iso-c-binding.def" - - case ISOCBINDING_PTR: - case ISOCBINDING_FUNPTR: - /* Already handled above. */ - break; - default: - if (i == ISOCBINDING_NULL_PTR) - tmp_symtree = c_ptr; - else if (i == ISOCBINDING_NULL_FUNPTR) - tmp_symtree = c_funptr; - else - tmp_symtree = NULL; - generate_isocbinding_symbol (iso_c_module_name, - (iso_c_binding_symbol) i, NULL, - tmp_symtree, false); - } - } - } - - for (u = gfc_rename_list; u; u = u->next) - { - if (u->found) - continue; - - gfc_error ("Symbol %qs referenced at %L not found in intrinsic " - "module ISO_C_BINDING", u->use_name, &u->where); - } -} - - -/* Add an integer named constant from a given module. */ - -static void -create_int_parameter (const char *name, int value, const char *modname, - intmod_id module, int id) -{ - gfc_symtree *tmp_symtree; - gfc_symbol *sym; - - tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (tmp_symtree != NULL) - { - if (strcmp (modname, tmp_symtree->n.sym->module) == 0) - return; - else - gfc_error ("Symbol %qs already declared", name); - } - - gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); - sym = tmp_symtree->n.sym; - - sym->module = gfc_get_string ("%s", modname); - sym->attr.flavor = FL_PARAMETER; - sym->ts.type = BT_INTEGER; - sym->ts.kind = gfc_default_integer_kind; - sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value); - sym->attr.use_assoc = 1; - sym->from_intmod = module; - sym->intmod_sym_id = id; -} - - -/* Value is already contained by the array constructor, but not - yet the shape. */ - -static void -create_int_parameter_array (const char *name, int size, gfc_expr *value, - const char *modname, intmod_id module, int id) -{ - gfc_symtree *tmp_symtree; - gfc_symbol *sym; - - tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (tmp_symtree != NULL) - { - if (strcmp (modname, tmp_symtree->n.sym->module) == 0) - return; - else - gfc_error ("Symbol %qs already declared", name); - } - - gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); - sym = tmp_symtree->n.sym; - - sym->module = gfc_get_string ("%s", modname); - sym->attr.flavor = FL_PARAMETER; - sym->ts.type = BT_INTEGER; - sym->ts.kind = gfc_default_integer_kind; - sym->attr.use_assoc = 1; - sym->from_intmod = module; - sym->intmod_sym_id = id; - sym->attr.dimension = 1; - sym->as = gfc_get_array_spec (); - sym->as->rank = 1; - sym->as->type = AS_EXPLICIT; - sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size); - - sym->value = value; - sym->value->shape = gfc_get_shape (1); - mpz_init_set_ui (sym->value->shape[0], size); -} - - -/* Add an derived type for a given module. */ - -static void -create_derived_type (const char *name, const char *modname, - intmod_id module, int id) -{ - gfc_symtree *tmp_symtree; - gfc_symbol *sym, *dt_sym; - gfc_interface *intr, *head; - - tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (tmp_symtree != NULL) - { - if (strcmp (modname, tmp_symtree->n.sym->module) == 0) - return; - else - gfc_error ("Symbol %qs already declared", name); - } - - gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); - sym = tmp_symtree->n.sym; - sym->module = gfc_get_string ("%s", modname); - sym->from_intmod = module; - sym->intmod_sym_id = id; - sym->attr.flavor = FL_PROCEDURE; - sym->attr.function = 1; - sym->attr.generic = 1; - - gfc_get_sym_tree (gfc_dt_upper_string (sym->name), - gfc_current_ns, &tmp_symtree, false); - dt_sym = tmp_symtree->n.sym; - dt_sym->name = gfc_get_string ("%s", sym->name); - dt_sym->attr.flavor = FL_DERIVED; - dt_sym->attr.private_comp = 1; - dt_sym->attr.zero_comp = 1; - dt_sym->attr.use_assoc = 1; - dt_sym->module = gfc_get_string ("%s", modname); - dt_sym->from_intmod = module; - dt_sym->intmod_sym_id = id; - - head = sym->generic; - intr = gfc_get_interface (); - intr->sym = dt_sym; - intr->where = gfc_current_locus; - intr->next = head; - sym->generic = intr; - sym->attr.if_source = IFSRC_DECL; -} - - -/* Read the contents of the module file into a temporary buffer. */ - -static void -read_module_to_tmpbuf () -{ - /* We don't know the uncompressed size, so enlarge the buffer as - needed. */ - int cursz = 4096; - int rsize = cursz; - int len = 0; - - module_content = XNEWVEC (char, cursz); - - while (1) - { - int nread = gzread (module_fp, module_content + len, rsize); - len += nread; - if (nread < rsize) - break; - cursz *= 2; - module_content = XRESIZEVEC (char, module_content, cursz); - rsize = cursz - len; - } - - module_content = XRESIZEVEC (char, module_content, len + 1); - module_content[len] = '\0'; - - module_pos = 0; -} - - -/* USE the ISO_FORTRAN_ENV intrinsic module. */ - -static void -use_iso_fortran_env_module (void) -{ - static char mod[] = "iso_fortran_env"; - gfc_use_rename *u; - gfc_symbol *mod_sym; - gfc_symtree *mod_symtree; - gfc_expr *expr; - int i, j; - - intmod_sym symbol[] = { -#define NAMED_INTCST(a,b,c,d) { a, b, 0, d }, -#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d }, -#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d }, -#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d }, -#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d }, -#include "iso-fortran-env.def" - { ISOFORTRANENV_INVALID, NULL, -1234, 0 } }; - - i = 0; -#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c; -#include "iso-fortran-env.def" - - /* Generate the symbol for the module itself. */ - mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod); - if (mod_symtree == NULL) - { - gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false); - gcc_assert (mod_symtree); - mod_sym = mod_symtree->n.sym; - - mod_sym->attr.flavor = FL_MODULE; - mod_sym->attr.intrinsic = 1; - mod_sym->module = gfc_get_string ("%s", mod); - mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV; - } - else - if (!mod_symtree->n.sym->attr.intrinsic) - gfc_error ("Use of intrinsic module %qs at %C conflicts with " - "non-intrinsic module name used previously", mod); - - /* Generate the symbols for the module integer named constants. */ - - for (i = 0; symbol[i].name; i++) - { - bool found = false; - for (u = gfc_rename_list; u; u = u->next) - { - if (strcmp (symbol[i].name, u->use_name) == 0) - { - found = true; - u->found = 1; - - if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, " - "referenced at %L, is not in the selected " - "standard", symbol[i].name, &u->where)) - continue; - - if ((flag_default_integer || flag_default_real_8) - && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) - gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named " - "constant from intrinsic module " - "ISO_FORTRAN_ENV at %L is incompatible with " - "option %qs", &u->where, - flag_default_integer - ? "-fdefault-integer-8" - : "-fdefault-real-8"); - switch (symbol[i].id) - { -#define NAMED_INTCST(a,b,c,d) \ - case a: -#include "iso-fortran-env.def" - create_int_parameter (u->local_name[0] ? u->local_name - : u->use_name, - symbol[i].value, mod, - INTMOD_ISO_FORTRAN_ENV, symbol[i].id); - break; - -#define NAMED_KINDARRAY(a,b,KINDS,d) \ - case a:\ - expr = gfc_get_array_expr (BT_INTEGER, \ - gfc_default_integer_kind,\ - NULL); \ - for (j = 0; KINDS[j].kind != 0; j++) \ - gfc_constructor_append_expr (&expr->value.constructor, \ - gfc_get_int_expr (gfc_default_integer_kind, NULL, \ - KINDS[j].kind), NULL); \ - create_int_parameter_array (u->local_name[0] ? u->local_name \ - : u->use_name, \ - j, expr, mod, \ - INTMOD_ISO_FORTRAN_ENV, \ - symbol[i].id); \ - break; -#include "iso-fortran-env.def" - -#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ - case a: -#include "iso-fortran-env.def" - create_derived_type (u->local_name[0] ? u->local_name - : u->use_name, - mod, INTMOD_ISO_FORTRAN_ENV, - symbol[i].id); - break; - -#define NAMED_FUNCTION(a,b,c,d) \ - case a: -#include "iso-fortran-env.def" - create_intrinsic_function (u->local_name[0] ? u->local_name - : u->use_name, - symbol[i].id, mod, - INTMOD_ISO_FORTRAN_ENV, false, - NULL); - break; - - default: - gcc_unreachable (); - } - } - } - - if (!found && !only_flag) - { - if ((gfc_option.allow_std & symbol[i].standard) == 0) - continue; - - if ((flag_default_integer || flag_default_real_8) - && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) - gfc_warning_now (0, - "Use of the NUMERIC_STORAGE_SIZE named constant " - "from intrinsic module ISO_FORTRAN_ENV at %C is " - "incompatible with option %s", - flag_default_integer - ? "-fdefault-integer-8" : "-fdefault-real-8"); - - switch (symbol[i].id) - { -#define NAMED_INTCST(a,b,c,d) \ - case a: -#include "iso-fortran-env.def" - create_int_parameter (symbol[i].name, symbol[i].value, mod, - INTMOD_ISO_FORTRAN_ENV, symbol[i].id); - break; - -#define NAMED_KINDARRAY(a,b,KINDS,d) \ - case a:\ - expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \ - NULL); \ - for (j = 0; KINDS[j].kind != 0; j++) \ - gfc_constructor_append_expr (&expr->value.constructor, \ - gfc_get_int_expr (gfc_default_integer_kind, NULL, \ - KINDS[j].kind), NULL); \ - create_int_parameter_array (symbol[i].name, j, expr, mod, \ - INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\ - break; -#include "iso-fortran-env.def" - -#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ - case a: -#include "iso-fortran-env.def" - create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV, - symbol[i].id); - break; - -#define NAMED_FUNCTION(a,b,c,d) \ - case a: -#include "iso-fortran-env.def" - create_intrinsic_function (symbol[i].name, symbol[i].id, mod, - INTMOD_ISO_FORTRAN_ENV, false, - NULL); - break; - - default: - gcc_unreachable (); - } - } - } - - for (u = gfc_rename_list; u; u = u->next) - { - if (u->found) - continue; - - gfc_error ("Symbol %qs referenced at %L not found in intrinsic " - "module ISO_FORTRAN_ENV", u->use_name, &u->where); - } -} - - -/* Process a USE directive. */ - -static void -gfc_use_module (gfc_use_list *module) -{ - char *filename; - gfc_state_data *p; - int c, line, start; - gfc_symtree *mod_symtree; - gfc_use_list *use_stmt; - locus old_locus = gfc_current_locus; - - gfc_current_locus = module->where; - module_name = module->module_name; - gfc_rename_list = module->rename; - only_flag = module->only_flag; - current_intmod = INTMOD_NONE; - - if (!only_flag) - gfc_warning_now (OPT_Wuse_without_only, - "USE statement at %C has no ONLY qualifier"); - - if (gfc_state_stack->state == COMP_MODULE - || module->submodule_name == NULL) - { - filename = XALLOCAVEC (char, strlen (module_name) - + strlen (MODULE_EXTENSION) + 1); - strcpy (filename, module_name); - strcat (filename, MODULE_EXTENSION); - } - else - { - filename = XALLOCAVEC (char, strlen (module->submodule_name) - + strlen (SUBMODULE_EXTENSION) + 1); - strcpy (filename, module->submodule_name); - strcat (filename, SUBMODULE_EXTENSION); - } - - /* First, try to find an non-intrinsic module, unless the USE statement - specified that the module is intrinsic. */ - module_fp = NULL; - if (!module->intrinsic) - module_fp = gzopen_included_file (filename, true, true); - - /* Then, see if it's an intrinsic one, unless the USE statement - specified that the module is non-intrinsic. */ - if (module_fp == NULL && !module->non_intrinsic) - { - if (strcmp (module_name, "iso_fortran_env") == 0 - && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV " - "intrinsic module at %C")) - { - use_iso_fortran_env_module (); - free_rename (module->rename); - module->rename = NULL; - gfc_current_locus = old_locus; - module->intrinsic = true; - return; - } - - if (strcmp (module_name, "iso_c_binding") == 0 - && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C")) - { - import_iso_c_binding_module(); - free_rename (module->rename); - module->rename = NULL; - gfc_current_locus = old_locus; - module->intrinsic = true; - return; - } - - module_fp = gzopen_intrinsic_module (filename); - - if (module_fp == NULL && module->intrinsic) - gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C", - module_name); - - /* Check for the IEEE modules, so we can mark their symbols - accordingly when we read them. */ - if (strcmp (module_name, "ieee_features") == 0 - && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C")) - { - current_intmod = INTMOD_IEEE_FEATURES; - } - else if (strcmp (module_name, "ieee_exceptions") == 0 - && gfc_notify_std (GFC_STD_F2003, - "IEEE_EXCEPTIONS module at %C")) - { - current_intmod = INTMOD_IEEE_EXCEPTIONS; - } - else if (strcmp (module_name, "ieee_arithmetic") == 0 - && gfc_notify_std (GFC_STD_F2003, - "IEEE_ARITHMETIC module at %C")) - { - current_intmod = INTMOD_IEEE_ARITHMETIC; - } - } - - if (module_fp == NULL) - { - if (gfc_state_stack->state != COMP_SUBMODULE - && module->submodule_name == NULL) - gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s", - filename, xstrerror (errno)); - else - gfc_fatal_error ("Module file %qs has not been generated, either " - "because the module does not contain a MODULE " - "PROCEDURE or there is an error in the module.", - filename); - } - - /* Check that we haven't already USEd an intrinsic module with the - same name. */ - - mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name); - if (mod_symtree && mod_symtree->n.sym->attr.intrinsic) - gfc_error ("Use of non-intrinsic module %qs at %C conflicts with " - "intrinsic module name used previously", module_name); - - iomode = IO_INPUT; - module_line = 1; - module_column = 1; - start = 0; - - read_module_to_tmpbuf (); - gzclose (module_fp); - - /* Skip the first line of the module, after checking that this is - a gfortran module file. */ - line = 0; - while (line < 1) - { - c = module_char (); - if (c == EOF) - bad_module ("Unexpected end of module"); - if (start++ < 3) - parse_name (c); - if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0) - || (start == 2 && strcmp (atom_name, " module") != 0)) - gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran" - " module file", module_fullpath); - if (start == 3) - { - if (strcmp (atom_name, " version") != 0 - || module_char () != ' ' - || parse_atom () != ATOM_STRING - || strcmp (atom_string, MOD_VERSION)) - gfc_fatal_error ("Cannot read module file %qs opened at %C," - " because it was created by a different" - " version of GNU Fortran", module_fullpath); - - free (atom_string); - } - - if (c == '\n') - line++; - } - - /* Make sure we're not reading the same module that we may be building. */ - for (p = gfc_state_stack; p; p = p->previous) - if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE) - && strcmp (p->sym->name, module_name) == 0) - { - if (p->state == COMP_SUBMODULE) - gfc_fatal_error ("Cannot USE a submodule that is currently built"); - else - gfc_fatal_error ("Cannot USE a module that is currently built"); - } - - init_pi_tree (); - init_true_name_tree (); - - read_module (); - - free_true_name (true_name_root); - true_name_root = NULL; - - free_pi_tree (pi_root); - pi_root = NULL; - - XDELETEVEC (module_content); - module_content = NULL; - - use_stmt = gfc_get_use_list (); - *use_stmt = *module; - use_stmt->next = gfc_current_ns->use_stmts; - gfc_current_ns->use_stmts = use_stmt; - - gfc_current_locus = old_locus; -} - - -/* Remove duplicated intrinsic operators from the rename list. */ - -static void -rename_list_remove_duplicate (gfc_use_rename *list) -{ - gfc_use_rename *seek, *last; - - for (; list; list = list->next) - if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE) - { - last = list; - for (seek = list->next; seek; seek = last->next) - { - if (list->op == seek->op) - { - last->next = seek->next; - free (seek); - } - else - last = seek; - } - } -} - - -/* Process all USE directives. */ - -void -gfc_use_modules (void) -{ - gfc_use_list *next, *seek, *last; - - for (next = module_list; next; next = next->next) - { - bool non_intrinsic = next->non_intrinsic; - bool intrinsic = next->intrinsic; - bool neither = !non_intrinsic && !intrinsic; - - for (seek = next->next; seek; seek = seek->next) - { - if (next->module_name != seek->module_name) - continue; - - if (seek->non_intrinsic) - non_intrinsic = true; - else if (seek->intrinsic) - intrinsic = true; - else - neither = true; - } - - if (intrinsic && neither && !non_intrinsic) - { - char *filename; - FILE *fp; - - filename = XALLOCAVEC (char, - strlen (next->module_name) - + strlen (MODULE_EXTENSION) + 1); - strcpy (filename, next->module_name); - strcat (filename, MODULE_EXTENSION); - fp = gfc_open_included_file (filename, true, true); - if (fp != NULL) - { - non_intrinsic = true; - fclose (fp); - } - } - - last = next; - for (seek = next->next; seek; seek = last->next) - { - if (next->module_name != seek->module_name) - { - last = seek; - continue; - } - - if ((!next->intrinsic && !seek->intrinsic) - || (next->intrinsic && seek->intrinsic) - || !non_intrinsic) - { - if (!seek->only_flag) - next->only_flag = false; - if (seek->rename) - { - gfc_use_rename *r = seek->rename; - while (r->next) - r = r->next; - r->next = next->rename; - next->rename = seek->rename; - } - last->next = seek->next; - free (seek); - } - else - last = seek; - } - } - - for (; module_list; module_list = next) - { - next = module_list->next; - rename_list_remove_duplicate (module_list->rename); - gfc_use_module (module_list); - free (module_list); - } - gfc_rename_list = NULL; -} - - -void -gfc_free_use_stmts (gfc_use_list *use_stmts) -{ - gfc_use_list *next; - for (; use_stmts; use_stmts = next) - { - gfc_use_rename *next_rename; - - for (; use_stmts->rename; use_stmts->rename = next_rename) - { - next_rename = use_stmts->rename->next; - free (use_stmts->rename); - } - next = use_stmts->next; - free (use_stmts); - } -} - - -void -gfc_module_init_2 (void) -{ - last_atom = ATOM_LPAREN; - gfc_rename_list = NULL; - module_list = NULL; -} - - -void -gfc_module_done_2 (void) -{ - free_rename (gfc_rename_list); - gfc_rename_list = NULL; -} diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc new file mode 100644 index 0000000..352e613 --- /dev/null +++ b/gcc/fortran/module.cc @@ -0,0 +1,7581 @@ +/* Handle modules, which amounts to loading and saving symbols and + their attendant structures. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +/* The syntax of gfortran modules resembles that of lisp lists, i.e. a + sequence of atoms, which can be left or right parenthesis, names, + integers or strings. Parenthesis are always matched which allows + us to skip over sections at high speed without having to know + anything about the internal structure of the lists. A "name" is + usually a fortran 95 identifier, but can also start with '@' in + order to reference a hidden symbol. + + The first line of a module is an informational message about what + created the module, the file it came from and when it was created. + The second line is a warning for people not to edit the module. + The rest of the module looks like: + + ( ( ) + ( ) + ... + ) + ( ( ... ) + ... + ) + ( ( ... ) + ... + ) + ( ( ) + ... + ) + + ( equivalence list ) + + ( + + + ( ) + ... + ) + ( + + + ... + ) + + In general, symbols refer to other symbols by their symbol number, + which are zero based. Symbols are written to the module in no + particular order. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "stringpool.h" +#include "arith.h" +#include "match.h" +#include "parse.h" /* FIXME */ +#include "constructor.h" +#include "cpp.h" +#include "scanner.h" +#include + +#define MODULE_EXTENSION ".mod" +#define SUBMODULE_EXTENSION ".smod" + +/* Don't put any single quote (') in MOD_VERSION, if you want it to be + recognized. */ +#define MOD_VERSION "15" + + +/* Structure that describes a position within a module file. */ + +typedef struct +{ + int column, line; + long pos; +} +module_locus; + +/* Structure for list of symbols of intrinsic modules. */ +typedef struct +{ + int id; + const char *name; + int value; + int standard; +} +intmod_sym; + + +typedef enum +{ + P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL +} +pointer_t; + +/* The fixup structure lists pointers to pointers that have to + be updated when a pointer value becomes known. */ + +typedef struct fixup_t +{ + void **pointer; + struct fixup_t *next; +} +fixup_t; + + +/* Structure for holding extra info needed for pointers being read. */ + +enum gfc_rsym_state +{ + UNUSED, + NEEDED, + USED +}; + +enum gfc_wsym_state +{ + UNREFERENCED = 0, + NEEDS_WRITE, + WRITTEN +}; + +typedef struct pointer_info +{ + BBT_HEADER (pointer_info); + HOST_WIDE_INT integer; + pointer_t type; + + /* The first component of each member of the union is the pointer + being stored. */ + + fixup_t *fixup; + + union + { + void *pointer; /* Member for doing pointer searches. */ + + struct + { + gfc_symbol *sym; + char *true_name, *module, *binding_label; + fixup_t *stfixup; + gfc_symtree *symtree; + enum gfc_rsym_state state; + int ns, referenced, renamed; + module_locus where; + } + rsym; + + struct + { + gfc_symbol *sym; + enum gfc_wsym_state state; + } + wsym; + } + u; + +} +pointer_info; + +#define gfc_get_pointer_info() XCNEW (pointer_info) + + +/* Local variables */ + +/* The gzFile for the module we're reading or writing. */ +static gzFile module_fp; + +/* Fully qualified module path */ +static char *module_fullpath = NULL; + +/* The name of the module we're reading (USE'ing) or writing. */ +static const char *module_name; +/* The name of the .smod file that the submodule will write to. */ +static const char *submodule_name; + +static gfc_use_list *module_list; + +/* If we're reading an intrinsic module, this is its ID. */ +static intmod_id current_intmod; + +/* Content of module. */ +static char* module_content; + +static long module_pos; +static int module_line, module_column, only_flag; +static int prev_module_line, prev_module_column; + +static enum +{ IO_INPUT, IO_OUTPUT } +iomode; + +static gfc_use_rename *gfc_rename_list; +static pointer_info *pi_root; +static int symbol_number; /* Counter for assigning symbol numbers */ + +/* Tells mio_expr_ref to make symbols for unused equivalence members. */ +static bool in_load_equiv; + + + +/*****************************************************************/ + +/* Pointer/integer conversion. Pointers between structures are stored + as integers in the module file. The next couple of subroutines + handle this translation for reading and writing. */ + +/* Recursively free the tree of pointer structures. */ + +static void +free_pi_tree (pointer_info *p) +{ + if (p == NULL) + return; + + if (p->fixup != NULL) + gfc_internal_error ("free_pi_tree(): Unresolved fixup"); + + free_pi_tree (p->left); + free_pi_tree (p->right); + + if (iomode == IO_INPUT) + { + XDELETEVEC (p->u.rsym.true_name); + XDELETEVEC (p->u.rsym.module); + XDELETEVEC (p->u.rsym.binding_label); + } + + free (p); +} + + +/* Compare pointers when searching by pointer. Used when writing a + module. */ + +static int +compare_pointers (void *_sn1, void *_sn2) +{ + pointer_info *sn1, *sn2; + + sn1 = (pointer_info *) _sn1; + sn2 = (pointer_info *) _sn2; + + if (sn1->u.pointer < sn2->u.pointer) + return -1; + if (sn1->u.pointer > sn2->u.pointer) + return 1; + + return 0; +} + + +/* Compare integers when searching by integer. Used when reading a + module. */ + +static int +compare_integers (void *_sn1, void *_sn2) +{ + pointer_info *sn1, *sn2; + + sn1 = (pointer_info *) _sn1; + sn2 = (pointer_info *) _sn2; + + if (sn1->integer < sn2->integer) + return -1; + if (sn1->integer > sn2->integer) + return 1; + + return 0; +} + + +/* Initialize the pointer_info tree. */ + +static void +init_pi_tree (void) +{ + compare_fn compare; + pointer_info *p; + + pi_root = NULL; + compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers; + + /* Pointer 0 is the NULL pointer. */ + p = gfc_get_pointer_info (); + p->u.pointer = NULL; + p->integer = 0; + p->type = P_OTHER; + + gfc_insert_bbt (&pi_root, p, compare); + + /* Pointer 1 is the current namespace. */ + p = gfc_get_pointer_info (); + p->u.pointer = gfc_current_ns; + p->integer = 1; + p->type = P_NAMESPACE; + + gfc_insert_bbt (&pi_root, p, compare); + + symbol_number = 2; +} + + +/* During module writing, call here with a pointer to something, + returning the pointer_info node. */ + +static pointer_info * +find_pointer (void *gp) +{ + pointer_info *p; + + p = pi_root; + while (p != NULL) + { + if (p->u.pointer == gp) + break; + p = (gp < p->u.pointer) ? p->left : p->right; + } + + return p; +} + + +/* Given a pointer while writing, returns the pointer_info tree node, + creating it if it doesn't exist. */ + +static pointer_info * +get_pointer (void *gp) +{ + pointer_info *p; + + p = find_pointer (gp); + if (p != NULL) + return p; + + /* Pointer doesn't have an integer. Give it one. */ + p = gfc_get_pointer_info (); + + p->u.pointer = gp; + p->integer = symbol_number++; + + gfc_insert_bbt (&pi_root, p, compare_pointers); + + return p; +} + + +/* Given an integer during reading, find it in the pointer_info tree, + creating the node if not found. */ + +static pointer_info * +get_integer (HOST_WIDE_INT integer) +{ + pointer_info *p, t; + int c; + + t.integer = integer; + + p = pi_root; + while (p != NULL) + { + c = compare_integers (&t, p); + if (c == 0) + break; + + p = (c < 0) ? p->left : p->right; + } + + if (p != NULL) + return p; + + p = gfc_get_pointer_info (); + p->integer = integer; + p->u.pointer = NULL; + + gfc_insert_bbt (&pi_root, p, compare_integers); + + return p; +} + + +/* Resolve any fixups using a known pointer. */ + +static void +resolve_fixups (fixup_t *f, void *gp) +{ + fixup_t *next; + + for (; f; f = next) + { + next = f->next; + *(f->pointer) = gp; + free (f); + } +} + + +/* Convert a string such that it starts with a lower-case character. Used + to convert the symtree name of a derived-type to the symbol name or to + the name of the associated generic function. */ + +const char * +gfc_dt_lower_string (const char *name) +{ + if (name[0] != (char) TOLOWER ((unsigned char) name[0])) + return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]), + &name[1]); + return gfc_get_string ("%s", name); +} + + +/* Convert a string such that it starts with an upper-case character. Used to + return the symtree-name for a derived type; the symbol name itself and the + symtree/symbol name of the associated generic function start with a lower- + case character. */ + +const char * +gfc_dt_upper_string (const char *name) +{ + if (name[0] != (char) TOUPPER ((unsigned char) name[0])) + return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]), + &name[1]); + return gfc_get_string ("%s", name); +} + +/* Call here during module reading when we know what pointer to + associate with an integer. Any fixups that exist are resolved at + this time. */ + +static void +associate_integer_pointer (pointer_info *p, void *gp) +{ + if (p->u.pointer != NULL) + gfc_internal_error ("associate_integer_pointer(): Already associated"); + + p->u.pointer = gp; + + resolve_fixups (p->fixup, gp); + + p->fixup = NULL; +} + + +/* During module reading, given an integer and a pointer to a pointer, + either store the pointer from an already-known value or create a + fixup structure in order to store things later. Returns zero if + the reference has been actually stored, or nonzero if the reference + must be fixed later (i.e., associate_integer_pointer must be called + sometime later. Returns the pointer_info structure. */ + +static pointer_info * +add_fixup (HOST_WIDE_INT integer, void *gp) +{ + pointer_info *p; + fixup_t *f; + char **cp; + + p = get_integer (integer); + + if (p->integer == 0 || p->u.pointer != NULL) + { + cp = (char **) gp; + *cp = (char *) p->u.pointer; + } + else + { + f = XCNEW (fixup_t); + + f->next = p->fixup; + p->fixup = f; + + f->pointer = (void **) gp; + } + + return p; +} + + +/*****************************************************************/ + +/* Parser related subroutines */ + +/* Free the rename list left behind by a USE statement. */ + +static void +free_rename (gfc_use_rename *list) +{ + gfc_use_rename *next; + + for (; list; list = next) + { + next = list->next; + free (list); + } +} + + +/* Match a USE statement. */ + +match +gfc_match_use (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1]; + gfc_use_rename *tail = NULL, *new_use; + interface_type type, type2; + gfc_intrinsic_op op; + match m; + gfc_use_list *use_list; + gfc_symtree *st; + locus loc; + + use_list = gfc_get_use_list (); + + if (gfc_match (" , ") == MATCH_YES) + { + if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "module " + "nature in USE statement at %C")) + goto cleanup; + + if (strcmp (module_nature, "intrinsic") == 0) + use_list->intrinsic = true; + else + { + if (strcmp (module_nature, "non_intrinsic") == 0) + use_list->non_intrinsic = true; + else + { + gfc_error ("Module nature in USE statement at %C shall " + "be either INTRINSIC or NON_INTRINSIC"); + goto cleanup; + } + } + } + else + { + /* Help output a better error message than "Unclassifiable + statement". */ + gfc_match (" %n", module_nature); + if (strcmp (module_nature, "intrinsic") == 0 + || strcmp (module_nature, "non_intrinsic") == 0) + gfc_error ("\"::\" was expected after module nature at %C " + "but was not found"); + free (use_list); + return m; + } + } + else + { + m = gfc_match (" ::"); + if (m == MATCH_YES && + !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C")) + goto cleanup; + + if (m != MATCH_YES) + { + m = gfc_match ("% "); + if (m != MATCH_YES) + { + free (use_list); + return m; + } + } + } + + use_list->where = gfc_current_locus; + + m = gfc_match_name (name); + if (m != MATCH_YES) + { + free (use_list); + return m; + } + + use_list->module_name = gfc_get_string ("%s", name); + + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + if (gfc_match (" only :") == MATCH_YES) + use_list->only_flag = true; + + if (gfc_match_eos () == MATCH_YES) + goto done; + + for (;;) + { + /* Get a new rename struct and add it to the rename list. */ + new_use = gfc_get_use_rename (); + new_use->where = gfc_current_locus; + new_use->found = 0; + + if (use_list->rename == NULL) + use_list->rename = new_use; + else + tail->next = new_use; + tail = new_use; + + /* See what kind of interface we're dealing with. Assume it is + not an operator. */ + new_use->op = INTRINSIC_NONE; + if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) + goto cleanup; + + switch (type) + { + case INTERFACE_NAMELESS: + gfc_error ("Missing generic specification in USE statement at %C"); + goto cleanup; + + case INTERFACE_USER_OP: + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + loc = gfc_current_locus; + + m = gfc_match (" =>"); + + if (type == INTERFACE_USER_OP && m == MATCH_YES + && (!gfc_notify_std(GFC_STD_F2003, "Renaming " + "operators in USE statements at %C"))) + goto cleanup; + + if (type == INTERFACE_USER_OP) + new_use->op = INTRINSIC_USER; + + if (use_list->only_flag) + { + if (m != MATCH_YES) + strcpy (new_use->use_name, name); + else + { + strcpy (new_use->local_name, name); + m = gfc_match_generic_spec (&type2, new_use->use_name, &op); + if (type != type2) + goto syntax; + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + } + else + { + if (m != MATCH_YES) + goto syntax; + strcpy (new_use->local_name, name); + + m = gfc_match_generic_spec (&type2, new_use->use_name, &op); + if (type != type2) + goto syntax; + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (st && type != INTERFACE_USER_OP + && (st->n.sym->module != use_list->module_name + || strcmp (st->n.sym->name, new_use->use_name) != 0)) + { + if (m == MATCH_YES) + gfc_error ("Symbol %qs at %L conflicts with the rename symbol " + "at %L", name, &st->n.sym->declared_at, &loc); + else + gfc_error ("Symbol %qs at %L conflicts with the symbol " + "at %L", name, &st->n.sym->declared_at, &loc); + goto cleanup; + } + + if (strcmp (new_use->use_name, use_list->module_name) == 0 + || strcmp (new_use->local_name, use_list->module_name) == 0) + { + gfc_error ("The name %qs at %C has already been used as " + "an external module name", use_list->module_name); + goto cleanup; + } + break; + + case INTERFACE_INTRINSIC_OP: + new_use->op = op; + break; + + default: + gcc_unreachable (); + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + +done: + if (module_list) + { + gfc_use_list *last = module_list; + while (last->next) + last = last->next; + last->next = use_list; + } + else + module_list = use_list; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_USE); + +cleanup: + free_rename (use_list->rename); + free (use_list); + return MATCH_ERROR; +} + + +/* Match a SUBMODULE statement. + + According to F2008:11.2.3.2, "The submodule identifier is the + ordered pair whose first element is the ancestor module name and + whose second element is the submodule name. 'Submodule_name' is + used for the submodule filename and uses '@' as a separator, whilst + the name of the symbol for the module uses '.' as a separator. + The reasons for these choices are: + (i) To follow another leading brand in the submodule filenames; + (ii) Since '.' is not particularly visible in the filenames; and + (iii) The linker does not permit '@' in mnemonics. */ + +match +gfc_match_submodule (void) +{ + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_use_list *use_list; + bool seen_colon = false; + + if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C")) + return MATCH_ERROR; + + if (gfc_current_state () != COMP_NONE) + { + gfc_error ("SUBMODULE declaration at %C cannot appear within " + "another scoping unit"); + return MATCH_ERROR; + } + + gfc_new_block = NULL; + gcc_assert (module_list == NULL); + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + while (1) + { + m = gfc_match (" %n", name); + if (m != MATCH_YES) + goto syntax; + + use_list = gfc_get_use_list (); + use_list->where = gfc_current_locus; + + if (module_list) + { + gfc_use_list *last = module_list; + while (last->next) + last = last->next; + last->next = use_list; + use_list->module_name + = gfc_get_string ("%s.%s", module_list->module_name, name); + use_list->submodule_name + = gfc_get_string ("%s@%s", module_list->module_name, name); + } + else + { + module_list = use_list; + use_list->module_name = gfc_get_string ("%s", name); + use_list->submodule_name = use_list->module_name; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + + if (gfc_match_char (':') != MATCH_YES + || seen_colon) + goto syntax; + + seen_colon = true; + } + + m = gfc_match (" %s%t", &gfc_new_block); + if (m != MATCH_YES) + goto syntax; + + submodule_name = gfc_get_string ("%s@%s", module_list->module_name, + gfc_new_block->name); + + gfc_new_block->name = gfc_get_string ("%s.%s", + module_list->module_name, + gfc_new_block->name); + + if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, + gfc_new_block->name, NULL)) + return MATCH_ERROR; + + /* Just retain the ultimate .(s)mod file for reading, since it + contains all the information in its ancestors. */ + use_list = module_list; + for (; module_list->next; use_list = module_list) + { + module_list = use_list->next; + free (use_list); + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in SUBMODULE statement at %C"); + return MATCH_ERROR; +} + + +/* Given a name and a number, inst, return the inst name + under which to load this symbol. Returns NULL if this + symbol shouldn't be loaded. If inst is zero, returns + the number of instances of this name. If interface is + true, a user-defined operator is sought, otherwise only + non-operators are sought. */ + +static const char * +find_use_name_n (const char *name, int *inst, bool interface) +{ + gfc_use_rename *u; + const char *low_name = NULL; + int i; + + /* For derived types. */ + if (name[0] != (char) TOLOWER ((unsigned char) name[0])) + low_name = gfc_dt_lower_string (name); + + i = 0; + for (u = gfc_rename_list; u; u = u->next) + { + if ((!low_name && strcmp (u->use_name, name) != 0) + || (low_name && strcmp (u->use_name, low_name) != 0) + || (u->op == INTRINSIC_USER && !interface) + || (u->op != INTRINSIC_USER && interface)) + continue; + if (++i == *inst) + break; + } + + if (!*inst) + { + *inst = i; + return NULL; + } + + if (u == NULL) + return only_flag ? NULL : name; + + u->found = 1; + + if (low_name) + { + if (u->local_name[0] == '\0') + return name; + return gfc_dt_upper_string (u->local_name); + } + + return (u->local_name[0] != '\0') ? u->local_name : name; +} + + +/* Given a name, return the name under which to load this symbol. + Returns NULL if this symbol shouldn't be loaded. */ + +static const char * +find_use_name (const char *name, bool interface) +{ + int i = 1; + return find_use_name_n (name, &i, interface); +} + + +/* Given a real name, return the number of use names associated with it. */ + +static int +number_use_names (const char *name, bool interface) +{ + int i = 0; + find_use_name_n (name, &i, interface); + return i; +} + + +/* Try to find the operator in the current list. */ + +static gfc_use_rename * +find_use_operator (gfc_intrinsic_op op) +{ + gfc_use_rename *u; + + for (u = gfc_rename_list; u; u = u->next) + if (u->op == op) + return u; + + return NULL; +} + + +/*****************************************************************/ + +/* The next couple of subroutines maintain a tree used to avoid a + brute-force search for a combination of true name and module name. + While symtree names, the name that a particular symbol is known by + can changed with USE statements, we still have to keep track of the + true names to generate the correct reference, and also avoid + loading the same real symbol twice in a program unit. + + When we start reading, the true name tree is built and maintained + as symbols are read. The tree is searched as we load new symbols + to see if it already exists someplace in the namespace. */ + +typedef struct true_name +{ + BBT_HEADER (true_name); + const char *name; + gfc_symbol *sym; +} +true_name; + +static true_name *true_name_root; + + +/* Compare two true_name structures. */ + +static int +compare_true_names (void *_t1, void *_t2) +{ + true_name *t1, *t2; + int c; + + t1 = (true_name *) _t1; + t2 = (true_name *) _t2; + + c = ((t1->sym->module > t2->sym->module) + - (t1->sym->module < t2->sym->module)); + if (c != 0) + return c; + + return strcmp (t1->name, t2->name); +} + + +/* Given a true name, search the true name tree to see if it exists + within the main namespace. */ + +static gfc_symbol * +find_true_name (const char *name, const char *module) +{ + true_name t, *p; + gfc_symbol sym; + int c; + + t.name = gfc_get_string ("%s", name); + if (module != NULL) + sym.module = gfc_get_string ("%s", module); + else + sym.module = NULL; + t.sym = &sym; + + p = true_name_root; + while (p != NULL) + { + c = compare_true_names ((void *) (&t), (void *) p); + if (c == 0) + return p->sym; + + p = (c < 0) ? p->left : p->right; + } + + return NULL; +} + + +/* Given a gfc_symbol pointer that is not in the true name tree, add it. */ + +static void +add_true_name (gfc_symbol *sym) +{ + true_name *t; + + t = XCNEW (true_name); + t->sym = sym; + if (gfc_fl_struct (sym->attr.flavor)) + t->name = gfc_dt_upper_string (sym->name); + else + t->name = sym->name; + + gfc_insert_bbt (&true_name_root, t, compare_true_names); +} + + +/* Recursive function to build the initial true name tree by + recursively traversing the current namespace. */ + +static void +build_tnt (gfc_symtree *st) +{ + const char *name; + if (st == NULL) + return; + + build_tnt (st->left); + build_tnt (st->right); + + if (gfc_fl_struct (st->n.sym->attr.flavor)) + name = gfc_dt_upper_string (st->n.sym->name); + else + name = st->n.sym->name; + + if (find_true_name (name, st->n.sym->module) != NULL) + return; + + add_true_name (st->n.sym); +} + + +/* Initialize the true name tree with the current namespace. */ + +static void +init_true_name_tree (void) +{ + true_name_root = NULL; + build_tnt (gfc_current_ns->sym_root); +} + + +/* Recursively free a true name tree node. */ + +static void +free_true_name (true_name *t) +{ + if (t == NULL) + return; + free_true_name (t->left); + free_true_name (t->right); + + free (t); +} + + +/*****************************************************************/ + +/* Module reading and writing. */ + +/* The following are versions similar to the ones in scanner.c, but + for dealing with compressed module files. */ + +static gzFile +gzopen_included_file_1 (const char *name, gfc_directorylist *list, + bool module, bool system) +{ + char *fullname; + gfc_directorylist *p; + gzFile f; + + for (p = list; p; p = p->next) + { + if (module && !p->use_for_modules) + continue; + + fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); + strcpy (fullname, p->path); + strcat (fullname, name); + + f = gzopen (fullname, "r"); + if (f != NULL) + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (fullname, system); + + free (module_fullpath); + module_fullpath = xstrdup (fullname); + return f; + } + } + + return NULL; +} + +static gzFile +gzopen_included_file (const char *name, bool include_cwd, bool module) +{ + gzFile f = NULL; + + if (IS_ABSOLUTE_PATH (name) || include_cwd) + { + f = gzopen (name, "r"); + if (f) + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, false); + + free (module_fullpath); + module_fullpath = xstrdup (name); + } + } + + if (!f) + f = gzopen_included_file_1 (name, include_dirs, module, false); + + return f; +} + +static gzFile +gzopen_intrinsic_module (const char* name) +{ + gzFile f = NULL; + + if (IS_ABSOLUTE_PATH (name)) + { + f = gzopen (name, "r"); + if (f) + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, true); + + free (module_fullpath); + module_fullpath = xstrdup (name); + } + } + + if (!f) + f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true); + + return f; +} + + +enum atom_type +{ + ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING +}; + +static atom_type last_atom; + + +/* The name buffer must be at least as long as a symbol name. Right + now it's not clear how we're going to store numeric constants-- + probably as a hexadecimal string, since this will allow the exact + number to be preserved (this can't be done by a decimal + representation). Worry about that later. TODO! */ + +#define MAX_ATOM_SIZE 100 + +static HOST_WIDE_INT atom_int; +static char *atom_string, atom_name[MAX_ATOM_SIZE]; + + +/* Report problems with a module. Error reporting is not very + elaborate, since this sorts of errors shouldn't really happen. + This subroutine never returns. */ + +static void bad_module (const char *) ATTRIBUTE_NORETURN; + +static void +bad_module (const char *msgid) +{ + XDELETEVEC (module_content); + module_content = NULL; + + switch (iomode) + { + case IO_INPUT: + gfc_fatal_error ("Reading module %qs at line %d column %d: %s", + module_fullpath, module_line, module_column, msgid); + break; + case IO_OUTPUT: + gfc_fatal_error ("Writing module %qs at line %d column %d: %s", + module_name, module_line, module_column, msgid); + break; + default: + gfc_fatal_error ("Module %qs at line %d column %d: %s", + module_name, module_line, module_column, msgid); + break; + } +} + + +/* Set the module's input pointer. */ + +static void +set_module_locus (module_locus *m) +{ + module_column = m->column; + module_line = m->line; + module_pos = m->pos; +} + + +/* Get the module's input pointer so that we can restore it later. */ + +static void +get_module_locus (module_locus *m) +{ + m->column = module_column; + m->line = module_line; + m->pos = module_pos; +} + +/* Peek at the next character in the module. */ + +static int +module_peek_char (void) +{ + return module_content[module_pos]; +} + +/* Get the next character in the module, updating our reckoning of + where we are. */ + +static int +module_char (void) +{ + const char c = module_content[module_pos++]; + if (c == '\0') + bad_module ("Unexpected EOF"); + + prev_module_line = module_line; + prev_module_column = module_column; + + if (c == '\n') + { + module_line++; + module_column = 0; + } + + module_column++; + return c; +} + +/* Unget a character while remembering the line and column. Works for + a single character only. */ + +static void +module_unget_char (void) +{ + module_line = prev_module_line; + module_column = prev_module_column; + module_pos--; +} + +/* Parse a string constant. The delimiter is guaranteed to be a + single quote. */ + +static void +parse_string (void) +{ + int c; + size_t cursz = 30; + size_t len = 0; + + atom_string = XNEWVEC (char, cursz); + + for ( ; ; ) + { + c = module_char (); + + if (c == '\'') + { + int c2 = module_char (); + if (c2 != '\'') + { + module_unget_char (); + break; + } + } + + if (len >= cursz) + { + cursz *= 2; + atom_string = XRESIZEVEC (char, atom_string, cursz); + } + atom_string[len] = c; + len++; + } + + atom_string = XRESIZEVEC (char, atom_string, len + 1); + atom_string[len] = '\0'; /* C-style string for debug purposes. */ +} + + +/* Parse an integer. Should fit in a HOST_WIDE_INT. */ + +static void +parse_integer (int c) +{ + int sign = 1; + + atom_int = 0; + switch (c) + { + case ('-'): + sign = -1; + case ('+'): + break; + default: + atom_int = c - '0'; + break; + } + + for (;;) + { + c = module_char (); + if (!ISDIGIT (c)) + { + module_unget_char (); + break; + } + + atom_int = 10 * atom_int + c - '0'; + } + + atom_int *= sign; +} + + +/* Parse a name. */ + +static void +parse_name (int c) +{ + char *p; + int len; + + p = atom_name; + + *p++ = c; + len = 1; + + for (;;) + { + c = module_char (); + if (!ISALNUM (c) && c != '_' && c != '-') + { + module_unget_char (); + break; + } + + *p++ = c; + if (++len > GFC_MAX_SYMBOL_LEN) + bad_module ("Name too long"); + } + + *p = '\0'; + +} + + +/* Read the next atom in the module's input stream. */ + +static atom_type +parse_atom (void) +{ + int c; + + do + { + c = module_char (); + } + while (c == ' ' || c == '\r' || c == '\n'); + + switch (c) + { + case '(': + return ATOM_LPAREN; + + case ')': + return ATOM_RPAREN; + + case '\'': + parse_string (); + return ATOM_STRING; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + parse_integer (c); + return ATOM_INTEGER; + + case '+': + case '-': + if (ISDIGIT (module_peek_char ())) + { + parse_integer (c); + return ATOM_INTEGER; + } + else + bad_module ("Bad name"); + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + parse_name (c); + return ATOM_NAME; + + default: + bad_module ("Bad name"); + } + + /* Not reached. */ +} + + +/* Peek at the next atom on the input. */ + +static atom_type +peek_atom (void) +{ + int c; + + do + { + c = module_char (); + } + while (c == ' ' || c == '\r' || c == '\n'); + + switch (c) + { + case '(': + module_unget_char (); + return ATOM_LPAREN; + + case ')': + module_unget_char (); + return ATOM_RPAREN; + + case '\'': + module_unget_char (); + return ATOM_STRING; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + module_unget_char (); + return ATOM_INTEGER; + + case '+': + case '-': + if (ISDIGIT (module_peek_char ())) + { + module_unget_char (); + return ATOM_INTEGER; + } + else + bad_module ("Bad name"); + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + module_unget_char (); + return ATOM_NAME; + + default: + bad_module ("Bad name"); + } +} + + +/* Read the next atom from the input, requiring that it be a + particular kind. */ + +static void +require_atom (atom_type type) +{ + atom_type t; + const char *p; + int column, line; + + column = module_column; + line = module_line; + + t = parse_atom (); + if (t != type) + { + switch (type) + { + case ATOM_NAME: + p = _("Expected name"); + break; + case ATOM_LPAREN: + p = _("Expected left parenthesis"); + break; + case ATOM_RPAREN: + p = _("Expected right parenthesis"); + break; + case ATOM_INTEGER: + p = _("Expected integer"); + break; + case ATOM_STRING: + p = _("Expected string"); + break; + default: + gfc_internal_error ("require_atom(): bad atom type required"); + } + + module_column = column; + module_line = line; + bad_module (p); + } +} + + +/* Given a pointer to an mstring array, require that the current input + be one of the strings in the array. We return the enum value. */ + +static int +find_enum (const mstring *m) +{ + int i; + + i = gfc_string2code (m, atom_name); + if (i >= 0) + return i; + + bad_module ("find_enum(): Enum not found"); + + /* Not reached. */ +} + + +/* Read a string. The caller is responsible for freeing. */ + +static char* +read_string (void) +{ + char* p; + require_atom (ATOM_STRING); + p = atom_string; + atom_string = NULL; + return p; +} + + +/**************** Module output subroutines ***************************/ + +/* Output a character to a module file. */ + +static void +write_char (char out) +{ + if (gzputc (module_fp, out) == EOF) + gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno)); + + if (out != '\n') + module_column++; + else + { + module_column = 1; + module_line++; + } +} + + +/* Write an atom to a module. The line wrapping isn't perfect, but it + should work most of the time. This isn't that big of a deal, since + the file really isn't meant to be read by people anyway. */ + +static void +write_atom (atom_type atom, const void *v) +{ + char buffer[32]; + + /* Workaround -Wmaybe-uninitialized false positive during + profiledbootstrap by initializing them. */ + int len; + HOST_WIDE_INT i = 0; + const char *p; + + switch (atom) + { + case ATOM_STRING: + case ATOM_NAME: + p = (const char *) v; + break; + + case ATOM_LPAREN: + p = "("; + break; + + case ATOM_RPAREN: + p = ")"; + break; + + case ATOM_INTEGER: + i = *((const HOST_WIDE_INT *) v); + + snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i); + p = buffer; + break; + + default: + gfc_internal_error ("write_atom(): Trying to write dab atom"); + + } + + if(p == NULL || *p == '\0') + len = 0; + else + len = strlen (p); + + if (atom != ATOM_RPAREN) + { + if (module_column + len > 72) + write_char ('\n'); + else + { + + if (last_atom != ATOM_LPAREN && module_column != 1) + write_char (' '); + } + } + + if (atom == ATOM_STRING) + write_char ('\''); + + while (p != NULL && *p) + { + if (atom == ATOM_STRING && *p == '\'') + write_char ('\''); + write_char (*p++); + } + + if (atom == ATOM_STRING) + write_char ('\''); + + last_atom = atom; +} + + + +/***************** Mid-level I/O subroutines *****************/ + +/* These subroutines let their caller read or write atoms without + caring about which of the two is actually happening. This lets a + subroutine concentrate on the actual format of the data being + written. */ + +static void mio_expr (gfc_expr **); +pointer_info *mio_symbol_ref (gfc_symbol **); +pointer_info *mio_interface_rest (gfc_interface **); +static void mio_symtree_ref (gfc_symtree **); + +/* Read or write an enumerated value. On writing, we return the input + value for the convenience of callers. We avoid using an integer + pointer because enums are sometimes inside bitfields. */ + +static int +mio_name (int t, const mstring *m) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_NAME, gfc_code2string (m, t)); + else + { + require_atom (ATOM_NAME); + t = find_enum (m); + } + + return t; +} + +/* Specialization of mio_name. */ + +#define DECL_MIO_NAME(TYPE) \ + static inline TYPE \ + MIO_NAME(TYPE) (TYPE t, const mstring *m) \ + { \ + return (TYPE) mio_name ((int) t, m); \ + } +#define MIO_NAME(TYPE) mio_name_##TYPE + +static void +mio_lparen (void) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_LPAREN, NULL); + else + require_atom (ATOM_LPAREN); +} + + +static void +mio_rparen (void) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_RPAREN, NULL); + else + require_atom (ATOM_RPAREN); +} + + +static void +mio_integer (int *ip) +{ + if (iomode == IO_OUTPUT) + { + HOST_WIDE_INT hwi = *ip; + write_atom (ATOM_INTEGER, &hwi); + } + else + { + require_atom (ATOM_INTEGER); + *ip = atom_int; + } +} + +static void +mio_hwi (HOST_WIDE_INT *hwi) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_INTEGER, hwi); + else + { + require_atom (ATOM_INTEGER); + *hwi = atom_int; + } +} + + +/* Read or write a gfc_intrinsic_op value. */ + +static void +mio_intrinsic_op (gfc_intrinsic_op* op) +{ + /* FIXME: Would be nicer to do this via the operators symbolic name. */ + if (iomode == IO_OUTPUT) + { + HOST_WIDE_INT converted = (HOST_WIDE_INT) *op; + write_atom (ATOM_INTEGER, &converted); + } + else + { + require_atom (ATOM_INTEGER); + *op = (gfc_intrinsic_op) atom_int; + } +} + + +/* Read or write a character pointer that points to a string on the heap. */ + +static const char * +mio_allocated_string (const char *s) +{ + if (iomode == IO_OUTPUT) + { + write_atom (ATOM_STRING, s); + return s; + } + else + { + require_atom (ATOM_STRING); + return atom_string; + } +} + + +/* Functions for quoting and unquoting strings. */ + +static char * +quote_string (const gfc_char_t *s, const size_t slength) +{ + const gfc_char_t *p; + char *res, *q; + size_t len = 0, i; + + /* Calculate the length we'll need: a backslash takes two ("\\"), + non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */ + for (p = s, i = 0; i < slength; p++, i++) + { + if (*p == '\\') + len += 2; + else if (!gfc_wide_is_printable (*p)) + len += 10; + else + len++; + } + + q = res = XCNEWVEC (char, len + 1); + for (p = s, i = 0; i < slength; p++, i++) + { + if (*p == '\\') + *q++ = '\\', *q++ = '\\'; + else if (!gfc_wide_is_printable (*p)) + { + sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x", + (unsigned HOST_WIDE_INT) *p); + q += 10; + } + else + *q++ = (unsigned char) *p; + } + + res[len] = '\0'; + return res; +} + +static gfc_char_t * +unquote_string (const char *s) +{ + size_t len, i; + const char *p; + gfc_char_t *res; + + for (p = s, len = 0; *p; p++, len++) + { + if (*p != '\\') + continue; + + if (p[1] == '\\') + p++; + else if (p[1] == 'U') + p += 9; /* That is a "\U????????". */ + else + gfc_internal_error ("unquote_string(): got bad string"); + } + + res = gfc_get_wide_string (len + 1); + for (i = 0, p = s; i < len; i++, p++) + { + gcc_assert (*p); + + if (*p != '\\') + res[i] = (unsigned char) *p; + else if (p[1] == '\\') + { + res[i] = (unsigned char) '\\'; + p++; + } + else + { + /* We read the 8-digits hexadecimal constant that follows. */ + int j; + unsigned n; + gfc_char_t c = 0; + + gcc_assert (p[1] == 'U'); + for (j = 0; j < 8; j++) + { + c = c << 4; + gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1); + c += n; + } + + res[i] = c; + p += 9; + } + } + + res[len] = '\0'; + return res; +} + + +/* Read or write a character pointer that points to a wide string on the + heap, performing quoting/unquoting of nonprintable characters using the + form \U???????? (where each ? is a hexadecimal digit). + Length is the length of the string, only known and used in output mode. */ + +static const gfc_char_t * +mio_allocated_wide_string (const gfc_char_t *s, const size_t length) +{ + if (iomode == IO_OUTPUT) + { + char *quoted = quote_string (s, length); + write_atom (ATOM_STRING, quoted); + free (quoted); + return s; + } + else + { + gfc_char_t *unquoted; + + require_atom (ATOM_STRING); + unquoted = unquote_string (atom_string); + free (atom_string); + return unquoted; + } +} + + +/* Read or write a string that is in static memory. */ + +static void +mio_pool_string (const char **stringp) +{ + /* TODO: one could write the string only once, and refer to it via a + fixup pointer. */ + + /* As a special case we have to deal with a NULL string. This + happens for the 'module' member of 'gfc_symbol's that are not in a + module. We read / write these as the empty string. */ + if (iomode == IO_OUTPUT) + { + const char *p = *stringp == NULL ? "" : *stringp; + write_atom (ATOM_STRING, p); + } + else + { + require_atom (ATOM_STRING); + *stringp = (atom_string[0] == '\0' + ? NULL : gfc_get_string ("%s", atom_string)); + free (atom_string); + } +} + + +/* Read or write a string that is inside of some already-allocated + structure. */ + +static void +mio_internal_string (char *string) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_STRING, string); + else + { + require_atom (ATOM_STRING); + strcpy (string, atom_string); + free (atom_string); + } +} + + +enum ab_attribute +{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL, + AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA, + AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, + AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, + AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, + AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP, + AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP, + AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, + AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, + AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, + AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, + AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, + AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, + AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, + AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, + AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, + AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, + AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, + AB_OACC_ROUTINE_NOHOST, + AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS, + AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS, + AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, + AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST, + AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY +}; + +static const mstring attr_bits[] = +{ + minit ("ALLOCATABLE", AB_ALLOCATABLE), + minit ("ARTIFICIAL", AB_ARTIFICIAL), + minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), + minit ("DIMENSION", AB_DIMENSION), + minit ("CODIMENSION", AB_CODIMENSION), + minit ("CONTIGUOUS", AB_CONTIGUOUS), + minit ("EXTERNAL", AB_EXTERNAL), + minit ("INTRINSIC", AB_INTRINSIC), + minit ("OPTIONAL", AB_OPTIONAL), + minit ("POINTER", AB_POINTER), + minit ("VOLATILE", AB_VOLATILE), + minit ("TARGET", AB_TARGET), + minit ("THREADPRIVATE", AB_THREADPRIVATE), + minit ("DUMMY", AB_DUMMY), + minit ("RESULT", AB_RESULT), + minit ("DATA", AB_DATA), + minit ("IN_NAMELIST", AB_IN_NAMELIST), + minit ("IN_COMMON", AB_IN_COMMON), + minit ("FUNCTION", AB_FUNCTION), + minit ("SUBROUTINE", AB_SUBROUTINE), + minit ("SEQUENCE", AB_SEQUENCE), + minit ("ELEMENTAL", AB_ELEMENTAL), + minit ("PURE", AB_PURE), + minit ("RECURSIVE", AB_RECURSIVE), + minit ("GENERIC", AB_GENERIC), + minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), + minit ("CRAY_POINTER", AB_CRAY_POINTER), + minit ("CRAY_POINTEE", AB_CRAY_POINTEE), + minit ("IS_BIND_C", AB_IS_BIND_C), + minit ("IS_C_INTEROP", AB_IS_C_INTEROP), + minit ("IS_ISO_C", AB_IS_ISO_C), + minit ("VALUE", AB_VALUE), + minit ("ALLOC_COMP", AB_ALLOC_COMP), + minit ("COARRAY_COMP", AB_COARRAY_COMP), + minit ("LOCK_COMP", AB_LOCK_COMP), + minit ("EVENT_COMP", AB_EVENT_COMP), + minit ("POINTER_COMP", AB_POINTER_COMP), + minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP), + minit ("PRIVATE_COMP", AB_PRIVATE_COMP), + minit ("ZERO_COMP", AB_ZERO_COMP), + minit ("PROTECTED", AB_PROTECTED), + minit ("ABSTRACT", AB_ABSTRACT), + minit ("IS_CLASS", AB_IS_CLASS), + minit ("PROCEDURE", AB_PROCEDURE), + minit ("PROC_POINTER", AB_PROC_POINTER), + minit ("VTYPE", AB_VTYPE), + minit ("VTAB", AB_VTAB), + minit ("CLASS_POINTER", AB_CLASS_POINTER), + minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), + minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), + minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET), + minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY), + minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE), + minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE), + minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN), + minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR), + minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), + minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), + minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), + minit ("PDT_KIND", AB_PDT_KIND), + minit ("PDT_LEN", AB_PDT_LEN), + minit ("PDT_TYPE", AB_PDT_TYPE), + minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE), + minit ("PDT_ARRAY", AB_PDT_ARRAY), + minit ("PDT_STRING", AB_PDT_STRING), + minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG), + minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), + minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), + minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ), + minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST), + minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD), + minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS), + minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY), + minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS), + minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST), + minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL), + minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED), + minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST), + minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST), + minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY), + minit (NULL, -1) +}; + +/* For binding attributes. */ +static const mstring binding_passing[] = +{ + minit ("PASS", 0), + minit ("NOPASS", 1), + minit (NULL, -1) +}; +static const mstring binding_overriding[] = +{ + minit ("OVERRIDABLE", 0), + minit ("NON_OVERRIDABLE", 1), + minit ("DEFERRED", 2), + minit (NULL, -1) +}; +static const mstring binding_generic[] = +{ + minit ("SPECIFIC", 0), + minit ("GENERIC", 1), + minit (NULL, -1) +}; +static const mstring binding_ppc[] = +{ + minit ("NO_PPC", 0), + minit ("PPC", 1), + minit (NULL, -1) +}; + +/* Specialization of mio_name. */ +DECL_MIO_NAME (ab_attribute) +DECL_MIO_NAME (ar_type) +DECL_MIO_NAME (array_type) +DECL_MIO_NAME (bt) +DECL_MIO_NAME (expr_t) +DECL_MIO_NAME (gfc_access) +DECL_MIO_NAME (gfc_intrinsic_op) +DECL_MIO_NAME (ifsrc) +DECL_MIO_NAME (save_state) +DECL_MIO_NAME (procedure_type) +DECL_MIO_NAME (ref_type) +DECL_MIO_NAME (sym_flavor) +DECL_MIO_NAME (sym_intent) +DECL_MIO_NAME (inquiry_type) +#undef DECL_MIO_NAME + +/* Verify OACC_ROUTINE_LOP_NONE. */ + +static void +verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop) +{ + if (lop != OACC_ROUTINE_LOP_NONE) + bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism"); +} + +/* Symbol attributes are stored in list with the first three elements + being the enumerated fields, while the remaining elements (if any) + indicate the individual attribute bits. The access field is not + saved-- it controls what symbols are exported when a module is + written. */ + +static void +mio_symbol_attribute (symbol_attribute *attr) +{ + atom_type t; + unsigned ext_attr,extension_level; + + mio_lparen (); + + attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors); + attr->intent = MIO_NAME (sym_intent) (attr->intent, intents); + attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures); + attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types); + attr->save = MIO_NAME (save_state) (attr->save, save_status); + + ext_attr = attr->ext_attr; + mio_integer ((int *) &ext_attr); + attr->ext_attr = ext_attr; + + extension_level = attr->extension; + mio_integer ((int *) &extension_level); + attr->extension = extension_level; + + if (iomode == IO_OUTPUT) + { + if (attr->allocatable) + MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits); + if (attr->artificial) + MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits); + if (attr->asynchronous) + MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits); + if (attr->dimension) + MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); + if (attr->codimension) + MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); + if (attr->contiguous) + MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits); + if (attr->external) + MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); + if (attr->intrinsic) + MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits); + if (attr->optional) + MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits); + if (attr->pointer) + MIO_NAME (ab_attribute) (AB_POINTER, attr_bits); + if (attr->class_pointer) + MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits); + if (attr->is_protected) + MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits); + if (attr->value) + MIO_NAME (ab_attribute) (AB_VALUE, attr_bits); + if (attr->volatile_) + MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits); + if (attr->target) + MIO_NAME (ab_attribute) (AB_TARGET, attr_bits); + if (attr->threadprivate) + MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits); + if (attr->dummy) + MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits); + if (attr->result) + MIO_NAME (ab_attribute) (AB_RESULT, attr_bits); + /* We deliberately don't preserve the "entry" flag. */ + + if (attr->data) + MIO_NAME (ab_attribute) (AB_DATA, attr_bits); + if (attr->in_namelist) + MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits); + if (attr->in_common) + MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits); + + if (attr->function) + MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits); + if (attr->subroutine) + MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits); + if (attr->generic) + MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits); + if (attr->abstract) + MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits); + + if (attr->sequence) + MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits); + if (attr->elemental) + MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits); + if (attr->pure) + MIO_NAME (ab_attribute) (AB_PURE, attr_bits); + if (attr->implicit_pure) + MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits); + if (attr->unlimited_polymorphic) + MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits); + if (attr->recursive) + MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits); + if (attr->always_explicit) + MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits); + if (attr->cray_pointer) + MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits); + if (attr->cray_pointee) + MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits); + if (attr->is_bind_c) + MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits); + if (attr->is_c_interop) + MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits); + if (attr->is_iso_c) + MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits); + if (attr->alloc_comp) + MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits); + if (attr->pointer_comp) + MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits); + if (attr->proc_pointer_comp) + MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits); + if (attr->private_comp) + MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); + if (attr->coarray_comp) + MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits); + if (attr->lock_comp) + MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits); + if (attr->event_comp) + MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits); + if (attr->zero_comp) + MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); + if (attr->is_class) + MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits); + if (attr->procedure) + MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits); + if (attr->proc_pointer) + MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits); + if (attr->vtype) + MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits); + if (attr->vtab) + MIO_NAME (ab_attribute) (AB_VTAB, attr_bits); + if (attr->omp_declare_target) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits); + if (attr->array_outer_dependency) + MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits); + if (attr->module_procedure) + MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits); + if (attr->oacc_declare_create) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits); + if (attr->oacc_declare_copyin) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits); + if (attr->oacc_declare_deviceptr) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits); + if (attr->oacc_declare_device_resident) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits); + if (attr->oacc_declare_link) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); + if (attr->omp_declare_target_link) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); + if (attr->pdt_kind) + MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); + if (attr->pdt_len) + MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits); + if (attr->pdt_type) + MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits); + if (attr->pdt_template) + MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits); + if (attr->pdt_array) + MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits); + if (attr->pdt_string) + MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits); + switch (attr->oacc_routine_lop) + { + case OACC_ROUTINE_LOP_NONE: + /* This is the default anyway, and for maintaining compatibility with + the current MOD_VERSION, we're not emitting anything in that + case. */ + break; + case OACC_ROUTINE_LOP_GANG: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits); + break; + case OACC_ROUTINE_LOP_WORKER: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits); + break; + case OACC_ROUTINE_LOP_VECTOR: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits); + break; + case OACC_ROUTINE_LOP_SEQ: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits); + break; + case OACC_ROUTINE_LOP_ERROR: + /* ... intentionally omitted here; it's only unsed internally. */ + default: + gcc_unreachable (); + } + if (attr->oacc_routine_nohost) + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_NOHOST, attr_bits); + + if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires) + { + if (gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD) + MIO_NAME (ab_attribute) (AB_OMP_REQ_REVERSE_OFFLOAD, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS) + MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_ADDRESS, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) + MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + MIO_NAME (ab_attribute) (AB_OMP_REQ_DYNAMIC_ALLOCATORS, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_SEQ_CST, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQ_REL, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits); + } + switch (attr->omp_device_type) + { + case OMP_DEVICE_TYPE_UNSET: + break; + case OMP_DEVICE_TYPE_HOST: + MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_HOST, attr_bits); + break; + case OMP_DEVICE_TYPE_NOHOST: + MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits); + break; + case OMP_DEVICE_TYPE_ANY: + MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits); + break; + default: + gcc_unreachable (); + } + mio_rparen (); + } + else + { + for (;;) + { + t = parse_atom (); + if (t == ATOM_RPAREN) + break; + if (t != ATOM_NAME) + bad_module ("Expected attribute bit name"); + + switch ((ab_attribute) find_enum (attr_bits)) + { + case AB_ALLOCATABLE: + attr->allocatable = 1; + break; + case AB_ARTIFICIAL: + attr->artificial = 1; + break; + case AB_ASYNCHRONOUS: + attr->asynchronous = 1; + break; + case AB_DIMENSION: + attr->dimension = 1; + break; + case AB_CODIMENSION: + attr->codimension = 1; + break; + case AB_CONTIGUOUS: + attr->contiguous = 1; + break; + case AB_EXTERNAL: + attr->external = 1; + break; + case AB_INTRINSIC: + attr->intrinsic = 1; + break; + case AB_OPTIONAL: + attr->optional = 1; + break; + case AB_POINTER: + attr->pointer = 1; + break; + case AB_CLASS_POINTER: + attr->class_pointer = 1; + break; + case AB_PROTECTED: + attr->is_protected = 1; + break; + case AB_VALUE: + attr->value = 1; + break; + case AB_VOLATILE: + attr->volatile_ = 1; + break; + case AB_TARGET: + attr->target = 1; + break; + case AB_THREADPRIVATE: + attr->threadprivate = 1; + break; + case AB_DUMMY: + attr->dummy = 1; + break; + case AB_RESULT: + attr->result = 1; + break; + case AB_DATA: + attr->data = 1; + break; + case AB_IN_NAMELIST: + attr->in_namelist = 1; + break; + case AB_IN_COMMON: + attr->in_common = 1; + break; + case AB_FUNCTION: + attr->function = 1; + break; + case AB_SUBROUTINE: + attr->subroutine = 1; + break; + case AB_GENERIC: + attr->generic = 1; + break; + case AB_ABSTRACT: + attr->abstract = 1; + break; + case AB_SEQUENCE: + attr->sequence = 1; + break; + case AB_ELEMENTAL: + attr->elemental = 1; + break; + case AB_PURE: + attr->pure = 1; + break; + case AB_IMPLICIT_PURE: + attr->implicit_pure = 1; + break; + case AB_UNLIMITED_POLY: + attr->unlimited_polymorphic = 1; + break; + case AB_RECURSIVE: + attr->recursive = 1; + break; + case AB_ALWAYS_EXPLICIT: + attr->always_explicit = 1; + break; + case AB_CRAY_POINTER: + attr->cray_pointer = 1; + break; + case AB_CRAY_POINTEE: + attr->cray_pointee = 1; + break; + case AB_IS_BIND_C: + attr->is_bind_c = 1; + break; + case AB_IS_C_INTEROP: + attr->is_c_interop = 1; + break; + case AB_IS_ISO_C: + attr->is_iso_c = 1; + break; + case AB_ALLOC_COMP: + attr->alloc_comp = 1; + break; + case AB_COARRAY_COMP: + attr->coarray_comp = 1; + break; + case AB_LOCK_COMP: + attr->lock_comp = 1; + break; + case AB_EVENT_COMP: + attr->event_comp = 1; + break; + case AB_POINTER_COMP: + attr->pointer_comp = 1; + break; + case AB_PROC_POINTER_COMP: + attr->proc_pointer_comp = 1; + break; + case AB_PRIVATE_COMP: + attr->private_comp = 1; + break; + case AB_ZERO_COMP: + attr->zero_comp = 1; + break; + case AB_IS_CLASS: + attr->is_class = 1; + break; + case AB_PROCEDURE: + attr->procedure = 1; + break; + case AB_PROC_POINTER: + attr->proc_pointer = 1; + break; + case AB_VTYPE: + attr->vtype = 1; + break; + case AB_VTAB: + attr->vtab = 1; + break; + case AB_OMP_DECLARE_TARGET: + attr->omp_declare_target = 1; + break; + case AB_OMP_DECLARE_TARGET_LINK: + attr->omp_declare_target_link = 1; + break; + case AB_ARRAY_OUTER_DEPENDENCY: + attr->array_outer_dependency =1; + break; + case AB_MODULE_PROCEDURE: + attr->module_procedure =1; + break; + case AB_OACC_DECLARE_CREATE: + attr->oacc_declare_create = 1; + break; + case AB_OACC_DECLARE_COPYIN: + attr->oacc_declare_copyin = 1; + break; + case AB_OACC_DECLARE_DEVICEPTR: + attr->oacc_declare_deviceptr = 1; + break; + case AB_OACC_DECLARE_DEVICE_RESIDENT: + attr->oacc_declare_device_resident = 1; + break; + case AB_OACC_DECLARE_LINK: + attr->oacc_declare_link = 1; + break; + case AB_PDT_KIND: + attr->pdt_kind = 1; + break; + case AB_PDT_LEN: + attr->pdt_len = 1; + break; + case AB_PDT_TYPE: + attr->pdt_type = 1; + break; + case AB_PDT_TEMPLATE: + attr->pdt_template = 1; + break; + case AB_PDT_ARRAY: + attr->pdt_array = 1; + break; + case AB_PDT_STRING: + attr->pdt_string = 1; + break; + case AB_OACC_ROUTINE_LOP_GANG: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG; + break; + case AB_OACC_ROUTINE_LOP_WORKER: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER; + break; + case AB_OACC_ROUTINE_LOP_VECTOR: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR; + break; + case AB_OACC_ROUTINE_LOP_SEQ: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ; + break; + case AB_OACC_ROUTINE_NOHOST: + attr->oacc_routine_nohost = 1; + break; + case AB_OMP_REQ_REVERSE_OFFLOAD: + gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD, + "reverse_offload", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_UNIFIED_ADDRESS: + gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS, + "unified_address", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_UNIFIED_SHARED_MEMORY: + gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY, + "unified_shared_memory", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_DYNAMIC_ALLOCATORS: + gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS, + "dynamic_allocators", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_SEQ_CST: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST, + "seq_cst", &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_ACQ_REL: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL, + "acq_rel", &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_RELAXED: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED, + "relaxed", &gfc_current_locus, + module_name); + break; + case AB_OMP_DEVICE_TYPE_HOST: + attr->omp_device_type = OMP_DEVICE_TYPE_HOST; + break; + case AB_OMP_DEVICE_TYPE_NOHOST: + attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST; + break; + case AB_OMP_DEVICE_TYPE_ANY: + attr->omp_device_type = OMP_DEVICE_TYPE_ANY; + break; + } + } + } +} + + +static const mstring bt_types[] = { + minit ("INTEGER", BT_INTEGER), + minit ("REAL", BT_REAL), + minit ("COMPLEX", BT_COMPLEX), + minit ("LOGICAL", BT_LOGICAL), + minit ("CHARACTER", BT_CHARACTER), + minit ("UNION", BT_UNION), + minit ("DERIVED", BT_DERIVED), + minit ("CLASS", BT_CLASS), + minit ("PROCEDURE", BT_PROCEDURE), + minit ("UNKNOWN", BT_UNKNOWN), + minit ("VOID", BT_VOID), + minit ("ASSUMED", BT_ASSUMED), + minit (NULL, -1) +}; + + +static void +mio_charlen (gfc_charlen **clp) +{ + gfc_charlen *cl; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + cl = *clp; + if (cl != NULL) + mio_expr (&cl->length); + } + else + { + if (peek_atom () != ATOM_RPAREN) + { + cl = gfc_new_charlen (gfc_current_ns, NULL); + mio_expr (&cl->length); + *clp = cl; + } + } + + mio_rparen (); +} + + +/* See if a name is a generated name. */ + +static int +check_unique_name (const char *name) +{ + return *name == '@'; +} + + +static void +mio_typespec (gfc_typespec *ts) +{ + mio_lparen (); + + ts->type = MIO_NAME (bt) (ts->type, bt_types); + + if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS) + mio_integer (&ts->kind); + else + mio_symbol_ref (&ts->u.derived); + + mio_symbol_ref (&ts->interface); + + /* Add info for C interop and is_iso_c. */ + mio_integer (&ts->is_c_interop); + mio_integer (&ts->is_iso_c); + + /* If the typespec is for an identifier either from iso_c_binding, or + a constant that was initialized to an identifier from it, use the + f90_type. Otherwise, use the ts->type, since it shouldn't matter. */ + if (ts->is_iso_c) + ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types); + else + ts->f90_type = MIO_NAME (bt) (ts->type, bt_types); + + if (ts->type != BT_CHARACTER) + { + /* ts->u.cl is only valid for BT_CHARACTER. */ + mio_lparen (); + mio_rparen (); + } + else + mio_charlen (&ts->u.cl); + + /* So as not to disturb the existing API, use an ATOM_NAME to + transmit deferred characteristic for characters (F2003). */ + if (iomode == IO_OUTPUT) + { + if (ts->type == BT_CHARACTER && ts->deferred) + write_atom (ATOM_NAME, "DEFERRED_CL"); + } + else if (peek_atom () != ATOM_RPAREN) + { + if (parse_atom () != ATOM_NAME) + bad_module ("Expected string"); + ts->deferred = 1; + } + + mio_rparen (); +} + + +static const mstring array_spec_types[] = { + minit ("EXPLICIT", AS_EXPLICIT), + minit ("ASSUMED_RANK", AS_ASSUMED_RANK), + minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE), + minit ("DEFERRED", AS_DEFERRED), + minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE), + minit (NULL, -1) +}; + + +static void +mio_array_spec (gfc_array_spec **asp) +{ + gfc_array_spec *as; + int i; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + int rank; + + if (*asp == NULL) + goto done; + as = *asp; + + /* mio_integer expects nonnegative values. */ + rank = as->rank > 0 ? as->rank : 0; + mio_integer (&rank); + } + else + { + if (peek_atom () == ATOM_RPAREN) + { + *asp = NULL; + goto done; + } + + *asp = as = gfc_get_array_spec (); + mio_integer (&as->rank); + } + + mio_integer (&as->corank); + as->type = MIO_NAME (array_type) (as->type, array_spec_types); + + if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK) + as->rank = -1; + if (iomode == IO_INPUT && as->corank) + as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT; + + if (as->rank + as->corank > 0) + for (i = 0; i < as->rank + as->corank; i++) + { + mio_expr (&as->lower[i]); + mio_expr (&as->upper[i]); + } + +done: + mio_rparen (); +} + + +/* Given a pointer to an array reference structure (which lives in a + gfc_ref structure), find the corresponding array specification + structure. Storing the pointer in the ref structure doesn't quite + work when loading from a module. Generating code for an array + reference also needs more information than just the array spec. */ + +static const mstring array_ref_types[] = { + minit ("FULL", AR_FULL), + minit ("ELEMENT", AR_ELEMENT), + minit ("SECTION", AR_SECTION), + minit (NULL, -1) +}; + + +static void +mio_array_ref (gfc_array_ref *ar) +{ + int i; + + mio_lparen (); + ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types); + mio_integer (&ar->dimen); + + switch (ar->type) + { + case AR_FULL: + break; + + case AR_ELEMENT: + for (i = 0; i < ar->dimen; i++) + mio_expr (&ar->start[i]); + + break; + + case AR_SECTION: + for (i = 0; i < ar->dimen; i++) + { + mio_expr (&ar->start[i]); + mio_expr (&ar->end[i]); + mio_expr (&ar->stride[i]); + } + + break; + + case AR_UNKNOWN: + gfc_internal_error ("mio_array_ref(): Unknown array ref"); + } + + /* Unfortunately, ar->dimen_type is an anonymous enumerated type so + we can't call mio_integer directly. Instead loop over each element + and cast it to/from an integer. */ + if (iomode == IO_OUTPUT) + { + for (i = 0; i < ar->dimen; i++) + { + HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i]; + write_atom (ATOM_INTEGER, &tmp); + } + } + else + { + for (i = 0; i < ar->dimen; i++) + { + require_atom (ATOM_INTEGER); + ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int; + } + } + + if (iomode == IO_INPUT) + { + ar->where = gfc_current_locus; + + for (i = 0; i < ar->dimen; i++) + ar->c_where[i] = gfc_current_locus; + } + + mio_rparen (); +} + + +/* Saves or restores a pointer. The pointer is converted back and + forth from an integer. We return the pointer_info pointer so that + the caller can take additional action based on the pointer type. */ + +static pointer_info * +mio_pointer_ref (void *gp) +{ + pointer_info *p; + + if (iomode == IO_OUTPUT) + { + p = get_pointer (*((char **) gp)); + HOST_WIDE_INT hwi = p->integer; + write_atom (ATOM_INTEGER, &hwi); + } + else + { + require_atom (ATOM_INTEGER); + p = add_fixup (atom_int, gp); + } + + return p; +} + + +/* Save and load references to components that occur within + expressions. We have to describe these references by a number and + by name. The number is necessary for forward references during + reading, and the name is necessary if the symbol already exists in + the namespace and is not loaded again. */ + +static void +mio_component_ref (gfc_component **cp) +{ + pointer_info *p; + + p = mio_pointer_ref (cp); + if (p->type == P_UNKNOWN) + p->type = P_COMPONENT; +} + + +static void mio_namespace_ref (gfc_namespace **nsp); +static void mio_formal_arglist (gfc_formal_arglist **formal); +static void mio_typebound_proc (gfc_typebound_proc** proc); +static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt); + +static void +mio_component (gfc_component *c, int vtype) +{ + pointer_info *p; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + p = get_pointer (c); + mio_hwi (&p->integer); + } + else + { + HOST_WIDE_INT n; + mio_hwi (&n); + p = get_integer (n); + associate_integer_pointer (p, c); + } + + if (p->type == P_UNKNOWN) + p->type = P_COMPONENT; + + mio_pool_string (&c->name); + mio_typespec (&c->ts); + mio_array_spec (&c->as); + + /* PDT templates store the expression for the kind of a component here. */ + mio_expr (&c->kind_expr); + + /* PDT types store the component specification list here. */ + mio_actual_arglist (&c->param_list, true); + + mio_symbol_attribute (&c->attr); + if (c->ts.type == BT_CLASS) + c->attr.class_ok = 1; + c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); + + if (!vtype || strcmp (c->name, "_final") == 0 + || strcmp (c->name, "_hash") == 0) + mio_expr (&c->initializer); + + if (c->attr.proc_pointer) + mio_typebound_proc (&c->tb); + + c->loc = gfc_current_locus; + + mio_rparen (); +} + + +static void +mio_component_list (gfc_component **cp, int vtype) +{ + gfc_component *c, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (c = *cp; c; c = c->next) + mio_component (c, vtype); + } + else + { + *cp = NULL; + tail = NULL; + + for (;;) + { + if (peek_atom () == ATOM_RPAREN) + break; + + c = gfc_get_component (); + mio_component (c, vtype); + + if (tail == NULL) + *cp = c; + else + tail->next = c; + + tail = c; + } + } + + mio_rparen (); +} + + +static void +mio_actual_arg (gfc_actual_arglist *a, bool pdt) +{ + mio_lparen (); + mio_pool_string (&a->name); + mio_expr (&a->expr); + if (pdt) + mio_integer ((int *)&a->spec_type); + mio_rparen (); +} + + +static void +mio_actual_arglist (gfc_actual_arglist **ap, bool pdt) +{ + gfc_actual_arglist *a, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (a = *ap; a; a = a->next) + mio_actual_arg (a, pdt); + + } + else + { + tail = NULL; + + for (;;) + { + if (peek_atom () != ATOM_LPAREN) + break; + + a = gfc_get_actual_arglist (); + + if (tail == NULL) + *ap = a; + else + tail->next = a; + + tail = a; + mio_actual_arg (a, pdt); + } + } + + mio_rparen (); +} + + +/* Read and write formal argument lists. */ + +static void +mio_formal_arglist (gfc_formal_arglist **formal) +{ + gfc_formal_arglist *f, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (f = *formal; f; f = f->next) + mio_symbol_ref (&f->sym); + } + else + { + *formal = tail = NULL; + + while (peek_atom () != ATOM_RPAREN) + { + f = gfc_get_formal_arglist (); + mio_symbol_ref (&f->sym); + + if (*formal == NULL) + *formal = f; + else + tail->next = f; + + tail = f; + } + } + + mio_rparen (); +} + + +/* Save or restore a reference to a symbol node. */ + +pointer_info * +mio_symbol_ref (gfc_symbol **symp) +{ + pointer_info *p; + + p = mio_pointer_ref (symp); + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (iomode == IO_OUTPUT) + { + if (p->u.wsym.state == UNREFERENCED) + p->u.wsym.state = NEEDS_WRITE; + } + else + { + if (p->u.rsym.state == UNUSED) + p->u.rsym.state = NEEDED; + } + return p; +} + + +/* Save or restore a reference to a symtree node. */ + +static void +mio_symtree_ref (gfc_symtree **stp) +{ + pointer_info *p; + fixup_t *f; + + if (iomode == IO_OUTPUT) + mio_symbol_ref (&(*stp)->n.sym); + else + { + require_atom (ATOM_INTEGER); + p = get_integer (atom_int); + + /* An unused equivalence member; make a symbol and a symtree + for it. */ + if (in_load_equiv && p->u.rsym.symtree == NULL) + { + /* Since this is not used, it must have a unique name. */ + p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns); + + /* Make the symbol. */ + if (p->u.rsym.sym == NULL) + { + p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name, + gfc_current_ns); + p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module); + } + + p->u.rsym.symtree->n.sym = p->u.rsym.sym; + p->u.rsym.symtree->n.sym->refs++; + p->u.rsym.referenced = 1; + + /* If the symbol is PRIVATE and in COMMON, load_commons will + generate a fixup symbol, which must be associated. */ + if (p->fixup) + resolve_fixups (p->fixup, p->u.rsym.sym); + p->fixup = NULL; + } + + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (p->u.rsym.state == UNUSED) + p->u.rsym.state = NEEDED; + + if (p->u.rsym.symtree != NULL) + { + *stp = p->u.rsym.symtree; + } + else + { + f = XCNEW (fixup_t); + + f->next = p->u.rsym.stfixup; + p->u.rsym.stfixup = f; + + f->pointer = (void **) stp; + } + } +} + + +static void +mio_iterator (gfc_iterator **ip) +{ + gfc_iterator *iter; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (*ip == NULL) + goto done; + } + else + { + if (peek_atom () == ATOM_RPAREN) + { + *ip = NULL; + goto done; + } + + *ip = gfc_get_iterator (); + } + + iter = *ip; + + mio_expr (&iter->var); + mio_expr (&iter->start); + mio_expr (&iter->end); + mio_expr (&iter->step); + +done: + mio_rparen (); +} + + +static void +mio_constructor (gfc_constructor_base *cp) +{ + gfc_constructor *c; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c)) + { + mio_lparen (); + mio_expr (&c->expr); + mio_iterator (&c->iterator); + mio_rparen (); + } + } + else + { + while (peek_atom () != ATOM_RPAREN) + { + c = gfc_constructor_append_expr (cp, NULL, NULL); + + mio_lparen (); + mio_expr (&c->expr); + mio_iterator (&c->iterator); + mio_rparen (); + } + } + + mio_rparen (); +} + + +static const mstring ref_types[] = { + minit ("ARRAY", REF_ARRAY), + minit ("COMPONENT", REF_COMPONENT), + minit ("SUBSTRING", REF_SUBSTRING), + minit ("INQUIRY", REF_INQUIRY), + minit (NULL, -1) +}; + +static const mstring inquiry_types[] = { + minit ("RE", INQUIRY_RE), + minit ("IM", INQUIRY_IM), + minit ("KIND", INQUIRY_KIND), + minit ("LEN", INQUIRY_LEN), + minit (NULL, -1) +}; + + +static void +mio_ref (gfc_ref **rp) +{ + gfc_ref *r; + + mio_lparen (); + + r = *rp; + r->type = MIO_NAME (ref_type) (r->type, ref_types); + + switch (r->type) + { + case REF_ARRAY: + mio_array_ref (&r->u.ar); + break; + + case REF_COMPONENT: + mio_symbol_ref (&r->u.c.sym); + mio_component_ref (&r->u.c.component); + break; + + case REF_SUBSTRING: + mio_expr (&r->u.ss.start); + mio_expr (&r->u.ss.end); + mio_charlen (&r->u.ss.length); + break; + + case REF_INQUIRY: + r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types); + break; + } + + mio_rparen (); +} + + +static void +mio_ref_list (gfc_ref **rp) +{ + gfc_ref *ref, *head, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (ref = *rp; ref; ref = ref->next) + mio_ref (&ref); + } + else + { + head = tail = NULL; + + while (peek_atom () != ATOM_RPAREN) + { + if (head == NULL) + head = tail = gfc_get_ref (); + else + { + tail->next = gfc_get_ref (); + tail = tail->next; + } + + mio_ref (&tail); + } + + *rp = head; + } + + mio_rparen (); +} + + +/* Read and write an integer value. */ + +static void +mio_gmp_integer (mpz_t *integer) +{ + char *p; + + if (iomode == IO_INPUT) + { + if (parse_atom () != ATOM_STRING) + bad_module ("Expected integer string"); + + mpz_init (*integer); + if (mpz_set_str (*integer, atom_string, 10)) + bad_module ("Error converting integer"); + + free (atom_string); + } + else + { + p = mpz_get_str (NULL, 10, *integer); + write_atom (ATOM_STRING, p); + free (p); + } +} + + +static void +mio_gmp_real (mpfr_t *real) +{ + mpfr_exp_t exponent; + char *p; + + if (iomode == IO_INPUT) + { + if (parse_atom () != ATOM_STRING) + bad_module ("Expected real string"); + + mpfr_init (*real); + mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE); + free (atom_string); + } + else + { + p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE); + + if (mpfr_nan_p (*real) || mpfr_inf_p (*real)) + { + write_atom (ATOM_STRING, p); + free (p); + return; + } + + atom_string = XCNEWVEC (char, strlen (p) + 20); + + sprintf (atom_string, "0.%s@%ld", p, exponent); + + /* Fix negative numbers. */ + if (atom_string[2] == '-') + { + atom_string[0] = '-'; + atom_string[1] = '0'; + atom_string[2] = '.'; + } + + write_atom (ATOM_STRING, atom_string); + + free (atom_string); + free (p); + } +} + + +/* Save and restore the shape of an array constructor. */ + +static void +mio_shape (mpz_t **pshape, int rank) +{ + mpz_t *shape; + atom_type t; + int n; + + /* A NULL shape is represented by (). */ + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + shape = *pshape; + if (!shape) + { + mio_rparen (); + return; + } + } + else + { + t = peek_atom (); + if (t == ATOM_RPAREN) + { + *pshape = NULL; + mio_rparen (); + return; + } + + shape = gfc_get_shape (rank); + *pshape = shape; + } + + for (n = 0; n < rank; n++) + mio_gmp_integer (&shape[n]); + + mio_rparen (); +} + + +static const mstring expr_types[] = { + minit ("OP", EXPR_OP), + minit ("FUNCTION", EXPR_FUNCTION), + minit ("CONSTANT", EXPR_CONSTANT), + minit ("VARIABLE", EXPR_VARIABLE), + minit ("SUBSTRING", EXPR_SUBSTRING), + minit ("STRUCTURE", EXPR_STRUCTURE), + minit ("ARRAY", EXPR_ARRAY), + minit ("NULL", EXPR_NULL), + minit ("COMPCALL", EXPR_COMPCALL), + minit (NULL, -1) +}; + +/* INTRINSIC_ASSIGN is missing because it is used as an index for + generic operators, not in expressions. INTRINSIC_USER is also + replaced by the correct function name by the time we see it. */ + +static const mstring intrinsics[] = +{ + minit ("UPLUS", INTRINSIC_UPLUS), + minit ("UMINUS", INTRINSIC_UMINUS), + minit ("PLUS", INTRINSIC_PLUS), + minit ("MINUS", INTRINSIC_MINUS), + minit ("TIMES", INTRINSIC_TIMES), + minit ("DIVIDE", INTRINSIC_DIVIDE), + minit ("POWER", INTRINSIC_POWER), + minit ("CONCAT", INTRINSIC_CONCAT), + minit ("AND", INTRINSIC_AND), + minit ("OR", INTRINSIC_OR), + minit ("EQV", INTRINSIC_EQV), + minit ("NEQV", INTRINSIC_NEQV), + minit ("EQ_SIGN", INTRINSIC_EQ), + minit ("EQ", INTRINSIC_EQ_OS), + minit ("NE_SIGN", INTRINSIC_NE), + minit ("NE", INTRINSIC_NE_OS), + minit ("GT_SIGN", INTRINSIC_GT), + minit ("GT", INTRINSIC_GT_OS), + minit ("GE_SIGN", INTRINSIC_GE), + minit ("GE", INTRINSIC_GE_OS), + minit ("LT_SIGN", INTRINSIC_LT), + minit ("LT", INTRINSIC_LT_OS), + minit ("LE_SIGN", INTRINSIC_LE), + minit ("LE", INTRINSIC_LE_OS), + minit ("NOT", INTRINSIC_NOT), + minit ("PARENTHESES", INTRINSIC_PARENTHESES), + minit ("USER", INTRINSIC_USER), + minit (NULL, -1) +}; + + +/* Remedy a couple of situations where the gfc_expr's can be defective. */ + +static void +fix_mio_expr (gfc_expr *e) +{ + gfc_symtree *ns_st = NULL; + const char *fname; + + if (iomode != IO_OUTPUT) + return; + + if (e->symtree) + { + /* If this is a symtree for a symbol that came from a contained module + namespace, it has a unique name and we should look in the current + namespace to see if the required, non-contained symbol is available + yet. If so, the latter should be written. */ + if (e->symtree->n.sym && check_unique_name (e->symtree->name)) + { + const char *name = e->symtree->n.sym->name; + if (gfc_fl_struct (e->symtree->n.sym->attr.flavor)) + name = gfc_dt_upper_string (name); + ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name); + } + + /* On the other hand, if the existing symbol is the module name or the + new symbol is a dummy argument, do not do the promotion. */ + if (ns_st && ns_st->n.sym + && ns_st->n.sym->attr.flavor != FL_MODULE + && !e->symtree->n.sym->attr.dummy) + e->symtree = ns_st; + } + else if (e->expr_type == EXPR_FUNCTION + && (e->value.function.name || e->value.function.isym)) + { + gfc_symbol *sym; + + /* In some circumstances, a function used in an initialization + expression, in one use associated module, can fail to be + coupled to its symtree when used in a specification + expression in another module. */ + fname = e->value.function.esym ? e->value.function.esym->name + : e->value.function.isym->name; + e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); + + if (e->symtree) + return; + + /* This is probably a reference to a private procedure from another + module. To prevent a segfault, make a generic with no specific + instances. If this module is used, without the required + specific coming from somewhere, the appropriate error message + is issued. */ + gfc_get_symbol (fname, gfc_current_ns, &sym); + sym->attr.flavor = FL_PROCEDURE; + sym->attr.generic = 1; + e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); + gfc_commit_symbol (sym); + } +} + + +/* Read and write expressions. The form "()" is allowed to indicate a + NULL expression. */ + +static void +mio_expr (gfc_expr **ep) +{ + HOST_WIDE_INT hwi; + gfc_expr *e; + atom_type t; + int flag; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (*ep == NULL) + { + mio_rparen (); + return; + } + + e = *ep; + MIO_NAME (expr_t) (e->expr_type, expr_types); + } + else + { + t = parse_atom (); + if (t == ATOM_RPAREN) + { + *ep = NULL; + return; + } + + if (t != ATOM_NAME) + bad_module ("Expected expression type"); + + e = *ep = gfc_get_expr (); + e->where = gfc_current_locus; + e->expr_type = (expr_t) find_enum (expr_types); + } + + mio_typespec (&e->ts); + mio_integer (&e->rank); + + fix_mio_expr (e); + + switch (e->expr_type) + { + case EXPR_OP: + e->value.op.op + = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics); + + switch (e->value.op.op) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_NOT: + case INTRINSIC_PARENTHESES: + mio_expr (&e->value.op.op1); + break; + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + case INTRINSIC_CONCAT: + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + mio_expr (&e->value.op.op1); + mio_expr (&e->value.op.op2); + break; + + case INTRINSIC_USER: + /* INTRINSIC_USER should not appear in resolved expressions, + though for UDRs we need to stream unresolved ones. */ + if (iomode == IO_OUTPUT) + write_atom (ATOM_STRING, e->value.op.uop->name); + else + { + char *name = read_string (); + const char *uop_name = find_use_name (name, true); + if (uop_name == NULL) + { + size_t len = strlen (name); + char *name2 = XCNEWVEC (char, len + 2); + memcpy (name2, name, len); + name2[len] = ' '; + name2[len + 1] = '\0'; + free (name); + uop_name = name = name2; + } + e->value.op.uop = gfc_get_uop (uop_name); + free (name); + } + mio_expr (&e->value.op.op1); + mio_expr (&e->value.op.op2); + break; + + default: + bad_module ("Bad operator"); + } + + break; + + case EXPR_FUNCTION: + mio_symtree_ref (&e->symtree); + mio_actual_arglist (&e->value.function.actual, false); + + if (iomode == IO_OUTPUT) + { + e->value.function.name + = mio_allocated_string (e->value.function.name); + if (e->value.function.esym) + flag = 1; + else if (e->ref) + flag = 2; + else if (e->value.function.isym == NULL) + flag = 3; + else + flag = 0; + mio_integer (&flag); + switch (flag) + { + case 1: + mio_symbol_ref (&e->value.function.esym); + break; + case 2: + mio_ref_list (&e->ref); + break; + case 3: + break; + default: + write_atom (ATOM_STRING, e->value.function.isym->name); + } + } + else + { + require_atom (ATOM_STRING); + if (atom_string[0] == '\0') + e->value.function.name = NULL; + else + e->value.function.name = gfc_get_string ("%s", atom_string); + free (atom_string); + + mio_integer (&flag); + switch (flag) + { + case 1: + mio_symbol_ref (&e->value.function.esym); + break; + case 2: + mio_ref_list (&e->ref); + break; + case 3: + break; + default: + require_atom (ATOM_STRING); + e->value.function.isym = gfc_find_function (atom_string); + free (atom_string); + } + } + + break; + + case EXPR_VARIABLE: + mio_symtree_ref (&e->symtree); + mio_ref_list (&e->ref); + break; + + case EXPR_SUBSTRING: + e->value.character.string + = CONST_CAST (gfc_char_t *, + mio_allocated_wide_string (e->value.character.string, + e->value.character.length)); + mio_ref_list (&e->ref); + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + mio_constructor (&e->value.constructor); + mio_shape (&e->shape, e->rank); + break; + + case EXPR_CONSTANT: + switch (e->ts.type) + { + case BT_INTEGER: + mio_gmp_integer (&e->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (e->ts.kind); + mio_gmp_real (&e->value.real); + break; + + case BT_COMPLEX: + gfc_set_model_kind (e->ts.kind); + mio_gmp_real (&mpc_realref (e->value.complex)); + mio_gmp_real (&mpc_imagref (e->value.complex)); + break; + + case BT_LOGICAL: + mio_integer (&e->value.logical); + break; + + case BT_CHARACTER: + hwi = e->value.character.length; + mio_hwi (&hwi); + e->value.character.length = hwi; + e->value.character.string + = CONST_CAST (gfc_char_t *, + mio_allocated_wide_string (e->value.character.string, + e->value.character.length)); + break; + + default: + bad_module ("Bad type in constant expression"); + } + + break; + + case EXPR_NULL: + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + case EXPR_UNKNOWN: + gcc_unreachable (); + break; + } + + /* PDT types store the expression specification list here. */ + mio_actual_arglist (&e->param_list, true); + + mio_rparen (); +} + + +/* Read and write namelists. */ + +static void +mio_namelist (gfc_symbol *sym) +{ + gfc_namelist *n, *m; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (n = sym->namelist; n; n = n->next) + mio_symbol_ref (&n->sym); + } + else + { + m = NULL; + while (peek_atom () != ATOM_RPAREN) + { + n = gfc_get_namelist (); + mio_symbol_ref (&n->sym); + + if (sym->namelist == NULL) + sym->namelist = n; + else + m->next = n; + + m = n; + } + sym->namelist_tail = m; + } + + mio_rparen (); +} + + +/* Save/restore lists of gfc_interface structures. When loading an + interface, we are really appending to the existing list of + interfaces. Checking for duplicate and ambiguous interfaces has to + be done later when all symbols have been loaded. */ + +pointer_info * +mio_interface_rest (gfc_interface **ip) +{ + gfc_interface *tail, *p; + pointer_info *pi = NULL; + + if (iomode == IO_OUTPUT) + { + if (ip != NULL) + for (p = *ip; p; p = p->next) + mio_symbol_ref (&p->sym); + } + else + { + if (*ip == NULL) + tail = NULL; + else + { + tail = *ip; + while (tail->next) + tail = tail->next; + } + + for (;;) + { + if (peek_atom () == ATOM_RPAREN) + break; + + p = gfc_get_interface (); + p->where = gfc_current_locus; + pi = mio_symbol_ref (&p->sym); + + if (tail == NULL) + *ip = p; + else + tail->next = p; + + tail = p; + } + } + + mio_rparen (); + return pi; +} + + +/* Save/restore a nameless operator interface. */ + +static void +mio_interface (gfc_interface **ip) +{ + mio_lparen (); + mio_interface_rest (ip); +} + + +/* Save/restore a named operator interface. */ + +static void +mio_symbol_interface (const char **name, const char **module, + gfc_interface **ip) +{ + mio_lparen (); + mio_pool_string (name); + mio_pool_string (module); + mio_interface_rest (ip); +} + + +static void +mio_namespace_ref (gfc_namespace **nsp) +{ + gfc_namespace *ns; + pointer_info *p; + + p = mio_pointer_ref (nsp); + + if (p->type == P_UNKNOWN) + p->type = P_NAMESPACE; + + if (iomode == IO_INPUT && p->integer != 0) + { + ns = (gfc_namespace *) p->u.pointer; + if (ns == NULL) + { + ns = gfc_get_namespace (NULL, 0); + associate_integer_pointer (p, ns); + } + else + ns->refs++; + } +} + + +/* Save/restore the f2k_derived namespace of a derived-type symbol. */ + +static gfc_namespace* current_f2k_derived; + +static void +mio_typebound_proc (gfc_typebound_proc** proc) +{ + int flag; + int overriding_flag; + + if (iomode == IO_INPUT) + { + *proc = gfc_get_typebound_proc (NULL); + (*proc)->where = gfc_current_locus; + } + gcc_assert (*proc); + + mio_lparen (); + + (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types); + + /* IO the NON_OVERRIDABLE/DEFERRED combination. */ + gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); + overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable; + overriding_flag = mio_name (overriding_flag, binding_overriding); + (*proc)->deferred = ((overriding_flag & 2) != 0); + (*proc)->non_overridable = ((overriding_flag & 1) != 0); + gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); + + (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing); + (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic); + (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc); + + mio_pool_string (&((*proc)->pass_arg)); + + flag = (int) (*proc)->pass_arg_num; + mio_integer (&flag); + (*proc)->pass_arg_num = (unsigned) flag; + + if ((*proc)->is_generic) + { + gfc_tbp_generic* g; + int iop; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + for (g = (*proc)->u.generic; g; g = g->next) + { + iop = (int) g->is_operator; + mio_integer (&iop); + mio_allocated_string (g->specific_st->name); + } + else + { + (*proc)->u.generic = NULL; + while (peek_atom () != ATOM_RPAREN) + { + gfc_symtree** sym_root; + + g = gfc_get_tbp_generic (); + g->specific = NULL; + + mio_integer (&iop); + g->is_operator = (bool) iop; + + require_atom (ATOM_STRING); + sym_root = ¤t_f2k_derived->tb_sym_root; + g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string); + free (atom_string); + + g->next = (*proc)->u.generic; + (*proc)->u.generic = g; + } + } + + mio_rparen (); + } + else if (!(*proc)->ppc) + mio_symtree_ref (&(*proc)->u.specific); + + mio_rparen (); +} + +/* Walker-callback function for this purpose. */ +static void +mio_typebound_symtree (gfc_symtree* st) +{ + if (iomode == IO_OUTPUT && !st->n.tb) + return; + + if (iomode == IO_OUTPUT) + { + mio_lparen (); + mio_allocated_string (st->name); + } + /* For IO_INPUT, the above is done in mio_f2k_derived. */ + + mio_typebound_proc (&st->n.tb); + mio_rparen (); +} + +/* IO a full symtree (in all depth). */ +static void +mio_full_typebound_tree (gfc_symtree** root) +{ + mio_lparen (); + + if (iomode == IO_OUTPUT) + gfc_traverse_symtree (*root, &mio_typebound_symtree); + else + { + while (peek_atom () == ATOM_LPAREN) + { + gfc_symtree* st; + + mio_lparen (); + + require_atom (ATOM_STRING); + st = gfc_get_tbp_symtree (root, atom_string); + free (atom_string); + + mio_typebound_symtree (st); + } + } + + mio_rparen (); +} + +static void +mio_finalizer (gfc_finalizer **f) +{ + if (iomode == IO_OUTPUT) + { + gcc_assert (*f); + gcc_assert ((*f)->proc_tree); /* Should already be resolved. */ + mio_symtree_ref (&(*f)->proc_tree); + } + else + { + *f = gfc_get_finalizer (); + (*f)->where = gfc_current_locus; /* Value should not matter. */ + (*f)->next = NULL; + + mio_symtree_ref (&(*f)->proc_tree); + (*f)->proc_sym = NULL; + } +} + +static void +mio_f2k_derived (gfc_namespace *f2k) +{ + current_f2k_derived = f2k; + + /* Handle the list of finalizer procedures. */ + mio_lparen (); + if (iomode == IO_OUTPUT) + { + gfc_finalizer *f; + for (f = f2k->finalizers; f; f = f->next) + mio_finalizer (&f); + } + else + { + f2k->finalizers = NULL; + while (peek_atom () != ATOM_RPAREN) + { + gfc_finalizer *cur = NULL; + mio_finalizer (&cur); + cur->next = f2k->finalizers; + f2k->finalizers = cur; + } + } + mio_rparen (); + + /* Handle type-bound procedures. */ + mio_full_typebound_tree (&f2k->tb_sym_root); + + /* Type-bound user operators. */ + mio_full_typebound_tree (&f2k->tb_uop_root); + + /* Type-bound intrinsic operators. */ + mio_lparen (); + if (iomode == IO_OUTPUT) + { + int op; + for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) + { + gfc_intrinsic_op realop; + + if (op == INTRINSIC_USER || !f2k->tb_op[op]) + continue; + + mio_lparen (); + realop = (gfc_intrinsic_op) op; + mio_intrinsic_op (&realop); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); + } + } + else + while (peek_atom () != ATOM_RPAREN) + { + gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */ + + mio_lparen (); + mio_intrinsic_op (&op); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); + } + mio_rparen (); +} + +static void +mio_full_f2k_derived (gfc_symbol *sym) +{ + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (sym->f2k_derived) + mio_f2k_derived (sym->f2k_derived); + } + else + { + if (peek_atom () != ATOM_RPAREN) + { + gfc_namespace *ns; + + sym->f2k_derived = gfc_get_namespace (NULL, 0); + + /* PDT templates make use of the mechanisms for formal args + and so the parameter symbols are stored in the formal + namespace. Transfer the sym_root to f2k_derived and then + free the formal namespace since it is uneeded. */ + if (sym->attr.pdt_template && sym->formal && sym->formal->sym) + { + ns = sym->formal->sym->ns; + sym->f2k_derived->sym_root = ns->sym_root; + ns->sym_root = NULL; + ns->refs++; + gfc_free_namespace (ns); + ns = NULL; + } + + mio_f2k_derived (sym->f2k_derived); + } + else + gcc_assert (!sym->f2k_derived); + } + + mio_rparen (); +} + +static const mstring omp_declare_simd_clauses[] = +{ + minit ("INBRANCH", 0), + minit ("NOTINBRANCH", 1), + minit ("SIMDLEN", 2), + minit ("UNIFORM", 3), + minit ("LINEAR", 4), + minit ("ALIGNED", 5), + minit ("LINEAR_REF", 33), + minit ("LINEAR_VAL", 34), + minit ("LINEAR_UVAL", 35), + minit (NULL, -1) +}; + +/* Handle !$omp declare simd. */ + +static void +mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp) +{ + if (iomode == IO_OUTPUT) + { + if (*odsp == NULL) + return; + } + else if (peek_atom () != ATOM_LPAREN) + return; + + gfc_omp_declare_simd *ods = *odsp; + + mio_lparen (); + if (iomode == IO_OUTPUT) + { + write_atom (ATOM_NAME, "OMP_DECLARE_SIMD"); + if (ods->clauses) + { + gfc_omp_namelist *n; + + if (ods->clauses->inbranch) + mio_name (0, omp_declare_simd_clauses); + if (ods->clauses->notinbranch) + mio_name (1, omp_declare_simd_clauses); + if (ods->clauses->simdlen_expr) + { + mio_name (2, omp_declare_simd_clauses); + mio_expr (&ods->clauses->simdlen_expr); + } + for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next) + { + mio_name (3, omp_declare_simd_clauses); + mio_symbol_ref (&n->sym); + } + for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next) + { + if (n->u.linear_op == OMP_LINEAR_DEFAULT) + mio_name (4, omp_declare_simd_clauses); + else + mio_name (32 + n->u.linear_op, omp_declare_simd_clauses); + mio_symbol_ref (&n->sym); + mio_expr (&n->expr); + } + for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) + { + mio_name (5, omp_declare_simd_clauses); + mio_symbol_ref (&n->sym); + mio_expr (&n->expr); + } + } + } + else + { + gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL }; + + require_atom (ATOM_NAME); + *odsp = ods = gfc_get_omp_declare_simd (); + ods->where = gfc_current_locus; + ods->proc_name = ns->proc_name; + if (peek_atom () == ATOM_NAME) + { + ods->clauses = gfc_get_omp_clauses (); + ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM]; + ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR]; + ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED]; + } + while (peek_atom () == ATOM_NAME) + { + gfc_omp_namelist *n; + int t = mio_name (0, omp_declare_simd_clauses); + + switch (t) + { + case 0: ods->clauses->inbranch = true; break; + case 1: ods->clauses->notinbranch = true; break; + case 2: mio_expr (&ods->clauses->simdlen_expr); break; + case 3: + case 4: + case 5: + *ptrs[t - 3] = n = gfc_get_omp_namelist (); + finish_namelist: + n->where = gfc_current_locus; + ptrs[t - 3] = &n->next; + mio_symbol_ref (&n->sym); + if (t != 3) + mio_expr (&n->expr); + break; + case 33: + case 34: + case 35: + *ptrs[1] = n = gfc_get_omp_namelist (); + n->u.linear_op = (enum gfc_omp_linear_op) (t - 32); + t = 4; + goto finish_namelist; + } + } + } + + mio_omp_declare_simd (ns, &ods->next); + + mio_rparen (); +} + + +static const mstring omp_declare_reduction_stmt[] = +{ + minit ("ASSIGN", 0), + minit ("CALL", 1), + minit (NULL, -1) +}; + + +static void +mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2, + gfc_namespace *ns, bool is_initializer) +{ + if (iomode == IO_OUTPUT) + { + if ((*sym1)->module == NULL) + { + (*sym1)->module = module_name; + (*sym2)->module = module_name; + } + mio_symbol_ref (sym1); + mio_symbol_ref (sym2); + if (ns->code->op == EXEC_ASSIGN) + { + mio_name (0, omp_declare_reduction_stmt); + mio_expr (&ns->code->expr1); + mio_expr (&ns->code->expr2); + } + else + { + int flag; + mio_name (1, omp_declare_reduction_stmt); + mio_symtree_ref (&ns->code->symtree); + mio_actual_arglist (&ns->code->ext.actual, false); + + flag = ns->code->resolved_isym != NULL; + mio_integer (&flag); + if (flag) + write_atom (ATOM_STRING, ns->code->resolved_isym->name); + else + mio_symbol_ref (&ns->code->resolved_sym); + } + } + else + { + pointer_info *p1 = mio_symbol_ref (sym1); + pointer_info *p2 = mio_symbol_ref (sym2); + gfc_symbol *sym; + gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns); + gcc_assert (p1->u.rsym.sym == NULL); + /* Add hidden symbols to the symtree. */ + pointer_info *q = get_integer (p1->u.rsym.ns); + q->u.pointer = (void *) ns; + sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns); + sym->ts = udr->ts; + sym->module = gfc_get_string ("%s", p1->u.rsym.module); + associate_integer_pointer (p1, sym); + sym->attr.omp_udr_artificial_var = 1; + gcc_assert (p2->u.rsym.sym == NULL); + sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns); + sym->ts = udr->ts; + sym->module = gfc_get_string ("%s", p2->u.rsym.module); + associate_integer_pointer (p2, sym); + sym->attr.omp_udr_artificial_var = 1; + if (mio_name (0, omp_declare_reduction_stmt) == 0) + { + ns->code = gfc_get_code (EXEC_ASSIGN); + mio_expr (&ns->code->expr1); + mio_expr (&ns->code->expr2); + } + else + { + int flag; + ns->code = gfc_get_code (EXEC_CALL); + mio_symtree_ref (&ns->code->symtree); + mio_actual_arglist (&ns->code->ext.actual, false); + + mio_integer (&flag); + if (flag) + { + require_atom (ATOM_STRING); + ns->code->resolved_isym = gfc_find_subroutine (atom_string); + free (atom_string); + } + else + mio_symbol_ref (&ns->code->resolved_sym); + } + ns->code->loc = gfc_current_locus; + ns->omp_udr_ns = 1; + } +} + + +/* Unlike most other routines, the address of the symbol node is already + fixed on input and the name/module has already been filled in. + If you update the symbol format here, don't forget to update read_module + as well (look for "seek to the symbol's component list"). */ + +static void +mio_symbol (gfc_symbol *sym) +{ + int intmod = INTMOD_NONE; + + mio_lparen (); + + mio_symbol_attribute (&sym->attr); + + if (sym->attr.pdt_type) + sym->name = gfc_dt_upper_string (sym->name); + + /* Note that components are always saved, even if they are supposed + to be private. Component access is checked during searching. */ + mio_component_list (&sym->components, sym->attr.vtype); + if (sym->components != NULL) + sym->component_access + = MIO_NAME (gfc_access) (sym->component_access, access_types); + + mio_typespec (&sym->ts); + if (sym->ts.type == BT_CLASS) + sym->attr.class_ok = 1; + + if (iomode == IO_OUTPUT) + mio_namespace_ref (&sym->formal_ns); + else + { + mio_namespace_ref (&sym->formal_ns); + if (sym->formal_ns) + sym->formal_ns->proc_name = sym; + } + + /* Save/restore common block links. */ + mio_symbol_ref (&sym->common_next); + + mio_formal_arglist (&sym->formal); + + if (sym->attr.flavor == FL_PARAMETER) + mio_expr (&sym->value); + + mio_array_spec (&sym->as); + + mio_symbol_ref (&sym->result); + + if (sym->attr.cray_pointee) + mio_symbol_ref (&sym->cp_pointer); + + /* Load/save the f2k_derived namespace of a derived-type symbol. */ + mio_full_f2k_derived (sym); + + /* PDT types store the symbol specification list here. */ + mio_actual_arglist (&sym->param_list, true); + + mio_namelist (sym); + + /* Add the fields that say whether this is from an intrinsic module, + and if so, what symbol it is within the module. */ +/* mio_integer (&(sym->from_intmod)); */ + if (iomode == IO_OUTPUT) + { + intmod = sym->from_intmod; + mio_integer (&intmod); + } + else + { + mio_integer (&intmod); + if (current_intmod) + sym->from_intmod = current_intmod; + else + sym->from_intmod = (intmod_id) intmod; + } + + mio_integer (&(sym->intmod_sym_id)); + + if (gfc_fl_struct (sym->attr.flavor)) + mio_integer (&(sym->hash_value)); + + if (sym->formal_ns + && sym->formal_ns->proc_name == sym + && sym->formal_ns->entries == NULL) + mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd); + + mio_rparen (); +} + + +/************************* Top level subroutines *************************/ + +/* A recursive function to look for a specific symbol by name and by + module. Whilst several symtrees might point to one symbol, its + is sufficient for the purposes here than one exist. Note that + generic interfaces are distinguished as are symbols that have been + renamed in another module. */ +static gfc_symtree * +find_symbol (gfc_symtree *st, const char *name, + const char *module, int generic) +{ + int c; + gfc_symtree *retval, *s; + + if (st == NULL || st->n.sym == NULL) + return NULL; + + c = strcmp (name, st->n.sym->name); + if (c == 0 && st->n.sym->module + && strcmp (module, st->n.sym->module) == 0 + && !check_unique_name (st->name)) + { + s = gfc_find_symtree (gfc_current_ns->sym_root, name); + + /* Detect symbols that are renamed by use association in another + module by the absence of a symtree and null attr.use_rename, + since the latter is not transmitted in the module file. */ + if (((!generic && !st->n.sym->attr.generic) + || (generic && st->n.sym->attr.generic)) + && !(s == NULL && !st->n.sym->attr.use_rename)) + return st; + } + + retval = find_symbol (st->left, name, module, generic); + + if (retval == NULL) + retval = find_symbol (st->right, name, module, generic); + + return retval; +} + + +/* Skip a list between balanced left and right parens. + By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens + have been already parsed by hand, and the remaining of the content is to be + skipped here. The default value is 0 (balanced parens). */ + +static void +skip_list (int nest_level = 0) +{ + int level; + + level = nest_level; + do + { + switch (parse_atom ()) + { + case ATOM_LPAREN: + level++; + break; + + case ATOM_RPAREN: + level--; + break; + + case ATOM_STRING: + free (atom_string); + break; + + case ATOM_NAME: + case ATOM_INTEGER: + break; + } + } + while (level > 0); +} + + +/* Load operator interfaces from the module. Interfaces are unusual + in that they attach themselves to existing symbols. */ + +static void +load_operator_interfaces (void) +{ + const char *p; + /* "module" must be large enough for the case of submodules in which the name + has the form module.submodule */ + char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2]; + gfc_user_op *uop; + pointer_info *pi = NULL; + int n, i; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + + mio_internal_string (name); + mio_internal_string (module); + + n = number_use_names (name, true); + n = n ? n : 1; + + for (i = 1; i <= n; i++) + { + /* Decide if we need to load this one or not. */ + p = find_use_name_n (name, &i, true); + + if (p == NULL) + { + while (parse_atom () != ATOM_RPAREN); + continue; + } + + if (i == 1) + { + uop = gfc_get_uop (p); + pi = mio_interface_rest (&uop->op); + } + else + { + if (gfc_find_uop (p, NULL)) + continue; + uop = gfc_get_uop (p); + uop->op = gfc_get_interface (); + uop->op->where = gfc_current_locus; + add_fixup (pi->integer, &uop->op->sym); + } + } + } + + mio_rparen (); +} + + +/* Load interfaces from the module. Interfaces are unusual in that + they attach themselves to existing symbols. */ + +static void +load_generic_interfaces (void) +{ + const char *p; + /* "module" must be large enough for the case of submodules in which the name + has the form module.submodule */ + char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2]; + gfc_symbol *sym; + gfc_interface *generic = NULL, *gen = NULL; + int n, i, renamed; + bool ambiguous_set = false; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + + mio_internal_string (name); + mio_internal_string (module); + + n = number_use_names (name, false); + renamed = n ? 1 : 0; + n = n ? n : 1; + + for (i = 1; i <= n; i++) + { + gfc_symtree *st; + /* Decide if we need to load this one or not. */ + p = find_use_name_n (name, &i, false); + + if (!p || gfc_find_symbol (p, NULL, 0, &sym)) + { + /* Skip the specific names for these cases. */ + while (i == 1 && parse_atom () != ATOM_RPAREN); + + continue; + } + + st = find_symbol (gfc_current_ns->sym_root, + name, module_name, 1); + + /* If the symbol exists already and is being USEd without being + in an ONLY clause, do not load a new symtree(11.3.2). */ + if (!only_flag && st) + sym = st->n.sym; + + if (!sym) + { + if (st) + { + sym = st->n.sym; + if (strcmp (st->name, p) != 0) + { + st = gfc_new_symtree (&gfc_current_ns->sym_root, p); + st->n.sym = sym; + sym->refs++; + } + } + + /* Since we haven't found a valid generic interface, we had + better make one. */ + if (!sym) + { + gfc_get_symbol (p, NULL, &sym); + sym->name = gfc_get_string ("%s", name); + sym->module = module_name; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.generic = 1; + sym->attr.use_assoc = 1; + } + } + else + { + /* Unless sym is a generic interface, this reference + is ambiguous. */ + if (st == NULL) + st = gfc_find_symtree (gfc_current_ns->sym_root, p); + + sym = st->n.sym; + + if (st && !sym->attr.generic + && !st->ambiguous + && sym->module + && strcmp (module, sym->module)) + { + ambiguous_set = true; + st->ambiguous = 1; + } + } + + sym->attr.use_only = only_flag; + sym->attr.use_rename = renamed; + + if (i == 1) + { + mio_interface_rest (&sym->generic); + generic = sym->generic; + } + else if (!sym->generic) + { + sym->generic = generic; + sym->attr.generic_copy = 1; + } + + /* If a procedure that is not generic has generic interfaces + that include itself, it is generic! We need to take care + to retain symbols ambiguous that were already so. */ + if (sym->attr.use_assoc + && !sym->attr.generic + && sym->attr.flavor == FL_PROCEDURE) + { + for (gen = generic; gen; gen = gen->next) + { + if (gen->sym == sym) + { + sym->attr.generic = 1; + if (ambiguous_set) + st->ambiguous = 0; + break; + } + } + } + + } + } + + mio_rparen (); +} + + +/* Load common blocks. */ + +static void +load_commons (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_common_head *p; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + int flags = 0; + char* label; + mio_lparen (); + mio_internal_string (name); + + p = gfc_get_common (name, 1); + + mio_symbol_ref (&p->head); + mio_integer (&flags); + if (flags & 1) + p->saved = 1; + if (flags & 2) + p->threadprivate = 1; + p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3); + p->use_assoc = 1; + + /* Get whether this was a bind(c) common or not. */ + mio_integer (&p->is_bind_c); + /* Get the binding label. */ + label = read_string (); + if (strlen (label)) + p->binding_label = IDENTIFIER_POINTER (get_identifier (label)); + XDELETEVEC (label); + + mio_rparen (); + } + + mio_rparen (); +} + + +/* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this + so that unused variables are not loaded and so that the expression can + be safely freed. */ + +static void +load_equiv (void) +{ + gfc_equiv *head, *tail, *end, *eq, *equiv; + bool duplicate; + + mio_lparen (); + in_load_equiv = true; + + end = gfc_current_ns->equiv; + while (end != NULL && end->next != NULL) + end = end->next; + + while (peek_atom () != ATOM_RPAREN) { + mio_lparen (); + head = tail = NULL; + + while(peek_atom () != ATOM_RPAREN) + { + if (head == NULL) + head = tail = gfc_get_equiv (); + else + { + tail->eq = gfc_get_equiv (); + tail = tail->eq; + } + + mio_pool_string (&tail->module); + mio_expr (&tail->expr); + } + + /* Check for duplicate equivalences being loaded from different modules */ + duplicate = false; + for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next) + { + if (equiv->module && head->module + && strcmp (equiv->module, head->module) == 0) + { + duplicate = true; + break; + } + } + + if (duplicate) + { + for (eq = head; eq; eq = head) + { + head = eq->eq; + gfc_free_expr (eq->expr); + free (eq); + } + } + + if (end == NULL) + gfc_current_ns->equiv = head; + else + end->next = head; + + if (head != NULL) + end = head; + + mio_rparen (); + } + + mio_rparen (); + in_load_equiv = false; +} + + +/* This function loads OpenMP user defined reductions. */ +static void +load_omp_udrs (void) +{ + mio_lparen (); + while (peek_atom () != ATOM_RPAREN) + { + const char *name = NULL, *newname; + char *altname; + gfc_typespec ts; + gfc_symtree *st; + gfc_omp_reduction_op rop = OMP_REDUCTION_USER; + + mio_lparen (); + mio_pool_string (&name); + gfc_clear_ts (&ts); + mio_typespec (&ts); + if (startswith (name, "operator ")) + { + const char *p = name + sizeof ("operator ") - 1; + if (strcmp (p, "+") == 0) + rop = OMP_REDUCTION_PLUS; + else if (strcmp (p, "*") == 0) + rop = OMP_REDUCTION_TIMES; + else if (strcmp (p, "-") == 0) + rop = OMP_REDUCTION_MINUS; + else if (strcmp (p, ".and.") == 0) + rop = OMP_REDUCTION_AND; + else if (strcmp (p, ".or.") == 0) + rop = OMP_REDUCTION_OR; + else if (strcmp (p, ".eqv.") == 0) + rop = OMP_REDUCTION_EQV; + else if (strcmp (p, ".neqv.") == 0) + rop = OMP_REDUCTION_NEQV; + } + altname = NULL; + if (rop == OMP_REDUCTION_USER && name[0] == '.') + { + size_t len = strlen (name + 1); + altname = XALLOCAVEC (char, len); + gcc_assert (name[len] == '.'); + memcpy (altname, name + 1, len - 1); + altname[len - 1] = '\0'; + } + newname = name; + if (rop == OMP_REDUCTION_USER) + newname = find_use_name (altname ? altname : name, !!altname); + else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL) + newname = NULL; + if (newname == NULL) + { + skip_list (1); + continue; + } + if (altname && newname != altname) + { + size_t len = strlen (newname); + altname = XALLOCAVEC (char, len + 3); + altname[0] = '.'; + memcpy (altname + 1, newname, len); + altname[len + 1] = '.'; + altname[len + 2] = '\0'; + name = gfc_get_string ("%s", altname); + } + st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); + gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts); + if (udr) + { + require_atom (ATOM_INTEGER); + pointer_info *p = get_integer (atom_int); + if (strcmp (p->u.rsym.module, udr->omp_out->module)) + { + gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from " + "module %s at %L", + p->u.rsym.module, &gfc_current_locus); + gfc_error ("Previous !$OMP DECLARE REDUCTION from module " + "%s at %L", + udr->omp_out->module, &udr->where); + } + skip_list (1); + continue; + } + udr = gfc_get_omp_udr (); + udr->name = name; + udr->rop = rop; + udr->ts = ts; + udr->where = gfc_current_locus; + udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1); + udr->combiner_ns->proc_name = gfc_current_ns->proc_name; + mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, + false); + if (peek_atom () != ATOM_RPAREN) + { + udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1); + udr->initializer_ns->proc_name = gfc_current_ns->proc_name; + mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, + udr->initializer_ns, true); + } + if (st) + { + udr->next = st->n.omp_udr; + st->n.omp_udr = udr; + } + else + { + st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); + st->n.omp_udr = udr; + } + mio_rparen (); + } + mio_rparen (); +} + + +/* Recursive function to traverse the pointer_info tree and load a + needed symbol. We return nonzero if we load a symbol and stop the + traversal, because the act of loading can alter the tree. */ + +static int +load_needed (pointer_info *p) +{ + gfc_namespace *ns; + pointer_info *q; + gfc_symbol *sym; + int rv; + + rv = 0; + if (p == NULL) + return rv; + + rv |= load_needed (p->left); + rv |= load_needed (p->right); + + if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED) + return rv; + + p->u.rsym.state = USED; + + set_module_locus (&p->u.rsym.where); + + sym = p->u.rsym.sym; + if (sym == NULL) + { + q = get_integer (p->u.rsym.ns); + + ns = (gfc_namespace *) q->u.pointer; + if (ns == NULL) + { + /* Create an interface namespace if necessary. These are + the namespaces that hold the formal parameters of module + procedures. */ + + ns = gfc_get_namespace (NULL, 0); + associate_integer_pointer (q, ns); + } + + /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl + doesn't go pear-shaped if the symbol is used. */ + if (!ns->proc_name) + gfc_find_symbol (p->u.rsym.module, gfc_current_ns, + 1, &ns->proc_name); + + sym = gfc_new_symbol (p->u.rsym.true_name, ns); + sym->name = gfc_dt_lower_string (p->u.rsym.true_name); + sym->module = gfc_get_string ("%s", p->u.rsym.module); + if (p->u.rsym.binding_label) + sym->binding_label = IDENTIFIER_POINTER (get_identifier + (p->u.rsym.binding_label)); + + associate_integer_pointer (p, sym); + } + + mio_symbol (sym); + sym->attr.use_assoc = 1; + + /* Unliked derived types, a STRUCTURE may share names with other symbols. + We greedily converted the symbol name to lowercase before we knew its + type, so now we must fix it. */ + if (sym->attr.flavor == FL_STRUCT) + sym->name = gfc_dt_upper_string (sym->name); + + /* Mark as only or rename for later diagnosis for explicitly imported + but not used warnings; don't mark internal symbols such as __vtab, + __def_init etc. Only mark them if they have been explicitly loaded. */ + + if (only_flag && sym->name[0] != '_' && sym->name[1] != '_') + { + gfc_use_rename *u; + + /* Search the use/rename list for the variable; if the variable is + found, mark it. */ + for (u = gfc_rename_list; u; u = u->next) + { + if (strcmp (u->use_name, sym->name) == 0) + { + sym->attr.use_only = 1; + break; + } + } + } + + if (p->u.rsym.renamed) + sym->attr.use_rename = 1; + + return 1; +} + + +/* Recursive function for cleaning up things after a module has been read. */ + +static void +read_cleanup (pointer_info *p) +{ + gfc_symtree *st; + pointer_info *q; + + if (p == NULL) + return; + + read_cleanup (p->left); + read_cleanup (p->right); + + if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced) + { + gfc_namespace *ns; + /* Add hidden symbols to the symtree. */ + q = get_integer (p->u.rsym.ns); + ns = (gfc_namespace *) q->u.pointer; + + if (!p->u.rsym.sym->attr.vtype + && !p->u.rsym.sym->attr.vtab) + st = gfc_get_unique_symtree (ns); + else + { + /* There is no reason to use 'unique_symtrees' for vtabs or + vtypes - their name is fine for a symtree and reduces the + namespace pollution. */ + st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name); + if (!st) + st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name); + } + + st->n.sym = p->u.rsym.sym; + st->n.sym->refs++; + + /* Fixup any symtree references. */ + p->u.rsym.symtree = st; + resolve_fixups (p->u.rsym.stfixup, st); + p->u.rsym.stfixup = NULL; + } + + /* Free unused symbols. */ + if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED) + gfc_free_symbol (p->u.rsym.sym); +} + + +/* It is not quite enough to check for ambiguity in the symbols by + the loaded symbol and the new symbol not being identical. */ +static bool +check_for_ambiguous (gfc_symtree *st, pointer_info *info) +{ + gfc_symbol *rsym; + module_locus locus; + symbol_attribute attr; + gfc_symbol *st_sym; + + if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name) + { + gfc_error ("%qs of module %qs, imported at %C, is also the name of the " + "current program unit", st->name, module_name); + return true; + } + + st_sym = st->n.sym; + rsym = info->u.rsym.sym; + if (st_sym == rsym) + return false; + + if (st_sym->attr.vtab || st_sym->attr.vtype) + return false; + + /* If the existing symbol is generic from a different module and + the new symbol is generic there can be no ambiguity. */ + if (st_sym->attr.generic + && st_sym->module + && st_sym->module != module_name) + { + /* The new symbol's attributes have not yet been read. Since + we need attr.generic, read it directly. */ + get_module_locus (&locus); + set_module_locus (&info->u.rsym.where); + mio_lparen (); + attr.generic = 0; + mio_symbol_attribute (&attr); + set_module_locus (&locus); + if (attr.generic) + return false; + } + + return true; +} + + +/* Read a module file. */ + +static void +read_module (void) +{ + module_locus operator_interfaces, user_operators, omp_udrs; + const char *p; + char name[GFC_MAX_SYMBOL_LEN + 1]; + int i; + /* Workaround -Wmaybe-uninitialized false positive during + profiledbootstrap by initializing them. */ + int ambiguous = 0, j, nuse, symbol = 0; + pointer_info *info, *q; + gfc_use_rename *u = NULL; + gfc_symtree *st; + gfc_symbol *sym; + + get_module_locus (&operator_interfaces); /* Skip these for now. */ + skip_list (); + + get_module_locus (&user_operators); + skip_list (); + skip_list (); + + /* Skip commons and equivalences for now. */ + skip_list (); + skip_list (); + + /* Skip OpenMP UDRs. */ + get_module_locus (&omp_udrs); + skip_list (); + + mio_lparen (); + + /* Create the fixup nodes for all the symbols. */ + + while (peek_atom () != ATOM_RPAREN) + { + char* bind_label; + require_atom (ATOM_INTEGER); + info = get_integer (atom_int); + + info->type = P_SYMBOL; + info->u.rsym.state = UNUSED; + + info->u.rsym.true_name = read_string (); + info->u.rsym.module = read_string (); + bind_label = read_string (); + if (strlen (bind_label)) + info->u.rsym.binding_label = bind_label; + else + XDELETEVEC (bind_label); + + require_atom (ATOM_INTEGER); + info->u.rsym.ns = atom_int; + + get_module_locus (&info->u.rsym.where); + + /* See if the symbol has already been loaded by a previous module. + If so, we reference the existing symbol and prevent it from + being loaded again. This should not happen if the symbol being + read is an index for an assumed shape dummy array (ns != 1). */ + + sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module); + + if (sym == NULL + || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1)) + { + skip_list (); + continue; + } + + info->u.rsym.state = USED; + info->u.rsym.sym = sym; + /* The current symbol has already been loaded, so we can avoid loading + it again. However, if it is a derived type, some of its components + can be used in expressions in the module. To avoid the module loading + failing, we need to associate the module's component pointer indexes + with the existing symbol's component pointers. */ + if (gfc_fl_struct (sym->attr.flavor)) + { + gfc_component *c; + + /* First seek to the symbol's component list. */ + mio_lparen (); /* symbol opening. */ + skip_list (); /* skip symbol attribute. */ + + mio_lparen (); /* component list opening. */ + for (c = sym->components; c; c = c->next) + { + pointer_info *p; + const char *comp_name = NULL; + int n = 0; + + mio_lparen (); /* component opening. */ + mio_integer (&n); + p = get_integer (n); + if (p->u.pointer == NULL) + associate_integer_pointer (p, c); + mio_pool_string (&comp_name); + if (comp_name != c->name) + { + gfc_fatal_error ("Mismatch in components of derived type " + "%qs from %qs at %C: expecting %qs, " + "but got %qs", sym->name, sym->module, + c->name, comp_name); + } + skip_list (1); /* component end. */ + } + mio_rparen (); /* component list closing. */ + + skip_list (1); /* symbol end. */ + } + else + skip_list (); + + /* Some symbols do not have a namespace (eg. formal arguments), + so the automatic "unique symtree" mechanism must be suppressed + by marking them as referenced. */ + q = get_integer (info->u.rsym.ns); + if (q->u.pointer == NULL) + { + info->u.rsym.referenced = 1; + continue; + } + } + + mio_rparen (); + + /* Parse the symtree lists. This lets us mark which symbols need to + be loaded. Renaming is also done at this point by replacing the + symtree name. */ + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_internal_string (name); + mio_integer (&ambiguous); + mio_integer (&symbol); + + info = get_integer (symbol); + + /* See how many use names there are. If none, go through the start + of the loop at least once. */ + nuse = number_use_names (name, false); + info->u.rsym.renamed = nuse ? 1 : 0; + + if (nuse == 0) + nuse = 1; + + for (j = 1; j <= nuse; j++) + { + /* Get the jth local name for this symbol. */ + p = find_use_name_n (name, &j, false); + + if (p == NULL && strcmp (name, module_name) == 0) + p = name; + + /* Exception: Always import vtabs & vtypes. */ + if (p == NULL && name[0] == '_' + && (startswith (name, "__vtab_") + || startswith (name, "__vtype_"))) + p = name; + + /* Skip symtree nodes not in an ONLY clause, unless there + is an existing symtree loaded from another USE statement. */ + if (p == NULL) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (st != NULL + && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0 + && st->n.sym->module != NULL + && strcmp (st->n.sym->module, info->u.rsym.module) == 0) + { + info->u.rsym.symtree = st; + info->u.rsym.sym = st->n.sym; + } + continue; + } + + /* If a symbol of the same name and module exists already, + this symbol, which is not in an ONLY clause, must not be + added to the namespace(11.3.2). Note that find_symbol + only returns the first occurrence that it finds. */ + if (!only_flag && !info->u.rsym.renamed + && strcmp (name, module_name) != 0 + && find_symbol (gfc_current_ns->sym_root, name, + module_name, 0)) + continue; + + st = gfc_find_symtree (gfc_current_ns->sym_root, p); + + if (st != NULL + && !(st->n.sym && st->n.sym->attr.used_in_submodule)) + { + /* Check for ambiguous symbols. */ + if (check_for_ambiguous (st, info)) + st->ambiguous = 1; + else + info->u.rsym.symtree = st; + } + else + { + if (st) + { + /* This symbol is host associated from a module in a + submodule. Hide it with a unique symtree. */ + gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); + s->n.sym = st->n.sym; + st->n.sym = NULL; + } + else + { + /* Create a symtree node in the current namespace for this + symbol. */ + st = check_unique_name (p) + ? gfc_get_unique_symtree (gfc_current_ns) + : gfc_new_symtree (&gfc_current_ns->sym_root, p); + st->ambiguous = ambiguous; + } + + sym = info->u.rsym.sym; + + /* Create a symbol node if it doesn't already exist. */ + if (sym == NULL) + { + info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, + gfc_current_ns); + info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name); + sym = info->u.rsym.sym; + sym->module = gfc_get_string ("%s", info->u.rsym.module); + + if (info->u.rsym.binding_label) + { + tree id = get_identifier (info->u.rsym.binding_label); + sym->binding_label = IDENTIFIER_POINTER (id); + } + } + + st->n.sym = sym; + st->n.sym->refs++; + + if (strcmp (name, p) != 0) + sym->attr.use_rename = 1; + + if (name[0] != '_' + || (!startswith (name, "__vtab_") + && !startswith (name, "__vtype_"))) + sym->attr.use_only = only_flag; + + /* Store the symtree pointing to this symbol. */ + info->u.rsym.symtree = st; + + if (info->u.rsym.state == UNUSED) + info->u.rsym.state = NEEDED; + info->u.rsym.referenced = 1; + } + } + } + + mio_rparen (); + + /* Load intrinsic operator interfaces. */ + set_module_locus (&operator_interfaces); + mio_lparen (); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + gfc_use_rename *u = NULL, *v = NULL; + int j = i; + + if (i == INTRINSIC_USER) + continue; + + if (only_flag) + { + u = find_use_operator ((gfc_intrinsic_op) i); + + /* F2018:10.1.5.5.1 requires same interpretation of old and new-style + relational operators. Special handling for USE, ONLY. */ + switch (i) + { + case INTRINSIC_EQ: + j = INTRINSIC_EQ_OS; + break; + case INTRINSIC_EQ_OS: + j = INTRINSIC_EQ; + break; + case INTRINSIC_NE: + j = INTRINSIC_NE_OS; + break; + case INTRINSIC_NE_OS: + j = INTRINSIC_NE; + break; + case INTRINSIC_GT: + j = INTRINSIC_GT_OS; + break; + case INTRINSIC_GT_OS: + j = INTRINSIC_GT; + break; + case INTRINSIC_GE: + j = INTRINSIC_GE_OS; + break; + case INTRINSIC_GE_OS: + j = INTRINSIC_GE; + break; + case INTRINSIC_LT: + j = INTRINSIC_LT_OS; + break; + case INTRINSIC_LT_OS: + j = INTRINSIC_LT; + break; + case INTRINSIC_LE: + j = INTRINSIC_LE_OS; + break; + case INTRINSIC_LE_OS: + j = INTRINSIC_LE; + break; + default: + break; + } + + if (j != i) + v = find_use_operator ((gfc_intrinsic_op) j); + + if (u == NULL && v == NULL) + { + skip_list (); + continue; + } + + if (u) + u->found = 1; + if (v) + v->found = 1; + } + + mio_interface (&gfc_current_ns->op[i]); + if (!gfc_current_ns->op[i] && !gfc_current_ns->op[j]) + { + if (u) + u->found = 0; + if (v) + v->found = 0; + } + } + + mio_rparen (); + + /* Load generic and user operator interfaces. These must follow the + loading of symtree because otherwise symbols can be marked as + ambiguous. */ + + set_module_locus (&user_operators); + + load_operator_interfaces (); + load_generic_interfaces (); + + load_commons (); + load_equiv (); + + /* Load OpenMP user defined reductions. */ + set_module_locus (&omp_udrs); + load_omp_udrs (); + + /* At this point, we read those symbols that are needed but haven't + been loaded yet. If one symbol requires another, the other gets + marked as NEEDED if its previous state was UNUSED. */ + + while (load_needed (pi_root)); + + /* Make sure all elements of the rename-list were found in the module. */ + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + if (u->op == INTRINSIC_NONE) + { + gfc_error ("Symbol %qs referenced at %L not found in module %qs", + u->use_name, &u->where, module_name); + continue; + } + + if (u->op == INTRINSIC_USER) + { + gfc_error ("User operator %qs referenced at %L not found " + "in module %qs", u->use_name, &u->where, module_name); + continue; + } + + gfc_error ("Intrinsic operator %qs referenced at %L not found " + "in module %qs", gfc_op2string (u->op), &u->where, + module_name); + } + + /* Clean up symbol nodes that were never loaded, create references + to hidden symbols. */ + + read_cleanup (pi_root); +} + + +/* Given an access type that is specific to an entity and the default + access, return nonzero if the entity is publicly accessible. If the + element is declared as PUBLIC, then it is public; if declared + PRIVATE, then private, and otherwise it is public unless the default + access in this context has been declared PRIVATE. */ + +static bool dump_smod = false; + +static bool +check_access (gfc_access specific_access, gfc_access default_access) +{ + if (dump_smod) + return true; + + if (specific_access == ACCESS_PUBLIC) + return TRUE; + if (specific_access == ACCESS_PRIVATE) + return FALSE; + + if (flag_module_private) + return default_access == ACCESS_PUBLIC; + else + return default_access != ACCESS_PRIVATE; +} + + +bool +gfc_check_symbol_access (gfc_symbol *sym) +{ + if (sym->attr.vtab || sym->attr.vtype) + return true; + else + return check_access (sym->attr.access, sym->ns->default_access); +} + + +/* A structure to remember which commons we've already written. */ + +struct written_common +{ + BBT_HEADER(written_common); + const char *name, *label; +}; + +static struct written_common *written_commons = NULL; + +/* Comparison function used for balancing the binary tree. */ + +static int +compare_written_commons (void *a1, void *b1) +{ + const char *aname = ((struct written_common *) a1)->name; + const char *alabel = ((struct written_common *) a1)->label; + const char *bname = ((struct written_common *) b1)->name; + const char *blabel = ((struct written_common *) b1)->label; + int c = strcmp (aname, bname); + + return (c != 0 ? c : strcmp (alabel, blabel)); +} + +/* Free a list of written commons. */ + +static void +free_written_common (struct written_common *w) +{ + if (!w) + return; + + if (w->left) + free_written_common (w->left); + if (w->right) + free_written_common (w->right); + + free (w); +} + +/* Write a common block to the module -- recursive helper function. */ + +static void +write_common_0 (gfc_symtree *st, bool this_module) +{ + gfc_common_head *p; + const char * name; + int flags; + const char *label; + struct written_common *w; + bool write_me = true; + + if (st == NULL) + return; + + write_common_0 (st->left, this_module); + + /* We will write out the binding label, or "" if no label given. */ + name = st->n.common->name; + p = st->n.common; + label = (p->is_bind_c && p->binding_label) ? p->binding_label : ""; + + /* Check if we've already output this common. */ + w = written_commons; + while (w) + { + int c = strcmp (name, w->name); + c = (c != 0 ? c : strcmp (label, w->label)); + if (c == 0) + write_me = false; + + w = (c < 0) ? w->left : w->right; + } + + if (this_module && p->use_assoc) + write_me = false; + + if (write_me) + { + /* Write the common to the module. */ + mio_lparen (); + mio_pool_string (&name); + + mio_symbol_ref (&p->head); + flags = p->saved ? 1 : 0; + if (p->threadprivate) + flags |= 2; + flags |= p->omp_device_type << 2; + mio_integer (&flags); + + /* Write out whether the common block is bind(c) or not. */ + mio_integer (&(p->is_bind_c)); + + mio_pool_string (&label); + mio_rparen (); + + /* Record that we have written this common. */ + w = XCNEW (struct written_common); + w->name = p->name; + w->label = label; + gfc_insert_bbt (&written_commons, w, compare_written_commons); + } + + write_common_0 (st->right, this_module); +} + + +/* Write a common, by initializing the list of written commons, calling + the recursive function write_common_0() and cleaning up afterwards. */ + +static void +write_common (gfc_symtree *st) +{ + written_commons = NULL; + write_common_0 (st, true); + write_common_0 (st, false); + free_written_common (written_commons); + written_commons = NULL; +} + + +/* Write the blank common block to the module. */ + +static void +write_blank_common (void) +{ + const char * name = BLANK_COMMON_NAME; + int saved; + /* TODO: Blank commons are not bind(c). The F2003 standard probably says + this, but it hasn't been checked. Just making it so for now. */ + int is_bind_c = 0; + + if (gfc_current_ns->blank_common.head == NULL) + return; + + mio_lparen (); + + mio_pool_string (&name); + + mio_symbol_ref (&gfc_current_ns->blank_common.head); + saved = gfc_current_ns->blank_common.saved; + mio_integer (&saved); + + /* Write out whether the common block is bind(c) or not. */ + mio_integer (&is_bind_c); + + /* Write out an empty binding label. */ + write_atom (ATOM_STRING, ""); + + mio_rparen (); +} + + +/* Write equivalences to the module. */ + +static void +write_equiv (void) +{ + gfc_equiv *eq, *e; + int num; + + num = 0; + for (eq = gfc_current_ns->equiv; eq; eq = eq->next) + { + mio_lparen (); + + for (e = eq; e; e = e->eq) + { + if (e->module == NULL) + e->module = gfc_get_string ("%s.eq.%d", module_name, num); + mio_allocated_string (e->module); + mio_expr (&e->expr); + } + + num++; + mio_rparen (); + } +} + + +/* Write a symbol to the module. */ + +static void +write_symbol (int n, gfc_symbol *sym) +{ + const char *label; + + if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL) + gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name); + + mio_integer (&n); + + if (gfc_fl_struct (sym->attr.flavor)) + { + const char *name; + name = gfc_dt_upper_string (sym->name); + mio_pool_string (&name); + } + else + mio_pool_string (&sym->name); + + mio_pool_string (&sym->module); + if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label) + { + label = sym->binding_label; + mio_pool_string (&label); + } + else + write_atom (ATOM_STRING, ""); + + mio_pointer_ref (&sym->ns); + + mio_symbol (sym); + write_char ('\n'); +} + + +/* Recursive traversal function to write the initial set of symbols to + the module. We check to see if the symbol should be written + according to the access specification. */ + +static void +write_symbol0 (gfc_symtree *st) +{ + gfc_symbol *sym; + pointer_info *p; + bool dont_write = false; + + if (st == NULL) + return; + + write_symbol0 (st->left); + + sym = st->n.sym; + if (sym->module == NULL) + sym->module = module_name; + + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic + && !sym->attr.subroutine && !sym->attr.function) + dont_write = true; + + if (!gfc_check_symbol_access (sym)) + dont_write = true; + + if (!dont_write) + { + p = get_pointer (sym); + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (p->u.wsym.state != WRITTEN) + { + write_symbol (p->integer, sym); + p->u.wsym.state = WRITTEN; + } + } + + write_symbol0 (st->right); +} + + +static void +write_omp_udr (gfc_omp_udr *udr) +{ + switch (udr->rop) + { + case OMP_REDUCTION_USER: + /* Non-operators can't be used outside of the module. */ + if (udr->name[0] != '.') + return; + else + { + gfc_symtree *st; + size_t len = strlen (udr->name + 1); + char *name = XALLOCAVEC (char, len); + memcpy (name, udr->name, len - 1); + name[len - 1] = '\0'; + st = gfc_find_symtree (gfc_current_ns->uop_root, name); + /* If corresponding user operator is private, don't write + the UDR. */ + if (st != NULL) + { + gfc_user_op *uop = st->n.uop; + if (!check_access (uop->access, uop->ns->default_access)) + return; + } + } + break; + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_MINUS: + case OMP_REDUCTION_TIMES: + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + /* If corresponding operator is private, don't write the UDR. */ + if (!check_access (gfc_current_ns->operator_access[udr->rop], + gfc_current_ns->default_access)) + return; + break; + default: + break; + } + if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS) + { + /* If derived type is private, don't write the UDR. */ + if (!gfc_check_symbol_access (udr->ts.u.derived)) + return; + } + + mio_lparen (); + mio_pool_string (&udr->name); + mio_typespec (&udr->ts); + mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false); + if (udr->initializer_ns) + mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, + udr->initializer_ns, true); + mio_rparen (); +} + + +static void +write_omp_udrs (gfc_symtree *st) +{ + if (st == NULL) + return; + + write_omp_udrs (st->left); + gfc_omp_udr *udr; + for (udr = st->n.omp_udr; udr; udr = udr->next) + write_omp_udr (udr); + write_omp_udrs (st->right); +} + + +/* Type for the temporary tree used when writing secondary symbols. */ + +struct sorted_pointer_info +{ + BBT_HEADER (sorted_pointer_info); + + pointer_info *p; +}; + +#define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info) + +/* Recursively traverse the temporary tree, free its contents. */ + +static void +free_sorted_pointer_info_tree (sorted_pointer_info *p) +{ + if (!p) + return; + + free_sorted_pointer_info_tree (p->left); + free_sorted_pointer_info_tree (p->right); + + free (p); +} + +/* Comparison function for the temporary tree. */ + +static int +compare_sorted_pointer_info (void *_spi1, void *_spi2) +{ + sorted_pointer_info *spi1, *spi2; + spi1 = (sorted_pointer_info *)_spi1; + spi2 = (sorted_pointer_info *)_spi2; + + if (spi1->p->integer < spi2->p->integer) + return -1; + if (spi1->p->integer > spi2->p->integer) + return 1; + return 0; +} + + +/* Finds the symbols that need to be written and collects them in the + sorted_pi tree so that they can be traversed in an order + independent of memory addresses. */ + +static void +find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p) +{ + if (!p) + return; + + if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE) + { + sorted_pointer_info *sp = gfc_get_sorted_pointer_info(); + sp->p = p; + + gfc_insert_bbt (tree, sp, compare_sorted_pointer_info); + } + + find_symbols_to_write (tree, p->left); + find_symbols_to_write (tree, p->right); +} + + +/* Recursive function that traverses the tree of symbols that need to be + written and writes them in order. */ + +static void +write_symbol1_recursion (sorted_pointer_info *sp) +{ + if (!sp) + return; + + write_symbol1_recursion (sp->left); + + pointer_info *p1 = sp->p; + gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE); + + p1->u.wsym.state = WRITTEN; + write_symbol (p1->integer, p1->u.wsym.sym); + p1->u.wsym.sym->attr.public_used = 1; + + write_symbol1_recursion (sp->right); +} + + +/* Write the secondary set of symbols to the module file. These are + symbols that were not public yet are needed by the public symbols + or another dependent symbol. The act of writing a symbol can add + symbols to the pointer_info tree, so we return nonzero if a symbol + was written and pass that information upwards. The caller will + then call this function again until nothing was written. It uses + the utility functions and a temporary tree to ensure a reproducible + ordering of the symbol output and thus the module file. */ + +static int +write_symbol1 (pointer_info *p) +{ + if (!p) + return 0; + + /* Put symbols that need to be written into a tree sorted on the + integer field. */ + + sorted_pointer_info *spi_root = NULL; + find_symbols_to_write (&spi_root, p); + + /* No symbols to write, return. */ + if (!spi_root) + return 0; + + /* Otherwise, write and free the tree again. */ + write_symbol1_recursion (spi_root); + free_sorted_pointer_info_tree (spi_root); + + return 1; +} + + +/* Write operator interfaces associated with a symbol. */ + +static void +write_operator (gfc_user_op *uop) +{ + static char nullstring[] = ""; + const char *p = nullstring; + + if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access)) + return; + + mio_symbol_interface (&uop->name, &p, &uop->op); +} + + +/* Write generic interfaces from the namespace sym_root. */ + +static void +write_generic (gfc_symtree *st) +{ + gfc_symbol *sym; + + if (st == NULL) + return; + + write_generic (st->left); + + sym = st->n.sym; + if (sym && !check_unique_name (st->name) + && sym->generic && gfc_check_symbol_access (sym)) + { + if (!sym->module) + sym->module = module_name; + + mio_symbol_interface (&st->name, &sym->module, &sym->generic); + } + + write_generic (st->right); +} + + +static void +write_symtree (gfc_symtree *st) +{ + gfc_symbol *sym; + pointer_info *p; + + sym = st->n.sym; + + /* A symbol in an interface body must not be visible in the + module file. */ + if (sym->ns != gfc_current_ns + && sym->ns->proc_name + && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY) + return; + + if (!gfc_check_symbol_access (sym) + || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic + && !sym->attr.subroutine && !sym->attr.function)) + return; + + if (check_unique_name (st->name)) + return; + + /* From F2003 onwards, intrinsic procedures are no longer subject to + the restriction, "that an elemental intrinsic function here be of + type integer or character and each argument must be an initialization + expr of type integer or character" is lifted so that intrinsic + procedures can be over-ridden. This requires that the intrinsic + symbol not appear in the module file, thereby preventing ambiguity + when USEd. */ + if (strcmp (sym->module, "(intrinsic)") == 0 + && (gfc_option.allow_std & GFC_STD_F2003)) + return; + + p = find_pointer (sym); + if (p == NULL) + gfc_internal_error ("write_symtree(): Symbol not written"); + + mio_pool_string (&st->name); + mio_integer (&st->ambiguous); + mio_hwi (&p->integer); +} + + +static void +write_module (void) +{ + int i; + + /* Initialize the column counter. */ + module_column = 1; + + /* Write the operator interfaces. */ + mio_lparen (); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + if (i == INTRINSIC_USER) + continue; + + mio_interface (check_access (gfc_current_ns->operator_access[i], + gfc_current_ns->default_access) + ? &gfc_current_ns->op[i] : NULL); + } + + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + gfc_traverse_user_op (gfc_current_ns, write_operator); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_generic (gfc_current_ns->sym_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_blank_common (); + write_common (gfc_current_ns->common_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_equiv (); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_omp_udrs (gfc_current_ns->omp_udr_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + /* Write symbol information. First we traverse all symbols in the + primary namespace, writing those that need to be written. + Sometimes writing one symbol will cause another to need to be + written. A list of these symbols ends up on the write stack, and + we end by popping the bottom of the stack and writing the symbol + until the stack is empty. */ + + mio_lparen (); + + write_symbol0 (gfc_current_ns->sym_root); + while (write_symbol1 (pi_root)) + /* Nothing. */; + + mio_rparen (); + + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree); + mio_rparen (); +} + + +/* Read a CRC32 sum from the gzip trailer of a module file. Returns + true on success, false on failure. */ + +static bool +read_crc32_from_module_file (const char* filename, uLong* crc) +{ + FILE *file; + char buf[4]; + unsigned int val; + + /* Open the file in binary mode. */ + if ((file = fopen (filename, "rb")) == NULL) + return false; + + /* The gzip crc32 value is found in the [END-8, END-4] bytes of the + file. See RFC 1952. */ + if (fseek (file, -8, SEEK_END) != 0) + { + fclose (file); + return false; + } + + /* Read the CRC32. */ + if (fread (buf, 1, 4, file) != 4) + { + fclose (file); + return false; + } + + /* Close the file. */ + fclose (file); + + val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16) + + ((buf[3] & 0xFF) << 24); + *crc = val; + + /* For debugging, the CRC value printed in hexadecimal should match + the CRC printed by "zcat -l -v filename". + printf("CRC of file %s is %x\n", filename, val); */ + + return true; +} + + +/* Given module, dump it to disk. If there was an error while + processing the module, dump_flag will be set to zero and we delete + the module file, even if it was already there. */ + +static void +dump_module (const char *name, int dump_flag) +{ + int n; + char *filename, *filename_tmp; + uLong crc, crc_old; + + module_name = gfc_get_string ("%s", name); + + if (dump_smod) + { + name = submodule_name; + n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1; + } + else + n = strlen (name) + strlen (MODULE_EXTENSION) + 1; + + if (gfc_option.module_dir != NULL) + { + n += strlen (gfc_option.module_dir); + filename = (char *) alloca (n); + strcpy (filename, gfc_option.module_dir); + strcat (filename, name); + } + else + { + filename = (char *) alloca (n); + strcpy (filename, name); + } + + if (dump_smod) + strcat (filename, SUBMODULE_EXTENSION); + else + strcat (filename, MODULE_EXTENSION); + + /* Name of the temporary file used to write the module. */ + filename_tmp = (char *) alloca (n + 1); + strcpy (filename_tmp, filename); + strcat (filename_tmp, "0"); + + /* There was an error while processing the module. We delete the + module file, even if it was already there. */ + if (!dump_flag) + { + remove (filename); + return; + } + + if (gfc_cpp_makedep ()) + gfc_cpp_add_target (filename); + + /* Write the module to the temporary file. */ + module_fp = gzopen (filename_tmp, "w"); + if (module_fp == NULL) + gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s", + filename_tmp, xstrerror (errno)); + + /* Use lbasename to ensure module files are reproducible regardless + of the build path (see the reproducible builds project). */ + gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n", + MOD_VERSION, lbasename (gfc_source_file)); + + /* Write the module itself. */ + iomode = IO_OUTPUT; + + init_pi_tree (); + + write_module (); + + free_pi_tree (pi_root); + pi_root = NULL; + + write_char ('\n'); + + if (gzclose (module_fp)) + gfc_fatal_error ("Error writing module file %qs for writing: %s", + filename_tmp, xstrerror (errno)); + + /* Read the CRC32 from the gzip trailers of the module files and + compare. */ + if (!read_crc32_from_module_file (filename_tmp, &crc) + || !read_crc32_from_module_file (filename, &crc_old) + || crc_old != crc) + { + /* Module file have changed, replace the old one. */ + if (remove (filename) && errno != ENOENT) + gfc_fatal_error ("Cannot delete module file %qs: %s", filename, + xstrerror (errno)); + if (rename (filename_tmp, filename)) + gfc_fatal_error ("Cannot rename module file %qs to %qs: %s", + filename_tmp, filename, xstrerror (errno)); + } + else + { + if (remove (filename_tmp)) + gfc_fatal_error ("Cannot delete temporary module file %qs: %s", + filename_tmp, xstrerror (errno)); + } +} + + +/* Suppress the output of a .smod file by module, if no module + procedures have been seen. */ +static bool no_module_procedures; + +static void +check_for_module_procedures (gfc_symbol *sym) +{ + if (sym && sym->attr.module_procedure) + no_module_procedures = false; +} + + +void +gfc_dump_module (const char *name, int dump_flag) +{ + if (gfc_state_stack->state == COMP_SUBMODULE) + dump_smod = true; + else + dump_smod =false; + + no_module_procedures = true; + gfc_traverse_ns (gfc_current_ns, check_for_module_procedures); + + dump_module (name, dump_flag); + + if (no_module_procedures || dump_smod) + return; + + /* Write a submodule file from a module. The 'dump_smod' flag switches + off the check for PRIVATE entities. */ + dump_smod = true; + submodule_name = module_name; + dump_module (name, dump_flag); + dump_smod = false; +} + +static void +create_intrinsic_function (const char *name, int id, + const char *modname, intmod_id module, + bool subroutine, gfc_symbol *result_type) +{ + gfc_intrinsic_sym *isym; + gfc_symtree *tmp_symtree; + gfc_symbol *sym; + + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (tmp_symtree) + { + if (tmp_symtree->n.sym && tmp_symtree->n.sym->module + && strcmp (modname, tmp_symtree->n.sym->module) == 0) + return; + gfc_error ("Symbol %qs at %C already declared", name); + return; + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + + if (subroutine) + { + gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); + isym = gfc_intrinsic_subroutine_by_id (isym_id); + sym->attr.subroutine = 1; + } + else + { + gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); + isym = gfc_intrinsic_function_by_id (isym_id); + + sym->attr.function = 1; + if (result_type) + { + sym->ts.type = BT_DERIVED; + sym->ts.u.derived = result_type; + sym->ts.is_c_interop = 1; + isym->ts.f90_type = BT_VOID; + isym->ts.type = BT_DERIVED; + isym->ts.f90_type = BT_VOID; + isym->ts.u.derived = result_type; + isym->ts.is_c_interop = 1; + } + } + gcc_assert (isym); + + sym->attr.flavor = FL_PROCEDURE; + sym->attr.intrinsic = 1; + + sym->module = gfc_get_string ("%s", modname); + sym->attr.use_assoc = 1; + sym->from_intmod = module; + sym->intmod_sym_id = id; +} + + +/* Import the intrinsic ISO_C_BINDING module, generating symbols in + the current namespace for all named constants, pointer types, and + procedures in the module unless the only clause was used or a rename + list was provided. */ + +static void +import_iso_c_binding_module (void) +{ + gfc_symbol *mod_sym = NULL, *return_type; + gfc_symtree *mod_symtree = NULL, *tmp_symtree; + gfc_symtree *c_ptr = NULL, *c_funptr = NULL; + const char *iso_c_module_name = "__iso_c_binding"; + gfc_use_rename *u; + int i; + bool want_c_ptr = false, want_c_funptr = false; + + /* Look only in the current namespace. */ + mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name); + + if (mod_symtree == NULL) + { + /* symtree doesn't already exist in current namespace. */ + gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree, + false); + + if (mod_symtree != NULL) + mod_sym = mod_symtree->n.sym; + else + gfc_internal_error ("import_iso_c_binding_module(): Unable to " + "create symbol for %s", iso_c_module_name); + + mod_sym->attr.flavor = FL_MODULE; + mod_sym->attr.intrinsic = 1; + mod_sym->module = gfc_get_string ("%s", iso_c_module_name); + mod_sym->from_intmod = INTMOD_ISO_C_BINDING; + } + + /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it; + check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which + need C_(FUN)PTR. */ + for (u = gfc_rename_list; u; u = u->next) + { + if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name, + u->use_name) == 0) + want_c_ptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name, + u->use_name) == 0) + want_c_ptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name, + u->use_name) == 0) + want_c_funptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name, + u->use_name) == 0) + want_c_funptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name, + u->use_name) == 0) + { + c_ptr = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_PTR, + u->local_name[0] ? u->local_name + : u->use_name, + NULL, false); + } + else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name, + u->use_name) == 0) + { + c_funptr + = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_FUNPTR, + u->local_name[0] ? u->local_name + : u->use_name, + NULL, false); + } + } + + if ((want_c_ptr || !only_flag) && !c_ptr) + c_ptr = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_PTR, + NULL, NULL, only_flag); + if ((want_c_funptr || !only_flag) && !c_funptr) + c_funptr = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_FUNPTR, + NULL, NULL, only_flag); + + /* Generate the symbols for the named constants representing + the kinds for intrinsic data types. */ + for (i = 0; i < ISOCBINDING_NUMBER; i++) + { + bool found = false; + for (u = gfc_rename_list; u; u = u->next) + if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0) + { + bool not_in_std; + const char *name; + u->found = 1; + found = true; + + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_INTCST(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_REALCST(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_CMPXCST(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#include "iso-c-binding.def" + default: + not_in_std = false; + name = ""; + } + + if (not_in_std) + { + gfc_error ("The symbol %qs, referenced at %L, is not " + "in the selected standard", name, &u->where); + continue; + } + + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + if (a == ISOCBINDING_LOC) \ + return_type = c_ptr->n.sym; \ + else if (a == ISOCBINDING_FUNLOC) \ + return_type = c_funptr->n.sym; \ + else \ + return_type = NULL; \ + create_intrinsic_function (u->local_name[0] \ + ? u->local_name : u->use_name, \ + a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, false, \ + return_type); \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + create_intrinsic_function (u->local_name[0] ? u->local_name \ + : u->use_name, \ + a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, true, NULL); \ + break; +#include "iso-c-binding.def" + + case ISOCBINDING_PTR: + case ISOCBINDING_FUNPTR: + /* Already handled above. */ + break; + default: + if (i == ISOCBINDING_NULL_PTR) + tmp_symtree = c_ptr; + else if (i == ISOCBINDING_NULL_FUNPTR) + tmp_symtree = c_funptr; + else + tmp_symtree = NULL; + generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) i, + u->local_name[0] + ? u->local_name : u->use_name, + tmp_symtree, false); + } + } + + if (!found && !only_flag) + { + /* Skip, if the symbol is not in the enabled standard. */ + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_INTCST(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_REALCST(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_CMPXCST(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#include "iso-c-binding.def" + default: + ; /* Not GFC_STD_* versioned. */ + } + + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + if (a == ISOCBINDING_LOC) \ + return_type = c_ptr->n.sym; \ + else if (a == ISOCBINDING_FUNLOC) \ + return_type = c_funptr->n.sym; \ + else \ + return_type = NULL; \ + create_intrinsic_function (b, a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, false, \ + return_type); \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + create_intrinsic_function (b, a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, true, NULL); \ + break; +#include "iso-c-binding.def" + + case ISOCBINDING_PTR: + case ISOCBINDING_FUNPTR: + /* Already handled above. */ + break; + default: + if (i == ISOCBINDING_NULL_PTR) + tmp_symtree = c_ptr; + else if (i == ISOCBINDING_NULL_FUNPTR) + tmp_symtree = c_funptr; + else + tmp_symtree = NULL; + generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) i, NULL, + tmp_symtree, false); + } + } + } + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + gfc_error ("Symbol %qs referenced at %L not found in intrinsic " + "module ISO_C_BINDING", u->use_name, &u->where); + } +} + + +/* Add an integer named constant from a given module. */ + +static void +create_int_parameter (const char *name, int value, const char *modname, + intmod_id module, int id) +{ + gfc_symtree *tmp_symtree; + gfc_symbol *sym; + + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (tmp_symtree != NULL) + { + if (strcmp (modname, tmp_symtree->n.sym->module) == 0) + return; + else + gfc_error ("Symbol %qs already declared", name); + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + + sym->module = gfc_get_string ("%s", modname); + sym->attr.flavor = FL_PARAMETER; + sym->ts.type = BT_INTEGER; + sym->ts.kind = gfc_default_integer_kind; + sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value); + sym->attr.use_assoc = 1; + sym->from_intmod = module; + sym->intmod_sym_id = id; +} + + +/* Value is already contained by the array constructor, but not + yet the shape. */ + +static void +create_int_parameter_array (const char *name, int size, gfc_expr *value, + const char *modname, intmod_id module, int id) +{ + gfc_symtree *tmp_symtree; + gfc_symbol *sym; + + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (tmp_symtree != NULL) + { + if (strcmp (modname, tmp_symtree->n.sym->module) == 0) + return; + else + gfc_error ("Symbol %qs already declared", name); + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + + sym->module = gfc_get_string ("%s", modname); + sym->attr.flavor = FL_PARAMETER; + sym->ts.type = BT_INTEGER; + sym->ts.kind = gfc_default_integer_kind; + sym->attr.use_assoc = 1; + sym->from_intmod = module; + sym->intmod_sym_id = id; + sym->attr.dimension = 1; + sym->as = gfc_get_array_spec (); + sym->as->rank = 1; + sym->as->type = AS_EXPLICIT; + sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size); + + sym->value = value; + sym->value->shape = gfc_get_shape (1); + mpz_init_set_ui (sym->value->shape[0], size); +} + + +/* Add an derived type for a given module. */ + +static void +create_derived_type (const char *name, const char *modname, + intmod_id module, int id) +{ + gfc_symtree *tmp_symtree; + gfc_symbol *sym, *dt_sym; + gfc_interface *intr, *head; + + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (tmp_symtree != NULL) + { + if (strcmp (modname, tmp_symtree->n.sym->module) == 0) + return; + else + gfc_error ("Symbol %qs already declared", name); + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + sym->module = gfc_get_string ("%s", modname); + sym->from_intmod = module; + sym->intmod_sym_id = id; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.function = 1; + sym->attr.generic = 1; + + gfc_get_sym_tree (gfc_dt_upper_string (sym->name), + gfc_current_ns, &tmp_symtree, false); + dt_sym = tmp_symtree->n.sym; + dt_sym->name = gfc_get_string ("%s", sym->name); + dt_sym->attr.flavor = FL_DERIVED; + dt_sym->attr.private_comp = 1; + dt_sym->attr.zero_comp = 1; + dt_sym->attr.use_assoc = 1; + dt_sym->module = gfc_get_string ("%s", modname); + dt_sym->from_intmod = module; + dt_sym->intmod_sym_id = id; + + head = sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + sym->generic = intr; + sym->attr.if_source = IFSRC_DECL; +} + + +/* Read the contents of the module file into a temporary buffer. */ + +static void +read_module_to_tmpbuf () +{ + /* We don't know the uncompressed size, so enlarge the buffer as + needed. */ + int cursz = 4096; + int rsize = cursz; + int len = 0; + + module_content = XNEWVEC (char, cursz); + + while (1) + { + int nread = gzread (module_fp, module_content + len, rsize); + len += nread; + if (nread < rsize) + break; + cursz *= 2; + module_content = XRESIZEVEC (char, module_content, cursz); + rsize = cursz - len; + } + + module_content = XRESIZEVEC (char, module_content, len + 1); + module_content[len] = '\0'; + + module_pos = 0; +} + + +/* USE the ISO_FORTRAN_ENV intrinsic module. */ + +static void +use_iso_fortran_env_module (void) +{ + static char mod[] = "iso_fortran_env"; + gfc_use_rename *u; + gfc_symbol *mod_sym; + gfc_symtree *mod_symtree; + gfc_expr *expr; + int i, j; + + intmod_sym symbol[] = { +#define NAMED_INTCST(a,b,c,d) { a, b, 0, d }, +#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d }, +#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d }, +#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d }, +#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d }, +#include "iso-fortran-env.def" + { ISOFORTRANENV_INVALID, NULL, -1234, 0 } }; + + i = 0; +#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c; +#include "iso-fortran-env.def" + + /* Generate the symbol for the module itself. */ + mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod); + if (mod_symtree == NULL) + { + gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false); + gcc_assert (mod_symtree); + mod_sym = mod_symtree->n.sym; + + mod_sym->attr.flavor = FL_MODULE; + mod_sym->attr.intrinsic = 1; + mod_sym->module = gfc_get_string ("%s", mod); + mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV; + } + else + if (!mod_symtree->n.sym->attr.intrinsic) + gfc_error ("Use of intrinsic module %qs at %C conflicts with " + "non-intrinsic module name used previously", mod); + + /* Generate the symbols for the module integer named constants. */ + + for (i = 0; symbol[i].name; i++) + { + bool found = false; + for (u = gfc_rename_list; u; u = u->next) + { + if (strcmp (symbol[i].name, u->use_name) == 0) + { + found = true; + u->found = 1; + + if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, " + "referenced at %L, is not in the selected " + "standard", symbol[i].name, &u->where)) + continue; + + if ((flag_default_integer || flag_default_real_8) + && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) + gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named " + "constant from intrinsic module " + "ISO_FORTRAN_ENV at %L is incompatible with " + "option %qs", &u->where, + flag_default_integer + ? "-fdefault-integer-8" + : "-fdefault-real-8"); + switch (symbol[i].id) + { +#define NAMED_INTCST(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_int_parameter (u->local_name[0] ? u->local_name + : u->use_name, + symbol[i].value, mod, + INTMOD_ISO_FORTRAN_ENV, symbol[i].id); + break; + +#define NAMED_KINDARRAY(a,b,KINDS,d) \ + case a:\ + expr = gfc_get_array_expr (BT_INTEGER, \ + gfc_default_integer_kind,\ + NULL); \ + for (j = 0; KINDS[j].kind != 0; j++) \ + gfc_constructor_append_expr (&expr->value.constructor, \ + gfc_get_int_expr (gfc_default_integer_kind, NULL, \ + KINDS[j].kind), NULL); \ + create_int_parameter_array (u->local_name[0] ? u->local_name \ + : u->use_name, \ + j, expr, mod, \ + INTMOD_ISO_FORTRAN_ENV, \ + symbol[i].id); \ + break; +#include "iso-fortran-env.def" + +#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ + case a: +#include "iso-fortran-env.def" + create_derived_type (u->local_name[0] ? u->local_name + : u->use_name, + mod, INTMOD_ISO_FORTRAN_ENV, + symbol[i].id); + break; + +#define NAMED_FUNCTION(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_intrinsic_function (u->local_name[0] ? u->local_name + : u->use_name, + symbol[i].id, mod, + INTMOD_ISO_FORTRAN_ENV, false, + NULL); + break; + + default: + gcc_unreachable (); + } + } + } + + if (!found && !only_flag) + { + if ((gfc_option.allow_std & symbol[i].standard) == 0) + continue; + + if ((flag_default_integer || flag_default_real_8) + && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) + gfc_warning_now (0, + "Use of the NUMERIC_STORAGE_SIZE named constant " + "from intrinsic module ISO_FORTRAN_ENV at %C is " + "incompatible with option %s", + flag_default_integer + ? "-fdefault-integer-8" : "-fdefault-real-8"); + + switch (symbol[i].id) + { +#define NAMED_INTCST(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_int_parameter (symbol[i].name, symbol[i].value, mod, + INTMOD_ISO_FORTRAN_ENV, symbol[i].id); + break; + +#define NAMED_KINDARRAY(a,b,KINDS,d) \ + case a:\ + expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \ + NULL); \ + for (j = 0; KINDS[j].kind != 0; j++) \ + gfc_constructor_append_expr (&expr->value.constructor, \ + gfc_get_int_expr (gfc_default_integer_kind, NULL, \ + KINDS[j].kind), NULL); \ + create_int_parameter_array (symbol[i].name, j, expr, mod, \ + INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\ + break; +#include "iso-fortran-env.def" + +#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ + case a: +#include "iso-fortran-env.def" + create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV, + symbol[i].id); + break; + +#define NAMED_FUNCTION(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_intrinsic_function (symbol[i].name, symbol[i].id, mod, + INTMOD_ISO_FORTRAN_ENV, false, + NULL); + break; + + default: + gcc_unreachable (); + } + } + } + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + gfc_error ("Symbol %qs referenced at %L not found in intrinsic " + "module ISO_FORTRAN_ENV", u->use_name, &u->where); + } +} + + +/* Process a USE directive. */ + +static void +gfc_use_module (gfc_use_list *module) +{ + char *filename; + gfc_state_data *p; + int c, line, start; + gfc_symtree *mod_symtree; + gfc_use_list *use_stmt; + locus old_locus = gfc_current_locus; + + gfc_current_locus = module->where; + module_name = module->module_name; + gfc_rename_list = module->rename; + only_flag = module->only_flag; + current_intmod = INTMOD_NONE; + + if (!only_flag) + gfc_warning_now (OPT_Wuse_without_only, + "USE statement at %C has no ONLY qualifier"); + + if (gfc_state_stack->state == COMP_MODULE + || module->submodule_name == NULL) + { + filename = XALLOCAVEC (char, strlen (module_name) + + strlen (MODULE_EXTENSION) + 1); + strcpy (filename, module_name); + strcat (filename, MODULE_EXTENSION); + } + else + { + filename = XALLOCAVEC (char, strlen (module->submodule_name) + + strlen (SUBMODULE_EXTENSION) + 1); + strcpy (filename, module->submodule_name); + strcat (filename, SUBMODULE_EXTENSION); + } + + /* First, try to find an non-intrinsic module, unless the USE statement + specified that the module is intrinsic. */ + module_fp = NULL; + if (!module->intrinsic) + module_fp = gzopen_included_file (filename, true, true); + + /* Then, see if it's an intrinsic one, unless the USE statement + specified that the module is non-intrinsic. */ + if (module_fp == NULL && !module->non_intrinsic) + { + if (strcmp (module_name, "iso_fortran_env") == 0 + && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV " + "intrinsic module at %C")) + { + use_iso_fortran_env_module (); + free_rename (module->rename); + module->rename = NULL; + gfc_current_locus = old_locus; + module->intrinsic = true; + return; + } + + if (strcmp (module_name, "iso_c_binding") == 0 + && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C")) + { + import_iso_c_binding_module(); + free_rename (module->rename); + module->rename = NULL; + gfc_current_locus = old_locus; + module->intrinsic = true; + return; + } + + module_fp = gzopen_intrinsic_module (filename); + + if (module_fp == NULL && module->intrinsic) + gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C", + module_name); + + /* Check for the IEEE modules, so we can mark their symbols + accordingly when we read them. */ + if (strcmp (module_name, "ieee_features") == 0 + && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C")) + { + current_intmod = INTMOD_IEEE_FEATURES; + } + else if (strcmp (module_name, "ieee_exceptions") == 0 + && gfc_notify_std (GFC_STD_F2003, + "IEEE_EXCEPTIONS module at %C")) + { + current_intmod = INTMOD_IEEE_EXCEPTIONS; + } + else if (strcmp (module_name, "ieee_arithmetic") == 0 + && gfc_notify_std (GFC_STD_F2003, + "IEEE_ARITHMETIC module at %C")) + { + current_intmod = INTMOD_IEEE_ARITHMETIC; + } + } + + if (module_fp == NULL) + { + if (gfc_state_stack->state != COMP_SUBMODULE + && module->submodule_name == NULL) + gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s", + filename, xstrerror (errno)); + else + gfc_fatal_error ("Module file %qs has not been generated, either " + "because the module does not contain a MODULE " + "PROCEDURE or there is an error in the module.", + filename); + } + + /* Check that we haven't already USEd an intrinsic module with the + same name. */ + + mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name); + if (mod_symtree && mod_symtree->n.sym->attr.intrinsic) + gfc_error ("Use of non-intrinsic module %qs at %C conflicts with " + "intrinsic module name used previously", module_name); + + iomode = IO_INPUT; + module_line = 1; + module_column = 1; + start = 0; + + read_module_to_tmpbuf (); + gzclose (module_fp); + + /* Skip the first line of the module, after checking that this is + a gfortran module file. */ + line = 0; + while (line < 1) + { + c = module_char (); + if (c == EOF) + bad_module ("Unexpected end of module"); + if (start++ < 3) + parse_name (c); + if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0) + || (start == 2 && strcmp (atom_name, " module") != 0)) + gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran" + " module file", module_fullpath); + if (start == 3) + { + if (strcmp (atom_name, " version") != 0 + || module_char () != ' ' + || parse_atom () != ATOM_STRING + || strcmp (atom_string, MOD_VERSION)) + gfc_fatal_error ("Cannot read module file %qs opened at %C," + " because it was created by a different" + " version of GNU Fortran", module_fullpath); + + free (atom_string); + } + + if (c == '\n') + line++; + } + + /* Make sure we're not reading the same module that we may be building. */ + for (p = gfc_state_stack; p; p = p->previous) + if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE) + && strcmp (p->sym->name, module_name) == 0) + { + if (p->state == COMP_SUBMODULE) + gfc_fatal_error ("Cannot USE a submodule that is currently built"); + else + gfc_fatal_error ("Cannot USE a module that is currently built"); + } + + init_pi_tree (); + init_true_name_tree (); + + read_module (); + + free_true_name (true_name_root); + true_name_root = NULL; + + free_pi_tree (pi_root); + pi_root = NULL; + + XDELETEVEC (module_content); + module_content = NULL; + + use_stmt = gfc_get_use_list (); + *use_stmt = *module; + use_stmt->next = gfc_current_ns->use_stmts; + gfc_current_ns->use_stmts = use_stmt; + + gfc_current_locus = old_locus; +} + + +/* Remove duplicated intrinsic operators from the rename list. */ + +static void +rename_list_remove_duplicate (gfc_use_rename *list) +{ + gfc_use_rename *seek, *last; + + for (; list; list = list->next) + if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE) + { + last = list; + for (seek = list->next; seek; seek = last->next) + { + if (list->op == seek->op) + { + last->next = seek->next; + free (seek); + } + else + last = seek; + } + } +} + + +/* Process all USE directives. */ + +void +gfc_use_modules (void) +{ + gfc_use_list *next, *seek, *last; + + for (next = module_list; next; next = next->next) + { + bool non_intrinsic = next->non_intrinsic; + bool intrinsic = next->intrinsic; + bool neither = !non_intrinsic && !intrinsic; + + for (seek = next->next; seek; seek = seek->next) + { + if (next->module_name != seek->module_name) + continue; + + if (seek->non_intrinsic) + non_intrinsic = true; + else if (seek->intrinsic) + intrinsic = true; + else + neither = true; + } + + if (intrinsic && neither && !non_intrinsic) + { + char *filename; + FILE *fp; + + filename = XALLOCAVEC (char, + strlen (next->module_name) + + strlen (MODULE_EXTENSION) + 1); + strcpy (filename, next->module_name); + strcat (filename, MODULE_EXTENSION); + fp = gfc_open_included_file (filename, true, true); + if (fp != NULL) + { + non_intrinsic = true; + fclose (fp); + } + } + + last = next; + for (seek = next->next; seek; seek = last->next) + { + if (next->module_name != seek->module_name) + { + last = seek; + continue; + } + + if ((!next->intrinsic && !seek->intrinsic) + || (next->intrinsic && seek->intrinsic) + || !non_intrinsic) + { + if (!seek->only_flag) + next->only_flag = false; + if (seek->rename) + { + gfc_use_rename *r = seek->rename; + while (r->next) + r = r->next; + r->next = next->rename; + next->rename = seek->rename; + } + last->next = seek->next; + free (seek); + } + else + last = seek; + } + } + + for (; module_list; module_list = next) + { + next = module_list->next; + rename_list_remove_duplicate (module_list->rename); + gfc_use_module (module_list); + free (module_list); + } + gfc_rename_list = NULL; +} + + +void +gfc_free_use_stmts (gfc_use_list *use_stmts) +{ + gfc_use_list *next; + for (; use_stmts; use_stmts = next) + { + gfc_use_rename *next_rename; + + for (; use_stmts->rename; use_stmts->rename = next_rename) + { + next_rename = use_stmts->rename->next; + free (use_stmts->rename); + } + next = use_stmts->next; + free (use_stmts); + } +} + + +void +gfc_module_init_2 (void) +{ + last_atom = ATOM_LPAREN; + gfc_rename_list = NULL; + module_list = NULL; +} + + +void +gfc_module_done_2 (void) +{ + free_rename (gfc_rename_list); + gfc_rename_list = NULL; +} diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c deleted file mode 100644 index 4a03197..0000000 --- a/gcc/fortran/openmp.c +++ /dev/null @@ -1,9411 +0,0 @@ -/* OpenMP directive matching and resolving. - Copyright (C) 2005-2022 Free Software Foundation, Inc. - Contributed by Jakub Jelinek - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "arith.h" -#include "match.h" -#include "parse.h" -#include "constructor.h" -#include "diagnostic.h" -#include "gomp-constants.h" -#include "target-memory.h" /* For gfc_encode_character. */ - -/* Match an end of OpenMP directive. End of OpenMP directive is optional - whitespace, followed by '\n' or comment '!'. */ - -static match -gfc_match_omp_eos (void) -{ - locus old_loc; - char c; - - old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - - c = gfc_next_ascii_char (); - switch (c) - { - case '!': - do - c = gfc_next_ascii_char (); - while (c != '\n'); - /* Fall through */ - - case '\n': - return MATCH_YES; - } - - gfc_current_locus = old_loc; - return MATCH_NO; -} - -match -gfc_match_omp_eos_error (void) -{ - if (gfc_match_omp_eos() == MATCH_YES) - return MATCH_YES; - - gfc_error ("Unexpected junk at %C"); - return MATCH_ERROR; -} - - -/* Free an omp_clauses structure. */ - -void -gfc_free_omp_clauses (gfc_omp_clauses *c) -{ - int i; - if (c == NULL) - return; - - gfc_free_expr (c->if_expr); - gfc_free_expr (c->final_expr); - gfc_free_expr (c->num_threads); - gfc_free_expr (c->chunk_size); - gfc_free_expr (c->safelen_expr); - gfc_free_expr (c->simdlen_expr); - gfc_free_expr (c->num_teams_lower); - gfc_free_expr (c->num_teams_upper); - gfc_free_expr (c->device); - gfc_free_expr (c->thread_limit); - gfc_free_expr (c->dist_chunk_size); - gfc_free_expr (c->grainsize); - gfc_free_expr (c->hint); - gfc_free_expr (c->num_tasks); - gfc_free_expr (c->priority); - gfc_free_expr (c->detach); - for (i = 0; i < OMP_IF_LAST; i++) - gfc_free_expr (c->if_exprs[i]); - gfc_free_expr (c->async_expr); - gfc_free_expr (c->gang_num_expr); - gfc_free_expr (c->gang_static_expr); - gfc_free_expr (c->worker_expr); - gfc_free_expr (c->vector_expr); - gfc_free_expr (c->num_gangs_expr); - gfc_free_expr (c->num_workers_expr); - gfc_free_expr (c->vector_length_expr); - for (i = 0; i < OMP_LIST_NUM; i++) - gfc_free_omp_namelist (c->lists[i], - i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND); - gfc_free_expr_list (c->wait_list); - gfc_free_expr_list (c->tile_list); - free (CONST_CAST (char *, c->critical_name)); - free (c); -} - -/* Free oacc_declare structures. */ - -void -gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc) -{ - struct gfc_oacc_declare *decl = oc; - - do - { - struct gfc_oacc_declare *next; - - next = decl->next; - gfc_free_omp_clauses (decl->clauses); - free (decl); - decl = next; - } - while (decl); -} - -/* Free expression list. */ -void -gfc_free_expr_list (gfc_expr_list *list) -{ - gfc_expr_list *n; - - for (; list; list = n) - { - n = list->next; - free (list); - } -} - -/* Free an !$omp declare simd construct list. */ - -void -gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods) -{ - if (ods) - { - gfc_free_omp_clauses (ods->clauses); - free (ods); - } -} - -void -gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list) -{ - while (list) - { - gfc_omp_declare_simd *current = list; - list = list->next; - gfc_free_omp_declare_simd (current); - } -} - -static void -gfc_free_omp_trait_property_list (gfc_omp_trait_property *list) -{ - while (list) - { - gfc_omp_trait_property *current = list; - list = list->next; - switch (current->property_kind) - { - case CTX_PROPERTY_ID: - free (current->name); - break; - case CTX_PROPERTY_NAME_LIST: - if (current->is_name) - free (current->name); - break; - case CTX_PROPERTY_SIMD: - gfc_free_omp_clauses (current->clauses); - break; - default: - break; - } - free (current); - } -} - -static void -gfc_free_omp_selector_list (gfc_omp_selector *list) -{ - while (list) - { - gfc_omp_selector *current = list; - list = list->next; - gfc_free_omp_trait_property_list (current->properties); - free (current); - } -} - -static void -gfc_free_omp_set_selector_list (gfc_omp_set_selector *list) -{ - while (list) - { - gfc_omp_set_selector *current = list; - list = list->next; - gfc_free_omp_selector_list (current->trait_selectors); - free (current); - } -} - -/* Free an !$omp declare variant construct list. */ - -void -gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list) -{ - while (list) - { - gfc_omp_declare_variant *current = list; - list = list->next; - gfc_free_omp_set_selector_list (current->set_selectors); - free (current); - } -} - -/* Free an !$omp declare reduction. */ - -void -gfc_free_omp_udr (gfc_omp_udr *omp_udr) -{ - if (omp_udr) - { - gfc_free_omp_udr (omp_udr->next); - gfc_free_namespace (omp_udr->combiner_ns); - if (omp_udr->initializer_ns) - gfc_free_namespace (omp_udr->initializer_ns); - free (omp_udr); - } -} - - -static gfc_omp_udr * -gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) -{ - gfc_symtree *st; - - if (ns == NULL) - ns = gfc_current_ns; - do - { - gfc_omp_udr *omp_udr; - - st = gfc_find_symtree (ns->omp_udr_root, name); - if (st != NULL) - { - for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) - if (ts == NULL) - return omp_udr; - else if (gfc_compare_types (&omp_udr->ts, ts)) - { - if (ts->type == BT_CHARACTER) - { - if (omp_udr->ts.u.cl->length == NULL) - return omp_udr; - if (ts->u.cl->length == NULL) - continue; - if (gfc_compare_expr (omp_udr->ts.u.cl->length, - ts->u.cl->length, - INTRINSIC_EQ) != 0) - continue; - } - return omp_udr; - } - } - - /* Don't escape an interface block. */ - if (ns && !ns->has_import_set - && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) - break; - - ns = ns->parent; - } - while (ns != NULL); - - return NULL; -} - - -/* Match a variable/common block list and construct a namelist from it. */ - -static match -gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, - bool allow_common, bool *end_colon = NULL, - gfc_omp_namelist ***headp = NULL, - bool allow_sections = false, - bool allow_derived = false) -{ - gfc_omp_namelist *head, *tail, *p; - locus old_loc, cur_loc; - char n[GFC_MAX_SYMBOL_LEN+1]; - gfc_symbol *sym; - match m; - gfc_symtree *st; - - head = tail = NULL; - - old_loc = gfc_current_locus; - - m = gfc_match (str); - if (m != MATCH_YES) - return m; - - for (;;) - { - cur_loc = gfc_current_locus; - m = gfc_match_symbol (&sym, 1); - switch (m) - { - case MATCH_YES: - gfc_expr *expr; - expr = NULL; - gfc_gobble_whitespace (); - if ((allow_sections && gfc_peek_ascii_char () == '(') - || (allow_derived && gfc_peek_ascii_char () == '%')) - { - gfc_current_locus = cur_loc; - m = gfc_match_variable (&expr, 0); - switch (m) - { - case MATCH_ERROR: - goto cleanup; - case MATCH_NO: - goto syntax; - default: - break; - } - if (gfc_is_coindexed (expr)) - { - gfc_error ("List item shall not be coindexed at %C"); - goto cleanup; - } - } - gfc_set_sym_referenced (sym); - p = gfc_get_omp_namelist (); - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = tail->next; - } - tail->sym = sym; - tail->expr = expr; - tail->where = cur_loc; - goto next_item; - case MATCH_NO: - break; - case MATCH_ERROR: - goto cleanup; - } - - if (!allow_common) - goto syntax; - - m = gfc_match (" / %n /", n); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - st = gfc_find_symtree (gfc_current_ns->common_root, n); - if (st == NULL) - { - gfc_error ("COMMON block /%s/ not found at %C", n); - goto cleanup; - } - for (sym = st->n.common->head; sym; sym = sym->common_next) - { - gfc_set_sym_referenced (sym); - p = gfc_get_omp_namelist (); - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = tail->next; - } - tail->sym = sym; - tail->where = cur_loc; - } - - next_item: - if (end_colon && gfc_match_char (':') == MATCH_YES) - { - *end_colon = true; - break; - } - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - while (*list) - list = &(*list)->next; - - *list = head; - if (headp) - *headp = list; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in OpenMP variable list at %C"); - -cleanup: - gfc_free_omp_namelist (head, false); - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - -/* Match a variable/procedure/common block list and construct a namelist - from it. */ - -static match -gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list) -{ - gfc_omp_namelist *head, *tail, *p; - locus old_loc, cur_loc; - char n[GFC_MAX_SYMBOL_LEN+1]; - gfc_symbol *sym; - match m; - gfc_symtree *st; - - head = tail = NULL; - - old_loc = gfc_current_locus; - - m = gfc_match (str); - if (m != MATCH_YES) - return m; - - for (;;) - { - cur_loc = gfc_current_locus; - m = gfc_match_symbol (&sym, 1); - switch (m) - { - case MATCH_YES: - p = gfc_get_omp_namelist (); - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = tail->next; - } - tail->sym = sym; - tail->where = cur_loc; - goto next_item; - case MATCH_NO: - break; - case MATCH_ERROR: - goto cleanup; - } - - m = gfc_match (" / %n /", n); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - st = gfc_find_symtree (gfc_current_ns->common_root, n); - if (st == NULL) - { - gfc_error ("COMMON block /%s/ not found at %C", n); - goto cleanup; - } - p = gfc_get_omp_namelist (); - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = tail->next; - } - tail->u.common = st->n.common; - tail->where = cur_loc; - - next_item: - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - while (*list) - list = &(*list)->next; - - *list = head; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in OpenMP variable list at %C"); - -cleanup: - gfc_free_omp_namelist (head, false); - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - -/* Match detach(event-handle). */ - -static match -gfc_match_omp_detach (gfc_expr **expr) -{ - locus old_loc = gfc_current_locus; - - if (gfc_match ("detach ( ") != MATCH_YES) - goto syntax_error; - - if (gfc_match_variable (expr, 0) != MATCH_YES) - goto syntax_error; - - if ((*expr)->ts.type != BT_INTEGER || (*expr)->ts.kind != gfc_c_intptr_kind) - { - gfc_error ("%qs at %L should be of type " - "integer(kind=omp_event_handle_kind)", - (*expr)->symtree->n.sym->name, &(*expr)->where); - return MATCH_ERROR; - } - - if (gfc_match_char (')') != MATCH_YES) - goto syntax_error; - - return MATCH_YES; - -syntax_error: - gfc_error ("Syntax error in OpenMP detach clause at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - -} - -/* Match depend(sink : ...) construct a namelist from it. */ - -static match -gfc_match_omp_depend_sink (gfc_omp_namelist **list) -{ - gfc_omp_namelist *head, *tail, *p; - locus old_loc, cur_loc; - gfc_symbol *sym; - - head = tail = NULL; - - old_loc = gfc_current_locus; - - for (;;) - { - cur_loc = gfc_current_locus; - switch (gfc_match_symbol (&sym, 1)) - { - case MATCH_YES: - gfc_set_sym_referenced (sym); - p = gfc_get_omp_namelist (); - if (head == NULL) - { - head = tail = p; - head->u.depend_op = OMP_DEPEND_SINK_FIRST; - } - else - { - tail->next = p; - tail = tail->next; - tail->u.depend_op = OMP_DEPEND_SINK; - } - tail->sym = sym; - tail->expr = NULL; - tail->where = cur_loc; - if (gfc_match_char ('+') == MATCH_YES) - { - if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) - goto syntax; - } - else if (gfc_match_char ('-') == MATCH_YES) - { - if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) - goto syntax; - tail->expr = gfc_uminus (tail->expr); - } - break; - case MATCH_NO: - goto syntax; - case MATCH_ERROR: - goto cleanup; - } - - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - while (*list) - list = &(*list)->next; - - *list = head; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C"); - -cleanup: - gfc_free_omp_namelist (head, false); - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - -static match -match_oacc_expr_list (const char *str, gfc_expr_list **list, - bool allow_asterisk) -{ - gfc_expr_list *head, *tail, *p; - locus old_loc; - gfc_expr *expr; - match m; - - head = tail = NULL; - - old_loc = gfc_current_locus; - - m = gfc_match (str); - if (m != MATCH_YES) - return m; - - for (;;) - { - m = gfc_match_expr (&expr); - if (m == MATCH_YES || allow_asterisk) - { - p = gfc_get_expr_list (); - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = tail->next; - } - if (m == MATCH_YES) - tail->expr = expr; - else if (gfc_match (" *") != MATCH_YES) - goto syntax; - goto next_item; - } - if (m == MATCH_ERROR) - goto cleanup; - goto syntax; - - next_item: - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - while (*list) - list = &(*list)->next; - - *list = head; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in OpenACC expression list at %C"); - -cleanup: - gfc_free_expr_list (head); - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - -static match -match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv) -{ - match ret = MATCH_YES; - - if (gfc_match (" ( ") != MATCH_YES) - return MATCH_NO; - - if (gwv == GOMP_DIM_GANG) - { - /* The gang clause accepts two optional arguments, num and static. - The num argument may either be explicit (num: ) or - implicit without ( without num:). */ - - while (ret == MATCH_YES) - { - if (gfc_match (" static :") == MATCH_YES) - { - if (cp->gang_static) - return MATCH_ERROR; - else - cp->gang_static = true; - if (gfc_match_char ('*') == MATCH_YES) - cp->gang_static_expr = NULL; - else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES) - return MATCH_ERROR; - } - else - { - if (cp->gang_num_expr) - return MATCH_ERROR; - - /* The 'num' argument is optional. */ - gfc_match (" num :"); - - if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES) - return MATCH_ERROR; - } - - ret = gfc_match (" , "); - } - } - else if (gwv == GOMP_DIM_WORKER) - { - /* The 'num' argument is optional. */ - gfc_match (" num :"); - - if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES) - return MATCH_ERROR; - } - else if (gwv == GOMP_DIM_VECTOR) - { - /* The 'length' argument is optional. */ - gfc_match (" length :"); - - if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES) - return MATCH_ERROR; - } - else - gfc_fatal_error ("Unexpected OpenACC parallelism."); - - return gfc_match (" )"); -} - -static match -gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list) -{ - gfc_omp_namelist *head = NULL; - gfc_omp_namelist *tail, *p; - locus old_loc; - char n[GFC_MAX_SYMBOL_LEN+1]; - gfc_symbol *sym; - match m; - gfc_symtree *st; - - old_loc = gfc_current_locus; - - m = gfc_match (str); - if (m != MATCH_YES) - return m; - - m = gfc_match (" ("); - - for (;;) - { - m = gfc_match_symbol (&sym, 0); - switch (m) - { - case MATCH_YES: - if (sym->attr.in_common) - { - gfc_error_now ("Variable at %C is an element of a COMMON block"); - goto cleanup; - } - gfc_set_sym_referenced (sym); - p = gfc_get_omp_namelist (); - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = tail->next; - } - tail->sym = sym; - tail->expr = NULL; - tail->where = gfc_current_locus; - goto next_item; - case MATCH_NO: - break; - - case MATCH_ERROR: - goto cleanup; - } - - m = gfc_match (" / %n /", n); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO || n[0] == '\0') - goto syntax; - - st = gfc_find_symtree (gfc_current_ns->common_root, n); - if (st == NULL) - { - gfc_error ("COMMON block /%s/ not found at %C", n); - goto cleanup; - } - - for (sym = st->n.common->head; sym; sym = sym->common_next) - { - gfc_set_sym_referenced (sym); - p = gfc_get_omp_namelist (); - if (head == NULL) - head = tail = p; - else - { - tail->next = p; - tail = tail->next; - } - tail->sym = sym; - tail->where = gfc_current_locus; - } - - next_item: - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after !$ACC DECLARE at %C"); - goto cleanup; - } - - while (*list) - list = &(*list)->next; - *list = head; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in !$ACC DECLARE list at %C"); - -cleanup: - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - -/* OpenMP clauses. */ -enum omp_mask1 -{ - OMP_CLAUSE_PRIVATE, - OMP_CLAUSE_FIRSTPRIVATE, - OMP_CLAUSE_LASTPRIVATE, - OMP_CLAUSE_COPYPRIVATE, - OMP_CLAUSE_SHARED, - OMP_CLAUSE_COPYIN, - OMP_CLAUSE_REDUCTION, - OMP_CLAUSE_IN_REDUCTION, - OMP_CLAUSE_TASK_REDUCTION, - OMP_CLAUSE_IF, - OMP_CLAUSE_NUM_THREADS, - OMP_CLAUSE_SCHEDULE, - OMP_CLAUSE_DEFAULT, - OMP_CLAUSE_ORDER, - OMP_CLAUSE_ORDERED, - OMP_CLAUSE_COLLAPSE, - OMP_CLAUSE_UNTIED, - OMP_CLAUSE_FINAL, - OMP_CLAUSE_MERGEABLE, - OMP_CLAUSE_ALIGNED, - OMP_CLAUSE_DEPEND, - OMP_CLAUSE_INBRANCH, - OMP_CLAUSE_LINEAR, - OMP_CLAUSE_NOTINBRANCH, - OMP_CLAUSE_PROC_BIND, - OMP_CLAUSE_SAFELEN, - OMP_CLAUSE_SIMDLEN, - OMP_CLAUSE_UNIFORM, - OMP_CLAUSE_DEVICE, - OMP_CLAUSE_MAP, - OMP_CLAUSE_TO, - OMP_CLAUSE_FROM, - OMP_CLAUSE_NUM_TEAMS, - OMP_CLAUSE_THREAD_LIMIT, - OMP_CLAUSE_DIST_SCHEDULE, - OMP_CLAUSE_DEFAULTMAP, - OMP_CLAUSE_GRAINSIZE, - OMP_CLAUSE_HINT, - OMP_CLAUSE_IS_DEVICE_PTR, - OMP_CLAUSE_LINK, - OMP_CLAUSE_NOGROUP, - OMP_CLAUSE_NOTEMPORAL, - OMP_CLAUSE_NUM_TASKS, - OMP_CLAUSE_PRIORITY, - OMP_CLAUSE_SIMD, - OMP_CLAUSE_THREADS, - OMP_CLAUSE_USE_DEVICE_PTR, - OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */ - OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */ - OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */ - OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */ - OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */ - OMP_CLAUSE_DETACH, /* OpenMP 5.0. */ - OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */ - OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */ - OMP_CLAUSE_BIND, /* OpenMP 5.0. */ - OMP_CLAUSE_FILTER, /* OpenMP 5.1. */ - OMP_CLAUSE_AT, /* OpenMP 5.1. */ - OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */ - OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */ - OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */ - OMP_CLAUSE_FAIL, /* OpenMP 5.1. */ - OMP_CLAUSE_WEAK, /* OpenMP 5.1. */ - OMP_CLAUSE_NOWAIT, - /* This must come last. */ - OMP_MASK1_LAST -}; - -/* OpenACC 2.0+ specific clauses. */ -enum omp_mask2 -{ - OMP_CLAUSE_ASYNC, - OMP_CLAUSE_NUM_GANGS, - OMP_CLAUSE_NUM_WORKERS, - OMP_CLAUSE_VECTOR_LENGTH, - OMP_CLAUSE_COPY, - OMP_CLAUSE_COPYOUT, - OMP_CLAUSE_CREATE, - OMP_CLAUSE_NO_CREATE, - OMP_CLAUSE_PRESENT, - OMP_CLAUSE_DEVICEPTR, - OMP_CLAUSE_GANG, - OMP_CLAUSE_WORKER, - OMP_CLAUSE_VECTOR, - OMP_CLAUSE_SEQ, - OMP_CLAUSE_INDEPENDENT, - OMP_CLAUSE_USE_DEVICE, - OMP_CLAUSE_DEVICE_RESIDENT, - OMP_CLAUSE_HOST_SELF, - OMP_CLAUSE_WAIT, - OMP_CLAUSE_DELETE, - OMP_CLAUSE_AUTO, - OMP_CLAUSE_TILE, - OMP_CLAUSE_IF_PRESENT, - OMP_CLAUSE_FINALIZE, - OMP_CLAUSE_ATTACH, - OMP_CLAUSE_NOHOST, - /* This must come last. */ - OMP_MASK2_LAST -}; - -struct omp_inv_mask; - -/* Customized bitset for up to 128-bits. - The two enums above provide bit numbers to use, and which of the - two enums it is determines which of the two mask fields is used. - Supported operations are defining a mask, like: - #define XXX_CLAUSES \ - (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ) - oring such bitsets together or removing selected bits: - (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV)) - and testing individual bits: - if (mask & OMP_CLAUSE_UUU) */ - -struct omp_mask { - const uint64_t mask1; - const uint64_t mask2; - inline omp_mask (); - inline omp_mask (omp_mask1); - inline omp_mask (omp_mask2); - inline omp_mask (uint64_t, uint64_t); - inline omp_mask operator| (omp_mask1) const; - inline omp_mask operator| (omp_mask2) const; - inline omp_mask operator| (omp_mask) const; - inline omp_mask operator& (const omp_inv_mask &) const; - inline bool operator& (omp_mask1) const; - inline bool operator& (omp_mask2) const; - inline omp_inv_mask operator~ () const; -}; - -struct omp_inv_mask : public omp_mask { - inline omp_inv_mask (const omp_mask &); -}; - -omp_mask::omp_mask () : mask1 (0), mask2 (0) -{ -} - -omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0) -{ -} - -omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m) -{ -} - -omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2) -{ -} - -omp_mask -omp_mask::operator| (omp_mask1 m) const -{ - return omp_mask (mask1 | (((uint64_t) 1) << m), mask2); -} - -omp_mask -omp_mask::operator| (omp_mask2 m) const -{ - return omp_mask (mask1, mask2 | (((uint64_t) 1) << m)); -} - -omp_mask -omp_mask::operator| (omp_mask m) const -{ - return omp_mask (mask1 | m.mask1, mask2 | m.mask2); -} - -omp_mask -omp_mask::operator& (const omp_inv_mask &m) const -{ - return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2); -} - -bool -omp_mask::operator& (omp_mask1 m) const -{ - return (mask1 & (((uint64_t) 1) << m)) != 0; -} - -bool -omp_mask::operator& (omp_mask2 m) const -{ - return (mask2 & (((uint64_t) 1) << m)) != 0; -} - -omp_inv_mask -omp_mask::operator~ () const -{ - return omp_inv_mask (*this); -} - -omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) -{ -} - -/* Helper function for OpenACC and OpenMP clauses involving memory - mapping. */ - -static bool -gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, - bool allow_common, bool allow_derived) -{ - gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true, - allow_derived) - == MATCH_YES) - { - gfc_omp_namelist *n; - for (n = *head; n; n = n->next) - n->u.map_op = map_op; - return true; - } - - return false; -} - -static match -gfc_match_iterator (gfc_namespace **ns, bool permit_var) -{ - locus old_loc = gfc_current_locus; - - if (gfc_match ("iterator ( ") != MATCH_YES) - return MATCH_NO; - - gfc_typespec ts; - gfc_symbol *last = NULL; - gfc_expr *begin, *end, *step; - *ns = gfc_build_block_ns (gfc_current_ns); - char name[GFC_MAX_SYMBOL_LEN + 1]; - while (true) - { - locus prev_loc = gfc_current_locus; - if (gfc_match_type_spec (&ts) == MATCH_YES - && gfc_match (" :: ") == MATCH_YES) - { - if (ts.type != BT_INTEGER) - { - gfc_error ("Expected INTEGER type at %L", &prev_loc); - return MATCH_ERROR; - } - permit_var = false; - } - else - { - ts.type = BT_INTEGER; - ts.kind = gfc_default_integer_kind; - gfc_current_locus = prev_loc; - } - prev_loc = gfc_current_locus; - if (gfc_match_name (name) != MATCH_YES) - { - gfc_error ("Expected identifier at %C"); - goto failed; - } - if (gfc_find_symtree ((*ns)->sym_root, name)) - { - gfc_error ("Same identifier %qs specified again at %C", name); - goto failed; - } - - gfc_symbol *sym = gfc_new_symbol (name, *ns); - if (last) - last->tlink = sym; - else - (*ns)->proc_name = sym; - last = sym; - sym->declared_at = prev_loc; - sym->ts = ts; - sym->attr.flavor = FL_VARIABLE; - sym->attr.artificial = 1; - sym->attr.referenced = 1; - sym->refs++; - gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name); - st->n.sym = sym; - - prev_loc = gfc_current_locus; - if (gfc_match (" = ") != MATCH_YES) - goto failed; - permit_var = false; - begin = end = step = NULL; - if (gfc_match ("%e : ", &begin) != MATCH_YES - || gfc_match ("%e ", &end) != MATCH_YES) - { - gfc_error ("Expected range-specification at %C"); - gfc_free_expr (begin); - gfc_free_expr (end); - return MATCH_ERROR; - } - if (':' == gfc_peek_ascii_char ()) - { - step = gfc_get_expr (); - if (gfc_match (": %e ", &step) != MATCH_YES) - { - gfc_free_expr (begin); - gfc_free_expr (end); - gfc_free_expr (step); - goto failed; - } - } - - gfc_expr *e = gfc_get_expr (); - e->where = prev_loc; - e->expr_type = EXPR_ARRAY; - e->ts = ts; - e->rank = 1; - e->shape = gfc_get_shape (1); - mpz_init_set_ui (e->shape[0], step ? 3 : 2); - gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where); - gfc_constructor_append_expr (&e->value.constructor, end, &end->where); - if (step) - gfc_constructor_append_expr (&e->value.constructor, step, &step->where); - sym->value = e; - - if (gfc_match (") ") == MATCH_YES) - break; - if (gfc_match (", ") != MATCH_YES) - goto failed; - } - return MATCH_YES; - -failed: - gfc_namespace *prev_ns = NULL; - for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling) - { - if (it == *ns) - { - if (prev_ns) - prev_ns->sibling = it->sibling; - else - gfc_current_ns->contained = it->sibling; - gfc_free_namespace (it); - break; - } - prev_ns = it; - } - *ns = NULL; - if (!permit_var) - return MATCH_ERROR; - gfc_current_locus = old_loc; - return MATCH_NO; -} - -/* reduction ( reduction-modifier, reduction-operator : variable-list ) - in_reduction ( reduction-operator : variable-list ) - task_reduction ( reduction-operator : variable-list ) */ - -static match -gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, - bool allow_derived, bool openmp_target = false) -{ - if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES) - return MATCH_NO; - else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES) - return MATCH_NO; - else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES) - return MATCH_NO; - - locus old_loc = gfc_current_locus; - int list_idx = 0; - - if (pc == 'r' && !openacc) - { - if (gfc_match ("inscan") == MATCH_YES) - list_idx = OMP_LIST_REDUCTION_INSCAN; - else if (gfc_match ("task") == MATCH_YES) - list_idx = OMP_LIST_REDUCTION_TASK; - else if (gfc_match ("default") == MATCH_YES) - list_idx = OMP_LIST_REDUCTION; - if (list_idx != 0 && gfc_match (", ") != MATCH_YES) - { - gfc_error ("Comma expected at %C"); - gfc_current_locus = old_loc; - return MATCH_NO; - } - if (list_idx == 0) - list_idx = OMP_LIST_REDUCTION; - } - else if (pc == 'i') - list_idx = OMP_LIST_IN_REDUCTION; - else if (pc == 't') - list_idx = OMP_LIST_TASK_REDUCTION; - else - list_idx = OMP_LIST_REDUCTION; - - gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; - char buffer[GFC_MAX_SYMBOL_LEN + 3]; - if (gfc_match_char ('+') == MATCH_YES) - rop = OMP_REDUCTION_PLUS; - else if (gfc_match_char ('*') == MATCH_YES) - rop = OMP_REDUCTION_TIMES; - else if (gfc_match_char ('-') == MATCH_YES) - rop = OMP_REDUCTION_MINUS; - else if (gfc_match (".and.") == MATCH_YES) - rop = OMP_REDUCTION_AND; - else if (gfc_match (".or.") == MATCH_YES) - rop = OMP_REDUCTION_OR; - else if (gfc_match (".eqv.") == MATCH_YES) - rop = OMP_REDUCTION_EQV; - else if (gfc_match (".neqv.") == MATCH_YES) - rop = OMP_REDUCTION_NEQV; - if (rop != OMP_REDUCTION_NONE) - snprintf (buffer, sizeof buffer, "operator %s", - gfc_op2string ((gfc_intrinsic_op) rop)); - else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES) - { - buffer[0] = '.'; - strcat (buffer, "."); - } - else if (gfc_match_name (buffer) == MATCH_YES) - { - gfc_symbol *sym; - const char *n = buffer; - - gfc_find_symbol (buffer, NULL, 1, &sym); - if (sym != NULL) - { - if (sym->attr.intrinsic) - n = sym->name; - else if ((sym->attr.flavor != FL_UNKNOWN - && sym->attr.flavor != FL_PROCEDURE) - || sym->attr.external - || sym->attr.generic - || sym->attr.entry - || sym->attr.result - || sym->attr.dummy - || sym->attr.subroutine - || sym->attr.pointer - || sym->attr.target - || sym->attr.cray_pointer - || sym->attr.cray_pointee - || (sym->attr.proc != PROC_UNKNOWN - && sym->attr.proc != PROC_INTRINSIC) - || sym->attr.if_source != IFSRC_UNKNOWN - || sym == sym->ns->proc_name) - { - sym = NULL; - n = NULL; - } - else - n = sym->name; - } - if (n == NULL) - rop = OMP_REDUCTION_NONE; - else if (strcmp (n, "max") == 0) - rop = OMP_REDUCTION_MAX; - else if (strcmp (n, "min") == 0) - rop = OMP_REDUCTION_MIN; - else if (strcmp (n, "iand") == 0) - rop = OMP_REDUCTION_IAND; - else if (strcmp (n, "ior") == 0) - rop = OMP_REDUCTION_IOR; - else if (strcmp (n, "ieor") == 0) - rop = OMP_REDUCTION_IEOR; - if (rop != OMP_REDUCTION_NONE - && sym != NULL - && ! sym->attr.intrinsic - && ! sym->attr.use_assoc - && ((sym->attr.flavor == FL_UNKNOWN - && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, - sym->name, NULL)) - || !gfc_add_intrinsic (&sym->attr, NULL))) - rop = OMP_REDUCTION_NONE; - } - else - buffer[0] = '\0'; - gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) - : NULL); - gfc_omp_namelist **head = NULL; - if (rop == OMP_REDUCTION_NONE && udr) - rop = OMP_REDUCTION_USER; - - if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL, - &head, openacc, allow_derived) != MATCH_YES) - { - gfc_current_locus = old_loc; - return MATCH_NO; - } - gfc_omp_namelist *n; - if (rop == OMP_REDUCTION_NONE) - { - n = *head; - *head = NULL; - gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L", - buffer, &old_loc); - gfc_free_omp_namelist (n, false); - } - else - for (n = *head; n; n = n->next) - { - n->u.reduction_op = rop; - if (udr) - { - n->u2.udr = gfc_get_omp_namelist_udr (); - n->u2.udr->udr = udr; - } - if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION) - { - gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl; - p->sym = n->sym; - p->where = p->where; - p->u.map_op = OMP_MAP_ALWAYS_TOFROM; - - tl = &c->lists[OMP_LIST_MAP]; - while (*tl) - tl = &((*tl)->next); - *tl = p; - p->next = NULL; - } - } - return MATCH_YES; -} - - -/* Match with duplicate check. Matches 'name'. If expr != NULL, it - then matches '(expr)', otherwise, if open_parens is true, - it matches a ' ( ' after 'name'. - dupl_message requires '%qs %L' - and is used by - gfc_match_dupl_memorder and gfc_match_dupl_atomic. */ - -static match -gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false, - gfc_expr **expr = NULL, const char *dupl_msg = NULL) -{ - match m; - locus old_loc = gfc_current_locus; - if ((m = gfc_match (name)) != MATCH_YES) - return m; - if (!not_dupl) - { - if (dupl_msg) - gfc_error (dupl_msg, name, &old_loc); - else - gfc_error ("Duplicated %qs clause at %L", name, &old_loc); - return MATCH_ERROR; - } - if (open_parens || expr) - { - if (gfc_match (" ( ") != MATCH_YES) - { - gfc_error ("Expected %<(%> after %qs at %C", name); - return MATCH_ERROR; - } - if (expr) - { - if (gfc_match ("%e )", expr) != MATCH_YES) - { - gfc_error ("Invalid expression after %<%s(%> at %C", name); - return MATCH_ERROR; - } - } - } - return MATCH_YES; -} - -static match -gfc_match_dupl_memorder (bool not_dupl, const char *name) -{ - return gfc_match_dupl_check (not_dupl, name, false, NULL, - "Duplicated memory-order clause: unexpected %s " - "clause at %L"); -} - -static match -gfc_match_dupl_atomic (bool not_dupl, const char *name) -{ - return gfc_match_dupl_check (not_dupl, name, false, NULL, - "Duplicated atomic clause: unexpected %s " - "clause at %L"); -} - -/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of - clauses that are allowed for a particular directive. */ - -static match -gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, - bool first = true, bool needs_space = true, - bool openacc = false, bool context_selector = false, - bool openmp_target = false) -{ - bool error = false; - gfc_omp_clauses *c = gfc_get_omp_clauses (); - locus old_loc; - /* Determine whether we're dealing with an OpenACC directive that permits - derived type member accesses. This in particular disallows - "!$acc declare" from using such accesses, because it's not clear if/how - that should work. */ - bool allow_derived = (openacc - && ((mask & OMP_CLAUSE_ATTACH) - || (mask & OMP_CLAUSE_DETACH) - || (mask & OMP_CLAUSE_HOST_SELF))); - - gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); - *cp = NULL; - while (1) - { - match m = MATCH_NO; - if ((first || (m = gfc_match_char (',')) != MATCH_YES) - && (needs_space && gfc_match_space () != MATCH_YES)) - break; - needs_space = false; - first = false; - gfc_gobble_whitespace (); - bool end_colon; - gfc_omp_namelist **head; - old_loc = gfc_current_locus; - char pc = gfc_peek_ascii_char (); - if (pc == '\n' && m == MATCH_YES) - { - gfc_error ("Clause expected at %C after trailing comma"); - goto error; - } - switch (pc) - { - case 'a': - end_colon = false; - head = NULL; - if ((mask & OMP_CLAUSE_ALIGNED) - && gfc_match_omp_variable_list ("aligned (", - &c->lists[OMP_LIST_ALIGNED], - false, &end_colon, - &head) == MATCH_YES) - { - gfc_expr *alignment = NULL; - gfc_omp_namelist *n; - - if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) - { - gfc_free_omp_namelist (*head, false); - gfc_current_locus = old_loc; - *head = NULL; - break; - } - for (n = *head; n; n = n->next) - if (n->next && alignment) - n->expr = gfc_copy_expr (alignment); - else - n->expr = alignment; - continue; - } - if ((mask & OMP_CLAUSE_MEMORDER) - && (m = gfc_match_dupl_memorder ((c->memorder - == OMP_MEMORDER_UNSET), - "acq_rel")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->memorder = OMP_MEMORDER_ACQ_REL; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_MEMORDER) - && (m = gfc_match_dupl_memorder ((c->memorder - == OMP_MEMORDER_UNSET), - "acquire")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->memorder = OMP_MEMORDER_ACQUIRE; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_AFFINITY) - && gfc_match ("affinity ( ") == MATCH_YES) - { - gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; - m = gfc_match_iterator (&ns_iter, true); - if (m == MATCH_ERROR) - break; - if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES) - { - gfc_error ("Expected %<:%> at %C"); - break; - } - if (ns_iter) - gfc_current_ns = ns_iter; - head = NULL; - m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY], - false, NULL, &head, true); - gfc_current_ns = ns_curr; - if (m == MATCH_ERROR) - break; - if (ns_iter) - { - for (gfc_omp_namelist *n = *head; n; n = n->next) - { - n->u2.ns = ns_iter; - ns_iter->refs++; - } - } - continue; - } - if ((mask & OMP_CLAUSE_ALLOCATE) - && gfc_match ("allocate ( ") == MATCH_YES) - { - gfc_expr *allocator = NULL; - old_loc = gfc_current_locus; - m = gfc_match_expr (&allocator); - if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES) - { - /* If no ":" then there is no allocator, we backtrack - and read the variable list. */ - gfc_free_expr (allocator); - allocator = NULL; - gfc_current_locus = old_loc; - } - - gfc_omp_namelist **head = NULL; - m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE], - true, NULL, &head); - - if (m != MATCH_YES) - { - gfc_free_expr (allocator); - gfc_error ("Expected variable list at %C"); - goto error; - } - - for (gfc_omp_namelist *n = *head; n; n = n->next) - if (allocator) - n->expr = gfc_copy_expr (allocator); - else - n->expr = NULL; - gfc_free_expr (allocator); - continue; - } - if ((mask & OMP_CLAUSE_AT) - && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("compilation )") == MATCH_YES) - c->at = OMP_AT_COMPILATION; - else if (gfc_match ("execution )") == MATCH_YES) - c->at = OMP_AT_EXECUTION; - else - { - gfc_error ("Expected COMPILATION or EXECUTION in AT clause " - "at %C"); - goto error; - } - continue; - } - if ((mask & OMP_CLAUSE_ASYNC) - && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->async = true; - m = gfc_match (" ( %e )", &c->async_expr); - if (m == MATCH_ERROR) - { - gfc_current_locus = old_loc; - break; - } - else if (m == MATCH_NO) - { - c->async_expr - = gfc_get_constant_expr (BT_INTEGER, - gfc_default_integer_kind, - &gfc_current_locus); - mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL); - needs_space = true; - } - continue; - } - if ((mask & OMP_CLAUSE_AUTO) - && (m = gfc_match_dupl_check (!c->par_auto, "auto")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->par_auto = true; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_ATTACH) - && gfc_match ("attach ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ATTACH, false, - allow_derived)) - continue; - break; - case 'b': - if ((mask & OMP_CLAUSE_BIND) - && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind", - true)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("teams )") == MATCH_YES) - c->bind = OMP_BIND_TEAMS; - else if (gfc_match ("parallel )") == MATCH_YES) - c->bind = OMP_BIND_PARALLEL; - else if (gfc_match ("thread )") == MATCH_YES) - c->bind = OMP_BIND_THREAD; - else - { - gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in " - "BIND at %C"); - break; - } - continue; - } - break; - case 'c': - if ((mask & OMP_CLAUSE_CAPTURE) - && (m = gfc_match_dupl_check (!c->capture, "capture")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->capture = true; - needs_space = true; - continue; - } - if (mask & OMP_CLAUSE_COLLAPSE) - { - gfc_expr *cexpr = NULL; - if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true, - &cexpr)) != MATCH_NO) - { - int collapse; - if (m == MATCH_ERROR) - goto error; - if (gfc_extract_int (cexpr, &collapse, -1)) - collapse = 1; - else if (collapse <= 0) - { - gfc_error_now ("COLLAPSE clause argument not constant " - "positive integer at %C"); - collapse = 1; - } - gfc_free_expr (cexpr); - c->collapse = collapse; - continue; - } - } - if ((mask & OMP_CLAUSE_COMPARE) - && (m = gfc_match_dupl_check (!c->compare, "compare")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->compare = true; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_COPY) - && gfc_match ("copy ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true, - allow_derived)) - continue; - if (mask & OMP_CLAUSE_COPYIN) - { - if (openacc) - { - if (gfc_match ("copyin ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true, - allow_derived)) - continue; - } - else if (gfc_match_omp_variable_list ("copyin (", - &c->lists[OMP_LIST_COPYIN], - true) == MATCH_YES) - continue; - } - if ((mask & OMP_CLAUSE_COPYOUT) - && gfc_match ("copyout ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_COPYPRIVATE) - && gfc_match_omp_variable_list ("copyprivate (", - &c->lists[OMP_LIST_COPYPRIVATE], - true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_CREATE) - && gfc_match ("create ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true, allow_derived)) - continue; - break; - case 'd': - if ((mask & OMP_CLAUSE_DEFAULTMAP) - && gfc_match ("defaultmap ( ") == MATCH_YES) - { - enum gfc_omp_defaultmap behavior; - gfc_omp_defaultmap_category category - = OMP_DEFAULTMAP_CAT_UNCATEGORIZED; - if (gfc_match ("alloc ") == MATCH_YES) - behavior = OMP_DEFAULTMAP_ALLOC; - else if (gfc_match ("tofrom ") == MATCH_YES) - behavior = OMP_DEFAULTMAP_TOFROM; - else if (gfc_match ("to ") == MATCH_YES) - behavior = OMP_DEFAULTMAP_TO; - else if (gfc_match ("from ") == MATCH_YES) - behavior = OMP_DEFAULTMAP_FROM; - else if (gfc_match ("firstprivate ") == MATCH_YES) - behavior = OMP_DEFAULTMAP_FIRSTPRIVATE; - else if (gfc_match ("none ") == MATCH_YES) - behavior = OMP_DEFAULTMAP_NONE; - else if (gfc_match ("default ") == MATCH_YES) - behavior = OMP_DEFAULTMAP_DEFAULT; - else - { - gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, " - "NONE or DEFAULT at %C"); - break; - } - if (')' == gfc_peek_ascii_char ()) - ; - else if (gfc_match (": ") != MATCH_YES) - break; - else - { - if (gfc_match ("scalar ") == MATCH_YES) - category = OMP_DEFAULTMAP_CAT_SCALAR; - else if (gfc_match ("aggregate ") == MATCH_YES) - category = OMP_DEFAULTMAP_CAT_AGGREGATE; - else if (gfc_match ("allocatable ") == MATCH_YES) - category = OMP_DEFAULTMAP_CAT_ALLOCATABLE; - else if (gfc_match ("pointer ") == MATCH_YES) - category = OMP_DEFAULTMAP_CAT_POINTER; - else - { - gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE or " - "POINTER at %C"); - break; - } - } - for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i) - { - if (i != category - && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED) - continue; - if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET) - { - const char *pcategory = NULL; - switch (i) - { - case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break; - case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break; - case OMP_DEFAULTMAP_CAT_AGGREGATE: - pcategory = "AGGREGATE"; - break; - case OMP_DEFAULTMAP_CAT_ALLOCATABLE: - pcategory = "ALLOCATABLE"; - break; - case OMP_DEFAULTMAP_CAT_POINTER: - pcategory = "POINTER"; - break; - default: gcc_unreachable (); - } - if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED) - gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with " - "unspecified category"); - else - gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for " - "category %s", pcategory); - goto error; - } - } - c->defaultmap[category] = behavior; - if (gfc_match (")") != MATCH_YES) - break; - continue; - } - if ((mask & OMP_CLAUSE_DEFAULT) - && (m = gfc_match_dupl_check (c->default_sharing - == OMP_DEFAULT_UNKNOWN, "default", - true)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("none") == MATCH_YES) - c->default_sharing = OMP_DEFAULT_NONE; - else if (openacc) - { - if (gfc_match ("present") == MATCH_YES) - c->default_sharing = OMP_DEFAULT_PRESENT; - } - else - { - if (gfc_match ("firstprivate") == MATCH_YES) - c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; - else if (gfc_match ("private") == MATCH_YES) - c->default_sharing = OMP_DEFAULT_PRIVATE; - else if (gfc_match ("shared") == MATCH_YES) - c->default_sharing = OMP_DEFAULT_SHARED; - } - if (c->default_sharing == OMP_DEFAULT_UNKNOWN) - { - if (openacc) - gfc_error ("Expected NONE or PRESENT in DEFAULT clause " - "at %C"); - else - gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED " - "in DEFAULT clause at %C"); - goto error; - } - if (gfc_match (" )") != MATCH_YES) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_DELETE) - && gfc_match ("delete ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_RELEASE, true, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_DEPEND) - && gfc_match ("depend ( ") == MATCH_YES) - { - gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; - match m_it = gfc_match_iterator (&ns_iter, false); - if (m_it == MATCH_ERROR) - break; - if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES) - break; - m = MATCH_YES; - gfc_omp_depend_op depend_op = OMP_DEPEND_OUT; - if (gfc_match ("inout") == MATCH_YES) - depend_op = OMP_DEPEND_INOUT; - else if (gfc_match ("in") == MATCH_YES) - depend_op = OMP_DEPEND_IN; - else if (gfc_match ("out") == MATCH_YES) - depend_op = OMP_DEPEND_OUT; - else if (gfc_match ("mutexinoutset") == MATCH_YES) - depend_op = OMP_DEPEND_MUTEXINOUTSET; - else if (gfc_match ("depobj") == MATCH_YES) - depend_op = OMP_DEPEND_DEPOBJ; - else if (!c->depend_source - && gfc_match ("source )") == MATCH_YES) - { - if (m_it == MATCH_YES) - { - gfc_error ("ITERATOR may not be combined with SOURCE " - "at %C"); - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - c->depend_source = true; - continue; - } - else if (gfc_match ("sink : ") == MATCH_YES) - { - if (m_it == MATCH_YES) - { - gfc_error ("ITERATOR may not be combined with SINK " - "at %C"); - break; - } - if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND]) - == MATCH_YES) - continue; - m = MATCH_NO; - } - else - m = MATCH_NO; - head = NULL; - if (ns_iter) - gfc_current_ns = ns_iter; - if (m == MATCH_YES) - m = gfc_match_omp_variable_list (" : ", - &c->lists[OMP_LIST_DEPEND], - false, NULL, &head, true); - gfc_current_ns = ns_curr; - if (m == MATCH_YES) - { - gfc_omp_namelist *n; - for (n = *head; n; n = n->next) - { - n->u.depend_op = depend_op; - n->u2.ns = ns_iter; - if (ns_iter) - ns_iter->refs++; - } - continue; - } - break; - } - if ((mask & OMP_CLAUSE_DETACH) - && !openacc - && !c->detach - && gfc_match_omp_detach (&c->detach) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_DETACH) - && openacc - && gfc_match ("detach ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_DETACH, false, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_DEVICE) - && !openacc - && ((m = gfc_match_dupl_check (!c->device, "device", true)) - != MATCH_NO)) - { - if (m == MATCH_ERROR) - goto error; - c->ancestor = false; - if (gfc_match ("device_num : ") == MATCH_YES) - { - if (gfc_match ("%e )", &c->device) != MATCH_YES) - { - gfc_error ("Expected integer expression at %C"); - break; - } - } - else if (gfc_match ("ancestor : ") == MATCH_YES) - { - c->ancestor = true; - if (!(gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) - { - gfc_error ("% device modifier not " - "preceded by % directive " - "with % clause at %C"); - break; - } - locus old_loc2 = gfc_current_locus; - if (gfc_match ("%e )", &c->device) == MATCH_YES) - { - int device = 0; - if (!gfc_extract_int (c->device, &device) && device != 1) - { - gfc_current_locus = old_loc2; - gfc_error ("the % clause expression must " - "evaluate to %<1%> at %C"); - break; - } - } - else - { - gfc_error ("Expected integer expression at %C"); - break; - } - } - else if (gfc_match ("%e )", &c->device) != MATCH_YES) - { - gfc_error ("Expected integer expression or a single device-" - "modifier % or % at %C"); - break; - } - continue; - } - if ((mask & OMP_CLAUSE_DEVICE) - && openacc - && gfc_match ("device ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TO, true, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_DEVICEPTR) - && gfc_match ("deviceptr ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_DEVICEPTR, false, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_DEVICE_TYPE) - && gfc_match ("device_type ( ") == MATCH_YES) - { - if (gfc_match ("host") == MATCH_YES) - c->device_type = OMP_DEVICE_TYPE_HOST; - else if (gfc_match ("nohost") == MATCH_YES) - c->device_type = OMP_DEVICE_TYPE_NOHOST; - else if (gfc_match ("any") == MATCH_YES) - c->device_type = OMP_DEVICE_TYPE_ANY; - else - { - gfc_error ("Expected HOST, NOHOST or ANY at %C"); - break; - } - if (gfc_match (" )") != MATCH_YES) - break; - continue; - } - if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) - && gfc_match_omp_variable_list - ("device_resident (", - &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_DIST_SCHEDULE) - && c->dist_sched_kind == OMP_SCHED_NONE - && gfc_match ("dist_schedule ( static") == MATCH_YES) - { - m = MATCH_NO; - c->dist_sched_kind = OMP_SCHED_STATIC; - m = gfc_match (" , %e )", &c->dist_chunk_size); - if (m != MATCH_YES) - m = gfc_match_char (')'); - if (m != MATCH_YES) - { - c->dist_sched_kind = OMP_SCHED_NONE; - gfc_current_locus = old_loc; - } - else - continue; - } - break; - case 'f': - if ((mask & OMP_CLAUSE_FAIL) - && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET, - "fail", true)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("seq_cst") == MATCH_YES) - c->fail = OMP_MEMORDER_SEQ_CST; - else if (gfc_match ("acquire") == MATCH_YES) - c->fail = OMP_MEMORDER_ACQUIRE; - else if (gfc_match ("relaxed") == MATCH_YES) - c->fail = OMP_MEMORDER_RELAXED; - else - { - gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C"); - break; - } - if (gfc_match (" )") != MATCH_YES) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_FILTER) - && (m = gfc_match_dupl_check (!c->filter, "filter", true, - &c->filter)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_FINAL) - && (m = gfc_match_dupl_check (!c->final_expr, "final", true, - &c->final_expr)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_FINALIZE) - && (m = gfc_match_dupl_check (!c->finalize, "finalize")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->finalize = true; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_FIRSTPRIVATE) - && gfc_match_omp_variable_list ("firstprivate (", - &c->lists[OMP_LIST_FIRSTPRIVATE], - true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_FROM) - && gfc_match_omp_variable_list ("from (", - &c->lists[OMP_LIST_FROM], false, - NULL, &head, true) == MATCH_YES) - continue; - break; - case 'g': - if ((mask & OMP_CLAUSE_GANG) - && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->gang = true; - m = match_oacc_clause_gwv (c, GOMP_DIM_GANG); - if (m == MATCH_ERROR) - { - gfc_current_locus = old_loc; - break; - } - else if (m == MATCH_NO) - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_GRAINSIZE) - && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("strict : ") == MATCH_YES) - c->grainsize_strict = true; - if (gfc_match (" %e )", &c->grainsize) != MATCH_YES) - goto error; - continue; - } - break; - case 'h': - if ((mask & OMP_CLAUSE_HINT) - && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_HOST_SELF) - && gfc_match ("host ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM, true, - allow_derived)) - continue; - break; - case 'i': - if ((mask & OMP_CLAUSE_IF_PRESENT) - && (m = gfc_match_dupl_check (!c->if_present, "if_present")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->if_present = true; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_IF) - && (m = gfc_match_dupl_check (!c->if_expr, "if", true)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (!openacc) - { - /* This should match the enum gfc_omp_if_kind order. */ - static const char *ifs[OMP_IF_LAST] = { - "cancel : %e )", - "parallel : %e )", - "simd : %e )", - "task : %e )", - "taskloop : %e )", - "target : %e )", - "target data : %e )", - "target update : %e )", - "target enter data : %e )", - "target exit data : %e )" }; - int i; - for (i = 0; i < OMP_IF_LAST; i++) - if (c->if_exprs[i] == NULL - && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES) - break; - if (i < OMP_IF_LAST) - continue; - } - if (gfc_match (" %e )", &c->if_expr) == MATCH_YES) - continue; - goto error; - } - if ((mask & OMP_CLAUSE_IN_REDUCTION) - && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived, - openmp_target) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_INBRANCH) - && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch, - "inbranch")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->inbranch = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_INDEPENDENT) - && (m = gfc_match_dupl_check (!c->independent, "independent")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->independent = true; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_IS_DEVICE_PTR) - && gfc_match_omp_variable_list - ("is_device_ptr (", - &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES) - continue; - break; - case 'l': - if ((mask & OMP_CLAUSE_LASTPRIVATE) - && gfc_match ("lastprivate ( ") == MATCH_YES) - { - bool conditional = gfc_match ("conditional : ") == MATCH_YES; - head = NULL; - if (gfc_match_omp_variable_list ("", - &c->lists[OMP_LIST_LASTPRIVATE], - false, NULL, &head) == MATCH_YES) - { - gfc_omp_namelist *n; - for (n = *head; n; n = n->next) - n->u.lastprivate_conditional = conditional; - continue; - } - gfc_current_locus = old_loc; - break; - } - end_colon = false; - head = NULL; - if ((mask & OMP_CLAUSE_LINEAR) - && gfc_match ("linear (") == MATCH_YES) - { - gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; - gfc_expr *step = NULL; - - if (gfc_match_omp_variable_list (" ref (", - &c->lists[OMP_LIST_LINEAR], - false, NULL, &head) - == MATCH_YES) - linear_op = OMP_LINEAR_REF; - else if (gfc_match_omp_variable_list (" val (", - &c->lists[OMP_LIST_LINEAR], - false, NULL, &head) - == MATCH_YES) - linear_op = OMP_LINEAR_VAL; - else if (gfc_match_omp_variable_list (" uval (", - &c->lists[OMP_LIST_LINEAR], - false, NULL, &head) - == MATCH_YES) - linear_op = OMP_LINEAR_UVAL; - else if (gfc_match_omp_variable_list ("", - &c->lists[OMP_LIST_LINEAR], - false, &end_colon, &head) - == MATCH_YES) - linear_op = OMP_LINEAR_DEFAULT; - else - { - gfc_current_locus = old_loc; - break; - } - if (linear_op != OMP_LINEAR_DEFAULT) - { - if (gfc_match (" :") == MATCH_YES) - end_colon = true; - else if (gfc_match (" )") != MATCH_YES) - { - gfc_free_omp_namelist (*head, false); - gfc_current_locus = old_loc; - *head = NULL; - break; - } - } - if (end_colon && gfc_match (" %e )", &step) != MATCH_YES) - { - gfc_free_omp_namelist (*head, false); - gfc_current_locus = old_loc; - *head = NULL; - break; - } - else if (!end_colon) - { - step = gfc_get_constant_expr (BT_INTEGER, - gfc_default_integer_kind, - &old_loc); - mpz_set_si (step->value.integer, 1); - } - (*head)->expr = step; - if (linear_op != OMP_LINEAR_DEFAULT) - for (gfc_omp_namelist *n = *head; n; n = n->next) - n->u.linear_op = linear_op; - continue; - } - if ((mask & OMP_CLAUSE_LINK) - && openacc - && (gfc_match_oacc_clause_link ("link (", - &c->lists[OMP_LIST_LINK]) - == MATCH_YES)) - continue; - else if ((mask & OMP_CLAUSE_LINK) - && !openacc - && (gfc_match_omp_to_link ("link (", - &c->lists[OMP_LIST_LINK]) - == MATCH_YES)) - continue; - break; - case 'm': - if ((mask & OMP_CLAUSE_MAP) - && gfc_match ("map ( ") == MATCH_YES) - { - locus old_loc2 = gfc_current_locus; - int always_modifier = 0; - int close_modifier = 0; - locus second_always_locus = old_loc2; - locus second_close_locus = old_loc2; - - for (;;) - { - locus current_locus = gfc_current_locus; - if (gfc_match ("always ") == MATCH_YES) - { - if (always_modifier++ == 1) - second_always_locus = current_locus; - } - else if (gfc_match ("close ") == MATCH_YES) - { - if (close_modifier++ == 1) - second_close_locus = current_locus; - } - else - break; - gfc_match (", "); - } - - gfc_omp_map_op map_op = OMP_MAP_TOFROM; - if (gfc_match ("alloc : ") == MATCH_YES) - map_op = OMP_MAP_ALLOC; - else if (gfc_match ("tofrom : ") == MATCH_YES) - map_op = always_modifier ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM; - else if (gfc_match ("to : ") == MATCH_YES) - map_op = always_modifier ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO; - else if (gfc_match ("from : ") == MATCH_YES) - map_op = always_modifier ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM; - else if (gfc_match ("release : ") == MATCH_YES) - map_op = OMP_MAP_RELEASE; - else if (gfc_match ("delete : ") == MATCH_YES) - map_op = OMP_MAP_DELETE; - else - { - gfc_current_locus = old_loc2; - always_modifier = 0; - close_modifier = 0; - } - - if (always_modifier > 1) - { - gfc_error ("too many % modifiers at %L", - &second_always_locus); - break; - } - if (close_modifier > 1) - { - gfc_error ("too many % modifiers at %L", - &second_close_locus); - break; - } - - head = NULL; - if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], - false, NULL, &head, - true, true) == MATCH_YES) - { - gfc_omp_namelist *n; - for (n = *head; n; n = n->next) - n->u.map_op = map_op; - continue; - } - gfc_current_locus = old_loc; - break; - } - if ((mask & OMP_CLAUSE_MERGEABLE) - && (m = gfc_match_dupl_check (!c->mergeable, "mergeable")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->mergeable = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_MESSAGE) - && (m = gfc_match_dupl_check (!c->message, "message", true, - &c->message)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - break; - case 'n': - if ((mask & OMP_CLAUSE_NO_CREATE) - && gfc_match ("no_create ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_IF_PRESENT, true, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_NOGROUP) - && (m = gfc_match_dupl_check (!c->nogroup, "nogroup")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->nogroup = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_NOHOST) - && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->nohost = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_NOTEMPORAL) - && gfc_match_omp_variable_list ("nontemporal (", - &c->lists[OMP_LIST_NONTEMPORAL], - true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_NOTINBRANCH) - && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch, - "notinbranch")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->notinbranch = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_NOWAIT) - && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->nowait = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_NUM_GANGS) - && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs", - true)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_NUM_TASKS) - && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("strict : ") == MATCH_YES) - c->num_tasks_strict = true; - if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_NUM_TEAMS) - && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams", - true)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES) - goto error; - if (gfc_peek_ascii_char () == ':') - { - c->num_teams_lower = c->num_teams_upper; - c->num_teams_upper = NULL; - if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES) - goto error; - } - if (gfc_match (") ") != MATCH_YES) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_NUM_THREADS) - && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true, - &c->num_threads)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_NUM_WORKERS) - && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers", - true, &c->num_workers_expr)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - break; - case 'o': - if ((mask & OMP_CLAUSE_ORDER) - && (m = gfc_match_dupl_check (!c->order_concurrent, "order (")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match (" reproducible : concurrent )") == MATCH_YES) - c->order_reproducible = true; - else if (gfc_match (" concurrent )") == MATCH_YES) - ; - else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES) - c->order_unconstrained = true; - else - { - gfc_error ("Expected ORDER(CONCURRENT) at %C " - "with optional % or " - "% modifier"); - goto error; - } - c->order_concurrent = true; - continue; - } - if ((mask & OMP_CLAUSE_ORDERED) - && (m = gfc_match_dupl_check (!c->ordered, "ordered")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - gfc_expr *cexpr = NULL; - m = gfc_match (" ( %e )", &cexpr); - - c->ordered = true; - if (m == MATCH_YES) - { - int ordered = 0; - if (gfc_extract_int (cexpr, &ordered, -1)) - ordered = 0; - else if (ordered <= 0) - { - gfc_error_now ("ORDERED clause argument not" - " constant positive integer at %C"); - ordered = 0; - } - c->orderedc = ordered; - gfc_free_expr (cexpr); - continue; - } - - needs_space = true; - continue; - } - break; - case 'p': - if ((mask & OMP_CLAUSE_COPY) - && gfc_match ("pcopy ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_COPYIN) - && gfc_match ("pcopyin ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_COPYOUT) - && gfc_match ("pcopyout ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_CREATE) - && gfc_match ("pcreate ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_PRESENT) - && gfc_match ("present ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_PRESENT, false, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_COPY) - && gfc_match ("present_or_copy ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM, true, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_COPYIN) - && gfc_match ("present_or_copyin ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_COPYOUT) - && gfc_match ("present_or_copyout ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_CREATE) - && gfc_match ("present_or_create ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC, true, allow_derived)) - continue; - if ((mask & OMP_CLAUSE_PRIORITY) - && (m = gfc_match_dupl_check (!c->priority, "priority", true, - &c->priority)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_PRIVATE) - && gfc_match_omp_variable_list ("private (", - &c->lists[OMP_LIST_PRIVATE], - true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_PROC_BIND) - && (m = gfc_match_dupl_check ((c->proc_bind - == OMP_PROC_BIND_UNKNOWN), - "proc_bind", true)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("primary )") == MATCH_YES) - c->proc_bind = OMP_PROC_BIND_PRIMARY; - else if (gfc_match ("master )") == MATCH_YES) - c->proc_bind = OMP_PROC_BIND_MASTER; - else if (gfc_match ("spread )") == MATCH_YES) - c->proc_bind = OMP_PROC_BIND_SPREAD; - else if (gfc_match ("close )") == MATCH_YES) - c->proc_bind = OMP_PROC_BIND_CLOSE; - else - goto error; - continue; - } - break; - case 'r': - if ((mask & OMP_CLAUSE_ATOMIC) - && (m = gfc_match_dupl_atomic ((c->atomic_op - == GFC_OMP_ATOMIC_UNSET), - "read")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->atomic_op = GFC_OMP_ATOMIC_READ; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_REDUCTION) - && gfc_match_omp_clause_reduction (pc, c, openacc, - allow_derived) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_MEMORDER) - && (m = gfc_match_dupl_memorder ((c->memorder - == OMP_MEMORDER_UNSET), - "relaxed")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->memorder = OMP_MEMORDER_RELAXED; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_MEMORDER) - && (m = gfc_match_dupl_memorder ((c->memorder - == OMP_MEMORDER_UNSET), - "release")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->memorder = OMP_MEMORDER_RELEASE; - needs_space = true; - continue; - } - break; - case 's': - if ((mask & OMP_CLAUSE_SAFELEN) - && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen", - true, &c->safelen_expr)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_SCHEDULE) - && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE, - "schedule", true)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - int nmodifiers = 0; - locus old_loc2 = gfc_current_locus; - do - { - if (gfc_match ("simd") == MATCH_YES) - { - c->sched_simd = true; - nmodifiers++; - } - else if (gfc_match ("monotonic") == MATCH_YES) - { - c->sched_monotonic = true; - nmodifiers++; - } - else if (gfc_match ("nonmonotonic") == MATCH_YES) - { - c->sched_nonmonotonic = true; - nmodifiers++; - } - else - { - if (nmodifiers) - gfc_current_locus = old_loc2; - break; - } - if (nmodifiers == 1 - && gfc_match (" , ") == MATCH_YES) - continue; - else if (gfc_match (" : ") == MATCH_YES) - break; - gfc_current_locus = old_loc2; - break; - } - while (1); - if (gfc_match ("static") == MATCH_YES) - c->sched_kind = OMP_SCHED_STATIC; - else if (gfc_match ("dynamic") == MATCH_YES) - c->sched_kind = OMP_SCHED_DYNAMIC; - else if (gfc_match ("guided") == MATCH_YES) - c->sched_kind = OMP_SCHED_GUIDED; - else if (gfc_match ("runtime") == MATCH_YES) - c->sched_kind = OMP_SCHED_RUNTIME; - else if (gfc_match ("auto") == MATCH_YES) - c->sched_kind = OMP_SCHED_AUTO; - if (c->sched_kind != OMP_SCHED_NONE) - { - m = MATCH_NO; - if (c->sched_kind != OMP_SCHED_RUNTIME - && c->sched_kind != OMP_SCHED_AUTO) - m = gfc_match (" , %e )", &c->chunk_size); - if (m != MATCH_YES) - m = gfc_match_char (')'); - if (m != MATCH_YES) - c->sched_kind = OMP_SCHED_NONE; - } - if (c->sched_kind != OMP_SCHED_NONE) - continue; - else - gfc_current_locus = old_loc; - } - if ((mask & OMP_CLAUSE_HOST_SELF) - && gfc_match ("self ( ") == MATCH_YES - && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM, true, - allow_derived)) - continue; - if ((mask & OMP_CLAUSE_SEQ) - && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->seq = true; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_MEMORDER) - && (m = gfc_match_dupl_memorder ((c->memorder - == OMP_MEMORDER_UNSET), - "seq_cst")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->memorder = OMP_MEMORDER_SEQ_CST; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_SHARED) - && gfc_match_omp_variable_list ("shared (", - &c->lists[OMP_LIST_SHARED], - true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_SIMDLEN) - && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true, - &c->simdlen_expr)) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_SIMD) - && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->simd = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_SEVERITY) - && (m = gfc_match_dupl_check (!c->severity, "severity", true)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - if (gfc_match ("fatal )") == MATCH_YES) - c->severity = OMP_SEVERITY_FATAL; - else if (gfc_match ("warning )") == MATCH_YES) - c->severity = OMP_SEVERITY_WARNING; - else - { - gfc_error ("Expected FATAL or WARNING in SEVERITY clause " - "at %C"); - goto error; - } - continue; - } - break; - case 't': - if ((mask & OMP_CLAUSE_TASK_REDUCTION) - && gfc_match_omp_clause_reduction (pc, c, openacc, - allow_derived) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_THREAD_LIMIT) - && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit", - true, &c->thread_limit)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_THREADS) - && (m = gfc_match_dupl_check (!c->threads, "threads")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->threads = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_TILE) - && !c->tile_list - && match_oacc_expr_list ("tile (", &c->tile_list, - true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK)) - { - if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]) - == MATCH_YES) - continue; - } - else if ((mask & OMP_CLAUSE_TO) - && gfc_match_omp_variable_list ("to (", - &c->lists[OMP_LIST_TO], false, - NULL, &head, true) == MATCH_YES) - continue; - break; - case 'u': - if ((mask & OMP_CLAUSE_UNIFORM) - && gfc_match_omp_variable_list ("uniform (", - &c->lists[OMP_LIST_UNIFORM], - false) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_UNTIED) - && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->untied = needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_ATOMIC) - && (m = gfc_match_dupl_atomic ((c->atomic_op - == GFC_OMP_ATOMIC_UNSET), - "update")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->atomic_op = GFC_OMP_ATOMIC_UPDATE; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_USE_DEVICE) - && gfc_match_omp_variable_list ("use_device (", - &c->lists[OMP_LIST_USE_DEVICE], - true) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_USE_DEVICE_PTR) - && gfc_match_omp_variable_list - ("use_device_ptr (", - &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES) - continue; - if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR) - && gfc_match_omp_variable_list - ("use_device_addr (", - &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES) - continue; - break; - case 'v': - /* VECTOR_LENGTH must be matched before VECTOR, because the latter - doesn't unconditionally match '('. */ - if ((mask & OMP_CLAUSE_VECTOR_LENGTH) - && (m = gfc_match_dupl_check (!c->vector_length_expr, - "vector_length", true, - &c->vector_length_expr)) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - continue; - } - if ((mask & OMP_CLAUSE_VECTOR) - && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->vector = true; - m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR); - if (m == MATCH_ERROR) - goto error; - if (m == MATCH_NO) - needs_space = true; - continue; - } - break; - case 'w': - if ((mask & OMP_CLAUSE_WAIT) - && gfc_match ("wait") == MATCH_YES) - { - m = match_oacc_expr_list (" (", &c->wait_list, false); - if (m == MATCH_ERROR) - goto error; - else if (m == MATCH_NO) - { - gfc_expr *expr - = gfc_get_constant_expr (BT_INTEGER, - gfc_default_integer_kind, - &gfc_current_locus); - mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL); - gfc_expr_list **expr_list = &c->wait_list; - while (*expr_list) - expr_list = &(*expr_list)->next; - *expr_list = gfc_get_expr_list (); - (*expr_list)->expr = expr; - needs_space = true; - } - continue; - } - if ((mask & OMP_CLAUSE_WEAK) - && (m = gfc_match_dupl_check (!c->weak, "weak")) - != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->weak = true; - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_WORKER) - && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->worker = true; - m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER); - if (m == MATCH_ERROR) - goto error; - else if (m == MATCH_NO) - needs_space = true; - continue; - } - if ((mask & OMP_CLAUSE_ATOMIC) - && (m = gfc_match_dupl_atomic ((c->atomic_op - == GFC_OMP_ATOMIC_UNSET), - "write")) != MATCH_NO) - { - if (m == MATCH_ERROR) - goto error; - c->atomic_op = GFC_OMP_ATOMIC_WRITE; - needs_space = true; - continue; - } - break; - } - break; - } - -end: - if (error - || (context_selector && gfc_peek_ascii_char () != ')') - || (!context_selector && gfc_match_omp_eos () != MATCH_YES)) - { - if (!gfc_error_flag_test ()) - gfc_error ("Failed to match clause at %C"); - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - - *cp = c; - return MATCH_YES; - -error: - error = true; - goto end; -} - - -#define OACC_PARALLEL_CLAUSES \ - (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ - | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \ - | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ - | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ - | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) -#define OACC_KERNELS_CLAUSES \ - (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ - | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ - | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ - | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) -#define OACC_SERIAL_CLAUSES \ - (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \ - | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ - | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ - | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) -#define OACC_DATA_CLAUSES \ - (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ - | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ - | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH) -#define OACC_LOOP_CLAUSES \ - (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ - | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ - | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \ - | OMP_CLAUSE_TILE) -#define OACC_PARALLEL_LOOP_CLAUSES \ - (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) -#define OACC_KERNELS_LOOP_CLAUSES \ - (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES) -#define OACC_SERIAL_LOOP_CLAUSES \ - (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES) -#define OACC_HOST_DATA_CLAUSES \ - (omp_mask (OMP_CLAUSE_USE_DEVICE) \ - | OMP_CLAUSE_IF \ - | OMP_CLAUSE_IF_PRESENT) -#define OACC_DECLARE_CLAUSES \ - (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ - | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ - | OMP_CLAUSE_PRESENT \ - | OMP_CLAUSE_LINK) -#define OACC_UPDATE_CLAUSES \ - (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \ - | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT) -#define OACC_ENTER_DATA_CLAUSES \ - (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ - | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH) -#define OACC_EXIT_DATA_CLAUSES \ - (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ - | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ - | OMP_CLAUSE_DETACH) -#define OACC_WAIT_CLAUSES \ - omp_mask (OMP_CLAUSE_ASYNC) -#define OACC_ROUTINE_CLAUSES \ - (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ - | OMP_CLAUSE_SEQ \ - | OMP_CLAUSE_NOHOST) - - -static match -match_acc (gfc_exec_op op, const omp_mask mask) -{ - gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES) - return MATCH_ERROR; - new_st.op = op; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - -match -gfc_match_oacc_parallel_loop (void) -{ - return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES); -} - - -match -gfc_match_oacc_parallel (void) -{ - return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES); -} - - -match -gfc_match_oacc_kernels_loop (void) -{ - return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES); -} - - -match -gfc_match_oacc_kernels (void) -{ - return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES); -} - - -match -gfc_match_oacc_serial_loop (void) -{ - return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES); -} - - -match -gfc_match_oacc_serial (void) -{ - return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES); -} - - -match -gfc_match_oacc_data (void) -{ - return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES); -} - - -match -gfc_match_oacc_host_data (void) -{ - return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES); -} - - -match -gfc_match_oacc_loop (void) -{ - return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES); -} - - -match -gfc_match_oacc_declare (void) -{ - gfc_omp_clauses *c; - gfc_omp_namelist *n; - gfc_namespace *ns = gfc_current_ns; - gfc_oacc_declare *new_oc; - bool module_var = false; - locus where = gfc_current_locus; - - if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true) - != MATCH_YES) - return MATCH_ERROR; - - for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next) - n->sym->attr.oacc_declare_device_resident = 1; - - for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next) - n->sym->attr.oacc_declare_link = 1; - - for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next) - { - gfc_symbol *s = n->sym; - - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) - { - if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO) - { - gfc_error ("Invalid clause in module with !$ACC DECLARE at %L", - &where); - return MATCH_ERROR; - } - - module_var = true; - } - - if (s->attr.use_assoc) - { - gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L", - &where); - return MATCH_ERROR; - } - - if ((s->result == s && s->ns->contained != gfc_current_ns) - || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE) - && s->ns != gfc_current_ns)) - { - gfc_error ("Variable %qs shall be declared in the same scoping unit " - "as !$ACC DECLARE at %L", s->name, &where); - return MATCH_ERROR; - } - - if ((s->attr.dimension || s->attr.codimension) - && s->attr.dummy && s->as->type != AS_EXPLICIT) - { - gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L", - &where); - return MATCH_ERROR; - } - - switch (n->u.map_op) - { - case OMP_MAP_FORCE_ALLOC: - case OMP_MAP_ALLOC: - s->attr.oacc_declare_create = 1; - break; - - case OMP_MAP_FORCE_TO: - case OMP_MAP_TO: - s->attr.oacc_declare_copyin = 1; - break; - - case OMP_MAP_FORCE_DEVICEPTR: - s->attr.oacc_declare_deviceptr = 1; - break; - - default: - break; - } - } - - new_oc = gfc_get_oacc_declare (); - new_oc->next = ns->oacc_declare; - new_oc->module_var = module_var; - new_oc->clauses = c; - new_oc->loc = gfc_current_locus; - ns->oacc_declare = new_oc; - - return MATCH_YES; -} - - -match -gfc_match_oacc_update (void) -{ - gfc_omp_clauses *c; - locus here = gfc_current_locus; - - if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true) - != MATCH_YES) - return MATCH_ERROR; - - if (!c->lists[OMP_LIST_MAP]) - { - gfc_error ("% must contain at least one " - "% or % or % clause at %L", &here); - return MATCH_ERROR; - } - - new_st.op = EXEC_OACC_UPDATE; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -match -gfc_match_oacc_enter_data (void) -{ - return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES); -} - - -match -gfc_match_oacc_exit_data (void) -{ - return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES); -} - - -match -gfc_match_oacc_wait (void) -{ - gfc_omp_clauses *c = gfc_get_omp_clauses (); - gfc_expr_list *wait_list = NULL, *el; - bool space = true; - match m; - - m = match_oacc_expr_list (" (", &wait_list, true); - if (m == MATCH_ERROR) - return m; - else if (m == MATCH_YES) - space = false; - - if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true) - == MATCH_ERROR) - return MATCH_ERROR; - - if (wait_list) - for (el = wait_list; el; el = el->next) - { - if (el->expr == NULL) - { - gfc_error ("Invalid argument to !$ACC WAIT at %C"); - return MATCH_ERROR; - } - - if (!gfc_resolve_expr (el->expr) - || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0) - { - gfc_error ("WAIT clause at %L requires a scalar INTEGER expression", - &el->expr->where); - - return MATCH_ERROR; - } - } - c->wait_list = wait_list; - new_st.op = EXEC_OACC_WAIT; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -match -gfc_match_oacc_cache (void) -{ - gfc_omp_clauses *c = gfc_get_omp_clauses (); - /* The OpenACC cache directive explicitly only allows "array elements or - subarrays", which we're currently not checking here. Either check this - after the call of gfc_match_omp_variable_list, or add something like a - only_sections variant next to its allow_sections parameter. */ - match m = gfc_match_omp_variable_list (" (", - &c->lists[OMP_LIST_CACHE], true, - NULL, NULL, true); - if (m != MATCH_YES) - { - gfc_free_omp_clauses(c); - return m; - } - - if (gfc_current_state() != COMP_DO - && gfc_current_state() != COMP_DO_CONCURRENT) - { - gfc_error ("ACC CACHE directive must be inside of loop %C"); - gfc_free_omp_clauses(c); - return MATCH_ERROR; - } - - new_st.op = EXEC_OACC_CACHE; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - -/* Determine the OpenACC 'routine' directive's level of parallelism. */ - -static oacc_routine_lop -gfc_oacc_routine_lop (gfc_omp_clauses *clauses) -{ - oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ; - - if (clauses) - { - unsigned n_lop_clauses = 0; - - if (clauses->gang) - { - ++n_lop_clauses; - ret = OACC_ROUTINE_LOP_GANG; - } - if (clauses->worker) - { - ++n_lop_clauses; - ret = OACC_ROUTINE_LOP_WORKER; - } - if (clauses->vector) - { - ++n_lop_clauses; - ret = OACC_ROUTINE_LOP_VECTOR; - } - if (clauses->seq) - { - ++n_lop_clauses; - ret = OACC_ROUTINE_LOP_SEQ; - } - - if (n_lop_clauses > 1) - ret = OACC_ROUTINE_LOP_ERROR; - } - - return ret; -} - -match -gfc_match_oacc_routine (void) -{ - locus old_loc; - match m; - gfc_intrinsic_sym *isym = NULL; - gfc_symbol *sym = NULL; - gfc_omp_clauses *c = NULL; - gfc_oacc_routine_name *n = NULL; - oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE; - bool nohost; - - old_loc = gfc_current_locus; - - m = gfc_match (" ("); - - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY - && m == MATCH_YES) - { - gfc_error ("Only the !$ACC ROUTINE form without " - "list is allowed in interface block at %C"); - goto cleanup; - } - - if (m == MATCH_YES) - { - char buffer[GFC_MAX_SYMBOL_LEN + 1]; - - m = gfc_match_name (buffer); - if (m == MATCH_YES) - { - gfc_symtree *st = NULL; - - /* First look for an intrinsic symbol. */ - isym = gfc_find_function (buffer); - if (!isym) - isym = gfc_find_subroutine (buffer); - /* If no intrinsic symbol found, search the current namespace. */ - if (!isym) - st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); - if (st) - { - sym = st->n.sym; - /* If the name in a 'routine' directive refers to the containing - subroutine or function, then make sure that we'll later handle - this accordingly. */ - if (gfc_current_ns->proc_name != NULL - && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) - sym = NULL; - } - - if (isym == NULL && st == NULL) - { - gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C", - buffer); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } - } - else - { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } - - if (gfc_match_char (')') != MATCH_YES) - { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" - " ')' after NAME"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } - } - - if (gfc_match_omp_eos () != MATCH_YES - && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true) - != MATCH_YES)) - return MATCH_ERROR; - - lop = gfc_oacc_routine_lop (c); - if (lop == OACC_ROUTINE_LOP_ERROR) - { - gfc_error ("Multiple loop axes specified for routine at %C"); - goto cleanup; - } - nohost = c ? c->nohost : false; - - if (isym != NULL) - { - /* Diagnose any OpenACC 'routine' directive that doesn't match the - (implicit) one with a 'seq' clause. */ - if (c && (c->gang || c->worker || c->vector)) - { - gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" - " at %C marked with incompatible GANG, WORKER, or VECTOR" - " clause"); - goto cleanup; - } - /* ..., and no 'nohost' clause. */ - if (nohost) - { - gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" - " at %C marked with incompatible NOHOST clause"); - goto cleanup; - } - } - else if (sym != NULL) - { - bool add = true; - - /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't - match the first one. */ - for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names; - n_p; - n_p = n_p->next) - if (n_p->sym == sym) - { - add = false; - bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false; - if (lop != gfc_oacc_routine_lop (n_p->clauses) - || nohost != nohost_p) - { - gfc_error ("!$ACC ROUTINE already applied at %C"); - goto cleanup; - } - } - - if (add) - { - sym->attr.oacc_routine_lop = lop; - sym->attr.oacc_routine_nohost = nohost; - - n = gfc_get_oacc_routine_name (); - n->sym = sym; - n->clauses = c; - n->next = gfc_current_ns->oacc_routine_names; - n->loc = old_loc; - gfc_current_ns->oacc_routine_names = n; - } - } - else if (gfc_current_ns->proc_name) - { - /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't - match the first one. */ - oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop; - bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost; - if (lop_p != OACC_ROUTINE_LOP_NONE - && (lop != lop_p - || nohost != nohost_p)) - { - gfc_error ("!$ACC ROUTINE already applied at %C"); - goto cleanup; - } - - if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, - gfc_current_ns->proc_name->name, - &old_loc)) - goto cleanup; - gfc_current_ns->proc_name->attr.oacc_routine_lop = lop; - gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost; - } - else - /* Something has gone wrong, possibly a syntax error. */ - goto cleanup; - - if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector)) - { - gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not " - "permitted in PURE procedure at %C"); - goto cleanup; - } - - - if (n) - n->clauses = c; - else if (gfc_current_ns->oacc_routine) - gfc_current_ns->oacc_routine_clauses = c; - - new_st.op = EXEC_OACC_ROUTINE; - new_st.ext.omp_clauses = c; - return MATCH_YES; - -cleanup: - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - - -#define OMP_PARALLEL_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \ - | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \ - | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE) -#define OMP_DECLARE_SIMD_CLAUSES \ - (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \ - | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \ - | OMP_CLAUSE_NOTINBRANCH) -#define OMP_DO_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ - | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \ - | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE) -#define OMP_LOOP_CLAUSES \ - (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \ - | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) - -#define OMP_SCOPE_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_REDUCTION) -#define OMP_SECTIONS_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE) -#define OMP_SIMD_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \ - | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \ - | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \ - | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL) -#define OMP_TASK_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ - | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ - | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \ - | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE) -#define OMP_TASKLOOP_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ - | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \ - | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \ - | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE) -#define OMP_TASKGROUP_CLAUSES \ - (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE) -#define OMP_TARGET_CLAUSES \ - (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ - | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \ - | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ - | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ - | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE) -#define OMP_TARGET_DATA_CLAUSES \ - (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ - | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) -#define OMP_TARGET_ENTER_DATA_CLAUSES \ - (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ - | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) -#define OMP_TARGET_EXIT_DATA_CLAUSES \ - (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ - | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) -#define OMP_TARGET_UPDATE_CLAUSES \ - (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \ - | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) -#define OMP_TEAMS_CLAUSES \ - (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \ - | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE) -#define OMP_DISTRIBUTE_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \ - | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE) -#define OMP_SINGLE_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_ALLOCATE) -#define OMP_ORDERED_CLAUSES \ - (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) -#define OMP_DECLARE_TARGET_CLAUSES \ - (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE) -#define OMP_ATOMIC_CLAUSES \ - (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ - | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ - | OMP_CLAUSE_WEAK) -#define OMP_MASKED_CLAUSES \ - (omp_mask (OMP_CLAUSE_FILTER)) -#define OMP_ERROR_CLAUSES \ - (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY) - - - -static match -match_omp (gfc_exec_op op, const omp_mask mask) -{ - gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, mask, true, true, false, false, - op == EXEC_OMP_TARGET) != MATCH_YES) - return MATCH_ERROR; - new_st.op = op; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -match -gfc_match_omp_critical (void) -{ - char n[GFC_MAX_SYMBOL_LEN+1]; - gfc_omp_clauses *c = NULL; - - if (gfc_match (" ( %n )", n) != MATCH_YES) - n[0] = '\0'; - - if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT), - /* first = */ n[0] == '\0') != MATCH_YES) - return MATCH_ERROR; - - new_st.op = EXEC_OMP_CRITICAL; - new_st.ext.omp_clauses = c; - if (n[0]) - c->critical_name = xstrdup (n); - return MATCH_YES; -} - - -match -gfc_match_omp_end_critical (void) -{ - char n[GFC_MAX_SYMBOL_LEN+1]; - - if (gfc_match (" ( %n )", n) != MATCH_YES) - n[0] = '\0'; - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); - return MATCH_ERROR; - } - - new_st.op = EXEC_OMP_END_CRITICAL; - new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL; - return MATCH_YES; -} - -/* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type) - dep-type = in/out/inout/mutexinoutset/depobj/source/sink - depend: !source, !sink - update: !source, !sink, !depobj - locator = exactly one list item .*/ -match -gfc_match_omp_depobj (void) -{ - gfc_omp_clauses *c = NULL; - gfc_expr *depobj; - - if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES) - { - gfc_error ("Expected %<( depobj )%> at %C"); - return MATCH_ERROR; - } - if (gfc_match ("update ( ") == MATCH_YES) - { - c = gfc_get_omp_clauses (); - if (gfc_match ("inout )") == MATCH_YES) - c->depobj_update = OMP_DEPEND_INOUT; - else if (gfc_match ("in )") == MATCH_YES) - c->depobj_update = OMP_DEPEND_IN; - else if (gfc_match ("out )") == MATCH_YES) - c->depobj_update = OMP_DEPEND_OUT; - else if (gfc_match ("mutexinoutset )") == MATCH_YES) - c->depobj_update = OMP_DEPEND_MUTEXINOUTSET; - else - { - gfc_error ("Expected IN, OUT, INOUT, MUTEXINOUTSET followed by " - "%<)%> at %C"); - goto error; - } - } - else if (gfc_match ("destroy") == MATCH_YES) - { - c = gfc_get_omp_clauses (); - c->destroy = true; - } - else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false) - != MATCH_YES) - goto error; - - if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy) - { - if (!c->depend_source && !c->lists[OMP_LIST_DEPEND]) - { - gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C"); - goto error; - } - if (c->depend_source - || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK_FIRST - || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK - || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_DEPOBJ) - { - gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not " - "have dependence-type SOURCE, SINK or DEPOBJ", - c->lists[OMP_LIST_DEPEND] - ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus); - goto error; - } - if (c->lists[OMP_LIST_DEPEND]->next) - { - gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have " - "only a single locator", - &c->lists[OMP_LIST_DEPEND]->next->where); - goto error; - } - } - - c->depobj = depobj; - new_st.op = EXEC_OMP_DEPOBJ; - new_st.ext.omp_clauses = c; - return MATCH_YES; - -error: - gfc_free_expr (depobj); - gfc_free_omp_clauses (c); - return MATCH_ERROR; -} - -match -gfc_match_omp_distribute (void) -{ - return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES); -} - - -match -gfc_match_omp_distribute_parallel_do (void) -{ - return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO, - (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES - | OMP_DO_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_ORDERED)) - & ~(omp_mask (OMP_CLAUSE_LINEAR))); -} - - -match -gfc_match_omp_distribute_parallel_do_simd (void) -{ - return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD, - (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES - | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_ORDERED))); -} - - -match -gfc_match_omp_distribute_simd (void) -{ - return match_omp (EXEC_OMP_DISTRIBUTE_SIMD, - OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_do (void) -{ - return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES); -} - - -match -gfc_match_omp_do_simd (void) -{ - return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_loop (void) -{ - return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES); -} - - -match -gfc_match_omp_teams_loop (void) -{ - return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); -} - - -match -gfc_match_omp_target_teams_loop (void) -{ - return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP, - OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); -} - - -match -gfc_match_omp_parallel_loop (void) -{ - return match_omp (EXEC_OMP_PARALLEL_LOOP, - OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES); -} - - -match -gfc_match_omp_target_parallel_loop (void) -{ - return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP, - (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES - | OMP_LOOP_CLAUSES)); -} - - -match -gfc_match_omp_error (void) -{ - locus loc = gfc_current_locus; - match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES); - if (m != MATCH_YES) - return m; - - gfc_omp_clauses *c = new_st.ext.omp_clauses; - if (c->severity == OMP_SEVERITY_UNSET) - c->severity = OMP_SEVERITY_FATAL; - if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION) - return MATCH_YES; - if (c->message - && (!gfc_resolve_expr (c->message) - || c->message->ts.type != BT_CHARACTER - || c->message->ts.kind != gfc_default_character_kind - || c->message->rank != 0)) - { - gfc_error ("MESSAGE clause at %L requires a scalar default-kind " - "CHARACTER expression", - &new_st.ext.omp_clauses->message->where); - return MATCH_ERROR; - } - if (c->message && !gfc_is_constant_expr (c->message)) - { - gfc_error ("Constant character expression required in MESSAGE clause " - "at %L", &new_st.ext.omp_clauses->message->where); - return MATCH_ERROR; - } - if (c->message) - { - const char *msg = G_("$OMP ERROR encountered at %L: %s"); - gcc_assert (c->message->expr_type == EXPR_CONSTANT); - gfc_charlen_t slen = c->message->value.character.length; - int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind, - false); - size_t size = slen * gfc_character_kinds[i].bit_size / 8; - unsigned char *s = XCNEWVAR (unsigned char, size + 1); - gfc_encode_character (gfc_default_character_kind, slen, - c->message->value.character.string, - (unsigned char *) s, size); - s[size] = '\0'; - if (c->severity == OMP_SEVERITY_WARNING) - gfc_warning_now (0, msg, &loc, s); - else - gfc_error_now (msg, &loc, s); - free (s); - } - else - { - const char *msg = G_("$OMP ERROR encountered at %L"); - if (c->severity == OMP_SEVERITY_WARNING) - gfc_warning_now (0, msg, &loc); - else - gfc_error_now (msg, &loc); - } - return MATCH_YES; -} - -match -gfc_match_omp_flush (void) -{ - gfc_omp_namelist *list = NULL; - gfc_omp_clauses *c = NULL; - gfc_gobble_whitespace (); - enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET; - if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(') - { - if (gfc_match ("seq_cst") == MATCH_YES) - mo = OMP_MEMORDER_SEQ_CST; - else if (gfc_match ("acq_rel") == MATCH_YES) - mo = OMP_MEMORDER_ACQ_REL; - else if (gfc_match ("release") == MATCH_YES) - mo = OMP_MEMORDER_RELEASE; - else if (gfc_match ("acquire") == MATCH_YES) - mo = OMP_MEMORDER_ACQUIRE; - else - { - gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C"); - return MATCH_ERROR; - } - c = gfc_get_omp_clauses (); - c->memorder = mo; - } - gfc_match_omp_variable_list (" (", &list, true); - if (list && mo != OMP_MEMORDER_UNSET) - { - gfc_error ("List specified together with memory order clause in FLUSH " - "directive at %C"); - gfc_free_omp_namelist (list, false); - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); - gfc_free_omp_namelist (list, false); - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - new_st.op = EXEC_OMP_FLUSH; - new_st.ext.omp_namelist = list; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -match -gfc_match_omp_declare_simd (void) -{ - locus where = gfc_current_locus; - gfc_symbol *proc_name; - gfc_omp_clauses *c; - gfc_omp_declare_simd *ods; - bool needs_space = false; - - switch (gfc_match (" ( %s ) ", &proc_name)) - { - case MATCH_YES: break; - case MATCH_NO: proc_name = NULL; needs_space = true; break; - case MATCH_ERROR: return MATCH_ERROR; - } - - if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true, - needs_space) != MATCH_YES) - return MATCH_ERROR; - - if (gfc_current_ns->is_block_data) - { - gfc_free_omp_clauses (c); - return MATCH_YES; - } - - ods = gfc_get_omp_declare_simd (); - ods->where = where; - ods->proc_name = proc_name; - ods->clauses = c; - ods->next = gfc_current_ns->omp_declare_simd; - gfc_current_ns->omp_declare_simd = ods; - return MATCH_YES; -} - - -static bool -match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2) -{ - match m; - locus old_loc = gfc_current_locus; - char sname[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - gfc_namespace *ns = gfc_current_ns; - gfc_expr *lvalue = NULL, *rvalue = NULL; - gfc_symtree *st; - gfc_actual_arglist *arglist; - - m = gfc_match (" %v =", &lvalue); - if (m != MATCH_YES) - gfc_current_locus = old_loc; - else - { - m = gfc_match (" %e )", &rvalue); - if (m == MATCH_YES) - { - ns->code = gfc_get_code (EXEC_ASSIGN); - ns->code->expr1 = lvalue; - ns->code->expr2 = rvalue; - ns->code->loc = old_loc; - return true; - } - - gfc_current_locus = old_loc; - gfc_free_expr (lvalue); - } - - m = gfc_match (" %n", sname); - if (m != MATCH_YES) - return false; - - if (strcmp (sname, omp_sym1->name) == 0 - || strcmp (sname, omp_sym2->name) == 0) - return false; - - gfc_current_ns = ns->parent; - if (gfc_get_ha_sym_tree (sname, &st)) - return false; - - sym = st->n.sym; - if (sym->attr.flavor != FL_PROCEDURE - && sym->attr.flavor != FL_UNKNOWN) - return false; - - if (!sym->attr.generic - && !sym->attr.subroutine - && !sym->attr.function) - { - if (!(sym->attr.external && !sym->attr.referenced)) - { - /* ...create a symbol in this scope... */ - if (sym->ns != gfc_current_ns - && gfc_get_sym_tree (sname, NULL, &st, false) == 1) - return false; - - if (sym != st->n.sym) - sym = st->n.sym; - } - - /* ...and then to try to make the symbol into a subroutine. */ - if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) - return false; - } - - gfc_set_sym_referenced (sym); - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () != '(') - return false; - - gfc_current_ns = ns; - m = gfc_match_actual_arglist (1, &arglist); - if (m != MATCH_YES) - return false; - - if (gfc_match_char (')') != MATCH_YES) - return false; - - ns->code = gfc_get_code (EXEC_CALL); - ns->code->symtree = st; - ns->code->ext.actual = arglist; - ns->code->loc = old_loc; - return true; -} - -static bool -gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name, - gfc_typespec *ts, const char **n) -{ - if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL) - return false; - - switch (rop) - { - case OMP_REDUCTION_PLUS: - case OMP_REDUCTION_MINUS: - case OMP_REDUCTION_TIMES: - return ts->type != BT_LOGICAL; - case OMP_REDUCTION_AND: - case OMP_REDUCTION_OR: - case OMP_REDUCTION_EQV: - case OMP_REDUCTION_NEQV: - return ts->type == BT_LOGICAL; - case OMP_REDUCTION_USER: - if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL)) - { - gfc_symbol *sym; - - gfc_find_symbol (name, NULL, 1, &sym); - if (sym != NULL) - { - if (sym->attr.intrinsic) - *n = sym->name; - else if ((sym->attr.flavor != FL_UNKNOWN - && sym->attr.flavor != FL_PROCEDURE) - || sym->attr.external - || sym->attr.generic - || sym->attr.entry - || sym->attr.result - || sym->attr.dummy - || sym->attr.subroutine - || sym->attr.pointer - || sym->attr.target - || sym->attr.cray_pointer - || sym->attr.cray_pointee - || (sym->attr.proc != PROC_UNKNOWN - && sym->attr.proc != PROC_INTRINSIC) - || sym->attr.if_source != IFSRC_UNKNOWN - || sym == sym->ns->proc_name) - *n = NULL; - else - *n = sym->name; - } - else - *n = name; - if (*n - && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0)) - return true; - else if (*n - && ts->type == BT_INTEGER - && (strcmp (*n, "iand") == 0 - || strcmp (*n, "ior") == 0 - || strcmp (*n, "ieor") == 0)) - return true; - } - break; - default: - break; - } - return false; -} - -gfc_omp_udr * -gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts) -{ - gfc_omp_udr *omp_udr; - - if (st == NULL) - return NULL; - - for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) - if (omp_udr->ts.type == ts->type - || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) - && (ts->type == BT_DERIVED || ts->type == BT_CLASS))) - { - if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) - { - if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0) - return omp_udr; - } - else if (omp_udr->ts.kind == ts->kind) - { - if (omp_udr->ts.type == BT_CHARACTER) - { - if (omp_udr->ts.u.cl->length == NULL - || ts->u.cl->length == NULL) - return omp_udr; - if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - return omp_udr; - if (ts->u.cl->length->expr_type != EXPR_CONSTANT) - return omp_udr; - if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER) - return omp_udr; - if (ts->u.cl->length->ts.type != BT_INTEGER) - return omp_udr; - if (gfc_compare_expr (omp_udr->ts.u.cl->length, - ts->u.cl->length, INTRINSIC_EQ) != 0) - continue; - } - return omp_udr; - } - } - return NULL; -} - -match -gfc_match_omp_declare_reduction (void) -{ - match m; - gfc_intrinsic_op op; - char name[GFC_MAX_SYMBOL_LEN + 3]; - auto_vec tss; - gfc_typespec ts; - unsigned int i; - gfc_symtree *st; - locus where = gfc_current_locus; - locus end_loc = gfc_current_locus; - bool end_loc_set = false; - gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; - - if (gfc_match_char ('(') != MATCH_YES) - return MATCH_ERROR; - - m = gfc_match (" %o : ", &op); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_YES) - { - snprintf (name, sizeof name, "operator %s", gfc_op2string (op)); - rop = (gfc_omp_reduction_op) op; - } - else - { - m = gfc_match_defined_op_name (name + 1, 1); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_YES) - { - name[0] = '.'; - strcat (name, "."); - if (gfc_match (" : ") != MATCH_YES) - return MATCH_ERROR; - } - else - { - if (gfc_match (" %n : ", name) != MATCH_YES) - return MATCH_ERROR; - } - rop = OMP_REDUCTION_USER; - } - - m = gfc_match_type_spec (&ts); - if (m != MATCH_YES) - return MATCH_ERROR; - /* Treat len=: the same as len=*. */ - if (ts.type == BT_CHARACTER) - ts.deferred = false; - tss.safe_push (ts); - - while (gfc_match_char (',') == MATCH_YES) - { - m = gfc_match_type_spec (&ts); - if (m != MATCH_YES) - return MATCH_ERROR; - tss.safe_push (ts); - } - if (gfc_match_char (':') != MATCH_YES) - return MATCH_ERROR; - - st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); - for (i = 0; i < tss.length (); i++) - { - gfc_symtree *omp_out, *omp_in; - gfc_symtree *omp_priv = NULL, *omp_orig = NULL; - gfc_namespace *combiner_ns, *initializer_ns = NULL; - gfc_omp_udr *prev_udr, *omp_udr; - const char *predef_name = NULL; - - omp_udr = gfc_get_omp_udr (); - omp_udr->name = gfc_get_string ("%s", name); - omp_udr->rop = rop; - omp_udr->ts = tss[i]; - omp_udr->where = where; - - gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1); - combiner_ns->proc_name = combiner_ns->parent->proc_name; - - gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false); - gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false); - combiner_ns->omp_udr_ns = 1; - omp_out->n.sym->ts = tss[i]; - omp_in->n.sym->ts = tss[i]; - omp_out->n.sym->attr.omp_udr_artificial_var = 1; - omp_in->n.sym->attr.omp_udr_artificial_var = 1; - omp_out->n.sym->attr.flavor = FL_VARIABLE; - omp_in->n.sym->attr.flavor = FL_VARIABLE; - gfc_commit_symbols (); - omp_udr->combiner_ns = combiner_ns; - omp_udr->omp_out = omp_out->n.sym; - omp_udr->omp_in = omp_in->n.sym; - - locus old_loc = gfc_current_locus; - - if (!match_udr_expr (omp_out, omp_in)) - { - syntax: - gfc_current_locus = old_loc; - gfc_current_ns = combiner_ns->parent; - gfc_undo_symbols (); - gfc_free_omp_udr (omp_udr); - return MATCH_ERROR; - } - - if (gfc_match (" initializer ( ") == MATCH_YES) - { - gfc_current_ns = combiner_ns->parent; - initializer_ns = gfc_get_namespace (gfc_current_ns, 1); - gfc_current_ns = initializer_ns; - initializer_ns->proc_name = initializer_ns->parent->proc_name; - - gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false); - gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false); - initializer_ns->omp_udr_ns = 1; - omp_priv->n.sym->ts = tss[i]; - omp_orig->n.sym->ts = tss[i]; - omp_priv->n.sym->attr.omp_udr_artificial_var = 1; - omp_orig->n.sym->attr.omp_udr_artificial_var = 1; - omp_priv->n.sym->attr.flavor = FL_VARIABLE; - omp_orig->n.sym->attr.flavor = FL_VARIABLE; - gfc_commit_symbols (); - omp_udr->initializer_ns = initializer_ns; - omp_udr->omp_priv = omp_priv->n.sym; - omp_udr->omp_orig = omp_orig->n.sym; - - if (!match_udr_expr (omp_priv, omp_orig)) - goto syntax; - } - - gfc_current_ns = combiner_ns->parent; - if (!end_loc_set) - { - end_loc_set = true; - end_loc = gfc_current_locus; - } - gfc_current_locus = old_loc; - - prev_udr = gfc_omp_udr_find (st, &tss[i]); - if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name) - /* Don't error on !$omp declare reduction (min : integer : ...) - just yet, there could be integer :: min afterwards, - making it valid. When the UDR is resolved, we'll get - to it again. */ - && (rop != OMP_REDUCTION_USER || name[0] == '.')) - { - if (predef_name) - gfc_error_now ("Redefinition of predefined %s " - "!$OMP DECLARE REDUCTION at %L", - predef_name, &where); - else - gfc_error_now ("Redefinition of predefined " - "!$OMP DECLARE REDUCTION at %L", &where); - } - else if (prev_udr) - { - gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L", - &where); - gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L", - &prev_udr->where); - } - else if (st) - { - omp_udr->next = st->n.omp_udr; - st->n.omp_udr = omp_udr; - } - else - { - st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); - st->n.omp_udr = omp_udr; - } - } - - if (end_loc_set) - { - gfc_current_locus = end_loc; - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C"); - gfc_current_locus = where; - return MATCH_ERROR; - } - - return MATCH_YES; - } - gfc_clear_error (); - return MATCH_ERROR; -} - - -match -gfc_match_omp_declare_target (void) -{ - locus old_loc; - match m; - gfc_omp_clauses *c = NULL; - int list; - gfc_omp_namelist *n; - gfc_symbol *s; - - old_loc = gfc_current_locus; - - if (gfc_current_ns->proc_name - && gfc_match_omp_eos () == MATCH_YES) - { - if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, - gfc_current_ns->proc_name->name, - &old_loc)) - goto cleanup; - return MATCH_YES; - } - - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) - { - gfc_error ("Only the !$OMP DECLARE TARGET form without " - "clauses is allowed in interface block at %C"); - goto cleanup; - } - - m = gfc_match (" ("); - if (m == MATCH_YES) - { - c = gfc_get_omp_clauses (); - gfc_current_locus = old_loc; - m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]); - if (m != MATCH_YES) - goto syntax; - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C"); - goto cleanup; - } - } - else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES) - return MATCH_ERROR; - - gfc_buffer_error (false); - - for (list = OMP_LIST_TO; list != OMP_LIST_NUM; - list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) - for (n = c->lists[list]; n; n = n->next) - if (n->sym) - n->sym->mark = 0; - else if (n->u.common->head) - n->u.common->head->mark = 0; - - for (list = OMP_LIST_TO; list != OMP_LIST_NUM; - list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) - for (n = c->lists[list]; n; n = n->next) - if (n->sym) - { - if (n->sym->attr.in_common) - gfc_error_now ("OMP DECLARE TARGET variable at %L is an " - "element of a COMMON block", &n->where); - else if (n->sym->attr.omp_declare_target - && n->sym->attr.omp_declare_target_link - && list != OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in LINK clause and later in TO clause", - &n->where); - else if (n->sym->attr.omp_declare_target - && !n->sym->attr.omp_declare_target_link - && list == OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in TO clause and later in LINK clause", - &n->where); - else if (n->sym->mark) - gfc_error_now ("Variable at %L mentioned multiple times in " - "clauses of the same OMP DECLARE TARGET directive", - &n->where); - else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, - &n->sym->declared_at)) - { - if (list == OMP_LIST_LINK) - gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, - &n->sym->declared_at); - } - if (c->device_type != OMP_DEVICE_TYPE_UNSET) - { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - n->sym->name, &n->where); - n->sym->attr.omp_device_type = c->device_type; - } - n->sym->mark = 1; - } - else if (n->u.common->omp_declare_target - && n->u.common->omp_declare_target_link - && list != OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in LINK clause and later in TO clause", - &n->where); - else if (n->u.common->omp_declare_target - && !n->u.common->omp_declare_target_link - && list == OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in TO clause and later in LINK clause", - &n->where); - else if (n->u.common->head && n->u.common->head->mark) - gfc_error_now ("COMMON at %L mentioned multiple times in " - "clauses of the same OMP DECLARE TARGET directive", - &n->where); - else - { - n->u.common->omp_declare_target = 1; - n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); - if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->u.common->omp_device_type != c->device_type) - gfc_error_now ("COMMON at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - &n->where); - n->u.common->omp_device_type = c->device_type; - - for (s = n->u.common->head; s; s = s->common_next) - { - s->mark = 1; - if (gfc_add_omp_declare_target (&s->attr, s->name, - &s->declared_at)) - { - if (list == OMP_LIST_LINK) - gfc_add_omp_declare_target_link (&s->attr, s->name, - &s->declared_at); - } - if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" - " TARGET directive to a different DEVICE_TYPE", - s->name, &n->where); - s->attr.omp_device_type = c->device_type; - } - } - if (c->device_type && !c->lists[OMP_LIST_TO] && !c->lists[OMP_LIST_LINK]) - gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only " - "DEVICE_TYPE clause is ignored", &old_loc); - - gfc_buffer_error (true); - - if (c) - gfc_free_omp_clauses (c); - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C"); - -cleanup: - gfc_current_locus = old_loc; - if (c) - gfc_free_omp_clauses (c); - return MATCH_ERROR; -} - - -static const char *const omp_construct_selectors[] = { - "simd", "target", "teams", "parallel", "do", NULL }; -static const char *const omp_device_selectors[] = { - "kind", "isa", "arch", NULL }; -static const char *const omp_implementation_selectors[] = { - "vendor", "extension", "atomic_default_mem_order", "unified_address", - "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL }; -static const char *const omp_user_selectors[] = { - "condition", NULL }; - - -/* OpenMP 5.0: - - trait-selector: - trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])] - - trait-score: - score(score-expression) */ - -match -gfc_match_omp_context_selector (gfc_omp_set_selector *oss) -{ - do - { - char selector[GFC_MAX_SYMBOL_LEN + 1]; - - if (gfc_match_name (selector) != MATCH_YES) - { - gfc_error ("expected trait selector name at %C"); - return MATCH_ERROR; - } - - gfc_omp_selector *os = gfc_get_omp_selector (); - os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1); - strcpy (os->trait_selector_name, selector); - os->next = oss->trait_selectors; - oss->trait_selectors = os; - - const char *const *selectors = NULL; - bool allow_score = true; - bool allow_user = false; - int property_limit = 0; - enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE; - switch (oss->trait_set_selector_name[0]) - { - case 'c': /* construct */ - selectors = omp_construct_selectors; - allow_score = false; - property_limit = 1; - property_kind = CTX_PROPERTY_SIMD; - break; - case 'd': /* device */ - selectors = omp_device_selectors; - allow_score = false; - allow_user = true; - property_limit = 3; - property_kind = CTX_PROPERTY_NAME_LIST; - break; - case 'i': /* implementation */ - selectors = omp_implementation_selectors; - allow_user = true; - property_limit = 3; - property_kind = CTX_PROPERTY_NAME_LIST; - break; - case 'u': /* user */ - selectors = omp_user_selectors; - property_limit = 1; - property_kind = CTX_PROPERTY_EXPR; - break; - default: - gcc_unreachable (); - } - for (int i = 0; ; i++) - { - if (selectors[i] == NULL) - { - if (allow_user) - { - property_kind = CTX_PROPERTY_USER; - break; - } - else - { - gfc_error ("selector '%s' not allowed for context selector " - "set '%s' at %C", - selector, oss->trait_set_selector_name); - return MATCH_ERROR; - } - } - if (i == property_limit) - property_kind = CTX_PROPERTY_NONE; - if (strcmp (selectors[i], selector) == 0) - break; - } - if (property_kind == CTX_PROPERTY_NAME_LIST - && oss->trait_set_selector_name[0] == 'i' - && strcmp (selector, "atomic_default_mem_order") == 0) - property_kind = CTX_PROPERTY_ID; - - if (gfc_match (" (") == MATCH_YES) - { - if (property_kind == CTX_PROPERTY_NONE) - { - gfc_error ("selector '%s' does not accept any properties at %C", - selector); - return MATCH_ERROR; - } - - if (allow_score && gfc_match (" score") == MATCH_YES) - { - if (gfc_match (" (") != MATCH_YES) - { - gfc_error ("expected '(' at %C"); - return MATCH_ERROR; - } - if (gfc_match_expr (&os->score) != MATCH_YES - || !gfc_resolve_expr (os->score) - || os->score->ts.type != BT_INTEGER - || os->score->rank != 0) - { - gfc_error ("score argument must be constant integer " - "expression at %C"); - return MATCH_ERROR; - } - - if (os->score->expr_type == EXPR_CONSTANT - && mpz_sgn (os->score->value.integer) < 0) - { - gfc_error ("score argument must be non-negative at %C"); - return MATCH_ERROR; - } - - if (gfc_match (" )") != MATCH_YES) - { - gfc_error ("expected ')' at %C"); - return MATCH_ERROR; - } - - if (gfc_match (" :") != MATCH_YES) - { - gfc_error ("expected : at %C"); - return MATCH_ERROR; - } - } - - gfc_omp_trait_property *otp = gfc_get_omp_trait_property (); - otp->property_kind = property_kind; - otp->next = os->properties; - os->properties = otp; - - switch (property_kind) - { - case CTX_PROPERTY_USER: - do - { - if (gfc_match_expr (&otp->expr) != MATCH_YES) - { - gfc_error ("property must be constant integer " - "expression or string literal at %C"); - return MATCH_ERROR; - } - - if (gfc_match (" ,") != MATCH_YES) - break; - } - while (1); - break; - case CTX_PROPERTY_ID: - { - char buf[GFC_MAX_SYMBOL_LEN + 1]; - if (gfc_match_name (buf) == MATCH_YES) - { - otp->name = XNEWVEC (char, strlen (buf) + 1); - strcpy (otp->name, buf); - } - else - { - gfc_error ("expected identifier at %C"); - return MATCH_ERROR; - } - } - break; - case CTX_PROPERTY_NAME_LIST: - do - { - char buf[GFC_MAX_SYMBOL_LEN + 1]; - if (gfc_match_name (buf) == MATCH_YES) - { - otp->name = XNEWVEC (char, strlen (buf) + 1); - strcpy (otp->name, buf); - otp->is_name = true; - } - else if (gfc_match_literal_constant (&otp->expr, 0) - != MATCH_YES - || otp->expr->ts.type != BT_CHARACTER) - { - gfc_error ("expected identifier or string literal " - "at %C"); - return MATCH_ERROR; - } - - if (gfc_match (" ,") == MATCH_YES) - { - otp = gfc_get_omp_trait_property (); - otp->property_kind = property_kind; - otp->next = os->properties; - os->properties = otp; - } - else - break; - } - while (1); - break; - case CTX_PROPERTY_EXPR: - if (gfc_match_expr (&otp->expr) != MATCH_YES) - { - gfc_error ("expected expression at %C"); - return MATCH_ERROR; - } - if (!gfc_resolve_expr (otp->expr) - || (otp->expr->ts.type != BT_LOGICAL - && otp->expr->ts.type != BT_INTEGER) - || otp->expr->rank != 0) - { - gfc_error ("property must be constant integer or logical " - "expression at %C"); - return MATCH_ERROR; - } - break; - case CTX_PROPERTY_SIMD: - { - if (gfc_match_omp_clauses (&otp->clauses, - OMP_DECLARE_SIMD_CLAUSES, - true, false, false, true) - != MATCH_YES) - { - gfc_error ("expected simd clause at %C"); - return MATCH_ERROR; - } - break; - } - default: - gcc_unreachable (); - } - - if (gfc_match (" )") != MATCH_YES) - { - gfc_error ("expected ')' at %C"); - return MATCH_ERROR; - } - } - else if (property_kind == CTX_PROPERTY_NAME_LIST - || property_kind == CTX_PROPERTY_ID - || property_kind == CTX_PROPERTY_EXPR) - { - if (gfc_match (" (") != MATCH_YES) - { - gfc_error ("expected '(' at %C"); - return MATCH_ERROR; - } - } - - if (gfc_match (" ,") != MATCH_YES) - break; - } - while (1); - - return MATCH_YES; -} - -/* OpenMP 5.0: - - trait-set-selector[,trait-set-selector[,...]] - - trait-set-selector: - trait-set-selector-name = { trait-selector[, trait-selector[, ...]] } - - trait-set-selector-name: - constructor - device - implementation - user */ - -match -gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) -{ - do - { - match m; - const char *selector_sets[] = { "construct", "device", - "implementation", "user" }; - const int selector_set_count - = sizeof (selector_sets) / sizeof (*selector_sets); - int i; - char buf[GFC_MAX_SYMBOL_LEN + 1]; - - m = gfc_match_name (buf); - if (m == MATCH_YES) - for (i = 0; i < selector_set_count; i++) - if (strcmp (buf, selector_sets[i]) == 0) - break; - - if (m != MATCH_YES || i == selector_set_count) - { - gfc_error ("expected 'construct', 'device', 'implementation' or " - "'user' at %C"); - return MATCH_ERROR; - } - - m = gfc_match (" ="); - if (m != MATCH_YES) - { - gfc_error ("expected '=' at %C"); - return MATCH_ERROR; - } - - m = gfc_match (" {"); - if (m != MATCH_YES) - { - gfc_error ("expected '{' at %C"); - return MATCH_ERROR; - } - - gfc_omp_set_selector *oss = gfc_get_omp_set_selector (); - oss->next = odv->set_selectors; - oss->trait_set_selector_name = selector_sets[i]; - odv->set_selectors = oss; - - if (gfc_match_omp_context_selector (oss) != MATCH_YES) - return MATCH_ERROR; - - m = gfc_match (" }"); - if (m != MATCH_YES) - { - gfc_error ("expected '}' at %C"); - return MATCH_ERROR; - } - - m = gfc_match (" ,"); - if (m != MATCH_YES) - break; - } - while (1); - - return MATCH_YES; -} - - -match -gfc_match_omp_declare_variant (void) -{ - bool first_p = true; - char buf[GFC_MAX_SYMBOL_LEN + 1]; - - if (gfc_match (" (") != MATCH_YES) - { - gfc_error ("expected '(' at %C"); - return MATCH_ERROR; - } - - gfc_symtree *base_proc_st, *variant_proc_st; - if (gfc_match_name (buf) != MATCH_YES) - { - gfc_error ("expected name at %C"); - return MATCH_ERROR; - } - - if (gfc_get_ha_sym_tree (buf, &base_proc_st)) - return MATCH_ERROR; - - if (gfc_match (" :") == MATCH_YES) - { - if (gfc_match_name (buf) != MATCH_YES) - { - gfc_error ("expected variant name at %C"); - return MATCH_ERROR; - } - - if (gfc_get_ha_sym_tree (buf, &variant_proc_st)) - return MATCH_ERROR; - } - else - { - /* Base procedure not specified. */ - variant_proc_st = base_proc_st; - base_proc_st = NULL; - } - - gfc_omp_declare_variant *odv; - odv = gfc_get_omp_declare_variant (); - odv->where = gfc_current_locus; - odv->variant_proc_symtree = variant_proc_st; - odv->base_proc_symtree = base_proc_st; - odv->next = NULL; - odv->error_p = false; - - /* Add the new declare variant to the end of the list. */ - gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant; - while (*prev_next) - prev_next = &((*prev_next)->next); - *prev_next = odv; - - if (gfc_match (" )") != MATCH_YES) - { - gfc_error ("expected ')' at %C"); - return MATCH_ERROR; - } - - for (;;) - { - if (gfc_match (" match") != MATCH_YES) - { - if (first_p) - { - gfc_error ("expected 'match' at %C"); - return MATCH_ERROR; - } - else - break; - } - - if (gfc_match (" (") != MATCH_YES) - { - gfc_error ("expected '(' at %C"); - return MATCH_ERROR; - } - - if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES) - return MATCH_ERROR; - - if (gfc_match (" )") != MATCH_YES) - { - gfc_error ("expected ')' at %C"); - return MATCH_ERROR; - } - - first_p = false; - } - - return MATCH_YES; -} - - -match -gfc_match_omp_threadprivate (void) -{ - locus old_loc; - char n[GFC_MAX_SYMBOL_LEN+1]; - gfc_symbol *sym; - match m; - gfc_symtree *st; - - old_loc = gfc_current_locus; - - m = gfc_match (" ("); - if (m != MATCH_YES) - return m; - - for (;;) - { - m = gfc_match_symbol (&sym, 0); - switch (m) - { - case MATCH_YES: - if (sym->attr.in_common) - gfc_error_now ("Threadprivate variable at %C is an element of " - "a COMMON block"); - else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) - goto cleanup; - goto next_item; - case MATCH_NO: - break; - case MATCH_ERROR: - goto cleanup; - } - - m = gfc_match (" / %n /", n); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO || n[0] == '\0') - goto syntax; - - st = gfc_find_symtree (gfc_current_ns->common_root, n); - if (st == NULL) - { - gfc_error ("COMMON block /%s/ not found at %C", n); - goto cleanup; - } - st->n.common->threadprivate = 1; - for (sym = st->n.common->head; sym; sym = sym->common_next) - if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) - goto cleanup; - - next_item: - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C"); - goto cleanup; - } - - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); - -cleanup: - gfc_current_locus = old_loc; - return MATCH_ERROR; -} - - -match -gfc_match_omp_parallel (void) -{ - return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); -} - - -match -gfc_match_omp_parallel_do (void) -{ - return match_omp (EXEC_OMP_PARALLEL_DO, - OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES); -} - - -match -gfc_match_omp_parallel_do_simd (void) -{ - return match_omp (EXEC_OMP_PARALLEL_DO_SIMD, - OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_parallel_masked (void) -{ - return match_omp (EXEC_OMP_PARALLEL_MASKED, - OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES); -} - -match -gfc_match_omp_parallel_masked_taskloop (void) -{ - return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP, - (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES - | OMP_TASKLOOP_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); -} - -match -gfc_match_omp_parallel_masked_taskloop_simd (void) -{ - return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, - (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES - | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); -} - -match -gfc_match_omp_parallel_master (void) -{ - return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES); -} - -match -gfc_match_omp_parallel_master_taskloop (void) -{ - return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP, - (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); -} - -match -gfc_match_omp_parallel_master_taskloop_simd (void) -{ - return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD, - (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES - | OMP_SIMD_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); -} - -match -gfc_match_omp_parallel_sections (void) -{ - return match_omp (EXEC_OMP_PARALLEL_SECTIONS, - OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES); -} - - -match -gfc_match_omp_parallel_workshare (void) -{ - return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES); -} - -void -gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires) -{ - if (ns->omp_target_seen - && (ns->omp_requires & OMP_REQ_TARGET_MASK) - != (ref_omp_requires & OMP_REQ_TARGET_MASK)) - { - gcc_assert (ns->proc_name); - if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD) - && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) - gfc_error ("Program unit at %L has OpenMP device constructs/routines " - "but does not set !$OMP REQUIRES REVERSE_OFFSET but other " - "program units do", &ns->proc_name->declared_at); - if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS) - && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS)) - gfc_error ("Program unit at %L has OpenMP device constructs/routines " - "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other " - "program units do", &ns->proc_name->declared_at); - if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) - && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)) - gfc_error ("Program unit at %L has OpenMP device constructs/routines " - "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but " - "other program units do", &ns->proc_name->declared_at); - } -} - -bool -gfc_omp_requires_add_clause (gfc_omp_requires_kind clause, - const char *clause_name, locus *loc, - const char *module_name) -{ - gfc_namespace *prog_unit = gfc_current_ns; - while (prog_unit->parent) - { - if (gfc_state_stack->previous - && gfc_state_stack->previous->state == COMP_INTERFACE) - break; - prog_unit = prog_unit->parent; - } - - /* Requires added after use. */ - if (prog_unit->omp_target_seen - && (clause & OMP_REQ_TARGET_MASK) - && !(prog_unit->omp_requires & clause)) - { - if (module_name) - gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use " - "at %L comes after using a device construct/routine", - clause_name, module_name, loc); - else - gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after " - "using a device construct/routine", clause_name, loc); - return false; - } - - /* Overriding atomic_default_mem_order clause value. */ - if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - != (int) clause) - { - const char *other; - if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) - other = "seq_cst"; - else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) - other = "acq_rel"; - else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) - other = "relaxed"; - else - gcc_unreachable (); - - if (module_name) - gfc_error ("!$OMP REQUIRES clause % " - "specified via module %qs use at %L overrides a previous " - "% (which might be through " - "using a module)", clause_name, module_name, loc, other); - else - gfc_error ("!$OMP REQUIRES clause % " - "specified at %L overrides a previous " - "% (which might be through " - "using a module)", clause_name, loc, other); - return false; - } - - /* Requires via module not at program-unit level and not repeating clause. */ - if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause)) - { - if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - gfc_error ("!$OMP REQUIRES clause % " - "specified via module %qs use at %L but same clause is " - "not specified for the program unit", clause_name, - module_name, loc); - else - gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at " - "%L but same clause is not specified for the program unit", - clause_name, module_name, loc); - return false; - } - - if (!gfc_state_stack->previous - || gfc_state_stack->previous->state != COMP_INTERFACE) - prog_unit->omp_requires |= clause; - return true; -} - -match -gfc_match_omp_requires (void) -{ - static const char *clauses[] = {"reverse_offload", - "unified_address", - "unified_shared_memory", - "dynamic_allocators", - "atomic_default"}; - const char *clause = NULL; - int requires_clauses = 0; - bool first = true; - locus old_loc; - - if (gfc_current_ns->parent - && (!gfc_state_stack->previous - || gfc_state_stack->previous->state != COMP_INTERFACE)) - { - gfc_error ("!$OMP REQUIRES at %C must appear in the specification part " - "of a program unit"); - return MATCH_ERROR; - } - - while (true) - { - old_loc = gfc_current_locus; - gfc_omp_requires_kind requires_clause; - if ((first || gfc_match_char (',') != MATCH_YES) - && (first && gfc_match_space () != MATCH_YES)) - goto error; - first = false; - gfc_gobble_whitespace (); - old_loc = gfc_current_locus; - - if (gfc_match_omp_eos () != MATCH_NO) - break; - if (gfc_match (clauses[0]) == MATCH_YES) - { - clause = clauses[0]; - requires_clause = OMP_REQ_REVERSE_OFFLOAD; - if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD) - goto duplicate_clause; - } - else if (gfc_match (clauses[1]) == MATCH_YES) - { - clause = clauses[1]; - requires_clause = OMP_REQ_UNIFIED_ADDRESS; - if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS) - goto duplicate_clause; - } - else if (gfc_match (clauses[2]) == MATCH_YES) - { - clause = clauses[2]; - requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY; - if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY) - goto duplicate_clause; - } - else if (gfc_match (clauses[3]) == MATCH_YES) - { - clause = clauses[3]; - requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS; - if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS) - goto duplicate_clause; - } - else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES) - { - clause = clauses[4]; - if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - goto duplicate_clause; - if (gfc_match (" seq_cst )") == MATCH_YES) - { - clause = "seq_cst"; - requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST; - } - else if (gfc_match (" acq_rel )") == MATCH_YES) - { - clause = "acq_rel"; - requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL; - } - else if (gfc_match (" relaxed )") == MATCH_YES) - { - clause = "relaxed"; - requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED; - } - else - { - gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for " - "ATOMIC_DEFAULT_MEM_ORDER clause at %C"); - goto error; - } - } - else - goto error; - - if (requires_clause & ~(OMP_REQ_ATOMIC_MEM_ORDER_MASK - | OMP_REQ_DYNAMIC_ALLOCATORS)) - gfc_error_now ("Sorry, %qs clause at %L on REQUIRES directive is not " - "yet supported", clause, &old_loc); - if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL)) - goto error; - requires_clauses |= requires_clause; - } - - if (requires_clauses == 0) - { - if (!gfc_error_flag_test ()) - gfc_error ("Clause expected at %C"); - goto error; - } - return MATCH_YES; - -duplicate_clause: - gfc_error ("%qs clause at %L specified more than once", clause, &old_loc); -error: - if (!gfc_error_flag_test ()) - gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, " - "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or " - "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc); - return MATCH_ERROR; -} - - -match -gfc_match_omp_scan (void) -{ - bool incl; - gfc_omp_clauses *c = gfc_get_omp_clauses (); - gfc_gobble_whitespace (); - if ((incl = (gfc_match ("inclusive") == MATCH_YES)) - || gfc_match ("exclusive") == MATCH_YES) - { - if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN - : OMP_LIST_SCAN_EX], - false) != MATCH_YES) - { - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - } - else - { - gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C"); - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after !$OMP SCAN at %C"); - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - - new_st.op = EXEC_OMP_SCAN; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -match -gfc_match_omp_scope (void) -{ - return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES); -} - - -match -gfc_match_omp_sections (void) -{ - return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES); -} - - -match -gfc_match_omp_simd (void) -{ - return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_single (void) -{ - return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES); -} - - -match -gfc_match_omp_target (void) -{ - return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES); -} - - -match -gfc_match_omp_target_data (void) -{ - return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES); -} - - -match -gfc_match_omp_target_enter_data (void) -{ - return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES); -} - - -match -gfc_match_omp_target_exit_data (void) -{ - return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES); -} - - -match -gfc_match_omp_target_parallel (void) -{ - return match_omp (EXEC_OMP_TARGET_PARALLEL, - (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_COPYIN))); -} - - -match -gfc_match_omp_target_parallel_do (void) -{ - return match_omp (EXEC_OMP_TARGET_PARALLEL_DO, - (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES - | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); -} - - -match -gfc_match_omp_target_parallel_do_simd (void) -{ - return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD, - (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES - | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); -} - - -match -gfc_match_omp_target_simd (void) -{ - return match_omp (EXEC_OMP_TARGET_SIMD, - OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_target_teams (void) -{ - return match_omp (EXEC_OMP_TARGET_TEAMS, - OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES); -} - - -match -gfc_match_omp_target_teams_distribute (void) -{ - return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE, - OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES - | OMP_DISTRIBUTE_CLAUSES); -} - - -match -gfc_match_omp_target_teams_distribute_parallel_do (void) -{ - return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, - (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES - | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES - | OMP_DO_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_ORDERED)) - & ~(omp_mask (OMP_CLAUSE_LINEAR))); -} - - -match -gfc_match_omp_target_teams_distribute_parallel_do_simd (void) -{ - return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES - | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES - | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_ORDERED))); -} - - -match -gfc_match_omp_target_teams_distribute_simd (void) -{ - return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD, - OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES - | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_target_update (void) -{ - return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES); -} - - -match -gfc_match_omp_task (void) -{ - return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES); -} - - -match -gfc_match_omp_taskloop (void) -{ - return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES); -} - - -match -gfc_match_omp_taskloop_simd (void) -{ - return match_omp (EXEC_OMP_TASKLOOP_SIMD, - OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_taskwait (void) -{ - if (gfc_match_omp_eos () == MATCH_YES) - { - new_st.op = EXEC_OMP_TASKWAIT; - new_st.ext.omp_clauses = NULL; - return MATCH_YES; - } - return match_omp (EXEC_OMP_TASKWAIT, omp_mask (OMP_CLAUSE_DEPEND)); -} - - -match -gfc_match_omp_taskyield (void) -{ - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after TASKYIELD clause at %C"); - return MATCH_ERROR; - } - new_st.op = EXEC_OMP_TASKYIELD; - new_st.ext.omp_clauses = NULL; - return MATCH_YES; -} - - -match -gfc_match_omp_teams (void) -{ - return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES); -} - - -match -gfc_match_omp_teams_distribute (void) -{ - return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE, - OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES); -} - - -match -gfc_match_omp_teams_distribute_parallel_do (void) -{ - return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO, - (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES - | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) - & ~(omp_mask (OMP_CLAUSE_ORDERED)) - & ~(omp_mask (OMP_CLAUSE_LINEAR))); -} - - -match -gfc_match_omp_teams_distribute_parallel_do_simd (void) -{ - return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, - (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES - | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES - | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED))); -} - - -match -gfc_match_omp_teams_distribute_simd (void) -{ - return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD, - OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES - | OMP_SIMD_CLAUSES); -} - - -match -gfc_match_omp_workshare (void) -{ - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C"); - return MATCH_ERROR; - } - new_st.op = EXEC_OMP_WORKSHARE; - new_st.ext.omp_clauses = gfc_get_omp_clauses (); - return MATCH_YES; -} - - -match -gfc_match_omp_masked (void) -{ - return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES); -} - -match -gfc_match_omp_masked_taskloop (void) -{ - return match_omp (EXEC_OMP_MASKED_TASKLOOP, - OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES); -} - -match -gfc_match_omp_masked_taskloop_simd (void) -{ - return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD, - (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES - | OMP_SIMD_CLAUSES)); -} - -match -gfc_match_omp_master (void) -{ - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP MASTER statement at %C"); - return MATCH_ERROR; - } - new_st.op = EXEC_OMP_MASTER; - new_st.ext.omp_clauses = NULL; - return MATCH_YES; -} - -match -gfc_match_omp_master_taskloop (void) -{ - return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES); -} - -match -gfc_match_omp_master_taskloop_simd (void) -{ - return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD, - OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); -} - -match -gfc_match_omp_ordered (void) -{ - return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES); -} - -match -gfc_match_omp_nothing (void) -{ - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP NOTHING statement at %C"); - return MATCH_ERROR; - } - /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */ - return MATCH_YES; -} - -match -gfc_match_omp_ordered_depend (void) -{ - return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND)); -} - - -/* omp atomic [clause-list] - - atomic-clause: read | write | update - - capture - - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed - - hint(hint-expr) - - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak -*/ - -match -gfc_match_omp_atomic (void) -{ - gfc_omp_clauses *c; - locus loc = gfc_current_locus; - - if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES) - return MATCH_ERROR; - - if (c->atomic_op == GFC_OMP_ATOMIC_UNSET) - c->atomic_op = GFC_OMP_ATOMIC_UPDATE; - - if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) - gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " - "READ or WRITE", &loc, "CAPTURE"); - if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) - gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " - "READ or WRITE", &loc, "COMPARE"); - if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) - gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " - "READ or WRITE", &loc, "FAIL"); - if (c->weak && !c->compare) - { - gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc, - "WEAK", "COMPARE"); - c->weak = false; - } - - if (c->memorder == OMP_MEMORDER_UNSET) - { - gfc_namespace *prog_unit = gfc_current_ns; - while (prog_unit->parent) - prog_unit = prog_unit->parent; - switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - { - case 0: - case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: - c->memorder = OMP_MEMORDER_RELAXED; - break; - case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: - c->memorder = OMP_MEMORDER_SEQ_CST; - break; - case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: - if (c->capture) - c->memorder = OMP_MEMORDER_ACQ_REL; - else if (c->atomic_op == GFC_OMP_ATOMIC_READ) - c->memorder = OMP_MEMORDER_ACQUIRE; - else - c->memorder = OMP_MEMORDER_RELEASE; - break; - default: - gcc_unreachable (); - } - } - else - switch (c->atomic_op) - { - case GFC_OMP_ATOMIC_READ: - if (c->memorder == OMP_MEMORDER_RELEASE) - { - gfc_error ("!$OMP ATOMIC READ at %L incompatible with " - "RELEASE clause", &loc); - c->memorder = OMP_MEMORDER_SEQ_CST; - } - else if (c->memorder == OMP_MEMORDER_ACQ_REL) - c->memorder = OMP_MEMORDER_ACQUIRE; - break; - case GFC_OMP_ATOMIC_WRITE: - if (c->memorder == OMP_MEMORDER_ACQUIRE) - { - gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with " - "ACQUIRE clause", &loc); - c->memorder = OMP_MEMORDER_SEQ_CST; - } - else if (c->memorder == OMP_MEMORDER_ACQ_REL) - c->memorder = OMP_MEMORDER_RELEASE; - break; - default: - break; - } - gfc_error_check (); - new_st.ext.omp_clauses = c; - new_st.op = EXEC_OMP_ATOMIC; - return MATCH_YES; -} - - -/* acc atomic [ read | write | update | capture] */ - -match -gfc_match_oacc_atomic (void) -{ - gfc_omp_clauses *c = gfc_get_omp_clauses (); - c->atomic_op = GFC_OMP_ATOMIC_UPDATE; - c->memorder = OMP_MEMORDER_RELAXED; - gfc_gobble_whitespace (); - if (gfc_match ("update") == MATCH_YES) - ; - else if (gfc_match ("read") == MATCH_YES) - c->atomic_op = GFC_OMP_ATOMIC_READ; - else if (gfc_match ("write") == MATCH_YES) - c->atomic_op = GFC_OMP_ATOMIC_WRITE; - else if (gfc_match ("capture") == MATCH_YES) - c->capture = true; - gfc_gobble_whitespace (); - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C"); - gfc_free_omp_clauses (c); - return MATCH_ERROR; - } - new_st.ext.omp_clauses = c; - new_st.op = EXEC_OACC_ATOMIC; - return MATCH_YES; -} - - -match -gfc_match_omp_barrier (void) -{ - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP BARRIER statement at %C"); - return MATCH_ERROR; - } - new_st.op = EXEC_OMP_BARRIER; - new_st.ext.omp_clauses = NULL; - return MATCH_YES; -} - - -match -gfc_match_omp_taskgroup (void) -{ - return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES); -} - - -static enum gfc_omp_cancel_kind -gfc_match_omp_cancel_kind (void) -{ - if (gfc_match_space () != MATCH_YES) - return OMP_CANCEL_UNKNOWN; - if (gfc_match ("parallel") == MATCH_YES) - return OMP_CANCEL_PARALLEL; - if (gfc_match ("sections") == MATCH_YES) - return OMP_CANCEL_SECTIONS; - if (gfc_match ("do") == MATCH_YES) - return OMP_CANCEL_DO; - if (gfc_match ("taskgroup") == MATCH_YES) - return OMP_CANCEL_TASKGROUP; - return OMP_CANCEL_UNKNOWN; -} - - -match -gfc_match_omp_cancel (void) -{ - gfc_omp_clauses *c; - enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); - if (kind == OMP_CANCEL_UNKNOWN) - return MATCH_ERROR; - if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES) - return MATCH_ERROR; - c->cancel = kind; - new_st.op = EXEC_OMP_CANCEL; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -match -gfc_match_omp_cancellation_point (void) -{ - gfc_omp_clauses *c; - enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); - if (kind == OMP_CANCEL_UNKNOWN) - { - gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP " - "in $OMP CANCELLATION POINT statement at %C"); - return MATCH_ERROR; - } - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement " - "at %C"); - return MATCH_ERROR; - } - c = gfc_get_omp_clauses (); - c->cancel = kind; - new_st.op = EXEC_OMP_CANCELLATION_POINT; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -match -gfc_match_omp_end_nowait (void) -{ - bool nowait = false; - if (gfc_match ("% nowait") == MATCH_YES) - nowait = true; - if (gfc_match_omp_eos () != MATCH_YES) - { - if (nowait) - gfc_error ("Unexpected junk after NOWAIT clause at %C"); - else - gfc_error ("Unexpected junk at %C"); - return MATCH_ERROR; - } - new_st.op = EXEC_OMP_END_NOWAIT; - new_st.ext.omp_bool = nowait; - return MATCH_YES; -} - - -match -gfc_match_omp_end_single (void) -{ - gfc_omp_clauses *c; - if (gfc_match ("% nowait") == MATCH_YES) - { - new_st.op = EXEC_OMP_END_NOWAIT; - new_st.ext.omp_bool = true; - return MATCH_YES; - } - if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)) - != MATCH_YES) - return MATCH_ERROR; - new_st.op = EXEC_OMP_END_SINGLE; - new_st.ext.omp_clauses = c; - return MATCH_YES; -} - - -static bool -oacc_is_loop (gfc_code *code) -{ - return code->op == EXEC_OACC_PARALLEL_LOOP - || code->op == EXEC_OACC_KERNELS_LOOP - || code->op == EXEC_OACC_SERIAL_LOOP - || code->op == EXEC_OACC_LOOP; -} - -static void -resolve_scalar_int_expr (gfc_expr *expr, const char *clause) -{ - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_INTEGER - || expr->rank != 0) - gfc_error ("%s clause at %L requires a scalar INTEGER expression", - clause, &expr->where); -} - -static void -resolve_positive_int_expr (gfc_expr *expr, const char *clause) -{ - resolve_scalar_int_expr (expr, clause); - if (expr->expr_type == EXPR_CONSTANT - && expr->ts.type == BT_INTEGER - && mpz_sgn (expr->value.integer) <= 0) - gfc_warning (0, "INTEGER expression of %s clause at %L must be positive", - clause, &expr->where); -} - -static void -resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause) -{ - resolve_scalar_int_expr (expr, clause); - if (expr->expr_type == EXPR_CONSTANT - && expr->ts.type == BT_INTEGER - && mpz_sgn (expr->value.integer) < 0) - gfc_warning (0, "INTEGER expression of %s clause at %L must be " - "non-negative", clause, &expr->where); -} - -/* Emits error when symbol is pointer, cray pointer or cray pointee - of derived of polymorphic type. */ - -static void -check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name) -{ - if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer) - gfc_error ("Cray pointer object %qs of derived type in %s clause at %L", - sym->name, name, &loc); - if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee) - gfc_error ("Cray pointee object %qs of derived type in %s clause at %L", - sym->name, name, &loc); - - if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.pointer)) - gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L", - sym->name, name, &loc); - if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.cray_pointer)) - gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L", - sym->name, name, &loc); - if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.cray_pointee)) - gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L", - sym->name, name, &loc); -} - -/* Emits error when symbol represents assumed size/rank array. */ - -static void -check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name) -{ - if (sym->as && sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array %qs in %s clause at %L", - sym->name, name, &loc); - if (sym->as && sym->as->type == AS_ASSUMED_RANK) - gfc_error ("Assumed rank array %qs in %s clause at %L", - sym->name, name, &loc); -} - -static void -resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) -{ - check_array_not_assumed (sym, loc, name); -} - -static void -resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name) -{ - if (sym->attr.pointer - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.class_pointer)) - gfc_error ("POINTER object %qs in %s clause at %L", - sym->name, name, &loc); - if (sym->attr.cray_pointer - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.cray_pointer)) - gfc_error ("Cray pointer object %qs in %s clause at %L", - sym->name, name, &loc); - if (sym->attr.cray_pointee - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.cray_pointee)) - gfc_error ("Cray pointee object %qs in %s clause at %L", - sym->name, name, &loc); - if (sym->attr.allocatable - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.allocatable)) - gfc_error ("ALLOCATABLE object %qs in %s clause at %L", - sym->name, name, &loc); - if (sym->attr.value) - gfc_error ("VALUE object %qs in %s clause at %L", - sym->name, name, &loc); - check_array_not_assumed (sym, loc, name); -} - - -struct resolve_omp_udr_callback_data -{ - gfc_symbol *sym1, *sym2; -}; - - -static int -resolve_omp_udr_callback (gfc_expr **e, int *, void *data) -{ - struct resolve_omp_udr_callback_data *rcd - = (struct resolve_omp_udr_callback_data *) data; - if ((*e)->expr_type == EXPR_VARIABLE - && ((*e)->symtree->n.sym == rcd->sym1 - || (*e)->symtree->n.sym == rcd->sym2)) - { - gfc_ref *ref = gfc_get_ref (); - ref->type = REF_ARRAY; - ref->u.ar.where = (*e)->where; - ref->u.ar.as = (*e)->symtree->n.sym->as; - ref->u.ar.type = AR_FULL; - ref->u.ar.dimen = 0; - ref->next = (*e)->ref; - (*e)->ref = ref; - } - return 0; -} - - -static int -resolve_omp_udr_callback2 (gfc_expr **e, int *, void *) -{ - if ((*e)->expr_type == EXPR_FUNCTION - && (*e)->value.function.isym == NULL) - { - gfc_symbol *sym = (*e)->symtree->n.sym; - if (!sym->attr.intrinsic - && sym->attr.if_source == IFSRC_UNKNOWN) - gfc_error ("Implicitly declared function %s used in " - "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where); - } - return 0; -} - - -static gfc_code * -resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, - gfc_symbol *sym1, gfc_symbol *sym2) -{ - gfc_code *copy; - gfc_symbol sym1_copy, sym2_copy; - - if (ns->code->op == EXEC_ASSIGN) - { - copy = gfc_get_code (EXEC_ASSIGN); - copy->expr1 = gfc_copy_expr (ns->code->expr1); - copy->expr2 = gfc_copy_expr (ns->code->expr2); - } - else - { - copy = gfc_get_code (EXEC_CALL); - copy->symtree = ns->code->symtree; - copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual); - } - copy->loc = ns->code->loc; - sym1_copy = *sym1; - sym2_copy = *sym2; - *sym1 = *n->sym; - *sym2 = *n->sym; - sym1->name = sym1_copy.name; - sym2->name = sym2_copy.name; - ns->proc_name = ns->parent->proc_name; - if (n->sym->attr.dimension) - { - struct resolve_omp_udr_callback_data rcd; - rcd.sym1 = sym1; - rcd.sym2 = sym2; - gfc_code_walker (©, gfc_dummy_code_callback, - resolve_omp_udr_callback, &rcd); - } - gfc_resolve_code (copy, gfc_current_ns); - if (copy->op == EXEC_CALL && copy->resolved_isym == NULL) - { - gfc_symbol *sym = copy->resolved_sym; - if (sym - && !sym->attr.intrinsic - && sym->attr.if_source == IFSRC_UNKNOWN) - gfc_error ("Implicitly declared subroutine %s used in " - "!$OMP DECLARE REDUCTION at %L", sym->name, - ©->loc); - } - gfc_code_walker (©, gfc_dummy_code_callback, - resolve_omp_udr_callback2, NULL); - *sym1 = sym1_copy; - *sym2 = sym2_copy; - return copy; -} - -/* OpenMP directive resolving routines. */ - -static void -resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, - gfc_namespace *ns, bool openacc = false) -{ - gfc_omp_namelist *n; - gfc_expr_list *el; - int list; - int ifc; - bool if_without_mod = false; - gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; - static const char *clause_names[] - = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", - "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP", - "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", - "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, - "IN_REDUCTION", "TASK_REDUCTION", - "DEVICE_RESIDENT", "LINK", "USE_DEVICE", - "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", - "NONTEMPORAL", "ALLOCATE" }; - STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); - - if (omp_clauses == NULL) - return; - - if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) - gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L", - &code->loc); - if (omp_clauses->order_concurrent && omp_clauses->ordered) - gfc_error ("ORDER clause must not be used together ORDERED at %L", - &code->loc); - if (omp_clauses->if_expr) - { - gfc_expr *expr = omp_clauses->if_expr; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_LOGICAL || expr->rank != 0) - gfc_error ("IF clause at %L requires a scalar LOGICAL expression", - &expr->where); - if_without_mod = true; - } - for (ifc = 0; ifc < OMP_IF_LAST; ifc++) - if (omp_clauses->if_exprs[ifc]) - { - gfc_expr *expr = omp_clauses->if_exprs[ifc]; - bool ok = true; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_LOGICAL || expr->rank != 0) - gfc_error ("IF clause at %L requires a scalar LOGICAL expression", - &expr->where); - else if (if_without_mod) - { - gfc_error ("IF clause without modifier at %L used together with " - "IF clauses with modifiers", - &omp_clauses->if_expr->where); - if_without_mod = false; - } - else - switch (code->op) - { - case EXEC_OMP_CANCEL: - ok = ifc == OMP_IF_CANCEL; - break; - - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - ok = ifc == OMP_IF_PARALLEL; - break; - - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD; - break; - - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP; - break; - - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - ok = (ifc == OMP_IF_PARALLEL - || ifc == OMP_IF_TASKLOOP - || ifc == OMP_IF_SIMD); - break; - - case EXEC_OMP_SIMD: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - ok = ifc == OMP_IF_SIMD; - break; - - case EXEC_OMP_TASK: - ok = ifc == OMP_IF_TASK; - break; - - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP: - ok = ifc == OMP_IF_TASKLOOP; - break; - - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD; - break; - - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_LOOP: - ok = ifc == OMP_IF_TARGET; - break; - - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_SIMD: - ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD; - break; - - case EXEC_OMP_TARGET_DATA: - ok = ifc == OMP_IF_TARGET_DATA; - break; - - case EXEC_OMP_TARGET_UPDATE: - ok = ifc == OMP_IF_TARGET_UPDATE; - break; - - case EXEC_OMP_TARGET_ENTER_DATA: - ok = ifc == OMP_IF_TARGET_ENTER_DATA; - break; - - case EXEC_OMP_TARGET_EXIT_DATA: - ok = ifc == OMP_IF_TARGET_EXIT_DATA; - break; - - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL; - break; - - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - ok = (ifc == OMP_IF_TARGET - || ifc == OMP_IF_PARALLEL - || ifc == OMP_IF_SIMD); - break; - - default: - ok = false; - break; - } - if (!ok) - { - static const char *ifs[] = { - "CANCEL", - "PARALLEL", - "SIMD", - "TASK", - "TASKLOOP", - "TARGET", - "TARGET DATA", - "TARGET UPDATE", - "TARGET ENTER DATA", - "TARGET EXIT DATA" - }; - gfc_error ("IF clause modifier %s at %L not appropriate for " - "the current OpenMP construct", ifs[ifc], &expr->where); - } - } - - if (omp_clauses->final_expr) - { - gfc_expr *expr = omp_clauses->final_expr; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_LOGICAL || expr->rank != 0) - gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression", - &expr->where); - } - if (omp_clauses->num_threads) - resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); - if (omp_clauses->chunk_size) - { - gfc_expr *expr = omp_clauses->chunk_size; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_INTEGER || expr->rank != 0) - gfc_error ("SCHEDULE clause's chunk_size at %L requires " - "a scalar INTEGER expression", &expr->where); - else if (expr->expr_type == EXPR_CONSTANT - && expr->ts.type == BT_INTEGER - && mpz_sgn (expr->value.integer) <= 0) - gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size " - "at %L must be positive", &expr->where); - } - if (omp_clauses->sched_kind != OMP_SCHED_NONE - && omp_clauses->sched_nonmonotonic) - { - if (omp_clauses->sched_monotonic) - gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers " - "specified at %L", &code->loc); - else if (omp_clauses->ordered) - gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED " - "clause at %L", &code->loc); - } - - if (omp_clauses->depobj - && (!gfc_resolve_expr (omp_clauses->depobj) - || omp_clauses->depobj->ts.type != BT_INTEGER - || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind - || omp_clauses->depobj->rank != 0)) - gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer " - "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where); - - /* Check that no symbol appears on multiple clauses, except that - a symbol can appear on both firstprivate and lastprivate. */ - for (list = 0; list < OMP_LIST_NUM; list++) - for (n = omp_clauses->lists[list]; n; n = n->next) - { - n->sym->mark = 0; - n->sym->comp_mark = 0; - if (n->sym->attr.flavor == FL_VARIABLE - || n->sym->attr.proc_pointer - || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) - { - if (!code && (!n->sym->attr.dummy || n->sym->ns != ns)) - gfc_error ("Variable %qs is not a dummy argument at %L", - n->sym->name, &n->where); - continue; - } - if (n->sym->attr.flavor == FL_PROCEDURE - && n->sym->result == n->sym - && n->sym->attr.function) - { - if (gfc_current_ns->proc_name == n->sym - || (gfc_current_ns->parent - && gfc_current_ns->parent->proc_name == n->sym)) - continue; - if (gfc_current_ns->proc_name->attr.entry_master) - { - gfc_entry_list *el = gfc_current_ns->entries; - for (; el; el = el->next) - if (el->sym == n->sym) - break; - if (el) - continue; - } - if (gfc_current_ns->parent - && gfc_current_ns->parent->proc_name->attr.entry_master) - { - gfc_entry_list *el = gfc_current_ns->parent->entries; - for (; el; el = el->next) - if (el->sym == n->sym) - break; - if (el) - continue; - } - } - if (list == OMP_LIST_MAP - && n->sym->attr.flavor == FL_PARAMETER) - { - if (openacc) - gfc_error ("Object %qs is not a variable at %L; parameters" - " cannot be and need not be copied", n->sym->name, - &n->where); - else - gfc_error ("Object %qs is not a variable at %L; parameters" - " cannot be and need not be mapped", n->sym->name, - &n->where); - } - else - gfc_error ("Object %qs is not a variable at %L", n->sym->name, - &n->where); - } - if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN] - && code->op != EXEC_OMP_DO - && code->op != EXEC_OMP_SIMD - && code->op != EXEC_OMP_DO_SIMD - && code->op != EXEC_OMP_PARALLEL_DO - && code->op != EXEC_OMP_PARALLEL_DO_SIMD) - gfc_error ("% REDUCTION clause on construct other than DO, SIMD, " - "DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L", - &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where); - - for (list = 0; list < OMP_LIST_NUM; list++) - if (list != OMP_LIST_FIRSTPRIVATE - && list != OMP_LIST_LASTPRIVATE - && list != OMP_LIST_ALIGNED - && list != OMP_LIST_DEPEND - && (list != OMP_LIST_MAP || openacc) - && list != OMP_LIST_FROM - && list != OMP_LIST_TO - && (list != OMP_LIST_REDUCTION || !openacc) - && list != OMP_LIST_REDUCTION_INSCAN - && list != OMP_LIST_REDUCTION_TASK - && list != OMP_LIST_IN_REDUCTION - && list != OMP_LIST_TASK_REDUCTION - && list != OMP_LIST_ALLOCATE) - for (n = omp_clauses->lists[list]; n; n = n->next) - { - bool component_ref_p = false; - - /* Allow multiple components of the same (e.g. derived-type) - variable here. Duplicate components are detected elsewhere. */ - if (n->expr && n->expr->expr_type == EXPR_VARIABLE) - for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - component_ref_p = true; - if ((!component_ref_p && n->sym->comp_mark) - || (component_ref_p && n->sym->mark)) - gfc_error ("Symbol %qs has mixed component and non-component " - "accesses at %L", n->sym->name, &n->where); - else if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &n->where); - else - { - if (component_ref_p) - n->sym->comp_mark = 1; - else - n->sym->mark = 1; - } - } - - gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); - for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) - for (n = omp_clauses->lists[list]; n; n = n->next) - if (n->sym->mark) - { - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &n->where); - n->sym->mark = 0; - } - - for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) - { - if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &n->where); - else - n->sym->mark = 1; - } - for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) - n->sym->mark = 0; - - for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) - { - if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &n->where); - else - n->sym->mark = 1; - } - - for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) - n->sym->mark = 0; - - for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) - { - if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &n->where); - else - n->sym->mark = 1; - } - - if (omp_clauses->lists[OMP_LIST_ALLOCATE]) - { - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (n->expr && (n->expr->ts.type != BT_INTEGER - || n->expr->ts.kind != gfc_c_intptr_kind)) - { - gfc_error ("Expected integer expression of the " - "'omp_allocator_handle_kind' kind at %L", - &n->expr->where); - break; - } - - /* Check for 2 things here. - 1. There is no duplication of variable in allocate clause. - 2. Variable in allocate clause are also present in some - privatization clase (non-composite case). */ - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - n->sym->mark = 0; - - gfc_omp_namelist *prev = NULL; - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;) - { - if (n->sym->mark == 1) - { - gfc_warning (0, "%qs appears more than once in % " - "clauses at %L" , n->sym->name, &n->where); - /* We have already seen this variable so it is a duplicate. - Remove it. */ - if (prev != NULL && prev->next == n) - { - prev->next = n->next; - n->next = NULL; - gfc_free_omp_namelist (n, 0); - n = prev->next; - } - continue; - } - n->sym->mark = 1; - prev = n; - n = n->next; - } - - /* Non-composite constructs. */ - if (code && code->op < EXEC_OMP_DO_SIMD) - { - for (list = 0; list < OMP_LIST_NUM; list++) - switch (list) - { - case OMP_LIST_PRIVATE: - case OMP_LIST_FIRSTPRIVATE: - case OMP_LIST_LASTPRIVATE: - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: - case OMP_LIST_IN_REDUCTION: - case OMP_LIST_TASK_REDUCTION: - case OMP_LIST_LINEAR: - for (n = omp_clauses->lists[list]; n; n = n->next) - n->sym->mark = 0; - break; - default: - break; - } - - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (n->sym->mark == 1) - gfc_error ("%qs specified in 'allocate' clause at %L but not " - "in an explicit privatization clause", - n->sym->name, &n->where); - } - } - - /* OpenACC reductions. */ - if (openacc) - { - for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) - n->sym->mark = 0; - - for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) - { - if (n->sym->mark) - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &n->where); - else - n->sym->mark = 1; - - /* OpenACC does not support reductions on arrays. */ - if (n->sym->as) - gfc_error ("Array %qs is not permitted in reduction at %L", - n->sym->name, &n->where); - } - } - - for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) - n->sym->mark = 0; - for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next) - if (n->expr == NULL) - n->sym->mark = 1; - for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) - { - if (n->expr == NULL && n->sym->mark) - gfc_error ("Symbol %qs present on both FROM and TO clauses at %L", - n->sym->name, &n->where); - else - n->sym->mark = 1; - } - - bool has_inscan = false, has_notinscan = false; - for (list = 0; list < OMP_LIST_NUM; list++) - if ((n = omp_clauses->lists[list]) != NULL) - { - const char *name = clause_names[list]; - - switch (list) - { - case OMP_LIST_COPYIN: - for (; n != NULL; n = n->next) - { - if (!n->sym->attr.threadprivate) - gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause" - " at %L", n->sym->name, &n->where); - } - break; - case OMP_LIST_COPYPRIVATE: - for (; n != NULL; n = n->next) - { - if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array %qs in COPYPRIVATE clause " - "at %L", n->sym->name, &n->where); - if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) - gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause " - "at %L", n->sym->name, &n->where); - } - break; - case OMP_LIST_SHARED: - for (; n != NULL; n = n->next) - { - if (n->sym->attr.threadprivate) - gfc_error ("THREADPRIVATE object %qs in SHARED clause at " - "%L", n->sym->name, &n->where); - if (n->sym->attr.cray_pointee) - gfc_error ("Cray pointee %qs in SHARED clause at %L", - n->sym->name, &n->where); - if (n->sym->attr.associate_var) - gfc_error ("ASSOCIATE name %qs in SHARED clause at %L", - n->sym->name, &n->where); - if (omp_clauses->detach - && n->sym == omp_clauses->detach->symtree->n.sym) - gfc_error ("DETACH event handle %qs in SHARED clause at %L", - n->sym->name, &n->where); - } - break; - case OMP_LIST_ALIGNED: - for (; n != NULL; n = n->next) - { - if (!n->sym->attr.pointer - && !n->sym->attr.allocatable - && !n->sym->attr.cray_pointer - && (n->sym->ts.type != BT_DERIVED - || (n->sym->ts.u.derived->from_intmod - != INTMOD_ISO_C_BINDING) - || (n->sym->ts.u.derived->intmod_sym_id - != ISOCBINDING_PTR))) - gfc_error ("%qs in ALIGNED clause must be POINTER, " - "ALLOCATABLE, Cray pointer or C_PTR at %L", - n->sym->name, &n->where); - else if (n->expr) - { - gfc_expr *expr = n->expr; - int alignment = 0; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_INTEGER - || expr->rank != 0 - || gfc_extract_int (expr, &alignment) - || alignment <= 0) - gfc_error ("%qs in ALIGNED clause at %L requires a scalar " - "positive constant integer alignment " - "expression", n->sym->name, &n->where); - } - } - break; - case OMP_LIST_AFFINITY: - case OMP_LIST_DEPEND: - case OMP_LIST_MAP: - case OMP_LIST_TO: - case OMP_LIST_FROM: - case OMP_LIST_CACHE: - for (; n != NULL; n = n->next) - { - if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY) - && n->u2.ns && !n->u2.ns->resolved) - { - n->u2.ns->resolved = 1; - for (gfc_symbol *sym = n->u2.ns->proc_name; sym; - sym = sym->tlink) - { - gfc_constructor *c; - c = gfc_constructor_first (sym->value->value.constructor); - if (!gfc_resolve_expr (c->expr) - || c->expr->ts.type != BT_INTEGER - || c->expr->rank != 0) - gfc_error ("Scalar integer expression for range begin" - " expected at %L", &c->expr->where); - c = gfc_constructor_next (c); - if (!gfc_resolve_expr (c->expr) - || c->expr->ts.type != BT_INTEGER - || c->expr->rank != 0) - gfc_error ("Scalar integer expression for range end " - "expected at %L", &c->expr->where); - c = gfc_constructor_next (c); - if (c && (!gfc_resolve_expr (c->expr) - || c->expr->ts.type != BT_INTEGER - || c->expr->rank != 0)) - gfc_error ("Scalar integer expression for range step " - "expected at %L", &c->expr->where); - else if (c - && c->expr->expr_type == EXPR_CONSTANT - && mpz_cmp_si (c->expr->value.integer, 0) == 0) - gfc_error ("Nonzero range step expected at %L", - &c->expr->where); - } - } - - if (list == OMP_LIST_DEPEND) - { - if (n->u.depend_op == OMP_DEPEND_SINK_FIRST - || n->u.depend_op == OMP_DEPEND_SINK) - { - if (code->op != EXEC_OMP_ORDERED) - gfc_error ("SINK dependence type only allowed " - "on ORDERED directive at %L", &n->where); - else if (omp_clauses->depend_source) - { - gfc_error ("DEPEND SINK used together with " - "DEPEND SOURCE on the same construct " - "at %L", &n->where); - omp_clauses->depend_source = false; - } - else if (n->expr) - { - if (!gfc_resolve_expr (n->expr) - || n->expr->ts.type != BT_INTEGER - || n->expr->rank != 0) - gfc_error ("SINK addend not a constant integer " - "at %L", &n->where); - } - continue; - } - else if (code->op == EXEC_OMP_ORDERED) - gfc_error ("Only SOURCE or SINK dependence types " - "are allowed on ORDERED directive at %L", - &n->where); - else if (n->u.depend_op == OMP_DEPEND_DEPOBJ - && !n->expr - && (n->sym->ts.type != BT_INTEGER - || n->sym->ts.kind - != 2 * gfc_index_integer_kind - || n->sym->attr.dimension)) - gfc_error ("Locator %qs at %L in DEPEND clause of depobj " - "type shall be a scalar integer of " - "OMP_DEPEND_KIND kind", n->sym->name, - &n->where); - else if (n->u.depend_op == OMP_DEPEND_DEPOBJ - && n->expr - && (!gfc_resolve_expr (n->expr) - || n->expr->ts.type != BT_INTEGER - || n->expr->ts.kind - != 2 * gfc_index_integer_kind - || n->expr->rank != 0)) - gfc_error ("Locator at %L in DEPEND clause of depobj " - "type shall be a scalar integer of " - "OMP_DEPEND_KIND kind", &n->expr->where); - } - gfc_ref *lastref = NULL, *lastslice = NULL; - bool resolved = false; - if (n->expr) - { - lastref = n->expr->ref; - resolved = gfc_resolve_expr (n->expr); - - /* Look through component refs to find last array - reference. */ - if (resolved) - { - for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT - || ref->type == REF_SUBSTRING - || ref->type == REF_INQUIRY) - lastref = ref; - else if (ref->type == REF_ARRAY) - { - for (int i = 0; i < ref->u.ar.dimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_RANGE) - lastslice = ref; - - lastref = ref; - } - - /* The "!$acc cache" directive allows rectangular - subarrays to be specified, with some restrictions - on the form of bounds (not implemented). - Only raise an error here if we're really sure the - array isn't contiguous. An expression such as - arr(-n:n,-n:n) could be contiguous even if it looks - like it may not be. */ - if (code->op != EXEC_OACC_UPDATE - && list != OMP_LIST_CACHE - && list != OMP_LIST_DEPEND - && !gfc_is_simply_contiguous (n->expr, false, true) - && gfc_is_not_contiguous (n->expr) - && !(lastslice - && (lastslice->next - || lastslice->type != REF_ARRAY))) - gfc_error ("Array is not contiguous at %L", - &n->where); - } - } - if (lastref - || (n->expr - && (!resolved || n->expr->expr_type != EXPR_VARIABLE))) - { - if (!lastslice - && lastref - && lastref->type == REF_SUBSTRING) - gfc_error ("Unexpected substring reference in %s clause " - "at %L", name, &n->where); - else if (!lastslice - && lastref - && lastref->type == REF_INQUIRY) - { - gcc_assert (lastref->u.i == INQUIRY_RE - || lastref->u.i == INQUIRY_IM); - gfc_error ("Unexpected complex-parts designator " - "reference in %s clause at %L", - name, &n->where); - } - else if (!resolved - || n->expr->expr_type != EXPR_VARIABLE - || (lastslice - && (lastslice->next - || lastslice->type != REF_ARRAY))) - gfc_error ("%qs in %s clause at %L is not a proper " - "array section", n->sym->name, name, - &n->where); - else if (lastslice) - { - int i; - gfc_array_ref *ar = &lastslice->u.ar; - for (i = 0; i < ar->dimen; i++) - if (ar->stride[i] && code->op != EXEC_OACC_UPDATE) - { - gfc_error ("Stride should not be specified for " - "array section in %s clause at %L", - name, &n->where); - break; - } - else if (ar->dimen_type[i] != DIMEN_ELEMENT - && ar->dimen_type[i] != DIMEN_RANGE) - { - gfc_error ("%qs in %s clause at %L is not a " - "proper array section", - n->sym->name, name, &n->where); - break; - } - else if ((list == OMP_LIST_DEPEND - || list == OMP_LIST_AFFINITY) - && ar->start[i] - && ar->start[i]->expr_type == EXPR_CONSTANT - && ar->end[i] - && ar->end[i]->expr_type == EXPR_CONSTANT - && mpz_cmp (ar->start[i]->value.integer, - ar->end[i]->value.integer) > 0) - { - gfc_error ("%qs in %s clause at %L is a " - "zero size array section", - n->sym->name, - list == OMP_LIST_DEPEND - ? "DEPEND" : "AFFINITY", &n->where); - break; - } - } - } - else if (openacc) - { - if (list == OMP_LIST_MAP - && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR) - resolve_oacc_deviceptr_clause (n->sym, n->where, name); - else - resolve_oacc_data_clauses (n->sym, n->where, name); - } - else if (list != OMP_LIST_DEPEND - && n->sym->as - && n->sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (!openacc - && list == OMP_LIST_MAP - && n->sym->ts.type == BT_DERIVED - && n->sym->ts.u.derived->attr.alloc_comp) - gfc_error ("List item %qs with allocatable components is not " - "permitted in map clause at %L", n->sym->name, - &n->where); - if (list == OMP_LIST_MAP && !openacc) - switch (code->op) - { - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - switch (n->u.map_op) - { - case OMP_MAP_TO: - case OMP_MAP_ALWAYS_TO: - case OMP_MAP_FROM: - case OMP_MAP_ALWAYS_FROM: - case OMP_MAP_TOFROM: - case OMP_MAP_ALWAYS_TOFROM: - case OMP_MAP_ALLOC: - break; - default: - gfc_error ("TARGET%s with map-type other than TO, " - "FROM, TOFROM, or ALLOC on MAP clause " - "at %L", - code->op == EXEC_OMP_TARGET - ? "" : " DATA", &n->where); - break; - } - break; - case EXEC_OMP_TARGET_ENTER_DATA: - switch (n->u.map_op) - { - case OMP_MAP_TO: - case OMP_MAP_ALWAYS_TO: - case OMP_MAP_ALLOC: - break; - default: - gfc_error ("TARGET ENTER DATA with map-type other " - "than TO, or ALLOC on MAP clause at %L", - &n->where); - break; - } - break; - case EXEC_OMP_TARGET_EXIT_DATA: - switch (n->u.map_op) - { - case OMP_MAP_FROM: - case OMP_MAP_ALWAYS_FROM: - case OMP_MAP_RELEASE: - case OMP_MAP_DELETE: - break; - default: - gfc_error ("TARGET EXIT DATA with map-type other " - "than FROM, RELEASE, or DELETE on MAP " - "clause at %L", &n->where); - break; - } - break; - default: - break; - } - } - - if (list != OMP_LIST_DEPEND) - for (n = omp_clauses->lists[list]; n != NULL; n = n->next) - { - n->sym->attr.referenced = 1; - if (n->sym->attr.threadprivate) - gfc_error ("THREADPRIVATE object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.cray_pointee) - gfc_error ("Cray pointee %qs in %s clause at %L", - n->sym->name, name, &n->where); - } - break; - case OMP_LIST_IS_DEVICE_PTR: - for (n = omp_clauses->lists[list]; n != NULL; n = n->next) - { - if (!n->sym->attr.dummy) - gfc_error ("Non-dummy object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.allocatable - || (n->sym->ts.type == BT_CLASS - && CLASS_DATA (n->sym)->attr.allocatable)) - gfc_error ("ALLOCATABLE object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.pointer - || (n->sym->ts.type == BT_CLASS - && CLASS_DATA (n->sym)->attr.pointer)) - gfc_error ("POINTER object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.value) - gfc_error ("VALUE object %qs in %s clause at %L", - n->sym->name, name, &n->where); - } - break; - case OMP_LIST_USE_DEVICE_PTR: - case OMP_LIST_USE_DEVICE_ADDR: - /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */ - break; - default: - for (; n != NULL; n = n->next) - { - bool bad = false; - bool is_reduction = (list == OMP_LIST_REDUCTION - || list == OMP_LIST_REDUCTION_INSCAN - || list == OMP_LIST_REDUCTION_TASK - || list == OMP_LIST_IN_REDUCTION - || list == OMP_LIST_TASK_REDUCTION); - if (list == OMP_LIST_REDUCTION_INSCAN) - has_inscan = true; - else if (is_reduction) - has_notinscan = true; - if (has_inscan && has_notinscan && is_reduction) - { - gfc_error ("% and non-% % " - "clauses on the same construct at %L", - &n->where); - break; - } - if (n->sym->attr.threadprivate) - gfc_error ("THREADPRIVATE object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.cray_pointee) - gfc_error ("Cray pointee %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.associate_var) - gfc_error ("ASSOCIATE name %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (list != OMP_LIST_PRIVATE && is_reduction) - { - if (n->sym->attr.proc_pointer) - gfc_error ("Procedure pointer %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.pointer) - gfc_error ("POINTER object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.cray_pointer) - gfc_error ("Cray pointer %qs in %s clause at %L", - n->sym->name, name, &n->where); - } - if (code - && (oacc_is_loop (code) - || code->op == EXEC_OACC_PARALLEL - || code->op == EXEC_OACC_SERIAL)) - check_array_not_assumed (n->sym, n->where, name); - else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.in_namelist && !is_reduction) - gfc_error ("Variable %qs in %s clause is used in " - "NAMELIST statement at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) - switch (list) - { - case OMP_LIST_PRIVATE: - case OMP_LIST_LASTPRIVATE: - case OMP_LIST_LINEAR: - /* case OMP_LIST_REDUCTION: */ - gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L", - n->sym->name, name, &n->where); - break; - default: - break; - } - if (omp_clauses->detach - && (list == OMP_LIST_PRIVATE - || list == OMP_LIST_FIRSTPRIVATE - || list == OMP_LIST_LASTPRIVATE) - && n->sym == omp_clauses->detach->symtree->n.sym) - gfc_error ("DETACH event handle %qs in %s clause at %L", - n->sym->name, name, &n->where); - switch (list) - { - case OMP_LIST_REDUCTION_TASK: - if (code - && (code->op == EXEC_OMP_LOOP - || code->op == EXEC_OMP_TASKLOOP - || code->op == EXEC_OMP_TASKLOOP_SIMD - || code->op == EXEC_OMP_MASKED_TASKLOOP - || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD - || code->op == EXEC_OMP_MASTER_TASKLOOP - || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD - || code->op == EXEC_OMP_PARALLEL_LOOP - || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP - || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD - || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP - || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD - || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP - || code->op == EXEC_OMP_TARGET_TEAMS_LOOP - || code->op == EXEC_OMP_TEAMS - || code->op == EXEC_OMP_TEAMS_DISTRIBUTE - || code->op == EXEC_OMP_TEAMS_LOOP)) - { - gfc_error ("Only DEFAULT permitted as reduction-" - "modifier in REDUCTION clause at %L", - &n->where); - break; - } - gcc_fallthrough (); - case OMP_LIST_REDUCTION: - case OMP_LIST_IN_REDUCTION: - case OMP_LIST_TASK_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - switch (n->u.reduction_op) - { - case OMP_REDUCTION_PLUS: - case OMP_REDUCTION_TIMES: - case OMP_REDUCTION_MINUS: - if (!gfc_numeric_ts (&n->sym->ts)) - bad = true; - break; - case OMP_REDUCTION_AND: - case OMP_REDUCTION_OR: - case OMP_REDUCTION_EQV: - case OMP_REDUCTION_NEQV: - if (n->sym->ts.type != BT_LOGICAL) - bad = true; - break; - case OMP_REDUCTION_MAX: - case OMP_REDUCTION_MIN: - if (n->sym->ts.type != BT_INTEGER - && n->sym->ts.type != BT_REAL) - bad = true; - break; - case OMP_REDUCTION_IAND: - case OMP_REDUCTION_IOR: - case OMP_REDUCTION_IEOR: - if (n->sym->ts.type != BT_INTEGER) - bad = true; - break; - case OMP_REDUCTION_USER: - bad = true; - break; - default: - break; - } - if (!bad) - n->u2.udr = NULL; - else - { - const char *udr_name = NULL; - if (n->u2.udr) - { - udr_name = n->u2.udr->udr->name; - n->u2.udr->udr - = gfc_find_omp_udr (NULL, udr_name, - &n->sym->ts); - if (n->u2.udr->udr == NULL) - { - free (n->u2.udr); - n->u2.udr = NULL; - } - } - if (n->u2.udr == NULL) - { - if (udr_name == NULL) - switch (n->u.reduction_op) - { - case OMP_REDUCTION_PLUS: - case OMP_REDUCTION_TIMES: - case OMP_REDUCTION_MINUS: - case OMP_REDUCTION_AND: - case OMP_REDUCTION_OR: - case OMP_REDUCTION_EQV: - case OMP_REDUCTION_NEQV: - udr_name = gfc_op2string ((gfc_intrinsic_op) - n->u.reduction_op); - break; - case OMP_REDUCTION_MAX: - udr_name = "max"; - break; - case OMP_REDUCTION_MIN: - udr_name = "min"; - break; - case OMP_REDUCTION_IAND: - udr_name = "iand"; - break; - case OMP_REDUCTION_IOR: - udr_name = "ior"; - break; - case OMP_REDUCTION_IEOR: - udr_name = "ieor"; - break; - default: - gcc_unreachable (); - } - gfc_error ("!$OMP DECLARE REDUCTION %s not found " - "for type %s at %L", udr_name, - gfc_typename (&n->sym->ts), &n->where); - } - else - { - gfc_omp_udr *udr = n->u2.udr->udr; - n->u.reduction_op = OMP_REDUCTION_USER; - n->u2.udr->combiner - = resolve_omp_udr_clause (n, udr->combiner_ns, - udr->omp_out, - udr->omp_in); - if (udr->initializer_ns) - n->u2.udr->initializer - = resolve_omp_udr_clause (n, - udr->initializer_ns, - udr->omp_priv, - udr->omp_orig); - } - } - break; - case OMP_LIST_LINEAR: - if (code - && n->u.linear_op != OMP_LINEAR_DEFAULT - && n->u.linear_op != linear_op) - { - gfc_error ("LINEAR clause modifier used on DO or SIMD" - " construct at %L", &n->where); - linear_op = n->u.linear_op; - } - else if (omp_clauses->orderedc) - gfc_error ("LINEAR clause specified together with " - "ORDERED clause with argument at %L", - &n->where); - else if (n->u.linear_op != OMP_LINEAR_REF - && n->sym->ts.type != BT_INTEGER) - gfc_error ("LINEAR variable %qs must be INTEGER " - "at %L", n->sym->name, &n->where); - else if ((n->u.linear_op == OMP_LINEAR_REF - || n->u.linear_op == OMP_LINEAR_UVAL) - && n->sym->attr.value) - gfc_error ("LINEAR dummy argument %qs with VALUE " - "attribute with %s modifier at %L", - n->sym->name, - n->u.linear_op == OMP_LINEAR_REF - ? "REF" : "UVAL", &n->where); - else if (n->expr) - { - gfc_expr *expr = n->expr; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_INTEGER - || expr->rank != 0) - gfc_error ("%qs in LINEAR clause at %L requires " - "a scalar integer linear-step expression", - n->sym->name, &n->where); - else if (!code && expr->expr_type != EXPR_CONSTANT) - { - if (expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym->attr.dummy - && expr->symtree->n.sym->ns == ns) - { - gfc_omp_namelist *n2; - for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM]; - n2; n2 = n2->next) - if (n2->sym == expr->symtree->n.sym) - break; - if (n2) - break; - } - gfc_error ("%qs in LINEAR clause at %L requires " - "a constant integer linear-step " - "expression or dummy argument " - "specified in UNIFORM clause", - n->sym->name, &n->where); - } - } - break; - /* Workaround for PR middle-end/26316, nothing really needs - to be done here for OMP_LIST_PRIVATE. */ - case OMP_LIST_PRIVATE: - gcc_assert (code && code->op != EXEC_NOP); - break; - case OMP_LIST_USE_DEVICE: - if (n->sym->attr.allocatable - || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym) - && CLASS_DATA (n->sym)->attr.allocatable)) - gfc_error ("ALLOCATABLE object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->ts.type == BT_CLASS - && CLASS_DATA (n->sym) - && CLASS_DATA (n->sym)->attr.class_pointer) - gfc_error ("POINTER object %qs of polymorphic type in " - "%s clause at %L", n->sym->name, name, - &n->where); - if (n->sym->attr.cray_pointer) - gfc_error ("Cray pointer object %qs in %s clause at %L", - n->sym->name, name, &n->where); - else if (n->sym->attr.cray_pointee) - gfc_error ("Cray pointee object %qs in %s clause at %L", - n->sym->name, name, &n->where); - else if (n->sym->attr.flavor == FL_VARIABLE - && !n->sym->as - && !n->sym->attr.pointer) - gfc_error ("%s clause variable %qs at %L is neither " - "a POINTER nor an array", name, - n->sym->name, &n->where); - /* FALLTHRU */ - case OMP_LIST_DEVICE_RESIDENT: - check_symbol_not_pointer (n->sym, n->where, name); - check_array_not_assumed (n->sym, n->where, name); - break; - default: - break; - } - } - break; - } - } - /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for - type(c_ptr). */ - if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR]) - { - gfc_omp_namelist *n_prev, *n_next, *n_addr; - n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR]; - for (; n_addr && n_addr->next; n_addr = n_addr->next) - ; - n_prev = NULL; - n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR]; - while (n) - { - n_next = n->next; - if (n->sym->ts.type != BT_DERIVED - || n->sym->ts.u.derived->ts.f90_type != BT_VOID) - { - n->next = NULL; - if (n_addr) - n_addr->next = n; - else - omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n; - n_addr = n; - if (n_prev) - n_prev->next = n_next; - else - omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next; - } - else - n_prev = n; - n = n_next; - } - } - if (omp_clauses->safelen_expr) - resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN"); - if (omp_clauses->simdlen_expr) - resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN"); - if (omp_clauses->num_teams_lower) - resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS"); - if (omp_clauses->num_teams_upper) - resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS"); - if (omp_clauses->num_teams_lower - && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT - && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT - && mpz_cmp (omp_clauses->num_teams_lower->value.integer, - omp_clauses->num_teams_upper->value.integer) > 0) - gfc_warning (0, "NUM_TEAMS lower bound at %L larger than upper bound at %L", - &omp_clauses->num_teams_lower->where, - &omp_clauses->num_teams_upper->where); - if (omp_clauses->device) - resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE"); - if (omp_clauses->filter) - resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER"); - if (omp_clauses->hint) - { - resolve_scalar_int_expr (omp_clauses->hint, "HINT"); - if (omp_clauses->hint->ts.type != BT_INTEGER - || omp_clauses->hint->expr_type != EXPR_CONSTANT - || mpz_sgn (omp_clauses->hint->value.integer) < 0) - gfc_error ("Value of HINT clause at %L shall be a valid " - "constant hint expression", &omp_clauses->hint->where); - } - if (omp_clauses->priority) - resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY"); - if (omp_clauses->dist_chunk_size) - { - gfc_expr *expr = omp_clauses->dist_chunk_size; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_INTEGER || expr->rank != 0) - gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires " - "a scalar INTEGER expression", &expr->where); - } - if (omp_clauses->thread_limit) - resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT"); - if (omp_clauses->grainsize) - resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE"); - if (omp_clauses->num_tasks) - resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS"); - if (omp_clauses->async) - if (omp_clauses->async_expr) - resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC"); - if (omp_clauses->num_gangs_expr) - resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS"); - if (omp_clauses->num_workers_expr) - resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS"); - if (omp_clauses->vector_length_expr) - resolve_positive_int_expr (omp_clauses->vector_length_expr, - "VECTOR_LENGTH"); - if (omp_clauses->gang_num_expr) - resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG"); - if (omp_clauses->gang_static_expr) - resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG"); - if (omp_clauses->worker_expr) - resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER"); - if (omp_clauses->vector_expr) - resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR"); - for (el = omp_clauses->wait_list; el; el = el->next) - resolve_scalar_int_expr (el->expr, "WAIT"); - if (omp_clauses->collapse && omp_clauses->tile_list) - gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc); - if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) - gfc_error ("SOURCE dependence type only allowed " - "on ORDERED directive at %L", &code->loc); - if (omp_clauses->message) - { - gfc_expr *expr = omp_clauses->message; - if (!gfc_resolve_expr (expr) - || expr->ts.kind != gfc_default_character_kind - || expr->ts.type != BT_CHARACTER || expr->rank != 0) - gfc_error ("MESSAGE clause at %L requires a scalar default-kind " - "CHARACTER expression", &expr->where); - } - if (!openacc - && code - && omp_clauses->lists[OMP_LIST_MAP] == NULL - && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL - && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL) - { - const char *p = NULL; - switch (code->op) - { - case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break; - case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break; - default: break; - } - if (code->op == EXEC_OMP_TARGET_DATA) - gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, " - "or USE_DEVICE_ADDR clause at %L", &code->loc); - else if (p) - gfc_error ("%s must contain at least one MAP clause at %L", - p, &code->loc); - } - if (!openacc && omp_clauses->mergeable && omp_clauses->detach) - gfc_error ("% clause at %L must not be used together with " - "% clause", &omp_clauses->detach->where); -} - - -/* Return true if SYM is ever referenced in EXPR except in the SE node. */ - -static bool -expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) -{ - gfc_actual_arglist *arg; - if (e == NULL || e == se) - return false; - switch (e->expr_type) - { - case EXPR_CONSTANT: - case EXPR_NULL: - case EXPR_VARIABLE: - case EXPR_STRUCTURE: - case EXPR_ARRAY: - if (e->symtree != NULL - && e->symtree->n.sym == s) - return true; - return false; - case EXPR_SUBSTRING: - if (e->ref != NULL - && (expr_references_sym (e->ref->u.ss.start, s, se) - || expr_references_sym (e->ref->u.ss.end, s, se))) - return true; - return false; - case EXPR_OP: - if (expr_references_sym (e->value.op.op2, s, se)) - return true; - return expr_references_sym (e->value.op.op1, s, se); - case EXPR_FUNCTION: - for (arg = e->value.function.actual; arg; arg = arg->next) - if (expr_references_sym (arg->expr, s, se)) - return true; - return false; - default: - gcc_unreachable (); - } -} - - -/* If EXPR is a conversion function that widens the type - if WIDENING is true or narrows the type if NARROW is true, - return the inner expression, otherwise return NULL. */ - -static gfc_expr * -is_conversion (gfc_expr *expr, bool narrowing, bool widening) -{ - gfc_typespec *ts1, *ts2; - - if (expr->expr_type != EXPR_FUNCTION - || expr->value.function.isym == NULL - || expr->value.function.esym != NULL - || expr->value.function.isym->id != GFC_ISYM_CONVERSION - || (!narrowing && !widening)) - return NULL; - - if (narrowing && widening) - return expr->value.function.actual->expr; - - if (widening) - { - ts1 = &expr->ts; - ts2 = &expr->value.function.actual->expr->ts; - } - else - { - ts1 = &expr->value.function.actual->expr->ts; - ts2 = &expr->ts; - } - - if (ts1->type > ts2->type - || (ts1->type == ts2->type && ts1->kind > ts2->kind)) - return expr->value.function.actual->expr; - - return NULL; -} - -static bool -is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok) -{ - if (must_be_var - && (expr->expr_type != EXPR_VARIABLE || !expr->symtree) - && (!conv_ok || !is_conversion (expr, true, true))) - return false; - return (expr->rank == 0 - && !gfc_is_coindexed (expr) - && (expr->ts.type == BT_INTEGER - || expr->ts.type == BT_REAL - || expr->ts.type == BT_COMPLEX - || expr->ts.type == BT_LOGICAL)); -} - -static void -resolve_omp_atomic (gfc_code *code) -{ - gfc_code *atomic_code = code->block; - gfc_symbol *var; - gfc_expr *stmt_expr2, *capt_expr2; - gfc_omp_atomic_op aop - = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op - & GFC_OMP_ATOMIC_MASK); - gfc_code *stmt = NULL, *capture_stmt = NULL; - gfc_expr *comp_cond = NULL; - locus *loc = NULL; - - code = code->block->next; - /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF - If it changed to EXEC_NOP, assume an error has been emitted already. */ - if (code->op == EXEC_NOP) - return; - - if (atomic_code->ext.omp_clauses->compare - && atomic_code->ext.omp_clauses->capture) - { - /* Must be either "if (x == e) then; x = d; else; v = x; end if" - or "v = expr" followed/preceded by - "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ - gfc_code *next = code; - if (code->op == EXEC_ASSIGN) - { - capture_stmt = code; - next = code->next; - } - if (next->op == EXEC_IF - && next->block - && next->block->op == EXEC_IF - && next->block->next->op == EXEC_ASSIGN) - { - comp_cond = next->block->expr1; - stmt = next->block->next; - if (stmt->next) - { - loc = &stmt->loc; - goto unexpected; - } - } - else if (capture_stmt) - { - gfc_error ("Expected IF at %L in atomic compare capture", - &next->loc); - return; - } - if (stmt && !capture_stmt && next->block->block) - { - if (next->block->block->expr1) - { - gfc_error ("Expected ELSE at %L in atomic compare capture", - &next->block->block->expr1->where); - return; - } - if (!code->block->block->next - || code->block->block->next->op != EXEC_ASSIGN) - { - loc = (code->block->block->next ? &code->block->block->next->loc - : &code->block->block->loc); - goto unexpected; - } - capture_stmt = code->block->block->next; - if (capture_stmt->next) - { - loc = &capture_stmt->next->loc; - goto unexpected; - } - } - if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN) - capture_stmt = next->next; - else if (!capture_stmt) - { - loc = &code->loc; - goto unexpected; - } - } - else if (atomic_code->ext.omp_clauses->compare) - { - /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ - if (code->op == EXEC_IF - && code->block - && code->block->op == EXEC_IF - && code->block->next->op == EXEC_ASSIGN) - { - comp_cond = code->block->expr1; - stmt = code->block->next; - if (stmt->next || code->block->block) - { - loc = stmt->next ? &stmt->next->loc : &code->block->block->loc; - goto unexpected; - } - } - else - { - loc = &code->loc; - goto unexpected; - } - } - else if (atomic_code->ext.omp_clauses->capture) - { - /* Must be: "v = x" followed/preceded by "x = ...". */ - if (code->op != EXEC_ASSIGN) - goto unexpected; - if (code->next->op != EXEC_ASSIGN) - { - loc = &code->next->loc; - goto unexpected; - } - gfc_expr *expr2, *expr2_next; - expr2 = is_conversion (code->expr2, true, true); - if (expr2 == NULL) - expr2 = code->expr2; - expr2_next = is_conversion (code->next->expr2, true, true); - if (expr2_next == NULL) - expr2_next = code->next->expr2; - if (code->expr1->expr_type == EXPR_VARIABLE - && code->next->expr1->expr_type == EXPR_VARIABLE - && expr2->expr_type == EXPR_VARIABLE - && expr2_next->expr_type == EXPR_VARIABLE) - { - if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym) - { - stmt = code; - capture_stmt = code->next; - } - else - { - capture_stmt = code; - stmt = code->next; - } - } - else if (expr2->expr_type == EXPR_VARIABLE) - { - capture_stmt = code; - stmt = code->next; - } - else - { - stmt = code; - capture_stmt = code->next; - } - gcc_assert (!code->next->next); - } - else - { - /* x = ... */ - stmt = code; - if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN) - goto unexpected; - gcc_assert (!code->next); - } - - if (comp_cond) - { - if (comp_cond->expr_type != EXPR_OP - || (comp_cond->value.op.op != INTRINSIC_EQ - && comp_cond->value.op.op != INTRINSIC_EQ_OS - && comp_cond->value.op.op != INTRINSIC_EQV)) - { - gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison " - "expression at %L", &comp_cond->where); - return; - } - if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true)) - { - gfc_error ("Expected scalar intrinsic variable at %L in atomic " - "comparison", &comp_cond->value.op.op1->where); - return; - } - if (!gfc_resolve_expr (comp_cond->value.op.op2)) - return; - if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false)) - { - gfc_error ("Expected scalar intrinsic expression at %L in atomic " - "comparison", &comp_cond->value.op.op1->where); - return; - } - } - - if (!is_scalar_intrinsic_expr (stmt->expr1, true, false)) - { - gfc_error ("!$OMP ATOMIC statement must set a scalar variable of " - "intrinsic type at %L", &stmt->expr1->where); - return; - } - - if (!gfc_resolve_expr (stmt->expr2)) - return; - if (!is_scalar_intrinsic_expr (stmt->expr2, false, false)) - { - gfc_error ("!$OMP ATOMIC statement must assign an expression of " - "intrinsic type at %L", &stmt->expr2->where); - return; - } - - if (gfc_expr_attr (stmt->expr1).allocatable) - { - gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L", - &stmt->expr1->where); - return; - } - - var = stmt->expr1->symtree->n.sym; - stmt_expr2 = is_conversion (stmt->expr2, true, true); - if (stmt_expr2 == NULL) - stmt_expr2 = stmt->expr2; - - switch (aop) - { - case GFC_OMP_ATOMIC_READ: - if (stmt_expr2->expr_type != EXPR_VARIABLE) - gfc_error ("!$OMP ATOMIC READ statement must read from a scalar " - "variable of intrinsic type at %L", &stmt_expr2->where); - return; - case GFC_OMP_ATOMIC_WRITE: - if (expr_references_sym (stmt_expr2, var, NULL)) - gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr " - "must be scalar and cannot reference var at %L", - &stmt_expr2->where); - return; - default: - break; - } - - if (atomic_code->ext.omp_clauses->capture) - { - if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false)) - { - gfc_error ("!$OMP ATOMIC capture-statement must set a scalar " - "variable of intrinsic type at %L", - &capture_stmt->expr1->where); - return; - } - - if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true)) - { - gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable" - " of intrinsic type at %L", &capture_stmt->expr2->where); - return; - } - capt_expr2 = is_conversion (capture_stmt->expr2, true, true); - if (capt_expr2 == NULL) - capt_expr2 = capture_stmt->expr2; - - if (capt_expr2->symtree->n.sym != var) - { - gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " - "different variable than update statement writes " - "into at %L", &capture_stmt->expr2->where); - return; - } - } - - if (atomic_code->ext.omp_clauses->compare) - { - gfc_expr *var_expr; - if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE) - var_expr = comp_cond->value.op.op1; - else - var_expr = comp_cond->value.op.op1->value.function.actual->expr; - if (var_expr->symtree->n.sym != var) - { - gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison" - " at %L must be the variable %qs that the update statement" - " writes into at %L", &var_expr->where, var->name, - &stmt->expr1->where); - return; - } - if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL)) - { - gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr " - "must be scalar and cannot reference var at %L", - &stmt_expr2->where); - return; - } - } - else if (atomic_code->ext.omp_clauses->capture - && !expr_references_sym (stmt_expr2, var, NULL)) - atomic_code->ext.omp_clauses->atomic_op - = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op - | GFC_OMP_ATOMIC_SWAP); - else if (stmt_expr2->expr_type == EXPR_OP) - { - gfc_expr *v = NULL, *e, *c; - gfc_intrinsic_op op = stmt_expr2->value.op.op; - gfc_intrinsic_op alt_op = INTRINSIC_NONE; - - if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET) - gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either" - " the COMPARE clause or using the intrinsic MIN/MAX " - "procedure", &atomic_code->loc); - switch (op) - { - case INTRINSIC_PLUS: - alt_op = INTRINSIC_MINUS; - break; - case INTRINSIC_TIMES: - alt_op = INTRINSIC_DIVIDE; - break; - case INTRINSIC_MINUS: - alt_op = INTRINSIC_PLUS; - break; - case INTRINSIC_DIVIDE: - alt_op = INTRINSIC_TIMES; - break; - case INTRINSIC_AND: - case INTRINSIC_OR: - break; - case INTRINSIC_EQV: - alt_op = INTRINSIC_NEQV; - break; - case INTRINSIC_NEQV: - alt_op = INTRINSIC_EQV; - break; - default: - gfc_error ("!$OMP ATOMIC assignment operator must be binary " - "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", - &stmt_expr2->where); - return; - } - - /* Check for var = var op expr resp. var = expr op var where - expr doesn't reference var and var op expr is mathematically - equivalent to var op (expr) resp. expr op var equivalent to - (expr) op var. We rely here on the fact that the matcher - for x op1 y op2 z where op1 and op2 have equal precedence - returns (x op1 y) op2 z. */ - e = stmt_expr2->value.op.op2; - if (e->expr_type == EXPR_VARIABLE - && e->symtree != NULL - && e->symtree->n.sym == var) - v = e; - else if ((c = is_conversion (e, false, true)) != NULL - && c->expr_type == EXPR_VARIABLE - && c->symtree != NULL - && c->symtree->n.sym == var) - v = c; - else - { - gfc_expr **p = NULL, **q; - for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; ) - if (e->expr_type == EXPR_VARIABLE - && e->symtree != NULL - && e->symtree->n.sym == var) - { - v = e; - break; - } - else if ((c = is_conversion (e, false, true)) != NULL) - q = &e->value.function.actual->expr; - else if (e->expr_type != EXPR_OP - || (e->value.op.op != op - && e->value.op.op != alt_op) - || e->rank != 0) - break; - else - { - p = q; - q = &e->value.op.op1; - } - - if (v == NULL) - { - gfc_error ("!$OMP ATOMIC assignment must be var = var op expr " - "or var = expr op var at %L", &stmt_expr2->where); - return; - } - - if (p != NULL) - { - e = *p; - switch (e->value.op.op) - { - case INTRINSIC_MINUS: - case INTRINSIC_DIVIDE: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: - gfc_error ("!$OMP ATOMIC var = var op expr not " - "mathematically equivalent to var = var op " - "(expr) at %L", &stmt_expr2->where); - break; - default: - break; - } - - /* Canonicalize into var = var op (expr). */ - *p = e->value.op.op2; - e->value.op.op2 = stmt_expr2; - e->ts = stmt_expr2->ts; - if (stmt->expr2 == stmt_expr2) - stmt->expr2 = stmt_expr2 = e; - else - stmt->expr2->value.function.actual->expr = stmt_expr2 = e; - - if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts, - &stmt_expr2->ts)) - { - for (p = &stmt_expr2->value.op.op1; *p != v; - p = &(*p)->value.function.actual->expr) - ; - *p = NULL; - gfc_free_expr (stmt_expr2->value.op.op1); - stmt_expr2->value.op.op1 = v; - gfc_convert_type (v, &stmt_expr2->ts, 2); - } - } - } - - if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v)) - { - gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr " - "must be scalar and cannot reference var at %L", - &stmt_expr2->where); - return; - } - } - else if (stmt_expr2->expr_type == EXPR_FUNCTION - && stmt_expr2->value.function.isym != NULL - && stmt_expr2->value.function.esym == NULL - && stmt_expr2->value.function.actual != NULL - && stmt_expr2->value.function.actual->next != NULL) - { - gfc_actual_arglist *arg, *var_arg; - - switch (stmt_expr2->value.function.isym->id) - { - case GFC_ISYM_MIN: - case GFC_ISYM_MAX: - break; - case GFC_ISYM_IAND: - case GFC_ISYM_IOR: - case GFC_ISYM_IEOR: - if (stmt_expr2->value.function.actual->next->next != NULL) - { - gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR " - "or IEOR must have two arguments at %L", - &stmt_expr2->where); - return; - } - break; - default: - gfc_error ("!$OMP ATOMIC assignment intrinsic must be " - "MIN, MAX, IAND, IOR or IEOR at %L", - &stmt_expr2->where); - return; - } - - var_arg = NULL; - for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next) - { - gfc_expr *e = NULL; - if (arg == stmt_expr2->value.function.actual - || (var_arg == NULL && arg->next == NULL)) - { - e = is_conversion (arg->expr, false, true); - if (!e) - e = arg->expr; - if (e->expr_type == EXPR_VARIABLE - && e->symtree != NULL - && e->symtree->n.sym == var) - var_arg = arg; - } - if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL)) - { - gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " - "not reference %qs at %L", - var->name, &arg->expr->where); - return; - } - if (arg->expr->rank != 0) - { - gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar " - "at %L", &arg->expr->where); - return; - } - } - - if (var_arg == NULL) - { - gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " - "be %qs at %L", var->name, &stmt_expr2->where); - return; - } - - if (var_arg != stmt_expr2->value.function.actual) - { - /* Canonicalize, so that var comes first. */ - gcc_assert (var_arg->next == NULL); - for (arg = stmt_expr2->value.function.actual; - arg->next != var_arg; arg = arg->next) - ; - var_arg->next = stmt_expr2->value.function.actual; - stmt_expr2->value.function.actual = var_arg; - arg->next = NULL; - } - } - else - gfc_error ("!$OMP ATOMIC assignment must have an operator or " - "intrinsic on right hand side at %L", &stmt_expr2->where); - return; - -unexpected: - gfc_error ("unexpected !$OMP ATOMIC expression at %L", - loc ? loc : &code->loc); - return; -} - - -static struct fortran_omp_context -{ - gfc_code *code; - hash_set *sharing_clauses; - hash_set *private_iterators; - struct fortran_omp_context *previous; - bool is_openmp; -} *omp_current_ctx; -static gfc_code *omp_current_do_code; -static int omp_current_do_collapse; - -void -gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) -{ - if (code->block->next && code->block->next->op == EXEC_DO) - { - int i; - gfc_code *c; - - omp_current_do_code = code->block->next; - if (code->ext.omp_clauses->orderedc) - omp_current_do_collapse = code->ext.omp_clauses->orderedc; - else - omp_current_do_collapse = code->ext.omp_clauses->collapse; - for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++) - { - c = c->block; - if (c->op != EXEC_DO || c->next == NULL) - break; - c = c->next; - if (c->op != EXEC_DO) - break; - } - if (i < omp_current_do_collapse || omp_current_do_collapse <= 0) - omp_current_do_collapse = 1; - if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) - { - locus *loc - = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where; - if (code->ext.omp_clauses->ordered) - gfc_error ("ORDERED clause specified together with % " - "REDUCTION clause at %L", loc); - if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE) - gfc_error ("SCHEDULE clause specified together with % " - "REDUCTION clause at %L", loc); - if (!c->block - || !c->block->next - || !c->block->next->next - || c->block->next->next->op != EXEC_OMP_SCAN - || !c->block->next->next->next - || c->block->next->next->next->next) - gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN " - "between two structured-block-sequences", loc); - else - /* Mark as checked; flag will be unset later. */ - c->block->next->next->ext.omp_clauses->if_present = true; - } - } - gfc_resolve_blocks (code->block, ns); - omp_current_do_collapse = 0; - omp_current_do_code = NULL; -} - - -void -gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) -{ - struct fortran_omp_context ctx; - gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; - gfc_omp_namelist *n; - int list; - - ctx.code = code; - ctx.sharing_clauses = new hash_set; - ctx.private_iterators = new hash_set; - ctx.previous = omp_current_ctx; - ctx.is_openmp = true; - omp_current_ctx = &ctx; - - for (list = 0; list < OMP_LIST_NUM; list++) - switch (list) - { - case OMP_LIST_SHARED: - case OMP_LIST_PRIVATE: - case OMP_LIST_FIRSTPRIVATE: - case OMP_LIST_LASTPRIVATE: - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: - case OMP_LIST_IN_REDUCTION: - case OMP_LIST_TASK_REDUCTION: - case OMP_LIST_LINEAR: - for (n = omp_clauses->lists[list]; n; n = n->next) - ctx.sharing_clauses->add (n->sym); - break; - default: - break; - } - - switch (code->op) - { - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - gfc_resolve_omp_do_blocks (code, ns); - break; - default: - gfc_resolve_blocks (code->block, ns); - } - - omp_current_ctx = ctx.previous; - delete ctx.sharing_clauses; - delete ctx.private_iterators; -} - - -/* Save and clear openmp.c private state. */ - -void -gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state) -{ - state->ptrs[0] = omp_current_ctx; - state->ptrs[1] = omp_current_do_code; - state->ints[0] = omp_current_do_collapse; - omp_current_ctx = NULL; - omp_current_do_code = NULL; - omp_current_do_collapse = 0; -} - - -/* Restore openmp.c private state from the saved state. */ - -void -gfc_omp_restore_state (struct gfc_omp_saved_state *state) -{ - omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0]; - omp_current_do_code = (gfc_code *) state->ptrs[1]; - omp_current_do_collapse = state->ints[0]; -} - - -/* Note a DO iterator variable. This is special in !$omp parallel - construct, where they are predetermined private. */ - -void -gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause) -{ - if (omp_current_ctx == NULL) - return; - - int i = omp_current_do_collapse; - gfc_code *c = omp_current_do_code; - - if (sym->attr.threadprivate) - return; - - /* !$omp do and !$omp parallel do iteration variable is predetermined - private just in the !$omp do resp. !$omp parallel do construct, - with no implications for the outer parallel constructs. */ - - while (i-- >= 1) - { - if (code == c) - return; - - c = c->block->next; - } - - /* An openacc context may represent a data clause. Abort if so. */ - if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code)) - return; - - if (omp_current_ctx->sharing_clauses->contains (sym)) - return; - - if (! omp_current_ctx->private_iterators->add (sym) && add_clause) - { - gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; - gfc_omp_namelist *p; - - p = gfc_get_omp_namelist (); - p->sym = sym; - p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; - omp_clauses->lists[OMP_LIST_PRIVATE] = p; - } -} - -static void -handle_local_var (gfc_symbol *sym) -{ - if (sym->attr.flavor != FL_VARIABLE - || sym->as != NULL - || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL)) - return; - gfc_resolve_do_iterator (sym->ns->code, sym, false); -} - -void -gfc_resolve_omp_local_vars (gfc_namespace *ns) -{ - if (omp_current_ctx) - gfc_traverse_ns (ns, handle_local_var); -} - -static void -resolve_omp_do (gfc_code *code) -{ - gfc_code *do_code, *c; - int list, i, collapse; - gfc_omp_namelist *n; - gfc_symbol *dovar; - const char *name; - bool is_simd = false; - - switch (code->op) - { - case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - name = "!$OMP DISTRIBUTE PARALLEL DO"; - break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; - is_simd = true; - break; - case EXEC_OMP_DISTRIBUTE_SIMD: - name = "!$OMP DISTRIBUTE SIMD"; - is_simd = true; - break; - case EXEC_OMP_DO: name = "!$OMP DO"; break; - case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break; - case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break; - case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break; - case EXEC_OMP_PARALLEL_DO_SIMD: - name = "!$OMP PARALLEL DO SIMD"; - is_simd = true; - break; - case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - name = "!$OMP PARALLEL MASKED TASKLOOP"; - break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - name = "!$OMP PARALLEL MASKED TASKLOOP SIMD"; - is_simd = true; - break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - name = "!$OMP PARALLEL MASTER TASKLOOP"; - break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - name = "!$OMP PARALLEL MASTER TASKLOOP SIMD"; - is_simd = true; - break; - case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break; - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - name = "!$OMP MASKED TASKLOOP SIMD"; - is_simd = true; - break; - case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break; - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - name = "!$OMP MASTER TASKLOOP SIMD"; - is_simd = true; - break; - case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break; - case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break; - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - name = "!$OMP TARGET PARALLEL DO SIMD"; - is_simd = true; - break; - case EXEC_OMP_TARGET_PARALLEL_LOOP: - name = "!$OMP TARGET PARALLEL LOOP"; - break; - case EXEC_OMP_TARGET_SIMD: - name = "!$OMP TARGET SIMD"; - is_simd = true; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - name = "!$OMP TARGET TEAMS DISTRIBUTE"; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; - is_simd = true; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; - is_simd = true; - break; - case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break; - case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break; - case EXEC_OMP_TASKLOOP_SIMD: - name = "!$OMP TASKLOOP SIMD"; - is_simd = true; - break; - case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; - break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; - is_simd = true; - break; - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - name = "!$OMP TEAMS DISTRIBUTE SIMD"; - is_simd = true; - break; - case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break; - default: gcc_unreachable (); - } - - if (code->ext.omp_clauses) - resolve_omp_clauses (code, code->ext.omp_clauses, NULL); - - do_code = code->block->next; - if (code->ext.omp_clauses->orderedc) - collapse = code->ext.omp_clauses->orderedc; - else - { - collapse = code->ext.omp_clauses->collapse; - if (collapse <= 0) - collapse = 1; - } - for (i = 1; i <= collapse; i++) - { - if (do_code->op == EXEC_DO_WHILE) - { - gfc_error ("%s cannot be a DO WHILE or DO without loop control " - "at %L", name, &do_code->loc); - break; - } - if (do_code->op == EXEC_DO_CONCURRENT) - { - gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name, - &do_code->loc); - break; - } - gcc_assert (do_code->op == EXEC_DO); - if (do_code->ext.iterator->var->ts.type != BT_INTEGER) - gfc_error ("%s iteration variable must be of type integer at %L", - name, &do_code->loc); - dovar = do_code->ext.iterator->var->symtree->n.sym; - if (dovar->attr.threadprivate) - gfc_error ("%s iteration variable must not be THREADPRIVATE " - "at %L", name, &do_code->loc); - if (code->ext.omp_clauses) - for (list = 0; list < OMP_LIST_NUM; list++) - if (!is_simd || code->ext.omp_clauses->collapse > 1 - ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE - && list != OMP_LIST_ALLOCATE) - : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE - && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR)) - for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) - if (dovar == n->sym) - { - if (!is_simd || code->ext.omp_clauses->collapse > 1) - gfc_error ("%s iteration variable present on clause " - "other than PRIVATE, LASTPRIVATE or " - "ALLOCATE at %L", name, &do_code->loc); - else - gfc_error ("%s iteration variable present on clause " - "other than PRIVATE, LASTPRIVATE, ALLOCATE or " - "LINEAR at %L", name, &do_code->loc); - break; - } - if (i > 1) - { - gfc_code *do_code2 = code->block->next; - int j; - - for (j = 1; j < i; j++) - { - gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; - if (dovar == ivar - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) - { - gfc_error ("%s collapsed loops don't form rectangular " - "iteration space at %L", name, &do_code->loc); - break; - } - do_code2 = do_code2->block->next; - } - } - for (c = do_code->next; c; c = c->next) - if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) - { - gfc_error ("collapsed %s loops not perfectly nested at %L", - name, &c->loc); - break; - } - if (i == collapse || c) - break; - do_code = do_code->block; - if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE) - { - gfc_error ("not enough DO loops for collapsed %s at %L", - name, &code->loc); - break; - } - do_code = do_code->next; - if (do_code == NULL - || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)) - { - gfc_error ("not enough DO loops for collapsed %s at %L", - name, &code->loc); - break; - } - } -} - - -static gfc_statement -omp_code_to_statement (gfc_code *code) -{ - switch (code->op) - { - case EXEC_OMP_PARALLEL: - return ST_OMP_PARALLEL; - case EXEC_OMP_PARALLEL_MASKED: - return ST_OMP_PARALLEL_MASKED; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - return ST_OMP_PARALLEL_MASKED_TASKLOOP; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD; - case EXEC_OMP_PARALLEL_MASTER: - return ST_OMP_PARALLEL_MASTER; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - return ST_OMP_PARALLEL_MASTER_TASKLOOP; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD; - case EXEC_OMP_PARALLEL_SECTIONS: - return ST_OMP_PARALLEL_SECTIONS; - case EXEC_OMP_SECTIONS: - return ST_OMP_SECTIONS; - case EXEC_OMP_ORDERED: - return ST_OMP_ORDERED; - case EXEC_OMP_CRITICAL: - return ST_OMP_CRITICAL; - case EXEC_OMP_MASKED: - return ST_OMP_MASKED; - case EXEC_OMP_MASKED_TASKLOOP: - return ST_OMP_MASKED_TASKLOOP; - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - return ST_OMP_MASKED_TASKLOOP_SIMD; - case EXEC_OMP_MASTER: - return ST_OMP_MASTER; - case EXEC_OMP_MASTER_TASKLOOP: - return ST_OMP_MASTER_TASKLOOP; - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - return ST_OMP_MASTER_TASKLOOP_SIMD; - case EXEC_OMP_SINGLE: - return ST_OMP_SINGLE; - case EXEC_OMP_TASK: - return ST_OMP_TASK; - case EXEC_OMP_WORKSHARE: - return ST_OMP_WORKSHARE; - case EXEC_OMP_PARALLEL_WORKSHARE: - return ST_OMP_PARALLEL_WORKSHARE; - case EXEC_OMP_DO: - return ST_OMP_DO; - case EXEC_OMP_LOOP: - return ST_OMP_LOOP; - case EXEC_OMP_ATOMIC: - return ST_OMP_ATOMIC; - case EXEC_OMP_BARRIER: - return ST_OMP_BARRIER; - case EXEC_OMP_CANCEL: - return ST_OMP_CANCEL; - case EXEC_OMP_CANCELLATION_POINT: - return ST_OMP_CANCELLATION_POINT; - case EXEC_OMP_ERROR: - return ST_OMP_ERROR; - case EXEC_OMP_FLUSH: - return ST_OMP_FLUSH; - case EXEC_OMP_DISTRIBUTE: - return ST_OMP_DISTRIBUTE; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - return ST_OMP_DISTRIBUTE_PARALLEL_DO; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD; - case EXEC_OMP_DISTRIBUTE_SIMD: - return ST_OMP_DISTRIBUTE_SIMD; - case EXEC_OMP_DO_SIMD: - return ST_OMP_DO_SIMD; - case EXEC_OMP_SCAN: - return ST_OMP_SCAN; - case EXEC_OMP_SCOPE: - return ST_OMP_SCOPE; - case EXEC_OMP_SIMD: - return ST_OMP_SIMD; - case EXEC_OMP_TARGET: - return ST_OMP_TARGET; - case EXEC_OMP_TARGET_DATA: - return ST_OMP_TARGET_DATA; - case EXEC_OMP_TARGET_ENTER_DATA: - return ST_OMP_TARGET_ENTER_DATA; - case EXEC_OMP_TARGET_EXIT_DATA: - return ST_OMP_TARGET_EXIT_DATA; - case EXEC_OMP_TARGET_PARALLEL: - return ST_OMP_TARGET_PARALLEL; - case EXEC_OMP_TARGET_PARALLEL_DO: - return ST_OMP_TARGET_PARALLEL_DO; - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - return ST_OMP_TARGET_PARALLEL_DO_SIMD; - case EXEC_OMP_TARGET_PARALLEL_LOOP: - return ST_OMP_TARGET_PARALLEL_LOOP; - case EXEC_OMP_TARGET_SIMD: - return ST_OMP_TARGET_SIMD; - case EXEC_OMP_TARGET_TEAMS: - return ST_OMP_TARGET_TEAMS; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - return ST_OMP_TARGET_TEAMS_DISTRIBUTE; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD; - case EXEC_OMP_TARGET_TEAMS_LOOP: - return ST_OMP_TARGET_TEAMS_LOOP; - case EXEC_OMP_TARGET_UPDATE: - return ST_OMP_TARGET_UPDATE; - case EXEC_OMP_TASKGROUP: - return ST_OMP_TASKGROUP; - case EXEC_OMP_TASKLOOP: - return ST_OMP_TASKLOOP; - case EXEC_OMP_TASKLOOP_SIMD: - return ST_OMP_TASKLOOP_SIMD; - case EXEC_OMP_TASKWAIT: - return ST_OMP_TASKWAIT; - case EXEC_OMP_TASKYIELD: - return ST_OMP_TASKYIELD; - case EXEC_OMP_TEAMS: - return ST_OMP_TEAMS; - case EXEC_OMP_TEAMS_DISTRIBUTE: - return ST_OMP_TEAMS_DISTRIBUTE; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - return ST_OMP_TEAMS_DISTRIBUTE_SIMD; - case EXEC_OMP_TEAMS_LOOP: - return ST_OMP_TEAMS_LOOP; - case EXEC_OMP_PARALLEL_DO: - return ST_OMP_PARALLEL_DO; - case EXEC_OMP_PARALLEL_DO_SIMD: - return ST_OMP_PARALLEL_DO_SIMD; - case EXEC_OMP_PARALLEL_LOOP: - return ST_OMP_PARALLEL_LOOP; - case EXEC_OMP_DEPOBJ: - return ST_OMP_DEPOBJ; - default: - gcc_unreachable (); - } -} - -static gfc_statement -oacc_code_to_statement (gfc_code *code) -{ - switch (code->op) - { - case EXEC_OACC_PARALLEL: - return ST_OACC_PARALLEL; - case EXEC_OACC_KERNELS: - return ST_OACC_KERNELS; - case EXEC_OACC_SERIAL: - return ST_OACC_SERIAL; - case EXEC_OACC_DATA: - return ST_OACC_DATA; - case EXEC_OACC_HOST_DATA: - return ST_OACC_HOST_DATA; - case EXEC_OACC_PARALLEL_LOOP: - return ST_OACC_PARALLEL_LOOP; - case EXEC_OACC_KERNELS_LOOP: - return ST_OACC_KERNELS_LOOP; - case EXEC_OACC_SERIAL_LOOP: - return ST_OACC_SERIAL_LOOP; - case EXEC_OACC_LOOP: - return ST_OACC_LOOP; - case EXEC_OACC_ATOMIC: - return ST_OACC_ATOMIC; - case EXEC_OACC_ROUTINE: - return ST_OACC_ROUTINE; - case EXEC_OACC_UPDATE: - return ST_OACC_UPDATE; - case EXEC_OACC_WAIT: - return ST_OACC_WAIT; - case EXEC_OACC_CACHE: - return ST_OACC_CACHE; - case EXEC_OACC_ENTER_DATA: - return ST_OACC_ENTER_DATA; - case EXEC_OACC_EXIT_DATA: - return ST_OACC_EXIT_DATA; - case EXEC_OACC_DECLARE: - return ST_OACC_DECLARE; - default: - gcc_unreachable (); - } -} - -static void -resolve_oacc_directive_inside_omp_region (gfc_code *code) -{ - if (omp_current_ctx != NULL && omp_current_ctx->is_openmp) - { - gfc_statement st = omp_code_to_statement (omp_current_ctx->code); - gfc_statement oacc_st = oacc_code_to_statement (code); - gfc_error ("The %s directive cannot be specified within " - "a %s region at %L", gfc_ascii_statement (oacc_st), - gfc_ascii_statement (st), &code->loc); - } -} - -static void -resolve_omp_directive_inside_oacc_region (gfc_code *code) -{ - if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp) - { - gfc_statement st = oacc_code_to_statement (omp_current_ctx->code); - gfc_statement omp_st = omp_code_to_statement (code); - gfc_error ("The %s directive cannot be specified within " - "a %s region at %L", gfc_ascii_statement (omp_st), - gfc_ascii_statement (st), &code->loc); - } -} - - -static void -resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse, - const char *clause) -{ - gfc_symbol *dovar; - gfc_code *c; - int i; - - for (i = 1; i <= collapse; i++) - { - if (do_code->op == EXEC_DO_WHILE) - { - gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control " - "at %L", &do_code->loc); - break; - } - if (do_code->op == EXEC_DO_CONCURRENT) - { - gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L", - &do_code->loc); - break; - } - gcc_assert (do_code->op == EXEC_DO); - if (do_code->ext.iterator->var->ts.type != BT_INTEGER) - gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L", - &do_code->loc); - dovar = do_code->ext.iterator->var->symtree->n.sym; - if (i > 1) - { - gfc_code *do_code2 = code->block->next; - int j; - - for (j = 1; j < i; j++) - { - gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; - if (dovar == ivar - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) - { - gfc_error ("!$ACC LOOP %s loops don't form rectangular " - "iteration space at %L", clause, &do_code->loc); - break; - } - do_code2 = do_code2->block->next; - } - } - if (i == collapse) - break; - for (c = do_code->next; c; c = c->next) - if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) - { - gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L", - clause, &c->loc); - break; - } - if (c) - break; - do_code = do_code->block; - if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE - && do_code->op != EXEC_DO_CONCURRENT) - { - gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", - clause, &code->loc); - break; - } - do_code = do_code->next; - if (do_code == NULL - || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE - && do_code->op != EXEC_DO_CONCURRENT)) - { - gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", - clause, &code->loc); - break; - } - } -} - - -static void -resolve_oacc_loop_blocks (gfc_code *code) -{ - if (!oacc_is_loop (code)) - return; - - if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang - && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector) - gfc_error ("Tiled loop cannot be parallelized across gangs, workers and " - "vectors at the same time at %L", &code->loc); - - if (code->ext.omp_clauses->tile_list) - { - gfc_expr_list *el; - for (el = code->ext.omp_clauses->tile_list; el; el = el->next) - { - if (el->expr == NULL) - { - /* NULL expressions are used to represent '*' arguments. - Convert those to a 0 expressions. */ - el->expr = gfc_get_constant_expr (BT_INTEGER, - gfc_default_integer_kind, - &code->loc); - mpz_set_si (el->expr->value.integer, 0); - } - else - { - resolve_positive_int_expr (el->expr, "TILE"); - if (el->expr->expr_type != EXPR_CONSTANT) - gfc_error ("TILE requires constant expression at %L", - &code->loc); - } - } - } -} - - -void -gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) -{ - fortran_omp_context ctx; - gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; - gfc_omp_namelist *n; - int list; - - resolve_oacc_loop_blocks (code); - - ctx.code = code; - ctx.sharing_clauses = new hash_set; - ctx.private_iterators = new hash_set; - ctx.previous = omp_current_ctx; - ctx.is_openmp = false; - omp_current_ctx = &ctx; - - for (list = 0; list < OMP_LIST_NUM; list++) - switch (list) - { - case OMP_LIST_PRIVATE: - for (n = omp_clauses->lists[list]; n; n = n->next) - ctx.sharing_clauses->add (n->sym); - break; - default: - break; - } - - gfc_resolve_blocks (code->block, ns); - - omp_current_ctx = ctx.previous; - delete ctx.sharing_clauses; - delete ctx.private_iterators; -} - - -static void -resolve_oacc_loop (gfc_code *code) -{ - gfc_code *do_code; - int collapse; - - if (code->ext.omp_clauses) - resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); - - do_code = code->block->next; - collapse = code->ext.omp_clauses->collapse; - - /* Both collapsed and tiled loops are lowered the same way, but are not - compatible. In gfc_trans_omp_do, the tile is prioritized. */ - if (code->ext.omp_clauses->tile_list) - { - int num = 0; - gfc_expr_list *el; - for (el = code->ext.omp_clauses->tile_list; el; el = el->next) - ++num; - resolve_oacc_nested_loops (code, code->block->next, num, "tiled"); - return; - } - - if (collapse <= 0) - collapse = 1; - resolve_oacc_nested_loops (code, do_code, collapse, "collapsed"); -} - -void -gfc_resolve_oacc_declare (gfc_namespace *ns) -{ - int list; - gfc_omp_namelist *n; - gfc_oacc_declare *oc; - - if (ns->oacc_declare == NULL) - return; - - for (oc = ns->oacc_declare; oc; oc = oc->next) - { - for (list = 0; list < OMP_LIST_NUM; list++) - for (n = oc->clauses->lists[list]; n; n = n->next) - { - n->sym->mark = 0; - if (n->sym->attr.flavor != FL_VARIABLE - && (n->sym->attr.flavor != FL_PROCEDURE - || n->sym->result != n->sym)) - { - gfc_error ("Object %qs is not a variable at %L", - n->sym->name, &oc->loc); - continue; - } - - if (n->expr && n->expr->ref->type == REF_ARRAY) - { - gfc_error ("Array sections: %qs not allowed in" - " !$ACC DECLARE at %L", n->sym->name, &oc->loc); - continue; - } - } - - for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next) - check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT"); - } - - for (oc = ns->oacc_declare; oc; oc = oc->next) - { - for (list = 0; list < OMP_LIST_NUM; list++) - for (n = oc->clauses->lists[list]; n; n = n->next) - { - if (n->sym->mark) - { - gfc_error ("Symbol %qs present on multiple clauses at %L", - n->sym->name, &oc->loc); - continue; - } - else - n->sym->mark = 1; - } - } - - for (oc = ns->oacc_declare; oc; oc = oc->next) - { - for (list = 0; list < OMP_LIST_NUM; list++) - for (n = oc->clauses->lists[list]; n; n = n->next) - n->sym->mark = 0; - } -} - - -void -gfc_resolve_oacc_routines (gfc_namespace *ns) -{ - for (gfc_oacc_routine_name *orn = ns->oacc_routine_names; - orn; - orn = orn->next) - { - gfc_symbol *sym = orn->sym; - if (!sym->attr.external - && !sym->attr.function - && !sym->attr.subroutine) - { - gfc_error ("NAME %qs does not refer to a subroutine or function" - " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); - continue; - } - if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc)) - { - gfc_error ("NAME %qs invalid" - " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); - continue; - } - } -} - - -void -gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) -{ - resolve_oacc_directive_inside_omp_region (code); - - switch (code->op) - { - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_UPDATE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); - break; - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_LOOP: - resolve_oacc_loop (code); - break; - case EXEC_OACC_ATOMIC: - resolve_omp_atomic (code); - break; - default: - break; - } -} - - -/* Resolve OpenMP directive clauses and check various requirements - of each directive. */ - -void -gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) -{ - resolve_omp_directive_inside_oacc_region (code); - - if (code->op != EXEC_OMP_ATOMIC) - gfc_maybe_initialize_eh (); - - switch (code->op) - { - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_LOOP: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_SIMD: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - resolve_omp_do (code); - break; - case EXEC_OMP_CANCEL: - case EXEC_OMP_ERROR: - case EXEC_OMP_MASKED: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TEAMS: - case EXEC_OMP_WORKSHARE: - case EXEC_OMP_DEPOBJ: - if (code->ext.omp_clauses) - resolve_omp_clauses (code, code->ext.omp_clauses, NULL); - break; - case EXEC_OMP_TARGET_UPDATE: - if (code->ext.omp_clauses) - resolve_omp_clauses (code, code->ext.omp_clauses, NULL); - if (code->ext.omp_clauses == NULL - || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL - && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL)) - gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or " - "FROM clause", &code->loc); - break; - case EXEC_OMP_ATOMIC: - resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL); - resolve_omp_atomic (code); - break; - case EXEC_OMP_CRITICAL: - resolve_omp_clauses (code, code->ext.omp_clauses, NULL); - if (!code->ext.omp_clauses->critical_name - && code->ext.omp_clauses->hint - && code->ext.omp_clauses->hint->ts.type == BT_INTEGER - && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT - && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0) - gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, " - "except when omp_sync_hint_none is used", &code->loc); - break; - case EXEC_OMP_SCAN: - /* Flag is only used to checking, hence, it is unset afterwards. */ - if (!code->ext.omp_clauses->if_present) - gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with " - "% REDUCTION clause", &code->loc); - code->ext.omp_clauses->if_present = false; - resolve_omp_clauses (code, code->ext.omp_clauses, ns); - break; - default: - break; - } -} - -/* Resolve !$omp declare simd constructs in NS. */ - -void -gfc_resolve_omp_declare_simd (gfc_namespace *ns) -{ - gfc_omp_declare_simd *ods; - - for (ods = ns->omp_declare_simd; ods; ods = ods->next) - { - if (ods->proc_name != NULL - && ods->proc_name != ns->proc_name) - gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure " - "%qs at %L", ns->proc_name->name, &ods->where); - if (ods->clauses) - resolve_omp_clauses (NULL, ods->clauses, ns); - } -} - -struct omp_udr_callback_data -{ - gfc_omp_udr *omp_udr; - bool is_initializer; -}; - -static int -omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data; - if ((*e)->expr_type == EXPR_VARIABLE) - { - if (cd->is_initializer) - { - if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv - && (*e)->symtree->n.sym != cd->omp_udr->omp_orig) - gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in " - "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L", - &(*e)->where); - } - else - { - if ((*e)->symtree->n.sym != cd->omp_udr->omp_out - && (*e)->symtree->n.sym != cd->omp_udr->omp_in) - gfc_error ("Variable other than OMP_OUT or OMP_IN used in " - "combiner of !$OMP DECLARE REDUCTION at %L", - &(*e)->where); - } - } - return 0; -} - -/* Resolve !$omp declare reduction constructs. */ - -static void -gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) -{ - gfc_actual_arglist *a; - const char *predef_name = NULL; - - switch (omp_udr->rop) - { - case OMP_REDUCTION_PLUS: - case OMP_REDUCTION_TIMES: - case OMP_REDUCTION_MINUS: - case OMP_REDUCTION_AND: - case OMP_REDUCTION_OR: - case OMP_REDUCTION_EQV: - case OMP_REDUCTION_NEQV: - case OMP_REDUCTION_MAX: - case OMP_REDUCTION_USER: - break; - default: - gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L", - omp_udr->name, &omp_udr->where); - return; - } - - if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name, - &omp_udr->ts, &predef_name)) - { - if (predef_name) - gfc_error_now ("Redefinition of predefined %s " - "!$OMP DECLARE REDUCTION at %L", - predef_name, &omp_udr->where); - else - gfc_error_now ("Redefinition of predefined " - "!$OMP DECLARE REDUCTION at %L", &omp_udr->where); - return; - } - - if (omp_udr->ts.type == BT_CHARACTER - && omp_udr->ts.u.cl->length - && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not " - "constant at %L", omp_udr->name, &omp_udr->where); - return; - } - - struct omp_udr_callback_data cd; - cd.omp_udr = omp_udr; - cd.is_initializer = false; - gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback, - omp_udr_callback, &cd); - if (omp_udr->combiner_ns->code->op == EXEC_CALL) - { - for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next) - if (a->expr == NULL) - break; - if (a) - gfc_error ("Subroutine call with alternate returns in combiner " - "of !$OMP DECLARE REDUCTION at %L", - &omp_udr->combiner_ns->code->loc); - } - if (omp_udr->initializer_ns) - { - cd.is_initializer = true; - gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback, - omp_udr_callback, &cd); - if (omp_udr->initializer_ns->code->op == EXEC_CALL) - { - for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) - if (a->expr == NULL) - break; - if (a) - gfc_error ("Subroutine call with alternate returns in " - "INITIALIZER clause of !$OMP DECLARE REDUCTION " - "at %L", &omp_udr->initializer_ns->code->loc); - for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) - if (a->expr - && a->expr->expr_type == EXPR_VARIABLE - && a->expr->symtree->n.sym == omp_udr->omp_priv - && a->expr->ref == NULL) - break; - if (a == NULL) - gfc_error ("One of actual subroutine arguments in INITIALIZER " - "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV " - "at %L", &omp_udr->initializer_ns->code->loc); - } - } - else if (omp_udr->ts.type == BT_DERIVED - && !gfc_has_default_initializer (omp_udr->ts.u.derived)) - { - gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION " - "of derived type without default initializer at %L", - &omp_udr->where); - return; - } -} - -void -gfc_resolve_omp_udrs (gfc_symtree *st) -{ - gfc_omp_udr *omp_udr; - - if (st == NULL) - return; - gfc_resolve_omp_udrs (st->left); - gfc_resolve_omp_udrs (st->right); - for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) - gfc_resolve_omp_udr (omp_udr); -} diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc new file mode 100644 index 0000000..4a03197 --- /dev/null +++ b/gcc/fortran/openmp.cc @@ -0,0 +1,9411 @@ +/* OpenMP directive matching and resolving. + Copyright (C) 2005-2022 Free Software Foundation, Inc. + Contributed by Jakub Jelinek + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "arith.h" +#include "match.h" +#include "parse.h" +#include "constructor.h" +#include "diagnostic.h" +#include "gomp-constants.h" +#include "target-memory.h" /* For gfc_encode_character. */ + +/* Match an end of OpenMP directive. End of OpenMP directive is optional + whitespace, followed by '\n' or comment '!'. */ + +static match +gfc_match_omp_eos (void) +{ + locus old_loc; + char c; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + c = gfc_next_ascii_char (); + switch (c) + { + case '!': + do + c = gfc_next_ascii_char (); + while (c != '\n'); + /* Fall through */ + + case '\n': + return MATCH_YES; + } + + gfc_current_locus = old_loc; + return MATCH_NO; +} + +match +gfc_match_omp_eos_error (void) +{ + if (gfc_match_omp_eos() == MATCH_YES) + return MATCH_YES; + + gfc_error ("Unexpected junk at %C"); + return MATCH_ERROR; +} + + +/* Free an omp_clauses structure. */ + +void +gfc_free_omp_clauses (gfc_omp_clauses *c) +{ + int i; + if (c == NULL) + return; + + gfc_free_expr (c->if_expr); + gfc_free_expr (c->final_expr); + gfc_free_expr (c->num_threads); + gfc_free_expr (c->chunk_size); + gfc_free_expr (c->safelen_expr); + gfc_free_expr (c->simdlen_expr); + gfc_free_expr (c->num_teams_lower); + gfc_free_expr (c->num_teams_upper); + gfc_free_expr (c->device); + gfc_free_expr (c->thread_limit); + gfc_free_expr (c->dist_chunk_size); + gfc_free_expr (c->grainsize); + gfc_free_expr (c->hint); + gfc_free_expr (c->num_tasks); + gfc_free_expr (c->priority); + gfc_free_expr (c->detach); + for (i = 0; i < OMP_IF_LAST; i++) + gfc_free_expr (c->if_exprs[i]); + gfc_free_expr (c->async_expr); + gfc_free_expr (c->gang_num_expr); + gfc_free_expr (c->gang_static_expr); + gfc_free_expr (c->worker_expr); + gfc_free_expr (c->vector_expr); + gfc_free_expr (c->num_gangs_expr); + gfc_free_expr (c->num_workers_expr); + gfc_free_expr (c->vector_length_expr); + for (i = 0; i < OMP_LIST_NUM; i++) + gfc_free_omp_namelist (c->lists[i], + i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND); + gfc_free_expr_list (c->wait_list); + gfc_free_expr_list (c->tile_list); + free (CONST_CAST (char *, c->critical_name)); + free (c); +} + +/* Free oacc_declare structures. */ + +void +gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc) +{ + struct gfc_oacc_declare *decl = oc; + + do + { + struct gfc_oacc_declare *next; + + next = decl->next; + gfc_free_omp_clauses (decl->clauses); + free (decl); + decl = next; + } + while (decl); +} + +/* Free expression list. */ +void +gfc_free_expr_list (gfc_expr_list *list) +{ + gfc_expr_list *n; + + for (; list; list = n) + { + n = list->next; + free (list); + } +} + +/* Free an !$omp declare simd construct list. */ + +void +gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods) +{ + if (ods) + { + gfc_free_omp_clauses (ods->clauses); + free (ods); + } +} + +void +gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list) +{ + while (list) + { + gfc_omp_declare_simd *current = list; + list = list->next; + gfc_free_omp_declare_simd (current); + } +} + +static void +gfc_free_omp_trait_property_list (gfc_omp_trait_property *list) +{ + while (list) + { + gfc_omp_trait_property *current = list; + list = list->next; + switch (current->property_kind) + { + case CTX_PROPERTY_ID: + free (current->name); + break; + case CTX_PROPERTY_NAME_LIST: + if (current->is_name) + free (current->name); + break; + case CTX_PROPERTY_SIMD: + gfc_free_omp_clauses (current->clauses); + break; + default: + break; + } + free (current); + } +} + +static void +gfc_free_omp_selector_list (gfc_omp_selector *list) +{ + while (list) + { + gfc_omp_selector *current = list; + list = list->next; + gfc_free_omp_trait_property_list (current->properties); + free (current); + } +} + +static void +gfc_free_omp_set_selector_list (gfc_omp_set_selector *list) +{ + while (list) + { + gfc_omp_set_selector *current = list; + list = list->next; + gfc_free_omp_selector_list (current->trait_selectors); + free (current); + } +} + +/* Free an !$omp declare variant construct list. */ + +void +gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list) +{ + while (list) + { + gfc_omp_declare_variant *current = list; + list = list->next; + gfc_free_omp_set_selector_list (current->set_selectors); + free (current); + } +} + +/* Free an !$omp declare reduction. */ + +void +gfc_free_omp_udr (gfc_omp_udr *omp_udr) +{ + if (omp_udr) + { + gfc_free_omp_udr (omp_udr->next); + gfc_free_namespace (omp_udr->combiner_ns); + if (omp_udr->initializer_ns) + gfc_free_namespace (omp_udr->initializer_ns); + free (omp_udr); + } +} + + +static gfc_omp_udr * +gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + do + { + gfc_omp_udr *omp_udr; + + st = gfc_find_symtree (ns->omp_udr_root, name); + if (st != NULL) + { + for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) + if (ts == NULL) + return omp_udr; + else if (gfc_compare_types (&omp_udr->ts, ts)) + { + if (ts->type == BT_CHARACTER) + { + if (omp_udr->ts.u.cl->length == NULL) + return omp_udr; + if (ts->u.cl->length == NULL) + continue; + if (gfc_compare_expr (omp_udr->ts.u.cl->length, + ts->u.cl->length, + INTRINSIC_EQ) != 0) + continue; + } + return omp_udr; + } + } + + /* Don't escape an interface block. */ + if (ns && !ns->has_import_set + && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) + break; + + ns = ns->parent; + } + while (ns != NULL); + + return NULL; +} + + +/* Match a variable/common block list and construct a namelist from it. */ + +static match +gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, + bool allow_common, bool *end_colon = NULL, + gfc_omp_namelist ***headp = NULL, + bool allow_sections = false, + bool allow_derived = false) +{ + gfc_omp_namelist *head, *tail, *p; + locus old_loc, cur_loc; + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_symbol *sym; + match m; + gfc_symtree *st; + + head = tail = NULL; + + old_loc = gfc_current_locus; + + m = gfc_match (str); + if (m != MATCH_YES) + return m; + + for (;;) + { + cur_loc = gfc_current_locus; + m = gfc_match_symbol (&sym, 1); + switch (m) + { + case MATCH_YES: + gfc_expr *expr; + expr = NULL; + gfc_gobble_whitespace (); + if ((allow_sections && gfc_peek_ascii_char () == '(') + || (allow_derived && gfc_peek_ascii_char () == '%')) + { + gfc_current_locus = cur_loc; + m = gfc_match_variable (&expr, 0); + switch (m) + { + case MATCH_ERROR: + goto cleanup; + case MATCH_NO: + goto syntax; + default: + break; + } + if (gfc_is_coindexed (expr)) + { + gfc_error ("List item shall not be coindexed at %C"); + goto cleanup; + } + } + gfc_set_sym_referenced (sym); + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + tail->expr = expr; + tail->where = cur_loc; + goto next_item; + case MATCH_NO: + break; + case MATCH_ERROR: + goto cleanup; + } + + if (!allow_common) + goto syntax; + + m = gfc_match (" / %n /", n); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + st = gfc_find_symtree (gfc_current_ns->common_root, n); + if (st == NULL) + { + gfc_error ("COMMON block /%s/ not found at %C", n); + goto cleanup; + } + for (sym = st->n.common->head; sym; sym = sym->common_next) + { + gfc_set_sym_referenced (sym); + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + tail->where = cur_loc; + } + + next_item: + if (end_colon && gfc_match_char (':') == MATCH_YES) + { + *end_colon = true; + break; + } + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + while (*list) + list = &(*list)->next; + + *list = head; + if (headp) + *headp = list; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in OpenMP variable list at %C"); + +cleanup: + gfc_free_omp_namelist (head, false); + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +/* Match a variable/procedure/common block list and construct a namelist + from it. */ + +static match +gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list) +{ + gfc_omp_namelist *head, *tail, *p; + locus old_loc, cur_loc; + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_symbol *sym; + match m; + gfc_symtree *st; + + head = tail = NULL; + + old_loc = gfc_current_locus; + + m = gfc_match (str); + if (m != MATCH_YES) + return m; + + for (;;) + { + cur_loc = gfc_current_locus; + m = gfc_match_symbol (&sym, 1); + switch (m) + { + case MATCH_YES: + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + tail->where = cur_loc; + goto next_item; + case MATCH_NO: + break; + case MATCH_ERROR: + goto cleanup; + } + + m = gfc_match (" / %n /", n); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + st = gfc_find_symtree (gfc_current_ns->common_root, n); + if (st == NULL) + { + gfc_error ("COMMON block /%s/ not found at %C", n); + goto cleanup; + } + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->u.common = st->n.common; + tail->where = cur_loc; + + next_item: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + while (*list) + list = &(*list)->next; + + *list = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in OpenMP variable list at %C"); + +cleanup: + gfc_free_omp_namelist (head, false); + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +/* Match detach(event-handle). */ + +static match +gfc_match_omp_detach (gfc_expr **expr) +{ + locus old_loc = gfc_current_locus; + + if (gfc_match ("detach ( ") != MATCH_YES) + goto syntax_error; + + if (gfc_match_variable (expr, 0) != MATCH_YES) + goto syntax_error; + + if ((*expr)->ts.type != BT_INTEGER || (*expr)->ts.kind != gfc_c_intptr_kind) + { + gfc_error ("%qs at %L should be of type " + "integer(kind=omp_event_handle_kind)", + (*expr)->symtree->n.sym->name, &(*expr)->where); + return MATCH_ERROR; + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax_error; + + return MATCH_YES; + +syntax_error: + gfc_error ("Syntax error in OpenMP detach clause at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + +} + +/* Match depend(sink : ...) construct a namelist from it. */ + +static match +gfc_match_omp_depend_sink (gfc_omp_namelist **list) +{ + gfc_omp_namelist *head, *tail, *p; + locus old_loc, cur_loc; + gfc_symbol *sym; + + head = tail = NULL; + + old_loc = gfc_current_locus; + + for (;;) + { + cur_loc = gfc_current_locus; + switch (gfc_match_symbol (&sym, 1)) + { + case MATCH_YES: + gfc_set_sym_referenced (sym); + p = gfc_get_omp_namelist (); + if (head == NULL) + { + head = tail = p; + head->u.depend_op = OMP_DEPEND_SINK_FIRST; + } + else + { + tail->next = p; + tail = tail->next; + tail->u.depend_op = OMP_DEPEND_SINK; + } + tail->sym = sym; + tail->expr = NULL; + tail->where = cur_loc; + if (gfc_match_char ('+') == MATCH_YES) + { + if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) + goto syntax; + } + else if (gfc_match_char ('-') == MATCH_YES) + { + if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) + goto syntax; + tail->expr = gfc_uminus (tail->expr); + } + break; + case MATCH_NO: + goto syntax; + case MATCH_ERROR: + goto cleanup; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + while (*list) + list = &(*list)->next; + + *list = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C"); + +cleanup: + gfc_free_omp_namelist (head, false); + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +static match +match_oacc_expr_list (const char *str, gfc_expr_list **list, + bool allow_asterisk) +{ + gfc_expr_list *head, *tail, *p; + locus old_loc; + gfc_expr *expr; + match m; + + head = tail = NULL; + + old_loc = gfc_current_locus; + + m = gfc_match (str); + if (m != MATCH_YES) + return m; + + for (;;) + { + m = gfc_match_expr (&expr); + if (m == MATCH_YES || allow_asterisk) + { + p = gfc_get_expr_list (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + if (m == MATCH_YES) + tail->expr = expr; + else if (gfc_match (" *") != MATCH_YES) + goto syntax; + goto next_item; + } + if (m == MATCH_ERROR) + goto cleanup; + goto syntax; + + next_item: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + while (*list) + list = &(*list)->next; + + *list = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in OpenACC expression list at %C"); + +cleanup: + gfc_free_expr_list (head); + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +static match +match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv) +{ + match ret = MATCH_YES; + + if (gfc_match (" ( ") != MATCH_YES) + return MATCH_NO; + + if (gwv == GOMP_DIM_GANG) + { + /* The gang clause accepts two optional arguments, num and static. + The num argument may either be explicit (num: ) or + implicit without ( without num:). */ + + while (ret == MATCH_YES) + { + if (gfc_match (" static :") == MATCH_YES) + { + if (cp->gang_static) + return MATCH_ERROR; + else + cp->gang_static = true; + if (gfc_match_char ('*') == MATCH_YES) + cp->gang_static_expr = NULL; + else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES) + return MATCH_ERROR; + } + else + { + if (cp->gang_num_expr) + return MATCH_ERROR; + + /* The 'num' argument is optional. */ + gfc_match (" num :"); + + if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES) + return MATCH_ERROR; + } + + ret = gfc_match (" , "); + } + } + else if (gwv == GOMP_DIM_WORKER) + { + /* The 'num' argument is optional. */ + gfc_match (" num :"); + + if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES) + return MATCH_ERROR; + } + else if (gwv == GOMP_DIM_VECTOR) + { + /* The 'length' argument is optional. */ + gfc_match (" length :"); + + if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES) + return MATCH_ERROR; + } + else + gfc_fatal_error ("Unexpected OpenACC parallelism."); + + return gfc_match (" )"); +} + +static match +gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list) +{ + gfc_omp_namelist *head = NULL; + gfc_omp_namelist *tail, *p; + locus old_loc; + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_symbol *sym; + match m; + gfc_symtree *st; + + old_loc = gfc_current_locus; + + m = gfc_match (str); + if (m != MATCH_YES) + return m; + + m = gfc_match (" ("); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (sym->attr.in_common) + { + gfc_error_now ("Variable at %C is an element of a COMMON block"); + goto cleanup; + } + gfc_set_sym_referenced (sym); + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + tail->expr = NULL; + tail->where = gfc_current_locus; + goto next_item; + case MATCH_NO: + break; + + case MATCH_ERROR: + goto cleanup; + } + + m = gfc_match (" / %n /", n); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO || n[0] == '\0') + goto syntax; + + st = gfc_find_symtree (gfc_current_ns->common_root, n); + if (st == NULL) + { + gfc_error ("COMMON block /%s/ not found at %C", n); + goto cleanup; + } + + for (sym = st->n.common->head; sym; sym = sym->common_next) + { + gfc_set_sym_referenced (sym); + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->sym = sym; + tail->where = gfc_current_locus; + } + + next_item: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after !$ACC DECLARE at %C"); + goto cleanup; + } + + while (*list) + list = &(*list)->next; + *list = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in !$ACC DECLARE list at %C"); + +cleanup: + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + +/* OpenMP clauses. */ +enum omp_mask1 +{ + OMP_CLAUSE_PRIVATE, + OMP_CLAUSE_FIRSTPRIVATE, + OMP_CLAUSE_LASTPRIVATE, + OMP_CLAUSE_COPYPRIVATE, + OMP_CLAUSE_SHARED, + OMP_CLAUSE_COPYIN, + OMP_CLAUSE_REDUCTION, + OMP_CLAUSE_IN_REDUCTION, + OMP_CLAUSE_TASK_REDUCTION, + OMP_CLAUSE_IF, + OMP_CLAUSE_NUM_THREADS, + OMP_CLAUSE_SCHEDULE, + OMP_CLAUSE_DEFAULT, + OMP_CLAUSE_ORDER, + OMP_CLAUSE_ORDERED, + OMP_CLAUSE_COLLAPSE, + OMP_CLAUSE_UNTIED, + OMP_CLAUSE_FINAL, + OMP_CLAUSE_MERGEABLE, + OMP_CLAUSE_ALIGNED, + OMP_CLAUSE_DEPEND, + OMP_CLAUSE_INBRANCH, + OMP_CLAUSE_LINEAR, + OMP_CLAUSE_NOTINBRANCH, + OMP_CLAUSE_PROC_BIND, + OMP_CLAUSE_SAFELEN, + OMP_CLAUSE_SIMDLEN, + OMP_CLAUSE_UNIFORM, + OMP_CLAUSE_DEVICE, + OMP_CLAUSE_MAP, + OMP_CLAUSE_TO, + OMP_CLAUSE_FROM, + OMP_CLAUSE_NUM_TEAMS, + OMP_CLAUSE_THREAD_LIMIT, + OMP_CLAUSE_DIST_SCHEDULE, + OMP_CLAUSE_DEFAULTMAP, + OMP_CLAUSE_GRAINSIZE, + OMP_CLAUSE_HINT, + OMP_CLAUSE_IS_DEVICE_PTR, + OMP_CLAUSE_LINK, + OMP_CLAUSE_NOGROUP, + OMP_CLAUSE_NOTEMPORAL, + OMP_CLAUSE_NUM_TASKS, + OMP_CLAUSE_PRIORITY, + OMP_CLAUSE_SIMD, + OMP_CLAUSE_THREADS, + OMP_CLAUSE_USE_DEVICE_PTR, + OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */ + OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */ + OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */ + OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */ + OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */ + OMP_CLAUSE_DETACH, /* OpenMP 5.0. */ + OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */ + OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */ + OMP_CLAUSE_BIND, /* OpenMP 5.0. */ + OMP_CLAUSE_FILTER, /* OpenMP 5.1. */ + OMP_CLAUSE_AT, /* OpenMP 5.1. */ + OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */ + OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */ + OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */ + OMP_CLAUSE_FAIL, /* OpenMP 5.1. */ + OMP_CLAUSE_WEAK, /* OpenMP 5.1. */ + OMP_CLAUSE_NOWAIT, + /* This must come last. */ + OMP_MASK1_LAST +}; + +/* OpenACC 2.0+ specific clauses. */ +enum omp_mask2 +{ + OMP_CLAUSE_ASYNC, + OMP_CLAUSE_NUM_GANGS, + OMP_CLAUSE_NUM_WORKERS, + OMP_CLAUSE_VECTOR_LENGTH, + OMP_CLAUSE_COPY, + OMP_CLAUSE_COPYOUT, + OMP_CLAUSE_CREATE, + OMP_CLAUSE_NO_CREATE, + OMP_CLAUSE_PRESENT, + OMP_CLAUSE_DEVICEPTR, + OMP_CLAUSE_GANG, + OMP_CLAUSE_WORKER, + OMP_CLAUSE_VECTOR, + OMP_CLAUSE_SEQ, + OMP_CLAUSE_INDEPENDENT, + OMP_CLAUSE_USE_DEVICE, + OMP_CLAUSE_DEVICE_RESIDENT, + OMP_CLAUSE_HOST_SELF, + OMP_CLAUSE_WAIT, + OMP_CLAUSE_DELETE, + OMP_CLAUSE_AUTO, + OMP_CLAUSE_TILE, + OMP_CLAUSE_IF_PRESENT, + OMP_CLAUSE_FINALIZE, + OMP_CLAUSE_ATTACH, + OMP_CLAUSE_NOHOST, + /* This must come last. */ + OMP_MASK2_LAST +}; + +struct omp_inv_mask; + +/* Customized bitset for up to 128-bits. + The two enums above provide bit numbers to use, and which of the + two enums it is determines which of the two mask fields is used. + Supported operations are defining a mask, like: + #define XXX_CLAUSES \ + (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ) + oring such bitsets together or removing selected bits: + (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV)) + and testing individual bits: + if (mask & OMP_CLAUSE_UUU) */ + +struct omp_mask { + const uint64_t mask1; + const uint64_t mask2; + inline omp_mask (); + inline omp_mask (omp_mask1); + inline omp_mask (omp_mask2); + inline omp_mask (uint64_t, uint64_t); + inline omp_mask operator| (omp_mask1) const; + inline omp_mask operator| (omp_mask2) const; + inline omp_mask operator| (omp_mask) const; + inline omp_mask operator& (const omp_inv_mask &) const; + inline bool operator& (omp_mask1) const; + inline bool operator& (omp_mask2) const; + inline omp_inv_mask operator~ () const; +}; + +struct omp_inv_mask : public omp_mask { + inline omp_inv_mask (const omp_mask &); +}; + +omp_mask::omp_mask () : mask1 (0), mask2 (0) +{ +} + +omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0) +{ +} + +omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m) +{ +} + +omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2) +{ +} + +omp_mask +omp_mask::operator| (omp_mask1 m) const +{ + return omp_mask (mask1 | (((uint64_t) 1) << m), mask2); +} + +omp_mask +omp_mask::operator| (omp_mask2 m) const +{ + return omp_mask (mask1, mask2 | (((uint64_t) 1) << m)); +} + +omp_mask +omp_mask::operator| (omp_mask m) const +{ + return omp_mask (mask1 | m.mask1, mask2 | m.mask2); +} + +omp_mask +omp_mask::operator& (const omp_inv_mask &m) const +{ + return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2); +} + +bool +omp_mask::operator& (omp_mask1 m) const +{ + return (mask1 & (((uint64_t) 1) << m)) != 0; +} + +bool +omp_mask::operator& (omp_mask2 m) const +{ + return (mask2 & (((uint64_t) 1) << m)) != 0; +} + +omp_inv_mask +omp_mask::operator~ () const +{ + return omp_inv_mask (*this); +} + +omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) +{ +} + +/* Helper function for OpenACC and OpenMP clauses involving memory + mapping. */ + +static bool +gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, + bool allow_common, bool allow_derived) +{ + gfc_omp_namelist **head = NULL; + if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true, + allow_derived) + == MATCH_YES) + { + gfc_omp_namelist *n; + for (n = *head; n; n = n->next) + n->u.map_op = map_op; + return true; + } + + return false; +} + +static match +gfc_match_iterator (gfc_namespace **ns, bool permit_var) +{ + locus old_loc = gfc_current_locus; + + if (gfc_match ("iterator ( ") != MATCH_YES) + return MATCH_NO; + + gfc_typespec ts; + gfc_symbol *last = NULL; + gfc_expr *begin, *end, *step; + *ns = gfc_build_block_ns (gfc_current_ns); + char name[GFC_MAX_SYMBOL_LEN + 1]; + while (true) + { + locus prev_loc = gfc_current_locus; + if (gfc_match_type_spec (&ts) == MATCH_YES + && gfc_match (" :: ") == MATCH_YES) + { + if (ts.type != BT_INTEGER) + { + gfc_error ("Expected INTEGER type at %L", &prev_loc); + return MATCH_ERROR; + } + permit_var = false; + } + else + { + ts.type = BT_INTEGER; + ts.kind = gfc_default_integer_kind; + gfc_current_locus = prev_loc; + } + prev_loc = gfc_current_locus; + if (gfc_match_name (name) != MATCH_YES) + { + gfc_error ("Expected identifier at %C"); + goto failed; + } + if (gfc_find_symtree ((*ns)->sym_root, name)) + { + gfc_error ("Same identifier %qs specified again at %C", name); + goto failed; + } + + gfc_symbol *sym = gfc_new_symbol (name, *ns); + if (last) + last->tlink = sym; + else + (*ns)->proc_name = sym; + last = sym; + sym->declared_at = prev_loc; + sym->ts = ts; + sym->attr.flavor = FL_VARIABLE; + sym->attr.artificial = 1; + sym->attr.referenced = 1; + sym->refs++; + gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name); + st->n.sym = sym; + + prev_loc = gfc_current_locus; + if (gfc_match (" = ") != MATCH_YES) + goto failed; + permit_var = false; + begin = end = step = NULL; + if (gfc_match ("%e : ", &begin) != MATCH_YES + || gfc_match ("%e ", &end) != MATCH_YES) + { + gfc_error ("Expected range-specification at %C"); + gfc_free_expr (begin); + gfc_free_expr (end); + return MATCH_ERROR; + } + if (':' == gfc_peek_ascii_char ()) + { + step = gfc_get_expr (); + if (gfc_match (": %e ", &step) != MATCH_YES) + { + gfc_free_expr (begin); + gfc_free_expr (end); + gfc_free_expr (step); + goto failed; + } + } + + gfc_expr *e = gfc_get_expr (); + e->where = prev_loc; + e->expr_type = EXPR_ARRAY; + e->ts = ts; + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], step ? 3 : 2); + gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where); + gfc_constructor_append_expr (&e->value.constructor, end, &end->where); + if (step) + gfc_constructor_append_expr (&e->value.constructor, step, &step->where); + sym->value = e; + + if (gfc_match (") ") == MATCH_YES) + break; + if (gfc_match (", ") != MATCH_YES) + goto failed; + } + return MATCH_YES; + +failed: + gfc_namespace *prev_ns = NULL; + for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling) + { + if (it == *ns) + { + if (prev_ns) + prev_ns->sibling = it->sibling; + else + gfc_current_ns->contained = it->sibling; + gfc_free_namespace (it); + break; + } + prev_ns = it; + } + *ns = NULL; + if (!permit_var) + return MATCH_ERROR; + gfc_current_locus = old_loc; + return MATCH_NO; +} + +/* reduction ( reduction-modifier, reduction-operator : variable-list ) + in_reduction ( reduction-operator : variable-list ) + task_reduction ( reduction-operator : variable-list ) */ + +static match +gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, + bool allow_derived, bool openmp_target = false) +{ + if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES) + return MATCH_NO; + else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES) + return MATCH_NO; + else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES) + return MATCH_NO; + + locus old_loc = gfc_current_locus; + int list_idx = 0; + + if (pc == 'r' && !openacc) + { + if (gfc_match ("inscan") == MATCH_YES) + list_idx = OMP_LIST_REDUCTION_INSCAN; + else if (gfc_match ("task") == MATCH_YES) + list_idx = OMP_LIST_REDUCTION_TASK; + else if (gfc_match ("default") == MATCH_YES) + list_idx = OMP_LIST_REDUCTION; + if (list_idx != 0 && gfc_match (", ") != MATCH_YES) + { + gfc_error ("Comma expected at %C"); + gfc_current_locus = old_loc; + return MATCH_NO; + } + if (list_idx == 0) + list_idx = OMP_LIST_REDUCTION; + } + else if (pc == 'i') + list_idx = OMP_LIST_IN_REDUCTION; + else if (pc == 't') + list_idx = OMP_LIST_TASK_REDUCTION; + else + list_idx = OMP_LIST_REDUCTION; + + gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; + char buffer[GFC_MAX_SYMBOL_LEN + 3]; + if (gfc_match_char ('+') == MATCH_YES) + rop = OMP_REDUCTION_PLUS; + else if (gfc_match_char ('*') == MATCH_YES) + rop = OMP_REDUCTION_TIMES; + else if (gfc_match_char ('-') == MATCH_YES) + rop = OMP_REDUCTION_MINUS; + else if (gfc_match (".and.") == MATCH_YES) + rop = OMP_REDUCTION_AND; + else if (gfc_match (".or.") == MATCH_YES) + rop = OMP_REDUCTION_OR; + else if (gfc_match (".eqv.") == MATCH_YES) + rop = OMP_REDUCTION_EQV; + else if (gfc_match (".neqv.") == MATCH_YES) + rop = OMP_REDUCTION_NEQV; + if (rop != OMP_REDUCTION_NONE) + snprintf (buffer, sizeof buffer, "operator %s", + gfc_op2string ((gfc_intrinsic_op) rop)); + else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES) + { + buffer[0] = '.'; + strcat (buffer, "."); + } + else if (gfc_match_name (buffer) == MATCH_YES) + { + gfc_symbol *sym; + const char *n = buffer; + + gfc_find_symbol (buffer, NULL, 1, &sym); + if (sym != NULL) + { + if (sym->attr.intrinsic) + n = sym->name; + else if ((sym->attr.flavor != FL_UNKNOWN + && sym->attr.flavor != FL_PROCEDURE) + || sym->attr.external + || sym->attr.generic + || sym->attr.entry + || sym->attr.result + || sym->attr.dummy + || sym->attr.subroutine + || sym->attr.pointer + || sym->attr.target + || sym->attr.cray_pointer + || sym->attr.cray_pointee + || (sym->attr.proc != PROC_UNKNOWN + && sym->attr.proc != PROC_INTRINSIC) + || sym->attr.if_source != IFSRC_UNKNOWN + || sym == sym->ns->proc_name) + { + sym = NULL; + n = NULL; + } + else + n = sym->name; + } + if (n == NULL) + rop = OMP_REDUCTION_NONE; + else if (strcmp (n, "max") == 0) + rop = OMP_REDUCTION_MAX; + else if (strcmp (n, "min") == 0) + rop = OMP_REDUCTION_MIN; + else if (strcmp (n, "iand") == 0) + rop = OMP_REDUCTION_IAND; + else if (strcmp (n, "ior") == 0) + rop = OMP_REDUCTION_IOR; + else if (strcmp (n, "ieor") == 0) + rop = OMP_REDUCTION_IEOR; + if (rop != OMP_REDUCTION_NONE + && sym != NULL + && ! sym->attr.intrinsic + && ! sym->attr.use_assoc + && ((sym->attr.flavor == FL_UNKNOWN + && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, + sym->name, NULL)) + || !gfc_add_intrinsic (&sym->attr, NULL))) + rop = OMP_REDUCTION_NONE; + } + else + buffer[0] = '\0'; + gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) + : NULL); + gfc_omp_namelist **head = NULL; + if (rop == OMP_REDUCTION_NONE && udr) + rop = OMP_REDUCTION_USER; + + if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL, + &head, openacc, allow_derived) != MATCH_YES) + { + gfc_current_locus = old_loc; + return MATCH_NO; + } + gfc_omp_namelist *n; + if (rop == OMP_REDUCTION_NONE) + { + n = *head; + *head = NULL; + gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L", + buffer, &old_loc); + gfc_free_omp_namelist (n, false); + } + else + for (n = *head; n; n = n->next) + { + n->u.reduction_op = rop; + if (udr) + { + n->u2.udr = gfc_get_omp_namelist_udr (); + n->u2.udr->udr = udr; + } + if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION) + { + gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl; + p->sym = n->sym; + p->where = p->where; + p->u.map_op = OMP_MAP_ALWAYS_TOFROM; + + tl = &c->lists[OMP_LIST_MAP]; + while (*tl) + tl = &((*tl)->next); + *tl = p; + p->next = NULL; + } + } + return MATCH_YES; +} + + +/* Match with duplicate check. Matches 'name'. If expr != NULL, it + then matches '(expr)', otherwise, if open_parens is true, + it matches a ' ( ' after 'name'. + dupl_message requires '%qs %L' - and is used by + gfc_match_dupl_memorder and gfc_match_dupl_atomic. */ + +static match +gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false, + gfc_expr **expr = NULL, const char *dupl_msg = NULL) +{ + match m; + locus old_loc = gfc_current_locus; + if ((m = gfc_match (name)) != MATCH_YES) + return m; + if (!not_dupl) + { + if (dupl_msg) + gfc_error (dupl_msg, name, &old_loc); + else + gfc_error ("Duplicated %qs clause at %L", name, &old_loc); + return MATCH_ERROR; + } + if (open_parens || expr) + { + if (gfc_match (" ( ") != MATCH_YES) + { + gfc_error ("Expected %<(%> after %qs at %C", name); + return MATCH_ERROR; + } + if (expr) + { + if (gfc_match ("%e )", expr) != MATCH_YES) + { + gfc_error ("Invalid expression after %<%s(%> at %C", name); + return MATCH_ERROR; + } + } + } + return MATCH_YES; +} + +static match +gfc_match_dupl_memorder (bool not_dupl, const char *name) +{ + return gfc_match_dupl_check (not_dupl, name, false, NULL, + "Duplicated memory-order clause: unexpected %s " + "clause at %L"); +} + +static match +gfc_match_dupl_atomic (bool not_dupl, const char *name) +{ + return gfc_match_dupl_check (not_dupl, name, false, NULL, + "Duplicated atomic clause: unexpected %s " + "clause at %L"); +} + +/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of + clauses that are allowed for a particular directive. */ + +static match +gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, + bool first = true, bool needs_space = true, + bool openacc = false, bool context_selector = false, + bool openmp_target = false) +{ + bool error = false; + gfc_omp_clauses *c = gfc_get_omp_clauses (); + locus old_loc; + /* Determine whether we're dealing with an OpenACC directive that permits + derived type member accesses. This in particular disallows + "!$acc declare" from using such accesses, because it's not clear if/how + that should work. */ + bool allow_derived = (openacc + && ((mask & OMP_CLAUSE_ATTACH) + || (mask & OMP_CLAUSE_DETACH) + || (mask & OMP_CLAUSE_HOST_SELF))); + + gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64); + *cp = NULL; + while (1) + { + match m = MATCH_NO; + if ((first || (m = gfc_match_char (',')) != MATCH_YES) + && (needs_space && gfc_match_space () != MATCH_YES)) + break; + needs_space = false; + first = false; + gfc_gobble_whitespace (); + bool end_colon; + gfc_omp_namelist **head; + old_loc = gfc_current_locus; + char pc = gfc_peek_ascii_char (); + if (pc == '\n' && m == MATCH_YES) + { + gfc_error ("Clause expected at %C after trailing comma"); + goto error; + } + switch (pc) + { + case 'a': + end_colon = false; + head = NULL; + if ((mask & OMP_CLAUSE_ALIGNED) + && gfc_match_omp_variable_list ("aligned (", + &c->lists[OMP_LIST_ALIGNED], + false, &end_colon, + &head) == MATCH_YES) + { + gfc_expr *alignment = NULL; + gfc_omp_namelist *n; + + if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) + { + gfc_free_omp_namelist (*head, false); + gfc_current_locus = old_loc; + *head = NULL; + break; + } + for (n = *head; n; n = n->next) + if (n->next && alignment) + n->expr = gfc_copy_expr (alignment); + else + n->expr = alignment; + continue; + } + if ((mask & OMP_CLAUSE_MEMORDER) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "acq_rel")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->memorder = OMP_MEMORDER_ACQ_REL; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_MEMORDER) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "acquire")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->memorder = OMP_MEMORDER_ACQUIRE; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_AFFINITY) + && gfc_match ("affinity ( ") == MATCH_YES) + { + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + m = gfc_match_iterator (&ns_iter, true); + if (m == MATCH_ERROR) + break; + if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES) + { + gfc_error ("Expected %<:%> at %C"); + break; + } + if (ns_iter) + gfc_current_ns = ns_iter; + head = NULL; + m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY], + false, NULL, &head, true); + gfc_current_ns = ns_curr; + if (m == MATCH_ERROR) + break; + if (ns_iter) + { + for (gfc_omp_namelist *n = *head; n; n = n->next) + { + n->u2.ns = ns_iter; + ns_iter->refs++; + } + } + continue; + } + if ((mask & OMP_CLAUSE_ALLOCATE) + && gfc_match ("allocate ( ") == MATCH_YES) + { + gfc_expr *allocator = NULL; + old_loc = gfc_current_locus; + m = gfc_match_expr (&allocator); + if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES) + { + /* If no ":" then there is no allocator, we backtrack + and read the variable list. */ + gfc_free_expr (allocator); + allocator = NULL; + gfc_current_locus = old_loc; + } + + gfc_omp_namelist **head = NULL; + m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE], + true, NULL, &head); + + if (m != MATCH_YES) + { + gfc_free_expr (allocator); + gfc_error ("Expected variable list at %C"); + goto error; + } + + for (gfc_omp_namelist *n = *head; n; n = n->next) + if (allocator) + n->expr = gfc_copy_expr (allocator); + else + n->expr = NULL; + gfc_free_expr (allocator); + continue; + } + if ((mask & OMP_CLAUSE_AT) + && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("compilation )") == MATCH_YES) + c->at = OMP_AT_COMPILATION; + else if (gfc_match ("execution )") == MATCH_YES) + c->at = OMP_AT_EXECUTION; + else + { + gfc_error ("Expected COMPILATION or EXECUTION in AT clause " + "at %C"); + goto error; + } + continue; + } + if ((mask & OMP_CLAUSE_ASYNC) + && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->async = true; + m = gfc_match (" ( %e )", &c->async_expr); + if (m == MATCH_ERROR) + { + gfc_current_locus = old_loc; + break; + } + else if (m == MATCH_NO) + { + c->async_expr + = gfc_get_constant_expr (BT_INTEGER, + gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL); + needs_space = true; + } + continue; + } + if ((mask & OMP_CLAUSE_AUTO) + && (m = gfc_match_dupl_check (!c->par_auto, "auto")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->par_auto = true; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_ATTACH) + && gfc_match ("attach ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_ATTACH, false, + allow_derived)) + continue; + break; + case 'b': + if ((mask & OMP_CLAUSE_BIND) + && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind", + true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("teams )") == MATCH_YES) + c->bind = OMP_BIND_TEAMS; + else if (gfc_match ("parallel )") == MATCH_YES) + c->bind = OMP_BIND_PARALLEL; + else if (gfc_match ("thread )") == MATCH_YES) + c->bind = OMP_BIND_THREAD; + else + { + gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in " + "BIND at %C"); + break; + } + continue; + } + break; + case 'c': + if ((mask & OMP_CLAUSE_CAPTURE) + && (m = gfc_match_dupl_check (!c->capture, "capture")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->capture = true; + needs_space = true; + continue; + } + if (mask & OMP_CLAUSE_COLLAPSE) + { + gfc_expr *cexpr = NULL; + if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true, + &cexpr)) != MATCH_NO) + { + int collapse; + if (m == MATCH_ERROR) + goto error; + if (gfc_extract_int (cexpr, &collapse, -1)) + collapse = 1; + else if (collapse <= 0) + { + gfc_error_now ("COLLAPSE clause argument not constant " + "positive integer at %C"); + collapse = 1; + } + gfc_free_expr (cexpr); + c->collapse = collapse; + continue; + } + } + if ((mask & OMP_CLAUSE_COMPARE) + && (m = gfc_match_dupl_check (!c->compare, "compare")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->compare = true; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_COPY) + && gfc_match ("copy ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_TOFROM, true, + allow_derived)) + continue; + if (mask & OMP_CLAUSE_COPYIN) + { + if (openacc) + { + if (gfc_match ("copyin ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_TO, true, + allow_derived)) + continue; + } + else if (gfc_match_omp_variable_list ("copyin (", + &c->lists[OMP_LIST_COPYIN], + true) == MATCH_YES) + continue; + } + if ((mask & OMP_CLAUSE_COPYOUT) + && gfc_match ("copyout ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FROM, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_COPYPRIVATE) + && gfc_match_omp_variable_list ("copyprivate (", + &c->lists[OMP_LIST_COPYPRIVATE], + true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_CREATE) + && gfc_match ("create ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_ALLOC, true, allow_derived)) + continue; + break; + case 'd': + if ((mask & OMP_CLAUSE_DEFAULTMAP) + && gfc_match ("defaultmap ( ") == MATCH_YES) + { + enum gfc_omp_defaultmap behavior; + gfc_omp_defaultmap_category category + = OMP_DEFAULTMAP_CAT_UNCATEGORIZED; + if (gfc_match ("alloc ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_ALLOC; + else if (gfc_match ("tofrom ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_TOFROM; + else if (gfc_match ("to ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_TO; + else if (gfc_match ("from ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_FROM; + else if (gfc_match ("firstprivate ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_FIRSTPRIVATE; + else if (gfc_match ("none ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_NONE; + else if (gfc_match ("default ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_DEFAULT; + else + { + gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, " + "NONE or DEFAULT at %C"); + break; + } + if (')' == gfc_peek_ascii_char ()) + ; + else if (gfc_match (": ") != MATCH_YES) + break; + else + { + if (gfc_match ("scalar ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_SCALAR; + else if (gfc_match ("aggregate ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_AGGREGATE; + else if (gfc_match ("allocatable ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_ALLOCATABLE; + else if (gfc_match ("pointer ") == MATCH_YES) + category = OMP_DEFAULTMAP_CAT_POINTER; + else + { + gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE or " + "POINTER at %C"); + break; + } + } + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i) + { + if (i != category + && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED) + continue; + if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET) + { + const char *pcategory = NULL; + switch (i) + { + case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break; + case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break; + case OMP_DEFAULTMAP_CAT_AGGREGATE: + pcategory = "AGGREGATE"; + break; + case OMP_DEFAULTMAP_CAT_ALLOCATABLE: + pcategory = "ALLOCATABLE"; + break; + case OMP_DEFAULTMAP_CAT_POINTER: + pcategory = "POINTER"; + break; + default: gcc_unreachable (); + } + if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED) + gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with " + "unspecified category"); + else + gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for " + "category %s", pcategory); + goto error; + } + } + c->defaultmap[category] = behavior; + if (gfc_match (")") != MATCH_YES) + break; + continue; + } + if ((mask & OMP_CLAUSE_DEFAULT) + && (m = gfc_match_dupl_check (c->default_sharing + == OMP_DEFAULT_UNKNOWN, "default", + true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("none") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_NONE; + else if (openacc) + { + if (gfc_match ("present") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_PRESENT; + } + else + { + if (gfc_match ("firstprivate") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE; + else if (gfc_match ("private") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_PRIVATE; + else if (gfc_match ("shared") == MATCH_YES) + c->default_sharing = OMP_DEFAULT_SHARED; + } + if (c->default_sharing == OMP_DEFAULT_UNKNOWN) + { + if (openacc) + gfc_error ("Expected NONE or PRESENT in DEFAULT clause " + "at %C"); + else + gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED " + "in DEFAULT clause at %C"); + goto error; + } + if (gfc_match (" )") != MATCH_YES) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_DELETE) + && gfc_match ("delete ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_RELEASE, true, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_DEPEND) + && gfc_match ("depend ( ") == MATCH_YES) + { + gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; + match m_it = gfc_match_iterator (&ns_iter, false); + if (m_it == MATCH_ERROR) + break; + if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES) + break; + m = MATCH_YES; + gfc_omp_depend_op depend_op = OMP_DEPEND_OUT; + if (gfc_match ("inout") == MATCH_YES) + depend_op = OMP_DEPEND_INOUT; + else if (gfc_match ("in") == MATCH_YES) + depend_op = OMP_DEPEND_IN; + else if (gfc_match ("out") == MATCH_YES) + depend_op = OMP_DEPEND_OUT; + else if (gfc_match ("mutexinoutset") == MATCH_YES) + depend_op = OMP_DEPEND_MUTEXINOUTSET; + else if (gfc_match ("depobj") == MATCH_YES) + depend_op = OMP_DEPEND_DEPOBJ; + else if (!c->depend_source + && gfc_match ("source )") == MATCH_YES) + { + if (m_it == MATCH_YES) + { + gfc_error ("ITERATOR may not be combined with SOURCE " + "at %C"); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + c->depend_source = true; + continue; + } + else if (gfc_match ("sink : ") == MATCH_YES) + { + if (m_it == MATCH_YES) + { + gfc_error ("ITERATOR may not be combined with SINK " + "at %C"); + break; + } + if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND]) + == MATCH_YES) + continue; + m = MATCH_NO; + } + else + m = MATCH_NO; + head = NULL; + if (ns_iter) + gfc_current_ns = ns_iter; + if (m == MATCH_YES) + m = gfc_match_omp_variable_list (" : ", + &c->lists[OMP_LIST_DEPEND], + false, NULL, &head, true); + gfc_current_ns = ns_curr; + if (m == MATCH_YES) + { + gfc_omp_namelist *n; + for (n = *head; n; n = n->next) + { + n->u.depend_op = depend_op; + n->u2.ns = ns_iter; + if (ns_iter) + ns_iter->refs++; + } + continue; + } + break; + } + if ((mask & OMP_CLAUSE_DETACH) + && !openacc + && !c->detach + && gfc_match_omp_detach (&c->detach) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_DETACH) + && openacc + && gfc_match ("detach ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_DETACH, false, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_DEVICE) + && !openacc + && ((m = gfc_match_dupl_check (!c->device, "device", true)) + != MATCH_NO)) + { + if (m == MATCH_ERROR) + goto error; + c->ancestor = false; + if (gfc_match ("device_num : ") == MATCH_YES) + { + if (gfc_match ("%e )", &c->device) != MATCH_YES) + { + gfc_error ("Expected integer expression at %C"); + break; + } + } + else if (gfc_match ("ancestor : ") == MATCH_YES) + { + c->ancestor = true; + if (!(gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) + { + gfc_error ("% device modifier not " + "preceded by % directive " + "with % clause at %C"); + break; + } + locus old_loc2 = gfc_current_locus; + if (gfc_match ("%e )", &c->device) == MATCH_YES) + { + int device = 0; + if (!gfc_extract_int (c->device, &device) && device != 1) + { + gfc_current_locus = old_loc2; + gfc_error ("the % clause expression must " + "evaluate to %<1%> at %C"); + break; + } + } + else + { + gfc_error ("Expected integer expression at %C"); + break; + } + } + else if (gfc_match ("%e )", &c->device) != MATCH_YES) + { + gfc_error ("Expected integer expression or a single device-" + "modifier % or % at %C"); + break; + } + continue; + } + if ((mask & OMP_CLAUSE_DEVICE) + && openacc + && gfc_match ("device ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FORCE_TO, true, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_DEVICEPTR) + && gfc_match ("deviceptr ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FORCE_DEVICEPTR, false, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_DEVICE_TYPE) + && gfc_match ("device_type ( ") == MATCH_YES) + { + if (gfc_match ("host") == MATCH_YES) + c->device_type = OMP_DEVICE_TYPE_HOST; + else if (gfc_match ("nohost") == MATCH_YES) + c->device_type = OMP_DEVICE_TYPE_NOHOST; + else if (gfc_match ("any") == MATCH_YES) + c->device_type = OMP_DEVICE_TYPE_ANY; + else + { + gfc_error ("Expected HOST, NOHOST or ANY at %C"); + break; + } + if (gfc_match (" )") != MATCH_YES) + break; + continue; + } + if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) + && gfc_match_omp_variable_list + ("device_resident (", + &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_DIST_SCHEDULE) + && c->dist_sched_kind == OMP_SCHED_NONE + && gfc_match ("dist_schedule ( static") == MATCH_YES) + { + m = MATCH_NO; + c->dist_sched_kind = OMP_SCHED_STATIC; + m = gfc_match (" , %e )", &c->dist_chunk_size); + if (m != MATCH_YES) + m = gfc_match_char (')'); + if (m != MATCH_YES) + { + c->dist_sched_kind = OMP_SCHED_NONE; + gfc_current_locus = old_loc; + } + else + continue; + } + break; + case 'f': + if ((mask & OMP_CLAUSE_FAIL) + && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET, + "fail", true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("seq_cst") == MATCH_YES) + c->fail = OMP_MEMORDER_SEQ_CST; + else if (gfc_match ("acquire") == MATCH_YES) + c->fail = OMP_MEMORDER_ACQUIRE; + else if (gfc_match ("relaxed") == MATCH_YES) + c->fail = OMP_MEMORDER_RELAXED; + else + { + gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C"); + break; + } + if (gfc_match (" )") != MATCH_YES) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_FILTER) + && (m = gfc_match_dupl_check (!c->filter, "filter", true, + &c->filter)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_FINAL) + && (m = gfc_match_dupl_check (!c->final_expr, "final", true, + &c->final_expr)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_FINALIZE) + && (m = gfc_match_dupl_check (!c->finalize, "finalize")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->finalize = true; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_FIRSTPRIVATE) + && gfc_match_omp_variable_list ("firstprivate (", + &c->lists[OMP_LIST_FIRSTPRIVATE], + true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_FROM) + && gfc_match_omp_variable_list ("from (", + &c->lists[OMP_LIST_FROM], false, + NULL, &head, true) == MATCH_YES) + continue; + break; + case 'g': + if ((mask & OMP_CLAUSE_GANG) + && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->gang = true; + m = match_oacc_clause_gwv (c, GOMP_DIM_GANG); + if (m == MATCH_ERROR) + { + gfc_current_locus = old_loc; + break; + } + else if (m == MATCH_NO) + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_GRAINSIZE) + && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("strict : ") == MATCH_YES) + c->grainsize_strict = true; + if (gfc_match (" %e )", &c->grainsize) != MATCH_YES) + goto error; + continue; + } + break; + case 'h': + if ((mask & OMP_CLAUSE_HINT) + && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_HOST_SELF) + && gfc_match ("host ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FORCE_FROM, true, + allow_derived)) + continue; + break; + case 'i': + if ((mask & OMP_CLAUSE_IF_PRESENT) + && (m = gfc_match_dupl_check (!c->if_present, "if_present")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->if_present = true; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_IF) + && (m = gfc_match_dupl_check (!c->if_expr, "if", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (!openacc) + { + /* This should match the enum gfc_omp_if_kind order. */ + static const char *ifs[OMP_IF_LAST] = { + "cancel : %e )", + "parallel : %e )", + "simd : %e )", + "task : %e )", + "taskloop : %e )", + "target : %e )", + "target data : %e )", + "target update : %e )", + "target enter data : %e )", + "target exit data : %e )" }; + int i; + for (i = 0; i < OMP_IF_LAST; i++) + if (c->if_exprs[i] == NULL + && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES) + break; + if (i < OMP_IF_LAST) + continue; + } + if (gfc_match (" %e )", &c->if_expr) == MATCH_YES) + continue; + goto error; + } + if ((mask & OMP_CLAUSE_IN_REDUCTION) + && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived, + openmp_target) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_INBRANCH) + && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch, + "inbranch")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->inbranch = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_INDEPENDENT) + && (m = gfc_match_dupl_check (!c->independent, "independent")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->independent = true; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_IS_DEVICE_PTR) + && gfc_match_omp_variable_list + ("is_device_ptr (", + &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES) + continue; + break; + case 'l': + if ((mask & OMP_CLAUSE_LASTPRIVATE) + && gfc_match ("lastprivate ( ") == MATCH_YES) + { + bool conditional = gfc_match ("conditional : ") == MATCH_YES; + head = NULL; + if (gfc_match_omp_variable_list ("", + &c->lists[OMP_LIST_LASTPRIVATE], + false, NULL, &head) == MATCH_YES) + { + gfc_omp_namelist *n; + for (n = *head; n; n = n->next) + n->u.lastprivate_conditional = conditional; + continue; + } + gfc_current_locus = old_loc; + break; + } + end_colon = false; + head = NULL; + if ((mask & OMP_CLAUSE_LINEAR) + && gfc_match ("linear (") == MATCH_YES) + { + gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; + gfc_expr *step = NULL; + + if (gfc_match_omp_variable_list (" ref (", + &c->lists[OMP_LIST_LINEAR], + false, NULL, &head) + == MATCH_YES) + linear_op = OMP_LINEAR_REF; + else if (gfc_match_omp_variable_list (" val (", + &c->lists[OMP_LIST_LINEAR], + false, NULL, &head) + == MATCH_YES) + linear_op = OMP_LINEAR_VAL; + else if (gfc_match_omp_variable_list (" uval (", + &c->lists[OMP_LIST_LINEAR], + false, NULL, &head) + == MATCH_YES) + linear_op = OMP_LINEAR_UVAL; + else if (gfc_match_omp_variable_list ("", + &c->lists[OMP_LIST_LINEAR], + false, &end_colon, &head) + == MATCH_YES) + linear_op = OMP_LINEAR_DEFAULT; + else + { + gfc_current_locus = old_loc; + break; + } + if (linear_op != OMP_LINEAR_DEFAULT) + { + if (gfc_match (" :") == MATCH_YES) + end_colon = true; + else if (gfc_match (" )") != MATCH_YES) + { + gfc_free_omp_namelist (*head, false); + gfc_current_locus = old_loc; + *head = NULL; + break; + } + } + if (end_colon && gfc_match (" %e )", &step) != MATCH_YES) + { + gfc_free_omp_namelist (*head, false); + gfc_current_locus = old_loc; + *head = NULL; + break; + } + else if (!end_colon) + { + step = gfc_get_constant_expr (BT_INTEGER, + gfc_default_integer_kind, + &old_loc); + mpz_set_si (step->value.integer, 1); + } + (*head)->expr = step; + if (linear_op != OMP_LINEAR_DEFAULT) + for (gfc_omp_namelist *n = *head; n; n = n->next) + n->u.linear_op = linear_op; + continue; + } + if ((mask & OMP_CLAUSE_LINK) + && openacc + && (gfc_match_oacc_clause_link ("link (", + &c->lists[OMP_LIST_LINK]) + == MATCH_YES)) + continue; + else if ((mask & OMP_CLAUSE_LINK) + && !openacc + && (gfc_match_omp_to_link ("link (", + &c->lists[OMP_LIST_LINK]) + == MATCH_YES)) + continue; + break; + case 'm': + if ((mask & OMP_CLAUSE_MAP) + && gfc_match ("map ( ") == MATCH_YES) + { + locus old_loc2 = gfc_current_locus; + int always_modifier = 0; + int close_modifier = 0; + locus second_always_locus = old_loc2; + locus second_close_locus = old_loc2; + + for (;;) + { + locus current_locus = gfc_current_locus; + if (gfc_match ("always ") == MATCH_YES) + { + if (always_modifier++ == 1) + second_always_locus = current_locus; + } + else if (gfc_match ("close ") == MATCH_YES) + { + if (close_modifier++ == 1) + second_close_locus = current_locus; + } + else + break; + gfc_match (", "); + } + + gfc_omp_map_op map_op = OMP_MAP_TOFROM; + if (gfc_match ("alloc : ") == MATCH_YES) + map_op = OMP_MAP_ALLOC; + else if (gfc_match ("tofrom : ") == MATCH_YES) + map_op = always_modifier ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM; + else if (gfc_match ("to : ") == MATCH_YES) + map_op = always_modifier ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO; + else if (gfc_match ("from : ") == MATCH_YES) + map_op = always_modifier ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM; + else if (gfc_match ("release : ") == MATCH_YES) + map_op = OMP_MAP_RELEASE; + else if (gfc_match ("delete : ") == MATCH_YES) + map_op = OMP_MAP_DELETE; + else + { + gfc_current_locus = old_loc2; + always_modifier = 0; + close_modifier = 0; + } + + if (always_modifier > 1) + { + gfc_error ("too many % modifiers at %L", + &second_always_locus); + break; + } + if (close_modifier > 1) + { + gfc_error ("too many % modifiers at %L", + &second_close_locus); + break; + } + + head = NULL; + if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], + false, NULL, &head, + true, true) == MATCH_YES) + { + gfc_omp_namelist *n; + for (n = *head; n; n = n->next) + n->u.map_op = map_op; + continue; + } + gfc_current_locus = old_loc; + break; + } + if ((mask & OMP_CLAUSE_MERGEABLE) + && (m = gfc_match_dupl_check (!c->mergeable, "mergeable")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->mergeable = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_MESSAGE) + && (m = gfc_match_dupl_check (!c->message, "message", true, + &c->message)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + break; + case 'n': + if ((mask & OMP_CLAUSE_NO_CREATE) + && gfc_match ("no_create ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_IF_PRESENT, true, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_NOGROUP) + && (m = gfc_match_dupl_check (!c->nogroup, "nogroup")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->nogroup = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_NOHOST) + && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->nohost = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_NOTEMPORAL) + && gfc_match_omp_variable_list ("nontemporal (", + &c->lists[OMP_LIST_NONTEMPORAL], + true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_NOTINBRANCH) + && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch, + "notinbranch")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->notinbranch = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_NOWAIT) + && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->nowait = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_NUM_GANGS) + && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs", + true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_NUM_TASKS) + && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("strict : ") == MATCH_YES) + c->num_tasks_strict = true; + if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_NUM_TEAMS) + && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams", + true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES) + goto error; + if (gfc_peek_ascii_char () == ':') + { + c->num_teams_lower = c->num_teams_upper; + c->num_teams_upper = NULL; + if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES) + goto error; + } + if (gfc_match (") ") != MATCH_YES) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_NUM_THREADS) + && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true, + &c->num_threads)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_NUM_WORKERS) + && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers", + true, &c->num_workers_expr)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + break; + case 'o': + if ((mask & OMP_CLAUSE_ORDER) + && (m = gfc_match_dupl_check (!c->order_concurrent, "order (")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match (" reproducible : concurrent )") == MATCH_YES) + c->order_reproducible = true; + else if (gfc_match (" concurrent )") == MATCH_YES) + ; + else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES) + c->order_unconstrained = true; + else + { + gfc_error ("Expected ORDER(CONCURRENT) at %C " + "with optional % or " + "% modifier"); + goto error; + } + c->order_concurrent = true; + continue; + } + if ((mask & OMP_CLAUSE_ORDERED) + && (m = gfc_match_dupl_check (!c->ordered, "ordered")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + gfc_expr *cexpr = NULL; + m = gfc_match (" ( %e )", &cexpr); + + c->ordered = true; + if (m == MATCH_YES) + { + int ordered = 0; + if (gfc_extract_int (cexpr, &ordered, -1)) + ordered = 0; + else if (ordered <= 0) + { + gfc_error_now ("ORDERED clause argument not" + " constant positive integer at %C"); + ordered = 0; + } + c->orderedc = ordered; + gfc_free_expr (cexpr); + continue; + } + + needs_space = true; + continue; + } + break; + case 'p': + if ((mask & OMP_CLAUSE_COPY) + && gfc_match ("pcopy ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_TOFROM, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_COPYIN) + && gfc_match ("pcopyin ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_TO, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_COPYOUT) + && gfc_match ("pcopyout ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FROM, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_CREATE) + && gfc_match ("pcreate ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_ALLOC, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_PRESENT) + && gfc_match ("present ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FORCE_PRESENT, false, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_COPY) + && gfc_match ("present_or_copy ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_TOFROM, true, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_COPYIN) + && gfc_match ("present_or_copyin ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_TO, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_COPYOUT) + && gfc_match ("present_or_copyout ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FROM, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_CREATE) + && gfc_match ("present_or_create ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_ALLOC, true, allow_derived)) + continue; + if ((mask & OMP_CLAUSE_PRIORITY) + && (m = gfc_match_dupl_check (!c->priority, "priority", true, + &c->priority)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_PRIVATE) + && gfc_match_omp_variable_list ("private (", + &c->lists[OMP_LIST_PRIVATE], + true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_PROC_BIND) + && (m = gfc_match_dupl_check ((c->proc_bind + == OMP_PROC_BIND_UNKNOWN), + "proc_bind", true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("primary )") == MATCH_YES) + c->proc_bind = OMP_PROC_BIND_PRIMARY; + else if (gfc_match ("master )") == MATCH_YES) + c->proc_bind = OMP_PROC_BIND_MASTER; + else if (gfc_match ("spread )") == MATCH_YES) + c->proc_bind = OMP_PROC_BIND_SPREAD; + else if (gfc_match ("close )") == MATCH_YES) + c->proc_bind = OMP_PROC_BIND_CLOSE; + else + goto error; + continue; + } + break; + case 'r': + if ((mask & OMP_CLAUSE_ATOMIC) + && (m = gfc_match_dupl_atomic ((c->atomic_op + == GFC_OMP_ATOMIC_UNSET), + "read")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->atomic_op = GFC_OMP_ATOMIC_READ; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_REDUCTION) + && gfc_match_omp_clause_reduction (pc, c, openacc, + allow_derived) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_MEMORDER) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "relaxed")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->memorder = OMP_MEMORDER_RELAXED; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_MEMORDER) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "release")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->memorder = OMP_MEMORDER_RELEASE; + needs_space = true; + continue; + } + break; + case 's': + if ((mask & OMP_CLAUSE_SAFELEN) + && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen", + true, &c->safelen_expr)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_SCHEDULE) + && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE, + "schedule", true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + int nmodifiers = 0; + locus old_loc2 = gfc_current_locus; + do + { + if (gfc_match ("simd") == MATCH_YES) + { + c->sched_simd = true; + nmodifiers++; + } + else if (gfc_match ("monotonic") == MATCH_YES) + { + c->sched_monotonic = true; + nmodifiers++; + } + else if (gfc_match ("nonmonotonic") == MATCH_YES) + { + c->sched_nonmonotonic = true; + nmodifiers++; + } + else + { + if (nmodifiers) + gfc_current_locus = old_loc2; + break; + } + if (nmodifiers == 1 + && gfc_match (" , ") == MATCH_YES) + continue; + else if (gfc_match (" : ") == MATCH_YES) + break; + gfc_current_locus = old_loc2; + break; + } + while (1); + if (gfc_match ("static") == MATCH_YES) + c->sched_kind = OMP_SCHED_STATIC; + else if (gfc_match ("dynamic") == MATCH_YES) + c->sched_kind = OMP_SCHED_DYNAMIC; + else if (gfc_match ("guided") == MATCH_YES) + c->sched_kind = OMP_SCHED_GUIDED; + else if (gfc_match ("runtime") == MATCH_YES) + c->sched_kind = OMP_SCHED_RUNTIME; + else if (gfc_match ("auto") == MATCH_YES) + c->sched_kind = OMP_SCHED_AUTO; + if (c->sched_kind != OMP_SCHED_NONE) + { + m = MATCH_NO; + if (c->sched_kind != OMP_SCHED_RUNTIME + && c->sched_kind != OMP_SCHED_AUTO) + m = gfc_match (" , %e )", &c->chunk_size); + if (m != MATCH_YES) + m = gfc_match_char (')'); + if (m != MATCH_YES) + c->sched_kind = OMP_SCHED_NONE; + } + if (c->sched_kind != OMP_SCHED_NONE) + continue; + else + gfc_current_locus = old_loc; + } + if ((mask & OMP_CLAUSE_HOST_SELF) + && gfc_match ("self ( ") == MATCH_YES + && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], + OMP_MAP_FORCE_FROM, true, + allow_derived)) + continue; + if ((mask & OMP_CLAUSE_SEQ) + && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->seq = true; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_MEMORDER) + && (m = gfc_match_dupl_memorder ((c->memorder + == OMP_MEMORDER_UNSET), + "seq_cst")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->memorder = OMP_MEMORDER_SEQ_CST; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_SHARED) + && gfc_match_omp_variable_list ("shared (", + &c->lists[OMP_LIST_SHARED], + true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_SIMDLEN) + && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true, + &c->simdlen_expr)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_SIMD) + && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->simd = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_SEVERITY) + && (m = gfc_match_dupl_check (!c->severity, "severity", true)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("fatal )") == MATCH_YES) + c->severity = OMP_SEVERITY_FATAL; + else if (gfc_match ("warning )") == MATCH_YES) + c->severity = OMP_SEVERITY_WARNING; + else + { + gfc_error ("Expected FATAL or WARNING in SEVERITY clause " + "at %C"); + goto error; + } + continue; + } + break; + case 't': + if ((mask & OMP_CLAUSE_TASK_REDUCTION) + && gfc_match_omp_clause_reduction (pc, c, openacc, + allow_derived) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_THREAD_LIMIT) + && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit", + true, &c->thread_limit)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_THREADS) + && (m = gfc_match_dupl_check (!c->threads, "threads")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->threads = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_TILE) + && !c->tile_list + && match_oacc_expr_list ("tile (", &c->tile_list, + true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK)) + { + if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]) + == MATCH_YES) + continue; + } + else if ((mask & OMP_CLAUSE_TO) + && gfc_match_omp_variable_list ("to (", + &c->lists[OMP_LIST_TO], false, + NULL, &head, true) == MATCH_YES) + continue; + break; + case 'u': + if ((mask & OMP_CLAUSE_UNIFORM) + && gfc_match_omp_variable_list ("uniform (", + &c->lists[OMP_LIST_UNIFORM], + false) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_UNTIED) + && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->untied = needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_ATOMIC) + && (m = gfc_match_dupl_atomic ((c->atomic_op + == GFC_OMP_ATOMIC_UNSET), + "update")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->atomic_op = GFC_OMP_ATOMIC_UPDATE; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_USE_DEVICE) + && gfc_match_omp_variable_list ("use_device (", + &c->lists[OMP_LIST_USE_DEVICE], + true) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_USE_DEVICE_PTR) + && gfc_match_omp_variable_list + ("use_device_ptr (", + &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES) + continue; + if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR) + && gfc_match_omp_variable_list + ("use_device_addr (", + &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES) + continue; + break; + case 'v': + /* VECTOR_LENGTH must be matched before VECTOR, because the latter + doesn't unconditionally match '('. */ + if ((mask & OMP_CLAUSE_VECTOR_LENGTH) + && (m = gfc_match_dupl_check (!c->vector_length_expr, + "vector_length", true, + &c->vector_length_expr)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((mask & OMP_CLAUSE_VECTOR) + && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->vector = true; + m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + needs_space = true; + continue; + } + break; + case 'w': + if ((mask & OMP_CLAUSE_WAIT) + && gfc_match ("wait") == MATCH_YES) + { + m = match_oacc_expr_list (" (", &c->wait_list, false); + if (m == MATCH_ERROR) + goto error; + else if (m == MATCH_NO) + { + gfc_expr *expr + = gfc_get_constant_expr (BT_INTEGER, + gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL); + gfc_expr_list **expr_list = &c->wait_list; + while (*expr_list) + expr_list = &(*expr_list)->next; + *expr_list = gfc_get_expr_list (); + (*expr_list)->expr = expr; + needs_space = true; + } + continue; + } + if ((mask & OMP_CLAUSE_WEAK) + && (m = gfc_match_dupl_check (!c->weak, "weak")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->weak = true; + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_WORKER) + && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->worker = true; + m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER); + if (m == MATCH_ERROR) + goto error; + else if (m == MATCH_NO) + needs_space = true; + continue; + } + if ((mask & OMP_CLAUSE_ATOMIC) + && (m = gfc_match_dupl_atomic ((c->atomic_op + == GFC_OMP_ATOMIC_UNSET), + "write")) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->atomic_op = GFC_OMP_ATOMIC_WRITE; + needs_space = true; + continue; + } + break; + } + break; + } + +end: + if (error + || (context_selector && gfc_peek_ascii_char () != ')') + || (!context_selector && gfc_match_omp_eos () != MATCH_YES)) + { + if (!gfc_error_flag_test ()) + gfc_error ("Failed to match clause at %C"); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + + *cp = c; + return MATCH_YES; + +error: + error = true; + goto end; +} + + +#define OACC_PARALLEL_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ + | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \ + | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ + | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ + | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) +#define OACC_KERNELS_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \ + | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \ + | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ + | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) +#define OACC_SERIAL_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \ + | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ + | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \ + | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH) +#define OACC_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \ + | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \ + | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH) +#define OACC_LOOP_CLAUSES \ + (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \ + | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \ + | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \ + | OMP_CLAUSE_TILE) +#define OACC_PARALLEL_LOOP_CLAUSES \ + (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES) +#define OACC_KERNELS_LOOP_CLAUSES \ + (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES) +#define OACC_SERIAL_LOOP_CLAUSES \ + (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES) +#define OACC_HOST_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_USE_DEVICE) \ + | OMP_CLAUSE_IF \ + | OMP_CLAUSE_IF_PRESENT) +#define OACC_DECLARE_CLAUSES \ + (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \ + | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \ + | OMP_CLAUSE_PRESENT \ + | OMP_CLAUSE_LINK) +#define OACC_UPDATE_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \ + | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT) +#define OACC_ENTER_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ + | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH) +#define OACC_EXIT_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \ + | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ + | OMP_CLAUSE_DETACH) +#define OACC_WAIT_CLAUSES \ + omp_mask (OMP_CLAUSE_ASYNC) +#define OACC_ROUTINE_CLAUSES \ + (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ + | OMP_CLAUSE_SEQ \ + | OMP_CLAUSE_NOHOST) + + +static match +match_acc (gfc_exec_op op, const omp_mask mask) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES) + return MATCH_ERROR; + new_st.op = op; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +match +gfc_match_oacc_parallel_loop (void) +{ + return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES); +} + + +match +gfc_match_oacc_parallel (void) +{ + return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES); +} + + +match +gfc_match_oacc_kernels_loop (void) +{ + return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES); +} + + +match +gfc_match_oacc_kernels (void) +{ + return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES); +} + + +match +gfc_match_oacc_serial_loop (void) +{ + return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES); +} + + +match +gfc_match_oacc_serial (void) +{ + return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES); +} + + +match +gfc_match_oacc_data (void) +{ + return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES); +} + + +match +gfc_match_oacc_host_data (void) +{ + return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES); +} + + +match +gfc_match_oacc_loop (void) +{ + return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES); +} + + +match +gfc_match_oacc_declare (void) +{ + gfc_omp_clauses *c; + gfc_omp_namelist *n; + gfc_namespace *ns = gfc_current_ns; + gfc_oacc_declare *new_oc; + bool module_var = false; + locus where = gfc_current_locus; + + if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true) + != MATCH_YES) + return MATCH_ERROR; + + for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next) + n->sym->attr.oacc_declare_device_resident = 1; + + for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next) + n->sym->attr.oacc_declare_link = 1; + + for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next) + { + gfc_symbol *s = n->sym; + + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) + { + if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO) + { + gfc_error ("Invalid clause in module with !$ACC DECLARE at %L", + &where); + return MATCH_ERROR; + } + + module_var = true; + } + + if (s->attr.use_assoc) + { + gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L", + &where); + return MATCH_ERROR; + } + + if ((s->result == s && s->ns->contained != gfc_current_ns) + || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE) + && s->ns != gfc_current_ns)) + { + gfc_error ("Variable %qs shall be declared in the same scoping unit " + "as !$ACC DECLARE at %L", s->name, &where); + return MATCH_ERROR; + } + + if ((s->attr.dimension || s->attr.codimension) + && s->attr.dummy && s->as->type != AS_EXPLICIT) + { + gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L", + &where); + return MATCH_ERROR; + } + + switch (n->u.map_op) + { + case OMP_MAP_FORCE_ALLOC: + case OMP_MAP_ALLOC: + s->attr.oacc_declare_create = 1; + break; + + case OMP_MAP_FORCE_TO: + case OMP_MAP_TO: + s->attr.oacc_declare_copyin = 1; + break; + + case OMP_MAP_FORCE_DEVICEPTR: + s->attr.oacc_declare_deviceptr = 1; + break; + + default: + break; + } + } + + new_oc = gfc_get_oacc_declare (); + new_oc->next = ns->oacc_declare; + new_oc->module_var = module_var; + new_oc->clauses = c; + new_oc->loc = gfc_current_locus; + ns->oacc_declare = new_oc; + + return MATCH_YES; +} + + +match +gfc_match_oacc_update (void) +{ + gfc_omp_clauses *c; + locus here = gfc_current_locus; + + if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true) + != MATCH_YES) + return MATCH_ERROR; + + if (!c->lists[OMP_LIST_MAP]) + { + gfc_error ("% must contain at least one " + "% or % or % clause at %L", &here); + return MATCH_ERROR; + } + + new_st.op = EXEC_OACC_UPDATE; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_enter_data (void) +{ + return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES); +} + + +match +gfc_match_oacc_exit_data (void) +{ + return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES); +} + + +match +gfc_match_oacc_wait (void) +{ + gfc_omp_clauses *c = gfc_get_omp_clauses (); + gfc_expr_list *wait_list = NULL, *el; + bool space = true; + match m; + + m = match_oacc_expr_list (" (", &wait_list, true); + if (m == MATCH_ERROR) + return m; + else if (m == MATCH_YES) + space = false; + + if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true) + == MATCH_ERROR) + return MATCH_ERROR; + + if (wait_list) + for (el = wait_list; el; el = el->next) + { + if (el->expr == NULL) + { + gfc_error ("Invalid argument to !$ACC WAIT at %C"); + return MATCH_ERROR; + } + + if (!gfc_resolve_expr (el->expr) + || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0) + { + gfc_error ("WAIT clause at %L requires a scalar INTEGER expression", + &el->expr->where); + + return MATCH_ERROR; + } + } + c->wait_list = wait_list; + new_st.op = EXEC_OACC_WAIT; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_oacc_cache (void) +{ + gfc_omp_clauses *c = gfc_get_omp_clauses (); + /* The OpenACC cache directive explicitly only allows "array elements or + subarrays", which we're currently not checking here. Either check this + after the call of gfc_match_omp_variable_list, or add something like a + only_sections variant next to its allow_sections parameter. */ + match m = gfc_match_omp_variable_list (" (", + &c->lists[OMP_LIST_CACHE], true, + NULL, NULL, true); + if (m != MATCH_YES) + { + gfc_free_omp_clauses(c); + return m; + } + + if (gfc_current_state() != COMP_DO + && gfc_current_state() != COMP_DO_CONCURRENT) + { + gfc_error ("ACC CACHE directive must be inside of loop %C"); + gfc_free_omp_clauses(c); + return MATCH_ERROR; + } + + new_st.op = EXEC_OACC_CACHE; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + +/* Determine the OpenACC 'routine' directive's level of parallelism. */ + +static oacc_routine_lop +gfc_oacc_routine_lop (gfc_omp_clauses *clauses) +{ + oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ; + + if (clauses) + { + unsigned n_lop_clauses = 0; + + if (clauses->gang) + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_GANG; + } + if (clauses->worker) + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_WORKER; + } + if (clauses->vector) + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_VECTOR; + } + if (clauses->seq) + { + ++n_lop_clauses; + ret = OACC_ROUTINE_LOP_SEQ; + } + + if (n_lop_clauses > 1) + ret = OACC_ROUTINE_LOP_ERROR; + } + + return ret; +} + +match +gfc_match_oacc_routine (void) +{ + locus old_loc; + match m; + gfc_intrinsic_sym *isym = NULL; + gfc_symbol *sym = NULL; + gfc_omp_clauses *c = NULL; + gfc_oacc_routine_name *n = NULL; + oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE; + bool nohost; + + old_loc = gfc_current_locus; + + m = gfc_match (" ("); + + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY + && m == MATCH_YES) + { + gfc_error ("Only the !$ACC ROUTINE form without " + "list is allowed in interface block at %C"); + goto cleanup; + } + + if (m == MATCH_YES) + { + char buffer[GFC_MAX_SYMBOL_LEN + 1]; + + m = gfc_match_name (buffer); + if (m == MATCH_YES) + { + gfc_symtree *st = NULL; + + /* First look for an intrinsic symbol. */ + isym = gfc_find_function (buffer); + if (!isym) + isym = gfc_find_subroutine (buffer); + /* If no intrinsic symbol found, search the current namespace. */ + if (!isym) + st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); + if (st) + { + sym = st->n.sym; + /* If the name in a 'routine' directive refers to the containing + subroutine or function, then make sure that we'll later handle + this accordingly. */ + if (gfc_current_ns->proc_name != NULL + && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) + sym = NULL; + } + + if (isym == NULL && st == NULL) + { + gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C", + buffer); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + } + else + { + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" + " ')' after NAME"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } + } + + if (gfc_match_omp_eos () != MATCH_YES + && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true) + != MATCH_YES)) + return MATCH_ERROR; + + lop = gfc_oacc_routine_lop (c); + if (lop == OACC_ROUTINE_LOP_ERROR) + { + gfc_error ("Multiple loop axes specified for routine at %C"); + goto cleanup; + } + nohost = c ? c->nohost : false; + + if (isym != NULL) + { + /* Diagnose any OpenACC 'routine' directive that doesn't match the + (implicit) one with a 'seq' clause. */ + if (c && (c->gang || c->worker || c->vector)) + { + gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" + " at %C marked with incompatible GANG, WORKER, or VECTOR" + " clause"); + goto cleanup; + } + /* ..., and no 'nohost' clause. */ + if (nohost) + { + gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )" + " at %C marked with incompatible NOHOST clause"); + goto cleanup; + } + } + else if (sym != NULL) + { + bool add = true; + + /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't + match the first one. */ + for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names; + n_p; + n_p = n_p->next) + if (n_p->sym == sym) + { + add = false; + bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false; + if (lop != gfc_oacc_routine_lop (n_p->clauses) + || nohost != nohost_p) + { + gfc_error ("!$ACC ROUTINE already applied at %C"); + goto cleanup; + } + } + + if (add) + { + sym->attr.oacc_routine_lop = lop; + sym->attr.oacc_routine_nohost = nohost; + + n = gfc_get_oacc_routine_name (); + n->sym = sym; + n->clauses = c; + n->next = gfc_current_ns->oacc_routine_names; + n->loc = old_loc; + gfc_current_ns->oacc_routine_names = n; + } + } + else if (gfc_current_ns->proc_name) + { + /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't + match the first one. */ + oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop; + bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost; + if (lop_p != OACC_ROUTINE_LOP_NONE + && (lop != lop_p + || nohost != nohost_p)) + { + gfc_error ("!$ACC ROUTINE already applied at %C"); + goto cleanup; + } + + if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, + gfc_current_ns->proc_name->name, + &old_loc)) + goto cleanup; + gfc_current_ns->proc_name->attr.oacc_routine_lop = lop; + gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost; + } + else + /* Something has gone wrong, possibly a syntax error. */ + goto cleanup; + + if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector)) + { + gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not " + "permitted in PURE procedure at %C"); + goto cleanup; + } + + + if (n) + n->clauses = c; + else if (gfc_current_ns->oacc_routine) + gfc_current_ns->oacc_routine_clauses = c; + + new_st.op = EXEC_OACC_ROUTINE; + new_st.ext.omp_clauses = c; + return MATCH_YES; + +cleanup: + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + + +#define OMP_PARALLEL_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \ + | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \ + | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE) +#define OMP_DECLARE_SIMD_CLAUSES \ + (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \ + | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \ + | OMP_CLAUSE_NOTINBRANCH) +#define OMP_DO_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ + | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \ + | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE) +#define OMP_LOOP_CLAUSES \ + (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \ + | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) + +#define OMP_SCOPE_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_REDUCTION) +#define OMP_SECTIONS_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE) +#define OMP_SIMD_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \ + | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \ + | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \ + | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL) +#define OMP_TASK_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ + | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \ + | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \ + | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE) +#define OMP_TASKLOOP_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \ + | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \ + | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \ + | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE) +#define OMP_TASKGROUP_CLAUSES \ + (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE) +#define OMP_TARGET_CLAUSES \ + (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ + | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \ + | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ + | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ + | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE) +#define OMP_TARGET_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ + | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) +#define OMP_TARGET_ENTER_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ + | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) +#define OMP_TARGET_EXIT_DATA_CLAUSES \ + (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ + | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) +#define OMP_TARGET_UPDATE_CLAUSES \ + (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \ + | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT) +#define OMP_TEAMS_CLAUSES \ + (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \ + | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE) +#define OMP_DISTRIBUTE_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \ + | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE) +#define OMP_SINGLE_CLAUSES \ + (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_ALLOCATE) +#define OMP_ORDERED_CLAUSES \ + (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) +#define OMP_DECLARE_TARGET_CLAUSES \ + (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE) +#define OMP_ATOMIC_CLAUSES \ + (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ + | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ + | OMP_CLAUSE_WEAK) +#define OMP_MASKED_CLAUSES \ + (omp_mask (OMP_CLAUSE_FILTER)) +#define OMP_ERROR_CLAUSES \ + (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY) + + + +static match +match_omp (gfc_exec_op op, const omp_mask mask) +{ + gfc_omp_clauses *c; + if (gfc_match_omp_clauses (&c, mask, true, true, false, false, + op == EXEC_OMP_TARGET) != MATCH_YES) + return MATCH_ERROR; + new_st.op = op; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_omp_critical (void) +{ + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_omp_clauses *c = NULL; + + if (gfc_match (" ( %n )", n) != MATCH_YES) + n[0] = '\0'; + + if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT), + /* first = */ n[0] == '\0') != MATCH_YES) + return MATCH_ERROR; + + new_st.op = EXEC_OMP_CRITICAL; + new_st.ext.omp_clauses = c; + if (n[0]) + c->critical_name = xstrdup (n); + return MATCH_YES; +} + + +match +gfc_match_omp_end_critical (void) +{ + char n[GFC_MAX_SYMBOL_LEN+1]; + + if (gfc_match (" ( %n )", n) != MATCH_YES) + n[0] = '\0'; + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); + return MATCH_ERROR; + } + + new_st.op = EXEC_OMP_END_CRITICAL; + new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL; + return MATCH_YES; +} + +/* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type) + dep-type = in/out/inout/mutexinoutset/depobj/source/sink + depend: !source, !sink + update: !source, !sink, !depobj + locator = exactly one list item .*/ +match +gfc_match_omp_depobj (void) +{ + gfc_omp_clauses *c = NULL; + gfc_expr *depobj; + + if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES) + { + gfc_error ("Expected %<( depobj )%> at %C"); + return MATCH_ERROR; + } + if (gfc_match ("update ( ") == MATCH_YES) + { + c = gfc_get_omp_clauses (); + if (gfc_match ("inout )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_INOUT; + else if (gfc_match ("in )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_IN; + else if (gfc_match ("out )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_OUT; + else if (gfc_match ("mutexinoutset )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_MUTEXINOUTSET; + else + { + gfc_error ("Expected IN, OUT, INOUT, MUTEXINOUTSET followed by " + "%<)%> at %C"); + goto error; + } + } + else if (gfc_match ("destroy") == MATCH_YES) + { + c = gfc_get_omp_clauses (); + c->destroy = true; + } + else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false) + != MATCH_YES) + goto error; + + if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy) + { + if (!c->depend_source && !c->lists[OMP_LIST_DEPEND]) + { + gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C"); + goto error; + } + if (c->depend_source + || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK_FIRST + || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK + || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_DEPOBJ) + { + gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not " + "have dependence-type SOURCE, SINK or DEPOBJ", + c->lists[OMP_LIST_DEPEND] + ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus); + goto error; + } + if (c->lists[OMP_LIST_DEPEND]->next) + { + gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have " + "only a single locator", + &c->lists[OMP_LIST_DEPEND]->next->where); + goto error; + } + } + + c->depobj = depobj; + new_st.op = EXEC_OMP_DEPOBJ; + new_st.ext.omp_clauses = c; + return MATCH_YES; + +error: + gfc_free_expr (depobj); + gfc_free_omp_clauses (c); + return MATCH_ERROR; +} + +match +gfc_match_omp_distribute (void) +{ + return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES); +} + + +match +gfc_match_omp_distribute_parallel_do (void) +{ + return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO, + (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES + | OMP_DO_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_ORDERED)) + & ~(omp_mask (OMP_CLAUSE_LINEAR))); +} + + +match +gfc_match_omp_distribute_parallel_do_simd (void) +{ + return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD, + (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES + | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_ORDERED))); +} + + +match +gfc_match_omp_distribute_simd (void) +{ + return match_omp (EXEC_OMP_DISTRIBUTE_SIMD, + OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_do (void) +{ + return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES); +} + + +match +gfc_match_omp_do_simd (void) +{ + return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_loop (void) +{ + return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_teams_loop (void) +{ + return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_target_teams_loop (void) +{ + return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP, + OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_parallel_loop (void) +{ + return match_omp (EXEC_OMP_PARALLEL_LOOP, + OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES); +} + + +match +gfc_match_omp_target_parallel_loop (void) +{ + return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP, + (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES + | OMP_LOOP_CLAUSES)); +} + + +match +gfc_match_omp_error (void) +{ + locus loc = gfc_current_locus; + match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES); + if (m != MATCH_YES) + return m; + + gfc_omp_clauses *c = new_st.ext.omp_clauses; + if (c->severity == OMP_SEVERITY_UNSET) + c->severity = OMP_SEVERITY_FATAL; + if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION) + return MATCH_YES; + if (c->message + && (!gfc_resolve_expr (c->message) + || c->message->ts.type != BT_CHARACTER + || c->message->ts.kind != gfc_default_character_kind + || c->message->rank != 0)) + { + gfc_error ("MESSAGE clause at %L requires a scalar default-kind " + "CHARACTER expression", + &new_st.ext.omp_clauses->message->where); + return MATCH_ERROR; + } + if (c->message && !gfc_is_constant_expr (c->message)) + { + gfc_error ("Constant character expression required in MESSAGE clause " + "at %L", &new_st.ext.omp_clauses->message->where); + return MATCH_ERROR; + } + if (c->message) + { + const char *msg = G_("$OMP ERROR encountered at %L: %s"); + gcc_assert (c->message->expr_type == EXPR_CONSTANT); + gfc_charlen_t slen = c->message->value.character.length; + int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind, + false); + size_t size = slen * gfc_character_kinds[i].bit_size / 8; + unsigned char *s = XCNEWVAR (unsigned char, size + 1); + gfc_encode_character (gfc_default_character_kind, slen, + c->message->value.character.string, + (unsigned char *) s, size); + s[size] = '\0'; + if (c->severity == OMP_SEVERITY_WARNING) + gfc_warning_now (0, msg, &loc, s); + else + gfc_error_now (msg, &loc, s); + free (s); + } + else + { + const char *msg = G_("$OMP ERROR encountered at %L"); + if (c->severity == OMP_SEVERITY_WARNING) + gfc_warning_now (0, msg, &loc); + else + gfc_error_now (msg, &loc); + } + return MATCH_YES; +} + +match +gfc_match_omp_flush (void) +{ + gfc_omp_namelist *list = NULL; + gfc_omp_clauses *c = NULL; + gfc_gobble_whitespace (); + enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET; + if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(') + { + if (gfc_match ("seq_cst") == MATCH_YES) + mo = OMP_MEMORDER_SEQ_CST; + else if (gfc_match ("acq_rel") == MATCH_YES) + mo = OMP_MEMORDER_ACQ_REL; + else if (gfc_match ("release") == MATCH_YES) + mo = OMP_MEMORDER_RELEASE; + else if (gfc_match ("acquire") == MATCH_YES) + mo = OMP_MEMORDER_ACQUIRE; + else + { + gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C"); + return MATCH_ERROR; + } + c = gfc_get_omp_clauses (); + c->memorder = mo; + } + gfc_match_omp_variable_list (" (", &list, true); + if (list && mo != OMP_MEMORDER_UNSET) + { + gfc_error ("List specified together with memory order clause in FLUSH " + "directive at %C"); + gfc_free_omp_namelist (list, false); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); + gfc_free_omp_namelist (list, false); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + new_st.op = EXEC_OMP_FLUSH; + new_st.ext.omp_namelist = list; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_omp_declare_simd (void) +{ + locus where = gfc_current_locus; + gfc_symbol *proc_name; + gfc_omp_clauses *c; + gfc_omp_declare_simd *ods; + bool needs_space = false; + + switch (gfc_match (" ( %s ) ", &proc_name)) + { + case MATCH_YES: break; + case MATCH_NO: proc_name = NULL; needs_space = true; break; + case MATCH_ERROR: return MATCH_ERROR; + } + + if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true, + needs_space) != MATCH_YES) + return MATCH_ERROR; + + if (gfc_current_ns->is_block_data) + { + gfc_free_omp_clauses (c); + return MATCH_YES; + } + + ods = gfc_get_omp_declare_simd (); + ods->where = where; + ods->proc_name = proc_name; + ods->clauses = c; + ods->next = gfc_current_ns->omp_declare_simd; + gfc_current_ns->omp_declare_simd = ods; + return MATCH_YES; +} + + +static bool +match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2) +{ + match m; + locus old_loc = gfc_current_locus; + char sname[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + gfc_namespace *ns = gfc_current_ns; + gfc_expr *lvalue = NULL, *rvalue = NULL; + gfc_symtree *st; + gfc_actual_arglist *arglist; + + m = gfc_match (" %v =", &lvalue); + if (m != MATCH_YES) + gfc_current_locus = old_loc; + else + { + m = gfc_match (" %e )", &rvalue); + if (m == MATCH_YES) + { + ns->code = gfc_get_code (EXEC_ASSIGN); + ns->code->expr1 = lvalue; + ns->code->expr2 = rvalue; + ns->code->loc = old_loc; + return true; + } + + gfc_current_locus = old_loc; + gfc_free_expr (lvalue); + } + + m = gfc_match (" %n", sname); + if (m != MATCH_YES) + return false; + + if (strcmp (sname, omp_sym1->name) == 0 + || strcmp (sname, omp_sym2->name) == 0) + return false; + + gfc_current_ns = ns->parent; + if (gfc_get_ha_sym_tree (sname, &st)) + return false; + + sym = st->n.sym; + if (sym->attr.flavor != FL_PROCEDURE + && sym->attr.flavor != FL_UNKNOWN) + return false; + + if (!sym->attr.generic + && !sym->attr.subroutine + && !sym->attr.function) + { + if (!(sym->attr.external && !sym->attr.referenced)) + { + /* ...create a symbol in this scope... */ + if (sym->ns != gfc_current_ns + && gfc_get_sym_tree (sname, NULL, &st, false) == 1) + return false; + + if (sym != st->n.sym) + sym = st->n.sym; + } + + /* ...and then to try to make the symbol into a subroutine. */ + if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) + return false; + } + + gfc_set_sym_referenced (sym); + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () != '(') + return false; + + gfc_current_ns = ns; + m = gfc_match_actual_arglist (1, &arglist); + if (m != MATCH_YES) + return false; + + if (gfc_match_char (')') != MATCH_YES) + return false; + + ns->code = gfc_get_code (EXEC_CALL); + ns->code->symtree = st; + ns->code->ext.actual = arglist; + ns->code->loc = old_loc; + return true; +} + +static bool +gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name, + gfc_typespec *ts, const char **n) +{ + if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL) + return false; + + switch (rop) + { + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_MINUS: + case OMP_REDUCTION_TIMES: + return ts->type != BT_LOGICAL; + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + return ts->type == BT_LOGICAL; + case OMP_REDUCTION_USER: + if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL)) + { + gfc_symbol *sym; + + gfc_find_symbol (name, NULL, 1, &sym); + if (sym != NULL) + { + if (sym->attr.intrinsic) + *n = sym->name; + else if ((sym->attr.flavor != FL_UNKNOWN + && sym->attr.flavor != FL_PROCEDURE) + || sym->attr.external + || sym->attr.generic + || sym->attr.entry + || sym->attr.result + || sym->attr.dummy + || sym->attr.subroutine + || sym->attr.pointer + || sym->attr.target + || sym->attr.cray_pointer + || sym->attr.cray_pointee + || (sym->attr.proc != PROC_UNKNOWN + && sym->attr.proc != PROC_INTRINSIC) + || sym->attr.if_source != IFSRC_UNKNOWN + || sym == sym->ns->proc_name) + *n = NULL; + else + *n = sym->name; + } + else + *n = name; + if (*n + && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0)) + return true; + else if (*n + && ts->type == BT_INTEGER + && (strcmp (*n, "iand") == 0 + || strcmp (*n, "ior") == 0 + || strcmp (*n, "ieor") == 0)) + return true; + } + break; + default: + break; + } + return false; +} + +gfc_omp_udr * +gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts) +{ + gfc_omp_udr *omp_udr; + + if (st == NULL) + return NULL; + + for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) + if (omp_udr->ts.type == ts->type + || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) + && (ts->type == BT_DERIVED || ts->type == BT_CLASS))) + { + if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS) + { + if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0) + return omp_udr; + } + else if (omp_udr->ts.kind == ts->kind) + { + if (omp_udr->ts.type == BT_CHARACTER) + { + if (omp_udr->ts.u.cl->length == NULL + || ts->u.cl->length == NULL) + return omp_udr; + if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) + return omp_udr; + if (ts->u.cl->length->expr_type != EXPR_CONSTANT) + return omp_udr; + if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER) + return omp_udr; + if (ts->u.cl->length->ts.type != BT_INTEGER) + return omp_udr; + if (gfc_compare_expr (omp_udr->ts.u.cl->length, + ts->u.cl->length, INTRINSIC_EQ) != 0) + continue; + } + return omp_udr; + } + } + return NULL; +} + +match +gfc_match_omp_declare_reduction (void) +{ + match m; + gfc_intrinsic_op op; + char name[GFC_MAX_SYMBOL_LEN + 3]; + auto_vec tss; + gfc_typespec ts; + unsigned int i; + gfc_symtree *st; + locus where = gfc_current_locus; + locus end_loc = gfc_current_locus; + bool end_loc_set = false; + gfc_omp_reduction_op rop = OMP_REDUCTION_NONE; + + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_ERROR; + + m = gfc_match (" %o : ", &op); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_YES) + { + snprintf (name, sizeof name, "operator %s", gfc_op2string (op)); + rop = (gfc_omp_reduction_op) op; + } + else + { + m = gfc_match_defined_op_name (name + 1, 1); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_YES) + { + name[0] = '.'; + strcat (name, "."); + if (gfc_match (" : ") != MATCH_YES) + return MATCH_ERROR; + } + else + { + if (gfc_match (" %n : ", name) != MATCH_YES) + return MATCH_ERROR; + } + rop = OMP_REDUCTION_USER; + } + + m = gfc_match_type_spec (&ts); + if (m != MATCH_YES) + return MATCH_ERROR; + /* Treat len=: the same as len=*. */ + if (ts.type == BT_CHARACTER) + ts.deferred = false; + tss.safe_push (ts); + + while (gfc_match_char (',') == MATCH_YES) + { + m = gfc_match_type_spec (&ts); + if (m != MATCH_YES) + return MATCH_ERROR; + tss.safe_push (ts); + } + if (gfc_match_char (':') != MATCH_YES) + return MATCH_ERROR; + + st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); + for (i = 0; i < tss.length (); i++) + { + gfc_symtree *omp_out, *omp_in; + gfc_symtree *omp_priv = NULL, *omp_orig = NULL; + gfc_namespace *combiner_ns, *initializer_ns = NULL; + gfc_omp_udr *prev_udr, *omp_udr; + const char *predef_name = NULL; + + omp_udr = gfc_get_omp_udr (); + omp_udr->name = gfc_get_string ("%s", name); + omp_udr->rop = rop; + omp_udr->ts = tss[i]; + omp_udr->where = where; + + gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1); + combiner_ns->proc_name = combiner_ns->parent->proc_name; + + gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false); + gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false); + combiner_ns->omp_udr_ns = 1; + omp_out->n.sym->ts = tss[i]; + omp_in->n.sym->ts = tss[i]; + omp_out->n.sym->attr.omp_udr_artificial_var = 1; + omp_in->n.sym->attr.omp_udr_artificial_var = 1; + omp_out->n.sym->attr.flavor = FL_VARIABLE; + omp_in->n.sym->attr.flavor = FL_VARIABLE; + gfc_commit_symbols (); + omp_udr->combiner_ns = combiner_ns; + omp_udr->omp_out = omp_out->n.sym; + omp_udr->omp_in = omp_in->n.sym; + + locus old_loc = gfc_current_locus; + + if (!match_udr_expr (omp_out, omp_in)) + { + syntax: + gfc_current_locus = old_loc; + gfc_current_ns = combiner_ns->parent; + gfc_undo_symbols (); + gfc_free_omp_udr (omp_udr); + return MATCH_ERROR; + } + + if (gfc_match (" initializer ( ") == MATCH_YES) + { + gfc_current_ns = combiner_ns->parent; + initializer_ns = gfc_get_namespace (gfc_current_ns, 1); + gfc_current_ns = initializer_ns; + initializer_ns->proc_name = initializer_ns->parent->proc_name; + + gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false); + gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false); + initializer_ns->omp_udr_ns = 1; + omp_priv->n.sym->ts = tss[i]; + omp_orig->n.sym->ts = tss[i]; + omp_priv->n.sym->attr.omp_udr_artificial_var = 1; + omp_orig->n.sym->attr.omp_udr_artificial_var = 1; + omp_priv->n.sym->attr.flavor = FL_VARIABLE; + omp_orig->n.sym->attr.flavor = FL_VARIABLE; + gfc_commit_symbols (); + omp_udr->initializer_ns = initializer_ns; + omp_udr->omp_priv = omp_priv->n.sym; + omp_udr->omp_orig = omp_orig->n.sym; + + if (!match_udr_expr (omp_priv, omp_orig)) + goto syntax; + } + + gfc_current_ns = combiner_ns->parent; + if (!end_loc_set) + { + end_loc_set = true; + end_loc = gfc_current_locus; + } + gfc_current_locus = old_loc; + + prev_udr = gfc_omp_udr_find (st, &tss[i]); + if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name) + /* Don't error on !$omp declare reduction (min : integer : ...) + just yet, there could be integer :: min afterwards, + making it valid. When the UDR is resolved, we'll get + to it again. */ + && (rop != OMP_REDUCTION_USER || name[0] == '.')) + { + if (predef_name) + gfc_error_now ("Redefinition of predefined %s " + "!$OMP DECLARE REDUCTION at %L", + predef_name, &where); + else + gfc_error_now ("Redefinition of predefined " + "!$OMP DECLARE REDUCTION at %L", &where); + } + else if (prev_udr) + { + gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L", + &where); + gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L", + &prev_udr->where); + } + else if (st) + { + omp_udr->next = st->n.omp_udr; + st->n.omp_udr = omp_udr; + } + else + { + st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); + st->n.omp_udr = omp_udr; + } + } + + if (end_loc_set) + { + gfc_current_locus = end_loc; + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C"); + gfc_current_locus = where; + return MATCH_ERROR; + } + + return MATCH_YES; + } + gfc_clear_error (); + return MATCH_ERROR; +} + + +match +gfc_match_omp_declare_target (void) +{ + locus old_loc; + match m; + gfc_omp_clauses *c = NULL; + int list; + gfc_omp_namelist *n; + gfc_symbol *s; + + old_loc = gfc_current_locus; + + if (gfc_current_ns->proc_name + && gfc_match_omp_eos () == MATCH_YES) + { + if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, + gfc_current_ns->proc_name->name, + &old_loc)) + goto cleanup; + return MATCH_YES; + } + + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) + { + gfc_error ("Only the !$OMP DECLARE TARGET form without " + "clauses is allowed in interface block at %C"); + goto cleanup; + } + + m = gfc_match (" ("); + if (m == MATCH_YES) + { + c = gfc_get_omp_clauses (); + gfc_current_locus = old_loc; + m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]); + if (m != MATCH_YES) + goto syntax; + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C"); + goto cleanup; + } + } + else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES) + return MATCH_ERROR; + + gfc_buffer_error (false); + + for (list = OMP_LIST_TO; list != OMP_LIST_NUM; + list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) + for (n = c->lists[list]; n; n = n->next) + if (n->sym) + n->sym->mark = 0; + else if (n->u.common->head) + n->u.common->head->mark = 0; + + for (list = OMP_LIST_TO; list != OMP_LIST_NUM; + list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) + for (n = c->lists[list]; n; n = n->next) + if (n->sym) + { + if (n->sym->attr.in_common) + gfc_error_now ("OMP DECLARE TARGET variable at %L is an " + "element of a COMMON block", &n->where); + else if (n->sym->attr.omp_declare_target + && n->sym->attr.omp_declare_target_link + && list != OMP_LIST_LINK) + gfc_error_now ("OMP DECLARE TARGET variable at %L previously " + "mentioned in LINK clause and later in TO clause", + &n->where); + else if (n->sym->attr.omp_declare_target + && !n->sym->attr.omp_declare_target_link + && list == OMP_LIST_LINK) + gfc_error_now ("OMP DECLARE TARGET variable at %L previously " + "mentioned in TO clause and later in LINK clause", + &n->where); + else if (n->sym->mark) + gfc_error_now ("Variable at %L mentioned multiple times in " + "clauses of the same OMP DECLARE TARGET directive", + &n->where); + else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, + &n->sym->declared_at)) + { + if (list == OMP_LIST_LINK) + gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, + &n->sym->declared_at); + } + if (c->device_type != OMP_DEVICE_TYPE_UNSET) + { + if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n->sym->attr.omp_device_type != c->device_type) + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " + "TARGET directive to a different DEVICE_TYPE", + n->sym->name, &n->where); + n->sym->attr.omp_device_type = c->device_type; + } + n->sym->mark = 1; + } + else if (n->u.common->omp_declare_target + && n->u.common->omp_declare_target_link + && list != OMP_LIST_LINK) + gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " + "mentioned in LINK clause and later in TO clause", + &n->where); + else if (n->u.common->omp_declare_target + && !n->u.common->omp_declare_target_link + && list == OMP_LIST_LINK) + gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " + "mentioned in TO clause and later in LINK clause", + &n->where); + else if (n->u.common->head && n->u.common->head->mark) + gfc_error_now ("COMMON at %L mentioned multiple times in " + "clauses of the same OMP DECLARE TARGET directive", + &n->where); + else + { + n->u.common->omp_declare_target = 1; + n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); + if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET + && n->u.common->omp_device_type != c->device_type) + gfc_error_now ("COMMON at %L set in previous OMP DECLARE " + "TARGET directive to a different DEVICE_TYPE", + &n->where); + n->u.common->omp_device_type = c->device_type; + + for (s = n->u.common->head; s; s = s->common_next) + { + s->mark = 1; + if (gfc_add_omp_declare_target (&s->attr, s->name, + &s->declared_at)) + { + if (list == OMP_LIST_LINK) + gfc_add_omp_declare_target_link (&s->attr, s->name, + &s->declared_at); + } + if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && s->attr.omp_device_type != c->device_type) + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" + " TARGET directive to a different DEVICE_TYPE", + s->name, &n->where); + s->attr.omp_device_type = c->device_type; + } + } + if (c->device_type && !c->lists[OMP_LIST_TO] && !c->lists[OMP_LIST_LINK]) + gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only " + "DEVICE_TYPE clause is ignored", &old_loc); + + gfc_buffer_error (true); + + if (c) + gfc_free_omp_clauses (c); + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C"); + +cleanup: + gfc_current_locus = old_loc; + if (c) + gfc_free_omp_clauses (c); + return MATCH_ERROR; +} + + +static const char *const omp_construct_selectors[] = { + "simd", "target", "teams", "parallel", "do", NULL }; +static const char *const omp_device_selectors[] = { + "kind", "isa", "arch", NULL }; +static const char *const omp_implementation_selectors[] = { + "vendor", "extension", "atomic_default_mem_order", "unified_address", + "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL }; +static const char *const omp_user_selectors[] = { + "condition", NULL }; + + +/* OpenMP 5.0: + + trait-selector: + trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])] + + trait-score: + score(score-expression) */ + +match +gfc_match_omp_context_selector (gfc_omp_set_selector *oss) +{ + do + { + char selector[GFC_MAX_SYMBOL_LEN + 1]; + + if (gfc_match_name (selector) != MATCH_YES) + { + gfc_error ("expected trait selector name at %C"); + return MATCH_ERROR; + } + + gfc_omp_selector *os = gfc_get_omp_selector (); + os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1); + strcpy (os->trait_selector_name, selector); + os->next = oss->trait_selectors; + oss->trait_selectors = os; + + const char *const *selectors = NULL; + bool allow_score = true; + bool allow_user = false; + int property_limit = 0; + enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE; + switch (oss->trait_set_selector_name[0]) + { + case 'c': /* construct */ + selectors = omp_construct_selectors; + allow_score = false; + property_limit = 1; + property_kind = CTX_PROPERTY_SIMD; + break; + case 'd': /* device */ + selectors = omp_device_selectors; + allow_score = false; + allow_user = true; + property_limit = 3; + property_kind = CTX_PROPERTY_NAME_LIST; + break; + case 'i': /* implementation */ + selectors = omp_implementation_selectors; + allow_user = true; + property_limit = 3; + property_kind = CTX_PROPERTY_NAME_LIST; + break; + case 'u': /* user */ + selectors = omp_user_selectors; + property_limit = 1; + property_kind = CTX_PROPERTY_EXPR; + break; + default: + gcc_unreachable (); + } + for (int i = 0; ; i++) + { + if (selectors[i] == NULL) + { + if (allow_user) + { + property_kind = CTX_PROPERTY_USER; + break; + } + else + { + gfc_error ("selector '%s' not allowed for context selector " + "set '%s' at %C", + selector, oss->trait_set_selector_name); + return MATCH_ERROR; + } + } + if (i == property_limit) + property_kind = CTX_PROPERTY_NONE; + if (strcmp (selectors[i], selector) == 0) + break; + } + if (property_kind == CTX_PROPERTY_NAME_LIST + && oss->trait_set_selector_name[0] == 'i' + && strcmp (selector, "atomic_default_mem_order") == 0) + property_kind = CTX_PROPERTY_ID; + + if (gfc_match (" (") == MATCH_YES) + { + if (property_kind == CTX_PROPERTY_NONE) + { + gfc_error ("selector '%s' does not accept any properties at %C", + selector); + return MATCH_ERROR; + } + + if (allow_score && gfc_match (" score") == MATCH_YES) + { + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + if (gfc_match_expr (&os->score) != MATCH_YES + || !gfc_resolve_expr (os->score) + || os->score->ts.type != BT_INTEGER + || os->score->rank != 0) + { + gfc_error ("score argument must be constant integer " + "expression at %C"); + return MATCH_ERROR; + } + + if (os->score->expr_type == EXPR_CONSTANT + && mpz_sgn (os->score->value.integer) < 0) + { + gfc_error ("score argument must be non-negative at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" :") != MATCH_YES) + { + gfc_error ("expected : at %C"); + return MATCH_ERROR; + } + } + + gfc_omp_trait_property *otp = gfc_get_omp_trait_property (); + otp->property_kind = property_kind; + otp->next = os->properties; + os->properties = otp; + + switch (property_kind) + { + case CTX_PROPERTY_USER: + do + { + if (gfc_match_expr (&otp->expr) != MATCH_YES) + { + gfc_error ("property must be constant integer " + "expression or string literal at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" ,") != MATCH_YES) + break; + } + while (1); + break; + case CTX_PROPERTY_ID: + { + char buf[GFC_MAX_SYMBOL_LEN + 1]; + if (gfc_match_name (buf) == MATCH_YES) + { + otp->name = XNEWVEC (char, strlen (buf) + 1); + strcpy (otp->name, buf); + } + else + { + gfc_error ("expected identifier at %C"); + return MATCH_ERROR; + } + } + break; + case CTX_PROPERTY_NAME_LIST: + do + { + char buf[GFC_MAX_SYMBOL_LEN + 1]; + if (gfc_match_name (buf) == MATCH_YES) + { + otp->name = XNEWVEC (char, strlen (buf) + 1); + strcpy (otp->name, buf); + otp->is_name = true; + } + else if (gfc_match_literal_constant (&otp->expr, 0) + != MATCH_YES + || otp->expr->ts.type != BT_CHARACTER) + { + gfc_error ("expected identifier or string literal " + "at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" ,") == MATCH_YES) + { + otp = gfc_get_omp_trait_property (); + otp->property_kind = property_kind; + otp->next = os->properties; + os->properties = otp; + } + else + break; + } + while (1); + break; + case CTX_PROPERTY_EXPR: + if (gfc_match_expr (&otp->expr) != MATCH_YES) + { + gfc_error ("expected expression at %C"); + return MATCH_ERROR; + } + if (!gfc_resolve_expr (otp->expr) + || (otp->expr->ts.type != BT_LOGICAL + && otp->expr->ts.type != BT_INTEGER) + || otp->expr->rank != 0) + { + gfc_error ("property must be constant integer or logical " + "expression at %C"); + return MATCH_ERROR; + } + break; + case CTX_PROPERTY_SIMD: + { + if (gfc_match_omp_clauses (&otp->clauses, + OMP_DECLARE_SIMD_CLAUSES, + true, false, false, true) + != MATCH_YES) + { + gfc_error ("expected simd clause at %C"); + return MATCH_ERROR; + } + break; + } + default: + gcc_unreachable (); + } + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + } + else if (property_kind == CTX_PROPERTY_NAME_LIST + || property_kind == CTX_PROPERTY_ID + || property_kind == CTX_PROPERTY_EXPR) + { + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + } + + if (gfc_match (" ,") != MATCH_YES) + break; + } + while (1); + + return MATCH_YES; +} + +/* OpenMP 5.0: + + trait-set-selector[,trait-set-selector[,...]] + + trait-set-selector: + trait-set-selector-name = { trait-selector[, trait-selector[, ...]] } + + trait-set-selector-name: + constructor + device + implementation + user */ + +match +gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) +{ + do + { + match m; + const char *selector_sets[] = { "construct", "device", + "implementation", "user" }; + const int selector_set_count + = sizeof (selector_sets) / sizeof (*selector_sets); + int i; + char buf[GFC_MAX_SYMBOL_LEN + 1]; + + m = gfc_match_name (buf); + if (m == MATCH_YES) + for (i = 0; i < selector_set_count; i++) + if (strcmp (buf, selector_sets[i]) == 0) + break; + + if (m != MATCH_YES || i == selector_set_count) + { + gfc_error ("expected 'construct', 'device', 'implementation' or " + "'user' at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" ="); + if (m != MATCH_YES) + { + gfc_error ("expected '=' at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" {"); + if (m != MATCH_YES) + { + gfc_error ("expected '{' at %C"); + return MATCH_ERROR; + } + + gfc_omp_set_selector *oss = gfc_get_omp_set_selector (); + oss->next = odv->set_selectors; + oss->trait_set_selector_name = selector_sets[i]; + odv->set_selectors = oss; + + if (gfc_match_omp_context_selector (oss) != MATCH_YES) + return MATCH_ERROR; + + m = gfc_match (" }"); + if (m != MATCH_YES) + { + gfc_error ("expected '}' at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" ,"); + if (m != MATCH_YES) + break; + } + while (1); + + return MATCH_YES; +} + + +match +gfc_match_omp_declare_variant (void) +{ + bool first_p = true; + char buf[GFC_MAX_SYMBOL_LEN + 1]; + + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + + gfc_symtree *base_proc_st, *variant_proc_st; + if (gfc_match_name (buf) != MATCH_YES) + { + gfc_error ("expected name at %C"); + return MATCH_ERROR; + } + + if (gfc_get_ha_sym_tree (buf, &base_proc_st)) + return MATCH_ERROR; + + if (gfc_match (" :") == MATCH_YES) + { + if (gfc_match_name (buf) != MATCH_YES) + { + gfc_error ("expected variant name at %C"); + return MATCH_ERROR; + } + + if (gfc_get_ha_sym_tree (buf, &variant_proc_st)) + return MATCH_ERROR; + } + else + { + /* Base procedure not specified. */ + variant_proc_st = base_proc_st; + base_proc_st = NULL; + } + + gfc_omp_declare_variant *odv; + odv = gfc_get_omp_declare_variant (); + odv->where = gfc_current_locus; + odv->variant_proc_symtree = variant_proc_st; + odv->base_proc_symtree = base_proc_st; + odv->next = NULL; + odv->error_p = false; + + /* Add the new declare variant to the end of the list. */ + gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant; + while (*prev_next) + prev_next = &((*prev_next)->next); + *prev_next = odv; + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + + for (;;) + { + if (gfc_match (" match") != MATCH_YES) + { + if (first_p) + { + gfc_error ("expected 'match' at %C"); + return MATCH_ERROR; + } + else + break; + } + + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + + if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + + first_p = false; + } + + return MATCH_YES; +} + + +match +gfc_match_omp_threadprivate (void) +{ + locus old_loc; + char n[GFC_MAX_SYMBOL_LEN+1]; + gfc_symbol *sym; + match m; + gfc_symtree *st; + + old_loc = gfc_current_locus; + + m = gfc_match (" ("); + if (m != MATCH_YES) + return m; + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (sym->attr.in_common) + gfc_error_now ("Threadprivate variable at %C is an element of " + "a COMMON block"); + else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + goto cleanup; + goto next_item; + case MATCH_NO: + break; + case MATCH_ERROR: + goto cleanup; + } + + m = gfc_match (" / %n /", n); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO || n[0] == '\0') + goto syntax; + + st = gfc_find_symtree (gfc_current_ns->common_root, n); + if (st == NULL) + { + gfc_error ("COMMON block /%s/ not found at %C", n); + goto cleanup; + } + st->n.common->threadprivate = 1; + for (sym = st->n.common->head; sym; sym = sym->common_next) + if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + goto cleanup; + + next_item: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C"); + goto cleanup; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); + +cleanup: + gfc_current_locus = old_loc; + return MATCH_ERROR; +} + + +match +gfc_match_omp_parallel (void) +{ + return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); +} + + +match +gfc_match_omp_parallel_do (void) +{ + return match_omp (EXEC_OMP_PARALLEL_DO, + OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES); +} + + +match +gfc_match_omp_parallel_do_simd (void) +{ + return match_omp (EXEC_OMP_PARALLEL_DO_SIMD, + OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_parallel_masked (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASKED, + OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES); +} + +match +gfc_match_omp_parallel_masked_taskloop (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP, + (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES + | OMP_TASKLOOP_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match +gfc_match_omp_parallel_masked_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, + (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES + | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match +gfc_match_omp_parallel_master (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES); +} + +match +gfc_match_omp_parallel_master_taskloop (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP, + (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match +gfc_match_omp_parallel_master_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD, + (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES + | OMP_SIMD_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION))); +} + +match +gfc_match_omp_parallel_sections (void) +{ + return match_omp (EXEC_OMP_PARALLEL_SECTIONS, + OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES); +} + + +match +gfc_match_omp_parallel_workshare (void) +{ + return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES); +} + +void +gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires) +{ + if (ns->omp_target_seen + && (ns->omp_requires & OMP_REQ_TARGET_MASK) + != (ref_omp_requires & OMP_REQ_TARGET_MASK)) + { + gcc_assert (ns->proc_name); + if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD) + && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) + gfc_error ("Program unit at %L has OpenMP device constructs/routines " + "but does not set !$OMP REQUIRES REVERSE_OFFSET but other " + "program units do", &ns->proc_name->declared_at); + if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS) + && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS)) + gfc_error ("Program unit at %L has OpenMP device constructs/routines " + "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other " + "program units do", &ns->proc_name->declared_at); + if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) + && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)) + gfc_error ("Program unit at %L has OpenMP device constructs/routines " + "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but " + "other program units do", &ns->proc_name->declared_at); + } +} + +bool +gfc_omp_requires_add_clause (gfc_omp_requires_kind clause, + const char *clause_name, locus *loc, + const char *module_name) +{ + gfc_namespace *prog_unit = gfc_current_ns; + while (prog_unit->parent) + { + if (gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_INTERFACE) + break; + prog_unit = prog_unit->parent; + } + + /* Requires added after use. */ + if (prog_unit->omp_target_seen + && (clause & OMP_REQ_TARGET_MASK) + && !(prog_unit->omp_requires & clause)) + { + if (module_name) + gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use " + "at %L comes after using a device construct/routine", + clause_name, module_name, loc); + else + gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after " + "using a device construct/routine", clause_name, loc); + return false; + } + + /* Overriding atomic_default_mem_order clause value. */ + if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + != (int) clause) + { + const char *other; + if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) + other = "seq_cst"; + else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) + other = "acq_rel"; + else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) + other = "relaxed"; + else + gcc_unreachable (); + + if (module_name) + gfc_error ("!$OMP REQUIRES clause % " + "specified via module %qs use at %L overrides a previous " + "% (which might be through " + "using a module)", clause_name, module_name, loc, other); + else + gfc_error ("!$OMP REQUIRES clause % " + "specified at %L overrides a previous " + "% (which might be through " + "using a module)", clause_name, loc, other); + return false; + } + + /* Requires via module not at program-unit level and not repeating clause. */ + if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause)) + { + if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + gfc_error ("!$OMP REQUIRES clause % " + "specified via module %qs use at %L but same clause is " + "not specified for the program unit", clause_name, + module_name, loc); + else + gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at " + "%L but same clause is not specified for the program unit", + clause_name, module_name, loc); + return false; + } + + if (!gfc_state_stack->previous + || gfc_state_stack->previous->state != COMP_INTERFACE) + prog_unit->omp_requires |= clause; + return true; +} + +match +gfc_match_omp_requires (void) +{ + static const char *clauses[] = {"reverse_offload", + "unified_address", + "unified_shared_memory", + "dynamic_allocators", + "atomic_default"}; + const char *clause = NULL; + int requires_clauses = 0; + bool first = true; + locus old_loc; + + if (gfc_current_ns->parent + && (!gfc_state_stack->previous + || gfc_state_stack->previous->state != COMP_INTERFACE)) + { + gfc_error ("!$OMP REQUIRES at %C must appear in the specification part " + "of a program unit"); + return MATCH_ERROR; + } + + while (true) + { + old_loc = gfc_current_locus; + gfc_omp_requires_kind requires_clause; + if ((first || gfc_match_char (',') != MATCH_YES) + && (first && gfc_match_space () != MATCH_YES)) + goto error; + first = false; + gfc_gobble_whitespace (); + old_loc = gfc_current_locus; + + if (gfc_match_omp_eos () != MATCH_NO) + break; + if (gfc_match (clauses[0]) == MATCH_YES) + { + clause = clauses[0]; + requires_clause = OMP_REQ_REVERSE_OFFLOAD; + if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD) + goto duplicate_clause; + } + else if (gfc_match (clauses[1]) == MATCH_YES) + { + clause = clauses[1]; + requires_clause = OMP_REQ_UNIFIED_ADDRESS; + if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS) + goto duplicate_clause; + } + else if (gfc_match (clauses[2]) == MATCH_YES) + { + clause = clauses[2]; + requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY; + if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY) + goto duplicate_clause; + } + else if (gfc_match (clauses[3]) == MATCH_YES) + { + clause = clauses[3]; + requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS; + if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS) + goto duplicate_clause; + } + else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES) + { + clause = clauses[4]; + if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + goto duplicate_clause; + if (gfc_match (" seq_cst )") == MATCH_YES) + { + clause = "seq_cst"; + requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST; + } + else if (gfc_match (" acq_rel )") == MATCH_YES) + { + clause = "acq_rel"; + requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL; + } + else if (gfc_match (" relaxed )") == MATCH_YES) + { + clause = "relaxed"; + requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED; + } + else + { + gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for " + "ATOMIC_DEFAULT_MEM_ORDER clause at %C"); + goto error; + } + } + else + goto error; + + if (requires_clause & ~(OMP_REQ_ATOMIC_MEM_ORDER_MASK + | OMP_REQ_DYNAMIC_ALLOCATORS)) + gfc_error_now ("Sorry, %qs clause at %L on REQUIRES directive is not " + "yet supported", clause, &old_loc); + if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL)) + goto error; + requires_clauses |= requires_clause; + } + + if (requires_clauses == 0) + { + if (!gfc_error_flag_test ()) + gfc_error ("Clause expected at %C"); + goto error; + } + return MATCH_YES; + +duplicate_clause: + gfc_error ("%qs clause at %L specified more than once", clause, &old_loc); +error: + if (!gfc_error_flag_test ()) + gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, " + "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or " + "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc); + return MATCH_ERROR; +} + + +match +gfc_match_omp_scan (void) +{ + bool incl; + gfc_omp_clauses *c = gfc_get_omp_clauses (); + gfc_gobble_whitespace (); + if ((incl = (gfc_match ("inclusive") == MATCH_YES)) + || gfc_match ("exclusive") == MATCH_YES) + { + if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN + : OMP_LIST_SCAN_EX], + false) != MATCH_YES) + { + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + } + else + { + gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C"); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after !$OMP SCAN at %C"); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + + new_st.op = EXEC_OMP_SCAN; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_omp_scope (void) +{ + return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES); +} + + +match +gfc_match_omp_sections (void) +{ + return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES); +} + + +match +gfc_match_omp_simd (void) +{ + return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_single (void) +{ + return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES); +} + + +match +gfc_match_omp_target (void) +{ + return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES); +} + + +match +gfc_match_omp_target_data (void) +{ + return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES); +} + + +match +gfc_match_omp_target_enter_data (void) +{ + return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES); +} + + +match +gfc_match_omp_target_exit_data (void) +{ + return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES); +} + + +match +gfc_match_omp_target_parallel (void) +{ + return match_omp (EXEC_OMP_TARGET_PARALLEL, + (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_COPYIN))); +} + + +match +gfc_match_omp_target_parallel_do (void) +{ + return match_omp (EXEC_OMP_TARGET_PARALLEL_DO, + (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES + | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); +} + + +match +gfc_match_omp_target_parallel_do_simd (void) +{ + return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD, + (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES + | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN))); +} + + +match +gfc_match_omp_target_simd (void) +{ + return match_omp (EXEC_OMP_TARGET_SIMD, + OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_target_teams (void) +{ + return match_omp (EXEC_OMP_TARGET_TEAMS, + OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES); +} + + +match +gfc_match_omp_target_teams_distribute (void) +{ + return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE, + OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES + | OMP_DISTRIBUTE_CLAUSES); +} + + +match +gfc_match_omp_target_teams_distribute_parallel_do (void) +{ + return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO, + (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES + | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES + | OMP_DO_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_ORDERED)) + & ~(omp_mask (OMP_CLAUSE_LINEAR))); +} + + +match +gfc_match_omp_target_teams_distribute_parallel_do_simd (void) +{ + return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES + | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES + | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_ORDERED))); +} + + +match +gfc_match_omp_target_teams_distribute_simd (void) +{ + return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD, + OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES + | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_target_update (void) +{ + return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES); +} + + +match +gfc_match_omp_task (void) +{ + return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES); +} + + +match +gfc_match_omp_taskloop (void) +{ + return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES); +} + + +match +gfc_match_omp_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_TASKLOOP_SIMD, + OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_taskwait (void) +{ + if (gfc_match_omp_eos () == MATCH_YES) + { + new_st.op = EXEC_OMP_TASKWAIT; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; + } + return match_omp (EXEC_OMP_TASKWAIT, omp_mask (OMP_CLAUSE_DEPEND)); +} + + +match +gfc_match_omp_taskyield (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after TASKYIELD clause at %C"); + return MATCH_ERROR; + } + new_st.op = EXEC_OMP_TASKYIELD; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; +} + + +match +gfc_match_omp_teams (void) +{ + return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES); +} + + +match +gfc_match_omp_teams_distribute (void) +{ + return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE, + OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES); +} + + +match +gfc_match_omp_teams_distribute_parallel_do (void) +{ + return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO, + (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES + | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES) + & ~(omp_mask (OMP_CLAUSE_ORDERED)) + & ~(omp_mask (OMP_CLAUSE_LINEAR))); +} + + +match +gfc_match_omp_teams_distribute_parallel_do_simd (void) +{ + return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD, + (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES + | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES + | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED))); +} + + +match +gfc_match_omp_teams_distribute_simd (void) +{ + return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD, + OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES + | OMP_SIMD_CLAUSES); +} + + +match +gfc_match_omp_workshare (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C"); + return MATCH_ERROR; + } + new_st.op = EXEC_OMP_WORKSHARE; + new_st.ext.omp_clauses = gfc_get_omp_clauses (); + return MATCH_YES; +} + + +match +gfc_match_omp_masked (void) +{ + return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES); +} + +match +gfc_match_omp_masked_taskloop (void) +{ + return match_omp (EXEC_OMP_MASKED_TASKLOOP, + OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES); +} + +match +gfc_match_omp_masked_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD, + (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES + | OMP_SIMD_CLAUSES)); +} + +match +gfc_match_omp_master (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP MASTER statement at %C"); + return MATCH_ERROR; + } + new_st.op = EXEC_OMP_MASTER; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; +} + +match +gfc_match_omp_master_taskloop (void) +{ + return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES); +} + +match +gfc_match_omp_master_taskloop_simd (void) +{ + return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD, + OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES); +} + +match +gfc_match_omp_ordered (void) +{ + return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES); +} + +match +gfc_match_omp_nothing (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP NOTHING statement at %C"); + return MATCH_ERROR; + } + /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */ + return MATCH_YES; +} + +match +gfc_match_omp_ordered_depend (void) +{ + return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND)); +} + + +/* omp atomic [clause-list] + - atomic-clause: read | write | update + - capture + - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed + - hint(hint-expr) + - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak +*/ + +match +gfc_match_omp_atomic (void) +{ + gfc_omp_clauses *c; + locus loc = gfc_current_locus; + + if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES) + return MATCH_ERROR; + + if (c->atomic_op == GFC_OMP_ATOMIC_UNSET) + c->atomic_op = GFC_OMP_ATOMIC_UPDATE; + + if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) + gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " + "READ or WRITE", &loc, "CAPTURE"); + if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) + gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " + "READ or WRITE", &loc, "COMPARE"); + if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) + gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " + "READ or WRITE", &loc, "FAIL"); + if (c->weak && !c->compare) + { + gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc, + "WEAK", "COMPARE"); + c->weak = false; + } + + if (c->memorder == OMP_MEMORDER_UNSET) + { + gfc_namespace *prog_unit = gfc_current_ns; + while (prog_unit->parent) + prog_unit = prog_unit->parent; + switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + { + case 0: + case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: + c->memorder = OMP_MEMORDER_RELAXED; + break; + case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: + c->memorder = OMP_MEMORDER_SEQ_CST; + break; + case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: + if (c->capture) + c->memorder = OMP_MEMORDER_ACQ_REL; + else if (c->atomic_op == GFC_OMP_ATOMIC_READ) + c->memorder = OMP_MEMORDER_ACQUIRE; + else + c->memorder = OMP_MEMORDER_RELEASE; + break; + default: + gcc_unreachable (); + } + } + else + switch (c->atomic_op) + { + case GFC_OMP_ATOMIC_READ: + if (c->memorder == OMP_MEMORDER_RELEASE) + { + gfc_error ("!$OMP ATOMIC READ at %L incompatible with " + "RELEASE clause", &loc); + c->memorder = OMP_MEMORDER_SEQ_CST; + } + else if (c->memorder == OMP_MEMORDER_ACQ_REL) + c->memorder = OMP_MEMORDER_ACQUIRE; + break; + case GFC_OMP_ATOMIC_WRITE: + if (c->memorder == OMP_MEMORDER_ACQUIRE) + { + gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with " + "ACQUIRE clause", &loc); + c->memorder = OMP_MEMORDER_SEQ_CST; + } + else if (c->memorder == OMP_MEMORDER_ACQ_REL) + c->memorder = OMP_MEMORDER_RELEASE; + break; + default: + break; + } + gfc_error_check (); + new_st.ext.omp_clauses = c; + new_st.op = EXEC_OMP_ATOMIC; + return MATCH_YES; +} + + +/* acc atomic [ read | write | update | capture] */ + +match +gfc_match_oacc_atomic (void) +{ + gfc_omp_clauses *c = gfc_get_omp_clauses (); + c->atomic_op = GFC_OMP_ATOMIC_UPDATE; + c->memorder = OMP_MEMORDER_RELAXED; + gfc_gobble_whitespace (); + if (gfc_match ("update") == MATCH_YES) + ; + else if (gfc_match ("read") == MATCH_YES) + c->atomic_op = GFC_OMP_ATOMIC_READ; + else if (gfc_match ("write") == MATCH_YES) + c->atomic_op = GFC_OMP_ATOMIC_WRITE; + else if (gfc_match ("capture") == MATCH_YES) + c->capture = true; + gfc_gobble_whitespace (); + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C"); + gfc_free_omp_clauses (c); + return MATCH_ERROR; + } + new_st.ext.omp_clauses = c; + new_st.op = EXEC_OACC_ATOMIC; + return MATCH_YES; +} + + +match +gfc_match_omp_barrier (void) +{ + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP BARRIER statement at %C"); + return MATCH_ERROR; + } + new_st.op = EXEC_OMP_BARRIER; + new_st.ext.omp_clauses = NULL; + return MATCH_YES; +} + + +match +gfc_match_omp_taskgroup (void) +{ + return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES); +} + + +static enum gfc_omp_cancel_kind +gfc_match_omp_cancel_kind (void) +{ + if (gfc_match_space () != MATCH_YES) + return OMP_CANCEL_UNKNOWN; + if (gfc_match ("parallel") == MATCH_YES) + return OMP_CANCEL_PARALLEL; + if (gfc_match ("sections") == MATCH_YES) + return OMP_CANCEL_SECTIONS; + if (gfc_match ("do") == MATCH_YES) + return OMP_CANCEL_DO; + if (gfc_match ("taskgroup") == MATCH_YES) + return OMP_CANCEL_TASKGROUP; + return OMP_CANCEL_UNKNOWN; +} + + +match +gfc_match_omp_cancel (void) +{ + gfc_omp_clauses *c; + enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); + if (kind == OMP_CANCEL_UNKNOWN) + return MATCH_ERROR; + if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES) + return MATCH_ERROR; + c->cancel = kind; + new_st.op = EXEC_OMP_CANCEL; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_omp_cancellation_point (void) +{ + gfc_omp_clauses *c; + enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind (); + if (kind == OMP_CANCEL_UNKNOWN) + { + gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP " + "in $OMP CANCELLATION POINT statement at %C"); + return MATCH_ERROR; + } + if (gfc_match_omp_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement " + "at %C"); + return MATCH_ERROR; + } + c = gfc_get_omp_clauses (); + c->cancel = kind; + new_st.op = EXEC_OMP_CANCELLATION_POINT; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +match +gfc_match_omp_end_nowait (void) +{ + bool nowait = false; + if (gfc_match ("% nowait") == MATCH_YES) + nowait = true; + if (gfc_match_omp_eos () != MATCH_YES) + { + if (nowait) + gfc_error ("Unexpected junk after NOWAIT clause at %C"); + else + gfc_error ("Unexpected junk at %C"); + return MATCH_ERROR; + } + new_st.op = EXEC_OMP_END_NOWAIT; + new_st.ext.omp_bool = nowait; + return MATCH_YES; +} + + +match +gfc_match_omp_end_single (void) +{ + gfc_omp_clauses *c; + if (gfc_match ("% nowait") == MATCH_YES) + { + new_st.op = EXEC_OMP_END_NOWAIT; + new_st.ext.omp_bool = true; + return MATCH_YES; + } + if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)) + != MATCH_YES) + return MATCH_ERROR; + new_st.op = EXEC_OMP_END_SINGLE; + new_st.ext.omp_clauses = c; + return MATCH_YES; +} + + +static bool +oacc_is_loop (gfc_code *code) +{ + return code->op == EXEC_OACC_PARALLEL_LOOP + || code->op == EXEC_OACC_KERNELS_LOOP + || code->op == EXEC_OACC_SERIAL_LOOP + || code->op == EXEC_OACC_LOOP; +} + +static void +resolve_scalar_int_expr (gfc_expr *expr, const char *clause) +{ + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_INTEGER + || expr->rank != 0) + gfc_error ("%s clause at %L requires a scalar INTEGER expression", + clause, &expr->where); +} + +static void +resolve_positive_int_expr (gfc_expr *expr, const char *clause) +{ + resolve_scalar_int_expr (expr, clause); + if (expr->expr_type == EXPR_CONSTANT + && expr->ts.type == BT_INTEGER + && mpz_sgn (expr->value.integer) <= 0) + gfc_warning (0, "INTEGER expression of %s clause at %L must be positive", + clause, &expr->where); +} + +static void +resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause) +{ + resolve_scalar_int_expr (expr, clause); + if (expr->expr_type == EXPR_CONSTANT + && expr->ts.type == BT_INTEGER + && mpz_sgn (expr->value.integer) < 0) + gfc_warning (0, "INTEGER expression of %s clause at %L must be " + "non-negative", clause, &expr->where); +} + +/* Emits error when symbol is pointer, cray pointer or cray pointee + of derived of polymorphic type. */ + +static void +check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name) +{ + if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer) + gfc_error ("Cray pointer object %qs of derived type in %s clause at %L", + sym->name, name, &loc); + if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee) + gfc_error ("Cray pointee object %qs of derived type in %s clause at %L", + sym->name, name, &loc); + + if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.pointer)) + gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L", + sym->name, name, &loc); + if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.cray_pointer)) + gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L", + sym->name, name, &loc); + if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.cray_pointee)) + gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L", + sym->name, name, &loc); +} + +/* Emits error when symbol represents assumed size/rank array. */ + +static void +check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name) +{ + if (sym->as && sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array %qs in %s clause at %L", + sym->name, name, &loc); + if (sym->as && sym->as->type == AS_ASSUMED_RANK) + gfc_error ("Assumed rank array %qs in %s clause at %L", + sym->name, name, &loc); +} + +static void +resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name) +{ + check_array_not_assumed (sym, loc, name); +} + +static void +resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name) +{ + if (sym->attr.pointer + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.class_pointer)) + gfc_error ("POINTER object %qs in %s clause at %L", + sym->name, name, &loc); + if (sym->attr.cray_pointer + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.cray_pointer)) + gfc_error ("Cray pointer object %qs in %s clause at %L", + sym->name, name, &loc); + if (sym->attr.cray_pointee + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.cray_pointee)) + gfc_error ("Cray pointee object %qs in %s clause at %L", + sym->name, name, &loc); + if (sym->attr.allocatable + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.allocatable)) + gfc_error ("ALLOCATABLE object %qs in %s clause at %L", + sym->name, name, &loc); + if (sym->attr.value) + gfc_error ("VALUE object %qs in %s clause at %L", + sym->name, name, &loc); + check_array_not_assumed (sym, loc, name); +} + + +struct resolve_omp_udr_callback_data +{ + gfc_symbol *sym1, *sym2; +}; + + +static int +resolve_omp_udr_callback (gfc_expr **e, int *, void *data) +{ + struct resolve_omp_udr_callback_data *rcd + = (struct resolve_omp_udr_callback_data *) data; + if ((*e)->expr_type == EXPR_VARIABLE + && ((*e)->symtree->n.sym == rcd->sym1 + || (*e)->symtree->n.sym == rcd->sym2)) + { + gfc_ref *ref = gfc_get_ref (); + ref->type = REF_ARRAY; + ref->u.ar.where = (*e)->where; + ref->u.ar.as = (*e)->symtree->n.sym->as; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = 0; + ref->next = (*e)->ref; + (*e)->ref = ref; + } + return 0; +} + + +static int +resolve_omp_udr_callback2 (gfc_expr **e, int *, void *) +{ + if ((*e)->expr_type == EXPR_FUNCTION + && (*e)->value.function.isym == NULL) + { + gfc_symbol *sym = (*e)->symtree->n.sym; + if (!sym->attr.intrinsic + && sym->attr.if_source == IFSRC_UNKNOWN) + gfc_error ("Implicitly declared function %s used in " + "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where); + } + return 0; +} + + +static gfc_code * +resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, + gfc_symbol *sym1, gfc_symbol *sym2) +{ + gfc_code *copy; + gfc_symbol sym1_copy, sym2_copy; + + if (ns->code->op == EXEC_ASSIGN) + { + copy = gfc_get_code (EXEC_ASSIGN); + copy->expr1 = gfc_copy_expr (ns->code->expr1); + copy->expr2 = gfc_copy_expr (ns->code->expr2); + } + else + { + copy = gfc_get_code (EXEC_CALL); + copy->symtree = ns->code->symtree; + copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual); + } + copy->loc = ns->code->loc; + sym1_copy = *sym1; + sym2_copy = *sym2; + *sym1 = *n->sym; + *sym2 = *n->sym; + sym1->name = sym1_copy.name; + sym2->name = sym2_copy.name; + ns->proc_name = ns->parent->proc_name; + if (n->sym->attr.dimension) + { + struct resolve_omp_udr_callback_data rcd; + rcd.sym1 = sym1; + rcd.sym2 = sym2; + gfc_code_walker (©, gfc_dummy_code_callback, + resolve_omp_udr_callback, &rcd); + } + gfc_resolve_code (copy, gfc_current_ns); + if (copy->op == EXEC_CALL && copy->resolved_isym == NULL) + { + gfc_symbol *sym = copy->resolved_sym; + if (sym + && !sym->attr.intrinsic + && sym->attr.if_source == IFSRC_UNKNOWN) + gfc_error ("Implicitly declared subroutine %s used in " + "!$OMP DECLARE REDUCTION at %L", sym->name, + ©->loc); + } + gfc_code_walker (©, gfc_dummy_code_callback, + resolve_omp_udr_callback2, NULL); + *sym1 = sym1_copy; + *sym2 = sym2_copy; + return copy; +} + +/* OpenMP directive resolving routines. */ + +static void +resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, + gfc_namespace *ns, bool openacc = false) +{ + gfc_omp_namelist *n; + gfc_expr_list *el; + int list; + int ifc; + bool if_without_mod = false; + gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; + static const char *clause_names[] + = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", + "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP", + "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", + "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, + "IN_REDUCTION", "TASK_REDUCTION", + "DEVICE_RESIDENT", "LINK", "USE_DEVICE", + "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", + "NONTEMPORAL", "ALLOCATE" }; + STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); + + if (omp_clauses == NULL) + return; + + if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) + gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L", + &code->loc); + if (omp_clauses->order_concurrent && omp_clauses->ordered) + gfc_error ("ORDER clause must not be used together ORDERED at %L", + &code->loc); + if (omp_clauses->if_expr) + { + gfc_expr *expr = omp_clauses->if_expr; + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_LOGICAL || expr->rank != 0) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &expr->where); + if_without_mod = true; + } + for (ifc = 0; ifc < OMP_IF_LAST; ifc++) + if (omp_clauses->if_exprs[ifc]) + { + gfc_expr *expr = omp_clauses->if_exprs[ifc]; + bool ok = true; + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_LOGICAL || expr->rank != 0) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &expr->where); + else if (if_without_mod) + { + gfc_error ("IF clause without modifier at %L used together with " + "IF clauses with modifiers", + &omp_clauses->if_expr->where); + if_without_mod = false; + } + else + switch (code->op) + { + case EXEC_OMP_CANCEL: + ok = ifc == OMP_IF_CANCEL; + break; + + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + ok = ifc == OMP_IF_PARALLEL; + break; + + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD; + break; + + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP; + break; + + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + ok = (ifc == OMP_IF_PARALLEL + || ifc == OMP_IF_TASKLOOP + || ifc == OMP_IF_SIMD); + break; + + case EXEC_OMP_SIMD: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + ok = ifc == OMP_IF_SIMD; + break; + + case EXEC_OMP_TASK: + ok = ifc == OMP_IF_TASK; + break; + + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP: + ok = ifc == OMP_IF_TASKLOOP; + break; + + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD; + break; + + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_LOOP: + ok = ifc == OMP_IF_TARGET; + break; + + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_SIMD: + ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD; + break; + + case EXEC_OMP_TARGET_DATA: + ok = ifc == OMP_IF_TARGET_DATA; + break; + + case EXEC_OMP_TARGET_UPDATE: + ok = ifc == OMP_IF_TARGET_UPDATE; + break; + + case EXEC_OMP_TARGET_ENTER_DATA: + ok = ifc == OMP_IF_TARGET_ENTER_DATA; + break; + + case EXEC_OMP_TARGET_EXIT_DATA: + ok = ifc == OMP_IF_TARGET_EXIT_DATA; + break; + + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL; + break; + + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + ok = (ifc == OMP_IF_TARGET + || ifc == OMP_IF_PARALLEL + || ifc == OMP_IF_SIMD); + break; + + default: + ok = false; + break; + } + if (!ok) + { + static const char *ifs[] = { + "CANCEL", + "PARALLEL", + "SIMD", + "TASK", + "TASKLOOP", + "TARGET", + "TARGET DATA", + "TARGET UPDATE", + "TARGET ENTER DATA", + "TARGET EXIT DATA" + }; + gfc_error ("IF clause modifier %s at %L not appropriate for " + "the current OpenMP construct", ifs[ifc], &expr->where); + } + } + + if (omp_clauses->final_expr) + { + gfc_expr *expr = omp_clauses->final_expr; + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_LOGICAL || expr->rank != 0) + gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression", + &expr->where); + } + if (omp_clauses->num_threads) + resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); + if (omp_clauses->chunk_size) + { + gfc_expr *expr = omp_clauses->chunk_size; + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_INTEGER || expr->rank != 0) + gfc_error ("SCHEDULE clause's chunk_size at %L requires " + "a scalar INTEGER expression", &expr->where); + else if (expr->expr_type == EXPR_CONSTANT + && expr->ts.type == BT_INTEGER + && mpz_sgn (expr->value.integer) <= 0) + gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size " + "at %L must be positive", &expr->where); + } + if (omp_clauses->sched_kind != OMP_SCHED_NONE + && omp_clauses->sched_nonmonotonic) + { + if (omp_clauses->sched_monotonic) + gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers " + "specified at %L", &code->loc); + else if (omp_clauses->ordered) + gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED " + "clause at %L", &code->loc); + } + + if (omp_clauses->depobj + && (!gfc_resolve_expr (omp_clauses->depobj) + || omp_clauses->depobj->ts.type != BT_INTEGER + || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind + || omp_clauses->depobj->rank != 0)) + gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer " + "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where); + + /* Check that no symbol appears on multiple clauses, except that + a symbol can appear on both firstprivate and lastprivate. */ + for (list = 0; list < OMP_LIST_NUM; list++) + for (n = omp_clauses->lists[list]; n; n = n->next) + { + n->sym->mark = 0; + n->sym->comp_mark = 0; + if (n->sym->attr.flavor == FL_VARIABLE + || n->sym->attr.proc_pointer + || (!code && (!n->sym->attr.dummy || n->sym->ns != ns))) + { + if (!code && (!n->sym->attr.dummy || n->sym->ns != ns)) + gfc_error ("Variable %qs is not a dummy argument at %L", + n->sym->name, &n->where); + continue; + } + if (n->sym->attr.flavor == FL_PROCEDURE + && n->sym->result == n->sym + && n->sym->attr.function) + { + if (gfc_current_ns->proc_name == n->sym + || (gfc_current_ns->parent + && gfc_current_ns->parent->proc_name == n->sym)) + continue; + if (gfc_current_ns->proc_name->attr.entry_master) + { + gfc_entry_list *el = gfc_current_ns->entries; + for (; el; el = el->next) + if (el->sym == n->sym) + break; + if (el) + continue; + } + if (gfc_current_ns->parent + && gfc_current_ns->parent->proc_name->attr.entry_master) + { + gfc_entry_list *el = gfc_current_ns->parent->entries; + for (; el; el = el->next) + if (el->sym == n->sym) + break; + if (el) + continue; + } + } + if (list == OMP_LIST_MAP + && n->sym->attr.flavor == FL_PARAMETER) + { + if (openacc) + gfc_error ("Object %qs is not a variable at %L; parameters" + " cannot be and need not be copied", n->sym->name, + &n->where); + else + gfc_error ("Object %qs is not a variable at %L; parameters" + " cannot be and need not be mapped", n->sym->name, + &n->where); + } + else + gfc_error ("Object %qs is not a variable at %L", n->sym->name, + &n->where); + } + if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN] + && code->op != EXEC_OMP_DO + && code->op != EXEC_OMP_SIMD + && code->op != EXEC_OMP_DO_SIMD + && code->op != EXEC_OMP_PARALLEL_DO + && code->op != EXEC_OMP_PARALLEL_DO_SIMD) + gfc_error ("% REDUCTION clause on construct other than DO, SIMD, " + "DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L", + &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where); + + for (list = 0; list < OMP_LIST_NUM; list++) + if (list != OMP_LIST_FIRSTPRIVATE + && list != OMP_LIST_LASTPRIVATE + && list != OMP_LIST_ALIGNED + && list != OMP_LIST_DEPEND + && (list != OMP_LIST_MAP || openacc) + && list != OMP_LIST_FROM + && list != OMP_LIST_TO + && (list != OMP_LIST_REDUCTION || !openacc) + && list != OMP_LIST_REDUCTION_INSCAN + && list != OMP_LIST_REDUCTION_TASK + && list != OMP_LIST_IN_REDUCTION + && list != OMP_LIST_TASK_REDUCTION + && list != OMP_LIST_ALLOCATE) + for (n = omp_clauses->lists[list]; n; n = n->next) + { + bool component_ref_p = false; + + /* Allow multiple components of the same (e.g. derived-type) + variable here. Duplicate components are detected elsewhere. */ + if (n->expr && n->expr->expr_type == EXPR_VARIABLE) + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + component_ref_p = true; + if ((!component_ref_p && n->sym->comp_mark) + || (component_ref_p && n->sym->mark)) + gfc_error ("Symbol %qs has mixed component and non-component " + "accesses at %L", n->sym->name, &n->where); + else if (n->sym->mark) + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &n->where); + else + { + if (component_ref_p) + n->sym->comp_mark = 1; + else + n->sym->mark = 1; + } + } + + gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1); + for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++) + for (n = omp_clauses->lists[list]; n; n = n->next) + if (n->sym->mark) + { + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &n->where); + n->sym->mark = 0; + } + + for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next) + { + if (n->sym->mark) + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &n->where); + else + n->sym->mark = 1; + } + for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) + n->sym->mark = 0; + + for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next) + { + if (n->sym->mark) + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &n->where); + else + n->sym->mark = 1; + } + + for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) + n->sym->mark = 0; + + for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) + { + if (n->sym->mark) + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &n->where); + else + n->sym->mark = 1; + } + + if (omp_clauses->lists[OMP_LIST_ALLOCATE]) + { + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (n->expr && (n->expr->ts.type != BT_INTEGER + || n->expr->ts.kind != gfc_c_intptr_kind)) + { + gfc_error ("Expected integer expression of the " + "'omp_allocator_handle_kind' kind at %L", + &n->expr->where); + break; + } + + /* Check for 2 things here. + 1. There is no duplication of variable in allocate clause. + 2. Variable in allocate clause are also present in some + privatization clase (non-composite case). */ + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + n->sym->mark = 0; + + gfc_omp_namelist *prev = NULL; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;) + { + if (n->sym->mark == 1) + { + gfc_warning (0, "%qs appears more than once in % " + "clauses at %L" , n->sym->name, &n->where); + /* We have already seen this variable so it is a duplicate. + Remove it. */ + if (prev != NULL && prev->next == n) + { + prev->next = n->next; + n->next = NULL; + gfc_free_omp_namelist (n, 0); + n = prev->next; + } + continue; + } + n->sym->mark = 1; + prev = n; + n = n->next; + } + + /* Non-composite constructs. */ + if (code && code->op < EXEC_OMP_DO_SIMD) + { + for (list = 0; list < OMP_LIST_NUM; list++) + switch (list) + { + case OMP_LIST_PRIVATE: + case OMP_LIST_FIRSTPRIVATE: + case OMP_LIST_LASTPRIVATE: + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: + case OMP_LIST_IN_REDUCTION: + case OMP_LIST_TASK_REDUCTION: + case OMP_LIST_LINEAR: + for (n = omp_clauses->lists[list]; n; n = n->next) + n->sym->mark = 0; + break; + default: + break; + } + + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (n->sym->mark == 1) + gfc_error ("%qs specified in 'allocate' clause at %L but not " + "in an explicit privatization clause", + n->sym->name, &n->where); + } + } + + /* OpenACC reductions. */ + if (openacc) + { + for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) + n->sym->mark = 0; + + for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next) + { + if (n->sym->mark) + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &n->where); + else + n->sym->mark = 1; + + /* OpenACC does not support reductions on arrays. */ + if (n->sym->as) + gfc_error ("Array %qs is not permitted in reduction at %L", + n->sym->name, &n->where); + } + } + + for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) + n->sym->mark = 0; + for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next) + if (n->expr == NULL) + n->sym->mark = 1; + for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next) + { + if (n->expr == NULL && n->sym->mark) + gfc_error ("Symbol %qs present on both FROM and TO clauses at %L", + n->sym->name, &n->where); + else + n->sym->mark = 1; + } + + bool has_inscan = false, has_notinscan = false; + for (list = 0; list < OMP_LIST_NUM; list++) + if ((n = omp_clauses->lists[list]) != NULL) + { + const char *name = clause_names[list]; + + switch (list) + { + case OMP_LIST_COPYIN: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.threadprivate) + gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause" + " at %L", n->sym->name, &n->where); + } + break; + case OMP_LIST_COPYPRIVATE: + for (; n != NULL; n = n->next) + { + if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array %qs in COPYPRIVATE clause " + "at %L", n->sym->name, &n->where); + if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) + gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause " + "at %L", n->sym->name, &n->where); + } + break; + case OMP_LIST_SHARED: + for (; n != NULL; n = n->next) + { + if (n->sym->attr.threadprivate) + gfc_error ("THREADPRIVATE object %qs in SHARED clause at " + "%L", n->sym->name, &n->where); + if (n->sym->attr.cray_pointee) + gfc_error ("Cray pointee %qs in SHARED clause at %L", + n->sym->name, &n->where); + if (n->sym->attr.associate_var) + gfc_error ("ASSOCIATE name %qs in SHARED clause at %L", + n->sym->name, &n->where); + if (omp_clauses->detach + && n->sym == omp_clauses->detach->symtree->n.sym) + gfc_error ("DETACH event handle %qs in SHARED clause at %L", + n->sym->name, &n->where); + } + break; + case OMP_LIST_ALIGNED: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.pointer + && !n->sym->attr.allocatable + && !n->sym->attr.cray_pointer + && (n->sym->ts.type != BT_DERIVED + || (n->sym->ts.u.derived->from_intmod + != INTMOD_ISO_C_BINDING) + || (n->sym->ts.u.derived->intmod_sym_id + != ISOCBINDING_PTR))) + gfc_error ("%qs in ALIGNED clause must be POINTER, " + "ALLOCATABLE, Cray pointer or C_PTR at %L", + n->sym->name, &n->where); + else if (n->expr) + { + gfc_expr *expr = n->expr; + int alignment = 0; + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_INTEGER + || expr->rank != 0 + || gfc_extract_int (expr, &alignment) + || alignment <= 0) + gfc_error ("%qs in ALIGNED clause at %L requires a scalar " + "positive constant integer alignment " + "expression", n->sym->name, &n->where); + } + } + break; + case OMP_LIST_AFFINITY: + case OMP_LIST_DEPEND: + case OMP_LIST_MAP: + case OMP_LIST_TO: + case OMP_LIST_FROM: + case OMP_LIST_CACHE: + for (; n != NULL; n = n->next) + { + if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY) + && n->u2.ns && !n->u2.ns->resolved) + { + n->u2.ns->resolved = 1; + for (gfc_symbol *sym = n->u2.ns->proc_name; sym; + sym = sym->tlink) + { + gfc_constructor *c; + c = gfc_constructor_first (sym->value->value.constructor); + if (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0) + gfc_error ("Scalar integer expression for range begin" + " expected at %L", &c->expr->where); + c = gfc_constructor_next (c); + if (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0) + gfc_error ("Scalar integer expression for range end " + "expected at %L", &c->expr->where); + c = gfc_constructor_next (c); + if (c && (!gfc_resolve_expr (c->expr) + || c->expr->ts.type != BT_INTEGER + || c->expr->rank != 0)) + gfc_error ("Scalar integer expression for range step " + "expected at %L", &c->expr->where); + else if (c + && c->expr->expr_type == EXPR_CONSTANT + && mpz_cmp_si (c->expr->value.integer, 0) == 0) + gfc_error ("Nonzero range step expected at %L", + &c->expr->where); + } + } + + if (list == OMP_LIST_DEPEND) + { + if (n->u.depend_op == OMP_DEPEND_SINK_FIRST + || n->u.depend_op == OMP_DEPEND_SINK) + { + if (code->op != EXEC_OMP_ORDERED) + gfc_error ("SINK dependence type only allowed " + "on ORDERED directive at %L", &n->where); + else if (omp_clauses->depend_source) + { + gfc_error ("DEPEND SINK used together with " + "DEPEND SOURCE on the same construct " + "at %L", &n->where); + omp_clauses->depend_source = false; + } + else if (n->expr) + { + if (!gfc_resolve_expr (n->expr) + || n->expr->ts.type != BT_INTEGER + || n->expr->rank != 0) + gfc_error ("SINK addend not a constant integer " + "at %L", &n->where); + } + continue; + } + else if (code->op == EXEC_OMP_ORDERED) + gfc_error ("Only SOURCE or SINK dependence types " + "are allowed on ORDERED directive at %L", + &n->where); + else if (n->u.depend_op == OMP_DEPEND_DEPOBJ + && !n->expr + && (n->sym->ts.type != BT_INTEGER + || n->sym->ts.kind + != 2 * gfc_index_integer_kind + || n->sym->attr.dimension)) + gfc_error ("Locator %qs at %L in DEPEND clause of depobj " + "type shall be a scalar integer of " + "OMP_DEPEND_KIND kind", n->sym->name, + &n->where); + else if (n->u.depend_op == OMP_DEPEND_DEPOBJ + && n->expr + && (!gfc_resolve_expr (n->expr) + || n->expr->ts.type != BT_INTEGER + || n->expr->ts.kind + != 2 * gfc_index_integer_kind + || n->expr->rank != 0)) + gfc_error ("Locator at %L in DEPEND clause of depobj " + "type shall be a scalar integer of " + "OMP_DEPEND_KIND kind", &n->expr->where); + } + gfc_ref *lastref = NULL, *lastslice = NULL; + bool resolved = false; + if (n->expr) + { + lastref = n->expr->ref; + resolved = gfc_resolve_expr (n->expr); + + /* Look through component refs to find last array + reference. */ + if (resolved) + { + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + || ref->type == REF_SUBSTRING + || ref->type == REF_INQUIRY) + lastref = ref; + else if (ref->type == REF_ARRAY) + { + for (int i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_RANGE) + lastslice = ref; + + lastref = ref; + } + + /* The "!$acc cache" directive allows rectangular + subarrays to be specified, with some restrictions + on the form of bounds (not implemented). + Only raise an error here if we're really sure the + array isn't contiguous. An expression such as + arr(-n:n,-n:n) could be contiguous even if it looks + like it may not be. */ + if (code->op != EXEC_OACC_UPDATE + && list != OMP_LIST_CACHE + && list != OMP_LIST_DEPEND + && !gfc_is_simply_contiguous (n->expr, false, true) + && gfc_is_not_contiguous (n->expr) + && !(lastslice + && (lastslice->next + || lastslice->type != REF_ARRAY))) + gfc_error ("Array is not contiguous at %L", + &n->where); + } + } + if (lastref + || (n->expr + && (!resolved || n->expr->expr_type != EXPR_VARIABLE))) + { + if (!lastslice + && lastref + && lastref->type == REF_SUBSTRING) + gfc_error ("Unexpected substring reference in %s clause " + "at %L", name, &n->where); + else if (!lastslice + && lastref + && lastref->type == REF_INQUIRY) + { + gcc_assert (lastref->u.i == INQUIRY_RE + || lastref->u.i == INQUIRY_IM); + gfc_error ("Unexpected complex-parts designator " + "reference in %s clause at %L", + name, &n->where); + } + else if (!resolved + || n->expr->expr_type != EXPR_VARIABLE + || (lastslice + && (lastslice->next + || lastslice->type != REF_ARRAY))) + gfc_error ("%qs in %s clause at %L is not a proper " + "array section", n->sym->name, name, + &n->where); + else if (lastslice) + { + int i; + gfc_array_ref *ar = &lastslice->u.ar; + for (i = 0; i < ar->dimen; i++) + if (ar->stride[i] && code->op != EXEC_OACC_UPDATE) + { + gfc_error ("Stride should not be specified for " + "array section in %s clause at %L", + name, &n->where); + break; + } + else if (ar->dimen_type[i] != DIMEN_ELEMENT + && ar->dimen_type[i] != DIMEN_RANGE) + { + gfc_error ("%qs in %s clause at %L is not a " + "proper array section", + n->sym->name, name, &n->where); + break; + } + else if ((list == OMP_LIST_DEPEND + || list == OMP_LIST_AFFINITY) + && ar->start[i] + && ar->start[i]->expr_type == EXPR_CONSTANT + && ar->end[i] + && ar->end[i]->expr_type == EXPR_CONSTANT + && mpz_cmp (ar->start[i]->value.integer, + ar->end[i]->value.integer) > 0) + { + gfc_error ("%qs in %s clause at %L is a " + "zero size array section", + n->sym->name, + list == OMP_LIST_DEPEND + ? "DEPEND" : "AFFINITY", &n->where); + break; + } + } + } + else if (openacc) + { + if (list == OMP_LIST_MAP + && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR) + resolve_oacc_deviceptr_clause (n->sym, n->where, name); + else + resolve_oacc_data_clauses (n->sym, n->where, name); + } + else if (list != OMP_LIST_DEPEND + && n->sym->as + && n->sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (!openacc + && list == OMP_LIST_MAP + && n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->attr.alloc_comp) + gfc_error ("List item %qs with allocatable components is not " + "permitted in map clause at %L", n->sym->name, + &n->where); + if (list == OMP_LIST_MAP && !openacc) + switch (code->op) + { + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + switch (n->u.map_op) + { + case OMP_MAP_TO: + case OMP_MAP_ALWAYS_TO: + case OMP_MAP_FROM: + case OMP_MAP_ALWAYS_FROM: + case OMP_MAP_TOFROM: + case OMP_MAP_ALWAYS_TOFROM: + case OMP_MAP_ALLOC: + break; + default: + gfc_error ("TARGET%s with map-type other than TO, " + "FROM, TOFROM, or ALLOC on MAP clause " + "at %L", + code->op == EXEC_OMP_TARGET + ? "" : " DATA", &n->where); + break; + } + break; + case EXEC_OMP_TARGET_ENTER_DATA: + switch (n->u.map_op) + { + case OMP_MAP_TO: + case OMP_MAP_ALWAYS_TO: + case OMP_MAP_ALLOC: + break; + default: + gfc_error ("TARGET ENTER DATA with map-type other " + "than TO, or ALLOC on MAP clause at %L", + &n->where); + break; + } + break; + case EXEC_OMP_TARGET_EXIT_DATA: + switch (n->u.map_op) + { + case OMP_MAP_FROM: + case OMP_MAP_ALWAYS_FROM: + case OMP_MAP_RELEASE: + case OMP_MAP_DELETE: + break; + default: + gfc_error ("TARGET EXIT DATA with map-type other " + "than FROM, RELEASE, or DELETE on MAP " + "clause at %L", &n->where); + break; + } + break; + default: + break; + } + } + + if (list != OMP_LIST_DEPEND) + for (n = omp_clauses->lists[list]; n != NULL; n = n->next) + { + n->sym->attr.referenced = 1; + if (n->sym->attr.threadprivate) + gfc_error ("THREADPRIVATE object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.cray_pointee) + gfc_error ("Cray pointee %qs in %s clause at %L", + n->sym->name, name, &n->where); + } + break; + case OMP_LIST_IS_DEVICE_PTR: + for (n = omp_clauses->lists[list]; n != NULL; n = n->next) + { + if (!n->sym->attr.dummy) + gfc_error ("Non-dummy object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.allocatable + || (n->sym->ts.type == BT_CLASS + && CLASS_DATA (n->sym)->attr.allocatable)) + gfc_error ("ALLOCATABLE object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.pointer + || (n->sym->ts.type == BT_CLASS + && CLASS_DATA (n->sym)->attr.pointer)) + gfc_error ("POINTER object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.value) + gfc_error ("VALUE object %qs in %s clause at %L", + n->sym->name, name, &n->where); + } + break; + case OMP_LIST_USE_DEVICE_PTR: + case OMP_LIST_USE_DEVICE_ADDR: + /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */ + break; + default: + for (; n != NULL; n = n->next) + { + bool bad = false; + bool is_reduction = (list == OMP_LIST_REDUCTION + || list == OMP_LIST_REDUCTION_INSCAN + || list == OMP_LIST_REDUCTION_TASK + || list == OMP_LIST_IN_REDUCTION + || list == OMP_LIST_TASK_REDUCTION); + if (list == OMP_LIST_REDUCTION_INSCAN) + has_inscan = true; + else if (is_reduction) + has_notinscan = true; + if (has_inscan && has_notinscan && is_reduction) + { + gfc_error ("% and non-% % " + "clauses on the same construct at %L", + &n->where); + break; + } + if (n->sym->attr.threadprivate) + gfc_error ("THREADPRIVATE object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.cray_pointee) + gfc_error ("Cray pointee %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.associate_var) + gfc_error ("ASSOCIATE name %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (list != OMP_LIST_PRIVATE && is_reduction) + { + if (n->sym->attr.proc_pointer) + gfc_error ("Procedure pointer %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.pointer) + gfc_error ("POINTER object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.cray_pointer) + gfc_error ("Cray pointer %qs in %s clause at %L", + n->sym->name, name, &n->where); + } + if (code + && (oacc_is_loop (code) + || code->op == EXEC_OACC_PARALLEL + || code->op == EXEC_OACC_SERIAL)) + check_array_not_assumed (n->sym, n->where, name); + else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.in_namelist && !is_reduction) + gfc_error ("Variable %qs in %s clause is used in " + "NAMELIST statement at %L", + n->sym->name, name, &n->where); + if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN) + switch (list) + { + case OMP_LIST_PRIVATE: + case OMP_LIST_LASTPRIVATE: + case OMP_LIST_LINEAR: + /* case OMP_LIST_REDUCTION: */ + gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L", + n->sym->name, name, &n->where); + break; + default: + break; + } + if (omp_clauses->detach + && (list == OMP_LIST_PRIVATE + || list == OMP_LIST_FIRSTPRIVATE + || list == OMP_LIST_LASTPRIVATE) + && n->sym == omp_clauses->detach->symtree->n.sym) + gfc_error ("DETACH event handle %qs in %s clause at %L", + n->sym->name, name, &n->where); + switch (list) + { + case OMP_LIST_REDUCTION_TASK: + if (code + && (code->op == EXEC_OMP_LOOP + || code->op == EXEC_OMP_TASKLOOP + || code->op == EXEC_OMP_TASKLOOP_SIMD + || code->op == EXEC_OMP_MASKED_TASKLOOP + || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD + || code->op == EXEC_OMP_MASTER_TASKLOOP + || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD + || code->op == EXEC_OMP_PARALLEL_LOOP + || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP + || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD + || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP + || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD + || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP + || code->op == EXEC_OMP_TARGET_TEAMS_LOOP + || code->op == EXEC_OMP_TEAMS + || code->op == EXEC_OMP_TEAMS_DISTRIBUTE + || code->op == EXEC_OMP_TEAMS_LOOP)) + { + gfc_error ("Only DEFAULT permitted as reduction-" + "modifier in REDUCTION clause at %L", + &n->where); + break; + } + gcc_fallthrough (); + case OMP_LIST_REDUCTION: + case OMP_LIST_IN_REDUCTION: + case OMP_LIST_TASK_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + switch (n->u.reduction_op) + { + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_TIMES: + case OMP_REDUCTION_MINUS: + if (!gfc_numeric_ts (&n->sym->ts)) + bad = true; + break; + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + if (n->sym->ts.type != BT_LOGICAL) + bad = true; + break; + case OMP_REDUCTION_MAX: + case OMP_REDUCTION_MIN: + if (n->sym->ts.type != BT_INTEGER + && n->sym->ts.type != BT_REAL) + bad = true; + break; + case OMP_REDUCTION_IAND: + case OMP_REDUCTION_IOR: + case OMP_REDUCTION_IEOR: + if (n->sym->ts.type != BT_INTEGER) + bad = true; + break; + case OMP_REDUCTION_USER: + bad = true; + break; + default: + break; + } + if (!bad) + n->u2.udr = NULL; + else + { + const char *udr_name = NULL; + if (n->u2.udr) + { + udr_name = n->u2.udr->udr->name; + n->u2.udr->udr + = gfc_find_omp_udr (NULL, udr_name, + &n->sym->ts); + if (n->u2.udr->udr == NULL) + { + free (n->u2.udr); + n->u2.udr = NULL; + } + } + if (n->u2.udr == NULL) + { + if (udr_name == NULL) + switch (n->u.reduction_op) + { + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_TIMES: + case OMP_REDUCTION_MINUS: + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + udr_name = gfc_op2string ((gfc_intrinsic_op) + n->u.reduction_op); + break; + case OMP_REDUCTION_MAX: + udr_name = "max"; + break; + case OMP_REDUCTION_MIN: + udr_name = "min"; + break; + case OMP_REDUCTION_IAND: + udr_name = "iand"; + break; + case OMP_REDUCTION_IOR: + udr_name = "ior"; + break; + case OMP_REDUCTION_IEOR: + udr_name = "ieor"; + break; + default: + gcc_unreachable (); + } + gfc_error ("!$OMP DECLARE REDUCTION %s not found " + "for type %s at %L", udr_name, + gfc_typename (&n->sym->ts), &n->where); + } + else + { + gfc_omp_udr *udr = n->u2.udr->udr; + n->u.reduction_op = OMP_REDUCTION_USER; + n->u2.udr->combiner + = resolve_omp_udr_clause (n, udr->combiner_ns, + udr->omp_out, + udr->omp_in); + if (udr->initializer_ns) + n->u2.udr->initializer + = resolve_omp_udr_clause (n, + udr->initializer_ns, + udr->omp_priv, + udr->omp_orig); + } + } + break; + case OMP_LIST_LINEAR: + if (code + && n->u.linear_op != OMP_LINEAR_DEFAULT + && n->u.linear_op != linear_op) + { + gfc_error ("LINEAR clause modifier used on DO or SIMD" + " construct at %L", &n->where); + linear_op = n->u.linear_op; + } + else if (omp_clauses->orderedc) + gfc_error ("LINEAR clause specified together with " + "ORDERED clause with argument at %L", + &n->where); + else if (n->u.linear_op != OMP_LINEAR_REF + && n->sym->ts.type != BT_INTEGER) + gfc_error ("LINEAR variable %qs must be INTEGER " + "at %L", n->sym->name, &n->where); + else if ((n->u.linear_op == OMP_LINEAR_REF + || n->u.linear_op == OMP_LINEAR_UVAL) + && n->sym->attr.value) + gfc_error ("LINEAR dummy argument %qs with VALUE " + "attribute with %s modifier at %L", + n->sym->name, + n->u.linear_op == OMP_LINEAR_REF + ? "REF" : "UVAL", &n->where); + else if (n->expr) + { + gfc_expr *expr = n->expr; + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_INTEGER + || expr->rank != 0) + gfc_error ("%qs in LINEAR clause at %L requires " + "a scalar integer linear-step expression", + n->sym->name, &n->where); + else if (!code && expr->expr_type != EXPR_CONSTANT) + { + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->attr.dummy + && expr->symtree->n.sym->ns == ns) + { + gfc_omp_namelist *n2; + for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM]; + n2; n2 = n2->next) + if (n2->sym == expr->symtree->n.sym) + break; + if (n2) + break; + } + gfc_error ("%qs in LINEAR clause at %L requires " + "a constant integer linear-step " + "expression or dummy argument " + "specified in UNIFORM clause", + n->sym->name, &n->where); + } + } + break; + /* Workaround for PR middle-end/26316, nothing really needs + to be done here for OMP_LIST_PRIVATE. */ + case OMP_LIST_PRIVATE: + gcc_assert (code && code->op != EXEC_NOP); + break; + case OMP_LIST_USE_DEVICE: + if (n->sym->attr.allocatable + || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym) + && CLASS_DATA (n->sym)->attr.allocatable)) + gfc_error ("ALLOCATABLE object %qs in %s clause at %L", + n->sym->name, name, &n->where); + if (n->sym->ts.type == BT_CLASS + && CLASS_DATA (n->sym) + && CLASS_DATA (n->sym)->attr.class_pointer) + gfc_error ("POINTER object %qs of polymorphic type in " + "%s clause at %L", n->sym->name, name, + &n->where); + if (n->sym->attr.cray_pointer) + gfc_error ("Cray pointer object %qs in %s clause at %L", + n->sym->name, name, &n->where); + else if (n->sym->attr.cray_pointee) + gfc_error ("Cray pointee object %qs in %s clause at %L", + n->sym->name, name, &n->where); + else if (n->sym->attr.flavor == FL_VARIABLE + && !n->sym->as + && !n->sym->attr.pointer) + gfc_error ("%s clause variable %qs at %L is neither " + "a POINTER nor an array", name, + n->sym->name, &n->where); + /* FALLTHRU */ + case OMP_LIST_DEVICE_RESIDENT: + check_symbol_not_pointer (n->sym, n->where, name); + check_array_not_assumed (n->sym, n->where, name); + break; + default: + break; + } + } + break; + } + } + /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for + type(c_ptr). */ + if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR]) + { + gfc_omp_namelist *n_prev, *n_next, *n_addr; + n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR]; + for (; n_addr && n_addr->next; n_addr = n_addr->next) + ; + n_prev = NULL; + n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR]; + while (n) + { + n_next = n->next; + if (n->sym->ts.type != BT_DERIVED + || n->sym->ts.u.derived->ts.f90_type != BT_VOID) + { + n->next = NULL; + if (n_addr) + n_addr->next = n; + else + omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n; + n_addr = n; + if (n_prev) + n_prev->next = n_next; + else + omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next; + } + else + n_prev = n; + n = n_next; + } + } + if (omp_clauses->safelen_expr) + resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN"); + if (omp_clauses->simdlen_expr) + resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN"); + if (omp_clauses->num_teams_lower) + resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS"); + if (omp_clauses->num_teams_upper) + resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS"); + if (omp_clauses->num_teams_lower + && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT + && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT + && mpz_cmp (omp_clauses->num_teams_lower->value.integer, + omp_clauses->num_teams_upper->value.integer) > 0) + gfc_warning (0, "NUM_TEAMS lower bound at %L larger than upper bound at %L", + &omp_clauses->num_teams_lower->where, + &omp_clauses->num_teams_upper->where); + if (omp_clauses->device) + resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE"); + if (omp_clauses->filter) + resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER"); + if (omp_clauses->hint) + { + resolve_scalar_int_expr (omp_clauses->hint, "HINT"); + if (omp_clauses->hint->ts.type != BT_INTEGER + || omp_clauses->hint->expr_type != EXPR_CONSTANT + || mpz_sgn (omp_clauses->hint->value.integer) < 0) + gfc_error ("Value of HINT clause at %L shall be a valid " + "constant hint expression", &omp_clauses->hint->where); + } + if (omp_clauses->priority) + resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY"); + if (omp_clauses->dist_chunk_size) + { + gfc_expr *expr = omp_clauses->dist_chunk_size; + if (!gfc_resolve_expr (expr) + || expr->ts.type != BT_INTEGER || expr->rank != 0) + gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires " + "a scalar INTEGER expression", &expr->where); + } + if (omp_clauses->thread_limit) + resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT"); + if (omp_clauses->grainsize) + resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE"); + if (omp_clauses->num_tasks) + resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS"); + if (omp_clauses->async) + if (omp_clauses->async_expr) + resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC"); + if (omp_clauses->num_gangs_expr) + resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS"); + if (omp_clauses->num_workers_expr) + resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS"); + if (omp_clauses->vector_length_expr) + resolve_positive_int_expr (omp_clauses->vector_length_expr, + "VECTOR_LENGTH"); + if (omp_clauses->gang_num_expr) + resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG"); + if (omp_clauses->gang_static_expr) + resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG"); + if (omp_clauses->worker_expr) + resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER"); + if (omp_clauses->vector_expr) + resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR"); + for (el = omp_clauses->wait_list; el; el = el->next) + resolve_scalar_int_expr (el->expr, "WAIT"); + if (omp_clauses->collapse && omp_clauses->tile_list) + gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc); + if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) + gfc_error ("SOURCE dependence type only allowed " + "on ORDERED directive at %L", &code->loc); + if (omp_clauses->message) + { + gfc_expr *expr = omp_clauses->message; + if (!gfc_resolve_expr (expr) + || expr->ts.kind != gfc_default_character_kind + || expr->ts.type != BT_CHARACTER || expr->rank != 0) + gfc_error ("MESSAGE clause at %L requires a scalar default-kind " + "CHARACTER expression", &expr->where); + } + if (!openacc + && code + && omp_clauses->lists[OMP_LIST_MAP] == NULL + && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL + && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL) + { + const char *p = NULL; + switch (code->op) + { + case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break; + case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break; + default: break; + } + if (code->op == EXEC_OMP_TARGET_DATA) + gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, " + "or USE_DEVICE_ADDR clause at %L", &code->loc); + else if (p) + gfc_error ("%s must contain at least one MAP clause at %L", + p, &code->loc); + } + if (!openacc && omp_clauses->mergeable && omp_clauses->detach) + gfc_error ("% clause at %L must not be used together with " + "% clause", &omp_clauses->detach->where); +} + + +/* Return true if SYM is ever referenced in EXPR except in the SE node. */ + +static bool +expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) +{ + gfc_actual_arglist *arg; + if (e == NULL || e == se) + return false; + switch (e->expr_type) + { + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_VARIABLE: + case EXPR_STRUCTURE: + case EXPR_ARRAY: + if (e->symtree != NULL + && e->symtree->n.sym == s) + return true; + return false; + case EXPR_SUBSTRING: + if (e->ref != NULL + && (expr_references_sym (e->ref->u.ss.start, s, se) + || expr_references_sym (e->ref->u.ss.end, s, se))) + return true; + return false; + case EXPR_OP: + if (expr_references_sym (e->value.op.op2, s, se)) + return true; + return expr_references_sym (e->value.op.op1, s, se); + case EXPR_FUNCTION: + for (arg = e->value.function.actual; arg; arg = arg->next) + if (expr_references_sym (arg->expr, s, se)) + return true; + return false; + default: + gcc_unreachable (); + } +} + + +/* If EXPR is a conversion function that widens the type + if WIDENING is true or narrows the type if NARROW is true, + return the inner expression, otherwise return NULL. */ + +static gfc_expr * +is_conversion (gfc_expr *expr, bool narrowing, bool widening) +{ + gfc_typespec *ts1, *ts2; + + if (expr->expr_type != EXPR_FUNCTION + || expr->value.function.isym == NULL + || expr->value.function.esym != NULL + || expr->value.function.isym->id != GFC_ISYM_CONVERSION + || (!narrowing && !widening)) + return NULL; + + if (narrowing && widening) + return expr->value.function.actual->expr; + + if (widening) + { + ts1 = &expr->ts; + ts2 = &expr->value.function.actual->expr->ts; + } + else + { + ts1 = &expr->value.function.actual->expr->ts; + ts2 = &expr->ts; + } + + if (ts1->type > ts2->type + || (ts1->type == ts2->type && ts1->kind > ts2->kind)) + return expr->value.function.actual->expr; + + return NULL; +} + +static bool +is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok) +{ + if (must_be_var + && (expr->expr_type != EXPR_VARIABLE || !expr->symtree) + && (!conv_ok || !is_conversion (expr, true, true))) + return false; + return (expr->rank == 0 + && !gfc_is_coindexed (expr) + && (expr->ts.type == BT_INTEGER + || expr->ts.type == BT_REAL + || expr->ts.type == BT_COMPLEX + || expr->ts.type == BT_LOGICAL)); +} + +static void +resolve_omp_atomic (gfc_code *code) +{ + gfc_code *atomic_code = code->block; + gfc_symbol *var; + gfc_expr *stmt_expr2, *capt_expr2; + gfc_omp_atomic_op aop + = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op + & GFC_OMP_ATOMIC_MASK); + gfc_code *stmt = NULL, *capture_stmt = NULL; + gfc_expr *comp_cond = NULL; + locus *loc = NULL; + + code = code->block->next; + /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF + If it changed to EXEC_NOP, assume an error has been emitted already. */ + if (code->op == EXEC_NOP) + return; + + if (atomic_code->ext.omp_clauses->compare + && atomic_code->ext.omp_clauses->capture) + { + /* Must be either "if (x == e) then; x = d; else; v = x; end if" + or "v = expr" followed/preceded by + "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ + gfc_code *next = code; + if (code->op == EXEC_ASSIGN) + { + capture_stmt = code; + next = code->next; + } + if (next->op == EXEC_IF + && next->block + && next->block->op == EXEC_IF + && next->block->next->op == EXEC_ASSIGN) + { + comp_cond = next->block->expr1; + stmt = next->block->next; + if (stmt->next) + { + loc = &stmt->loc; + goto unexpected; + } + } + else if (capture_stmt) + { + gfc_error ("Expected IF at %L in atomic compare capture", + &next->loc); + return; + } + if (stmt && !capture_stmt && next->block->block) + { + if (next->block->block->expr1) + { + gfc_error ("Expected ELSE at %L in atomic compare capture", + &next->block->block->expr1->where); + return; + } + if (!code->block->block->next + || code->block->block->next->op != EXEC_ASSIGN) + { + loc = (code->block->block->next ? &code->block->block->next->loc + : &code->block->block->loc); + goto unexpected; + } + capture_stmt = code->block->block->next; + if (capture_stmt->next) + { + loc = &capture_stmt->next->loc; + goto unexpected; + } + } + if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN) + capture_stmt = next->next; + else if (!capture_stmt) + { + loc = &code->loc; + goto unexpected; + } + } + else if (atomic_code->ext.omp_clauses->compare) + { + /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ + if (code->op == EXEC_IF + && code->block + && code->block->op == EXEC_IF + && code->block->next->op == EXEC_ASSIGN) + { + comp_cond = code->block->expr1; + stmt = code->block->next; + if (stmt->next || code->block->block) + { + loc = stmt->next ? &stmt->next->loc : &code->block->block->loc; + goto unexpected; + } + } + else + { + loc = &code->loc; + goto unexpected; + } + } + else if (atomic_code->ext.omp_clauses->capture) + { + /* Must be: "v = x" followed/preceded by "x = ...". */ + if (code->op != EXEC_ASSIGN) + goto unexpected; + if (code->next->op != EXEC_ASSIGN) + { + loc = &code->next->loc; + goto unexpected; + } + gfc_expr *expr2, *expr2_next; + expr2 = is_conversion (code->expr2, true, true); + if (expr2 == NULL) + expr2 = code->expr2; + expr2_next = is_conversion (code->next->expr2, true, true); + if (expr2_next == NULL) + expr2_next = code->next->expr2; + if (code->expr1->expr_type == EXPR_VARIABLE + && code->next->expr1->expr_type == EXPR_VARIABLE + && expr2->expr_type == EXPR_VARIABLE + && expr2_next->expr_type == EXPR_VARIABLE) + { + if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym) + { + stmt = code; + capture_stmt = code->next; + } + else + { + capture_stmt = code; + stmt = code->next; + } + } + else if (expr2->expr_type == EXPR_VARIABLE) + { + capture_stmt = code; + stmt = code->next; + } + else + { + stmt = code; + capture_stmt = code->next; + } + gcc_assert (!code->next->next); + } + else + { + /* x = ... */ + stmt = code; + if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN) + goto unexpected; + gcc_assert (!code->next); + } + + if (comp_cond) + { + if (comp_cond->expr_type != EXPR_OP + || (comp_cond->value.op.op != INTRINSIC_EQ + && comp_cond->value.op.op != INTRINSIC_EQ_OS + && comp_cond->value.op.op != INTRINSIC_EQV)) + { + gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison " + "expression at %L", &comp_cond->where); + return; + } + if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true)) + { + gfc_error ("Expected scalar intrinsic variable at %L in atomic " + "comparison", &comp_cond->value.op.op1->where); + return; + } + if (!gfc_resolve_expr (comp_cond->value.op.op2)) + return; + if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false)) + { + gfc_error ("Expected scalar intrinsic expression at %L in atomic " + "comparison", &comp_cond->value.op.op1->where); + return; + } + } + + if (!is_scalar_intrinsic_expr (stmt->expr1, true, false)) + { + gfc_error ("!$OMP ATOMIC statement must set a scalar variable of " + "intrinsic type at %L", &stmt->expr1->where); + return; + } + + if (!gfc_resolve_expr (stmt->expr2)) + return; + if (!is_scalar_intrinsic_expr (stmt->expr2, false, false)) + { + gfc_error ("!$OMP ATOMIC statement must assign an expression of " + "intrinsic type at %L", &stmt->expr2->where); + return; + } + + if (gfc_expr_attr (stmt->expr1).allocatable) + { + gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L", + &stmt->expr1->where); + return; + } + + var = stmt->expr1->symtree->n.sym; + stmt_expr2 = is_conversion (stmt->expr2, true, true); + if (stmt_expr2 == NULL) + stmt_expr2 = stmt->expr2; + + switch (aop) + { + case GFC_OMP_ATOMIC_READ: + if (stmt_expr2->expr_type != EXPR_VARIABLE) + gfc_error ("!$OMP ATOMIC READ statement must read from a scalar " + "variable of intrinsic type at %L", &stmt_expr2->where); + return; + case GFC_OMP_ATOMIC_WRITE: + if (expr_references_sym (stmt_expr2, var, NULL)) + gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr " + "must be scalar and cannot reference var at %L", + &stmt_expr2->where); + return; + default: + break; + } + + if (atomic_code->ext.omp_clauses->capture) + { + if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false)) + { + gfc_error ("!$OMP ATOMIC capture-statement must set a scalar " + "variable of intrinsic type at %L", + &capture_stmt->expr1->where); + return; + } + + if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true)) + { + gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable" + " of intrinsic type at %L", &capture_stmt->expr2->where); + return; + } + capt_expr2 = is_conversion (capture_stmt->expr2, true, true); + if (capt_expr2 == NULL) + capt_expr2 = capture_stmt->expr2; + + if (capt_expr2->symtree->n.sym != var) + { + gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " + "different variable than update statement writes " + "into at %L", &capture_stmt->expr2->where); + return; + } + } + + if (atomic_code->ext.omp_clauses->compare) + { + gfc_expr *var_expr; + if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE) + var_expr = comp_cond->value.op.op1; + else + var_expr = comp_cond->value.op.op1->value.function.actual->expr; + if (var_expr->symtree->n.sym != var) + { + gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison" + " at %L must be the variable %qs that the update statement" + " writes into at %L", &var_expr->where, var->name, + &stmt->expr1->where); + return; + } + if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL)) + { + gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr " + "must be scalar and cannot reference var at %L", + &stmt_expr2->where); + return; + } + } + else if (atomic_code->ext.omp_clauses->capture + && !expr_references_sym (stmt_expr2, var, NULL)) + atomic_code->ext.omp_clauses->atomic_op + = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op + | GFC_OMP_ATOMIC_SWAP); + else if (stmt_expr2->expr_type == EXPR_OP) + { + gfc_expr *v = NULL, *e, *c; + gfc_intrinsic_op op = stmt_expr2->value.op.op; + gfc_intrinsic_op alt_op = INTRINSIC_NONE; + + if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET) + gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either" + " the COMPARE clause or using the intrinsic MIN/MAX " + "procedure", &atomic_code->loc); + switch (op) + { + case INTRINSIC_PLUS: + alt_op = INTRINSIC_MINUS; + break; + case INTRINSIC_TIMES: + alt_op = INTRINSIC_DIVIDE; + break; + case INTRINSIC_MINUS: + alt_op = INTRINSIC_PLUS; + break; + case INTRINSIC_DIVIDE: + alt_op = INTRINSIC_TIMES; + break; + case INTRINSIC_AND: + case INTRINSIC_OR: + break; + case INTRINSIC_EQV: + alt_op = INTRINSIC_NEQV; + break; + case INTRINSIC_NEQV: + alt_op = INTRINSIC_EQV; + break; + default: + gfc_error ("!$OMP ATOMIC assignment operator must be binary " + "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", + &stmt_expr2->where); + return; + } + + /* Check for var = var op expr resp. var = expr op var where + expr doesn't reference var and var op expr is mathematically + equivalent to var op (expr) resp. expr op var equivalent to + (expr) op var. We rely here on the fact that the matcher + for x op1 y op2 z where op1 and op2 have equal precedence + returns (x op1 y) op2 z. */ + e = stmt_expr2->value.op.op2; + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + v = e; + else if ((c = is_conversion (e, false, true)) != NULL + && c->expr_type == EXPR_VARIABLE + && c->symtree != NULL + && c->symtree->n.sym == var) + v = c; + else + { + gfc_expr **p = NULL, **q; + for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; ) + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + { + v = e; + break; + } + else if ((c = is_conversion (e, false, true)) != NULL) + q = &e->value.function.actual->expr; + else if (e->expr_type != EXPR_OP + || (e->value.op.op != op + && e->value.op.op != alt_op) + || e->rank != 0) + break; + else + { + p = q; + q = &e->value.op.op1; + } + + if (v == NULL) + { + gfc_error ("!$OMP ATOMIC assignment must be var = var op expr " + "or var = expr op var at %L", &stmt_expr2->where); + return; + } + + if (p != NULL) + { + e = *p; + switch (e->value.op.op) + { + case INTRINSIC_MINUS: + case INTRINSIC_DIVIDE: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + gfc_error ("!$OMP ATOMIC var = var op expr not " + "mathematically equivalent to var = var op " + "(expr) at %L", &stmt_expr2->where); + break; + default: + break; + } + + /* Canonicalize into var = var op (expr). */ + *p = e->value.op.op2; + e->value.op.op2 = stmt_expr2; + e->ts = stmt_expr2->ts; + if (stmt->expr2 == stmt_expr2) + stmt->expr2 = stmt_expr2 = e; + else + stmt->expr2->value.function.actual->expr = stmt_expr2 = e; + + if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts, + &stmt_expr2->ts)) + { + for (p = &stmt_expr2->value.op.op1; *p != v; + p = &(*p)->value.function.actual->expr) + ; + *p = NULL; + gfc_free_expr (stmt_expr2->value.op.op1); + stmt_expr2->value.op.op1 = v; + gfc_convert_type (v, &stmt_expr2->ts, 2); + } + } + } + + if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v)) + { + gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr " + "must be scalar and cannot reference var at %L", + &stmt_expr2->where); + return; + } + } + else if (stmt_expr2->expr_type == EXPR_FUNCTION + && stmt_expr2->value.function.isym != NULL + && stmt_expr2->value.function.esym == NULL + && stmt_expr2->value.function.actual != NULL + && stmt_expr2->value.function.actual->next != NULL) + { + gfc_actual_arglist *arg, *var_arg; + + switch (stmt_expr2->value.function.isym->id) + { + case GFC_ISYM_MIN: + case GFC_ISYM_MAX: + break; + case GFC_ISYM_IAND: + case GFC_ISYM_IOR: + case GFC_ISYM_IEOR: + if (stmt_expr2->value.function.actual->next->next != NULL) + { + gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR " + "or IEOR must have two arguments at %L", + &stmt_expr2->where); + return; + } + break; + default: + gfc_error ("!$OMP ATOMIC assignment intrinsic must be " + "MIN, MAX, IAND, IOR or IEOR at %L", + &stmt_expr2->where); + return; + } + + var_arg = NULL; + for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next) + { + gfc_expr *e = NULL; + if (arg == stmt_expr2->value.function.actual + || (var_arg == NULL && arg->next == NULL)) + { + e = is_conversion (arg->expr, false, true); + if (!e) + e = arg->expr; + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + var_arg = arg; + } + if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL)) + { + gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " + "not reference %qs at %L", + var->name, &arg->expr->where); + return; + } + if (arg->expr->rank != 0) + { + gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar " + "at %L", &arg->expr->where); + return; + } + } + + if (var_arg == NULL) + { + gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " + "be %qs at %L", var->name, &stmt_expr2->where); + return; + } + + if (var_arg != stmt_expr2->value.function.actual) + { + /* Canonicalize, so that var comes first. */ + gcc_assert (var_arg->next == NULL); + for (arg = stmt_expr2->value.function.actual; + arg->next != var_arg; arg = arg->next) + ; + var_arg->next = stmt_expr2->value.function.actual; + stmt_expr2->value.function.actual = var_arg; + arg->next = NULL; + } + } + else + gfc_error ("!$OMP ATOMIC assignment must have an operator or " + "intrinsic on right hand side at %L", &stmt_expr2->where); + return; + +unexpected: + gfc_error ("unexpected !$OMP ATOMIC expression at %L", + loc ? loc : &code->loc); + return; +} + + +static struct fortran_omp_context +{ + gfc_code *code; + hash_set *sharing_clauses; + hash_set *private_iterators; + struct fortran_omp_context *previous; + bool is_openmp; +} *omp_current_ctx; +static gfc_code *omp_current_do_code; +static int omp_current_do_collapse; + +void +gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) +{ + if (code->block->next && code->block->next->op == EXEC_DO) + { + int i; + gfc_code *c; + + omp_current_do_code = code->block->next; + if (code->ext.omp_clauses->orderedc) + omp_current_do_collapse = code->ext.omp_clauses->orderedc; + else + omp_current_do_collapse = code->ext.omp_clauses->collapse; + for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++) + { + c = c->block; + if (c->op != EXEC_DO || c->next == NULL) + break; + c = c->next; + if (c->op != EXEC_DO) + break; + } + if (i < omp_current_do_collapse || omp_current_do_collapse <= 0) + omp_current_do_collapse = 1; + if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]) + { + locus *loc + = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where; + if (code->ext.omp_clauses->ordered) + gfc_error ("ORDERED clause specified together with % " + "REDUCTION clause at %L", loc); + if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE) + gfc_error ("SCHEDULE clause specified together with % " + "REDUCTION clause at %L", loc); + if (!c->block + || !c->block->next + || !c->block->next->next + || c->block->next->next->op != EXEC_OMP_SCAN + || !c->block->next->next->next + || c->block->next->next->next->next) + gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN " + "between two structured-block-sequences", loc); + else + /* Mark as checked; flag will be unset later. */ + c->block->next->next->ext.omp_clauses->if_present = true; + } + } + gfc_resolve_blocks (code->block, ns); + omp_current_do_collapse = 0; + omp_current_do_code = NULL; +} + + +void +gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) +{ + struct fortran_omp_context ctx; + gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; + gfc_omp_namelist *n; + int list; + + ctx.code = code; + ctx.sharing_clauses = new hash_set; + ctx.private_iterators = new hash_set; + ctx.previous = omp_current_ctx; + ctx.is_openmp = true; + omp_current_ctx = &ctx; + + for (list = 0; list < OMP_LIST_NUM; list++) + switch (list) + { + case OMP_LIST_SHARED: + case OMP_LIST_PRIVATE: + case OMP_LIST_FIRSTPRIVATE: + case OMP_LIST_LASTPRIVATE: + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: + case OMP_LIST_IN_REDUCTION: + case OMP_LIST_TASK_REDUCTION: + case OMP_LIST_LINEAR: + for (n = omp_clauses->lists[list]; n; n = n->next) + ctx.sharing_clauses->add (n->sym); + break; + default: + break; + } + + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + gfc_resolve_omp_do_blocks (code, ns); + break; + default: + gfc_resolve_blocks (code->block, ns); + } + + omp_current_ctx = ctx.previous; + delete ctx.sharing_clauses; + delete ctx.private_iterators; +} + + +/* Save and clear openmp.c private state. */ + +void +gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state) +{ + state->ptrs[0] = omp_current_ctx; + state->ptrs[1] = omp_current_do_code; + state->ints[0] = omp_current_do_collapse; + omp_current_ctx = NULL; + omp_current_do_code = NULL; + omp_current_do_collapse = 0; +} + + +/* Restore openmp.c private state from the saved state. */ + +void +gfc_omp_restore_state (struct gfc_omp_saved_state *state) +{ + omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0]; + omp_current_do_code = (gfc_code *) state->ptrs[1]; + omp_current_do_collapse = state->ints[0]; +} + + +/* Note a DO iterator variable. This is special in !$omp parallel + construct, where they are predetermined private. */ + +void +gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause) +{ + if (omp_current_ctx == NULL) + return; + + int i = omp_current_do_collapse; + gfc_code *c = omp_current_do_code; + + if (sym->attr.threadprivate) + return; + + /* !$omp do and !$omp parallel do iteration variable is predetermined + private just in the !$omp do resp. !$omp parallel do construct, + with no implications for the outer parallel constructs. */ + + while (i-- >= 1) + { + if (code == c) + return; + + c = c->block->next; + } + + /* An openacc context may represent a data clause. Abort if so. */ + if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code)) + return; + + if (omp_current_ctx->sharing_clauses->contains (sym)) + return; + + if (! omp_current_ctx->private_iterators->add (sym) && add_clause) + { + gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; + gfc_omp_namelist *p; + + p = gfc_get_omp_namelist (); + p->sym = sym; + p->next = omp_clauses->lists[OMP_LIST_PRIVATE]; + omp_clauses->lists[OMP_LIST_PRIVATE] = p; + } +} + +static void +handle_local_var (gfc_symbol *sym) +{ + if (sym->attr.flavor != FL_VARIABLE + || sym->as != NULL + || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL)) + return; + gfc_resolve_do_iterator (sym->ns->code, sym, false); +} + +void +gfc_resolve_omp_local_vars (gfc_namespace *ns) +{ + if (omp_current_ctx) + gfc_traverse_ns (ns, handle_local_var); +} + +static void +resolve_omp_do (gfc_code *code) +{ + gfc_code *do_code, *c; + int list, i, collapse; + gfc_omp_namelist *n; + gfc_symbol *dovar; + const char *name; + bool is_simd = false; + + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + name = "!$OMP DISTRIBUTE PARALLEL DO"; + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + name = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; + is_simd = true; + break; + case EXEC_OMP_DISTRIBUTE_SIMD: + name = "!$OMP DISTRIBUTE SIMD"; + is_simd = true; + break; + case EXEC_OMP_DO: name = "!$OMP DO"; break; + case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break; + case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break; + case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break; + case EXEC_OMP_PARALLEL_DO_SIMD: + name = "!$OMP PARALLEL DO SIMD"; + is_simd = true; + break; + case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + name = "!$OMP PARALLEL MASKED TASKLOOP"; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + name = "!$OMP PARALLEL MASKED TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + name = "!$OMP PARALLEL MASTER TASKLOOP"; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + name = "!$OMP PARALLEL MASTER TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + name = "!$OMP MASKED TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + name = "!$OMP MASTER TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break; + case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break; + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + name = "!$OMP TARGET PARALLEL DO SIMD"; + is_simd = true; + break; + case EXEC_OMP_TARGET_PARALLEL_LOOP: + name = "!$OMP TARGET PARALLEL LOOP"; + break; + case EXEC_OMP_TARGET_SIMD: + name = "!$OMP TARGET SIMD"; + is_simd = true; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + name = "!$OMP TARGET TEAMS DISTRIBUTE"; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; + is_simd = true; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; + is_simd = true; + break; + case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break; + case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break; + case EXEC_OMP_TASKLOOP_SIMD: + name = "!$OMP TASKLOOP SIMD"; + is_simd = true; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; + is_simd = true; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + name = "!$OMP TEAMS DISTRIBUTE SIMD"; + is_simd = true; + break; + case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break; + default: gcc_unreachable (); + } + + if (code->ext.omp_clauses) + resolve_omp_clauses (code, code->ext.omp_clauses, NULL); + + do_code = code->block->next; + if (code->ext.omp_clauses->orderedc) + collapse = code->ext.omp_clauses->orderedc; + else + { + collapse = code->ext.omp_clauses->collapse; + if (collapse <= 0) + collapse = 1; + } + for (i = 1; i <= collapse; i++) + { + if (do_code->op == EXEC_DO_WHILE) + { + gfc_error ("%s cannot be a DO WHILE or DO without loop control " + "at %L", name, &do_code->loc); + break; + } + if (do_code->op == EXEC_DO_CONCURRENT) + { + gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name, + &do_code->loc); + break; + } + gcc_assert (do_code->op == EXEC_DO); + if (do_code->ext.iterator->var->ts.type != BT_INTEGER) + gfc_error ("%s iteration variable must be of type integer at %L", + name, &do_code->loc); + dovar = do_code->ext.iterator->var->symtree->n.sym; + if (dovar->attr.threadprivate) + gfc_error ("%s iteration variable must not be THREADPRIVATE " + "at %L", name, &do_code->loc); + if (code->ext.omp_clauses) + for (list = 0; list < OMP_LIST_NUM; list++) + if (!is_simd || code->ext.omp_clauses->collapse > 1 + ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE + && list != OMP_LIST_ALLOCATE) + : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE + && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR)) + for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) + if (dovar == n->sym) + { + if (!is_simd || code->ext.omp_clauses->collapse > 1) + gfc_error ("%s iteration variable present on clause " + "other than PRIVATE, LASTPRIVATE or " + "ALLOCATE at %L", name, &do_code->loc); + else + gfc_error ("%s iteration variable present on clause " + "other than PRIVATE, LASTPRIVATE, ALLOCATE or " + "LINEAR at %L", name, &do_code->loc); + break; + } + if (i > 1) + { + gfc_code *do_code2 = code->block->next; + int j; + + for (j = 1; j < i; j++) + { + gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; + if (dovar == ivar + || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) + || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) + || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) + { + gfc_error ("%s collapsed loops don't form rectangular " + "iteration space at %L", name, &do_code->loc); + break; + } + do_code2 = do_code2->block->next; + } + } + for (c = do_code->next; c; c = c->next) + if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) + { + gfc_error ("collapsed %s loops not perfectly nested at %L", + name, &c->loc); + break; + } + if (i == collapse || c) + break; + do_code = do_code->block; + if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE) + { + gfc_error ("not enough DO loops for collapsed %s at %L", + name, &code->loc); + break; + } + do_code = do_code->next; + if (do_code == NULL + || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)) + { + gfc_error ("not enough DO loops for collapsed %s at %L", + name, &code->loc); + break; + } + } +} + + +static gfc_statement +omp_code_to_statement (gfc_code *code) +{ + switch (code->op) + { + case EXEC_OMP_PARALLEL: + return ST_OMP_PARALLEL; + case EXEC_OMP_PARALLEL_MASKED: + return ST_OMP_PARALLEL_MASKED; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + return ST_OMP_PARALLEL_MASKED_TASKLOOP; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD; + case EXEC_OMP_PARALLEL_MASTER: + return ST_OMP_PARALLEL_MASTER; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + return ST_OMP_PARALLEL_MASTER_TASKLOOP; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD; + case EXEC_OMP_PARALLEL_SECTIONS: + return ST_OMP_PARALLEL_SECTIONS; + case EXEC_OMP_SECTIONS: + return ST_OMP_SECTIONS; + case EXEC_OMP_ORDERED: + return ST_OMP_ORDERED; + case EXEC_OMP_CRITICAL: + return ST_OMP_CRITICAL; + case EXEC_OMP_MASKED: + return ST_OMP_MASKED; + case EXEC_OMP_MASKED_TASKLOOP: + return ST_OMP_MASKED_TASKLOOP; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + return ST_OMP_MASKED_TASKLOOP_SIMD; + case EXEC_OMP_MASTER: + return ST_OMP_MASTER; + case EXEC_OMP_MASTER_TASKLOOP: + return ST_OMP_MASTER_TASKLOOP; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + return ST_OMP_MASTER_TASKLOOP_SIMD; + case EXEC_OMP_SINGLE: + return ST_OMP_SINGLE; + case EXEC_OMP_TASK: + return ST_OMP_TASK; + case EXEC_OMP_WORKSHARE: + return ST_OMP_WORKSHARE; + case EXEC_OMP_PARALLEL_WORKSHARE: + return ST_OMP_PARALLEL_WORKSHARE; + case EXEC_OMP_DO: + return ST_OMP_DO; + case EXEC_OMP_LOOP: + return ST_OMP_LOOP; + case EXEC_OMP_ATOMIC: + return ST_OMP_ATOMIC; + case EXEC_OMP_BARRIER: + return ST_OMP_BARRIER; + case EXEC_OMP_CANCEL: + return ST_OMP_CANCEL; + case EXEC_OMP_CANCELLATION_POINT: + return ST_OMP_CANCELLATION_POINT; + case EXEC_OMP_ERROR: + return ST_OMP_ERROR; + case EXEC_OMP_FLUSH: + return ST_OMP_FLUSH; + case EXEC_OMP_DISTRIBUTE: + return ST_OMP_DISTRIBUTE; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_DISTRIBUTE_PARALLEL_DO; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD; + case EXEC_OMP_DISTRIBUTE_SIMD: + return ST_OMP_DISTRIBUTE_SIMD; + case EXEC_OMP_DO_SIMD: + return ST_OMP_DO_SIMD; + case EXEC_OMP_SCAN: + return ST_OMP_SCAN; + case EXEC_OMP_SCOPE: + return ST_OMP_SCOPE; + case EXEC_OMP_SIMD: + return ST_OMP_SIMD; + case EXEC_OMP_TARGET: + return ST_OMP_TARGET; + case EXEC_OMP_TARGET_DATA: + return ST_OMP_TARGET_DATA; + case EXEC_OMP_TARGET_ENTER_DATA: + return ST_OMP_TARGET_ENTER_DATA; + case EXEC_OMP_TARGET_EXIT_DATA: + return ST_OMP_TARGET_EXIT_DATA; + case EXEC_OMP_TARGET_PARALLEL: + return ST_OMP_TARGET_PARALLEL; + case EXEC_OMP_TARGET_PARALLEL_DO: + return ST_OMP_TARGET_PARALLEL_DO; + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + return ST_OMP_TARGET_PARALLEL_DO_SIMD; + case EXEC_OMP_TARGET_PARALLEL_LOOP: + return ST_OMP_TARGET_PARALLEL_LOOP; + case EXEC_OMP_TARGET_SIMD: + return ST_OMP_TARGET_SIMD; + case EXEC_OMP_TARGET_TEAMS: + return ST_OMP_TARGET_TEAMS; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD; + case EXEC_OMP_TARGET_TEAMS_LOOP: + return ST_OMP_TARGET_TEAMS_LOOP; + case EXEC_OMP_TARGET_UPDATE: + return ST_OMP_TARGET_UPDATE; + case EXEC_OMP_TASKGROUP: + return ST_OMP_TASKGROUP; + case EXEC_OMP_TASKLOOP: + return ST_OMP_TASKLOOP; + case EXEC_OMP_TASKLOOP_SIMD: + return ST_OMP_TASKLOOP_SIMD; + case EXEC_OMP_TASKWAIT: + return ST_OMP_TASKWAIT; + case EXEC_OMP_TASKYIELD: + return ST_OMP_TASKYIELD; + case EXEC_OMP_TEAMS: + return ST_OMP_TEAMS; + case EXEC_OMP_TEAMS_DISTRIBUTE: + return ST_OMP_TEAMS_DISTRIBUTE; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + return ST_OMP_TEAMS_DISTRIBUTE_SIMD; + case EXEC_OMP_TEAMS_LOOP: + return ST_OMP_TEAMS_LOOP; + case EXEC_OMP_PARALLEL_DO: + return ST_OMP_PARALLEL_DO; + case EXEC_OMP_PARALLEL_DO_SIMD: + return ST_OMP_PARALLEL_DO_SIMD; + case EXEC_OMP_PARALLEL_LOOP: + return ST_OMP_PARALLEL_LOOP; + case EXEC_OMP_DEPOBJ: + return ST_OMP_DEPOBJ; + default: + gcc_unreachable (); + } +} + +static gfc_statement +oacc_code_to_statement (gfc_code *code) +{ + switch (code->op) + { + case EXEC_OACC_PARALLEL: + return ST_OACC_PARALLEL; + case EXEC_OACC_KERNELS: + return ST_OACC_KERNELS; + case EXEC_OACC_SERIAL: + return ST_OACC_SERIAL; + case EXEC_OACC_DATA: + return ST_OACC_DATA; + case EXEC_OACC_HOST_DATA: + return ST_OACC_HOST_DATA; + case EXEC_OACC_PARALLEL_LOOP: + return ST_OACC_PARALLEL_LOOP; + case EXEC_OACC_KERNELS_LOOP: + return ST_OACC_KERNELS_LOOP; + case EXEC_OACC_SERIAL_LOOP: + return ST_OACC_SERIAL_LOOP; + case EXEC_OACC_LOOP: + return ST_OACC_LOOP; + case EXEC_OACC_ATOMIC: + return ST_OACC_ATOMIC; + case EXEC_OACC_ROUTINE: + return ST_OACC_ROUTINE; + case EXEC_OACC_UPDATE: + return ST_OACC_UPDATE; + case EXEC_OACC_WAIT: + return ST_OACC_WAIT; + case EXEC_OACC_CACHE: + return ST_OACC_CACHE; + case EXEC_OACC_ENTER_DATA: + return ST_OACC_ENTER_DATA; + case EXEC_OACC_EXIT_DATA: + return ST_OACC_EXIT_DATA; + case EXEC_OACC_DECLARE: + return ST_OACC_DECLARE; + default: + gcc_unreachable (); + } +} + +static void +resolve_oacc_directive_inside_omp_region (gfc_code *code) +{ + if (omp_current_ctx != NULL && omp_current_ctx->is_openmp) + { + gfc_statement st = omp_code_to_statement (omp_current_ctx->code); + gfc_statement oacc_st = oacc_code_to_statement (code); + gfc_error ("The %s directive cannot be specified within " + "a %s region at %L", gfc_ascii_statement (oacc_st), + gfc_ascii_statement (st), &code->loc); + } +} + +static void +resolve_omp_directive_inside_oacc_region (gfc_code *code) +{ + if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp) + { + gfc_statement st = oacc_code_to_statement (omp_current_ctx->code); + gfc_statement omp_st = omp_code_to_statement (code); + gfc_error ("The %s directive cannot be specified within " + "a %s region at %L", gfc_ascii_statement (omp_st), + gfc_ascii_statement (st), &code->loc); + } +} + + +static void +resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse, + const char *clause) +{ + gfc_symbol *dovar; + gfc_code *c; + int i; + + for (i = 1; i <= collapse; i++) + { + if (do_code->op == EXEC_DO_WHILE) + { + gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control " + "at %L", &do_code->loc); + break; + } + if (do_code->op == EXEC_DO_CONCURRENT) + { + gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L", + &do_code->loc); + break; + } + gcc_assert (do_code->op == EXEC_DO); + if (do_code->ext.iterator->var->ts.type != BT_INTEGER) + gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L", + &do_code->loc); + dovar = do_code->ext.iterator->var->symtree->n.sym; + if (i > 1) + { + gfc_code *do_code2 = code->block->next; + int j; + + for (j = 1; j < i; j++) + { + gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; + if (dovar == ivar + || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) + || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) + || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) + { + gfc_error ("!$ACC LOOP %s loops don't form rectangular " + "iteration space at %L", clause, &do_code->loc); + break; + } + do_code2 = do_code2->block->next; + } + } + if (i == collapse) + break; + for (c = do_code->next; c; c = c->next) + if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) + { + gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L", + clause, &c->loc); + break; + } + if (c) + break; + do_code = do_code->block; + if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE + && do_code->op != EXEC_DO_CONCURRENT) + { + gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", + clause, &code->loc); + break; + } + do_code = do_code->next; + if (do_code == NULL + || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE + && do_code->op != EXEC_DO_CONCURRENT)) + { + gfc_error ("not enough DO loops for %s !$ACC LOOP at %L", + clause, &code->loc); + break; + } + } +} + + +static void +resolve_oacc_loop_blocks (gfc_code *code) +{ + if (!oacc_is_loop (code)) + return; + + if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang + && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector) + gfc_error ("Tiled loop cannot be parallelized across gangs, workers and " + "vectors at the same time at %L", &code->loc); + + if (code->ext.omp_clauses->tile_list) + { + gfc_expr_list *el; + for (el = code->ext.omp_clauses->tile_list; el; el = el->next) + { + if (el->expr == NULL) + { + /* NULL expressions are used to represent '*' arguments. + Convert those to a 0 expressions. */ + el->expr = gfc_get_constant_expr (BT_INTEGER, + gfc_default_integer_kind, + &code->loc); + mpz_set_si (el->expr->value.integer, 0); + } + else + { + resolve_positive_int_expr (el->expr, "TILE"); + if (el->expr->expr_type != EXPR_CONSTANT) + gfc_error ("TILE requires constant expression at %L", + &code->loc); + } + } + } +} + + +void +gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) +{ + fortran_omp_context ctx; + gfc_omp_clauses *omp_clauses = code->ext.omp_clauses; + gfc_omp_namelist *n; + int list; + + resolve_oacc_loop_blocks (code); + + ctx.code = code; + ctx.sharing_clauses = new hash_set; + ctx.private_iterators = new hash_set; + ctx.previous = omp_current_ctx; + ctx.is_openmp = false; + omp_current_ctx = &ctx; + + for (list = 0; list < OMP_LIST_NUM; list++) + switch (list) + { + case OMP_LIST_PRIVATE: + for (n = omp_clauses->lists[list]; n; n = n->next) + ctx.sharing_clauses->add (n->sym); + break; + default: + break; + } + + gfc_resolve_blocks (code->block, ns); + + omp_current_ctx = ctx.previous; + delete ctx.sharing_clauses; + delete ctx.private_iterators; +} + + +static void +resolve_oacc_loop (gfc_code *code) +{ + gfc_code *do_code; + int collapse; + + if (code->ext.omp_clauses) + resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); + + do_code = code->block->next; + collapse = code->ext.omp_clauses->collapse; + + /* Both collapsed and tiled loops are lowered the same way, but are not + compatible. In gfc_trans_omp_do, the tile is prioritized. */ + if (code->ext.omp_clauses->tile_list) + { + int num = 0; + gfc_expr_list *el; + for (el = code->ext.omp_clauses->tile_list; el; el = el->next) + ++num; + resolve_oacc_nested_loops (code, code->block->next, num, "tiled"); + return; + } + + if (collapse <= 0) + collapse = 1; + resolve_oacc_nested_loops (code, do_code, collapse, "collapsed"); +} + +void +gfc_resolve_oacc_declare (gfc_namespace *ns) +{ + int list; + gfc_omp_namelist *n; + gfc_oacc_declare *oc; + + if (ns->oacc_declare == NULL) + return; + + for (oc = ns->oacc_declare; oc; oc = oc->next) + { + for (list = 0; list < OMP_LIST_NUM; list++) + for (n = oc->clauses->lists[list]; n; n = n->next) + { + n->sym->mark = 0; + if (n->sym->attr.flavor != FL_VARIABLE + && (n->sym->attr.flavor != FL_PROCEDURE + || n->sym->result != n->sym)) + { + gfc_error ("Object %qs is not a variable at %L", + n->sym->name, &oc->loc); + continue; + } + + if (n->expr && n->expr->ref->type == REF_ARRAY) + { + gfc_error ("Array sections: %qs not allowed in" + " !$ACC DECLARE at %L", n->sym->name, &oc->loc); + continue; + } + } + + for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next) + check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT"); + } + + for (oc = ns->oacc_declare; oc; oc = oc->next) + { + for (list = 0; list < OMP_LIST_NUM; list++) + for (n = oc->clauses->lists[list]; n; n = n->next) + { + if (n->sym->mark) + { + gfc_error ("Symbol %qs present on multiple clauses at %L", + n->sym->name, &oc->loc); + continue; + } + else + n->sym->mark = 1; + } + } + + for (oc = ns->oacc_declare; oc; oc = oc->next) + { + for (list = 0; list < OMP_LIST_NUM; list++) + for (n = oc->clauses->lists[list]; n; n = n->next) + n->sym->mark = 0; + } +} + + +void +gfc_resolve_oacc_routines (gfc_namespace *ns) +{ + for (gfc_oacc_routine_name *orn = ns->oacc_routine_names; + orn; + orn = orn->next) + { + gfc_symbol *sym = orn->sym; + if (!sym->attr.external + && !sym->attr.function + && !sym->attr.subroutine) + { + gfc_error ("NAME %qs does not refer to a subroutine or function" + " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); + continue; + } + if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc)) + { + gfc_error ("NAME %qs invalid" + " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc); + continue; + } + } +} + + +void +gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) +{ + resolve_oacc_directive_inside_omp_region (code); + + switch (code->op) + { + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_UPDATE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_WAIT: + case EXEC_OACC_CACHE: + resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true); + break; + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_LOOP: + resolve_oacc_loop (code); + break; + case EXEC_OACC_ATOMIC: + resolve_omp_atomic (code); + break; + default: + break; + } +} + + +/* Resolve OpenMP directive clauses and check various requirements + of each directive. */ + +void +gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) +{ + resolve_omp_directive_inside_oacc_region (code); + + if (code->op != EXEC_OMP_ATOMIC) + gfc_maybe_initialize_eh (); + + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_LOOP: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_SIMD: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + resolve_omp_do (code); + break; + case EXEC_OMP_CANCEL: + case EXEC_OMP_ERROR: + case EXEC_OMP_MASKED: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TEAMS: + case EXEC_OMP_WORKSHARE: + case EXEC_OMP_DEPOBJ: + if (code->ext.omp_clauses) + resolve_omp_clauses (code, code->ext.omp_clauses, NULL); + break; + case EXEC_OMP_TARGET_UPDATE: + if (code->ext.omp_clauses) + resolve_omp_clauses (code, code->ext.omp_clauses, NULL); + if (code->ext.omp_clauses == NULL + || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL + && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL)) + gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or " + "FROM clause", &code->loc); + break; + case EXEC_OMP_ATOMIC: + resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL); + resolve_omp_atomic (code); + break; + case EXEC_OMP_CRITICAL: + resolve_omp_clauses (code, code->ext.omp_clauses, NULL); + if (!code->ext.omp_clauses->critical_name + && code->ext.omp_clauses->hint + && code->ext.omp_clauses->hint->ts.type == BT_INTEGER + && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT + && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0) + gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, " + "except when omp_sync_hint_none is used", &code->loc); + break; + case EXEC_OMP_SCAN: + /* Flag is only used to checking, hence, it is unset afterwards. */ + if (!code->ext.omp_clauses->if_present) + gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with " + "% REDUCTION clause", &code->loc); + code->ext.omp_clauses->if_present = false; + resolve_omp_clauses (code, code->ext.omp_clauses, ns); + break; + default: + break; + } +} + +/* Resolve !$omp declare simd constructs in NS. */ + +void +gfc_resolve_omp_declare_simd (gfc_namespace *ns) +{ + gfc_omp_declare_simd *ods; + + for (ods = ns->omp_declare_simd; ods; ods = ods->next) + { + if (ods->proc_name != NULL + && ods->proc_name != ns->proc_name) + gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure " + "%qs at %L", ns->proc_name->name, &ods->where); + if (ods->clauses) + resolve_omp_clauses (NULL, ods->clauses, ns); + } +} + +struct omp_udr_callback_data +{ + gfc_omp_udr *omp_udr; + bool is_initializer; +}; + +static int +omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data; + if ((*e)->expr_type == EXPR_VARIABLE) + { + if (cd->is_initializer) + { + if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv + && (*e)->symtree->n.sym != cd->omp_udr->omp_orig) + gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in " + "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L", + &(*e)->where); + } + else + { + if ((*e)->symtree->n.sym != cd->omp_udr->omp_out + && (*e)->symtree->n.sym != cd->omp_udr->omp_in) + gfc_error ("Variable other than OMP_OUT or OMP_IN used in " + "combiner of !$OMP DECLARE REDUCTION at %L", + &(*e)->where); + } + } + return 0; +} + +/* Resolve !$omp declare reduction constructs. */ + +static void +gfc_resolve_omp_udr (gfc_omp_udr *omp_udr) +{ + gfc_actual_arglist *a; + const char *predef_name = NULL; + + switch (omp_udr->rop) + { + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_TIMES: + case OMP_REDUCTION_MINUS: + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + case OMP_REDUCTION_MAX: + case OMP_REDUCTION_USER: + break; + default: + gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L", + omp_udr->name, &omp_udr->where); + return; + } + + if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name, + &omp_udr->ts, &predef_name)) + { + if (predef_name) + gfc_error_now ("Redefinition of predefined %s " + "!$OMP DECLARE REDUCTION at %L", + predef_name, &omp_udr->where); + else + gfc_error_now ("Redefinition of predefined " + "!$OMP DECLARE REDUCTION at %L", &omp_udr->where); + return; + } + + if (omp_udr->ts.type == BT_CHARACTER + && omp_udr->ts.u.cl->length + && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not " + "constant at %L", omp_udr->name, &omp_udr->where); + return; + } + + struct omp_udr_callback_data cd; + cd.omp_udr = omp_udr; + cd.is_initializer = false; + gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback, + omp_udr_callback, &cd); + if (omp_udr->combiner_ns->code->op == EXEC_CALL) + { + for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next) + if (a->expr == NULL) + break; + if (a) + gfc_error ("Subroutine call with alternate returns in combiner " + "of !$OMP DECLARE REDUCTION at %L", + &omp_udr->combiner_ns->code->loc); + } + if (omp_udr->initializer_ns) + { + cd.is_initializer = true; + gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback, + omp_udr_callback, &cd); + if (omp_udr->initializer_ns->code->op == EXEC_CALL) + { + for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) + if (a->expr == NULL) + break; + if (a) + gfc_error ("Subroutine call with alternate returns in " + "INITIALIZER clause of !$OMP DECLARE REDUCTION " + "at %L", &omp_udr->initializer_ns->code->loc); + for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next) + if (a->expr + && a->expr->expr_type == EXPR_VARIABLE + && a->expr->symtree->n.sym == omp_udr->omp_priv + && a->expr->ref == NULL) + break; + if (a == NULL) + gfc_error ("One of actual subroutine arguments in INITIALIZER " + "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV " + "at %L", &omp_udr->initializer_ns->code->loc); + } + } + else if (omp_udr->ts.type == BT_DERIVED + && !gfc_has_default_initializer (omp_udr->ts.u.derived)) + { + gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION " + "of derived type without default initializer at %L", + &omp_udr->where); + return; + } +} + +void +gfc_resolve_omp_udrs (gfc_symtree *st) +{ + gfc_omp_udr *omp_udr; + + if (st == NULL) + return; + gfc_resolve_omp_udrs (st->left); + gfc_resolve_omp_udrs (st->right); + for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) + gfc_resolve_omp_udr (omp_udr); +} diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c deleted file mode 100644 index d0fa634..0000000 --- a/gcc/fortran/options.c +++ /dev/null @@ -1,914 +0,0 @@ -/* Parse and display command line options. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "target.h" -#include "tree.h" -#include "gfortran.h" -#include "diagnostic.h" /* For global_dc. */ -#include "opts.h" -#include "toplev.h" /* For save_decoded_options. */ -#include "cpp.h" -#include "langhooks.h" - -gfc_option_t gfc_option; - -#define SET_FLAG(flag, condition, on_value, off_value) \ - do \ - { \ - if (condition) \ - flag = (on_value); \ - else \ - flag = (off_value); \ - } while (0) - -#define SET_BITFLAG2(m) m - -#define SET_BITFLAG(flag, condition, value) \ - SET_BITFLAG2 (SET_FLAG (flag, condition, (flag | (value)), (flag & ~(value)))) - - -/* Set flags that control warnings and errors for different - Fortran standards to their default values. Keep in sync with - libgfortran/runtime/compile_options.c (init_compile_options). */ - -static void -set_default_std_flags (void) -{ - gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL - | GFC_STD_F2003 | GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77 - | GFC_STD_F2008_OBS | GFC_STD_GNU | GFC_STD_LEGACY - | GFC_STD_F2018 | GFC_STD_F2018_DEL | GFC_STD_F2018_OBS; - gfc_option.warn_std = GFC_STD_F2018_DEL | GFC_STD_F95_DEL | GFC_STD_LEGACY; -} - -/* Set (or unset) the DEC extension flags. */ - -static void -set_dec_flags (int value) -{ - /* Set (or unset) other DEC compatibility extensions. */ - SET_BITFLAG (flag_dollar_ok, value, value); - SET_BITFLAG (flag_cray_pointer, value, value); - SET_BITFLAG (flag_dec_structure, value, value); - SET_BITFLAG (flag_dec_intrinsic_ints, value, value); - SET_BITFLAG (flag_dec_static, value, value); - SET_BITFLAG (flag_dec_math, value, value); - SET_BITFLAG (flag_dec_include, value, value); - SET_BITFLAG (flag_dec_format_defaults, value, value); - SET_BITFLAG (flag_dec_blank_format_item, value, value); - SET_BITFLAG (flag_dec_char_conversions, value, value); -} - -/* Finalize DEC flags. */ - -static void -post_dec_flags (int value) -{ - /* Don't warn for legacy code if -fdec is given; however, setting -fno-dec - does not force these warnings. We make one final determination on this - at the end because -std= is always set first; thus, we can avoid - clobbering the user's desired standard settings in gfc_handle_option - e.g. when -fdec and -fno-dec are both given. */ - if (value) - { - gfc_option.allow_std |= GFC_STD_F95_OBS | GFC_STD_F95_DEL - | GFC_STD_GNU | GFC_STD_LEGACY; - gfc_option.warn_std &= ~(GFC_STD_LEGACY | GFC_STD_F95_DEL); - } -} - -/* Enable (or disable) -finit-local-zero. */ - -static void -set_init_local_zero (int value) -{ - gfc_option.flag_init_integer_value = 0; - gfc_option.flag_init_character_value = (char)0; - - SET_FLAG (gfc_option.flag_init_integer, value, GFC_INIT_INTEGER_ON, - GFC_INIT_INTEGER_OFF); - SET_FLAG (gfc_option.flag_init_logical, value, GFC_INIT_LOGICAL_FALSE, - GFC_INIT_LOGICAL_OFF); - SET_FLAG (gfc_option.flag_init_character, value, GFC_INIT_CHARACTER_ON, - GFC_INIT_CHARACTER_OFF); - SET_FLAG (flag_init_real, value, GFC_INIT_REAL_ZERO, GFC_INIT_REAL_OFF); -} - -/* Return language mask for Fortran options. */ - -unsigned int -gfc_option_lang_mask (void) -{ - return CL_Fortran; -} - -/* Initialize options structure OPTS. */ - -void -gfc_init_options_struct (struct gcc_options *opts) -{ - opts->x_flag_errno_math = 0; - opts->frontend_set_flag_errno_math = true; - opts->x_flag_associative_math = -1; - opts->frontend_set_flag_associative_math = true; -} - -/* Get ready for options handling. Keep in sync with - libgfortran/runtime/compile_options.c (init_compile_options). */ - -void -gfc_init_options (unsigned int decoded_options_count, - struct cl_decoded_option *decoded_options) -{ - gfc_source_file = NULL; - gfc_option.module_dir = NULL; - gfc_option.source_form = FORM_UNKNOWN; - gfc_option.max_continue_fixed = 255; - gfc_option.max_continue_free = 255; - gfc_option.max_identifier_length = GFC_MAX_SYMBOL_LEN; - gfc_option.max_errors = 25; - - gfc_option.flag_preprocessed = 0; - gfc_option.flag_d_lines = -1; - set_init_local_zero (0); - - gfc_option.fpe = 0; - /* All except GFC_FPE_INEXACT. */ - gfc_option.fpe_summary = GFC_FPE_INVALID | GFC_FPE_DENORMAL - | GFC_FPE_ZERO | GFC_FPE_OVERFLOW - | GFC_FPE_UNDERFLOW; - gfc_option.rtcheck = 0; - - set_dec_flags (0); - set_default_std_flags (); - - /* Initialize cpp-related options. */ - gfc_cpp_init_options (decoded_options_count, decoded_options); - gfc_diagnostics_init (); -} - - -/* Determine the source form from the filename extension. We assume - case insensitivity. */ - -static gfc_source_form -form_from_filename (const char *filename) -{ - static const struct - { - const char *extension; - gfc_source_form form; - } - exttype[] = - { - { - ".f90", FORM_FREE} - , - { - ".f95", FORM_FREE} - , - { - ".f03", FORM_FREE} - , - { - ".f08", FORM_FREE} - , - { - ".f", FORM_FIXED} - , - { - ".for", FORM_FIXED} - , - { - ".ftn", FORM_FIXED} - , - { - "", FORM_UNKNOWN} - }; /* sentinel value */ - - gfc_source_form f_form; - const char *fileext; - int i; - - /* Find end of file name. Note, filename is either a NULL pointer or - a NUL terminated string. */ - i = 0; - while (filename[i] != '\0') - i++; - - /* Find last period. */ - while (i >= 0 && (filename[i] != '.')) - i--; - - /* Did we see a file extension? */ - if (i < 0) - return FORM_UNKNOWN; /* Nope */ - - /* Get file extension and compare it to others. */ - fileext = &(filename[i]); - - i = -1; - f_form = FORM_UNKNOWN; - do - { - i++; - if (strcasecmp (fileext, exttype[i].extension) == 0) - { - f_form = exttype[i].form; - break; - } - } - while (exttype[i].form != FORM_UNKNOWN); - - return f_form; -} - - -/* Finalize commandline options. */ - -bool -gfc_post_options (const char **pfilename) -{ - const char *filename = *pfilename, *canon_source_file = NULL; - char *source_path; - bool verbose_missing_dir_warn; - int i; - - /* This needs to be after the commandline has been processed. - In Fortran, the options is by default enabled, in C/C++ - by default disabled. - If not enabled explicitly by the user, only warn for -I - and -J, otherwise warn for all include paths. */ - verbose_missing_dir_warn - = (OPTION_SET_P (cpp_warn_missing_include_dirs) - && global_options.x_cpp_warn_missing_include_dirs); - SET_OPTION_IF_UNSET (&global_options, &global_options_set, - cpp_warn_missing_include_dirs, 1); - gfc_check_include_dirs (verbose_missing_dir_warn); - - /* Finalize DEC flags. */ - post_dec_flags (flag_dec); - - /* Excess precision other than "fast" requires front-end - support. */ - if (flag_excess_precision == EXCESS_PRECISION_STANDARD) - sorry ("%<-fexcess-precision=standard%> for Fortran"); - else if (flag_excess_precision == EXCESS_PRECISION_FLOAT16) - sorry ("%<-fexcess-precision=16%> for Fortran"); - - flag_excess_precision = EXCESS_PRECISION_FAST; - - /* Fortran allows associative math - but we cannot reassociate if - we want traps or signed zeros. Cf. also flag_protect_parens. */ - if (flag_associative_math == -1) - flag_associative_math = (!flag_trapping_math && !flag_signed_zeros); - - if (flag_protect_parens == -1) - flag_protect_parens = !optimize_fast; - - /* -Ofast sets implies -fstack-arrays unless an explicit size is set for - stack arrays. */ - if (flag_stack_arrays == -1 && flag_max_stack_var_size == -2) - flag_stack_arrays = optimize_fast; - - /* By default, disable (re)allocation during assignment for -std=f95, - and enable it for F2003/F2008/GNU/Legacy. */ - if (flag_realloc_lhs == -1) - { - if (gfc_option.allow_std & GFC_STD_F2003) - flag_realloc_lhs = 1; - else - flag_realloc_lhs = 0; - } - - /* -fbounds-check is equivalent to -fcheck=bounds */ - if (flag_bounds_check) - gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS; - - if (flag_compare_debug) - flag_dump_fortran_original = 0; - - /* Make -fmax-errors visible to gfortran's diagnostic machinery. */ - if (OPTION_SET_P (flag_max_errors)) - gfc_option.max_errors = flag_max_errors; - - /* Verify the input file name. */ - if (!filename || strcmp (filename, "-") == 0) - { - filename = ""; - } - - if (gfc_option.flag_preprocessed) - { - /* For preprocessed files, if the first tokens are of the form # NUM. - handle the directives so we know the original file name. */ - gfc_source_file = gfc_read_orig_filename (filename, &canon_source_file); - if (gfc_source_file == NULL) - gfc_source_file = filename; - else - *pfilename = gfc_source_file; - } - else - gfc_source_file = filename; - - if (canon_source_file == NULL) - canon_source_file = gfc_source_file; - - /* Adds the path where the source file is to the list of include files. */ - - i = strlen (canon_source_file); - while (i > 0 && !IS_DIR_SEPARATOR (canon_source_file[i])) - i--; - - if (i != 0) - { - source_path = (char *) alloca (i + 1); - memcpy (source_path, canon_source_file, i); - source_path[i] = 0; - /* Only warn if the directory is different from the input file as - if that one is not found, already an error is shown. */ - bool warn = gfc_option.flag_preprocessed && gfc_source_file != filename; - gfc_add_include_path (source_path, true, true, warn, false); - } - else - gfc_add_include_path (".", true, true, false, false); - - if (canon_source_file != gfc_source_file) - free (CONST_CAST (char *, canon_source_file)); - - /* Decide which form the file will be read in as. */ - - if (gfc_option.source_form != FORM_UNKNOWN) - gfc_current_form = gfc_option.source_form; - else - { - gfc_current_form = form_from_filename (filename); - - if (gfc_current_form == FORM_UNKNOWN) - { - gfc_current_form = FORM_FREE; - main_input_filename = filename; - gfc_warning_now (0, "Reading file %qs as free form", - (filename[0] == '\0') ? "" : filename); - } - } - - /* If the user specified -fd-lines-as-{code|comments} verify that we're - in fixed form. */ - if (gfc_current_form == FORM_FREE) - { - if (gfc_option.flag_d_lines == 0) - gfc_warning_now (0, "%<-fd-lines-as-comments%> has no effect " - "in free form"); - else if (gfc_option.flag_d_lines == 1) - gfc_warning_now (0, "%<-fd-lines-as-code%> has no effect in free form"); - - if (warn_line_truncation == -1) - warn_line_truncation = 1; - - /* Enable -Werror=line-truncation when -Werror and -Wno-error have - not been set. */ - if (warn_line_truncation && !OPTION_SET_P (warnings_are_errors) - && (global_dc->classify_diagnostic[OPT_Wline_truncation] == - DK_UNSPECIFIED)) - diagnostic_classify_diagnostic (global_dc, OPT_Wline_truncation, - DK_ERROR, UNKNOWN_LOCATION); - } - else - { - /* With -fdec, set -fd-lines-as-comments by default in fixed form. */ - if (flag_dec && gfc_option.flag_d_lines == -1) - gfc_option.flag_d_lines = 0; - - if (warn_line_truncation == -1) - warn_line_truncation = 0; - } - - /* If -pedantic, warn about the use of GNU extensions. */ - if (pedantic && (gfc_option.allow_std & GFC_STD_GNU) != 0) - gfc_option.warn_std |= GFC_STD_GNU; - /* -std=legacy -pedantic is effectively -std=gnu. */ - if (pedantic && (gfc_option.allow_std & GFC_STD_LEGACY) != 0) - gfc_option.warn_std |= GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_LEGACY; - - /* If the user didn't explicitly specify -f(no)-second-underscore we - use it if we're trying to be compatible with f2c, and not - otherwise. */ - if (flag_second_underscore == -1) - flag_second_underscore = flag_f2c; - - if (!flag_automatic && flag_max_stack_var_size != -2 - && flag_max_stack_var_size != 0) - gfc_warning_now (0, "Flag %<-fno-automatic%> overwrites %<-fmax-stack-var-size=%d%>", - flag_max_stack_var_size); - else if (!flag_automatic && flag_recursive) - gfc_warning_now (OPT_Woverwrite_recursive, "Flag %<-fno-automatic%> " - "overwrites %<-frecursive%>"); - else if (!flag_automatic && (flag_openmp || flag_openacc)) - gfc_warning_now (0, "Flag %<-fno-automatic%> overwrites %<-frecursive%> " - "implied by %qs", flag_openmp ? "-fopenmp" : "-fopenacc"); - else if (flag_max_stack_var_size != -2 && flag_recursive) - gfc_warning_now (0, "Flag %<-frecursive%> overwrites %<-fmax-stack-var-size=%d%>", - flag_max_stack_var_size); - else if (flag_max_stack_var_size != -2 && (flag_openmp || flag_openacc)) - gfc_warning_now (0, "Flag %<-fmax-stack-var-size=%d%> overwrites " - "%<-frecursive%> implied by %qs", flag_max_stack_var_size, - flag_openmp ? "-fopenmp" : "-fopenacc"); - - /* Implement -frecursive as -fmax-stack-var-size=-1. */ - if (flag_recursive) - flag_max_stack_var_size = -1; - - /* Implied -frecursive; implemented as -fmax-stack-var-size=-1. */ - if (flag_max_stack_var_size == -2 && flag_automatic - && (flag_openmp || flag_openacc)) - { - flag_recursive = 1; - flag_max_stack_var_size = -1; - } - - /* Set flag_stack_arrays correctly. */ - if (flag_stack_arrays == -1) - flag_stack_arrays = 0; - - /* Set default. */ - if (flag_max_stack_var_size == -2) - flag_max_stack_var_size = 65536; - - /* Implement -fno-automatic as -fmax-stack-var-size=0. */ - if (!flag_automatic) - flag_max_stack_var_size = 0; - - /* If the user did not specify an inline matmul limit, inline up to the BLAS - limit or up to 30 if no external BLAS is specified. */ - - if (flag_inline_matmul_limit < 0) - { - if (flag_external_blas) - flag_inline_matmul_limit = flag_blas_matmul_limit; - else - flag_inline_matmul_limit = 30; - } - - /* Optimization implies front end optimization, unless the user - specified it directly. */ - - if (flag_frontend_optimize == -1) - flag_frontend_optimize = optimize && !optimize_debug; - - /* Same for front end loop interchange. */ - - if (flag_frontend_loop_interchange == -1) - flag_frontend_loop_interchange = optimize; - - /* Do inline packing by default if optimizing, but not if - optimizing for size. */ - if (flag_inline_arg_packing == -1) - flag_inline_arg_packing = optimize && !optimize_size; - - if (flag_max_array_constructor < 65535) - flag_max_array_constructor = 65535; - - if (flag_fixed_line_length != 0 && flag_fixed_line_length < 7) - gfc_fatal_error ("Fixed line length must be at least seven"); - - if (flag_free_line_length != 0 && flag_free_line_length < 4) - gfc_fatal_error ("Free line length must be at least three"); - - if (flag_max_subrecord_length > MAX_SUBRECORD_LENGTH) - gfc_fatal_error ("Maximum subrecord length cannot exceed %d", - MAX_SUBRECORD_LENGTH); - - gfc_cpp_post_options (verbose_missing_dir_warn); - - if (gfc_option.allow_std & GFC_STD_F2008) - lang_hooks.name = "GNU Fortran2008"; - else if (gfc_option.allow_std & GFC_STD_F2003) - lang_hooks.name = "GNU Fortran2003"; - - return gfc_cpp_preprocess_only (); -} - - -static void -gfc_handle_module_path_options (const char *arg) -{ - - if (gfc_option.module_dir != NULL) - gfc_fatal_error ("gfortran: Only one %<-J%> option allowed"); - - gfc_option.module_dir = XCNEWVEC (char, strlen (arg) + 2); - strcpy (gfc_option.module_dir, arg); - - gfc_add_include_path (gfc_option.module_dir, true, false, true, true); - - strcat (gfc_option.module_dir, "/"); -} - - -/* Handle options -ffpe-trap= and -ffpe-summary=. */ - -static void -gfc_handle_fpe_option (const char *arg, bool trap) -{ - int result, pos = 0, n; - /* precision is a backwards compatibility alias for inexact. */ - static const char * const exception[] = { "invalid", "denormal", "zero", - "overflow", "underflow", - "inexact", "precision", NULL }; - static const int opt_exception[] = { GFC_FPE_INVALID, GFC_FPE_DENORMAL, - GFC_FPE_ZERO, GFC_FPE_OVERFLOW, - GFC_FPE_UNDERFLOW, GFC_FPE_INEXACT, - GFC_FPE_INEXACT, - 0 }; - - /* As the default for -ffpe-summary= is nonzero, set it to 0. */ - if (!trap) - gfc_option.fpe_summary = 0; - - while (*arg) - { - while (*arg == ',') - arg++; - - while (arg[pos] && arg[pos] != ',') - pos++; - - result = 0; - if (!trap && strncmp ("none", arg, pos) == 0) - { - gfc_option.fpe_summary = 0; - arg += pos; - pos = 0; - continue; - } - else if (!trap && strncmp ("all", arg, pos) == 0) - { - gfc_option.fpe_summary = GFC_FPE_INVALID | GFC_FPE_DENORMAL - | GFC_FPE_ZERO | GFC_FPE_OVERFLOW - | GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT; - arg += pos; - pos = 0; - continue; - } - else - for (n = 0; exception[n] != NULL; n++) - { - if (exception[n] && strncmp (exception[n], arg, pos) == 0) - { - if (trap) - gfc_option.fpe |= opt_exception[n]; - else - gfc_option.fpe_summary |= opt_exception[n]; - arg += pos; - pos = 0; - result = 1; - break; - } - } - if (!result && !trap) - gfc_fatal_error ("Argument to %<-ffpe-trap%> is not valid: %s", arg); - else if (!result) - gfc_fatal_error ("Argument to %<-ffpe-summary%> is not valid: %s", arg); - - } -} - - -static void -gfc_handle_runtime_check_option (const char *arg) -{ - int result, pos = 0, n; - static const char * const optname[] = { "all", "bounds", "array-temps", - "recursion", "do", "pointer", - "mem", "bits", NULL }; - static const int optmask[] = { GFC_RTCHECK_ALL, GFC_RTCHECK_BOUNDS, - GFC_RTCHECK_ARRAY_TEMPS, - GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO, - GFC_RTCHECK_POINTER, GFC_RTCHECK_MEM, - GFC_RTCHECK_BITS, 0 }; - - while (*arg) - { - while (*arg == ',') - arg++; - - while (arg[pos] && arg[pos] != ',') - pos++; - - result = 0; - for (n = 0; optname[n] != NULL; n++) - { - if (optname[n] && strncmp (optname[n], arg, pos) == 0) - { - gfc_option.rtcheck |= optmask[n]; - arg += pos; - pos = 0; - result = 1; - break; - } - else if (optname[n] && pos > 3 && startswith (arg, "no-") - && strncmp (optname[n], arg+3, pos-3) == 0) - { - gfc_option.rtcheck &= ~optmask[n]; - arg += pos; - pos = 0; - result = 1; - break; - } - } - if (!result) - gfc_fatal_error ("Argument to %<-fcheck%> is not valid: %s", arg); - } -} - - -/* Handle command-line options. Returns 0 if unrecognized, 1 if - recognized and handled. */ - -bool -gfc_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, - int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED, - const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) -{ - bool result = true; - enum opt_code code = (enum opt_code) scode; - - if (gfc_cpp_handle_option (scode, arg, value) == 1) - return true; - - switch (code) - { - default: - if (cl_options[code].flags & gfc_option_lang_mask ()) - break; - result = false; - break; - - case OPT_fcheck_array_temporaries: - SET_BITFLAG (gfc_option.rtcheck, value, GFC_RTCHECK_ARRAY_TEMPS); - break; - - case OPT_fd_lines_as_code: - gfc_option.flag_d_lines = 1; - break; - - case OPT_fd_lines_as_comments: - gfc_option.flag_d_lines = 0; - break; - - case OPT_ffixed_form: - gfc_option.source_form = FORM_FIXED; - break; - - case OPT_ffree_form: - gfc_option.source_form = FORM_FREE; - break; - - case OPT_static_libgfortran: -#ifndef HAVE_LD_STATIC_DYNAMIC - gfc_fatal_error ("%<-static-libgfortran%> is not supported in this " - "configuration"); -#endif - break; - - case OPT_fintrinsic_modules_path: - case OPT_fintrinsic_modules_path_: - - /* This is needed because omp_lib.h is in a directory together - with intrinsic modules. Do no warn because during testing - without an installed compiler, we would get lots of bogus - warnings for a missing include directory. */ - gfc_add_include_path (arg, false, false, false, true); - - gfc_add_intrinsic_modules_path (arg); - break; - - case OPT_fpreprocessed: - gfc_option.flag_preprocessed = value; - break; - - case OPT_fmax_identifier_length_: - if (value > GFC_MAX_SYMBOL_LEN) - gfc_fatal_error ("Maximum supported identifier length is %d", - GFC_MAX_SYMBOL_LEN); - gfc_option.max_identifier_length = value; - break; - - case OPT_finit_local_zero: - set_init_local_zero (value); - break; - - case OPT_finit_logical_: - if (!strcasecmp (arg, "false")) - gfc_option.flag_init_logical = GFC_INIT_LOGICAL_FALSE; - else if (!strcasecmp (arg, "true")) - gfc_option.flag_init_logical = GFC_INIT_LOGICAL_TRUE; - else - gfc_fatal_error ("Unrecognized option to %<-finit-logical%>: %s", - arg); - break; - - case OPT_finit_integer_: - gfc_option.flag_init_integer = GFC_INIT_INTEGER_ON; - gfc_option.flag_init_integer_value = strtol (arg, NULL, 10); - break; - - case OPT_finit_character_: - if (value >= 0 && value <= 127) - { - gfc_option.flag_init_character = GFC_INIT_CHARACTER_ON; - gfc_option.flag_init_character_value = (char)value; - } - else - gfc_fatal_error ("The value of n in %<-finit-character=n%> must be " - "between 0 and 127"); - break; - - case OPT_I: - gfc_add_include_path (arg, true, false, true, true); - break; - - case OPT_J: - gfc_handle_module_path_options (arg); - break; - - case OPT_ffpe_trap_: - gfc_handle_fpe_option (arg, true); - break; - - case OPT_ffpe_summary_: - gfc_handle_fpe_option (arg, false); - break; - - case OPT_std_f95: - gfc_option.allow_std = GFC_STD_OPT_F95; - gfc_option.warn_std = GFC_STD_F95_OBS; - gfc_option.max_continue_fixed = 19; - gfc_option.max_continue_free = 39; - gfc_option.max_identifier_length = 31; - warn_ampersand = 1; - warn_tabs = 1; - break; - - case OPT_std_f2003: - gfc_option.allow_std = GFC_STD_OPT_F03; - gfc_option.warn_std = GFC_STD_F95_OBS; - gfc_option.max_identifier_length = 63; - warn_ampersand = 1; - warn_tabs = 1; - break; - - case OPT_std_f2008: - gfc_option.allow_std = GFC_STD_OPT_F08; - gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS; - gfc_option.max_identifier_length = 63; - warn_ampersand = 1; - warn_tabs = 1; - break; - - case OPT_std_f2008ts: - case OPT_std_f2018: - gfc_option.allow_std = GFC_STD_OPT_F18; - gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS - | GFC_STD_F2018_OBS; - gfc_option.max_identifier_length = 63; - warn_ampersand = 1; - warn_tabs = 1; - break; - - case OPT_std_gnu: - set_default_std_flags (); - break; - - case OPT_std_legacy: - set_default_std_flags (); - gfc_option.warn_std = 0; - break; - - case OPT_fshort_enums: - /* Handled in language-independent code. */ - break; - - case OPT_fcheck_: - gfc_handle_runtime_check_option (arg); - break; - - case OPT_fdec: - /* Set (or unset) the DEC extension flags. */ - set_dec_flags (value); - break; - } - - Fortran_handle_option_auto (&global_options, &global_options_set, - scode, arg, value, - gfc_option_lang_mask (), kind, - loc, handlers, global_dc); - return result; -} - - -/* Return a string with the options passed to the compiler; used for - Fortran's compiler_options() intrinsic. */ - -char * -gfc_get_option_string (void) -{ - unsigned j; - size_t len, pos; - char *result; - - /* Allocate and return a one-character string with '\0'. */ - if (!save_decoded_options_count) - return XCNEWVEC (char, 1); - - /* Determine required string length. */ - - len = 0; - for (j = 1; j < save_decoded_options_count; j++) - { - switch (save_decoded_options[j].opt_index) - { - case OPT_o: - case OPT_d: - case OPT_dumpbase: - case OPT_dumpbase_ext: - case OPT_dumpdir: - case OPT_quiet: - case OPT_version: - case OPT_fintrinsic_modules_path: - case OPT_fintrinsic_modules_path_: - /* Ignore these. */ - break; - default: - /* Ignore file names. */ - if (save_decoded_options[j].orig_option_with_args_text[0] == '-') - len += 1 - + strlen (save_decoded_options[j].orig_option_with_args_text); - } - } - - result = XCNEWVEC (char, len); - - pos = 0; - for (j = 1; j < save_decoded_options_count; j++) - { - switch (save_decoded_options[j].opt_index) - { - case OPT_o: - case OPT_d: - case OPT_dumpbase: - case OPT_dumpbase_ext: - case OPT_dumpdir: - case OPT_quiet: - case OPT_version: - case OPT_fintrinsic_modules_path: - case OPT_fintrinsic_modules_path_: - /* Ignore these. */ - continue; - - case OPT_cpp_: - /* Use "-cpp" rather than "-cpp=". */ - len = 4; - break; - - default: - /* Ignore file names. */ - if (save_decoded_options[j].orig_option_with_args_text[0] != '-') - continue; - - len = strlen (save_decoded_options[j].orig_option_with_args_text); - } - - memcpy (&result[pos], save_decoded_options[j].orig_option_with_args_text, len); - pos += len; - result[pos++] = ' '; - } - - result[--pos] = '\0'; - return result; -} - -#undef SET_BITFLAG -#undef SET_BITFLAG2 -#undef SET_FLAG diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc new file mode 100644 index 0000000..d0fa634 --- /dev/null +++ b/gcc/fortran/options.cc @@ -0,0 +1,914 @@ +/* Parse and display command line options. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "target.h" +#include "tree.h" +#include "gfortran.h" +#include "diagnostic.h" /* For global_dc. */ +#include "opts.h" +#include "toplev.h" /* For save_decoded_options. */ +#include "cpp.h" +#include "langhooks.h" + +gfc_option_t gfc_option; + +#define SET_FLAG(flag, condition, on_value, off_value) \ + do \ + { \ + if (condition) \ + flag = (on_value); \ + else \ + flag = (off_value); \ + } while (0) + +#define SET_BITFLAG2(m) m + +#define SET_BITFLAG(flag, condition, value) \ + SET_BITFLAG2 (SET_FLAG (flag, condition, (flag | (value)), (flag & ~(value)))) + + +/* Set flags that control warnings and errors for different + Fortran standards to their default values. Keep in sync with + libgfortran/runtime/compile_options.c (init_compile_options). */ + +static void +set_default_std_flags (void) +{ + gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_F2003 | GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77 + | GFC_STD_F2008_OBS | GFC_STD_GNU | GFC_STD_LEGACY + | GFC_STD_F2018 | GFC_STD_F2018_DEL | GFC_STD_F2018_OBS; + gfc_option.warn_std = GFC_STD_F2018_DEL | GFC_STD_F95_DEL | GFC_STD_LEGACY; +} + +/* Set (or unset) the DEC extension flags. */ + +static void +set_dec_flags (int value) +{ + /* Set (or unset) other DEC compatibility extensions. */ + SET_BITFLAG (flag_dollar_ok, value, value); + SET_BITFLAG (flag_cray_pointer, value, value); + SET_BITFLAG (flag_dec_structure, value, value); + SET_BITFLAG (flag_dec_intrinsic_ints, value, value); + SET_BITFLAG (flag_dec_static, value, value); + SET_BITFLAG (flag_dec_math, value, value); + SET_BITFLAG (flag_dec_include, value, value); + SET_BITFLAG (flag_dec_format_defaults, value, value); + SET_BITFLAG (flag_dec_blank_format_item, value, value); + SET_BITFLAG (flag_dec_char_conversions, value, value); +} + +/* Finalize DEC flags. */ + +static void +post_dec_flags (int value) +{ + /* Don't warn for legacy code if -fdec is given; however, setting -fno-dec + does not force these warnings. We make one final determination on this + at the end because -std= is always set first; thus, we can avoid + clobbering the user's desired standard settings in gfc_handle_option + e.g. when -fdec and -fno-dec are both given. */ + if (value) + { + gfc_option.allow_std |= GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_GNU | GFC_STD_LEGACY; + gfc_option.warn_std &= ~(GFC_STD_LEGACY | GFC_STD_F95_DEL); + } +} + +/* Enable (or disable) -finit-local-zero. */ + +static void +set_init_local_zero (int value) +{ + gfc_option.flag_init_integer_value = 0; + gfc_option.flag_init_character_value = (char)0; + + SET_FLAG (gfc_option.flag_init_integer, value, GFC_INIT_INTEGER_ON, + GFC_INIT_INTEGER_OFF); + SET_FLAG (gfc_option.flag_init_logical, value, GFC_INIT_LOGICAL_FALSE, + GFC_INIT_LOGICAL_OFF); + SET_FLAG (gfc_option.flag_init_character, value, GFC_INIT_CHARACTER_ON, + GFC_INIT_CHARACTER_OFF); + SET_FLAG (flag_init_real, value, GFC_INIT_REAL_ZERO, GFC_INIT_REAL_OFF); +} + +/* Return language mask for Fortran options. */ + +unsigned int +gfc_option_lang_mask (void) +{ + return CL_Fortran; +} + +/* Initialize options structure OPTS. */ + +void +gfc_init_options_struct (struct gcc_options *opts) +{ + opts->x_flag_errno_math = 0; + opts->frontend_set_flag_errno_math = true; + opts->x_flag_associative_math = -1; + opts->frontend_set_flag_associative_math = true; +} + +/* Get ready for options handling. Keep in sync with + libgfortran/runtime/compile_options.c (init_compile_options). */ + +void +gfc_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options) +{ + gfc_source_file = NULL; + gfc_option.module_dir = NULL; + gfc_option.source_form = FORM_UNKNOWN; + gfc_option.max_continue_fixed = 255; + gfc_option.max_continue_free = 255; + gfc_option.max_identifier_length = GFC_MAX_SYMBOL_LEN; + gfc_option.max_errors = 25; + + gfc_option.flag_preprocessed = 0; + gfc_option.flag_d_lines = -1; + set_init_local_zero (0); + + gfc_option.fpe = 0; + /* All except GFC_FPE_INEXACT. */ + gfc_option.fpe_summary = GFC_FPE_INVALID | GFC_FPE_DENORMAL + | GFC_FPE_ZERO | GFC_FPE_OVERFLOW + | GFC_FPE_UNDERFLOW; + gfc_option.rtcheck = 0; + + set_dec_flags (0); + set_default_std_flags (); + + /* Initialize cpp-related options. */ + gfc_cpp_init_options (decoded_options_count, decoded_options); + gfc_diagnostics_init (); +} + + +/* Determine the source form from the filename extension. We assume + case insensitivity. */ + +static gfc_source_form +form_from_filename (const char *filename) +{ + static const struct + { + const char *extension; + gfc_source_form form; + } + exttype[] = + { + { + ".f90", FORM_FREE} + , + { + ".f95", FORM_FREE} + , + { + ".f03", FORM_FREE} + , + { + ".f08", FORM_FREE} + , + { + ".f", FORM_FIXED} + , + { + ".for", FORM_FIXED} + , + { + ".ftn", FORM_FIXED} + , + { + "", FORM_UNKNOWN} + }; /* sentinel value */ + + gfc_source_form f_form; + const char *fileext; + int i; + + /* Find end of file name. Note, filename is either a NULL pointer or + a NUL terminated string. */ + i = 0; + while (filename[i] != '\0') + i++; + + /* Find last period. */ + while (i >= 0 && (filename[i] != '.')) + i--; + + /* Did we see a file extension? */ + if (i < 0) + return FORM_UNKNOWN; /* Nope */ + + /* Get file extension and compare it to others. */ + fileext = &(filename[i]); + + i = -1; + f_form = FORM_UNKNOWN; + do + { + i++; + if (strcasecmp (fileext, exttype[i].extension) == 0) + { + f_form = exttype[i].form; + break; + } + } + while (exttype[i].form != FORM_UNKNOWN); + + return f_form; +} + + +/* Finalize commandline options. */ + +bool +gfc_post_options (const char **pfilename) +{ + const char *filename = *pfilename, *canon_source_file = NULL; + char *source_path; + bool verbose_missing_dir_warn; + int i; + + /* This needs to be after the commandline has been processed. + In Fortran, the options is by default enabled, in C/C++ + by default disabled. + If not enabled explicitly by the user, only warn for -I + and -J, otherwise warn for all include paths. */ + verbose_missing_dir_warn + = (OPTION_SET_P (cpp_warn_missing_include_dirs) + && global_options.x_cpp_warn_missing_include_dirs); + SET_OPTION_IF_UNSET (&global_options, &global_options_set, + cpp_warn_missing_include_dirs, 1); + gfc_check_include_dirs (verbose_missing_dir_warn); + + /* Finalize DEC flags. */ + post_dec_flags (flag_dec); + + /* Excess precision other than "fast" requires front-end + support. */ + if (flag_excess_precision == EXCESS_PRECISION_STANDARD) + sorry ("%<-fexcess-precision=standard%> for Fortran"); + else if (flag_excess_precision == EXCESS_PRECISION_FLOAT16) + sorry ("%<-fexcess-precision=16%> for Fortran"); + + flag_excess_precision = EXCESS_PRECISION_FAST; + + /* Fortran allows associative math - but we cannot reassociate if + we want traps or signed zeros. Cf. also flag_protect_parens. */ + if (flag_associative_math == -1) + flag_associative_math = (!flag_trapping_math && !flag_signed_zeros); + + if (flag_protect_parens == -1) + flag_protect_parens = !optimize_fast; + + /* -Ofast sets implies -fstack-arrays unless an explicit size is set for + stack arrays. */ + if (flag_stack_arrays == -1 && flag_max_stack_var_size == -2) + flag_stack_arrays = optimize_fast; + + /* By default, disable (re)allocation during assignment for -std=f95, + and enable it for F2003/F2008/GNU/Legacy. */ + if (flag_realloc_lhs == -1) + { + if (gfc_option.allow_std & GFC_STD_F2003) + flag_realloc_lhs = 1; + else + flag_realloc_lhs = 0; + } + + /* -fbounds-check is equivalent to -fcheck=bounds */ + if (flag_bounds_check) + gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS; + + if (flag_compare_debug) + flag_dump_fortran_original = 0; + + /* Make -fmax-errors visible to gfortran's diagnostic machinery. */ + if (OPTION_SET_P (flag_max_errors)) + gfc_option.max_errors = flag_max_errors; + + /* Verify the input file name. */ + if (!filename || strcmp (filename, "-") == 0) + { + filename = ""; + } + + if (gfc_option.flag_preprocessed) + { + /* For preprocessed files, if the first tokens are of the form # NUM. + handle the directives so we know the original file name. */ + gfc_source_file = gfc_read_orig_filename (filename, &canon_source_file); + if (gfc_source_file == NULL) + gfc_source_file = filename; + else + *pfilename = gfc_source_file; + } + else + gfc_source_file = filename; + + if (canon_source_file == NULL) + canon_source_file = gfc_source_file; + + /* Adds the path where the source file is to the list of include files. */ + + i = strlen (canon_source_file); + while (i > 0 && !IS_DIR_SEPARATOR (canon_source_file[i])) + i--; + + if (i != 0) + { + source_path = (char *) alloca (i + 1); + memcpy (source_path, canon_source_file, i); + source_path[i] = 0; + /* Only warn if the directory is different from the input file as + if that one is not found, already an error is shown. */ + bool warn = gfc_option.flag_preprocessed && gfc_source_file != filename; + gfc_add_include_path (source_path, true, true, warn, false); + } + else + gfc_add_include_path (".", true, true, false, false); + + if (canon_source_file != gfc_source_file) + free (CONST_CAST (char *, canon_source_file)); + + /* Decide which form the file will be read in as. */ + + if (gfc_option.source_form != FORM_UNKNOWN) + gfc_current_form = gfc_option.source_form; + else + { + gfc_current_form = form_from_filename (filename); + + if (gfc_current_form == FORM_UNKNOWN) + { + gfc_current_form = FORM_FREE; + main_input_filename = filename; + gfc_warning_now (0, "Reading file %qs as free form", + (filename[0] == '\0') ? "" : filename); + } + } + + /* If the user specified -fd-lines-as-{code|comments} verify that we're + in fixed form. */ + if (gfc_current_form == FORM_FREE) + { + if (gfc_option.flag_d_lines == 0) + gfc_warning_now (0, "%<-fd-lines-as-comments%> has no effect " + "in free form"); + else if (gfc_option.flag_d_lines == 1) + gfc_warning_now (0, "%<-fd-lines-as-code%> has no effect in free form"); + + if (warn_line_truncation == -1) + warn_line_truncation = 1; + + /* Enable -Werror=line-truncation when -Werror and -Wno-error have + not been set. */ + if (warn_line_truncation && !OPTION_SET_P (warnings_are_errors) + && (global_dc->classify_diagnostic[OPT_Wline_truncation] == + DK_UNSPECIFIED)) + diagnostic_classify_diagnostic (global_dc, OPT_Wline_truncation, + DK_ERROR, UNKNOWN_LOCATION); + } + else + { + /* With -fdec, set -fd-lines-as-comments by default in fixed form. */ + if (flag_dec && gfc_option.flag_d_lines == -1) + gfc_option.flag_d_lines = 0; + + if (warn_line_truncation == -1) + warn_line_truncation = 0; + } + + /* If -pedantic, warn about the use of GNU extensions. */ + if (pedantic && (gfc_option.allow_std & GFC_STD_GNU) != 0) + gfc_option.warn_std |= GFC_STD_GNU; + /* -std=legacy -pedantic is effectively -std=gnu. */ + if (pedantic && (gfc_option.allow_std & GFC_STD_LEGACY) != 0) + gfc_option.warn_std |= GFC_STD_F95_OBS | GFC_STD_F95_DEL | GFC_STD_LEGACY; + + /* If the user didn't explicitly specify -f(no)-second-underscore we + use it if we're trying to be compatible with f2c, and not + otherwise. */ + if (flag_second_underscore == -1) + flag_second_underscore = flag_f2c; + + if (!flag_automatic && flag_max_stack_var_size != -2 + && flag_max_stack_var_size != 0) + gfc_warning_now (0, "Flag %<-fno-automatic%> overwrites %<-fmax-stack-var-size=%d%>", + flag_max_stack_var_size); + else if (!flag_automatic && flag_recursive) + gfc_warning_now (OPT_Woverwrite_recursive, "Flag %<-fno-automatic%> " + "overwrites %<-frecursive%>"); + else if (!flag_automatic && (flag_openmp || flag_openacc)) + gfc_warning_now (0, "Flag %<-fno-automatic%> overwrites %<-frecursive%> " + "implied by %qs", flag_openmp ? "-fopenmp" : "-fopenacc"); + else if (flag_max_stack_var_size != -2 && flag_recursive) + gfc_warning_now (0, "Flag %<-frecursive%> overwrites %<-fmax-stack-var-size=%d%>", + flag_max_stack_var_size); + else if (flag_max_stack_var_size != -2 && (flag_openmp || flag_openacc)) + gfc_warning_now (0, "Flag %<-fmax-stack-var-size=%d%> overwrites " + "%<-frecursive%> implied by %qs", flag_max_stack_var_size, + flag_openmp ? "-fopenmp" : "-fopenacc"); + + /* Implement -frecursive as -fmax-stack-var-size=-1. */ + if (flag_recursive) + flag_max_stack_var_size = -1; + + /* Implied -frecursive; implemented as -fmax-stack-var-size=-1. */ + if (flag_max_stack_var_size == -2 && flag_automatic + && (flag_openmp || flag_openacc)) + { + flag_recursive = 1; + flag_max_stack_var_size = -1; + } + + /* Set flag_stack_arrays correctly. */ + if (flag_stack_arrays == -1) + flag_stack_arrays = 0; + + /* Set default. */ + if (flag_max_stack_var_size == -2) + flag_max_stack_var_size = 65536; + + /* Implement -fno-automatic as -fmax-stack-var-size=0. */ + if (!flag_automatic) + flag_max_stack_var_size = 0; + + /* If the user did not specify an inline matmul limit, inline up to the BLAS + limit or up to 30 if no external BLAS is specified. */ + + if (flag_inline_matmul_limit < 0) + { + if (flag_external_blas) + flag_inline_matmul_limit = flag_blas_matmul_limit; + else + flag_inline_matmul_limit = 30; + } + + /* Optimization implies front end optimization, unless the user + specified it directly. */ + + if (flag_frontend_optimize == -1) + flag_frontend_optimize = optimize && !optimize_debug; + + /* Same for front end loop interchange. */ + + if (flag_frontend_loop_interchange == -1) + flag_frontend_loop_interchange = optimize; + + /* Do inline packing by default if optimizing, but not if + optimizing for size. */ + if (flag_inline_arg_packing == -1) + flag_inline_arg_packing = optimize && !optimize_size; + + if (flag_max_array_constructor < 65535) + flag_max_array_constructor = 65535; + + if (flag_fixed_line_length != 0 && flag_fixed_line_length < 7) + gfc_fatal_error ("Fixed line length must be at least seven"); + + if (flag_free_line_length != 0 && flag_free_line_length < 4) + gfc_fatal_error ("Free line length must be at least three"); + + if (flag_max_subrecord_length > MAX_SUBRECORD_LENGTH) + gfc_fatal_error ("Maximum subrecord length cannot exceed %d", + MAX_SUBRECORD_LENGTH); + + gfc_cpp_post_options (verbose_missing_dir_warn); + + if (gfc_option.allow_std & GFC_STD_F2008) + lang_hooks.name = "GNU Fortran2008"; + else if (gfc_option.allow_std & GFC_STD_F2003) + lang_hooks.name = "GNU Fortran2003"; + + return gfc_cpp_preprocess_only (); +} + + +static void +gfc_handle_module_path_options (const char *arg) +{ + + if (gfc_option.module_dir != NULL) + gfc_fatal_error ("gfortran: Only one %<-J%> option allowed"); + + gfc_option.module_dir = XCNEWVEC (char, strlen (arg) + 2); + strcpy (gfc_option.module_dir, arg); + + gfc_add_include_path (gfc_option.module_dir, true, false, true, true); + + strcat (gfc_option.module_dir, "/"); +} + + +/* Handle options -ffpe-trap= and -ffpe-summary=. */ + +static void +gfc_handle_fpe_option (const char *arg, bool trap) +{ + int result, pos = 0, n; + /* precision is a backwards compatibility alias for inexact. */ + static const char * const exception[] = { "invalid", "denormal", "zero", + "overflow", "underflow", + "inexact", "precision", NULL }; + static const int opt_exception[] = { GFC_FPE_INVALID, GFC_FPE_DENORMAL, + GFC_FPE_ZERO, GFC_FPE_OVERFLOW, + GFC_FPE_UNDERFLOW, GFC_FPE_INEXACT, + GFC_FPE_INEXACT, + 0 }; + + /* As the default for -ffpe-summary= is nonzero, set it to 0. */ + if (!trap) + gfc_option.fpe_summary = 0; + + while (*arg) + { + while (*arg == ',') + arg++; + + while (arg[pos] && arg[pos] != ',') + pos++; + + result = 0; + if (!trap && strncmp ("none", arg, pos) == 0) + { + gfc_option.fpe_summary = 0; + arg += pos; + pos = 0; + continue; + } + else if (!trap && strncmp ("all", arg, pos) == 0) + { + gfc_option.fpe_summary = GFC_FPE_INVALID | GFC_FPE_DENORMAL + | GFC_FPE_ZERO | GFC_FPE_OVERFLOW + | GFC_FPE_UNDERFLOW | GFC_FPE_INEXACT; + arg += pos; + pos = 0; + continue; + } + else + for (n = 0; exception[n] != NULL; n++) + { + if (exception[n] && strncmp (exception[n], arg, pos) == 0) + { + if (trap) + gfc_option.fpe |= opt_exception[n]; + else + gfc_option.fpe_summary |= opt_exception[n]; + arg += pos; + pos = 0; + result = 1; + break; + } + } + if (!result && !trap) + gfc_fatal_error ("Argument to %<-ffpe-trap%> is not valid: %s", arg); + else if (!result) + gfc_fatal_error ("Argument to %<-ffpe-summary%> is not valid: %s", arg); + + } +} + + +static void +gfc_handle_runtime_check_option (const char *arg) +{ + int result, pos = 0, n; + static const char * const optname[] = { "all", "bounds", "array-temps", + "recursion", "do", "pointer", + "mem", "bits", NULL }; + static const int optmask[] = { GFC_RTCHECK_ALL, GFC_RTCHECK_BOUNDS, + GFC_RTCHECK_ARRAY_TEMPS, + GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO, + GFC_RTCHECK_POINTER, GFC_RTCHECK_MEM, + GFC_RTCHECK_BITS, 0 }; + + while (*arg) + { + while (*arg == ',') + arg++; + + while (arg[pos] && arg[pos] != ',') + pos++; + + result = 0; + for (n = 0; optname[n] != NULL; n++) + { + if (optname[n] && strncmp (optname[n], arg, pos) == 0) + { + gfc_option.rtcheck |= optmask[n]; + arg += pos; + pos = 0; + result = 1; + break; + } + else if (optname[n] && pos > 3 && startswith (arg, "no-") + && strncmp (optname[n], arg+3, pos-3) == 0) + { + gfc_option.rtcheck &= ~optmask[n]; + arg += pos; + pos = 0; + result = 1; + break; + } + } + if (!result) + gfc_fatal_error ("Argument to %<-fcheck%> is not valid: %s", arg); + } +} + + +/* Handle command-line options. Returns 0 if unrecognized, 1 if + recognized and handled. */ + +bool +gfc_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, + int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED, + const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) +{ + bool result = true; + enum opt_code code = (enum opt_code) scode; + + if (gfc_cpp_handle_option (scode, arg, value) == 1) + return true; + + switch (code) + { + default: + if (cl_options[code].flags & gfc_option_lang_mask ()) + break; + result = false; + break; + + case OPT_fcheck_array_temporaries: + SET_BITFLAG (gfc_option.rtcheck, value, GFC_RTCHECK_ARRAY_TEMPS); + break; + + case OPT_fd_lines_as_code: + gfc_option.flag_d_lines = 1; + break; + + case OPT_fd_lines_as_comments: + gfc_option.flag_d_lines = 0; + break; + + case OPT_ffixed_form: + gfc_option.source_form = FORM_FIXED; + break; + + case OPT_ffree_form: + gfc_option.source_form = FORM_FREE; + break; + + case OPT_static_libgfortran: +#ifndef HAVE_LD_STATIC_DYNAMIC + gfc_fatal_error ("%<-static-libgfortran%> is not supported in this " + "configuration"); +#endif + break; + + case OPT_fintrinsic_modules_path: + case OPT_fintrinsic_modules_path_: + + /* This is needed because omp_lib.h is in a directory together + with intrinsic modules. Do no warn because during testing + without an installed compiler, we would get lots of bogus + warnings for a missing include directory. */ + gfc_add_include_path (arg, false, false, false, true); + + gfc_add_intrinsic_modules_path (arg); + break; + + case OPT_fpreprocessed: + gfc_option.flag_preprocessed = value; + break; + + case OPT_fmax_identifier_length_: + if (value > GFC_MAX_SYMBOL_LEN) + gfc_fatal_error ("Maximum supported identifier length is %d", + GFC_MAX_SYMBOL_LEN); + gfc_option.max_identifier_length = value; + break; + + case OPT_finit_local_zero: + set_init_local_zero (value); + break; + + case OPT_finit_logical_: + if (!strcasecmp (arg, "false")) + gfc_option.flag_init_logical = GFC_INIT_LOGICAL_FALSE; + else if (!strcasecmp (arg, "true")) + gfc_option.flag_init_logical = GFC_INIT_LOGICAL_TRUE; + else + gfc_fatal_error ("Unrecognized option to %<-finit-logical%>: %s", + arg); + break; + + case OPT_finit_integer_: + gfc_option.flag_init_integer = GFC_INIT_INTEGER_ON; + gfc_option.flag_init_integer_value = strtol (arg, NULL, 10); + break; + + case OPT_finit_character_: + if (value >= 0 && value <= 127) + { + gfc_option.flag_init_character = GFC_INIT_CHARACTER_ON; + gfc_option.flag_init_character_value = (char)value; + } + else + gfc_fatal_error ("The value of n in %<-finit-character=n%> must be " + "between 0 and 127"); + break; + + case OPT_I: + gfc_add_include_path (arg, true, false, true, true); + break; + + case OPT_J: + gfc_handle_module_path_options (arg); + break; + + case OPT_ffpe_trap_: + gfc_handle_fpe_option (arg, true); + break; + + case OPT_ffpe_summary_: + gfc_handle_fpe_option (arg, false); + break; + + case OPT_std_f95: + gfc_option.allow_std = GFC_STD_OPT_F95; + gfc_option.warn_std = GFC_STD_F95_OBS; + gfc_option.max_continue_fixed = 19; + gfc_option.max_continue_free = 39; + gfc_option.max_identifier_length = 31; + warn_ampersand = 1; + warn_tabs = 1; + break; + + case OPT_std_f2003: + gfc_option.allow_std = GFC_STD_OPT_F03; + gfc_option.warn_std = GFC_STD_F95_OBS; + gfc_option.max_identifier_length = 63; + warn_ampersand = 1; + warn_tabs = 1; + break; + + case OPT_std_f2008: + gfc_option.allow_std = GFC_STD_OPT_F08; + gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS; + gfc_option.max_identifier_length = 63; + warn_ampersand = 1; + warn_tabs = 1; + break; + + case OPT_std_f2008ts: + case OPT_std_f2018: + gfc_option.allow_std = GFC_STD_OPT_F18; + gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2008_OBS + | GFC_STD_F2018_OBS; + gfc_option.max_identifier_length = 63; + warn_ampersand = 1; + warn_tabs = 1; + break; + + case OPT_std_gnu: + set_default_std_flags (); + break; + + case OPT_std_legacy: + set_default_std_flags (); + gfc_option.warn_std = 0; + break; + + case OPT_fshort_enums: + /* Handled in language-independent code. */ + break; + + case OPT_fcheck_: + gfc_handle_runtime_check_option (arg); + break; + + case OPT_fdec: + /* Set (or unset) the DEC extension flags. */ + set_dec_flags (value); + break; + } + + Fortran_handle_option_auto (&global_options, &global_options_set, + scode, arg, value, + gfc_option_lang_mask (), kind, + loc, handlers, global_dc); + return result; +} + + +/* Return a string with the options passed to the compiler; used for + Fortran's compiler_options() intrinsic. */ + +char * +gfc_get_option_string (void) +{ + unsigned j; + size_t len, pos; + char *result; + + /* Allocate and return a one-character string with '\0'. */ + if (!save_decoded_options_count) + return XCNEWVEC (char, 1); + + /* Determine required string length. */ + + len = 0; + for (j = 1; j < save_decoded_options_count; j++) + { + switch (save_decoded_options[j].opt_index) + { + case OPT_o: + case OPT_d: + case OPT_dumpbase: + case OPT_dumpbase_ext: + case OPT_dumpdir: + case OPT_quiet: + case OPT_version: + case OPT_fintrinsic_modules_path: + case OPT_fintrinsic_modules_path_: + /* Ignore these. */ + break; + default: + /* Ignore file names. */ + if (save_decoded_options[j].orig_option_with_args_text[0] == '-') + len += 1 + + strlen (save_decoded_options[j].orig_option_with_args_text); + } + } + + result = XCNEWVEC (char, len); + + pos = 0; + for (j = 1; j < save_decoded_options_count; j++) + { + switch (save_decoded_options[j].opt_index) + { + case OPT_o: + case OPT_d: + case OPT_dumpbase: + case OPT_dumpbase_ext: + case OPT_dumpdir: + case OPT_quiet: + case OPT_version: + case OPT_fintrinsic_modules_path: + case OPT_fintrinsic_modules_path_: + /* Ignore these. */ + continue; + + case OPT_cpp_: + /* Use "-cpp" rather than "-cpp=". */ + len = 4; + break; + + default: + /* Ignore file names. */ + if (save_decoded_options[j].orig_option_with_args_text[0] != '-') + continue; + + len = strlen (save_decoded_options[j].orig_option_with_args_text); + } + + memcpy (&result[pos], save_decoded_options[j].orig_option_with_args_text, len); + pos += len; + result[pos++] = ' '; + } + + result[--pos] = '\0'; + return result; +} + +#undef SET_BITFLAG +#undef SET_BITFLAG2 +#undef SET_FLAG diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c deleted file mode 100644 index c04ad77..0000000 --- a/gcc/fortran/parse.c +++ /dev/null @@ -1,6987 +0,0 @@ -/* Main parser. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include -#include "match.h" -#include "parse.h" -#include "tree-core.h" -#include "omp-general.h" - -/* Current statement label. Zero means no statement label. Because new_st - can get wiped during statement matching, we have to keep it separate. */ - -gfc_st_label *gfc_statement_label; - -static locus label_locus; -static jmp_buf eof_buf; - -gfc_state_data *gfc_state_stack; -static bool last_was_use_stmt = false; - -/* TODO: Re-order functions to kill these forward decls. */ -static void check_statement_label (gfc_statement); -static void undo_new_statement (void); -static void reject_statement (void); - - -/* A sort of half-matching function. We try to match the word on the - input with the passed string. If this succeeds, we call the - keyword-dependent matching function that will match the rest of the - statement. For single keywords, the matching subroutine is - gfc_match_eos(). */ - -static match -match_word (const char *str, match (*subr) (void), locus *old_locus) -{ - match m; - - if (str != NULL) - { - m = gfc_match (str); - if (m != MATCH_YES) - return m; - } - - m = (*subr) (); - - if (m != MATCH_YES) - { - gfc_current_locus = *old_locus; - reject_statement (); - } - - return m; -} - - -/* Like match_word, but if str is matched, set a flag that it - was matched. */ -static match -match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus, - bool *simd_matched) -{ - match m; - - if (str != NULL) - { - m = gfc_match (str); - if (m != MATCH_YES) - return m; - *simd_matched = true; - } - - m = (*subr) (); - - if (m != MATCH_YES) - { - gfc_current_locus = *old_locus; - reject_statement (); - } - - return m; -} - - -/* Load symbols from all USE statements encountered in this scoping unit. */ - -static void -use_modules (void) -{ - gfc_error_buffer old_error; - - gfc_push_error (&old_error); - gfc_buffer_error (false); - gfc_use_modules (); - gfc_buffer_error (true); - gfc_pop_error (&old_error); - gfc_commit_symbols (); - gfc_warning_check (); - gfc_current_ns->old_equiv = gfc_current_ns->equiv; - gfc_current_ns->old_data = gfc_current_ns->data; - last_was_use_stmt = false; -} - - -/* Figure out what the next statement is, (mostly) regardless of - proper ordering. The do...while(0) is there to prevent if/else - ambiguity. */ - -#define match(keyword, subr, st) \ - do { \ - if (match_word (keyword, subr, &old_locus) == MATCH_YES) \ - return st; \ - else \ - undo_new_statement (); \ - } while (0) - - -/* This is a specialist version of decode_statement that is used - for the specification statements in a function, whose - characteristics are deferred into the specification statements. - eg.: INTEGER (king = mykind) foo () - USE mymodule, ONLY mykind..... - The KIND parameter needs a return after USE or IMPORT, whereas - derived type declarations can occur anywhere, up the executable - block. ST_GET_FCN_CHARACTERISTICS is returned when we have run - out of the correct kind of specification statements. */ -static gfc_statement -decode_specification_statement (void) -{ - gfc_statement st; - locus old_locus; - char c; - - if (gfc_match_eos () == MATCH_YES) - return ST_NONE; - - old_locus = gfc_current_locus; - - if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) - { - last_was_use_stmt = true; - return ST_USE; - } - else - { - undo_new_statement (); - if (last_was_use_stmt) - use_modules (); - } - - match ("import", gfc_match_import, ST_IMPORT); - - if (gfc_current_block ()->result->ts.type != BT_DERIVED) - goto end_of_block; - - match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); - match (NULL, gfc_match_data_decl, ST_DATA_DECL); - match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); - - /* General statement matching: Instead of testing every possible - statement, we eliminate most possibilities by peeking at the - first character. */ - - c = gfc_peek_ascii_char (); - - switch (c) - { - case 'a': - match ("abstract% interface", gfc_match_abstract_interface, - ST_INTERFACE); - match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); - match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); - match ("automatic", gfc_match_automatic, ST_ATTR_DECL); - break; - - case 'b': - match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); - break; - - case 'c': - match ("codimension", gfc_match_codimension, ST_ATTR_DECL); - match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); - break; - - case 'd': - match ("data", gfc_match_data, ST_DATA); - match ("dimension", gfc_match_dimension, ST_ATTR_DECL); - break; - - case 'e': - match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); - match ("entry% ", gfc_match_entry, ST_ENTRY); - match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); - match ("external", gfc_match_external, ST_ATTR_DECL); - break; - - case 'f': - match ("format", gfc_match_format, ST_FORMAT); - break; - - case 'g': - break; - - case 'i': - match ("implicit", gfc_match_implicit, ST_IMPLICIT); - match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); - match ("interface", gfc_match_interface, ST_INTERFACE); - match ("intent", gfc_match_intent, ST_ATTR_DECL); - match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); - break; - - case 'm': - break; - - case 'n': - match ("namelist", gfc_match_namelist, ST_NAMELIST); - break; - - case 'o': - match ("optional", gfc_match_optional, ST_ATTR_DECL); - break; - - case 'p': - match ("parameter", gfc_match_parameter, ST_PARAMETER); - match ("pointer", gfc_match_pointer, ST_ATTR_DECL); - if (gfc_match_private (&st) == MATCH_YES) - return st; - match ("procedure", gfc_match_procedure, ST_PROCEDURE); - if (gfc_match_public (&st) == MATCH_YES) - return st; - match ("protected", gfc_match_protected, ST_ATTR_DECL); - break; - - case 'r': - break; - - case 's': - match ("save", gfc_match_save, ST_ATTR_DECL); - match ("static", gfc_match_static, ST_ATTR_DECL); - match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); - break; - - case 't': - match ("target", gfc_match_target, ST_ATTR_DECL); - match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); - break; - - case 'u': - break; - - case 'v': - match ("value", gfc_match_value, ST_ATTR_DECL); - match ("volatile", gfc_match_volatile, ST_ATTR_DECL); - break; - - case 'w': - break; - } - - /* This is not a specification statement. See if any of the matchers - has stored an error message of some sort. */ - -end_of_block: - gfc_clear_error (); - gfc_buffer_error (false); - gfc_current_locus = old_locus; - - return ST_GET_FCN_CHARACTERISTICS; -} - -static bool in_specification_block; - -/* This is the primary 'decode_statement'. */ -static gfc_statement -decode_statement (void) -{ - gfc_statement st; - locus old_locus; - match m = MATCH_NO; - char c; - - gfc_enforce_clean_symbol_state (); - - gfc_clear_error (); /* Clear any pending errors. */ - gfc_clear_warning (); /* Clear any pending warnings. */ - - gfc_matching_function = false; - - if (gfc_match_eos () == MATCH_YES) - return ST_NONE; - - if (gfc_current_state () == COMP_FUNCTION - && gfc_current_block ()->result->ts.kind == -1) - return decode_specification_statement (); - - old_locus = gfc_current_locus; - - c = gfc_peek_ascii_char (); - - if (c == 'u') - { - if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) - { - last_was_use_stmt = true; - return ST_USE; - } - else - undo_new_statement (); - } - - if (last_was_use_stmt) - use_modules (); - - /* Try matching a data declaration or function declaration. The - input "REALFUNCTIONA(N)" can mean several things in different - contexts, so it (and its relatives) get special treatment. */ - - if (gfc_current_state () == COMP_NONE - || gfc_current_state () == COMP_INTERFACE - || gfc_current_state () == COMP_CONTAINS) - { - gfc_matching_function = true; - m = gfc_match_function_decl (); - if (m == MATCH_YES) - return ST_FUNCTION; - else if (m == MATCH_ERROR) - reject_statement (); - else - gfc_undo_symbols (); - gfc_current_locus = old_locus; - } - gfc_matching_function = false; - - /* Legacy parameter statements are ambiguous with assignments so try parameter - first. */ - match ("parameter", gfc_match_parameter, ST_PARAMETER); - - /* Match statements whose error messages are meant to be overwritten - by something better. */ - - match (NULL, gfc_match_assignment, ST_ASSIGNMENT); - match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT); - - if (in_specification_block) - { - m = match_word (NULL, gfc_match_st_function, &old_locus); - if (m == MATCH_YES) - return ST_STATEMENT_FUNCTION; - } - - if (!(in_specification_block && m == MATCH_ERROR)) - { - match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT); - } - - match (NULL, gfc_match_data_decl, ST_DATA_DECL); - match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); - - /* Try to match a subroutine statement, which has the same optional - prefixes that functions can have. */ - - if (gfc_match_subroutine () == MATCH_YES) - return ST_SUBROUTINE; - gfc_undo_symbols (); - gfc_current_locus = old_locus; - - if (gfc_match_submod_proc () == MATCH_YES) - { - if (gfc_new_block->attr.subroutine) - return ST_SUBROUTINE; - else if (gfc_new_block->attr.function) - return ST_FUNCTION; - } - gfc_undo_symbols (); - gfc_current_locus = old_locus; - - /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE - statements, which might begin with a block label. The match functions for - these statements are unusual in that their keyword is not seen before - the matcher is called. */ - - if (gfc_match_if (&st) == MATCH_YES) - return st; - gfc_undo_symbols (); - gfc_current_locus = old_locus; - - if (gfc_match_where (&st) == MATCH_YES) - return st; - gfc_undo_symbols (); - gfc_current_locus = old_locus; - - if (gfc_match_forall (&st) == MATCH_YES) - return st; - gfc_undo_symbols (); - gfc_current_locus = old_locus; - - /* Try to match TYPE as an alias for PRINT. */ - if (gfc_match_type (&st) == MATCH_YES) - return st; - gfc_undo_symbols (); - gfc_current_locus = old_locus; - - match (NULL, gfc_match_do, ST_DO); - match (NULL, gfc_match_block, ST_BLOCK); - match (NULL, gfc_match_associate, ST_ASSOCIATE); - match (NULL, gfc_match_critical, ST_CRITICAL); - match (NULL, gfc_match_select, ST_SELECT_CASE); - match (NULL, gfc_match_select_type, ST_SELECT_TYPE); - match (NULL, gfc_match_select_rank, ST_SELECT_RANK); - - /* General statement matching: Instead of testing every possible - statement, we eliminate most possibilities by peeking at the - first character. */ - - switch (c) - { - case 'a': - match ("abstract% interface", gfc_match_abstract_interface, - ST_INTERFACE); - match ("allocate", gfc_match_allocate, ST_ALLOCATE); - match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); - match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); - match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); - match ("automatic", gfc_match_automatic, ST_ATTR_DECL); - break; - - case 'b': - match ("backspace", gfc_match_backspace, ST_BACKSPACE); - match ("block data", gfc_match_block_data, ST_BLOCK_DATA); - match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); - break; - - case 'c': - match ("call", gfc_match_call, ST_CALL); - match ("change team", gfc_match_change_team, ST_CHANGE_TEAM); - match ("close", gfc_match_close, ST_CLOSE); - match ("continue", gfc_match_continue, ST_CONTINUE); - match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); - match ("cycle", gfc_match_cycle, ST_CYCLE); - match ("case", gfc_match_case, ST_CASE); - match ("common", gfc_match_common, ST_COMMON); - match ("contains", gfc_match_eos, ST_CONTAINS); - match ("class", gfc_match_class_is, ST_CLASS_IS); - match ("codimension", gfc_match_codimension, ST_ATTR_DECL); - break; - - case 'd': - match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE); - match ("data", gfc_match_data, ST_DATA); - match ("dimension", gfc_match_dimension, ST_ATTR_DECL); - break; - - case 'e': - match ("end file", gfc_match_endfile, ST_END_FILE); - match ("end team", gfc_match_end_team, ST_END_TEAM); - match ("exit", gfc_match_exit, ST_EXIT); - match ("else", gfc_match_else, ST_ELSE); - match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); - match ("else if", gfc_match_elseif, ST_ELSEIF); - match ("error stop", gfc_match_error_stop, ST_ERROR_STOP); - match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); - - if (gfc_match_end (&st) == MATCH_YES) - return st; - - match ("entry% ", gfc_match_entry, ST_ENTRY); - match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); - match ("external", gfc_match_external, ST_ATTR_DECL); - match ("event post", gfc_match_event_post, ST_EVENT_POST); - match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT); - break; - - case 'f': - match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE); - match ("final", gfc_match_final_decl, ST_FINAL); - match ("flush", gfc_match_flush, ST_FLUSH); - match ("form team", gfc_match_form_team, ST_FORM_TEAM); - match ("format", gfc_match_format, ST_FORMAT); - break; - - case 'g': - match ("generic", gfc_match_generic, ST_GENERIC); - match ("go to", gfc_match_goto, ST_GOTO); - break; - - case 'i': - match ("inquire", gfc_match_inquire, ST_INQUIRE); - match ("implicit", gfc_match_implicit, ST_IMPLICIT); - match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); - match ("import", gfc_match_import, ST_IMPORT); - match ("interface", gfc_match_interface, ST_INTERFACE); - match ("intent", gfc_match_intent, ST_ATTR_DECL); - match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); - break; - - case 'l': - match ("lock", gfc_match_lock, ST_LOCK); - break; - - case 'm': - match ("map", gfc_match_map, ST_MAP); - match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); - match ("module", gfc_match_module, ST_MODULE); - break; - - case 'n': - match ("nullify", gfc_match_nullify, ST_NULLIFY); - match ("namelist", gfc_match_namelist, ST_NAMELIST); - break; - - case 'o': - match ("open", gfc_match_open, ST_OPEN); - match ("optional", gfc_match_optional, ST_ATTR_DECL); - break; - - case 'p': - match ("print", gfc_match_print, ST_WRITE); - match ("pause", gfc_match_pause, ST_PAUSE); - match ("pointer", gfc_match_pointer, ST_ATTR_DECL); - if (gfc_match_private (&st) == MATCH_YES) - return st; - match ("procedure", gfc_match_procedure, ST_PROCEDURE); - match ("program", gfc_match_program, ST_PROGRAM); - if (gfc_match_public (&st) == MATCH_YES) - return st; - match ("protected", gfc_match_protected, ST_ATTR_DECL); - break; - - case 'r': - match ("rank", gfc_match_rank_is, ST_RANK); - match ("read", gfc_match_read, ST_READ); - match ("return", gfc_match_return, ST_RETURN); - match ("rewind", gfc_match_rewind, ST_REWIND); - break; - - case 's': - match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); - match ("sequence", gfc_match_eos, ST_SEQUENCE); - match ("stop", gfc_match_stop, ST_STOP); - match ("save", gfc_match_save, ST_ATTR_DECL); - match ("static", gfc_match_static, ST_ATTR_DECL); - match ("submodule", gfc_match_submodule, ST_SUBMODULE); - match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); - match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); - match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); - match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM); - break; - - case 't': - match ("target", gfc_match_target, ST_ATTR_DECL); - match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); - match ("type is", gfc_match_type_is, ST_TYPE_IS); - break; - - case 'u': - match ("union", gfc_match_union, ST_UNION); - match ("unlock", gfc_match_unlock, ST_UNLOCK); - break; - - case 'v': - match ("value", gfc_match_value, ST_ATTR_DECL); - match ("volatile", gfc_match_volatile, ST_ATTR_DECL); - break; - - case 'w': - match ("wait", gfc_match_wait, ST_WAIT); - match ("write", gfc_match_write, ST_WRITE); - break; - } - - /* All else has failed, so give up. See if any of the matchers has - stored an error message of some sort. Suppress the "Unclassifiable - statement" if a previous error message was emitted, e.g., by - gfc_error_now (). */ - if (!gfc_error_check ()) - { - int ecnt; - gfc_get_errors (NULL, &ecnt); - if (ecnt <= 0) - gfc_error_now ("Unclassifiable statement at %C"); - } - - reject_statement (); - - gfc_error_recovery (); - - return ST_NONE; -} - -/* Like match and if spec_only, goto do_spec_only without actually - matching. */ -/* If the directive matched but the clauses failed, do not start - matching the next directive in the same switch statement. */ -#define matcha(keyword, subr, st) \ - do { \ - match m2; \ - if (spec_only && gfc_match (keyword) == MATCH_YES) \ - goto do_spec_only; \ - else if ((m2 = match_word (keyword, subr, &old_locus)) \ - == MATCH_YES) \ - return st; \ - else if (m2 == MATCH_ERROR) \ - goto error_handling; \ - else \ - undo_new_statement (); \ - } while (0) - -static gfc_statement -decode_oacc_directive (void) -{ - locus old_locus; - char c; - bool spec_only = false; - - gfc_enforce_clean_symbol_state (); - - gfc_clear_error (); /* Clear any pending errors. */ - gfc_clear_warning (); /* Clear any pending warnings. */ - - gfc_matching_function = false; - - if (gfc_current_state () == COMP_FUNCTION - && gfc_current_block ()->result->ts.kind == -1) - spec_only = true; - - old_locus = gfc_current_locus; - - /* General OpenACC directive matching: Instead of testing every possible - statement, we eliminate most possibilities by peeking at the - first character. */ - - c = gfc_peek_ascii_char (); - - switch (c) - { - case 'r': - matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE); - break; - } - - gfc_unset_implicit_pure (NULL); - if (gfc_pure (NULL)) - { - gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE " - "procedures at %C"); - goto error_handling; - } - - switch (c) - { - case 'a': - matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); - break; - case 'c': - matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE); - break; - case 'd': - matcha ("data", gfc_match_oacc_data, ST_OACC_DATA); - match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE); - break; - case 'e': - matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC); - matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA); - matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA); - matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP); - matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS); - matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP); - matcha ("end parallel loop", gfc_match_omp_eos_error, - ST_OACC_END_PARALLEL_LOOP); - matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL); - matcha ("end serial loop", gfc_match_omp_eos_error, - ST_OACC_END_SERIAL_LOOP); - matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL); - matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA); - matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA); - break; - case 'h': - matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA); - break; - case 'p': - matcha ("parallel loop", gfc_match_oacc_parallel_loop, - ST_OACC_PARALLEL_LOOP); - matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL); - break; - case 'k': - matcha ("kernels loop", gfc_match_oacc_kernels_loop, - ST_OACC_KERNELS_LOOP); - matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS); - break; - case 'l': - matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP); - break; - case 's': - matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP); - matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL); - break; - case 'u': - matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE); - break; - case 'w': - matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT); - break; - } - - /* Directive not found or stored an error message. - Check and give up. */ - - error_handling: - if (gfc_error_check () == 0) - gfc_error_now ("Unclassifiable OpenACC directive at %C"); - - reject_statement (); - - gfc_error_recovery (); - - return ST_NONE; - - do_spec_only: - reject_statement (); - gfc_clear_error (); - gfc_buffer_error (false); - gfc_current_locus = old_locus; - return ST_GET_FCN_CHARACTERISTICS; -} - -/* Like match, but set a flag simd_matched if keyword matched - and if spec_only, goto do_spec_only without actually matching. */ -#define matchs(keyword, subr, st) \ - do { \ - match m2; \ - if (spec_only && gfc_match (keyword) == MATCH_YES) \ - goto do_spec_only; \ - if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \ - &simd_matched)) == MATCH_YES) \ - { \ - ret = st; \ - goto finish; \ - } \ - else if (m2 == MATCH_ERROR) \ - goto error_handling; \ - else \ - undo_new_statement (); \ - } while (0) - -/* Like match, but don't match anything if not -fopenmp - and if spec_only, goto do_spec_only without actually matching. */ -/* If the directive matched but the clauses failed, do not start - matching the next directive in the same switch statement. */ -#define matcho(keyword, subr, st) \ - do { \ - match m2; \ - if (!flag_openmp) \ - ; \ - else if (spec_only && gfc_match (keyword) == MATCH_YES) \ - goto do_spec_only; \ - else if ((m2 = match_word (keyword, subr, &old_locus)) \ - == MATCH_YES) \ - { \ - ret = st; \ - goto finish; \ - } \ - else if (m2 == MATCH_ERROR) \ - goto error_handling; \ - else \ - undo_new_statement (); \ - } while (0) - -/* Like match, but set a flag simd_matched if keyword matched. */ -#define matchds(keyword, subr, st) \ - do { \ - match m2; \ - if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \ - &simd_matched)) == MATCH_YES) \ - { \ - ret = st; \ - goto finish; \ - } \ - else if (m2 == MATCH_ERROR) \ - goto error_handling; \ - else \ - undo_new_statement (); \ - } while (0) - -/* Like match, but don't match anything if not -fopenmp. */ -#define matchdo(keyword, subr, st) \ - do { \ - match m2; \ - if (!flag_openmp) \ - ; \ - else if ((m2 = match_word (keyword, subr, &old_locus)) \ - == MATCH_YES) \ - { \ - ret = st; \ - goto finish; \ - } \ - else if (m2 == MATCH_ERROR) \ - goto error_handling; \ - else \ - undo_new_statement (); \ - } while (0) - -static gfc_statement -decode_omp_directive (void) -{ - locus old_locus; - char c; - bool simd_matched = false; - bool spec_only = false; - gfc_statement ret = ST_NONE; - bool pure_ok = true; - - gfc_enforce_clean_symbol_state (); - - gfc_clear_error (); /* Clear any pending errors. */ - gfc_clear_warning (); /* Clear any pending warnings. */ - - gfc_matching_function = false; - - if (gfc_current_state () == COMP_FUNCTION - && gfc_current_block ()->result->ts.kind == -1) - spec_only = true; - - old_locus = gfc_current_locus; - - /* General OpenMP directive matching: Instead of testing every possible - statement, we eliminate most possibilities by peeking at the - first character. */ - - c = gfc_peek_ascii_char (); - - /* match is for directives that should be recognized only if - -fopenmp, matchs for directives that should be recognized - if either -fopenmp or -fopenmp-simd. - Handle only the directives allowed in PURE procedures - first (those also shall not turn off implicit pure). */ - switch (c) - { - case 'd': - matchds ("declare simd", gfc_match_omp_declare_simd, - ST_OMP_DECLARE_SIMD); - matchdo ("declare target", gfc_match_omp_declare_target, - ST_OMP_DECLARE_TARGET); - matchdo ("declare variant", gfc_match_omp_declare_variant, - ST_OMP_DECLARE_VARIANT); - break; - case 's': - matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD); - break; - } - - pure_ok = false; - if (flag_openmp && gfc_pure (NULL)) - { - gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " - "at %C may not appear in PURE procedures"); - gfc_error_recovery (); - return ST_NONE; - } - - /* match is for directives that should be recognized only if - -fopenmp, matchs for directives that should be recognized - if either -fopenmp or -fopenmp-simd. */ - switch (c) - { - case 'a': - matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); - break; - case 'b': - matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); - break; - case 'c': - matcho ("cancellation% point", gfc_match_omp_cancellation_point, - ST_OMP_CANCELLATION_POINT); - matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL); - matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); - break; - case 'd': - matchds ("declare reduction", gfc_match_omp_declare_reduction, - ST_OMP_DECLARE_REDUCTION); - matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ); - matchs ("distribute parallel do simd", - gfc_match_omp_distribute_parallel_do_simd, - ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD); - matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do, - ST_OMP_DISTRIBUTE_PARALLEL_DO); - matchs ("distribute simd", gfc_match_omp_distribute_simd, - ST_OMP_DISTRIBUTE_SIMD); - matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE); - matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD); - matcho ("do", gfc_match_omp_do, ST_OMP_DO); - break; - case 'e': - matcho ("error", gfc_match_omp_error, ST_OMP_ERROR); - matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC); - matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL); - matchs ("end distribute parallel do simd", gfc_match_omp_eos_error, - ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD); - matcho ("end distribute parallel do", gfc_match_omp_eos_error, - ST_OMP_END_DISTRIBUTE_PARALLEL_DO); - matchs ("end distribute simd", gfc_match_omp_eos_error, - ST_OMP_END_DISTRIBUTE_SIMD); - matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE); - matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD); - matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); - matcho ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP); - matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD); - matcho ("end masked taskloop simd", gfc_match_omp_eos_error, - ST_OMP_END_MASKED_TASKLOOP_SIMD); - matcho ("end masked taskloop", gfc_match_omp_eos_error, - ST_OMP_END_MASKED_TASKLOOP); - matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED); - matcho ("end master taskloop simd", gfc_match_omp_eos_error, - ST_OMP_END_MASTER_TASKLOOP_SIMD); - matcho ("end master taskloop", gfc_match_omp_eos_error, - ST_OMP_END_MASTER_TASKLOOP); - matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER); - matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED); - matchs ("end parallel do simd", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_DO_SIMD); - matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO); - matcho ("end parallel loop", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_LOOP); - matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD); - matcho ("end parallel masked taskloop", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_MASKED_TASKLOOP); - matcho ("end parallel masked", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_MASKED); - matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD); - matcho ("end parallel master taskloop", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_MASTER_TASKLOOP); - matcho ("end parallel master", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_MASTER); - matcho ("end parallel sections", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_SECTIONS); - matcho ("end parallel workshare", gfc_match_omp_eos_error, - ST_OMP_END_PARALLEL_WORKSHARE); - matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL); - matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE); - matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); - matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); - matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA); - matchs ("end target parallel do simd", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_PARALLEL_DO_SIMD); - matcho ("end target parallel do", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_PARALLEL_DO); - matcho ("end target parallel loop", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_PARALLEL_LOOP); - matcho ("end target parallel", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_PARALLEL); - matchs ("end target simd", gfc_match_omp_end_nowait, ST_OMP_END_TARGET_SIMD); - matchs ("end target teams distribute parallel do simd", - gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); - matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); - matchs ("end target teams distribute simd", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD); - matcho ("end target teams distribute", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_TEAMS_DISTRIBUTE); - matcho ("end target teams loop", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_TEAMS_LOOP); - matcho ("end target teams", gfc_match_omp_end_nowait, - ST_OMP_END_TARGET_TEAMS); - matcho ("end target", gfc_match_omp_end_nowait, ST_OMP_END_TARGET); - matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP); - matchs ("end taskloop simd", gfc_match_omp_eos_error, - ST_OMP_END_TASKLOOP_SIMD); - matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP); - matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK); - matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error, - ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); - matcho ("end teams distribute parallel do", gfc_match_omp_eos_error, - ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO); - matchs ("end teams distribute simd", gfc_match_omp_eos_error, - ST_OMP_END_TEAMS_DISTRIBUTE_SIMD); - matcho ("end teams distribute", gfc_match_omp_eos_error, - ST_OMP_END_TEAMS_DISTRIBUTE); - matcho ("end teams loop", gfc_match_omp_eos_error, ST_OMP_END_TEAMS_LOOP); - matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS); - matcho ("end workshare", gfc_match_omp_end_nowait, - ST_OMP_END_WORKSHARE); - break; - case 'f': - matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); - break; - case 'm': - matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd, - ST_OMP_MASKED_TASKLOOP_SIMD); - matcho ("masked taskloop", gfc_match_omp_masked_taskloop, - ST_OMP_MASKED_TASKLOOP); - matcho ("masked", gfc_match_omp_masked, ST_OMP_MASKED); - matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd, - ST_OMP_MASTER_TASKLOOP_SIMD); - matcho ("master taskloop", gfc_match_omp_master_taskloop, - ST_OMP_MASTER_TASKLOOP); - matcho ("master", gfc_match_omp_master, ST_OMP_MASTER); - break; - case 'n': - matcho ("nothing", gfc_match_omp_nothing, ST_NONE); - break; - case 'l': - matcho ("loop", gfc_match_omp_loop, ST_OMP_LOOP); - break; - case 'o': - if (gfc_match ("ordered depend (") == MATCH_YES) - { - gfc_current_locus = old_locus; - if (!flag_openmp) - break; - matcho ("ordered", gfc_match_omp_ordered_depend, - ST_OMP_ORDERED_DEPEND); - } - else - matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED); - break; - case 'p': - matchs ("parallel do simd", gfc_match_omp_parallel_do_simd, - ST_OMP_PARALLEL_DO_SIMD); - matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); - matcho ("parallel loop", gfc_match_omp_parallel_loop, - ST_OMP_PARALLEL_LOOP); - matcho ("parallel masked taskloop simd", - gfc_match_omp_parallel_masked_taskloop_simd, - ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD); - matcho ("parallel masked taskloop", - gfc_match_omp_parallel_masked_taskloop, - ST_OMP_PARALLEL_MASKED_TASKLOOP); - matcho ("parallel masked", gfc_match_omp_parallel_masked, - ST_OMP_PARALLEL_MASKED); - matcho ("parallel master taskloop simd", - gfc_match_omp_parallel_master_taskloop_simd, - ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD); - matcho ("parallel master taskloop", - gfc_match_omp_parallel_master_taskloop, - ST_OMP_PARALLEL_MASTER_TASKLOOP); - matcho ("parallel master", gfc_match_omp_parallel_master, - ST_OMP_PARALLEL_MASTER); - matcho ("parallel sections", gfc_match_omp_parallel_sections, - ST_OMP_PARALLEL_SECTIONS); - matcho ("parallel workshare", gfc_match_omp_parallel_workshare, - ST_OMP_PARALLEL_WORKSHARE); - matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); - break; - case 'r': - matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES); - break; - case 's': - matcho ("scan", gfc_match_omp_scan, ST_OMP_SCAN); - matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE); - matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); - matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION); - matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE); - break; - case 't': - matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA); - matcho ("target enter data", gfc_match_omp_target_enter_data, - ST_OMP_TARGET_ENTER_DATA); - matcho ("target exit data", gfc_match_omp_target_exit_data, - ST_OMP_TARGET_EXIT_DATA); - matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd, - ST_OMP_TARGET_PARALLEL_DO_SIMD); - matcho ("target parallel do", gfc_match_omp_target_parallel_do, - ST_OMP_TARGET_PARALLEL_DO); - matcho ("target parallel loop", gfc_match_omp_target_parallel_loop, - ST_OMP_TARGET_PARALLEL_LOOP); - matcho ("target parallel", gfc_match_omp_target_parallel, - ST_OMP_TARGET_PARALLEL); - matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD); - matchs ("target teams distribute parallel do simd", - gfc_match_omp_target_teams_distribute_parallel_do_simd, - ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); - matcho ("target teams distribute parallel do", - gfc_match_omp_target_teams_distribute_parallel_do, - ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); - matchs ("target teams distribute simd", - gfc_match_omp_target_teams_distribute_simd, - ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD); - matcho ("target teams distribute", gfc_match_omp_target_teams_distribute, - ST_OMP_TARGET_TEAMS_DISTRIBUTE); - matcho ("target teams loop", gfc_match_omp_target_teams_loop, - ST_OMP_TARGET_TEAMS_LOOP); - matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS); - matcho ("target update", gfc_match_omp_target_update, - ST_OMP_TARGET_UPDATE); - matcho ("target", gfc_match_omp_target, ST_OMP_TARGET); - matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP); - matchs ("taskloop simd", gfc_match_omp_taskloop_simd, - ST_OMP_TASKLOOP_SIMD); - matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP); - matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT); - matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD); - matcho ("task", gfc_match_omp_task, ST_OMP_TASK); - matchs ("teams distribute parallel do simd", - gfc_match_omp_teams_distribute_parallel_do_simd, - ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); - matcho ("teams distribute parallel do", - gfc_match_omp_teams_distribute_parallel_do, - ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO); - matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd, - ST_OMP_TEAMS_DISTRIBUTE_SIMD); - matcho ("teams distribute", gfc_match_omp_teams_distribute, - ST_OMP_TEAMS_DISTRIBUTE); - matcho ("teams loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP); - matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS); - matchdo ("threadprivate", gfc_match_omp_threadprivate, - ST_OMP_THREADPRIVATE); - break; - case 'w': - matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); - break; - } - - /* All else has failed, so give up. See if any of the matchers has - stored an error message of some sort. Don't error out if - not -fopenmp and simd_matched is false, i.e. if a directive other - than one marked with match has been seen. */ - - error_handling: - if (flag_openmp || simd_matched) - { - if (!gfc_error_check ()) - gfc_error_now ("Unclassifiable OpenMP directive at %C"); - } - - reject_statement (); - - gfc_error_recovery (); - - return ST_NONE; - - finish: - if (!pure_ok) - { - gfc_unset_implicit_pure (NULL); - - if (!flag_openmp && gfc_pure (NULL)) - { - gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " - "at %C may not appear in PURE procedures"); - reject_statement (); - gfc_error_recovery (); - return ST_NONE; - } - } - switch (ret) - { - case ST_OMP_DECLARE_TARGET: - case ST_OMP_TARGET: - case ST_OMP_TARGET_DATA: - case ST_OMP_TARGET_ENTER_DATA: - case ST_OMP_TARGET_EXIT_DATA: - case ST_OMP_TARGET_TEAMS: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_TEAMS_LOOP: - case ST_OMP_TARGET_PARALLEL: - case ST_OMP_TARGET_PARALLEL_DO: - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_PARALLEL_LOOP: - case ST_OMP_TARGET_SIMD: - case ST_OMP_TARGET_UPDATE: - { - gfc_namespace *prog_unit = gfc_current_ns; - while (prog_unit->parent) - { - if (gfc_state_stack->previous - && gfc_state_stack->previous->state == COMP_INTERFACE) - break; - prog_unit = prog_unit->parent; - } - prog_unit->omp_target_seen = true; - break; - } - case ST_OMP_ERROR: - if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION) - return ST_NONE; - default: - break; - } - return ret; - - do_spec_only: - reject_statement (); - gfc_clear_error (); - gfc_buffer_error (false); - gfc_current_locus = old_locus; - return ST_GET_FCN_CHARACTERISTICS; -} - -static gfc_statement -decode_gcc_attribute (void) -{ - locus old_locus; - - gfc_enforce_clean_symbol_state (); - - gfc_clear_error (); /* Clear any pending errors. */ - gfc_clear_warning (); /* Clear any pending warnings. */ - old_locus = gfc_current_locus; - - match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL); - match ("unroll", gfc_match_gcc_unroll, ST_NONE); - match ("builtin", gfc_match_gcc_builtin, ST_NONE); - match ("ivdep", gfc_match_gcc_ivdep, ST_NONE); - match ("vector", gfc_match_gcc_vector, ST_NONE); - match ("novector", gfc_match_gcc_novector, ST_NONE); - - /* All else has failed, so give up. See if any of the matchers has - stored an error message of some sort. */ - - if (!gfc_error_check ()) - { - if (pedantic) - gfc_error_now ("Unclassifiable GCC directive at %C"); - else - gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored"); - } - - reject_statement (); - - gfc_error_recovery (); - - return ST_NONE; -} - -#undef match - -/* Assert next length characters to be equal to token in free form. */ - -static void -verify_token_free (const char* token, int length, bool last_was_use_stmt) -{ - int i; - char c; - - c = gfc_next_ascii_char (); - for (i = 0; i < length; i++, c = gfc_next_ascii_char ()) - gcc_assert (c == token[i]); - - gcc_assert (gfc_is_whitespace(c)); - gfc_gobble_whitespace (); - if (last_was_use_stmt) - use_modules (); -} - -/* Get the next statement in free form source. */ - -static gfc_statement -next_free (void) -{ - match m; - int i, cnt, at_bol; - char c; - - at_bol = gfc_at_bol (); - gfc_gobble_whitespace (); - - c = gfc_peek_ascii_char (); - - if (ISDIGIT (c)) - { - char d; - - /* Found a statement label? */ - m = gfc_match_st_label (&gfc_statement_label); - - d = gfc_peek_ascii_char (); - if (m != MATCH_YES || !gfc_is_whitespace (d)) - { - gfc_match_small_literal_int (&i, &cnt); - - if (cnt > 5) - gfc_error_now ("Too many digits in statement label at %C"); - - if (i == 0) - gfc_error_now ("Zero is not a valid statement label at %C"); - - do - c = gfc_next_ascii_char (); - while (ISDIGIT(c)); - - if (!gfc_is_whitespace (c)) - gfc_error_now ("Non-numeric character in statement label at %C"); - - return ST_NONE; - } - else - { - label_locus = gfc_current_locus; - - gfc_gobble_whitespace (); - - if (at_bol && gfc_peek_ascii_char () == ';') - { - gfc_error_now ("Semicolon at %C needs to be preceded by " - "statement"); - gfc_next_ascii_char (); /* Eat up the semicolon. */ - return ST_NONE; - } - - if (gfc_match_eos () == MATCH_YES) - gfc_error_now ("Statement label without statement at %L", - &label_locus); - } - } - else if (c == '!') - { - /* Comments have already been skipped by the time we get here, - except for GCC attributes and OpenMP/OpenACC directives. */ - - gfc_next_ascii_char (); /* Eat up the exclamation sign. */ - c = gfc_peek_ascii_char (); - - if (c == 'g') - { - int i; - - c = gfc_next_ascii_char (); - for (i = 0; i < 4; i++, c = gfc_next_ascii_char ()) - gcc_assert (c == "gcc$"[i]); - - gfc_gobble_whitespace (); - return decode_gcc_attribute (); - - } - else if (c == '$') - { - /* Since both OpenMP and OpenACC directives starts with - !$ character sequence, we must check all flags combinations */ - if ((flag_openmp || flag_openmp_simd) - && !flag_openacc) - { - verify_token_free ("$omp", 4, last_was_use_stmt); - return decode_omp_directive (); - } - else if ((flag_openmp || flag_openmp_simd) - && flag_openacc) - { - gfc_next_ascii_char (); /* Eat up dollar character */ - c = gfc_peek_ascii_char (); - - if (c == 'o') - { - verify_token_free ("omp", 3, last_was_use_stmt); - return decode_omp_directive (); - } - else if (c == 'a') - { - verify_token_free ("acc", 3, last_was_use_stmt); - return decode_oacc_directive (); - } - } - else if (flag_openacc) - { - verify_token_free ("$acc", 4, last_was_use_stmt); - return decode_oacc_directive (); - } - } - gcc_unreachable (); - } - - if (at_bol && c == ';') - { - if (!(gfc_option.allow_std & GFC_STD_F2008)) - gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " - "statement"); - gfc_next_ascii_char (); /* Eat up the semicolon. */ - return ST_NONE; - } - - return decode_statement (); -} - -/* Assert next length characters to be equal to token in fixed form. */ - -static bool -verify_token_fixed (const char *token, int length, bool last_was_use_stmt) -{ - int i; - char c = gfc_next_char_literal (NONSTRING); - - for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING)) - gcc_assert ((char) gfc_wide_tolower (c) == token[i]); - - if (c != ' ' && c != '0') - { - gfc_buffer_error (false); - gfc_error ("Bad continuation line at %C"); - return false; - } - if (last_was_use_stmt) - use_modules (); - - return true; -} - -/* Get the next statement in fixed-form source. */ - -static gfc_statement -next_fixed (void) -{ - int label, digit_flag, i; - locus loc; - gfc_char_t c; - - if (!gfc_at_bol ()) - return decode_statement (); - - /* Skip past the current label field, parsing a statement label if - one is there. This is a weird number parser, since the number is - contained within five columns and can have any kind of embedded - spaces. We also check for characters that make the rest of the - line a comment. */ - - label = 0; - digit_flag = 0; - - for (i = 0; i < 5; i++) - { - c = gfc_next_char_literal (NONSTRING); - - switch (c) - { - case ' ': - break; - - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - label = label * 10 + ((unsigned char) c - '0'); - label_locus = gfc_current_locus; - digit_flag = 1; - break; - - /* Comments have already been skipped by the time we get - here, except for GCC attributes and OpenMP directives. */ - - case '*': - c = gfc_next_char_literal (NONSTRING); - - if (TOLOWER (c) == 'g') - { - for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING)) - gcc_assert (TOLOWER (c) == "gcc$"[i]); - - return decode_gcc_attribute (); - } - else if (c == '$') - { - if ((flag_openmp || flag_openmp_simd) - && !flag_openacc) - { - if (!verify_token_fixed ("omp", 3, last_was_use_stmt)) - return ST_NONE; - return decode_omp_directive (); - } - else if ((flag_openmp || flag_openmp_simd) - && flag_openacc) - { - c = gfc_next_char_literal(NONSTRING); - if (c == 'o' || c == 'O') - { - if (!verify_token_fixed ("mp", 2, last_was_use_stmt)) - return ST_NONE; - return decode_omp_directive (); - } - else if (c == 'a' || c == 'A') - { - if (!verify_token_fixed ("cc", 2, last_was_use_stmt)) - return ST_NONE; - return decode_oacc_directive (); - } - } - else if (flag_openacc) - { - if (!verify_token_fixed ("acc", 3, last_was_use_stmt)) - return ST_NONE; - return decode_oacc_directive (); - } - } - gcc_fallthrough (); - - /* Comments have already been skipped by the time we get - here so don't bother checking for them. */ - - default: - gfc_buffer_error (false); - gfc_error ("Non-numeric character in statement label at %C"); - return ST_NONE; - } - } - - if (digit_flag) - { - if (label == 0) - gfc_warning_now (0, "Zero is not a valid statement label at %C"); - else - { - /* We've found a valid statement label. */ - gfc_statement_label = gfc_get_st_label (label); - } - } - - /* Since this line starts a statement, it cannot be a continuation - of a previous statement. If we see something here besides a - space or zero, it must be a bad continuation line. */ - - c = gfc_next_char_literal (NONSTRING); - if (c == '\n') - goto blank_line; - - if (c != ' ' && c != '0') - { - gfc_buffer_error (false); - gfc_error ("Bad continuation line at %C"); - return ST_NONE; - } - - /* Now that we've taken care of the statement label columns, we have - to make sure that the first nonblank character is not a '!'. If - it is, the rest of the line is a comment. */ - - do - { - loc = gfc_current_locus; - c = gfc_next_char_literal (NONSTRING); - } - while (gfc_is_whitespace (c)); - - if (c == '!') - goto blank_line; - gfc_current_locus = loc; - - if (c == ';') - { - if (digit_flag) - gfc_error_now ("Semicolon at %C needs to be preceded by statement"); - else if (!(gfc_option.allow_std & GFC_STD_F2008)) - gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " - "statement"); - return ST_NONE; - } - - if (gfc_match_eos () == MATCH_YES) - goto blank_line; - - /* At this point, we've got a nonblank statement to parse. */ - return decode_statement (); - -blank_line: - if (digit_flag) - gfc_error_now ("Statement label without statement at %L", &label_locus); - - gfc_current_locus.lb->truncated = 0; - gfc_advance_line (); - return ST_NONE; -} - - -/* Return the next non-ST_NONE statement to the caller. We also worry - about including files and the ends of include files at this stage. */ - -static gfc_statement -next_statement (void) -{ - gfc_statement st; - locus old_locus; - - gfc_enforce_clean_symbol_state (); - - gfc_new_block = NULL; - - gfc_current_ns->old_equiv = gfc_current_ns->equiv; - gfc_current_ns->old_data = gfc_current_ns->data; - for (;;) - { - gfc_statement_label = NULL; - gfc_buffer_error (true); - - if (gfc_at_eol ()) - gfc_advance_line (); - - gfc_skip_comments (); - - if (gfc_at_end ()) - { - st = ST_NONE; - break; - } - - if (gfc_define_undef_line ()) - continue; - - old_locus = gfc_current_locus; - - st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free (); - - if (st != ST_NONE) - break; - } - - gfc_buffer_error (false); - - if (st == ST_GET_FCN_CHARACTERISTICS) - { - if (gfc_statement_label != NULL) - { - gfc_free_st_label (gfc_statement_label); - gfc_statement_label = NULL; - } - gfc_current_locus = old_locus; - } - - if (st != ST_NONE) - check_statement_label (st); - - return st; -} - - -/****************************** Parser ***********************************/ - -/* The parser subroutines are of type 'try' that fail if the file ends - unexpectedly. */ - -/* Macros that expand to case-labels for various classes of - statements. Start with executable statements that directly do - things. */ - -#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \ - case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ - case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ - case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ - case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \ - case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ - case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ - case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ - case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \ - case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \ - case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \ - case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \ - case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \ - case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ - case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ - case ST_END_TEAM: case ST_SYNC_TEAM: \ - case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ - case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ - case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA - -/* Statements that mark other executable statements. */ - -#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ - case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ - case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ - case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \ - case ST_OMP_PARALLEL_MASKED_TASKLOOP: \ - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \ - case ST_OMP_PARALLEL_MASTER_TASKLOOP: \ - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \ - case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ - case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \ - case ST_OMP_MASKED_TASKLOOP_SIMD: \ - case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \ - case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \ - case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ - case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \ - case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \ - case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \ - case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \ - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \ - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \ - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \ - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ - case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \ - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \ - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \ - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \ - case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \ - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \ - case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \ - case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ - case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \ - case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \ - case ST_CRITICAL: \ - case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \ - case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ - case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \ - case ST_OACC_ATOMIC - -/* Declaration statements */ - -#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ - case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ - case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE - -/* OpenMP and OpenACC declaration statements, which may appear anywhere in - the specification part. */ - -#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ - case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ - case ST_OMP_DECLARE_VARIANT: \ - case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE - -/* Block end statements. Errors associated with interchanging these - are detected in gfc_match_end(). */ - -#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ - case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ - case ST_END_BLOCK: case ST_END_ASSOCIATE - - -/* Push a new state onto the stack. */ - -static void -push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym) -{ - p->state = new_state; - p->previous = gfc_state_stack; - p->sym = sym; - p->head = p->tail = NULL; - p->do_variable = NULL; - if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT) - p->ext.oacc_declare_clauses = NULL; - - /* If this the state of a construct like BLOCK, DO or IF, the corresponding - construct statement was accepted right before pushing the state. Thus, - the construct's gfc_code is available as tail of the parent state. */ - gcc_assert (gfc_state_stack); - p->construct = gfc_state_stack->tail; - - gfc_state_stack = p; -} - - -/* Pop the current state. */ -static void -pop_state (void) -{ - gfc_state_stack = gfc_state_stack->previous; -} - - -/* Try to find the given state in the state stack. */ - -bool -gfc_find_state (gfc_compile_state state) -{ - gfc_state_data *p; - - for (p = gfc_state_stack; p; p = p->previous) - if (p->state == state) - break; - - return (p == NULL) ? false : true; -} - - -/* Starts a new level in the statement list. */ - -static gfc_code * -new_level (gfc_code *q) -{ - gfc_code *p; - - p = q->block = gfc_get_code (EXEC_NOP); - - gfc_state_stack->head = gfc_state_stack->tail = p; - - return p; -} - - -/* Add the current new_st code structure and adds it to the current - program unit. As a side-effect, it zeroes the new_st. */ - -static gfc_code * -add_statement (void) -{ - gfc_code *p; - - p = XCNEW (gfc_code); - *p = new_st; - - p->loc = gfc_current_locus; - - if (gfc_state_stack->head == NULL) - gfc_state_stack->head = p; - else - gfc_state_stack->tail->next = p; - - while (p->next != NULL) - p = p->next; - - gfc_state_stack->tail = p; - - gfc_clear_new_st (); - - return p; -} - - -/* Frees everything associated with the current statement. */ - -static void -undo_new_statement (void) -{ - gfc_free_statements (new_st.block); - gfc_free_statements (new_st.next); - gfc_free_statement (&new_st); - gfc_clear_new_st (); -} - - -/* If the current statement has a statement label, make sure that it - is allowed to, or should have one. */ - -static void -check_statement_label (gfc_statement st) -{ - gfc_sl_type type; - - if (gfc_statement_label == NULL) - { - if (st == ST_FORMAT) - gfc_error ("FORMAT statement at %L does not have a statement label", - &new_st.loc); - return; - } - - switch (st) - { - case ST_END_PROGRAM: - case ST_END_FUNCTION: - case ST_END_SUBROUTINE: - case ST_ENDDO: - case ST_ENDIF: - case ST_END_SELECT: - case ST_END_CRITICAL: - case ST_END_BLOCK: - case ST_END_ASSOCIATE: - case_executable: - case_exec_markers: - if (st == ST_ENDDO || st == ST_CONTINUE) - type = ST_LABEL_DO_TARGET; - else - type = ST_LABEL_TARGET; - break; - - case ST_FORMAT: - type = ST_LABEL_FORMAT; - break; - - /* Statement labels are not restricted from appearing on a - particular line. However, there are plenty of situations - where the resulting label can't be referenced. */ - - default: - type = ST_LABEL_BAD_TARGET; - break; - } - - gfc_define_st_label (gfc_statement_label, type, &label_locus); - - new_st.here = gfc_statement_label; -} - - -/* Figures out what the enclosing program unit is. This will be a - function, subroutine, program, block data or module. */ - -gfc_state_data * -gfc_enclosing_unit (gfc_compile_state * result) -{ - gfc_state_data *p; - - for (p = gfc_state_stack; p; p = p->previous) - if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE - || p->state == COMP_MODULE || p->state == COMP_SUBMODULE - || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM) - { - - if (result != NULL) - *result = p->state; - return p; - } - - if (result != NULL) - *result = COMP_PROGRAM; - return NULL; -} - - -/* Translate a statement enum to a string. */ - -const char * -gfc_ascii_statement (gfc_statement st) -{ - const char *p; - - switch (st) - { - case ST_ARITHMETIC_IF: - p = _("arithmetic IF"); - break; - case ST_ALLOCATE: - p = "ALLOCATE"; - break; - case ST_ASSOCIATE: - p = "ASSOCIATE"; - break; - case ST_ATTR_DECL: - p = _("attribute declaration"); - break; - case ST_BACKSPACE: - p = "BACKSPACE"; - break; - case ST_BLOCK: - p = "BLOCK"; - break; - case ST_BLOCK_DATA: - p = "BLOCK DATA"; - break; - case ST_CALL: - p = "CALL"; - break; - case ST_CASE: - p = "CASE"; - break; - case ST_CLOSE: - p = "CLOSE"; - break; - case ST_COMMON: - p = "COMMON"; - break; - case ST_CONTINUE: - p = "CONTINUE"; - break; - case ST_CONTAINS: - p = "CONTAINS"; - break; - case ST_CRITICAL: - p = "CRITICAL"; - break; - case ST_CYCLE: - p = "CYCLE"; - break; - case ST_DATA_DECL: - p = _("data declaration"); - break; - case ST_DATA: - p = "DATA"; - break; - case ST_DEALLOCATE: - p = "DEALLOCATE"; - break; - case ST_MAP: - p = "MAP"; - break; - case ST_UNION: - p = "UNION"; - break; - case ST_STRUCTURE_DECL: - p = "STRUCTURE"; - break; - case ST_DERIVED_DECL: - p = _("derived type declaration"); - break; - case ST_DO: - p = "DO"; - break; - case ST_ELSE: - p = "ELSE"; - break; - case ST_ELSEIF: - p = "ELSE IF"; - break; - case ST_ELSEWHERE: - p = "ELSEWHERE"; - break; - case ST_EVENT_POST: - p = "EVENT POST"; - break; - case ST_EVENT_WAIT: - p = "EVENT WAIT"; - break; - case ST_FAIL_IMAGE: - p = "FAIL IMAGE"; - break; - case ST_CHANGE_TEAM: - p = "CHANGE TEAM"; - break; - case ST_END_TEAM: - p = "END TEAM"; - break; - case ST_FORM_TEAM: - p = "FORM TEAM"; - break; - case ST_SYNC_TEAM: - p = "SYNC TEAM"; - break; - case ST_END_ASSOCIATE: - p = "END ASSOCIATE"; - break; - case ST_END_BLOCK: - p = "END BLOCK"; - break; - case ST_END_BLOCK_DATA: - p = "END BLOCK DATA"; - break; - case ST_END_CRITICAL: - p = "END CRITICAL"; - break; - case ST_ENDDO: - p = "END DO"; - break; - case ST_END_FILE: - p = "END FILE"; - break; - case ST_END_FORALL: - p = "END FORALL"; - break; - case ST_END_FUNCTION: - p = "END FUNCTION"; - break; - case ST_ENDIF: - p = "END IF"; - break; - case ST_END_INTERFACE: - p = "END INTERFACE"; - break; - case ST_END_MODULE: - p = "END MODULE"; - break; - case ST_END_SUBMODULE: - p = "END SUBMODULE"; - break; - case ST_END_PROGRAM: - p = "END PROGRAM"; - break; - case ST_END_SELECT: - p = "END SELECT"; - break; - case ST_END_SUBROUTINE: - p = "END SUBROUTINE"; - break; - case ST_END_WHERE: - p = "END WHERE"; - break; - case ST_END_STRUCTURE: - p = "END STRUCTURE"; - break; - case ST_END_UNION: - p = "END UNION"; - break; - case ST_END_MAP: - p = "END MAP"; - break; - case ST_END_TYPE: - p = "END TYPE"; - break; - case ST_ENTRY: - p = "ENTRY"; - break; - case ST_EQUIVALENCE: - p = "EQUIVALENCE"; - break; - case ST_ERROR_STOP: - p = "ERROR STOP"; - break; - case ST_EXIT: - p = "EXIT"; - break; - case ST_FLUSH: - p = "FLUSH"; - break; - case ST_FORALL_BLOCK: /* Fall through */ - case ST_FORALL: - p = "FORALL"; - break; - case ST_FORMAT: - p = "FORMAT"; - break; - case ST_FUNCTION: - p = "FUNCTION"; - break; - case ST_GENERIC: - p = "GENERIC"; - break; - case ST_GOTO: - p = "GOTO"; - break; - case ST_IF_BLOCK: - p = _("block IF"); - break; - case ST_IMPLICIT: - p = "IMPLICIT"; - break; - case ST_IMPLICIT_NONE: - p = "IMPLICIT NONE"; - break; - case ST_IMPLIED_ENDDO: - p = _("implied END DO"); - break; - case ST_IMPORT: - p = "IMPORT"; - break; - case ST_INQUIRE: - p = "INQUIRE"; - break; - case ST_INTERFACE: - p = "INTERFACE"; - break; - case ST_LOCK: - p = "LOCK"; - break; - case ST_PARAMETER: - p = "PARAMETER"; - break; - case ST_PRIVATE: - p = "PRIVATE"; - break; - case ST_PUBLIC: - p = "PUBLIC"; - break; - case ST_MODULE: - p = "MODULE"; - break; - case ST_SUBMODULE: - p = "SUBMODULE"; - break; - case ST_PAUSE: - p = "PAUSE"; - break; - case ST_MODULE_PROC: - p = "MODULE PROCEDURE"; - break; - case ST_NAMELIST: - p = "NAMELIST"; - break; - case ST_NULLIFY: - p = "NULLIFY"; - break; - case ST_OPEN: - p = "OPEN"; - break; - case ST_PROGRAM: - p = "PROGRAM"; - break; - case ST_PROCEDURE: - p = "PROCEDURE"; - break; - case ST_READ: - p = "READ"; - break; - case ST_RETURN: - p = "RETURN"; - break; - case ST_REWIND: - p = "REWIND"; - break; - case ST_STOP: - p = "STOP"; - break; - case ST_SYNC_ALL: - p = "SYNC ALL"; - break; - case ST_SYNC_IMAGES: - p = "SYNC IMAGES"; - break; - case ST_SYNC_MEMORY: - p = "SYNC MEMORY"; - break; - case ST_SUBROUTINE: - p = "SUBROUTINE"; - break; - case ST_TYPE: - p = "TYPE"; - break; - case ST_UNLOCK: - p = "UNLOCK"; - break; - case ST_USE: - p = "USE"; - break; - case ST_WHERE_BLOCK: /* Fall through */ - case ST_WHERE: - p = "WHERE"; - break; - case ST_WAIT: - p = "WAIT"; - break; - case ST_WRITE: - p = "WRITE"; - break; - case ST_ASSIGNMENT: - p = _("assignment"); - break; - case ST_POINTER_ASSIGNMENT: - p = _("pointer assignment"); - break; - case ST_SELECT_CASE: - p = "SELECT CASE"; - break; - case ST_SELECT_TYPE: - p = "SELECT TYPE"; - break; - case ST_SELECT_RANK: - p = "SELECT RANK"; - break; - case ST_TYPE_IS: - p = "TYPE IS"; - break; - case ST_CLASS_IS: - p = "CLASS IS"; - break; - case ST_RANK: - p = "RANK"; - break; - case ST_SEQUENCE: - p = "SEQUENCE"; - break; - case ST_SIMPLE_IF: - p = _("simple IF"); - break; - case ST_STATEMENT_FUNCTION: - p = "STATEMENT FUNCTION"; - break; - case ST_LABEL_ASSIGNMENT: - p = "LABEL ASSIGNMENT"; - break; - case ST_ENUM: - p = "ENUM DEFINITION"; - break; - case ST_ENUMERATOR: - p = "ENUMERATOR DEFINITION"; - break; - case ST_END_ENUM: - p = "END ENUM"; - break; - case ST_OACC_PARALLEL_LOOP: - p = "!$ACC PARALLEL LOOP"; - break; - case ST_OACC_END_PARALLEL_LOOP: - p = "!$ACC END PARALLEL LOOP"; - break; - case ST_OACC_PARALLEL: - p = "!$ACC PARALLEL"; - break; - case ST_OACC_END_PARALLEL: - p = "!$ACC END PARALLEL"; - break; - case ST_OACC_KERNELS: - p = "!$ACC KERNELS"; - break; - case ST_OACC_END_KERNELS: - p = "!$ACC END KERNELS"; - break; - case ST_OACC_KERNELS_LOOP: - p = "!$ACC KERNELS LOOP"; - break; - case ST_OACC_END_KERNELS_LOOP: - p = "!$ACC END KERNELS LOOP"; - break; - case ST_OACC_SERIAL_LOOP: - p = "!$ACC SERIAL LOOP"; - break; - case ST_OACC_END_SERIAL_LOOP: - p = "!$ACC END SERIAL LOOP"; - break; - case ST_OACC_SERIAL: - p = "!$ACC SERIAL"; - break; - case ST_OACC_END_SERIAL: - p = "!$ACC END SERIAL"; - break; - case ST_OACC_DATA: - p = "!$ACC DATA"; - break; - case ST_OACC_END_DATA: - p = "!$ACC END DATA"; - break; - case ST_OACC_HOST_DATA: - p = "!$ACC HOST_DATA"; - break; - case ST_OACC_END_HOST_DATA: - p = "!$ACC END HOST_DATA"; - break; - case ST_OACC_LOOP: - p = "!$ACC LOOP"; - break; - case ST_OACC_END_LOOP: - p = "!$ACC END LOOP"; - break; - case ST_OACC_DECLARE: - p = "!$ACC DECLARE"; - break; - case ST_OACC_UPDATE: - p = "!$ACC UPDATE"; - break; - case ST_OACC_WAIT: - p = "!$ACC WAIT"; - break; - case ST_OACC_CACHE: - p = "!$ACC CACHE"; - break; - case ST_OACC_ENTER_DATA: - p = "!$ACC ENTER DATA"; - break; - case ST_OACC_EXIT_DATA: - p = "!$ACC EXIT DATA"; - break; - case ST_OACC_ROUTINE: - p = "!$ACC ROUTINE"; - break; - case ST_OACC_ATOMIC: - p = "!$ACC ATOMIC"; - break; - case ST_OACC_END_ATOMIC: - p = "!$ACC END ATOMIC"; - break; - case ST_OMP_ATOMIC: - p = "!$OMP ATOMIC"; - break; - case ST_OMP_BARRIER: - p = "!$OMP BARRIER"; - break; - case ST_OMP_CANCEL: - p = "!$OMP CANCEL"; - break; - case ST_OMP_CANCELLATION_POINT: - p = "!$OMP CANCELLATION POINT"; - break; - case ST_OMP_CRITICAL: - p = "!$OMP CRITICAL"; - break; - case ST_OMP_DECLARE_REDUCTION: - p = "!$OMP DECLARE REDUCTION"; - break; - case ST_OMP_DECLARE_SIMD: - p = "!$OMP DECLARE SIMD"; - break; - case ST_OMP_DECLARE_TARGET: - p = "!$OMP DECLARE TARGET"; - break; - case ST_OMP_DECLARE_VARIANT: - p = "!$OMP DECLARE VARIANT"; - break; - case ST_OMP_DEPOBJ: - p = "!$OMP DEPOBJ"; - break; - case ST_OMP_DISTRIBUTE: - p = "!$OMP DISTRIBUTE"; - break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - p = "!$OMP DISTRIBUTE PARALLEL DO"; - break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - p = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; - break; - case ST_OMP_DISTRIBUTE_SIMD: - p = "!$OMP DISTRIBUTE SIMD"; - break; - case ST_OMP_DO: - p = "!$OMP DO"; - break; - case ST_OMP_DO_SIMD: - p = "!$OMP DO SIMD"; - break; - case ST_OMP_END_ATOMIC: - p = "!$OMP END ATOMIC"; - break; - case ST_OMP_END_CRITICAL: - p = "!$OMP END CRITICAL"; - break; - case ST_OMP_END_DISTRIBUTE: - p = "!$OMP END DISTRIBUTE"; - break; - case ST_OMP_END_DISTRIBUTE_PARALLEL_DO: - p = "!$OMP END DISTRIBUTE PARALLEL DO"; - break; - case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD: - p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD"; - break; - case ST_OMP_END_DISTRIBUTE_SIMD: - p = "!$OMP END DISTRIBUTE SIMD"; - break; - case ST_OMP_END_DO: - p = "!$OMP END DO"; - break; - case ST_OMP_END_DO_SIMD: - p = "!$OMP END DO SIMD"; - break; - case ST_OMP_END_SCOPE: - p = "!$OMP END SCOPE"; - break; - case ST_OMP_END_SIMD: - p = "!$OMP END SIMD"; - break; - case ST_OMP_END_LOOP: - p = "!$OMP END LOOP"; - break; - case ST_OMP_END_MASKED: - p = "!$OMP END MASKED"; - break; - case ST_OMP_END_MASKED_TASKLOOP: - p = "!$OMP END MASKED TASKLOOP"; - break; - case ST_OMP_END_MASKED_TASKLOOP_SIMD: - p = "!$OMP END MASKED TASKLOOP SIMD"; - break; - case ST_OMP_END_MASTER: - p = "!$OMP END MASTER"; - break; - case ST_OMP_END_MASTER_TASKLOOP: - p = "!$OMP END MASTER TASKLOOP"; - break; - case ST_OMP_END_MASTER_TASKLOOP_SIMD: - p = "!$OMP END MASTER TASKLOOP SIMD"; - break; - case ST_OMP_END_ORDERED: - p = "!$OMP END ORDERED"; - break; - case ST_OMP_END_PARALLEL: - p = "!$OMP END PARALLEL"; - break; - case ST_OMP_END_PARALLEL_DO: - p = "!$OMP END PARALLEL DO"; - break; - case ST_OMP_END_PARALLEL_DO_SIMD: - p = "!$OMP END PARALLEL DO SIMD"; - break; - case ST_OMP_END_PARALLEL_LOOP: - p = "!$OMP END PARALLEL LOOP"; - break; - case ST_OMP_END_PARALLEL_MASKED: - p = "!$OMP END PARALLEL MASKED"; - break; - case ST_OMP_END_PARALLEL_MASKED_TASKLOOP: - p = "!$OMP END PARALLEL MASKED TASKLOOP"; - break; - case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD: - p = "!$OMP END PARALLEL MASKED TASKLOOP SIMD"; - break; - case ST_OMP_END_PARALLEL_MASTER: - p = "!$OMP END PARALLEL MASTER"; - break; - case ST_OMP_END_PARALLEL_MASTER_TASKLOOP: - p = "!$OMP END PARALLEL MASTER TASKLOOP"; - break; - case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD: - p = "!$OMP END PARALLEL MASTER TASKLOOP SIMD"; - break; - case ST_OMP_END_PARALLEL_SECTIONS: - p = "!$OMP END PARALLEL SECTIONS"; - break; - case ST_OMP_END_PARALLEL_WORKSHARE: - p = "!$OMP END PARALLEL WORKSHARE"; - break; - case ST_OMP_END_SECTIONS: - p = "!$OMP END SECTIONS"; - break; - case ST_OMP_END_SINGLE: - p = "!$OMP END SINGLE"; - break; - case ST_OMP_END_TASK: - p = "!$OMP END TASK"; - break; - case ST_OMP_END_TARGET: - p = "!$OMP END TARGET"; - break; - case ST_OMP_END_TARGET_DATA: - p = "!$OMP END TARGET DATA"; - break; - case ST_OMP_END_TARGET_PARALLEL: - p = "!$OMP END TARGET PARALLEL"; - break; - case ST_OMP_END_TARGET_PARALLEL_DO: - p = "!$OMP END TARGET PARALLEL DO"; - break; - case ST_OMP_END_TARGET_PARALLEL_DO_SIMD: - p = "!$OMP END TARGET PARALLEL DO SIMD"; - break; - case ST_OMP_END_TARGET_PARALLEL_LOOP: - p = "!$OMP END TARGET PARALLEL LOOP"; - break; - case ST_OMP_END_TARGET_SIMD: - p = "!$OMP END TARGET SIMD"; - break; - case ST_OMP_END_TARGET_TEAMS: - p = "!$OMP END TARGET TEAMS"; - break; - case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE: - p = "!$OMP END TARGET TEAMS DISTRIBUTE"; - break; - case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO"; - break; - case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; - break; - case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD: - p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD"; - break; - case ST_OMP_END_TARGET_TEAMS_LOOP: - p = "!$OMP END TARGET TEAMS LOOP"; - break; - case ST_OMP_END_TASKGROUP: - p = "!$OMP END TASKGROUP"; - break; - case ST_OMP_END_TASKLOOP: - p = "!$OMP END TASKLOOP"; - break; - case ST_OMP_END_TASKLOOP_SIMD: - p = "!$OMP END TASKLOOP SIMD"; - break; - case ST_OMP_END_TEAMS: - p = "!$OMP END TEAMS"; - break; - case ST_OMP_END_TEAMS_DISTRIBUTE: - p = "!$OMP END TEAMS DISTRIBUTE"; - break; - case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO: - p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO"; - break; - case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD"; - break; - case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD: - p = "!$OMP END TEAMS DISTRIBUTE SIMD"; - break; - case ST_OMP_END_TEAMS_LOOP: - p = "!$OMP END TEAMS LOOP"; - break; - case ST_OMP_END_WORKSHARE: - p = "!$OMP END WORKSHARE"; - break; - case ST_OMP_ERROR: - p = "!$OMP ERROR"; - break; - case ST_OMP_FLUSH: - p = "!$OMP FLUSH"; - break; - case ST_OMP_LOOP: - p = "!$OMP LOOP"; - break; - case ST_OMP_MASKED: - p = "!$OMP MASKED"; - break; - case ST_OMP_MASKED_TASKLOOP: - p = "!$OMP MASKED TASKLOOP"; - break; - case ST_OMP_MASKED_TASKLOOP_SIMD: - p = "!$OMP MASKED TASKLOOP SIMD"; - break; - case ST_OMP_MASTER: - p = "!$OMP MASTER"; - break; - case ST_OMP_MASTER_TASKLOOP: - p = "!$OMP MASTER TASKLOOP"; - break; - case ST_OMP_MASTER_TASKLOOP_SIMD: - p = "!$OMP MASTER TASKLOOP SIMD"; - break; - case ST_OMP_ORDERED: - case ST_OMP_ORDERED_DEPEND: - p = "!$OMP ORDERED"; - break; - case ST_OMP_PARALLEL: - p = "!$OMP PARALLEL"; - break; - case ST_OMP_PARALLEL_DO: - p = "!$OMP PARALLEL DO"; - break; - case ST_OMP_PARALLEL_LOOP: - p = "!$OMP PARALLEL LOOP"; - break; - case ST_OMP_PARALLEL_DO_SIMD: - p = "!$OMP PARALLEL DO SIMD"; - break; - case ST_OMP_PARALLEL_MASKED: - p = "!$OMP PARALLEL MASKED"; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP: - p = "!$OMP PARALLEL MASKED TASKLOOP"; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - p = "!$OMP PARALLEL MASKED TASKLOOP SIMD"; - break; - case ST_OMP_PARALLEL_MASTER: - p = "!$OMP PARALLEL MASTER"; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP: - p = "!$OMP PARALLEL MASTER TASKLOOP"; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - p = "!$OMP PARALLEL MASTER TASKLOOP SIMD"; - break; - case ST_OMP_PARALLEL_SECTIONS: - p = "!$OMP PARALLEL SECTIONS"; - break; - case ST_OMP_PARALLEL_WORKSHARE: - p = "!$OMP PARALLEL WORKSHARE"; - break; - case ST_OMP_REQUIRES: - p = "!$OMP REQUIRES"; - break; - case ST_OMP_SCAN: - p = "!$OMP SCAN"; - break; - case ST_OMP_SCOPE: - p = "!$OMP SCOPE"; - break; - case ST_OMP_SECTIONS: - p = "!$OMP SECTIONS"; - break; - case ST_OMP_SECTION: - p = "!$OMP SECTION"; - break; - case ST_OMP_SIMD: - p = "!$OMP SIMD"; - break; - case ST_OMP_SINGLE: - p = "!$OMP SINGLE"; - break; - case ST_OMP_TARGET: - p = "!$OMP TARGET"; - break; - case ST_OMP_TARGET_DATA: - p = "!$OMP TARGET DATA"; - break; - case ST_OMP_TARGET_ENTER_DATA: - p = "!$OMP TARGET ENTER DATA"; - break; - case ST_OMP_TARGET_EXIT_DATA: - p = "!$OMP TARGET EXIT DATA"; - break; - case ST_OMP_TARGET_PARALLEL: - p = "!$OMP TARGET PARALLEL"; - break; - case ST_OMP_TARGET_PARALLEL_DO: - p = "!$OMP TARGET PARALLEL DO"; - break; - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - p = "!$OMP TARGET PARALLEL DO SIMD"; - break; - case ST_OMP_TARGET_PARALLEL_LOOP: - p = "!$OMP TARGET PARALLEL LOOP"; - break; - case ST_OMP_TARGET_SIMD: - p = "!$OMP TARGET SIMD"; - break; - case ST_OMP_TARGET_TEAMS: - p = "!$OMP TARGET TEAMS"; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - p = "!$OMP TARGET TEAMS DISTRIBUTE"; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; - break; - case ST_OMP_TARGET_TEAMS_LOOP: - p = "!$OMP TARGET TEAMS LOOP"; - break; - case ST_OMP_TARGET_UPDATE: - p = "!$OMP TARGET UPDATE"; - break; - case ST_OMP_TASK: - p = "!$OMP TASK"; - break; - case ST_OMP_TASKGROUP: - p = "!$OMP TASKGROUP"; - break; - case ST_OMP_TASKLOOP: - p = "!$OMP TASKLOOP"; - break; - case ST_OMP_TASKLOOP_SIMD: - p = "!$OMP TASKLOOP SIMD"; - break; - case ST_OMP_TASKWAIT: - p = "!$OMP TASKWAIT"; - break; - case ST_OMP_TASKYIELD: - p = "!$OMP TASKYIELD"; - break; - case ST_OMP_TEAMS: - p = "!$OMP TEAMS"; - break; - case ST_OMP_TEAMS_DISTRIBUTE: - p = "!$OMP TEAMS DISTRIBUTE"; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; - break; - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - p = "!$OMP TEAMS DISTRIBUTE SIMD"; - break; - case ST_OMP_TEAMS_LOOP: - p = "!$OMP TEAMS LOOP"; - break; - case ST_OMP_THREADPRIVATE: - p = "!$OMP THREADPRIVATE"; - break; - case ST_OMP_WORKSHARE: - p = "!$OMP WORKSHARE"; - break; - default: - gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); - } - - return p; -} - - -/* Create a symbol for the main program and assign it to ns->proc_name. */ - -static void -main_program_symbol (gfc_namespace *ns, const char *name) -{ - gfc_symbol *main_program; - symbol_attribute attr; - - gfc_get_symbol (name, ns, &main_program); - gfc_clear_attr (&attr); - attr.flavor = FL_PROGRAM; - attr.proc = PROC_UNKNOWN; - attr.subroutine = 1; - attr.access = ACCESS_PUBLIC; - attr.is_main_program = 1; - main_program->attr = attr; - main_program->declared_at = gfc_current_locus; - ns->proc_name = main_program; - gfc_commit_symbols (); -} - - -/* Do whatever is necessary to accept the last statement. */ - -static void -accept_statement (gfc_statement st) -{ - switch (st) - { - case ST_IMPLICIT_NONE: - case ST_IMPLICIT: - break; - - case ST_FUNCTION: - case ST_SUBROUTINE: - case ST_MODULE: - case ST_SUBMODULE: - gfc_current_ns->proc_name = gfc_new_block; - break; - - /* If the statement is the end of a block, lay down a special code - that allows a branch to the end of the block from within the - construct. IF and SELECT are treated differently from DO - (where EXEC_NOP is added inside the loop) for two - reasons: - 1. END DO has a meaning in the sense that after a GOTO to - it, the loop counter must be increased. - 2. IF blocks and SELECT blocks can consist of multiple - parallel blocks (IF ... ELSE IF ... ELSE ... END IF). - Putting the label before the END IF would make the jump - from, say, the ELSE IF block to the END IF illegal. */ - - case ST_ENDIF: - case ST_END_SELECT: - case ST_END_CRITICAL: - if (gfc_statement_label != NULL) - { - new_st.op = EXEC_END_NESTED_BLOCK; - add_statement (); - } - break; - - /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than - one parallel block. Thus, we add the special code to the nested block - itself, instead of the parent one. */ - case ST_END_BLOCK: - case ST_END_ASSOCIATE: - if (gfc_statement_label != NULL) - { - new_st.op = EXEC_END_BLOCK; - add_statement (); - } - break; - - /* The end-of-program unit statements do not get the special - marker and require a statement of some sort if they are a - branch target. */ - - case ST_END_PROGRAM: - case ST_END_FUNCTION: - case ST_END_SUBROUTINE: - if (gfc_statement_label != NULL) - { - new_st.op = EXEC_RETURN; - add_statement (); - } - else - { - new_st.op = EXEC_END_PROCEDURE; - add_statement (); - } - - break; - - case ST_ENTRY: - case_executable: - case_exec_markers: - add_statement (); - break; - - default: - break; - } - - gfc_commit_symbols (); - gfc_warning_check (); - gfc_clear_new_st (); -} - - -/* Undo anything tentative that has been built for the current statement, - except if a gfc_charlen structure has been added to current namespace's - list of gfc_charlen structure. */ - -static void -reject_statement (void) -{ - gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv); - gfc_current_ns->equiv = gfc_current_ns->old_equiv; - - gfc_reject_data (gfc_current_ns); - - gfc_new_block = NULL; - gfc_undo_symbols (); - gfc_clear_warning (); - undo_new_statement (); -} - - -/* Generic complaint about an out of order statement. We also do - whatever is necessary to clean up. */ - -static void -unexpected_statement (gfc_statement st) -{ - gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); - - reject_statement (); -} - - -/* Given the next statement seen by the matcher, make sure that it is - in proper order with the last. This subroutine is initialized by - calling it with an argument of ST_NONE. If there is a problem, we - issue an error and return false. Otherwise we return true. - - Individual parsers need to verify that the statements seen are - valid before calling here, i.e., ENTRY statements are not allowed in - INTERFACE blocks. The following diagram is taken from the standard: - - +---------------------------------------+ - | program subroutine function module | - +---------------------------------------+ - | use | - +---------------------------------------+ - | import | - +---------------------------------------+ - | | implicit none | - | +-----------+------------------+ - | | parameter | implicit | - | +-----------+------------------+ - | format | | derived type | - | entry | parameter | interface | - | | data | specification | - | | | statement func | - | +-----------+------------------+ - | | data | executable | - +--------+-----------+------------------+ - | contains | - +---------------------------------------+ - | internal module/subprogram | - +---------------------------------------+ - | end | - +---------------------------------------+ - -*/ - -enum state_order -{ - ORDER_START, - ORDER_USE, - ORDER_IMPORT, - ORDER_IMPLICIT_NONE, - ORDER_IMPLICIT, - ORDER_SPEC, - ORDER_EXEC -}; - -typedef struct -{ - enum state_order state; - gfc_statement last_statement; - locus where; -} -st_state; - -static bool -verify_st_order (st_state *p, gfc_statement st, bool silent) -{ - - switch (st) - { - case ST_NONE: - p->state = ORDER_START; - break; - - case ST_USE: - if (p->state > ORDER_USE) - goto order; - p->state = ORDER_USE; - break; - - case ST_IMPORT: - if (p->state > ORDER_IMPORT) - goto order; - p->state = ORDER_IMPORT; - break; - - case ST_IMPLICIT_NONE: - if (p->state > ORDER_IMPLICIT) - goto order; - - /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY - statement disqualifies a USE but not an IMPLICIT NONE. - Duplicate IMPLICIT NONEs are caught when the implicit types - are set. */ - - p->state = ORDER_IMPLICIT_NONE; - break; - - case ST_IMPLICIT: - if (p->state > ORDER_IMPLICIT) - goto order; - p->state = ORDER_IMPLICIT; - break; - - case ST_FORMAT: - case ST_ENTRY: - if (p->state < ORDER_IMPLICIT_NONE) - p->state = ORDER_IMPLICIT_NONE; - break; - - case ST_PARAMETER: - if (p->state >= ORDER_EXEC) - goto order; - if (p->state < ORDER_IMPLICIT) - p->state = ORDER_IMPLICIT; - break; - - case ST_DATA: - if (p->state < ORDER_SPEC) - p->state = ORDER_SPEC; - break; - - case ST_PUBLIC: - case ST_PRIVATE: - case ST_STRUCTURE_DECL: - case ST_DERIVED_DECL: - case_decl: - if (p->state >= ORDER_EXEC) - goto order; - if (p->state < ORDER_SPEC) - p->state = ORDER_SPEC; - break; - - case_omp_decl: - /* The OpenMP/OpenACC directives have to be somewhere in the specification - part, but there are no further requirements on their ordering. - Thus don't adjust p->state, just ignore them. */ - if (p->state >= ORDER_EXEC) - goto order; - break; - - case_executable: - case_exec_markers: - if (p->state < ORDER_EXEC) - p->state = ORDER_EXEC; - break; - - default: - return false; - } - - /* All is well, record the statement in case we need it next time. */ - p->where = gfc_current_locus; - p->last_statement = st; - return true; - -order: - if (!silent) - gfc_error ("%s statement at %C cannot follow %s statement at %L", - gfc_ascii_statement (st), - gfc_ascii_statement (p->last_statement), &p->where); - - return false; -} - - -/* Handle an unexpected end of file. This is a show-stopper... */ - -static void unexpected_eof (void) ATTRIBUTE_NORETURN; - -static void -unexpected_eof (void) -{ - gfc_state_data *p; - - gfc_error ("Unexpected end of file in %qs", gfc_source_file); - - /* Memory cleanup. Move to "second to last". */ - for (p = gfc_state_stack; p && p->previous && p->previous->previous; - p = p->previous); - - gfc_current_ns->code = (p && p->previous) ? p->head : NULL; - gfc_done_2 (); - - longjmp (eof_buf, 1); - - /* Avoids build error on systems where longjmp is not declared noreturn. */ - gcc_unreachable (); -} - - -/* Parse the CONTAINS section of a derived type definition. */ - -gfc_access gfc_typebound_default_access; - -static bool -parse_derived_contains (void) -{ - gfc_state_data s; - bool seen_private = false; - bool seen_comps = false; - bool error_flag = false; - bool to_finish; - - gcc_assert (gfc_current_state () == COMP_DERIVED); - gcc_assert (gfc_current_block ()); - - /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS - section. */ - if (gfc_current_block ()->attr.sequence) - gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS" - " section at %C", gfc_current_block ()->name); - if (gfc_current_block ()->attr.is_bind_c) - gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS" - " section at %C", gfc_current_block ()->name); - - accept_statement (ST_CONTAINS); - push_state (&s, COMP_DERIVED_CONTAINS, NULL); - - gfc_typebound_default_access = ACCESS_PUBLIC; - - to_finish = false; - while (!to_finish) - { - gfc_statement st; - st = next_statement (); - switch (st) - { - case ST_NONE: - unexpected_eof (); - break; - - case ST_DATA_DECL: - gfc_error ("Components in TYPE at %C must precede CONTAINS"); - goto error; - - case ST_PROCEDURE: - if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C")) - goto error; - - accept_statement (ST_PROCEDURE); - seen_comps = true; - break; - - case ST_GENERIC: - if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C")) - goto error; - - accept_statement (ST_GENERIC); - seen_comps = true; - break; - - case ST_FINAL: - if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration" - " at %C")) - goto error; - - accept_statement (ST_FINAL); - seen_comps = true; - break; - - case ST_END_TYPE: - to_finish = true; - - if (!seen_comps - && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition " - "at %C with empty CONTAINS section"))) - goto error; - - /* ST_END_TYPE is accepted by parse_derived after return. */ - break; - - case ST_PRIVATE: - if (!gfc_find_state (COMP_MODULE)) - { - gfc_error ("PRIVATE statement in TYPE at %C must be inside " - "a MODULE"); - goto error; - } - - if (seen_comps) - { - gfc_error ("PRIVATE statement at %C must precede procedure" - " bindings"); - goto error; - } - - if (seen_private) - { - gfc_error ("Duplicate PRIVATE statement at %C"); - goto error; - } - - accept_statement (ST_PRIVATE); - gfc_typebound_default_access = ACCESS_PRIVATE; - seen_private = true; - break; - - case ST_SEQUENCE: - gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); - goto error; - - case ST_CONTAINS: - gfc_error ("Already inside a CONTAINS block at %C"); - goto error; - - default: - unexpected_statement (st); - break; - } - - continue; - -error: - error_flag = true; - reject_statement (); - } - - pop_state (); - gcc_assert (gfc_current_state () == COMP_DERIVED); - - return error_flag; -} - - -/* Set attributes for the parent symbol based on the attributes of a component - and raise errors if conflicting attributes are found for the component. */ - -static void -check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp, - gfc_component **eventp) -{ - bool coarray, lock_type, event_type, allocatable, pointer; - coarray = lock_type = event_type = allocatable = pointer = false; - gfc_component *lock_comp = NULL, *event_comp = NULL; - - if (lockp) lock_comp = *lockp; - if (eventp) event_comp = *eventp; - - /* Look for allocatable components. */ - if (c->attr.allocatable - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.allocatable) - || (c->ts.type == BT_DERIVED && !c->attr.pointer - && c->ts.u.derived->attr.alloc_comp)) - { - allocatable = true; - sym->attr.alloc_comp = 1; - } - - /* Look for pointer components. */ - if (c->attr.pointer - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.class_pointer) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) - { - pointer = true; - sym->attr.pointer_comp = 1; - } - - /* Look for procedure pointer components. */ - if (c->attr.proc_pointer - || (c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.proc_pointer_comp)) - sym->attr.proc_pointer_comp = 1; - - /* Looking for coarray components. */ - if (c->attr.codimension - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->attr.codimension)) - { - coarray = true; - sym->attr.coarray_comp = 1; - } - - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp - && !c->attr.pointer) - { - coarray = true; - sym->attr.coarray_comp = 1; - } - - /* Looking for lock_type components. */ - if ((c->ts.type == BT_DERIVED - && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && CLASS_DATA (c)->ts.u.derived->intmod_sym_id - == ISOFORTRAN_LOCK_TYPE) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp - && !allocatable && !pointer)) - { - lock_type = 1; - lock_comp = c; - sym->attr.lock_comp = 1; - } - - /* Looking for event_type components. */ - if ((c->ts.type == BT_DERIVED - && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) - || (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && CLASS_DATA (c)->ts.u.derived->intmod_sym_id - == ISOFORTRAN_EVENT_TYPE) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp - && !allocatable && !pointer)) - { - event_type = 1; - event_comp = c; - sym->attr.event_comp = 1; - } - - /* Check for F2008, C1302 - and recall that pointers may not be coarrays - (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7), - unless there are nondirect [allocatable or pointer] components - involved (cf. 1.3.33.1 and 1.3.33.3). */ - - if (pointer && !coarray && lock_type) - gfc_error ("Component %s at %L of type LOCK_TYPE must have a " - "codimension or be a subcomponent of a coarray, " - "which is not possible as the component has the " - "pointer attribute", c->name, &c->loc); - else if (pointer && !coarray && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.lock_comp) - gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " - "of type LOCK_TYPE, which must have a codimension or be a " - "subcomponent of a coarray", c->name, &c->loc); - - if (lock_type && allocatable && !coarray) - gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have " - "a codimension", c->name, &c->loc); - else if (lock_type && allocatable && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.lock_comp) - gfc_error ("Allocatable component %s at %L must have a codimension as " - "it has a noncoarray subcomponent of type LOCK_TYPE", - c->name, &c->loc); - - if (sym->attr.coarray_comp && !coarray && lock_type) - gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " - "subcomponent of type LOCK_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as already a coarray " - "subcomponent exists)", c->name, &c->loc, sym->name); - - if (sym->attr.lock_comp && coarray && !lock_type) - gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " - "subcomponent of type LOCK_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as %s at %L has a codimension or a " - "coarray subcomponent)", lock_comp->name, &lock_comp->loc, - sym->name, c->name, &c->loc); - - /* Similarly for EVENT TYPE. */ - - if (pointer && !coarray && event_type) - gfc_error ("Component %s at %L of type EVENT_TYPE must have a " - "codimension or be a subcomponent of a coarray, " - "which is not possible as the component has the " - "pointer attribute", c->name, &c->loc); - else if (pointer && !coarray && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.event_comp) - gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " - "of type EVENT_TYPE, which must have a codimension or be a " - "subcomponent of a coarray", c->name, &c->loc); - - if (event_type && allocatable && !coarray) - gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have " - "a codimension", c->name, &c->loc); - else if (event_type && allocatable && c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.event_comp) - gfc_error ("Allocatable component %s at %L must have a codimension as " - "it has a noncoarray subcomponent of type EVENT_TYPE", - c->name, &c->loc); - - if (sym->attr.coarray_comp && !coarray && event_type) - gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " - "subcomponent of type EVENT_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as already a coarray " - "subcomponent exists)", c->name, &c->loc, sym->name); - - if (sym->attr.event_comp && coarray && !event_type) - gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " - "subcomponent of type EVENT_TYPE must have a codimension or " - "be a subcomponent of a coarray. (Variables of type %s may " - "not have a codimension as %s at %L has a codimension or a " - "coarray subcomponent)", event_comp->name, &event_comp->loc, - sym->name, c->name, &c->loc); - - /* Look for private components. */ - if (sym->component_access == ACCESS_PRIVATE - || c->attr.access == ACCESS_PRIVATE - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp)) - sym->attr.private_comp = 1; - - if (lockp) *lockp = lock_comp; - if (eventp) *eventp = event_comp; -} - - -static void parse_struct_map (gfc_statement); - -/* Parse a union component definition within a structure definition. */ - -static void -parse_union (void) -{ - int compiling; - gfc_statement st; - gfc_state_data s; - gfc_component *c, *lock_comp = NULL, *event_comp = NULL; - gfc_symbol *un; - - accept_statement(ST_UNION); - push_state (&s, COMP_UNION, gfc_new_block); - un = gfc_new_block; - - compiling = 1; - - while (compiling) - { - st = next_statement (); - /* Only MAP declarations valid within a union. */ - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_MAP: - accept_statement (ST_MAP); - parse_struct_map (ST_MAP); - /* Add a component to the union for each map. */ - if (!gfc_add_component (un, gfc_new_block->name, &c)) - { - gfc_internal_error ("failed to create map component '%s'", - gfc_new_block->name); - reject_statement (); - return; - } - c->ts.type = BT_DERIVED; - c->ts.u.derived = gfc_new_block; - /* Normally components get their initialization expressions when they - are created in decl.c (build_struct) so we can look through the - flat component list for initializers during resolution. Unions and - maps create components along with their type definitions so we - have to generate initializers here. */ - c->initializer = gfc_default_initializer (&c->ts); - break; - - case ST_END_UNION: - compiling = 0; - accept_statement (ST_END_UNION); - break; - - default: - unexpected_statement (st); - break; - } - } - - for (c = un->components; c; c = c->next) - check_component (un, c, &lock_comp, &event_comp); - - /* Add the union as a component in its parent structure. */ - pop_state (); - if (!gfc_add_component (gfc_current_block (), un->name, &c)) - { - gfc_internal_error ("failed to create union component '%s'", un->name); - reject_statement (); - return; - } - c->ts.type = BT_UNION; - c->ts.u.derived = un; - c->initializer = gfc_default_initializer (&c->ts); - - un->attr.zero_comp = un->components == NULL; -} - - -/* Parse a STRUCTURE or MAP. */ - -static void -parse_struct_map (gfc_statement block) -{ - int compiling_type; - gfc_statement st; - gfc_state_data s; - gfc_symbol *sym; - gfc_component *c, *lock_comp = NULL, *event_comp = NULL; - gfc_compile_state comp; - gfc_statement ends; - - if (block == ST_STRUCTURE_DECL) - { - comp = COMP_STRUCTURE; - ends = ST_END_STRUCTURE; - } - else - { - gcc_assert (block == ST_MAP); - comp = COMP_MAP; - ends = ST_END_MAP; - } - - accept_statement(block); - push_state (&s, comp, gfc_new_block); - - gfc_new_block->component_access = ACCESS_PUBLIC; - compiling_type = 1; - - while (compiling_type) - { - st = next_statement (); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - /* Nested structure declarations will be captured as ST_DATA_DECL. */ - case ST_STRUCTURE_DECL: - /* Let a more specific error make it to decode_statement(). */ - if (gfc_error_check () == 0) - gfc_error ("Syntax error in nested structure declaration at %C"); - reject_statement (); - /* Skip the rest of this statement. */ - gfc_error_recovery (); - break; - - case ST_UNION: - accept_statement (ST_UNION); - parse_union (); - break; - - case ST_DATA_DECL: - /* The data declaration was a nested/ad-hoc STRUCTURE field. */ - accept_statement (ST_DATA_DECL); - if (gfc_new_block && gfc_new_block != gfc_current_block () - && gfc_new_block->attr.flavor == FL_STRUCT) - parse_struct_map (ST_STRUCTURE_DECL); - break; - - case ST_END_STRUCTURE: - case ST_END_MAP: - if (st == ends) - { - accept_statement (st); - compiling_type = 0; - } - else - unexpected_statement (st); - break; - - default: - unexpected_statement (st); - break; - } - } - - /* Validate each component. */ - sym = gfc_current_block (); - for (c = sym->components; c; c = c->next) - check_component (sym, c, &lock_comp, &event_comp); - - sym->attr.zero_comp = (sym->components == NULL); - - /* Allow parse_union to find this structure to add to its list of maps. */ - if (block == ST_MAP) - gfc_new_block = gfc_current_block (); - - pop_state (); -} - - -/* Parse a derived type. */ - -static void -parse_derived (void) -{ - int compiling_type, seen_private, seen_sequence, seen_component; - gfc_statement st; - gfc_state_data s; - gfc_symbol *sym; - gfc_component *c, *lock_comp = NULL, *event_comp = NULL; - - accept_statement (ST_DERIVED_DECL); - push_state (&s, COMP_DERIVED, gfc_new_block); - - gfc_new_block->component_access = ACCESS_PUBLIC; - seen_private = 0; - seen_sequence = 0; - seen_component = 0; - - compiling_type = 1; - - while (compiling_type) - { - st = next_statement (); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_DATA_DECL: - case ST_PROCEDURE: - accept_statement (st); - seen_component = 1; - break; - - case ST_FINAL: - gfc_error ("FINAL declaration at %C must be inside CONTAINS"); - break; - - case ST_END_TYPE: -endType: - compiling_type = 0; - - if (!seen_component) - gfc_notify_std (GFC_STD_F2003, "Derived type " - "definition at %C without components"); - - accept_statement (ST_END_TYPE); - break; - - case ST_PRIVATE: - if (!gfc_find_state (COMP_MODULE)) - { - gfc_error ("PRIVATE statement in TYPE at %C must be inside " - "a MODULE"); - break; - } - - if (seen_component) - { - gfc_error ("PRIVATE statement at %C must precede " - "structure components"); - break; - } - - if (seen_private) - gfc_error ("Duplicate PRIVATE statement at %C"); - - s.sym->component_access = ACCESS_PRIVATE; - - accept_statement (ST_PRIVATE); - seen_private = 1; - break; - - case ST_SEQUENCE: - if (seen_component) - { - gfc_error ("SEQUENCE statement at %C must precede " - "structure components"); - break; - } - - if (gfc_current_block ()->attr.sequence) - gfc_warning (0, "SEQUENCE attribute at %C already specified in " - "TYPE statement"); - - if (seen_sequence) - { - gfc_error ("Duplicate SEQUENCE statement at %C"); - } - - seen_sequence = 1; - gfc_add_sequence (&gfc_current_block ()->attr, - gfc_current_block ()->name, NULL); - break; - - case ST_CONTAINS: - gfc_notify_std (GFC_STD_F2003, - "CONTAINS block in derived type" - " definition at %C"); - - accept_statement (ST_CONTAINS); - parse_derived_contains (); - goto endType; - - default: - unexpected_statement (st); - break; - } - } - - /* need to verify that all fields of the derived type are - * interoperable with C if the type is declared to be bind(c) - */ - sym = gfc_current_block (); - for (c = sym->components; c; c = c->next) - check_component (sym, c, &lock_comp, &event_comp); - - if (!seen_component) - sym->attr.zero_comp = 1; - - pop_state (); -} - - -/* Parse an ENUM. */ - -static void -parse_enum (void) -{ - gfc_statement st; - int compiling_enum; - gfc_state_data s; - int seen_enumerator = 0; - - push_state (&s, COMP_ENUM, gfc_new_block); - - compiling_enum = 1; - - while (compiling_enum) - { - st = next_statement (); - switch (st) - { - case ST_NONE: - unexpected_eof (); - break; - - case ST_ENUMERATOR: - seen_enumerator = 1; - accept_statement (st); - break; - - case ST_END_ENUM: - compiling_enum = 0; - if (!seen_enumerator) - gfc_error ("ENUM declaration at %C has no ENUMERATORS"); - accept_statement (st); - break; - - default: - gfc_free_enum_history (); - unexpected_statement (st); - break; - } - } - pop_state (); -} - - -/* Parse an interface. We must be able to deal with the possibility - of recursive interfaces. The parse_spec() subroutine is mutually - recursive with parse_interface(). */ - -static gfc_statement parse_spec (gfc_statement); - -static void -parse_interface (void) -{ - gfc_compile_state new_state = COMP_NONE, current_state; - gfc_symbol *prog_unit, *sym; - gfc_interface_info save; - gfc_state_data s1, s2; - gfc_statement st; - - accept_statement (ST_INTERFACE); - - current_interface.ns = gfc_current_ns; - save = current_interface; - - sym = (current_interface.type == INTERFACE_GENERIC - || current_interface.type == INTERFACE_USER_OP) - ? gfc_new_block : NULL; - - push_state (&s1, COMP_INTERFACE, sym); - current_state = COMP_NONE; - -loop: - gfc_current_ns = gfc_get_namespace (current_interface.ns, 0); - - st = next_statement (); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_SUBROUTINE: - case ST_FUNCTION: - if (st == ST_SUBROUTINE) - new_state = COMP_SUBROUTINE; - else if (st == ST_FUNCTION) - new_state = COMP_FUNCTION; - if (gfc_new_block->attr.pointer) - { - gfc_new_block->attr.pointer = 0; - gfc_new_block->attr.proc_pointer = 1; - } - if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, - gfc_new_block->formal, NULL)) - { - reject_statement (); - gfc_free_namespace (gfc_current_ns); - goto loop; - } - /* F2008 C1210 forbids the IMPORT statement in module procedure - interface bodies and the flag is set to import symbols. */ - if (gfc_new_block->attr.module_procedure) - gfc_current_ns->has_import_set = 1; - break; - - case ST_PROCEDURE: - case ST_MODULE_PROC: /* The module procedure matcher makes - sure the context is correct. */ - accept_statement (st); - gfc_free_namespace (gfc_current_ns); - goto loop; - - case ST_END_INTERFACE: - gfc_free_namespace (gfc_current_ns); - gfc_current_ns = current_interface.ns; - goto done; - - default: - gfc_error ("Unexpected %s statement in INTERFACE block at %C", - gfc_ascii_statement (st)); - reject_statement (); - gfc_free_namespace (gfc_current_ns); - goto loop; - } - - - /* Make sure that the generic name has the right attribute. */ - if (current_interface.type == INTERFACE_GENERIC - && current_state == COMP_NONE) - { - if (new_state == COMP_FUNCTION && sym) - gfc_add_function (&sym->attr, sym->name, NULL); - else if (new_state == COMP_SUBROUTINE && sym) - gfc_add_subroutine (&sym->attr, sym->name, NULL); - - current_state = new_state; - } - - if (current_interface.type == INTERFACE_ABSTRACT) - { - gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus); - if (gfc_is_intrinsic_typename (gfc_new_block->name)) - gfc_error ("Name %qs of ABSTRACT INTERFACE at %C " - "cannot be the same as an intrinsic type", - gfc_new_block->name); - } - - push_state (&s2, new_state, gfc_new_block); - accept_statement (st); - prog_unit = gfc_new_block; - prog_unit->formal_ns = gfc_current_ns; - if (prog_unit == prog_unit->formal_ns->proc_name - && prog_unit->ns != prog_unit->formal_ns) - prog_unit->refs++; - -decl: - /* Read data declaration statements. */ - st = parse_spec (ST_NONE); - in_specification_block = true; - - /* Since the interface block does not permit an IMPLICIT statement, - the default type for the function or the result must be taken - from the formal namespace. */ - if (new_state == COMP_FUNCTION) - { - if (prog_unit->result == prog_unit - && prog_unit->ts.type == BT_UNKNOWN) - gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns); - else if (prog_unit->result != prog_unit - && prog_unit->result->ts.type == BT_UNKNOWN) - gfc_set_default_type (prog_unit->result, 1, - prog_unit->formal_ns); - } - - if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION) - { - gfc_error ("Unexpected %s statement at %C in INTERFACE body", - gfc_ascii_statement (st)); - reject_statement (); - goto decl; - } - - /* Add EXTERNAL attribute to function or subroutine. */ - if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy) - gfc_add_external (&prog_unit->attr, &gfc_current_locus); - - current_interface = save; - gfc_add_interface (prog_unit); - pop_state (); - - if (current_interface.ns - && current_interface.ns->proc_name - && strcmp (current_interface.ns->proc_name->name, - prog_unit->name) == 0) - gfc_error ("INTERFACE procedure %qs at %L has the same name as the " - "enclosing procedure", prog_unit->name, - ¤t_interface.ns->proc_name->declared_at); - - goto loop; - -done: - pop_state (); -} - - -/* Associate function characteristics by going back to the function - declaration and rematching the prefix. */ - -static match -match_deferred_characteristics (gfc_typespec * ts) -{ - locus loc; - match m = MATCH_ERROR; - char name[GFC_MAX_SYMBOL_LEN + 1]; - - loc = gfc_current_locus; - - gfc_current_locus = gfc_current_block ()->declared_at; - - gfc_clear_error (); - gfc_buffer_error (true); - m = gfc_match_prefix (ts); - gfc_buffer_error (false); - - if (ts->type == BT_DERIVED) - { - ts->kind = 0; - - if (!ts->u.derived) - m = MATCH_ERROR; - } - - /* Only permit one go at the characteristic association. */ - if (ts->kind == -1) - ts->kind = 0; - - /* Set the function locus correctly. If we have not found the - function name, there is an error. */ - if (m == MATCH_YES - && gfc_match ("function% %n", name) == MATCH_YES - && strcmp (name, gfc_current_block ()->name) == 0) - { - gfc_current_block ()->declared_at = gfc_current_locus; - gfc_commit_symbols (); - } - else - { - gfc_error_check (); - gfc_undo_symbols (); - } - - gfc_current_locus =loc; - return m; -} - - -/* Check specification-expressions in the function result of the currently - parsed block and ensure they are typed (give an IMPLICIT type if necessary). - For return types specified in a FUNCTION prefix, the IMPLICIT rules of the - scope are not yet parsed so this has to be delayed up to parse_spec. */ - -static void -check_function_result_typed (void) -{ - gfc_typespec ts; - - gcc_assert (gfc_current_state () == COMP_FUNCTION); - - if (!gfc_current_ns->proc_name->result) return; - - ts = gfc_current_ns->proc_name->result->ts; - - /* Check type-parameters, at the moment only CHARACTER lengths possible. */ - /* TODO: Extend when KIND type parameters are implemented. */ - if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length) - gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true); -} - - -/* Parse a set of specification statements. Returns the statement - that doesn't fit. */ - -static gfc_statement -parse_spec (gfc_statement st) -{ - st_state ss; - bool function_result_typed = false; - bool bad_characteristic = false; - gfc_typespec *ts; - - in_specification_block = true; - - verify_st_order (&ss, ST_NONE, false); - if (st == ST_NONE) - st = next_statement (); - - /* If we are not inside a function or don't have a result specified so far, - do nothing special about it. */ - if (gfc_current_state () != COMP_FUNCTION) - function_result_typed = true; - else - { - gfc_symbol* proc = gfc_current_ns->proc_name; - gcc_assert (proc); - - if (proc->result->ts.type == BT_UNKNOWN) - function_result_typed = true; - } - -loop: - - /* If we're inside a BLOCK construct, some statements are disallowed. - Check this here. Attribute declaration statements like INTENT, OPTIONAL - or VALUE are also disallowed, but they don't have a particular ST_* - key so we have to check for them individually in their matcher routine. */ - if (gfc_current_state () == COMP_BLOCK) - switch (st) - { - case ST_IMPLICIT: - case ST_IMPLICIT_NONE: - case ST_NAMELIST: - case ST_COMMON: - case ST_EQUIVALENCE: - case ST_STATEMENT_FUNCTION: - gfc_error ("%s statement is not allowed inside of BLOCK at %C", - gfc_ascii_statement (st)); - reject_statement (); - break; - - default: - break; - } - else if (gfc_current_state () == COMP_BLOCK_DATA) - /* Fortran 2008, C1116. */ - switch (st) - { - case ST_ATTR_DECL: - case ST_COMMON: - case ST_DATA: - case ST_DATA_DECL: - case ST_DERIVED_DECL: - case ST_END_BLOCK_DATA: - case ST_EQUIVALENCE: - case ST_IMPLICIT: - case ST_IMPLICIT_NONE: - case ST_OMP_THREADPRIVATE: - case ST_PARAMETER: - case ST_STRUCTURE_DECL: - case ST_TYPE: - case ST_USE: - break; - - case ST_NONE: - break; - - default: - gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C", - gfc_ascii_statement (st)); - reject_statement (); - break; - } - - /* If we find a statement that cannot be followed by an IMPLICIT statement - (and thus we can expect to see none any further), type the function result - if it has not yet been typed. Be careful not to give the END statement - to verify_st_order! */ - if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS) - { - bool verify_now = false; - - if (st == ST_END_FUNCTION || st == ST_CONTAINS) - verify_now = true; - else - { - st_state dummyss; - verify_st_order (&dummyss, ST_NONE, false); - verify_st_order (&dummyss, st, false); - - if (!verify_st_order (&dummyss, ST_IMPLICIT, true)) - verify_now = true; - } - - if (verify_now) - { - check_function_result_typed (); - function_result_typed = true; - } - } - - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_IMPLICIT_NONE: - case ST_IMPLICIT: - if (!function_result_typed) - { - check_function_result_typed (); - function_result_typed = true; - } - goto declSt; - - case ST_FORMAT: - case ST_ENTRY: - case ST_DATA: /* Not allowed in interfaces */ - if (gfc_current_state () == COMP_INTERFACE) - break; - - /* Fall through */ - - case ST_USE: - case ST_IMPORT: - case ST_PARAMETER: - case ST_PUBLIC: - case ST_PRIVATE: - case ST_STRUCTURE_DECL: - case ST_DERIVED_DECL: - case_decl: - case_omp_decl: -declSt: - if (!verify_st_order (&ss, st, false)) - { - reject_statement (); - st = next_statement (); - goto loop; - } - - switch (st) - { - case ST_INTERFACE: - parse_interface (); - break; - - case ST_STRUCTURE_DECL: - parse_struct_map (ST_STRUCTURE_DECL); - break; - - case ST_DERIVED_DECL: - parse_derived (); - break; - - case ST_PUBLIC: - case ST_PRIVATE: - if (gfc_current_state () != COMP_MODULE) - { - gfc_error ("%s statement must appear in a MODULE", - gfc_ascii_statement (st)); - reject_statement (); - break; - } - - if (gfc_current_ns->default_access != ACCESS_UNKNOWN) - { - gfc_error ("%s statement at %C follows another accessibility " - "specification", gfc_ascii_statement (st)); - reject_statement (); - break; - } - - gfc_current_ns->default_access = (st == ST_PUBLIC) - ? ACCESS_PUBLIC : ACCESS_PRIVATE; - - break; - - case ST_STATEMENT_FUNCTION: - if (gfc_current_state () == COMP_MODULE - || gfc_current_state () == COMP_SUBMODULE) - { - unexpected_statement (st); - break; - } - - default: - break; - } - - accept_statement (st); - st = next_statement (); - goto loop; - - case ST_ENUM: - accept_statement (st); - parse_enum(); - st = next_statement (); - goto loop; - - case ST_GET_FCN_CHARACTERISTICS: - /* This statement triggers the association of a function's result - characteristics. */ - ts = &gfc_current_block ()->result->ts; - if (match_deferred_characteristics (ts) != MATCH_YES) - bad_characteristic = true; - - st = next_statement (); - goto loop; - - default: - break; - } - - /* If match_deferred_characteristics failed, then there is an error. */ - if (bad_characteristic) - { - ts = &gfc_current_block ()->result->ts; - if (ts->type != BT_DERIVED) - gfc_error ("Bad kind expression for function %qs at %L", - gfc_current_block ()->name, - &gfc_current_block ()->declared_at); - else - gfc_error ("The type for function %qs at %L is not accessible", - gfc_current_block ()->name, - &gfc_current_block ()->declared_at); - - gfc_current_block ()->ts.kind = 0; - /* Keep the derived type; if it's bad, it will be discovered later. */ - if (!(ts->type == BT_DERIVED && ts->u.derived)) - ts->type = BT_UNKNOWN; - } - - in_specification_block = false; - - return st; -} - - -/* Parse a WHERE block, (not a simple WHERE statement). */ - -static void -parse_where_block (void) -{ - int seen_empty_else; - gfc_code *top, *d; - gfc_state_data s; - gfc_statement st; - - accept_statement (ST_WHERE_BLOCK); - top = gfc_state_stack->tail; - - push_state (&s, COMP_WHERE, gfc_new_block); - - d = add_statement (); - d->expr1 = top->expr1; - d->op = EXEC_WHERE; - - top->expr1 = NULL; - top->block = d; - - seen_empty_else = 0; - - do - { - st = next_statement (); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_WHERE_BLOCK: - parse_where_block (); - break; - - case ST_ASSIGNMENT: - case ST_WHERE: - accept_statement (st); - break; - - case ST_ELSEWHERE: - if (seen_empty_else) - { - gfc_error ("ELSEWHERE statement at %C follows previous " - "unmasked ELSEWHERE"); - reject_statement (); - break; - } - - if (new_st.expr1 == NULL) - seen_empty_else = 1; - - d = new_level (gfc_state_stack->head); - d->op = EXEC_WHERE; - d->expr1 = new_st.expr1; - - accept_statement (st); - - break; - - case ST_END_WHERE: - accept_statement (st); - break; - - default: - gfc_error ("Unexpected %s statement in WHERE block at %C", - gfc_ascii_statement (st)); - reject_statement (); - break; - } - } - while (st != ST_END_WHERE); - - pop_state (); -} - - -/* Parse a FORALL block (not a simple FORALL statement). */ - -static void -parse_forall_block (void) -{ - gfc_code *top, *d; - gfc_state_data s; - gfc_statement st; - - accept_statement (ST_FORALL_BLOCK); - top = gfc_state_stack->tail; - - push_state (&s, COMP_FORALL, gfc_new_block); - - d = add_statement (); - d->op = EXEC_FORALL; - top->block = d; - - do - { - st = next_statement (); - switch (st) - { - - case ST_ASSIGNMENT: - case ST_POINTER_ASSIGNMENT: - case ST_WHERE: - case ST_FORALL: - accept_statement (st); - break; - - case ST_WHERE_BLOCK: - parse_where_block (); - break; - - case ST_FORALL_BLOCK: - parse_forall_block (); - break; - - case ST_END_FORALL: - accept_statement (st); - break; - - case ST_NONE: - unexpected_eof (); - - default: - gfc_error ("Unexpected %s statement in FORALL block at %C", - gfc_ascii_statement (st)); - - reject_statement (); - break; - } - } - while (st != ST_END_FORALL); - - pop_state (); -} - - -static gfc_statement parse_executable (gfc_statement); - -/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */ - -static void -parse_if_block (void) -{ - gfc_code *top, *d; - gfc_statement st; - locus else_locus; - gfc_state_data s; - int seen_else; - - seen_else = 0; - accept_statement (ST_IF_BLOCK); - - top = gfc_state_stack->tail; - push_state (&s, COMP_IF, gfc_new_block); - - new_st.op = EXEC_IF; - d = add_statement (); - - d->expr1 = top->expr1; - top->expr1 = NULL; - top->block = d; - - do - { - st = parse_executable (ST_NONE); - - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_ELSEIF: - if (seen_else) - { - gfc_error ("ELSE IF statement at %C cannot follow ELSE " - "statement at %L", &else_locus); - - reject_statement (); - break; - } - - d = new_level (gfc_state_stack->head); - d->op = EXEC_IF; - d->expr1 = new_st.expr1; - - accept_statement (st); - - break; - - case ST_ELSE: - if (seen_else) - { - gfc_error ("Duplicate ELSE statements at %L and %C", - &else_locus); - reject_statement (); - break; - } - - seen_else = 1; - else_locus = gfc_current_locus; - - d = new_level (gfc_state_stack->head); - d->op = EXEC_IF; - - accept_statement (st); - - break; - - case ST_ENDIF: - break; - - default: - unexpected_statement (st); - break; - } - } - while (st != ST_ENDIF); - - pop_state (); - accept_statement (st); -} - - -/* Parse a SELECT block. */ - -static void -parse_select_block (void) -{ - gfc_statement st; - gfc_code *cp; - gfc_state_data s; - - accept_statement (ST_SELECT_CASE); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_SELECT, gfc_new_block); - - /* Make sure that the next statement is a CASE or END SELECT. */ - for (;;) - { - st = next_statement (); - if (st == ST_NONE) - unexpected_eof (); - if (st == ST_END_SELECT) - { - /* Empty SELECT CASE is OK. */ - accept_statement (st); - pop_state (); - return; - } - if (st == ST_CASE) - break; - - gfc_error ("Expected a CASE or END SELECT statement following SELECT " - "CASE at %C"); - - reject_statement (); - } - - /* At this point, we've got a nonempty select block. */ - cp = new_level (cp); - *cp = new_st; - - accept_statement (st); - - do - { - st = parse_executable (ST_NONE); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_CASE: - cp = new_level (gfc_state_stack->head); - *cp = new_st; - gfc_clear_new_st (); - - accept_statement (st); - /* Fall through */ - - case ST_END_SELECT: - break; - - /* Can't have an executable statement because of - parse_executable(). */ - default: - unexpected_statement (st); - break; - } - } - while (st != ST_END_SELECT); - - pop_state (); - accept_statement (st); -} - - -/* Pop the current selector from the SELECT TYPE stack. */ - -static void -select_type_pop (void) -{ - gfc_select_type_stack *old = select_type_stack; - select_type_stack = old->prev; - free (old); -} - - -/* Parse a SELECT TYPE construct (F03:R821). */ - -static void -parse_select_type_block (void) -{ - gfc_statement st; - gfc_code *cp; - gfc_state_data s; - - gfc_current_ns = new_st.ext.block.ns; - accept_statement (ST_SELECT_TYPE); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_SELECT_TYPE, gfc_new_block); - - /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT - or END SELECT. */ - for (;;) - { - st = next_statement (); - if (st == ST_NONE) - unexpected_eof (); - if (st == ST_END_SELECT) - /* Empty SELECT CASE is OK. */ - goto done; - if (st == ST_TYPE_IS || st == ST_CLASS_IS) - break; - - gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement " - "following SELECT TYPE at %C"); - - reject_statement (); - } - - /* At this point, we've got a nonempty select block. */ - cp = new_level (cp); - *cp = new_st; - - accept_statement (st); - - do - { - st = parse_executable (ST_NONE); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_TYPE_IS: - case ST_CLASS_IS: - cp = new_level (gfc_state_stack->head); - *cp = new_st; - gfc_clear_new_st (); - - accept_statement (st); - /* Fall through */ - - case ST_END_SELECT: - break; - - /* Can't have an executable statement because of - parse_executable(). */ - default: - unexpected_statement (st); - break; - } - } - while (st != ST_END_SELECT); - -done: - pop_state (); - accept_statement (st); - gfc_current_ns = gfc_current_ns->parent; - select_type_pop (); -} - - -/* Parse a SELECT RANK construct. */ - -static void -parse_select_rank_block (void) -{ - gfc_statement st; - gfc_code *cp; - gfc_state_data s; - - gfc_current_ns = new_st.ext.block.ns; - accept_statement (ST_SELECT_RANK); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_SELECT_RANK, gfc_new_block); - - /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */ - for (;;) - { - st = next_statement (); - if (st == ST_NONE) - unexpected_eof (); - if (st == ST_END_SELECT) - /* Empty SELECT CASE is OK. */ - goto done; - if (st == ST_RANK) - break; - - gfc_error ("Expected RANK or RANK DEFAULT " - "following SELECT RANK at %C"); - - reject_statement (); - } - - /* At this point, we've got a nonempty select block. */ - cp = new_level (cp); - *cp = new_st; - - accept_statement (st); - - do - { - st = parse_executable (ST_NONE); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_RANK: - cp = new_level (gfc_state_stack->head); - *cp = new_st; - gfc_clear_new_st (); - - accept_statement (st); - /* Fall through */ - - case ST_END_SELECT: - break; - - /* Can't have an executable statement because of - parse_executable(). */ - default: - unexpected_statement (st); - break; - } - } - while (st != ST_END_SELECT); - -done: - pop_state (); - accept_statement (st); - gfc_current_ns = gfc_current_ns->parent; - select_type_pop (); -} - - -/* Given a symbol, make sure it is not an iteration variable for a DO - statement. This subroutine is called when the symbol is seen in a - context that causes it to become redefined. If the symbol is an - iterator, we generate an error message and return nonzero. */ - -int -gfc_check_do_variable (gfc_symtree *st) -{ - gfc_state_data *s; - - if (!st) - return 0; - - for (s=gfc_state_stack; s; s = s->previous) - if (s->do_variable == st) - { - gfc_error_now ("Variable %qs at %C cannot be redefined inside " - "loop beginning at %L", st->name, &s->head->loc); - return 1; - } - - return 0; -} - - -/* Checks to see if the current statement label closes an enddo. - Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues - an error) if it incorrectly closes an ENDDO. */ - -static int -check_do_closure (void) -{ - gfc_state_data *p; - - if (gfc_statement_label == NULL) - return 0; - - for (p = gfc_state_stack; p; p = p->previous) - if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) - break; - - if (p == NULL) - return 0; /* No loops to close */ - - if (p->ext.end_do_label == gfc_statement_label) - { - if (p == gfc_state_stack) - return 1; - - gfc_error ("End of nonblock DO statement at %C is within another block"); - return 2; - } - - /* At this point, the label doesn't terminate the innermost loop. - Make sure it doesn't terminate another one. */ - for (; p; p = p->previous) - if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) - && p->ext.end_do_label == gfc_statement_label) - { - gfc_error ("End of nonblock DO statement at %C is interwoven " - "with another DO loop"); - return 2; - } - - return 0; -} - - -/* Parse a series of contained program units. */ - -static void parse_progunit (gfc_statement); - - -/* Parse a CRITICAL block. */ - -static void -parse_critical_block (void) -{ - gfc_code *top, *d; - gfc_state_data s, *sd; - gfc_statement st; - - for (sd = gfc_state_stack; sd; sd = sd->previous) - if (sd->state == COMP_OMP_STRUCTURED_BLOCK) - gfc_error_now (is_oacc (sd) - ? G_("CRITICAL block inside of OpenACC region at %C") - : G_("CRITICAL block inside of OpenMP region at %C")); - - s.ext.end_do_label = new_st.label1; - - accept_statement (ST_CRITICAL); - top = gfc_state_stack->tail; - - push_state (&s, COMP_CRITICAL, gfc_new_block); - - d = add_statement (); - d->op = EXEC_CRITICAL; - top->block = d; - - do - { - st = parse_executable (ST_NONE); - - switch (st) - { - case ST_NONE: - unexpected_eof (); - break; - - case ST_END_CRITICAL: - if (s.ext.end_do_label != NULL - && s.ext.end_do_label != gfc_statement_label) - gfc_error_now ("Statement label in END CRITICAL at %C does not " - "match CRITICAL label"); - - if (gfc_statement_label != NULL) - { - new_st.op = EXEC_NOP; - add_statement (); - } - break; - - default: - unexpected_statement (st); - break; - } - } - while (st != ST_END_CRITICAL); - - pop_state (); - accept_statement (st); -} - - -/* Set up the local namespace for a BLOCK construct. */ - -gfc_namespace* -gfc_build_block_ns (gfc_namespace *parent_ns) -{ - gfc_namespace* my_ns; - static int numblock = 1; - - my_ns = gfc_get_namespace (parent_ns, 1); - my_ns->construct_entities = 1; - - /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct - code generation (so it must not be NULL). - We set its recursive argument if our container procedure is recursive, so - that local variables are accordingly placed on the stack when it - will be necessary. */ - if (gfc_new_block) - my_ns->proc_name = gfc_new_block; - else - { - bool t; - char buffer[20]; /* Enough to hold "block@2147483648\n". */ - - snprintf(buffer, sizeof(buffer), "block@%d", numblock++); - gfc_get_symbol (buffer, my_ns, &my_ns->proc_name); - t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL, - my_ns->proc_name->name, NULL); - gcc_assert (t); - gfc_commit_symbol (my_ns->proc_name); - } - - if (parent_ns->proc_name) - my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive; - - return my_ns; -} - - -/* Parse a BLOCK construct. */ - -static void -parse_block_construct (void) -{ - gfc_namespace* my_ns; - gfc_namespace* my_parent; - gfc_state_data s; - - gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C"); - - my_ns = gfc_build_block_ns (gfc_current_ns); - - new_st.op = EXEC_BLOCK; - new_st.ext.block.ns = my_ns; - new_st.ext.block.assoc = NULL; - accept_statement (ST_BLOCK); - - push_state (&s, COMP_BLOCK, my_ns->proc_name); - gfc_current_ns = my_ns; - my_parent = my_ns->parent; - - parse_progunit (ST_NONE); - - /* Don't depend on the value of gfc_current_ns; it might have been - reset if the block had errors and was cleaned up. */ - gfc_current_ns = my_parent; - - pop_state (); -} - - -/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct - behind the scenes with compiler-generated variables. */ - -static void -parse_associate (void) -{ - gfc_namespace* my_ns; - gfc_state_data s; - gfc_statement st; - gfc_association_list* a; - - gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); - - my_ns = gfc_build_block_ns (gfc_current_ns); - - new_st.op = EXEC_BLOCK; - new_st.ext.block.ns = my_ns; - gcc_assert (new_st.ext.block.assoc); - - /* Add all associate-names as BLOCK variables. Creating them is enough - for now, they'll get their values during trans-* phase. */ - gfc_current_ns = my_ns; - for (a = new_st.ext.block.assoc; a; a = a->next) - { - gfc_symbol* sym; - gfc_ref *ref; - gfc_array_ref *array_ref; - - if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) - gcc_unreachable (); - - sym = a->st->n.sym; - sym->attr.flavor = FL_VARIABLE; - sym->assoc = a; - sym->declared_at = a->where; - gfc_set_sym_referenced (sym); - - /* Initialize the typespec. It is not available in all cases, - however, as it may only be set on the target during resolution. - Still, sometimes it helps to have it right now -- especially - for parsing component references on the associate-name - in case of association to a derived-type. */ - sym->ts = a->target->ts; - - /* Check if the target expression is array valued. This cannot always - be done by looking at target.rank, because that might not have been - set yet. Therefore traverse the chain of refs, looking for the last - array ref and evaluate that. */ - array_ref = NULL; - for (ref = a->target->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY) - array_ref = &ref->u.ar; - if (array_ref || a->target->rank) - { - gfc_array_spec *as; - int dim, rank = 0; - if (array_ref) - { - a->rankguessed = 1; - /* Count the dimension, that have a non-scalar extend. */ - for (dim = 0; dim < array_ref->dimen; ++dim) - if (array_ref->dimen_type[dim] != DIMEN_ELEMENT - && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN - && array_ref->end[dim] == NULL - && array_ref->start[dim] != NULL)) - ++rank; - } - else - rank = a->target->rank; - /* When the rank is greater than zero then sym will be an array. */ - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) - { - if ((!CLASS_DATA (sym)->as && rank != 0) - || (CLASS_DATA (sym)->as - && CLASS_DATA (sym)->as->rank != rank)) - { - /* Don't just (re-)set the attr and as in the sym.ts, - because this modifies the target's attr and as. Copy the - data and do a build_class_symbol. */ - symbol_attribute attr = CLASS_DATA (a->target)->attr; - int corank = gfc_get_corank (a->target); - gfc_typespec type; - - if (rank || corank) - { - as = gfc_get_array_spec (); - as->type = AS_DEFERRED; - as->rank = rank; - as->corank = corank; - attr.dimension = rank ? 1 : 0; - attr.codimension = corank ? 1 : 0; - } - else - { - as = NULL; - attr.dimension = attr.codimension = 0; - } - attr.class_ok = 0; - type = CLASS_DATA (sym)->ts; - if (!gfc_build_class_symbol (&type, - &attr, &as)) - gcc_unreachable (); - sym->ts = type; - sym->ts.type = BT_CLASS; - sym->attr.class_ok = 1; - } - else - sym->attr.class_ok = 1; - } - else if ((!sym->as && rank != 0) - || (sym->as && sym->as->rank != rank)) - { - as = gfc_get_array_spec (); - as->type = AS_DEFERRED; - as->rank = rank; - as->corank = gfc_get_corank (a->target); - sym->as = as; - sym->attr.dimension = 1; - if (as->corank) - sym->attr.codimension = 1; - } - } - } - - accept_statement (ST_ASSOCIATE); - push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); - -loop: - st = parse_executable (ST_NONE); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case_end: - accept_statement (st); - my_ns->code = gfc_state_stack->head; - break; - - default: - unexpected_statement (st); - goto loop; - } - - gfc_current_ns = gfc_current_ns->parent; - pop_state (); -} - - -/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are - handled inside of parse_executable(), because they aren't really - loop statements. */ - -static void -parse_do_block (void) -{ - gfc_statement st; - gfc_code *top; - gfc_state_data s; - gfc_symtree *stree; - gfc_exec_op do_op; - - do_op = new_st.op; - s.ext.end_do_label = new_st.label1; - - if (new_st.ext.iterator != NULL) - { - stree = new_st.ext.iterator->var->symtree; - if (directive_unroll != -1) - { - new_st.ext.iterator->unroll = directive_unroll; - directive_unroll = -1; - } - if (directive_ivdep) - { - new_st.ext.iterator->ivdep = directive_ivdep; - directive_ivdep = false; - } - if (directive_vector) - { - new_st.ext.iterator->vector = directive_vector; - directive_vector = false; - } - if (directive_novector) - { - new_st.ext.iterator->novector = directive_novector; - directive_novector = false; - } - } - else - stree = NULL; - - accept_statement (ST_DO); - - top = gfc_state_stack->tail; - push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO, - gfc_new_block); - - s.do_variable = stree; - - top->block = new_level (top); - top->block->op = EXEC_DO; - -loop: - st = parse_executable (ST_NONE); - - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_ENDDO: - if (s.ext.end_do_label != NULL - && s.ext.end_do_label != gfc_statement_label) - gfc_error_now ("Statement label in ENDDO at %C doesn't match " - "DO label"); - - if (gfc_statement_label != NULL) - { - new_st.op = EXEC_NOP; - add_statement (); - } - break; - - case ST_IMPLIED_ENDDO: - /* If the do-stmt of this DO construct has a do-construct-name, - the corresponding end-do must be an end-do-stmt (with a matching - name, but in that case we must have seen ST_ENDDO first). - We only complain about this in pedantic mode. */ - if (gfc_current_block () != NULL) - gfc_error_now ("Named block DO at %L requires matching ENDDO name", - &gfc_current_block()->declared_at); - - break; - - default: - unexpected_statement (st); - goto loop; - } - - pop_state (); - accept_statement (st); -} - - -/* Parse the statements of OpenMP do/parallel do. */ - -static gfc_statement -parse_omp_do (gfc_statement omp_st) -{ - gfc_statement st; - gfc_code *cp, *np; - gfc_state_data s; - - accept_statement (omp_st); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); - np = new_level (cp); - np->op = cp->op; - np->block = NULL; - - for (;;) - { - st = next_statement (); - if (st == ST_NONE) - unexpected_eof (); - else if (st == ST_DO) - break; - else - unexpected_statement (st); - } - - parse_do_block (); - if (gfc_statement_label != NULL - && gfc_state_stack->previous != NULL - && gfc_state_stack->previous->state == COMP_DO - && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) - { - /* In - DO 100 I=1,10 - !$OMP DO - DO J=1,10 - ... - 100 CONTINUE - there should be no !$OMP END DO. */ - pop_state (); - return ST_IMPLIED_ENDDO; - } - - check_do_closure (); - pop_state (); - - st = next_statement (); - gfc_statement omp_end_st = ST_OMP_END_DO; - switch (omp_st) - { - case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD; - break; - case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break; - case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break; - case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break; - case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break; - case ST_OMP_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD; - break; - case ST_OMP_PARALLEL_LOOP: - omp_end_st = ST_OMP_END_PARALLEL_LOOP; - break; - case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break; - case ST_OMP_TARGET_PARALLEL_DO: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO; - break; - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD; - break; - case ST_OMP_TARGET_PARALLEL_LOOP: - omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP; - break; - case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; - break; - case ST_OMP_TARGET_TEAMS_LOOP: - omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP; - break; - case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break; - case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break; - case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break; - case ST_OMP_MASKED_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD; - break; - case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break; - case ST_OMP_MASTER_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP: - omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP; - break; - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP: - omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP; - break; - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD; - break; - case ST_OMP_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; - break; - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; - break; - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; - break; - case ST_OMP_TEAMS_LOOP: - omp_end_st = ST_OMP_END_TEAMS_LOOP; - break; - default: gcc_unreachable (); - } - if (st == omp_end_st) - { - if (new_st.op == EXEC_OMP_END_NOWAIT) - cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; - else - gcc_assert (new_st.op == EXEC_NOP); - gfc_clear_new_st (); - gfc_commit_symbols (); - gfc_warning_check (); - st = next_statement (); - } - return st; -} - - -/* Parse the statements of OpenMP atomic directive. */ - -static gfc_statement -parse_omp_oacc_atomic (bool omp_p) -{ - gfc_statement st, st_atomic, st_end_atomic; - gfc_code *cp, *np; - gfc_state_data s; - int count; - - if (omp_p) - { - st_atomic = ST_OMP_ATOMIC; - st_end_atomic = ST_OMP_END_ATOMIC; - } - else - { - st_atomic = ST_OACC_ATOMIC; - st_end_atomic = ST_OACC_END_ATOMIC; - } - accept_statement (st_atomic); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); - np = new_level (cp); - np->op = cp->op; - np->block = NULL; - np->ext.omp_clauses = cp->ext.omp_clauses; - cp->ext.omp_clauses = NULL; - count = 1 + np->ext.omp_clauses->capture; - - while (count) - { - st = next_statement (); - if (st == ST_NONE) - unexpected_eof (); - else if (np->ext.omp_clauses->compare - && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK)) - { - count--; - if (st == ST_IF_BLOCK) - { - parse_if_block (); - /* With else (or elseif). */ - if (gfc_state_stack->tail->block->block) - count--; - } - accept_statement (st); - } - else if (st == ST_ASSIGNMENT - && (!np->ext.omp_clauses->compare - || np->ext.omp_clauses->capture)) - { - accept_statement (st); - count--; - } - else - unexpected_statement (st); - } - - pop_state (); - - st = next_statement (); - if (st == st_end_atomic) - { - gfc_clear_new_st (); - gfc_commit_symbols (); - gfc_warning_check (); - st = next_statement (); - } - return st; -} - - -/* Parse the statements of an OpenACC structured block. */ - -static void -parse_oacc_structured_block (gfc_statement acc_st) -{ - gfc_statement st, acc_end_st; - gfc_code *cp, *np; - gfc_state_data s, *sd; - - for (sd = gfc_state_stack; sd; sd = sd->previous) - if (sd->state == COMP_CRITICAL) - gfc_error_now ("OpenACC directive inside of CRITICAL block at %C"); - - accept_statement (acc_st); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); - np = new_level (cp); - np->op = cp->op; - np->block = NULL; - switch (acc_st) - { - case ST_OACC_PARALLEL: - acc_end_st = ST_OACC_END_PARALLEL; - break; - case ST_OACC_KERNELS: - acc_end_st = ST_OACC_END_KERNELS; - break; - case ST_OACC_SERIAL: - acc_end_st = ST_OACC_END_SERIAL; - break; - case ST_OACC_DATA: - acc_end_st = ST_OACC_END_DATA; - break; - case ST_OACC_HOST_DATA: - acc_end_st = ST_OACC_END_HOST_DATA; - break; - default: - gcc_unreachable (); - } - - do - { - st = parse_executable (ST_NONE); - if (st == ST_NONE) - unexpected_eof (); - else if (st != acc_end_st) - { - gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st)); - reject_statement (); - } - } - while (st != acc_end_st); - - gcc_assert (new_st.op == EXEC_NOP); - - gfc_clear_new_st (); - gfc_commit_symbols (); - gfc_warning_check (); - pop_state (); -} - -/* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */ - -static gfc_statement -parse_oacc_loop (gfc_statement acc_st) -{ - gfc_statement st; - gfc_code *cp, *np; - gfc_state_data s, *sd; - - for (sd = gfc_state_stack; sd; sd = sd->previous) - if (sd->state == COMP_CRITICAL) - gfc_error_now ("OpenACC directive inside of CRITICAL block at %C"); - - accept_statement (acc_st); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); - np = new_level (cp); - np->op = cp->op; - np->block = NULL; - - for (;;) - { - st = next_statement (); - if (st == ST_NONE) - unexpected_eof (); - else if (st == ST_DO) - break; - else - { - gfc_error ("Expected DO loop at %C"); - reject_statement (); - } - } - - parse_do_block (); - if (gfc_statement_label != NULL - && gfc_state_stack->previous != NULL - && gfc_state_stack->previous->state == COMP_DO - && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) - { - pop_state (); - return ST_IMPLIED_ENDDO; - } - - check_do_closure (); - pop_state (); - - st = next_statement (); - if (st == ST_OACC_END_LOOP) - gfc_warning (0, "Redundant !$ACC END LOOP at %C"); - if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) || - (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) || - (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) || - (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP)) - { - gcc_assert (new_st.op == EXEC_NOP); - gfc_clear_new_st (); - gfc_commit_symbols (); - gfc_warning_check (); - st = next_statement (); - } - return st; -} - - -/* Parse the statements of an OpenMP structured block. */ - -static gfc_statement -parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) -{ - gfc_statement st, omp_end_st; - gfc_code *cp, *np; - gfc_state_data s; - - accept_statement (omp_st); - - cp = gfc_state_stack->tail; - push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); - np = new_level (cp); - np->op = cp->op; - np->block = NULL; - - switch (omp_st) - { - case ST_OMP_PARALLEL: - omp_end_st = ST_OMP_END_PARALLEL; - break; - case ST_OMP_PARALLEL_MASKED: - omp_end_st = ST_OMP_END_PARALLEL_MASKED; - break; - case ST_OMP_PARALLEL_MASTER: - omp_end_st = ST_OMP_END_PARALLEL_MASTER; - break; - case ST_OMP_PARALLEL_SECTIONS: - omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; - break; - case ST_OMP_SCOPE: - omp_end_st = ST_OMP_END_SCOPE; - break; - case ST_OMP_SECTIONS: - omp_end_st = ST_OMP_END_SECTIONS; - break; - case ST_OMP_ORDERED: - omp_end_st = ST_OMP_END_ORDERED; - break; - case ST_OMP_CRITICAL: - omp_end_st = ST_OMP_END_CRITICAL; - break; - case ST_OMP_MASKED: - omp_end_st = ST_OMP_END_MASKED; - break; - case ST_OMP_MASTER: - omp_end_st = ST_OMP_END_MASTER; - break; - case ST_OMP_SINGLE: - omp_end_st = ST_OMP_END_SINGLE; - break; - case ST_OMP_TARGET: - omp_end_st = ST_OMP_END_TARGET; - break; - case ST_OMP_TARGET_DATA: - omp_end_st = ST_OMP_END_TARGET_DATA; - break; - case ST_OMP_TARGET_PARALLEL: - omp_end_st = ST_OMP_END_TARGET_PARALLEL; - break; - case ST_OMP_TARGET_TEAMS: - omp_end_st = ST_OMP_END_TARGET_TEAMS; - break; - case ST_OMP_TASK: - omp_end_st = ST_OMP_END_TASK; - break; - case ST_OMP_TASKGROUP: - omp_end_st = ST_OMP_END_TASKGROUP; - break; - case ST_OMP_TEAMS: - omp_end_st = ST_OMP_END_TEAMS; - break; - case ST_OMP_TEAMS_DISTRIBUTE: - omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; - break; - case ST_OMP_DISTRIBUTE: - omp_end_st = ST_OMP_END_DISTRIBUTE; - break; - case ST_OMP_WORKSHARE: - omp_end_st = ST_OMP_END_WORKSHARE; - break; - case ST_OMP_PARALLEL_WORKSHARE: - omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; - break; - default: - gcc_unreachable (); - } - - bool block_construct = false; - gfc_namespace *my_ns = NULL; - gfc_namespace *my_parent = NULL; - - st = next_statement (); - - if (st == ST_BLOCK) - { - /* Adjust state to a strictly-structured block, now that we found that - the body starts with a BLOCK construct. */ - s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK; - - block_construct = true; - gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C"); - - my_ns = gfc_build_block_ns (gfc_current_ns); - gfc_current_ns = my_ns; - my_parent = my_ns->parent; - - new_st.op = EXEC_BLOCK; - new_st.ext.block.ns = my_ns; - new_st.ext.block.assoc = NULL; - accept_statement (ST_BLOCK); - st = parse_spec (ST_NONE); - } - - do - { - if (workshare_stmts_only) - { - /* Inside of !$omp workshare, only - scalar assignments - array assignments - where statements and constructs - forall statements and constructs - !$omp atomic - !$omp critical - !$omp parallel - are allowed. For !$omp critical these - restrictions apply recursively. */ - bool cycle = true; - - for (;;) - { - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_ASSIGNMENT: - case ST_WHERE: - case ST_FORALL: - accept_statement (st); - break; - - case ST_WHERE_BLOCK: - parse_where_block (); - break; - - case ST_FORALL_BLOCK: - parse_forall_block (); - break; - - case ST_OMP_PARALLEL: - case ST_OMP_PARALLEL_MASKED: - case ST_OMP_PARALLEL_MASTER: - case ST_OMP_PARALLEL_SECTIONS: - st = parse_omp_structured_block (st, false); - continue; - - case ST_OMP_PARALLEL_WORKSHARE: - case ST_OMP_CRITICAL: - st = parse_omp_structured_block (st, true); - continue; - - case ST_OMP_PARALLEL_DO: - case ST_OMP_PARALLEL_DO_SIMD: - st = parse_omp_do (st); - continue; - - case ST_OMP_ATOMIC: - st = parse_omp_oacc_atomic (true); - continue; - - default: - cycle = false; - break; - } - - if (!cycle) - break; - - st = next_statement (); - } - } - else - st = parse_executable (st); - if (st == ST_NONE) - unexpected_eof (); - else if (st == ST_OMP_SECTION - && (omp_st == ST_OMP_SECTIONS - || omp_st == ST_OMP_PARALLEL_SECTIONS)) - { - np = new_level (np); - np->op = cp->op; - np->block = NULL; - st = next_statement (); - } - else if (block_construct && st == ST_END_BLOCK) - { - accept_statement (st); - gfc_current_ns = my_parent; - pop_state (); - - st = next_statement (); - if (st == omp_end_st) - { - accept_statement (st); - st = next_statement (); - } - return st; - } - else if (st != omp_end_st) - { - unexpected_statement (st); - st = next_statement (); - } - } - while (st != omp_end_st); - - switch (new_st.op) - { - case EXEC_OMP_END_NOWAIT: - cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; - break; - case EXEC_OMP_END_CRITICAL: - if (((cp->ext.omp_clauses->critical_name == NULL) - ^ (new_st.ext.omp_name == NULL)) - || (new_st.ext.omp_name != NULL - && strcmp (cp->ext.omp_clauses->critical_name, - new_st.ext.omp_name) != 0)) - gfc_error ("Name after !$omp critical and !$omp end critical does " - "not match at %C"); - free (CONST_CAST (char *, new_st.ext.omp_name)); - new_st.ext.omp_name = NULL; - break; - case EXEC_OMP_END_SINGLE: - cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] - = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]; - new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL; - gfc_free_omp_clauses (new_st.ext.omp_clauses); - break; - case EXEC_NOP: - break; - default: - gcc_unreachable (); - } - - gfc_clear_new_st (); - gfc_commit_symbols (); - gfc_warning_check (); - pop_state (); - st = next_statement (); - return st; -} - - -/* Accept a series of executable statements. We return the first - statement that doesn't fit to the caller. Any block statements are - passed on to the correct handler, which usually passes the buck - right back here. */ - -static gfc_statement -parse_executable (gfc_statement st) -{ - int close_flag; - - if (st == ST_NONE) - st = next_statement (); - - for (;;) - { - close_flag = check_do_closure (); - if (close_flag) - switch (st) - { - case ST_GOTO: - case ST_END_PROGRAM: - case ST_RETURN: - case ST_EXIT: - case ST_END_FUNCTION: - case ST_CYCLE: - case ST_PAUSE: - case ST_STOP: - case ST_ERROR_STOP: - case ST_END_SUBROUTINE: - - case ST_DO: - case ST_FORALL: - case ST_WHERE: - case ST_SELECT_CASE: - gfc_error ("%s statement at %C cannot terminate a non-block " - "DO loop", gfc_ascii_statement (st)); - break; - - default: - break; - } - - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_DATA: - gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the " - "first executable statement"); - /* Fall through. */ - - case ST_FORMAT: - case ST_ENTRY: - case_executable: - accept_statement (st); - if (close_flag == 1) - return ST_IMPLIED_ENDDO; - break; - - case ST_BLOCK: - parse_block_construct (); - break; - - case ST_ASSOCIATE: - parse_associate (); - break; - - case ST_IF_BLOCK: - parse_if_block (); - break; - - case ST_SELECT_CASE: - parse_select_block (); - break; - - case ST_SELECT_TYPE: - parse_select_type_block (); - break; - - case ST_SELECT_RANK: - parse_select_rank_block (); - break; - - case ST_DO: - parse_do_block (); - if (check_do_closure () == 1) - return ST_IMPLIED_ENDDO; - break; - - case ST_CRITICAL: - parse_critical_block (); - break; - - case ST_WHERE_BLOCK: - parse_where_block (); - break; - - case ST_FORALL_BLOCK: - parse_forall_block (); - break; - - case ST_OACC_PARALLEL_LOOP: - case ST_OACC_KERNELS_LOOP: - case ST_OACC_SERIAL_LOOP: - case ST_OACC_LOOP: - st = parse_oacc_loop (st); - if (st == ST_IMPLIED_ENDDO) - return st; - continue; - - case ST_OACC_PARALLEL: - case ST_OACC_KERNELS: - case ST_OACC_SERIAL: - case ST_OACC_DATA: - case ST_OACC_HOST_DATA: - parse_oacc_structured_block (st); - break; - - case ST_OMP_PARALLEL: - case ST_OMP_PARALLEL_MASKED: - case ST_OMP_PARALLEL_MASTER: - case ST_OMP_PARALLEL_SECTIONS: - case ST_OMP_ORDERED: - case ST_OMP_CRITICAL: - case ST_OMP_MASKED: - case ST_OMP_MASTER: - case ST_OMP_SCOPE: - case ST_OMP_SECTIONS: - case ST_OMP_SINGLE: - case ST_OMP_TARGET: - case ST_OMP_TARGET_DATA: - case ST_OMP_TARGET_PARALLEL: - case ST_OMP_TARGET_TEAMS: - case ST_OMP_TEAMS: - case ST_OMP_TASK: - case ST_OMP_TASKGROUP: - st = parse_omp_structured_block (st, false); - continue; - - case ST_OMP_WORKSHARE: - case ST_OMP_PARALLEL_WORKSHARE: - st = parse_omp_structured_block (st, true); - continue; - - case ST_OMP_DISTRIBUTE: - case ST_OMP_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_DISTRIBUTE_SIMD: - case ST_OMP_DO: - case ST_OMP_DO_SIMD: - case ST_OMP_LOOP: - case ST_OMP_PARALLEL_DO: - case ST_OMP_PARALLEL_DO_SIMD: - case ST_OMP_PARALLEL_LOOP: - case ST_OMP_PARALLEL_MASKED_TASKLOOP: - case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case ST_OMP_PARALLEL_MASTER_TASKLOOP: - case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case ST_OMP_MASKED_TASKLOOP: - case ST_OMP_MASKED_TASKLOOP_SIMD: - case ST_OMP_MASTER_TASKLOOP: - case ST_OMP_MASTER_TASKLOOP_SIMD: - case ST_OMP_SIMD: - case ST_OMP_TARGET_PARALLEL_DO: - case ST_OMP_TARGET_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_PARALLEL_LOOP: - case ST_OMP_TARGET_SIMD: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case ST_OMP_TARGET_TEAMS_LOOP: - case ST_OMP_TASKLOOP: - case ST_OMP_TASKLOOP_SIMD: - case ST_OMP_TEAMS_DISTRIBUTE: - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case ST_OMP_TEAMS_DISTRIBUTE_SIMD: - case ST_OMP_TEAMS_LOOP: - st = parse_omp_do (st); - if (st == ST_IMPLIED_ENDDO) - return st; - continue; - - case ST_OACC_ATOMIC: - st = parse_omp_oacc_atomic (false); - continue; - - case ST_OMP_ATOMIC: - st = parse_omp_oacc_atomic (true); - continue; - - default: - return st; - } - - if (directive_unroll != -1) - gfc_error ("% directive not at the start of a loop at %C"); - - if (directive_ivdep) - gfc_error ("% directive not at the start of a loop at %C"); - - if (directive_vector) - gfc_error ("% directive not at the start of a loop at %C"); - - if (directive_novector) - gfc_error ("% " - "directive not at the start of a loop at %C"); - - st = next_statement (); - } -} - - -/* Fix the symbols for sibling functions. These are incorrectly added to - the child namespace as the parser didn't know about this procedure. */ - -static void -gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) -{ - gfc_namespace *ns; - gfc_symtree *st; - gfc_symbol *old_sym; - - for (ns = siblings; ns; ns = ns->sibling) - { - st = gfc_find_symtree (ns->sym_root, sym->name); - - if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) - goto fixup_contained; - - if ((st->n.sym->attr.flavor == FL_DERIVED - && sym->attr.generic && sym->attr.function) - ||(sym->attr.flavor == FL_DERIVED - && st->n.sym->attr.generic && st->n.sym->attr.function)) - goto fixup_contained; - - old_sym = st->n.sym; - if (old_sym->ns == ns - && !old_sym->attr.contained - - /* By 14.6.1.3, host association should be excluded - for the following. */ - && !(old_sym->attr.external - || (old_sym->ts.type != BT_UNKNOWN - && !old_sym->attr.implicit_type) - || old_sym->attr.flavor == FL_PARAMETER - || old_sym->attr.use_assoc - || old_sym->attr.in_common - || old_sym->attr.in_equivalence - || old_sym->attr.data - || old_sym->attr.dummy - || old_sym->attr.result - || old_sym->attr.dimension - || old_sym->attr.allocatable - || old_sym->attr.intrinsic - || old_sym->attr.generic - || old_sym->attr.flavor == FL_NAMELIST - || old_sym->attr.flavor == FL_LABEL - || old_sym->attr.proc == PROC_ST_FUNCTION)) - { - /* Replace it with the symbol from the parent namespace. */ - st->n.sym = sym; - sym->refs++; - - gfc_release_symbol (old_sym); - } - -fixup_contained: - /* Do the same for any contained procedures. */ - gfc_fixup_sibling_symbols (sym, ns->contained); - } -} - -static void -parse_contained (int module) -{ - gfc_namespace *ns, *parent_ns, *tmp; - gfc_state_data s1, s2; - gfc_statement st; - gfc_symbol *sym; - gfc_entry_list *el; - locus old_loc; - int contains_statements = 0; - int seen_error = 0; - - push_state (&s1, COMP_CONTAINS, NULL); - parent_ns = gfc_current_ns; - - do - { - gfc_current_ns = gfc_get_namespace (parent_ns, 1); - - gfc_current_ns->sibling = parent_ns->contained; - parent_ns->contained = gfc_current_ns; - - next: - /* Process the next available statement. We come here if we got an error - and rejected the last statement. */ - old_loc = gfc_current_locus; - st = next_statement (); - - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_FUNCTION: - case ST_SUBROUTINE: - contains_statements = 1; - accept_statement (st); - - push_state (&s2, - (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE, - gfc_new_block); - - /* For internal procedures, create/update the symbol in the - parent namespace. */ - - if (!module) - { - if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym)) - gfc_error ("Contained procedure %qs at %C is already " - "ambiguous", gfc_new_block->name); - else - { - if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, - sym->name, - &gfc_new_block->declared_at)) - { - if (st == ST_FUNCTION) - gfc_add_function (&sym->attr, sym->name, - &gfc_new_block->declared_at); - else - gfc_add_subroutine (&sym->attr, sym->name, - &gfc_new_block->declared_at); - } - } - - gfc_commit_symbols (); - } - else - sym = gfc_new_block; - - /* Mark this as a contained function, so it isn't replaced - by other module functions. */ - sym->attr.contained = 1; - - /* Set implicit_pure so that it can be reset if any of the - tests for purity fail. This is used for some optimisation - during translation. */ - if (!sym->attr.pure) - sym->attr.implicit_pure = 1; - - parse_progunit (ST_NONE); - - /* Fix up any sibling functions that refer to this one. */ - gfc_fixup_sibling_symbols (sym, gfc_current_ns); - /* Or refer to any of its alternate entry points. */ - for (el = gfc_current_ns->entries; el; el = el->next) - gfc_fixup_sibling_symbols (el->sym, gfc_current_ns); - - gfc_current_ns->code = s2.head; - gfc_current_ns = parent_ns; - - pop_state (); - break; - - /* These statements are associated with the end of the host unit. */ - case ST_END_FUNCTION: - case ST_END_MODULE: - case ST_END_SUBMODULE: - case ST_END_PROGRAM: - case ST_END_SUBROUTINE: - accept_statement (st); - gfc_current_ns->code = s1.head; - break; - - default: - gfc_error ("Unexpected %s statement in CONTAINS section at %C", - gfc_ascii_statement (st)); - reject_statement (); - seen_error = 1; - goto next; - break; - } - } - while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE - && st != ST_END_MODULE && st != ST_END_SUBMODULE - && st != ST_END_PROGRAM); - - /* The first namespace in the list is guaranteed to not have - anything (worthwhile) in it. */ - tmp = gfc_current_ns; - gfc_current_ns = parent_ns; - if (seen_error && tmp->refs > 1) - gfc_free_namespace (tmp); - - ns = gfc_current_ns->contained; - gfc_current_ns->contained = ns->sibling; - gfc_free_namespace (ns); - - pop_state (); - if (!contains_statements) - gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without " - "FUNCTION or SUBROUTINE statement at %L", &old_loc); -} - - -/* The result variable in a MODULE PROCEDURE needs to be created and - its characteristics copied from the interface since it is neither - declared in the procedure declaration nor in the specification - part. */ - -static void -get_modproc_result (void) -{ - gfc_symbol *proc; - if (gfc_state_stack->previous - && gfc_state_stack->previous->state == COMP_CONTAINS - && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) - { - proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL; - if (proc != NULL - && proc->attr.function - && proc->tlink - && proc->tlink->result - && proc->tlink->result != proc->tlink) - { - gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1); - gfc_set_sym_referenced (proc->result); - proc->result->attr.if_source = IFSRC_DECL; - gfc_commit_symbol (proc->result); - } - } -} - - -/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */ - -static void -parse_progunit (gfc_statement st) -{ - gfc_state_data *p; - int n; - - gfc_adjust_builtins (); - - if (gfc_new_block - && gfc_new_block->abr_modproc_decl - && gfc_new_block->attr.function) - get_modproc_result (); - - st = parse_spec (st); - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_CONTAINS: - /* This is not allowed within BLOCK! */ - if (gfc_current_state () != COMP_BLOCK) - goto contains; - break; - - case_end: - accept_statement (st); - goto done; - - default: - break; - } - - if (gfc_current_state () == COMP_FUNCTION) - gfc_check_function_type (gfc_current_ns); - -loop: - for (;;) - { - st = parse_executable (st); - - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_CONTAINS: - /* This is not allowed within BLOCK! */ - if (gfc_current_state () != COMP_BLOCK) - goto contains; - break; - - case_end: - accept_statement (st); - goto done; - - default: - break; - } - - unexpected_statement (st); - reject_statement (); - st = next_statement (); - } - -contains: - n = 0; - - for (p = gfc_state_stack; p; p = p->previous) - if (p->state == COMP_CONTAINS) - n++; - - if (gfc_find_state (COMP_MODULE) == true - || gfc_find_state (COMP_SUBMODULE) == true) - n--; - - if (n > 0) - { - gfc_error ("CONTAINS statement at %C is already in a contained " - "program unit"); - reject_statement (); - st = next_statement (); - goto loop; - } - - parse_contained (0); - -done: - gfc_current_ns->code = gfc_state_stack->head; -} - - -/* Come here to complain about a global symbol already in use as - something else. */ - -void -gfc_global_used (gfc_gsymbol *sym, locus *where) -{ - const char *name; - - if (where == NULL) - where = &gfc_current_locus; - - switch(sym->type) - { - case GSYM_PROGRAM: - name = "PROGRAM"; - break; - case GSYM_FUNCTION: - name = "FUNCTION"; - break; - case GSYM_SUBROUTINE: - name = "SUBROUTINE"; - break; - case GSYM_COMMON: - name = "COMMON"; - break; - case GSYM_BLOCK_DATA: - name = "BLOCK DATA"; - break; - case GSYM_MODULE: - name = "MODULE"; - break; - default: - name = NULL; - } - - if (name) - { - if (sym->binding_label) - gfc_error ("Global binding name %qs at %L is already being used " - "as a %s at %L", sym->binding_label, where, name, - &sym->where); - else - gfc_error ("Global name %qs at %L is already being used as " - "a %s at %L", sym->name, where, name, &sym->where); - } - else - { - if (sym->binding_label) - gfc_error ("Global binding name %qs at %L is already being used " - "at %L", sym->binding_label, where, &sym->where); - else - gfc_error ("Global name %qs at %L is already being used at %L", - sym->name, where, &sym->where); - } -} - - -/* Parse a block data program unit. */ - -static void -parse_block_data (void) -{ - gfc_statement st; - static locus blank_locus; - static int blank_block=0; - gfc_gsymbol *s; - - gfc_current_ns->proc_name = gfc_new_block; - gfc_current_ns->is_block_data = 1; - - if (gfc_new_block == NULL) - { - if (blank_block) - gfc_error ("Blank BLOCK DATA at %C conflicts with " - "prior BLOCK DATA at %L", &blank_locus); - else - { - blank_block = 1; - blank_locus = gfc_current_locus; - } - } - else - { - s = gfc_get_gsymbol (gfc_new_block->name, false); - if (s->defined - || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) - gfc_global_used (s, &gfc_new_block->declared_at); - else - { - s->type = GSYM_BLOCK_DATA; - s->where = gfc_new_block->declared_at; - s->defined = 1; - } - } - - st = parse_spec (ST_NONE); - - while (st != ST_END_BLOCK_DATA) - { - gfc_error ("Unexpected %s statement in BLOCK DATA at %C", - gfc_ascii_statement (st)); - reject_statement (); - st = next_statement (); - } -} - - -/* Following the association of the ancestor (sub)module symbols, they - must be set host rather than use associated and all must be public. - They are flagged up by 'used_in_submodule' so that they can be set - DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the - linker chokes on multiple symbol definitions. */ - -static void -set_syms_host_assoc (gfc_symbol *sym) -{ - gfc_component *c; - const char dot[2] = "."; - /* Symbols take the form module.submodule_ or module.name_. */ - char parent1[2 * GFC_MAX_SYMBOL_LEN + 2]; - char parent2[2 * GFC_MAX_SYMBOL_LEN + 2]; - - if (sym == NULL) - return; - - if (sym->attr.module_procedure) - sym->attr.external = 0; - - sym->attr.use_assoc = 0; - sym->attr.host_assoc = 1; - sym->attr.used_in_submodule =1; - - if (sym->attr.flavor == FL_DERIVED) - { - /* Derived types with PRIVATE components that are declared in - modules other than the parent module must not be changed to be - PUBLIC. The 'use-assoc' attribute must be reset so that the - test in symbol.c(gfc_find_component) works correctly. This is - not necessary for PRIVATE symbols since they are not read from - the module. */ - memset(parent1, '\0', sizeof(parent1)); - memset(parent2, '\0', sizeof(parent2)); - strcpy (parent1, gfc_new_block->name); - strcpy (parent2, sym->module); - if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0) - { - for (c = sym->components; c; c = c->next) - c->attr.access = ACCESS_PUBLIC; - } - else - { - sym->attr.use_assoc = 1; - sym->attr.host_assoc = 0; - } - } -} - -/* Parse a module subprogram. */ - -static void -parse_module (void) -{ - gfc_statement st; - gfc_gsymbol *s; - bool error; - - s = gfc_get_gsymbol (gfc_new_block->name, false); - if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE)) - gfc_global_used (s, &gfc_new_block->declared_at); - else - { - s->type = GSYM_MODULE; - s->where = gfc_new_block->declared_at; - s->defined = 1; - } - - /* Something is nulling the module_list after this point. This is good - since it allows us to 'USE' the parent modules that the submodule - inherits and to set (most) of the symbols as host associated. */ - if (gfc_current_state () == COMP_SUBMODULE) - { - use_modules (); - gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc); - } - - st = parse_spec (ST_NONE); - - error = false; -loop: - switch (st) - { - case ST_NONE: - unexpected_eof (); - - case ST_CONTAINS: - parse_contained (1); - break; - - case ST_END_MODULE: - case ST_END_SUBMODULE: - accept_statement (st); - break; - - default: - gfc_error ("Unexpected %s statement in MODULE at %C", - gfc_ascii_statement (st)); - - error = true; - reject_statement (); - st = next_statement (); - goto loop; - } - - /* Make sure not to free the namespace twice on error. */ - if (!error) - s->ns = gfc_current_ns; -} - - -/* Add a procedure name to the global symbol table. */ - -static void -add_global_procedure (bool sub) -{ - gfc_gsymbol *s; - - /* Only in Fortran 2003: For procedures with a binding label also the Fortran - name is a global identifier. */ - if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008)) - { - s = gfc_get_gsymbol (gfc_new_block->name, false); - - if (s->defined - || (s->type != GSYM_UNKNOWN - && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) - { - gfc_global_used (s, &gfc_new_block->declared_at); - /* Silence follow-up errors. */ - gfc_new_block->binding_label = NULL; - } - else - { - s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; - s->sym_name = gfc_new_block->name; - s->where = gfc_new_block->declared_at; - s->defined = 1; - s->ns = gfc_current_ns; - } - } - - /* Don't add the symbol multiple times. */ - if (gfc_new_block->binding_label - && (!gfc_notification_std (GFC_STD_F2008) - || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0)) - { - s = gfc_get_gsymbol (gfc_new_block->binding_label, true); - - if (s->defined - || (s->type != GSYM_UNKNOWN - && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) - { - gfc_global_used (s, &gfc_new_block->declared_at); - /* Silence follow-up errors. */ - gfc_new_block->binding_label = NULL; - } - else - { - s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; - s->sym_name = gfc_new_block->name; - s->binding_label = gfc_new_block->binding_label; - s->where = gfc_new_block->declared_at; - s->defined = 1; - s->ns = gfc_current_ns; - } - } -} - - -/* Add a program to the global symbol table. */ - -static void -add_global_program (void) -{ - gfc_gsymbol *s; - - if (gfc_new_block == NULL) - return; - s = gfc_get_gsymbol (gfc_new_block->name, false); - - if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM)) - gfc_global_used (s, &gfc_new_block->declared_at); - else - { - s->type = GSYM_PROGRAM; - s->where = gfc_new_block->declared_at; - s->defined = 1; - s->ns = gfc_current_ns; - } -} - - -/* Resolve all the program units. */ -static void -resolve_all_program_units (gfc_namespace *gfc_global_ns_list) -{ - gfc_derived_types = NULL; - gfc_current_ns = gfc_global_ns_list; - for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) - { - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) - continue; /* Already resolved. */ - - if (gfc_current_ns->proc_name) - gfc_current_locus = gfc_current_ns->proc_name->declared_at; - gfc_resolve (gfc_current_ns); - gfc_current_ns->derived_types = gfc_derived_types; - gfc_derived_types = NULL; - } -} - - -static void -clean_up_modules (gfc_gsymbol *&gsym) -{ - if (gsym == NULL) - return; - - clean_up_modules (gsym->left); - clean_up_modules (gsym->right); - - if (gsym->type != GSYM_MODULE) - return; - - if (gsym->ns) - { - gfc_current_ns = gsym->ns; - gfc_derived_types = gfc_current_ns->derived_types; - gfc_done_2 (); - gsym->ns = NULL; - } - free (gsym); - gsym = NULL; -} - - -/* Translate all the program units. This could be in a different order - to resolution if there are forward references in the file. */ -static void -translate_all_program_units (gfc_namespace *gfc_global_ns_list) -{ - int errors; - - gfc_current_ns = gfc_global_ns_list; - gfc_get_errors (NULL, &errors); - - /* We first translate all modules to make sure that later parts - of the program can use the decl. Then we translate the nonmodules. */ - - for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) - { - if (!gfc_current_ns->proc_name - || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) - continue; - - gfc_current_locus = gfc_current_ns->proc_name->declared_at; - gfc_derived_types = gfc_current_ns->derived_types; - gfc_generate_module_code (gfc_current_ns); - gfc_current_ns->translated = 1; - } - - gfc_current_ns = gfc_global_ns_list; - for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) - { - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) - continue; - - gfc_current_locus = gfc_current_ns->proc_name->declared_at; - gfc_derived_types = gfc_current_ns->derived_types; - gfc_generate_code (gfc_current_ns); - gfc_current_ns->translated = 1; - } - - /* Clean up all the namespaces after translation. */ - gfc_current_ns = gfc_global_ns_list; - for (;gfc_current_ns;) - { - gfc_namespace *ns; - - if (gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) - { - gfc_current_ns = gfc_current_ns->sibling; - continue; - } - - ns = gfc_current_ns->sibling; - gfc_derived_types = gfc_current_ns->derived_types; - gfc_done_2 (); - gfc_current_ns = ns; - } - - clean_up_modules (gfc_gsym_root); -} - - -/* Top level parser. */ - -bool -gfc_parse_file (void) -{ - int seen_program, errors_before, errors; - gfc_state_data top, s; - gfc_statement st; - locus prog_locus; - gfc_namespace *next; - - gfc_start_source_files (); - - top.state = COMP_NONE; - top.sym = NULL; - top.previous = NULL; - top.head = top.tail = NULL; - top.do_variable = NULL; - - gfc_state_stack = ⊤ - - gfc_clear_new_st (); - - gfc_statement_label = NULL; - - if (setjmp (eof_buf)) - return false; /* Come here on unexpected EOF */ - - /* Prepare the global namespace that will contain the - program units. */ - gfc_global_ns_list = next = NULL; - - seen_program = 0; - errors_before = 0; - - /* Exit early for empty files. */ - if (gfc_at_eof ()) - goto done; - - in_specification_block = true; -loop: - gfc_init_2 (); - st = next_statement (); - switch (st) - { - case ST_NONE: - gfc_done_2 (); - goto done; - - case ST_PROGRAM: - if (seen_program) - goto duplicate_main; - seen_program = 1; - prog_locus = gfc_current_locus; - - push_state (&s, COMP_PROGRAM, gfc_new_block); - main_program_symbol (gfc_current_ns, gfc_new_block->name); - accept_statement (st); - add_global_program (); - parse_progunit (ST_NONE); - goto prog_units; - - case ST_SUBROUTINE: - add_global_procedure (true); - push_state (&s, COMP_SUBROUTINE, gfc_new_block); - accept_statement (st); - parse_progunit (ST_NONE); - goto prog_units; - - case ST_FUNCTION: - add_global_procedure (false); - push_state (&s, COMP_FUNCTION, gfc_new_block); - accept_statement (st); - parse_progunit (ST_NONE); - goto prog_units; - - case ST_BLOCK_DATA: - push_state (&s, COMP_BLOCK_DATA, gfc_new_block); - accept_statement (st); - parse_block_data (); - break; - - case ST_MODULE: - push_state (&s, COMP_MODULE, gfc_new_block); - accept_statement (st); - - gfc_get_errors (NULL, &errors_before); - parse_module (); - break; - - case ST_SUBMODULE: - push_state (&s, COMP_SUBMODULE, gfc_new_block); - accept_statement (st); - - gfc_get_errors (NULL, &errors_before); - parse_module (); - break; - - /* Anything else starts a nameless main program block. */ - default: - if (seen_program) - goto duplicate_main; - seen_program = 1; - prog_locus = gfc_current_locus; - - push_state (&s, COMP_PROGRAM, gfc_new_block); - main_program_symbol (gfc_current_ns, "MAIN__"); - parse_progunit (st); - goto prog_units; - } - - /* Handle the non-program units. */ - gfc_current_ns->code = s.head; - - gfc_resolve (gfc_current_ns); - - /* Fix the implicit_pure attribute for those procedures who should - not have it. */ - while (gfc_fix_implicit_pure (gfc_current_ns)) - ; - - /* Dump the parse tree if requested. */ - if (flag_dump_fortran_original) - gfc_dump_parse_tree (gfc_current_ns, stdout); - - gfc_get_errors (NULL, &errors); - if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE) - { - gfc_dump_module (s.sym->name, errors_before == errors); - gfc_current_ns->derived_types = gfc_derived_types; - gfc_derived_types = NULL; - goto prog_units; - } - else - { - if (errors == 0) - gfc_generate_code (gfc_current_ns); - pop_state (); - gfc_done_2 (); - } - - goto loop; - -prog_units: - /* The main program and non-contained procedures are put - in the global namespace list, so that they can be processed - later and all their interfaces resolved. */ - gfc_current_ns->code = s.head; - if (next) - { - for (; next->sibling; next = next->sibling) - ; - next->sibling = gfc_current_ns; - } - else - gfc_global_ns_list = gfc_current_ns; - - next = gfc_current_ns; - - pop_state (); - goto loop; - -done: - /* Do the resolution. */ - resolve_all_program_units (gfc_global_ns_list); - - /* Go through all top-level namespaces and unset the implicit_pure - attribute for any procedures that call something not pure or - implicit_pure. Because the a procedure marked as not implicit_pure - in one sweep may be called by another routine, we repeat this - process until there are no more changes. */ - bool changed; - do - { - changed = false; - for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; - gfc_current_ns = gfc_current_ns->sibling) - { - if (gfc_fix_implicit_pure (gfc_current_ns)) - changed = true; - } - } - while (changed); - - /* Fixup for external procedures and resolve 'omp requires'. */ - int omp_requires; - omp_requires = 0; - for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; - gfc_current_ns = gfc_current_ns->sibling) - { - omp_requires |= gfc_current_ns->omp_requires; - gfc_check_externals (gfc_current_ns); - } - for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; - gfc_current_ns = gfc_current_ns->sibling) - gfc_check_omp_requires (gfc_current_ns, omp_requires); - - /* Populate omp_requires_mask (needed for resolving OpenMP - metadirectives and declare variant). */ - switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) - { - case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: - omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST); - break; - case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: - omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL); - break; - case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: - omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED); - break; - } - - /* Do the parse tree dump. */ - gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; - - for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) - if (!gfc_current_ns->proc_name - || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) - { - gfc_dump_parse_tree (gfc_current_ns, stdout); - fputs ("------------------------------------------\n\n", stdout); - } - - /* Dump C prototypes. */ - if (flag_c_prototypes || flag_c_prototypes_external) - { - fprintf (stdout, - "#include \n" - "#ifdef __cplusplus\n" - "#include \n" - "#define __GFORTRAN_FLOAT_COMPLEX std::complex\n" - "#define __GFORTRAN_DOUBLE_COMPLEX std::complex\n" - "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex\n" - "extern \"C\" {\n" - "#else\n" - "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n" - "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n" - "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n" - "#endif\n\n"); - } - - /* First dump BIND(C) prototypes. */ - if (flag_c_prototypes) - { - for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; - gfc_current_ns = gfc_current_ns->sibling) - gfc_dump_c_prototypes (gfc_current_ns, stdout); - } - - /* Dump external prototypes. */ - if (flag_c_prototypes_external) - gfc_dump_external_c_prototypes (stdout); - - if (flag_c_prototypes || flag_c_prototypes_external) - fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n"); - - /* Do the translation. */ - translate_all_program_units (gfc_global_ns_list); - - /* Dump the global symbol ist. We only do this here because part - of it is generated after mangling the identifiers in - trans-decl.c. */ - - if (flag_dump_fortran_global) - gfc_dump_global_symbols (stdout); - - gfc_end_source_files (); - return true; - -duplicate_main: - /* If we see a duplicate main program, shut down. If the second - instance is an implied main program, i.e. data decls or executable - statements, we're in for lots of errors. */ - gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); - reject_statement (); - gfc_done_2 (); - return true; -} - -/* Return true if this state data represents an OpenACC region. */ -bool -is_oacc (gfc_state_data *sd) -{ - switch (sd->construct->op) - { - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OACC_ATOMIC: - case EXEC_OACC_ROUTINE: - return true; - - default: - return false; - } -} diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc new file mode 100644 index 0000000..c04ad77 --- /dev/null +++ b/gcc/fortran/parse.cc @@ -0,0 +1,6987 @@ +/* Main parser. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include +#include "match.h" +#include "parse.h" +#include "tree-core.h" +#include "omp-general.h" + +/* Current statement label. Zero means no statement label. Because new_st + can get wiped during statement matching, we have to keep it separate. */ + +gfc_st_label *gfc_statement_label; + +static locus label_locus; +static jmp_buf eof_buf; + +gfc_state_data *gfc_state_stack; +static bool last_was_use_stmt = false; + +/* TODO: Re-order functions to kill these forward decls. */ +static void check_statement_label (gfc_statement); +static void undo_new_statement (void); +static void reject_statement (void); + + +/* A sort of half-matching function. We try to match the word on the + input with the passed string. If this succeeds, we call the + keyword-dependent matching function that will match the rest of the + statement. For single keywords, the matching subroutine is + gfc_match_eos(). */ + +static match +match_word (const char *str, match (*subr) (void), locus *old_locus) +{ + match m; + + if (str != NULL) + { + m = gfc_match (str); + if (m != MATCH_YES) + return m; + } + + m = (*subr) (); + + if (m != MATCH_YES) + { + gfc_current_locus = *old_locus; + reject_statement (); + } + + return m; +} + + +/* Like match_word, but if str is matched, set a flag that it + was matched. */ +static match +match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus, + bool *simd_matched) +{ + match m; + + if (str != NULL) + { + m = gfc_match (str); + if (m != MATCH_YES) + return m; + *simd_matched = true; + } + + m = (*subr) (); + + if (m != MATCH_YES) + { + gfc_current_locus = *old_locus; + reject_statement (); + } + + return m; +} + + +/* Load symbols from all USE statements encountered in this scoping unit. */ + +static void +use_modules (void) +{ + gfc_error_buffer old_error; + + gfc_push_error (&old_error); + gfc_buffer_error (false); + gfc_use_modules (); + gfc_buffer_error (true); + gfc_pop_error (&old_error); + gfc_commit_symbols (); + gfc_warning_check (); + gfc_current_ns->old_equiv = gfc_current_ns->equiv; + gfc_current_ns->old_data = gfc_current_ns->data; + last_was_use_stmt = false; +} + + +/* Figure out what the next statement is, (mostly) regardless of + proper ordering. The do...while(0) is there to prevent if/else + ambiguity. */ + +#define match(keyword, subr, st) \ + do { \ + if (match_word (keyword, subr, &old_locus) == MATCH_YES) \ + return st; \ + else \ + undo_new_statement (); \ + } while (0) + + +/* This is a specialist version of decode_statement that is used + for the specification statements in a function, whose + characteristics are deferred into the specification statements. + eg.: INTEGER (king = mykind) foo () + USE mymodule, ONLY mykind..... + The KIND parameter needs a return after USE or IMPORT, whereas + derived type declarations can occur anywhere, up the executable + block. ST_GET_FCN_CHARACTERISTICS is returned when we have run + out of the correct kind of specification statements. */ +static gfc_statement +decode_specification_statement (void) +{ + gfc_statement st; + locus old_locus; + char c; + + if (gfc_match_eos () == MATCH_YES) + return ST_NONE; + + old_locus = gfc_current_locus; + + if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) + { + last_was_use_stmt = true; + return ST_USE; + } + else + { + undo_new_statement (); + if (last_was_use_stmt) + use_modules (); + } + + match ("import", gfc_match_import, ST_IMPORT); + + if (gfc_current_block ()->result->ts.type != BT_DERIVED) + goto end_of_block; + + match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); + match (NULL, gfc_match_data_decl, ST_DATA_DECL); + match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); + + /* General statement matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_ascii_char (); + + switch (c) + { + case 'a': + match ("abstract% interface", gfc_match_abstract_interface, + ST_INTERFACE); + match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); + match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); + match ("automatic", gfc_match_automatic, ST_ATTR_DECL); + break; + + case 'b': + match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); + break; + + case 'c': + match ("codimension", gfc_match_codimension, ST_ATTR_DECL); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); + break; + + case 'd': + match ("data", gfc_match_data, ST_DATA); + match ("dimension", gfc_match_dimension, ST_ATTR_DECL); + break; + + case 'e': + match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); + match ("entry% ", gfc_match_entry, ST_ENTRY); + match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); + match ("external", gfc_match_external, ST_ATTR_DECL); + break; + + case 'f': + match ("format", gfc_match_format, ST_FORMAT); + break; + + case 'g': + break; + + case 'i': + match ("implicit", gfc_match_implicit, ST_IMPLICIT); + match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); + match ("interface", gfc_match_interface, ST_INTERFACE); + match ("intent", gfc_match_intent, ST_ATTR_DECL); + match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); + break; + + case 'm': + break; + + case 'n': + match ("namelist", gfc_match_namelist, ST_NAMELIST); + break; + + case 'o': + match ("optional", gfc_match_optional, ST_ATTR_DECL); + break; + + case 'p': + match ("parameter", gfc_match_parameter, ST_PARAMETER); + match ("pointer", gfc_match_pointer, ST_ATTR_DECL); + if (gfc_match_private (&st) == MATCH_YES) + return st; + match ("procedure", gfc_match_procedure, ST_PROCEDURE); + if (gfc_match_public (&st) == MATCH_YES) + return st; + match ("protected", gfc_match_protected, ST_ATTR_DECL); + break; + + case 'r': + break; + + case 's': + match ("save", gfc_match_save, ST_ATTR_DECL); + match ("static", gfc_match_static, ST_ATTR_DECL); + match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); + break; + + case 't': + match ("target", gfc_match_target, ST_ATTR_DECL); + match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); + break; + + case 'u': + break; + + case 'v': + match ("value", gfc_match_value, ST_ATTR_DECL); + match ("volatile", gfc_match_volatile, ST_ATTR_DECL); + break; + + case 'w': + break; + } + + /* This is not a specification statement. See if any of the matchers + has stored an error message of some sort. */ + +end_of_block: + gfc_clear_error (); + gfc_buffer_error (false); + gfc_current_locus = old_locus; + + return ST_GET_FCN_CHARACTERISTICS; +} + +static bool in_specification_block; + +/* This is the primary 'decode_statement'. */ +static gfc_statement +decode_statement (void) +{ + gfc_statement st; + locus old_locus; + match m = MATCH_NO; + char c; + + gfc_enforce_clean_symbol_state (); + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + + gfc_matching_function = false; + + if (gfc_match_eos () == MATCH_YES) + return ST_NONE; + + if (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->result->ts.kind == -1) + return decode_specification_statement (); + + old_locus = gfc_current_locus; + + c = gfc_peek_ascii_char (); + + if (c == 'u') + { + if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) + { + last_was_use_stmt = true; + return ST_USE; + } + else + undo_new_statement (); + } + + if (last_was_use_stmt) + use_modules (); + + /* Try matching a data declaration or function declaration. The + input "REALFUNCTIONA(N)" can mean several things in different + contexts, so it (and its relatives) get special treatment. */ + + if (gfc_current_state () == COMP_NONE + || gfc_current_state () == COMP_INTERFACE + || gfc_current_state () == COMP_CONTAINS) + { + gfc_matching_function = true; + m = gfc_match_function_decl (); + if (m == MATCH_YES) + return ST_FUNCTION; + else if (m == MATCH_ERROR) + reject_statement (); + else + gfc_undo_symbols (); + gfc_current_locus = old_locus; + } + gfc_matching_function = false; + + /* Legacy parameter statements are ambiguous with assignments so try parameter + first. */ + match ("parameter", gfc_match_parameter, ST_PARAMETER); + + /* Match statements whose error messages are meant to be overwritten + by something better. */ + + match (NULL, gfc_match_assignment, ST_ASSIGNMENT); + match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT); + + if (in_specification_block) + { + m = match_word (NULL, gfc_match_st_function, &old_locus); + if (m == MATCH_YES) + return ST_STATEMENT_FUNCTION; + } + + if (!(in_specification_block && m == MATCH_ERROR)) + { + match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT); + } + + match (NULL, gfc_match_data_decl, ST_DATA_DECL); + match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); + + /* Try to match a subroutine statement, which has the same optional + prefixes that functions can have. */ + + if (gfc_match_subroutine () == MATCH_YES) + return ST_SUBROUTINE; + gfc_undo_symbols (); + gfc_current_locus = old_locus; + + if (gfc_match_submod_proc () == MATCH_YES) + { + if (gfc_new_block->attr.subroutine) + return ST_SUBROUTINE; + else if (gfc_new_block->attr.function) + return ST_FUNCTION; + } + gfc_undo_symbols (); + gfc_current_locus = old_locus; + + /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE + statements, which might begin with a block label. The match functions for + these statements are unusual in that their keyword is not seen before + the matcher is called. */ + + if (gfc_match_if (&st) == MATCH_YES) + return st; + gfc_undo_symbols (); + gfc_current_locus = old_locus; + + if (gfc_match_where (&st) == MATCH_YES) + return st; + gfc_undo_symbols (); + gfc_current_locus = old_locus; + + if (gfc_match_forall (&st) == MATCH_YES) + return st; + gfc_undo_symbols (); + gfc_current_locus = old_locus; + + /* Try to match TYPE as an alias for PRINT. */ + if (gfc_match_type (&st) == MATCH_YES) + return st; + gfc_undo_symbols (); + gfc_current_locus = old_locus; + + match (NULL, gfc_match_do, ST_DO); + match (NULL, gfc_match_block, ST_BLOCK); + match (NULL, gfc_match_associate, ST_ASSOCIATE); + match (NULL, gfc_match_critical, ST_CRITICAL); + match (NULL, gfc_match_select, ST_SELECT_CASE); + match (NULL, gfc_match_select_type, ST_SELECT_TYPE); + match (NULL, gfc_match_select_rank, ST_SELECT_RANK); + + /* General statement matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + switch (c) + { + case 'a': + match ("abstract% interface", gfc_match_abstract_interface, + ST_INTERFACE); + match ("allocate", gfc_match_allocate, ST_ALLOCATE); + match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); + match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); + match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); + match ("automatic", gfc_match_automatic, ST_ATTR_DECL); + break; + + case 'b': + match ("backspace", gfc_match_backspace, ST_BACKSPACE); + match ("block data", gfc_match_block_data, ST_BLOCK_DATA); + match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); + break; + + case 'c': + match ("call", gfc_match_call, ST_CALL); + match ("change team", gfc_match_change_team, ST_CHANGE_TEAM); + match ("close", gfc_match_close, ST_CLOSE); + match ("continue", gfc_match_continue, ST_CONTINUE); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); + match ("cycle", gfc_match_cycle, ST_CYCLE); + match ("case", gfc_match_case, ST_CASE); + match ("common", gfc_match_common, ST_COMMON); + match ("contains", gfc_match_eos, ST_CONTAINS); + match ("class", gfc_match_class_is, ST_CLASS_IS); + match ("codimension", gfc_match_codimension, ST_ATTR_DECL); + break; + + case 'd': + match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE); + match ("data", gfc_match_data, ST_DATA); + match ("dimension", gfc_match_dimension, ST_ATTR_DECL); + break; + + case 'e': + match ("end file", gfc_match_endfile, ST_END_FILE); + match ("end team", gfc_match_end_team, ST_END_TEAM); + match ("exit", gfc_match_exit, ST_EXIT); + match ("else", gfc_match_else, ST_ELSE); + match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); + match ("else if", gfc_match_elseif, ST_ELSEIF); + match ("error stop", gfc_match_error_stop, ST_ERROR_STOP); + match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); + + if (gfc_match_end (&st) == MATCH_YES) + return st; + + match ("entry% ", gfc_match_entry, ST_ENTRY); + match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); + match ("external", gfc_match_external, ST_ATTR_DECL); + match ("event post", gfc_match_event_post, ST_EVENT_POST); + match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT); + break; + + case 'f': + match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE); + match ("final", gfc_match_final_decl, ST_FINAL); + match ("flush", gfc_match_flush, ST_FLUSH); + match ("form team", gfc_match_form_team, ST_FORM_TEAM); + match ("format", gfc_match_format, ST_FORMAT); + break; + + case 'g': + match ("generic", gfc_match_generic, ST_GENERIC); + match ("go to", gfc_match_goto, ST_GOTO); + break; + + case 'i': + match ("inquire", gfc_match_inquire, ST_INQUIRE); + match ("implicit", gfc_match_implicit, ST_IMPLICIT); + match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); + match ("import", gfc_match_import, ST_IMPORT); + match ("interface", gfc_match_interface, ST_INTERFACE); + match ("intent", gfc_match_intent, ST_ATTR_DECL); + match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); + break; + + case 'l': + match ("lock", gfc_match_lock, ST_LOCK); + break; + + case 'm': + match ("map", gfc_match_map, ST_MAP); + match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); + match ("module", gfc_match_module, ST_MODULE); + break; + + case 'n': + match ("nullify", gfc_match_nullify, ST_NULLIFY); + match ("namelist", gfc_match_namelist, ST_NAMELIST); + break; + + case 'o': + match ("open", gfc_match_open, ST_OPEN); + match ("optional", gfc_match_optional, ST_ATTR_DECL); + break; + + case 'p': + match ("print", gfc_match_print, ST_WRITE); + match ("pause", gfc_match_pause, ST_PAUSE); + match ("pointer", gfc_match_pointer, ST_ATTR_DECL); + if (gfc_match_private (&st) == MATCH_YES) + return st; + match ("procedure", gfc_match_procedure, ST_PROCEDURE); + match ("program", gfc_match_program, ST_PROGRAM); + if (gfc_match_public (&st) == MATCH_YES) + return st; + match ("protected", gfc_match_protected, ST_ATTR_DECL); + break; + + case 'r': + match ("rank", gfc_match_rank_is, ST_RANK); + match ("read", gfc_match_read, ST_READ); + match ("return", gfc_match_return, ST_RETURN); + match ("rewind", gfc_match_rewind, ST_REWIND); + break; + + case 's': + match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); + match ("sequence", gfc_match_eos, ST_SEQUENCE); + match ("stop", gfc_match_stop, ST_STOP); + match ("save", gfc_match_save, ST_ATTR_DECL); + match ("static", gfc_match_static, ST_ATTR_DECL); + match ("submodule", gfc_match_submodule, ST_SUBMODULE); + match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); + match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); + match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM); + break; + + case 't': + match ("target", gfc_match_target, ST_ATTR_DECL); + match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); + match ("type is", gfc_match_type_is, ST_TYPE_IS); + break; + + case 'u': + match ("union", gfc_match_union, ST_UNION); + match ("unlock", gfc_match_unlock, ST_UNLOCK); + break; + + case 'v': + match ("value", gfc_match_value, ST_ATTR_DECL); + match ("volatile", gfc_match_volatile, ST_ATTR_DECL); + break; + + case 'w': + match ("wait", gfc_match_wait, ST_WAIT); + match ("write", gfc_match_write, ST_WRITE); + break; + } + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. Suppress the "Unclassifiable + statement" if a previous error message was emitted, e.g., by + gfc_error_now (). */ + if (!gfc_error_check ()) + { + int ecnt; + gfc_get_errors (NULL, &ecnt); + if (ecnt <= 0) + gfc_error_now ("Unclassifiable statement at %C"); + } + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; +} + +/* Like match and if spec_only, goto do_spec_only without actually + matching. */ +/* If the directive matched but the clauses failed, do not start + matching the next directive in the same switch statement. */ +#define matcha(keyword, subr, st) \ + do { \ + match m2; \ + if (spec_only && gfc_match (keyword) == MATCH_YES) \ + goto do_spec_only; \ + else if ((m2 = match_word (keyword, subr, &old_locus)) \ + == MATCH_YES) \ + return st; \ + else if (m2 == MATCH_ERROR) \ + goto error_handling; \ + else \ + undo_new_statement (); \ + } while (0) + +static gfc_statement +decode_oacc_directive (void) +{ + locus old_locus; + char c; + bool spec_only = false; + + gfc_enforce_clean_symbol_state (); + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + + gfc_matching_function = false; + + if (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->result->ts.kind == -1) + spec_only = true; + + old_locus = gfc_current_locus; + + /* General OpenACC directive matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_ascii_char (); + + switch (c) + { + case 'r': + matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE); + break; + } + + gfc_unset_implicit_pure (NULL); + if (gfc_pure (NULL)) + { + gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE " + "procedures at %C"); + goto error_handling; + } + + switch (c) + { + case 'a': + matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); + break; + case 'c': + matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE); + break; + case 'd': + matcha ("data", gfc_match_oacc_data, ST_OACC_DATA); + match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE); + break; + case 'e': + matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC); + matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA); + matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA); + matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP); + matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS); + matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP); + matcha ("end parallel loop", gfc_match_omp_eos_error, + ST_OACC_END_PARALLEL_LOOP); + matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL); + matcha ("end serial loop", gfc_match_omp_eos_error, + ST_OACC_END_SERIAL_LOOP); + matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL); + matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA); + matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA); + break; + case 'h': + matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA); + break; + case 'p': + matcha ("parallel loop", gfc_match_oacc_parallel_loop, + ST_OACC_PARALLEL_LOOP); + matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL); + break; + case 'k': + matcha ("kernels loop", gfc_match_oacc_kernels_loop, + ST_OACC_KERNELS_LOOP); + matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS); + break; + case 'l': + matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP); + break; + case 's': + matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP); + matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL); + break; + case 'u': + matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE); + break; + case 'w': + matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT); + break; + } + + /* Directive not found or stored an error message. + Check and give up. */ + + error_handling: + if (gfc_error_check () == 0) + gfc_error_now ("Unclassifiable OpenACC directive at %C"); + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; + + do_spec_only: + reject_statement (); + gfc_clear_error (); + gfc_buffer_error (false); + gfc_current_locus = old_locus; + return ST_GET_FCN_CHARACTERISTICS; +} + +/* Like match, but set a flag simd_matched if keyword matched + and if spec_only, goto do_spec_only without actually matching. */ +#define matchs(keyword, subr, st) \ + do { \ + match m2; \ + if (spec_only && gfc_match (keyword) == MATCH_YES) \ + goto do_spec_only; \ + if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \ + &simd_matched)) == MATCH_YES) \ + { \ + ret = st; \ + goto finish; \ + } \ + else if (m2 == MATCH_ERROR) \ + goto error_handling; \ + else \ + undo_new_statement (); \ + } while (0) + +/* Like match, but don't match anything if not -fopenmp + and if spec_only, goto do_spec_only without actually matching. */ +/* If the directive matched but the clauses failed, do not start + matching the next directive in the same switch statement. */ +#define matcho(keyword, subr, st) \ + do { \ + match m2; \ + if (!flag_openmp) \ + ; \ + else if (spec_only && gfc_match (keyword) == MATCH_YES) \ + goto do_spec_only; \ + else if ((m2 = match_word (keyword, subr, &old_locus)) \ + == MATCH_YES) \ + { \ + ret = st; \ + goto finish; \ + } \ + else if (m2 == MATCH_ERROR) \ + goto error_handling; \ + else \ + undo_new_statement (); \ + } while (0) + +/* Like match, but set a flag simd_matched if keyword matched. */ +#define matchds(keyword, subr, st) \ + do { \ + match m2; \ + if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \ + &simd_matched)) == MATCH_YES) \ + { \ + ret = st; \ + goto finish; \ + } \ + else if (m2 == MATCH_ERROR) \ + goto error_handling; \ + else \ + undo_new_statement (); \ + } while (0) + +/* Like match, but don't match anything if not -fopenmp. */ +#define matchdo(keyword, subr, st) \ + do { \ + match m2; \ + if (!flag_openmp) \ + ; \ + else if ((m2 = match_word (keyword, subr, &old_locus)) \ + == MATCH_YES) \ + { \ + ret = st; \ + goto finish; \ + } \ + else if (m2 == MATCH_ERROR) \ + goto error_handling; \ + else \ + undo_new_statement (); \ + } while (0) + +static gfc_statement +decode_omp_directive (void) +{ + locus old_locus; + char c; + bool simd_matched = false; + bool spec_only = false; + gfc_statement ret = ST_NONE; + bool pure_ok = true; + + gfc_enforce_clean_symbol_state (); + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + + gfc_matching_function = false; + + if (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->result->ts.kind == -1) + spec_only = true; + + old_locus = gfc_current_locus; + + /* General OpenMP directive matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_ascii_char (); + + /* match is for directives that should be recognized only if + -fopenmp, matchs for directives that should be recognized + if either -fopenmp or -fopenmp-simd. + Handle only the directives allowed in PURE procedures + first (those also shall not turn off implicit pure). */ + switch (c) + { + case 'd': + matchds ("declare simd", gfc_match_omp_declare_simd, + ST_OMP_DECLARE_SIMD); + matchdo ("declare target", gfc_match_omp_declare_target, + ST_OMP_DECLARE_TARGET); + matchdo ("declare variant", gfc_match_omp_declare_variant, + ST_OMP_DECLARE_VARIANT); + break; + case 's': + matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD); + break; + } + + pure_ok = false; + if (flag_openmp && gfc_pure (NULL)) + { + gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " + "at %C may not appear in PURE procedures"); + gfc_error_recovery (); + return ST_NONE; + } + + /* match is for directives that should be recognized only if + -fopenmp, matchs for directives that should be recognized + if either -fopenmp or -fopenmp-simd. */ + switch (c) + { + case 'a': + matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); + break; + case 'b': + matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); + break; + case 'c': + matcho ("cancellation% point", gfc_match_omp_cancellation_point, + ST_OMP_CANCELLATION_POINT); + matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL); + matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); + break; + case 'd': + matchds ("declare reduction", gfc_match_omp_declare_reduction, + ST_OMP_DECLARE_REDUCTION); + matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ); + matchs ("distribute parallel do simd", + gfc_match_omp_distribute_parallel_do_simd, + ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD); + matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do, + ST_OMP_DISTRIBUTE_PARALLEL_DO); + matchs ("distribute simd", gfc_match_omp_distribute_simd, + ST_OMP_DISTRIBUTE_SIMD); + matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE); + matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD); + matcho ("do", gfc_match_omp_do, ST_OMP_DO); + break; + case 'e': + matcho ("error", gfc_match_omp_error, ST_OMP_ERROR); + matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC); + matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL); + matchs ("end distribute parallel do simd", gfc_match_omp_eos_error, + ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD); + matcho ("end distribute parallel do", gfc_match_omp_eos_error, + ST_OMP_END_DISTRIBUTE_PARALLEL_DO); + matchs ("end distribute simd", gfc_match_omp_eos_error, + ST_OMP_END_DISTRIBUTE_SIMD); + matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE); + matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD); + matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); + matcho ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP); + matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD); + matcho ("end masked taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_MASKED_TASKLOOP_SIMD); + matcho ("end masked taskloop", gfc_match_omp_eos_error, + ST_OMP_END_MASKED_TASKLOOP); + matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED); + matcho ("end master taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_MASTER_TASKLOOP_SIMD); + matcho ("end master taskloop", gfc_match_omp_eos_error, + ST_OMP_END_MASTER_TASKLOOP); + matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER); + matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED); + matchs ("end parallel do simd", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_DO_SIMD); + matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO); + matcho ("end parallel loop", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_LOOP); + matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD); + matcho ("end parallel masked taskloop", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASKED_TASKLOOP); + matcho ("end parallel masked", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASKED); + matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD); + matcho ("end parallel master taskloop", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASTER_TASKLOOP); + matcho ("end parallel master", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_MASTER); + matcho ("end parallel sections", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_SECTIONS); + matcho ("end parallel workshare", gfc_match_omp_eos_error, + ST_OMP_END_PARALLEL_WORKSHARE); + matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL); + matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE); + matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); + matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); + matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA); + matchs ("end target parallel do simd", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_PARALLEL_DO_SIMD); + matcho ("end target parallel do", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_PARALLEL_DO); + matcho ("end target parallel loop", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_PARALLEL_LOOP); + matcho ("end target parallel", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_PARALLEL); + matchs ("end target simd", gfc_match_omp_end_nowait, ST_OMP_END_TARGET_SIMD); + matchs ("end target teams distribute parallel do simd", + gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); + matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); + matchs ("end target teams distribute simd", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD); + matcho ("end target teams distribute", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_TEAMS_DISTRIBUTE); + matcho ("end target teams loop", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_TEAMS_LOOP); + matcho ("end target teams", gfc_match_omp_end_nowait, + ST_OMP_END_TARGET_TEAMS); + matcho ("end target", gfc_match_omp_end_nowait, ST_OMP_END_TARGET); + matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP); + matchs ("end taskloop simd", gfc_match_omp_eos_error, + ST_OMP_END_TASKLOOP_SIMD); + matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP); + matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK); + matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error, + ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); + matcho ("end teams distribute parallel do", gfc_match_omp_eos_error, + ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO); + matchs ("end teams distribute simd", gfc_match_omp_eos_error, + ST_OMP_END_TEAMS_DISTRIBUTE_SIMD); + matcho ("end teams distribute", gfc_match_omp_eos_error, + ST_OMP_END_TEAMS_DISTRIBUTE); + matcho ("end teams loop", gfc_match_omp_eos_error, ST_OMP_END_TEAMS_LOOP); + matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS); + matcho ("end workshare", gfc_match_omp_end_nowait, + ST_OMP_END_WORKSHARE); + break; + case 'f': + matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); + break; + case 'm': + matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd, + ST_OMP_MASKED_TASKLOOP_SIMD); + matcho ("masked taskloop", gfc_match_omp_masked_taskloop, + ST_OMP_MASKED_TASKLOOP); + matcho ("masked", gfc_match_omp_masked, ST_OMP_MASKED); + matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd, + ST_OMP_MASTER_TASKLOOP_SIMD); + matcho ("master taskloop", gfc_match_omp_master_taskloop, + ST_OMP_MASTER_TASKLOOP); + matcho ("master", gfc_match_omp_master, ST_OMP_MASTER); + break; + case 'n': + matcho ("nothing", gfc_match_omp_nothing, ST_NONE); + break; + case 'l': + matcho ("loop", gfc_match_omp_loop, ST_OMP_LOOP); + break; + case 'o': + if (gfc_match ("ordered depend (") == MATCH_YES) + { + gfc_current_locus = old_locus; + if (!flag_openmp) + break; + matcho ("ordered", gfc_match_omp_ordered_depend, + ST_OMP_ORDERED_DEPEND); + } + else + matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED); + break; + case 'p': + matchs ("parallel do simd", gfc_match_omp_parallel_do_simd, + ST_OMP_PARALLEL_DO_SIMD); + matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); + matcho ("parallel loop", gfc_match_omp_parallel_loop, + ST_OMP_PARALLEL_LOOP); + matcho ("parallel masked taskloop simd", + gfc_match_omp_parallel_masked_taskloop_simd, + ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD); + matcho ("parallel masked taskloop", + gfc_match_omp_parallel_masked_taskloop, + ST_OMP_PARALLEL_MASKED_TASKLOOP); + matcho ("parallel masked", gfc_match_omp_parallel_masked, + ST_OMP_PARALLEL_MASKED); + matcho ("parallel master taskloop simd", + gfc_match_omp_parallel_master_taskloop_simd, + ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD); + matcho ("parallel master taskloop", + gfc_match_omp_parallel_master_taskloop, + ST_OMP_PARALLEL_MASTER_TASKLOOP); + matcho ("parallel master", gfc_match_omp_parallel_master, + ST_OMP_PARALLEL_MASTER); + matcho ("parallel sections", gfc_match_omp_parallel_sections, + ST_OMP_PARALLEL_SECTIONS); + matcho ("parallel workshare", gfc_match_omp_parallel_workshare, + ST_OMP_PARALLEL_WORKSHARE); + matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); + break; + case 'r': + matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES); + break; + case 's': + matcho ("scan", gfc_match_omp_scan, ST_OMP_SCAN); + matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE); + matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); + matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION); + matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE); + break; + case 't': + matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA); + matcho ("target enter data", gfc_match_omp_target_enter_data, + ST_OMP_TARGET_ENTER_DATA); + matcho ("target exit data", gfc_match_omp_target_exit_data, + ST_OMP_TARGET_EXIT_DATA); + matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd, + ST_OMP_TARGET_PARALLEL_DO_SIMD); + matcho ("target parallel do", gfc_match_omp_target_parallel_do, + ST_OMP_TARGET_PARALLEL_DO); + matcho ("target parallel loop", gfc_match_omp_target_parallel_loop, + ST_OMP_TARGET_PARALLEL_LOOP); + matcho ("target parallel", gfc_match_omp_target_parallel, + ST_OMP_TARGET_PARALLEL); + matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD); + matchs ("target teams distribute parallel do simd", + gfc_match_omp_target_teams_distribute_parallel_do_simd, + ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); + matcho ("target teams distribute parallel do", + gfc_match_omp_target_teams_distribute_parallel_do, + ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); + matchs ("target teams distribute simd", + gfc_match_omp_target_teams_distribute_simd, + ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD); + matcho ("target teams distribute", gfc_match_omp_target_teams_distribute, + ST_OMP_TARGET_TEAMS_DISTRIBUTE); + matcho ("target teams loop", gfc_match_omp_target_teams_loop, + ST_OMP_TARGET_TEAMS_LOOP); + matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS); + matcho ("target update", gfc_match_omp_target_update, + ST_OMP_TARGET_UPDATE); + matcho ("target", gfc_match_omp_target, ST_OMP_TARGET); + matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP); + matchs ("taskloop simd", gfc_match_omp_taskloop_simd, + ST_OMP_TASKLOOP_SIMD); + matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP); + matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT); + matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD); + matcho ("task", gfc_match_omp_task, ST_OMP_TASK); + matchs ("teams distribute parallel do simd", + gfc_match_omp_teams_distribute_parallel_do_simd, + ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); + matcho ("teams distribute parallel do", + gfc_match_omp_teams_distribute_parallel_do, + ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO); + matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd, + ST_OMP_TEAMS_DISTRIBUTE_SIMD); + matcho ("teams distribute", gfc_match_omp_teams_distribute, + ST_OMP_TEAMS_DISTRIBUTE); + matcho ("teams loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP); + matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS); + matchdo ("threadprivate", gfc_match_omp_threadprivate, + ST_OMP_THREADPRIVATE); + break; + case 'w': + matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); + break; + } + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. Don't error out if + not -fopenmp and simd_matched is false, i.e. if a directive other + than one marked with match has been seen. */ + + error_handling: + if (flag_openmp || simd_matched) + { + if (!gfc_error_check ()) + gfc_error_now ("Unclassifiable OpenMP directive at %C"); + } + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; + + finish: + if (!pure_ok) + { + gfc_unset_implicit_pure (NULL); + + if (!flag_openmp && gfc_pure (NULL)) + { + gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " + "at %C may not appear in PURE procedures"); + reject_statement (); + gfc_error_recovery (); + return ST_NONE; + } + } + switch (ret) + { + case ST_OMP_DECLARE_TARGET: + case ST_OMP_TARGET: + case ST_OMP_TARGET_DATA: + case ST_OMP_TARGET_ENTER_DATA: + case ST_OMP_TARGET_EXIT_DATA: + case ST_OMP_TARGET_TEAMS: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_TEAMS_LOOP: + case ST_OMP_TARGET_PARALLEL: + case ST_OMP_TARGET_PARALLEL_DO: + case ST_OMP_TARGET_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_PARALLEL_LOOP: + case ST_OMP_TARGET_SIMD: + case ST_OMP_TARGET_UPDATE: + { + gfc_namespace *prog_unit = gfc_current_ns; + while (prog_unit->parent) + { + if (gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_INTERFACE) + break; + prog_unit = prog_unit->parent; + } + prog_unit->omp_target_seen = true; + break; + } + case ST_OMP_ERROR: + if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION) + return ST_NONE; + default: + break; + } + return ret; + + do_spec_only: + reject_statement (); + gfc_clear_error (); + gfc_buffer_error (false); + gfc_current_locus = old_locus; + return ST_GET_FCN_CHARACTERISTICS; +} + +static gfc_statement +decode_gcc_attribute (void) +{ + locus old_locus; + + gfc_enforce_clean_symbol_state (); + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + old_locus = gfc_current_locus; + + match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL); + match ("unroll", gfc_match_gcc_unroll, ST_NONE); + match ("builtin", gfc_match_gcc_builtin, ST_NONE); + match ("ivdep", gfc_match_gcc_ivdep, ST_NONE); + match ("vector", gfc_match_gcc_vector, ST_NONE); + match ("novector", gfc_match_gcc_novector, ST_NONE); + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. */ + + if (!gfc_error_check ()) + { + if (pedantic) + gfc_error_now ("Unclassifiable GCC directive at %C"); + else + gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored"); + } + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; +} + +#undef match + +/* Assert next length characters to be equal to token in free form. */ + +static void +verify_token_free (const char* token, int length, bool last_was_use_stmt) +{ + int i; + char c; + + c = gfc_next_ascii_char (); + for (i = 0; i < length; i++, c = gfc_next_ascii_char ()) + gcc_assert (c == token[i]); + + gcc_assert (gfc_is_whitespace(c)); + gfc_gobble_whitespace (); + if (last_was_use_stmt) + use_modules (); +} + +/* Get the next statement in free form source. */ + +static gfc_statement +next_free (void) +{ + match m; + int i, cnt, at_bol; + char c; + + at_bol = gfc_at_bol (); + gfc_gobble_whitespace (); + + c = gfc_peek_ascii_char (); + + if (ISDIGIT (c)) + { + char d; + + /* Found a statement label? */ + m = gfc_match_st_label (&gfc_statement_label); + + d = gfc_peek_ascii_char (); + if (m != MATCH_YES || !gfc_is_whitespace (d)) + { + gfc_match_small_literal_int (&i, &cnt); + + if (cnt > 5) + gfc_error_now ("Too many digits in statement label at %C"); + + if (i == 0) + gfc_error_now ("Zero is not a valid statement label at %C"); + + do + c = gfc_next_ascii_char (); + while (ISDIGIT(c)); + + if (!gfc_is_whitespace (c)) + gfc_error_now ("Non-numeric character in statement label at %C"); + + return ST_NONE; + } + else + { + label_locus = gfc_current_locus; + + gfc_gobble_whitespace (); + + if (at_bol && gfc_peek_ascii_char () == ';') + { + gfc_error_now ("Semicolon at %C needs to be preceded by " + "statement"); + gfc_next_ascii_char (); /* Eat up the semicolon. */ + return ST_NONE; + } + + if (gfc_match_eos () == MATCH_YES) + gfc_error_now ("Statement label without statement at %L", + &label_locus); + } + } + else if (c == '!') + { + /* Comments have already been skipped by the time we get here, + except for GCC attributes and OpenMP/OpenACC directives. */ + + gfc_next_ascii_char (); /* Eat up the exclamation sign. */ + c = gfc_peek_ascii_char (); + + if (c == 'g') + { + int i; + + c = gfc_next_ascii_char (); + for (i = 0; i < 4; i++, c = gfc_next_ascii_char ()) + gcc_assert (c == "gcc$"[i]); + + gfc_gobble_whitespace (); + return decode_gcc_attribute (); + + } + else if (c == '$') + { + /* Since both OpenMP and OpenACC directives starts with + !$ character sequence, we must check all flags combinations */ + if ((flag_openmp || flag_openmp_simd) + && !flag_openacc) + { + verify_token_free ("$omp", 4, last_was_use_stmt); + return decode_omp_directive (); + } + else if ((flag_openmp || flag_openmp_simd) + && flag_openacc) + { + gfc_next_ascii_char (); /* Eat up dollar character */ + c = gfc_peek_ascii_char (); + + if (c == 'o') + { + verify_token_free ("omp", 3, last_was_use_stmt); + return decode_omp_directive (); + } + else if (c == 'a') + { + verify_token_free ("acc", 3, last_was_use_stmt); + return decode_oacc_directive (); + } + } + else if (flag_openacc) + { + verify_token_free ("$acc", 4, last_was_use_stmt); + return decode_oacc_directive (); + } + } + gcc_unreachable (); + } + + if (at_bol && c == ';') + { + if (!(gfc_option.allow_std & GFC_STD_F2008)) + gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " + "statement"); + gfc_next_ascii_char (); /* Eat up the semicolon. */ + return ST_NONE; + } + + return decode_statement (); +} + +/* Assert next length characters to be equal to token in fixed form. */ + +static bool +verify_token_fixed (const char *token, int length, bool last_was_use_stmt) +{ + int i; + char c = gfc_next_char_literal (NONSTRING); + + for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING)) + gcc_assert ((char) gfc_wide_tolower (c) == token[i]); + + if (c != ' ' && c != '0') + { + gfc_buffer_error (false); + gfc_error ("Bad continuation line at %C"); + return false; + } + if (last_was_use_stmt) + use_modules (); + + return true; +} + +/* Get the next statement in fixed-form source. */ + +static gfc_statement +next_fixed (void) +{ + int label, digit_flag, i; + locus loc; + gfc_char_t c; + + if (!gfc_at_bol ()) + return decode_statement (); + + /* Skip past the current label field, parsing a statement label if + one is there. This is a weird number parser, since the number is + contained within five columns and can have any kind of embedded + spaces. We also check for characters that make the rest of the + line a comment. */ + + label = 0; + digit_flag = 0; + + for (i = 0; i < 5; i++) + { + c = gfc_next_char_literal (NONSTRING); + + switch (c) + { + case ' ': + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + label = label * 10 + ((unsigned char) c - '0'); + label_locus = gfc_current_locus; + digit_flag = 1; + break; + + /* Comments have already been skipped by the time we get + here, except for GCC attributes and OpenMP directives. */ + + case '*': + c = gfc_next_char_literal (NONSTRING); + + if (TOLOWER (c) == 'g') + { + for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING)) + gcc_assert (TOLOWER (c) == "gcc$"[i]); + + return decode_gcc_attribute (); + } + else if (c == '$') + { + if ((flag_openmp || flag_openmp_simd) + && !flag_openacc) + { + if (!verify_token_fixed ("omp", 3, last_was_use_stmt)) + return ST_NONE; + return decode_omp_directive (); + } + else if ((flag_openmp || flag_openmp_simd) + && flag_openacc) + { + c = gfc_next_char_literal(NONSTRING); + if (c == 'o' || c == 'O') + { + if (!verify_token_fixed ("mp", 2, last_was_use_stmt)) + return ST_NONE; + return decode_omp_directive (); + } + else if (c == 'a' || c == 'A') + { + if (!verify_token_fixed ("cc", 2, last_was_use_stmt)) + return ST_NONE; + return decode_oacc_directive (); + } + } + else if (flag_openacc) + { + if (!verify_token_fixed ("acc", 3, last_was_use_stmt)) + return ST_NONE; + return decode_oacc_directive (); + } + } + gcc_fallthrough (); + + /* Comments have already been skipped by the time we get + here so don't bother checking for them. */ + + default: + gfc_buffer_error (false); + gfc_error ("Non-numeric character in statement label at %C"); + return ST_NONE; + } + } + + if (digit_flag) + { + if (label == 0) + gfc_warning_now (0, "Zero is not a valid statement label at %C"); + else + { + /* We've found a valid statement label. */ + gfc_statement_label = gfc_get_st_label (label); + } + } + + /* Since this line starts a statement, it cannot be a continuation + of a previous statement. If we see something here besides a + space or zero, it must be a bad continuation line. */ + + c = gfc_next_char_literal (NONSTRING); + if (c == '\n') + goto blank_line; + + if (c != ' ' && c != '0') + { + gfc_buffer_error (false); + gfc_error ("Bad continuation line at %C"); + return ST_NONE; + } + + /* Now that we've taken care of the statement label columns, we have + to make sure that the first nonblank character is not a '!'. If + it is, the rest of the line is a comment. */ + + do + { + loc = gfc_current_locus; + c = gfc_next_char_literal (NONSTRING); + } + while (gfc_is_whitespace (c)); + + if (c == '!') + goto blank_line; + gfc_current_locus = loc; + + if (c == ';') + { + if (digit_flag) + gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + else if (!(gfc_option.allow_std & GFC_STD_F2008)) + gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " + "statement"); + return ST_NONE; + } + + if (gfc_match_eos () == MATCH_YES) + goto blank_line; + + /* At this point, we've got a nonblank statement to parse. */ + return decode_statement (); + +blank_line: + if (digit_flag) + gfc_error_now ("Statement label without statement at %L", &label_locus); + + gfc_current_locus.lb->truncated = 0; + gfc_advance_line (); + return ST_NONE; +} + + +/* Return the next non-ST_NONE statement to the caller. We also worry + about including files and the ends of include files at this stage. */ + +static gfc_statement +next_statement (void) +{ + gfc_statement st; + locus old_locus; + + gfc_enforce_clean_symbol_state (); + + gfc_new_block = NULL; + + gfc_current_ns->old_equiv = gfc_current_ns->equiv; + gfc_current_ns->old_data = gfc_current_ns->data; + for (;;) + { + gfc_statement_label = NULL; + gfc_buffer_error (true); + + if (gfc_at_eol ()) + gfc_advance_line (); + + gfc_skip_comments (); + + if (gfc_at_end ()) + { + st = ST_NONE; + break; + } + + if (gfc_define_undef_line ()) + continue; + + old_locus = gfc_current_locus; + + st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free (); + + if (st != ST_NONE) + break; + } + + gfc_buffer_error (false); + + if (st == ST_GET_FCN_CHARACTERISTICS) + { + if (gfc_statement_label != NULL) + { + gfc_free_st_label (gfc_statement_label); + gfc_statement_label = NULL; + } + gfc_current_locus = old_locus; + } + + if (st != ST_NONE) + check_statement_label (st); + + return st; +} + + +/****************************** Parser ***********************************/ + +/* The parser subroutines are of type 'try' that fail if the file ends + unexpectedly. */ + +/* Macros that expand to case-labels for various classes of + statements. Start with executable statements that directly do + things. */ + +#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \ + case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ + case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ + case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ + case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \ + case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ + case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ + case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ + case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \ + case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \ + case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \ + case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \ + case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \ + case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ + case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ + case ST_END_TEAM: case ST_SYNC_TEAM: \ + case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ + case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ + case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA + +/* Statements that mark other executable statements. */ + +#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ + case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ + case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ + case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \ + case ST_OMP_PARALLEL_MASKED_TASKLOOP: \ + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP: \ + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \ + case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ + case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \ + case ST_OMP_MASKED_TASKLOOP_SIMD: \ + case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \ + case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \ + case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ + case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \ + case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \ + case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \ + case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ + case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \ + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \ + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \ + case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \ + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \ + case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \ + case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ + case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \ + case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \ + case ST_CRITICAL: \ + case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \ + case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ + case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \ + case ST_OACC_ATOMIC + +/* Declaration statements */ + +#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ + case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ + case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE + +/* OpenMP and OpenACC declaration statements, which may appear anywhere in + the specification part. */ + +#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ + case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ + case ST_OMP_DECLARE_VARIANT: \ + case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE + +/* Block end statements. Errors associated with interchanging these + are detected in gfc_match_end(). */ + +#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ + case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ + case ST_END_BLOCK: case ST_END_ASSOCIATE + + +/* Push a new state onto the stack. */ + +static void +push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym) +{ + p->state = new_state; + p->previous = gfc_state_stack; + p->sym = sym; + p->head = p->tail = NULL; + p->do_variable = NULL; + if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT) + p->ext.oacc_declare_clauses = NULL; + + /* If this the state of a construct like BLOCK, DO or IF, the corresponding + construct statement was accepted right before pushing the state. Thus, + the construct's gfc_code is available as tail of the parent state. */ + gcc_assert (gfc_state_stack); + p->construct = gfc_state_stack->tail; + + gfc_state_stack = p; +} + + +/* Pop the current state. */ +static void +pop_state (void) +{ + gfc_state_stack = gfc_state_stack->previous; +} + + +/* Try to find the given state in the state stack. */ + +bool +gfc_find_state (gfc_compile_state state) +{ + gfc_state_data *p; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == state) + break; + + return (p == NULL) ? false : true; +} + + +/* Starts a new level in the statement list. */ + +static gfc_code * +new_level (gfc_code *q) +{ + gfc_code *p; + + p = q->block = gfc_get_code (EXEC_NOP); + + gfc_state_stack->head = gfc_state_stack->tail = p; + + return p; +} + + +/* Add the current new_st code structure and adds it to the current + program unit. As a side-effect, it zeroes the new_st. */ + +static gfc_code * +add_statement (void) +{ + gfc_code *p; + + p = XCNEW (gfc_code); + *p = new_st; + + p->loc = gfc_current_locus; + + if (gfc_state_stack->head == NULL) + gfc_state_stack->head = p; + else + gfc_state_stack->tail->next = p; + + while (p->next != NULL) + p = p->next; + + gfc_state_stack->tail = p; + + gfc_clear_new_st (); + + return p; +} + + +/* Frees everything associated with the current statement. */ + +static void +undo_new_statement (void) +{ + gfc_free_statements (new_st.block); + gfc_free_statements (new_st.next); + gfc_free_statement (&new_st); + gfc_clear_new_st (); +} + + +/* If the current statement has a statement label, make sure that it + is allowed to, or should have one. */ + +static void +check_statement_label (gfc_statement st) +{ + gfc_sl_type type; + + if (gfc_statement_label == NULL) + { + if (st == ST_FORMAT) + gfc_error ("FORMAT statement at %L does not have a statement label", + &new_st.loc); + return; + } + + switch (st) + { + case ST_END_PROGRAM: + case ST_END_FUNCTION: + case ST_END_SUBROUTINE: + case ST_ENDDO: + case ST_ENDIF: + case ST_END_SELECT: + case ST_END_CRITICAL: + case ST_END_BLOCK: + case ST_END_ASSOCIATE: + case_executable: + case_exec_markers: + if (st == ST_ENDDO || st == ST_CONTINUE) + type = ST_LABEL_DO_TARGET; + else + type = ST_LABEL_TARGET; + break; + + case ST_FORMAT: + type = ST_LABEL_FORMAT; + break; + + /* Statement labels are not restricted from appearing on a + particular line. However, there are plenty of situations + where the resulting label can't be referenced. */ + + default: + type = ST_LABEL_BAD_TARGET; + break; + } + + gfc_define_st_label (gfc_statement_label, type, &label_locus); + + new_st.here = gfc_statement_label; +} + + +/* Figures out what the enclosing program unit is. This will be a + function, subroutine, program, block data or module. */ + +gfc_state_data * +gfc_enclosing_unit (gfc_compile_state * result) +{ + gfc_state_data *p; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE + || p->state == COMP_MODULE || p->state == COMP_SUBMODULE + || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM) + { + + if (result != NULL) + *result = p->state; + return p; + } + + if (result != NULL) + *result = COMP_PROGRAM; + return NULL; +} + + +/* Translate a statement enum to a string. */ + +const char * +gfc_ascii_statement (gfc_statement st) +{ + const char *p; + + switch (st) + { + case ST_ARITHMETIC_IF: + p = _("arithmetic IF"); + break; + case ST_ALLOCATE: + p = "ALLOCATE"; + break; + case ST_ASSOCIATE: + p = "ASSOCIATE"; + break; + case ST_ATTR_DECL: + p = _("attribute declaration"); + break; + case ST_BACKSPACE: + p = "BACKSPACE"; + break; + case ST_BLOCK: + p = "BLOCK"; + break; + case ST_BLOCK_DATA: + p = "BLOCK DATA"; + break; + case ST_CALL: + p = "CALL"; + break; + case ST_CASE: + p = "CASE"; + break; + case ST_CLOSE: + p = "CLOSE"; + break; + case ST_COMMON: + p = "COMMON"; + break; + case ST_CONTINUE: + p = "CONTINUE"; + break; + case ST_CONTAINS: + p = "CONTAINS"; + break; + case ST_CRITICAL: + p = "CRITICAL"; + break; + case ST_CYCLE: + p = "CYCLE"; + break; + case ST_DATA_DECL: + p = _("data declaration"); + break; + case ST_DATA: + p = "DATA"; + break; + case ST_DEALLOCATE: + p = "DEALLOCATE"; + break; + case ST_MAP: + p = "MAP"; + break; + case ST_UNION: + p = "UNION"; + break; + case ST_STRUCTURE_DECL: + p = "STRUCTURE"; + break; + case ST_DERIVED_DECL: + p = _("derived type declaration"); + break; + case ST_DO: + p = "DO"; + break; + case ST_ELSE: + p = "ELSE"; + break; + case ST_ELSEIF: + p = "ELSE IF"; + break; + case ST_ELSEWHERE: + p = "ELSEWHERE"; + break; + case ST_EVENT_POST: + p = "EVENT POST"; + break; + case ST_EVENT_WAIT: + p = "EVENT WAIT"; + break; + case ST_FAIL_IMAGE: + p = "FAIL IMAGE"; + break; + case ST_CHANGE_TEAM: + p = "CHANGE TEAM"; + break; + case ST_END_TEAM: + p = "END TEAM"; + break; + case ST_FORM_TEAM: + p = "FORM TEAM"; + break; + case ST_SYNC_TEAM: + p = "SYNC TEAM"; + break; + case ST_END_ASSOCIATE: + p = "END ASSOCIATE"; + break; + case ST_END_BLOCK: + p = "END BLOCK"; + break; + case ST_END_BLOCK_DATA: + p = "END BLOCK DATA"; + break; + case ST_END_CRITICAL: + p = "END CRITICAL"; + break; + case ST_ENDDO: + p = "END DO"; + break; + case ST_END_FILE: + p = "END FILE"; + break; + case ST_END_FORALL: + p = "END FORALL"; + break; + case ST_END_FUNCTION: + p = "END FUNCTION"; + break; + case ST_ENDIF: + p = "END IF"; + break; + case ST_END_INTERFACE: + p = "END INTERFACE"; + break; + case ST_END_MODULE: + p = "END MODULE"; + break; + case ST_END_SUBMODULE: + p = "END SUBMODULE"; + break; + case ST_END_PROGRAM: + p = "END PROGRAM"; + break; + case ST_END_SELECT: + p = "END SELECT"; + break; + case ST_END_SUBROUTINE: + p = "END SUBROUTINE"; + break; + case ST_END_WHERE: + p = "END WHERE"; + break; + case ST_END_STRUCTURE: + p = "END STRUCTURE"; + break; + case ST_END_UNION: + p = "END UNION"; + break; + case ST_END_MAP: + p = "END MAP"; + break; + case ST_END_TYPE: + p = "END TYPE"; + break; + case ST_ENTRY: + p = "ENTRY"; + break; + case ST_EQUIVALENCE: + p = "EQUIVALENCE"; + break; + case ST_ERROR_STOP: + p = "ERROR STOP"; + break; + case ST_EXIT: + p = "EXIT"; + break; + case ST_FLUSH: + p = "FLUSH"; + break; + case ST_FORALL_BLOCK: /* Fall through */ + case ST_FORALL: + p = "FORALL"; + break; + case ST_FORMAT: + p = "FORMAT"; + break; + case ST_FUNCTION: + p = "FUNCTION"; + break; + case ST_GENERIC: + p = "GENERIC"; + break; + case ST_GOTO: + p = "GOTO"; + break; + case ST_IF_BLOCK: + p = _("block IF"); + break; + case ST_IMPLICIT: + p = "IMPLICIT"; + break; + case ST_IMPLICIT_NONE: + p = "IMPLICIT NONE"; + break; + case ST_IMPLIED_ENDDO: + p = _("implied END DO"); + break; + case ST_IMPORT: + p = "IMPORT"; + break; + case ST_INQUIRE: + p = "INQUIRE"; + break; + case ST_INTERFACE: + p = "INTERFACE"; + break; + case ST_LOCK: + p = "LOCK"; + break; + case ST_PARAMETER: + p = "PARAMETER"; + break; + case ST_PRIVATE: + p = "PRIVATE"; + break; + case ST_PUBLIC: + p = "PUBLIC"; + break; + case ST_MODULE: + p = "MODULE"; + break; + case ST_SUBMODULE: + p = "SUBMODULE"; + break; + case ST_PAUSE: + p = "PAUSE"; + break; + case ST_MODULE_PROC: + p = "MODULE PROCEDURE"; + break; + case ST_NAMELIST: + p = "NAMELIST"; + break; + case ST_NULLIFY: + p = "NULLIFY"; + break; + case ST_OPEN: + p = "OPEN"; + break; + case ST_PROGRAM: + p = "PROGRAM"; + break; + case ST_PROCEDURE: + p = "PROCEDURE"; + break; + case ST_READ: + p = "READ"; + break; + case ST_RETURN: + p = "RETURN"; + break; + case ST_REWIND: + p = "REWIND"; + break; + case ST_STOP: + p = "STOP"; + break; + case ST_SYNC_ALL: + p = "SYNC ALL"; + break; + case ST_SYNC_IMAGES: + p = "SYNC IMAGES"; + break; + case ST_SYNC_MEMORY: + p = "SYNC MEMORY"; + break; + case ST_SUBROUTINE: + p = "SUBROUTINE"; + break; + case ST_TYPE: + p = "TYPE"; + break; + case ST_UNLOCK: + p = "UNLOCK"; + break; + case ST_USE: + p = "USE"; + break; + case ST_WHERE_BLOCK: /* Fall through */ + case ST_WHERE: + p = "WHERE"; + break; + case ST_WAIT: + p = "WAIT"; + break; + case ST_WRITE: + p = "WRITE"; + break; + case ST_ASSIGNMENT: + p = _("assignment"); + break; + case ST_POINTER_ASSIGNMENT: + p = _("pointer assignment"); + break; + case ST_SELECT_CASE: + p = "SELECT CASE"; + break; + case ST_SELECT_TYPE: + p = "SELECT TYPE"; + break; + case ST_SELECT_RANK: + p = "SELECT RANK"; + break; + case ST_TYPE_IS: + p = "TYPE IS"; + break; + case ST_CLASS_IS: + p = "CLASS IS"; + break; + case ST_RANK: + p = "RANK"; + break; + case ST_SEQUENCE: + p = "SEQUENCE"; + break; + case ST_SIMPLE_IF: + p = _("simple IF"); + break; + case ST_STATEMENT_FUNCTION: + p = "STATEMENT FUNCTION"; + break; + case ST_LABEL_ASSIGNMENT: + p = "LABEL ASSIGNMENT"; + break; + case ST_ENUM: + p = "ENUM DEFINITION"; + break; + case ST_ENUMERATOR: + p = "ENUMERATOR DEFINITION"; + break; + case ST_END_ENUM: + p = "END ENUM"; + break; + case ST_OACC_PARALLEL_LOOP: + p = "!$ACC PARALLEL LOOP"; + break; + case ST_OACC_END_PARALLEL_LOOP: + p = "!$ACC END PARALLEL LOOP"; + break; + case ST_OACC_PARALLEL: + p = "!$ACC PARALLEL"; + break; + case ST_OACC_END_PARALLEL: + p = "!$ACC END PARALLEL"; + break; + case ST_OACC_KERNELS: + p = "!$ACC KERNELS"; + break; + case ST_OACC_END_KERNELS: + p = "!$ACC END KERNELS"; + break; + case ST_OACC_KERNELS_LOOP: + p = "!$ACC KERNELS LOOP"; + break; + case ST_OACC_END_KERNELS_LOOP: + p = "!$ACC END KERNELS LOOP"; + break; + case ST_OACC_SERIAL_LOOP: + p = "!$ACC SERIAL LOOP"; + break; + case ST_OACC_END_SERIAL_LOOP: + p = "!$ACC END SERIAL LOOP"; + break; + case ST_OACC_SERIAL: + p = "!$ACC SERIAL"; + break; + case ST_OACC_END_SERIAL: + p = "!$ACC END SERIAL"; + break; + case ST_OACC_DATA: + p = "!$ACC DATA"; + break; + case ST_OACC_END_DATA: + p = "!$ACC END DATA"; + break; + case ST_OACC_HOST_DATA: + p = "!$ACC HOST_DATA"; + break; + case ST_OACC_END_HOST_DATA: + p = "!$ACC END HOST_DATA"; + break; + case ST_OACC_LOOP: + p = "!$ACC LOOP"; + break; + case ST_OACC_END_LOOP: + p = "!$ACC END LOOP"; + break; + case ST_OACC_DECLARE: + p = "!$ACC DECLARE"; + break; + case ST_OACC_UPDATE: + p = "!$ACC UPDATE"; + break; + case ST_OACC_WAIT: + p = "!$ACC WAIT"; + break; + case ST_OACC_CACHE: + p = "!$ACC CACHE"; + break; + case ST_OACC_ENTER_DATA: + p = "!$ACC ENTER DATA"; + break; + case ST_OACC_EXIT_DATA: + p = "!$ACC EXIT DATA"; + break; + case ST_OACC_ROUTINE: + p = "!$ACC ROUTINE"; + break; + case ST_OACC_ATOMIC: + p = "!$ACC ATOMIC"; + break; + case ST_OACC_END_ATOMIC: + p = "!$ACC END ATOMIC"; + break; + case ST_OMP_ATOMIC: + p = "!$OMP ATOMIC"; + break; + case ST_OMP_BARRIER: + p = "!$OMP BARRIER"; + break; + case ST_OMP_CANCEL: + p = "!$OMP CANCEL"; + break; + case ST_OMP_CANCELLATION_POINT: + p = "!$OMP CANCELLATION POINT"; + break; + case ST_OMP_CRITICAL: + p = "!$OMP CRITICAL"; + break; + case ST_OMP_DECLARE_REDUCTION: + p = "!$OMP DECLARE REDUCTION"; + break; + case ST_OMP_DECLARE_SIMD: + p = "!$OMP DECLARE SIMD"; + break; + case ST_OMP_DECLARE_TARGET: + p = "!$OMP DECLARE TARGET"; + break; + case ST_OMP_DECLARE_VARIANT: + p = "!$OMP DECLARE VARIANT"; + break; + case ST_OMP_DEPOBJ: + p = "!$OMP DEPOBJ"; + break; + case ST_OMP_DISTRIBUTE: + p = "!$OMP DISTRIBUTE"; + break; + case ST_OMP_DISTRIBUTE_PARALLEL_DO: + p = "!$OMP DISTRIBUTE PARALLEL DO"; + break; + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + p = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; + break; + case ST_OMP_DISTRIBUTE_SIMD: + p = "!$OMP DISTRIBUTE SIMD"; + break; + case ST_OMP_DO: + p = "!$OMP DO"; + break; + case ST_OMP_DO_SIMD: + p = "!$OMP DO SIMD"; + break; + case ST_OMP_END_ATOMIC: + p = "!$OMP END ATOMIC"; + break; + case ST_OMP_END_CRITICAL: + p = "!$OMP END CRITICAL"; + break; + case ST_OMP_END_DISTRIBUTE: + p = "!$OMP END DISTRIBUTE"; + break; + case ST_OMP_END_DISTRIBUTE_PARALLEL_DO: + p = "!$OMP END DISTRIBUTE PARALLEL DO"; + break; + case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD: + p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD"; + break; + case ST_OMP_END_DISTRIBUTE_SIMD: + p = "!$OMP END DISTRIBUTE SIMD"; + break; + case ST_OMP_END_DO: + p = "!$OMP END DO"; + break; + case ST_OMP_END_DO_SIMD: + p = "!$OMP END DO SIMD"; + break; + case ST_OMP_END_SCOPE: + p = "!$OMP END SCOPE"; + break; + case ST_OMP_END_SIMD: + p = "!$OMP END SIMD"; + break; + case ST_OMP_END_LOOP: + p = "!$OMP END LOOP"; + break; + case ST_OMP_END_MASKED: + p = "!$OMP END MASKED"; + break; + case ST_OMP_END_MASKED_TASKLOOP: + p = "!$OMP END MASKED TASKLOOP"; + break; + case ST_OMP_END_MASKED_TASKLOOP_SIMD: + p = "!$OMP END MASKED TASKLOOP SIMD"; + break; + case ST_OMP_END_MASTER: + p = "!$OMP END MASTER"; + break; + case ST_OMP_END_MASTER_TASKLOOP: + p = "!$OMP END MASTER TASKLOOP"; + break; + case ST_OMP_END_MASTER_TASKLOOP_SIMD: + p = "!$OMP END MASTER TASKLOOP SIMD"; + break; + case ST_OMP_END_ORDERED: + p = "!$OMP END ORDERED"; + break; + case ST_OMP_END_PARALLEL: + p = "!$OMP END PARALLEL"; + break; + case ST_OMP_END_PARALLEL_DO: + p = "!$OMP END PARALLEL DO"; + break; + case ST_OMP_END_PARALLEL_DO_SIMD: + p = "!$OMP END PARALLEL DO SIMD"; + break; + case ST_OMP_END_PARALLEL_LOOP: + p = "!$OMP END PARALLEL LOOP"; + break; + case ST_OMP_END_PARALLEL_MASKED: + p = "!$OMP END PARALLEL MASKED"; + break; + case ST_OMP_END_PARALLEL_MASKED_TASKLOOP: + p = "!$OMP END PARALLEL MASKED TASKLOOP"; + break; + case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD: + p = "!$OMP END PARALLEL MASKED TASKLOOP SIMD"; + break; + case ST_OMP_END_PARALLEL_MASTER: + p = "!$OMP END PARALLEL MASTER"; + break; + case ST_OMP_END_PARALLEL_MASTER_TASKLOOP: + p = "!$OMP END PARALLEL MASTER TASKLOOP"; + break; + case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD: + p = "!$OMP END PARALLEL MASTER TASKLOOP SIMD"; + break; + case ST_OMP_END_PARALLEL_SECTIONS: + p = "!$OMP END PARALLEL SECTIONS"; + break; + case ST_OMP_END_PARALLEL_WORKSHARE: + p = "!$OMP END PARALLEL WORKSHARE"; + break; + case ST_OMP_END_SECTIONS: + p = "!$OMP END SECTIONS"; + break; + case ST_OMP_END_SINGLE: + p = "!$OMP END SINGLE"; + break; + case ST_OMP_END_TASK: + p = "!$OMP END TASK"; + break; + case ST_OMP_END_TARGET: + p = "!$OMP END TARGET"; + break; + case ST_OMP_END_TARGET_DATA: + p = "!$OMP END TARGET DATA"; + break; + case ST_OMP_END_TARGET_PARALLEL: + p = "!$OMP END TARGET PARALLEL"; + break; + case ST_OMP_END_TARGET_PARALLEL_DO: + p = "!$OMP END TARGET PARALLEL DO"; + break; + case ST_OMP_END_TARGET_PARALLEL_DO_SIMD: + p = "!$OMP END TARGET PARALLEL DO SIMD"; + break; + case ST_OMP_END_TARGET_PARALLEL_LOOP: + p = "!$OMP END TARGET PARALLEL LOOP"; + break; + case ST_OMP_END_TARGET_SIMD: + p = "!$OMP END TARGET SIMD"; + break; + case ST_OMP_END_TARGET_TEAMS: + p = "!$OMP END TARGET TEAMS"; + break; + case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE: + p = "!$OMP END TARGET TEAMS DISTRIBUTE"; + break; + case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO"; + break; + case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; + break; + case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD: + p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD"; + break; + case ST_OMP_END_TARGET_TEAMS_LOOP: + p = "!$OMP END TARGET TEAMS LOOP"; + break; + case ST_OMP_END_TASKGROUP: + p = "!$OMP END TASKGROUP"; + break; + case ST_OMP_END_TASKLOOP: + p = "!$OMP END TASKLOOP"; + break; + case ST_OMP_END_TASKLOOP_SIMD: + p = "!$OMP END TASKLOOP SIMD"; + break; + case ST_OMP_END_TEAMS: + p = "!$OMP END TEAMS"; + break; + case ST_OMP_END_TEAMS_DISTRIBUTE: + p = "!$OMP END TEAMS DISTRIBUTE"; + break; + case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO: + p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO"; + break; + case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD"; + break; + case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD: + p = "!$OMP END TEAMS DISTRIBUTE SIMD"; + break; + case ST_OMP_END_TEAMS_LOOP: + p = "!$OMP END TEAMS LOOP"; + break; + case ST_OMP_END_WORKSHARE: + p = "!$OMP END WORKSHARE"; + break; + case ST_OMP_ERROR: + p = "!$OMP ERROR"; + break; + case ST_OMP_FLUSH: + p = "!$OMP FLUSH"; + break; + case ST_OMP_LOOP: + p = "!$OMP LOOP"; + break; + case ST_OMP_MASKED: + p = "!$OMP MASKED"; + break; + case ST_OMP_MASKED_TASKLOOP: + p = "!$OMP MASKED TASKLOOP"; + break; + case ST_OMP_MASKED_TASKLOOP_SIMD: + p = "!$OMP MASKED TASKLOOP SIMD"; + break; + case ST_OMP_MASTER: + p = "!$OMP MASTER"; + break; + case ST_OMP_MASTER_TASKLOOP: + p = "!$OMP MASTER TASKLOOP"; + break; + case ST_OMP_MASTER_TASKLOOP_SIMD: + p = "!$OMP MASTER TASKLOOP SIMD"; + break; + case ST_OMP_ORDERED: + case ST_OMP_ORDERED_DEPEND: + p = "!$OMP ORDERED"; + break; + case ST_OMP_PARALLEL: + p = "!$OMP PARALLEL"; + break; + case ST_OMP_PARALLEL_DO: + p = "!$OMP PARALLEL DO"; + break; + case ST_OMP_PARALLEL_LOOP: + p = "!$OMP PARALLEL LOOP"; + break; + case ST_OMP_PARALLEL_DO_SIMD: + p = "!$OMP PARALLEL DO SIMD"; + break; + case ST_OMP_PARALLEL_MASKED: + p = "!$OMP PARALLEL MASKED"; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + p = "!$OMP PARALLEL MASKED TASKLOOP"; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + p = "!$OMP PARALLEL MASKED TASKLOOP SIMD"; + break; + case ST_OMP_PARALLEL_MASTER: + p = "!$OMP PARALLEL MASTER"; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + p = "!$OMP PARALLEL MASTER TASKLOOP"; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + p = "!$OMP PARALLEL MASTER TASKLOOP SIMD"; + break; + case ST_OMP_PARALLEL_SECTIONS: + p = "!$OMP PARALLEL SECTIONS"; + break; + case ST_OMP_PARALLEL_WORKSHARE: + p = "!$OMP PARALLEL WORKSHARE"; + break; + case ST_OMP_REQUIRES: + p = "!$OMP REQUIRES"; + break; + case ST_OMP_SCAN: + p = "!$OMP SCAN"; + break; + case ST_OMP_SCOPE: + p = "!$OMP SCOPE"; + break; + case ST_OMP_SECTIONS: + p = "!$OMP SECTIONS"; + break; + case ST_OMP_SECTION: + p = "!$OMP SECTION"; + break; + case ST_OMP_SIMD: + p = "!$OMP SIMD"; + break; + case ST_OMP_SINGLE: + p = "!$OMP SINGLE"; + break; + case ST_OMP_TARGET: + p = "!$OMP TARGET"; + break; + case ST_OMP_TARGET_DATA: + p = "!$OMP TARGET DATA"; + break; + case ST_OMP_TARGET_ENTER_DATA: + p = "!$OMP TARGET ENTER DATA"; + break; + case ST_OMP_TARGET_EXIT_DATA: + p = "!$OMP TARGET EXIT DATA"; + break; + case ST_OMP_TARGET_PARALLEL: + p = "!$OMP TARGET PARALLEL"; + break; + case ST_OMP_TARGET_PARALLEL_DO: + p = "!$OMP TARGET PARALLEL DO"; + break; + case ST_OMP_TARGET_PARALLEL_DO_SIMD: + p = "!$OMP TARGET PARALLEL DO SIMD"; + break; + case ST_OMP_TARGET_PARALLEL_LOOP: + p = "!$OMP TARGET PARALLEL LOOP"; + break; + case ST_OMP_TARGET_SIMD: + p = "!$OMP TARGET SIMD"; + break; + case ST_OMP_TARGET_TEAMS: + p = "!$OMP TARGET TEAMS"; + break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: + p = "!$OMP TARGET TEAMS DISTRIBUTE"; + break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; + break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; + break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; + break; + case ST_OMP_TARGET_TEAMS_LOOP: + p = "!$OMP TARGET TEAMS LOOP"; + break; + case ST_OMP_TARGET_UPDATE: + p = "!$OMP TARGET UPDATE"; + break; + case ST_OMP_TASK: + p = "!$OMP TASK"; + break; + case ST_OMP_TASKGROUP: + p = "!$OMP TASKGROUP"; + break; + case ST_OMP_TASKLOOP: + p = "!$OMP TASKLOOP"; + break; + case ST_OMP_TASKLOOP_SIMD: + p = "!$OMP TASKLOOP SIMD"; + break; + case ST_OMP_TASKWAIT: + p = "!$OMP TASKWAIT"; + break; + case ST_OMP_TASKYIELD: + p = "!$OMP TASKYIELD"; + break; + case ST_OMP_TEAMS: + p = "!$OMP TEAMS"; + break; + case ST_OMP_TEAMS_DISTRIBUTE: + p = "!$OMP TEAMS DISTRIBUTE"; + break; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; + break; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; + break; + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: + p = "!$OMP TEAMS DISTRIBUTE SIMD"; + break; + case ST_OMP_TEAMS_LOOP: + p = "!$OMP TEAMS LOOP"; + break; + case ST_OMP_THREADPRIVATE: + p = "!$OMP THREADPRIVATE"; + break; + case ST_OMP_WORKSHARE: + p = "!$OMP WORKSHARE"; + break; + default: + gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); + } + + return p; +} + + +/* Create a symbol for the main program and assign it to ns->proc_name. */ + +static void +main_program_symbol (gfc_namespace *ns, const char *name) +{ + gfc_symbol *main_program; + symbol_attribute attr; + + gfc_get_symbol (name, ns, &main_program); + gfc_clear_attr (&attr); + attr.flavor = FL_PROGRAM; + attr.proc = PROC_UNKNOWN; + attr.subroutine = 1; + attr.access = ACCESS_PUBLIC; + attr.is_main_program = 1; + main_program->attr = attr; + main_program->declared_at = gfc_current_locus; + ns->proc_name = main_program; + gfc_commit_symbols (); +} + + +/* Do whatever is necessary to accept the last statement. */ + +static void +accept_statement (gfc_statement st) +{ + switch (st) + { + case ST_IMPLICIT_NONE: + case ST_IMPLICIT: + break; + + case ST_FUNCTION: + case ST_SUBROUTINE: + case ST_MODULE: + case ST_SUBMODULE: + gfc_current_ns->proc_name = gfc_new_block; + break; + + /* If the statement is the end of a block, lay down a special code + that allows a branch to the end of the block from within the + construct. IF and SELECT are treated differently from DO + (where EXEC_NOP is added inside the loop) for two + reasons: + 1. END DO has a meaning in the sense that after a GOTO to + it, the loop counter must be increased. + 2. IF blocks and SELECT blocks can consist of multiple + parallel blocks (IF ... ELSE IF ... ELSE ... END IF). + Putting the label before the END IF would make the jump + from, say, the ELSE IF block to the END IF illegal. */ + + case ST_ENDIF: + case ST_END_SELECT: + case ST_END_CRITICAL: + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_END_NESTED_BLOCK; + add_statement (); + } + break; + + /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than + one parallel block. Thus, we add the special code to the nested block + itself, instead of the parent one. */ + case ST_END_BLOCK: + case ST_END_ASSOCIATE: + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_END_BLOCK; + add_statement (); + } + break; + + /* The end-of-program unit statements do not get the special + marker and require a statement of some sort if they are a + branch target. */ + + case ST_END_PROGRAM: + case ST_END_FUNCTION: + case ST_END_SUBROUTINE: + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_RETURN; + add_statement (); + } + else + { + new_st.op = EXEC_END_PROCEDURE; + add_statement (); + } + + break; + + case ST_ENTRY: + case_executable: + case_exec_markers: + add_statement (); + break; + + default: + break; + } + + gfc_commit_symbols (); + gfc_warning_check (); + gfc_clear_new_st (); +} + + +/* Undo anything tentative that has been built for the current statement, + except if a gfc_charlen structure has been added to current namespace's + list of gfc_charlen structure. */ + +static void +reject_statement (void) +{ + gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv); + gfc_current_ns->equiv = gfc_current_ns->old_equiv; + + gfc_reject_data (gfc_current_ns); + + gfc_new_block = NULL; + gfc_undo_symbols (); + gfc_clear_warning (); + undo_new_statement (); +} + + +/* Generic complaint about an out of order statement. We also do + whatever is necessary to clean up. */ + +static void +unexpected_statement (gfc_statement st) +{ + gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); + + reject_statement (); +} + + +/* Given the next statement seen by the matcher, make sure that it is + in proper order with the last. This subroutine is initialized by + calling it with an argument of ST_NONE. If there is a problem, we + issue an error and return false. Otherwise we return true. + + Individual parsers need to verify that the statements seen are + valid before calling here, i.e., ENTRY statements are not allowed in + INTERFACE blocks. The following diagram is taken from the standard: + + +---------------------------------------+ + | program subroutine function module | + +---------------------------------------+ + | use | + +---------------------------------------+ + | import | + +---------------------------------------+ + | | implicit none | + | +-----------+------------------+ + | | parameter | implicit | + | +-----------+------------------+ + | format | | derived type | + | entry | parameter | interface | + | | data | specification | + | | | statement func | + | +-----------+------------------+ + | | data | executable | + +--------+-----------+------------------+ + | contains | + +---------------------------------------+ + | internal module/subprogram | + +---------------------------------------+ + | end | + +---------------------------------------+ + +*/ + +enum state_order +{ + ORDER_START, + ORDER_USE, + ORDER_IMPORT, + ORDER_IMPLICIT_NONE, + ORDER_IMPLICIT, + ORDER_SPEC, + ORDER_EXEC +}; + +typedef struct +{ + enum state_order state; + gfc_statement last_statement; + locus where; +} +st_state; + +static bool +verify_st_order (st_state *p, gfc_statement st, bool silent) +{ + + switch (st) + { + case ST_NONE: + p->state = ORDER_START; + break; + + case ST_USE: + if (p->state > ORDER_USE) + goto order; + p->state = ORDER_USE; + break; + + case ST_IMPORT: + if (p->state > ORDER_IMPORT) + goto order; + p->state = ORDER_IMPORT; + break; + + case ST_IMPLICIT_NONE: + if (p->state > ORDER_IMPLICIT) + goto order; + + /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY + statement disqualifies a USE but not an IMPLICIT NONE. + Duplicate IMPLICIT NONEs are caught when the implicit types + are set. */ + + p->state = ORDER_IMPLICIT_NONE; + break; + + case ST_IMPLICIT: + if (p->state > ORDER_IMPLICIT) + goto order; + p->state = ORDER_IMPLICIT; + break; + + case ST_FORMAT: + case ST_ENTRY: + if (p->state < ORDER_IMPLICIT_NONE) + p->state = ORDER_IMPLICIT_NONE; + break; + + case ST_PARAMETER: + if (p->state >= ORDER_EXEC) + goto order; + if (p->state < ORDER_IMPLICIT) + p->state = ORDER_IMPLICIT; + break; + + case ST_DATA: + if (p->state < ORDER_SPEC) + p->state = ORDER_SPEC; + break; + + case ST_PUBLIC: + case ST_PRIVATE: + case ST_STRUCTURE_DECL: + case ST_DERIVED_DECL: + case_decl: + if (p->state >= ORDER_EXEC) + goto order; + if (p->state < ORDER_SPEC) + p->state = ORDER_SPEC; + break; + + case_omp_decl: + /* The OpenMP/OpenACC directives have to be somewhere in the specification + part, but there are no further requirements on their ordering. + Thus don't adjust p->state, just ignore them. */ + if (p->state >= ORDER_EXEC) + goto order; + break; + + case_executable: + case_exec_markers: + if (p->state < ORDER_EXEC) + p->state = ORDER_EXEC; + break; + + default: + return false; + } + + /* All is well, record the statement in case we need it next time. */ + p->where = gfc_current_locus; + p->last_statement = st; + return true; + +order: + if (!silent) + gfc_error ("%s statement at %C cannot follow %s statement at %L", + gfc_ascii_statement (st), + gfc_ascii_statement (p->last_statement), &p->where); + + return false; +} + + +/* Handle an unexpected end of file. This is a show-stopper... */ + +static void unexpected_eof (void) ATTRIBUTE_NORETURN; + +static void +unexpected_eof (void) +{ + gfc_state_data *p; + + gfc_error ("Unexpected end of file in %qs", gfc_source_file); + + /* Memory cleanup. Move to "second to last". */ + for (p = gfc_state_stack; p && p->previous && p->previous->previous; + p = p->previous); + + gfc_current_ns->code = (p && p->previous) ? p->head : NULL; + gfc_done_2 (); + + longjmp (eof_buf, 1); + + /* Avoids build error on systems where longjmp is not declared noreturn. */ + gcc_unreachable (); +} + + +/* Parse the CONTAINS section of a derived type definition. */ + +gfc_access gfc_typebound_default_access; + +static bool +parse_derived_contains (void) +{ + gfc_state_data s; + bool seen_private = false; + bool seen_comps = false; + bool error_flag = false; + bool to_finish; + + gcc_assert (gfc_current_state () == COMP_DERIVED); + gcc_assert (gfc_current_block ()); + + /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS + section. */ + if (gfc_current_block ()->attr.sequence) + gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS" + " section at %C", gfc_current_block ()->name); + if (gfc_current_block ()->attr.is_bind_c) + gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS" + " section at %C", gfc_current_block ()->name); + + accept_statement (ST_CONTAINS); + push_state (&s, COMP_DERIVED_CONTAINS, NULL); + + gfc_typebound_default_access = ACCESS_PUBLIC; + + to_finish = false; + while (!to_finish) + { + gfc_statement st; + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + break; + + case ST_DATA_DECL: + gfc_error ("Components in TYPE at %C must precede CONTAINS"); + goto error; + + case ST_PROCEDURE: + if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C")) + goto error; + + accept_statement (ST_PROCEDURE); + seen_comps = true; + break; + + case ST_GENERIC: + if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C")) + goto error; + + accept_statement (ST_GENERIC); + seen_comps = true; + break; + + case ST_FINAL: + if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration" + " at %C")) + goto error; + + accept_statement (ST_FINAL); + seen_comps = true; + break; + + case ST_END_TYPE: + to_finish = true; + + if (!seen_comps + && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition " + "at %C with empty CONTAINS section"))) + goto error; + + /* ST_END_TYPE is accepted by parse_derived after return. */ + break; + + case ST_PRIVATE: + if (!gfc_find_state (COMP_MODULE)) + { + gfc_error ("PRIVATE statement in TYPE at %C must be inside " + "a MODULE"); + goto error; + } + + if (seen_comps) + { + gfc_error ("PRIVATE statement at %C must precede procedure" + " bindings"); + goto error; + } + + if (seen_private) + { + gfc_error ("Duplicate PRIVATE statement at %C"); + goto error; + } + + accept_statement (ST_PRIVATE); + gfc_typebound_default_access = ACCESS_PRIVATE; + seen_private = true; + break; + + case ST_SEQUENCE: + gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); + goto error; + + case ST_CONTAINS: + gfc_error ("Already inside a CONTAINS block at %C"); + goto error; + + default: + unexpected_statement (st); + break; + } + + continue; + +error: + error_flag = true; + reject_statement (); + } + + pop_state (); + gcc_assert (gfc_current_state () == COMP_DERIVED); + + return error_flag; +} + + +/* Set attributes for the parent symbol based on the attributes of a component + and raise errors if conflicting attributes are found for the component. */ + +static void +check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp, + gfc_component **eventp) +{ + bool coarray, lock_type, event_type, allocatable, pointer; + coarray = lock_type = event_type = allocatable = pointer = false; + gfc_component *lock_comp = NULL, *event_comp = NULL; + + if (lockp) lock_comp = *lockp; + if (eventp) event_comp = *eventp; + + /* Look for allocatable components. */ + if (c->attr.allocatable + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.allocatable) + || (c->ts.type == BT_DERIVED && !c->attr.pointer + && c->ts.u.derived->attr.alloc_comp)) + { + allocatable = true; + sym->attr.alloc_comp = 1; + } + + /* Look for pointer components. */ + if (c->attr.pointer + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.class_pointer) + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) + { + pointer = true; + sym->attr.pointer_comp = 1; + } + + /* Look for procedure pointer components. */ + if (c->attr.proc_pointer + || (c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.proc_pointer_comp)) + sym->attr.proc_pointer_comp = 1; + + /* Looking for coarray components. */ + if (c->attr.codimension + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->attr.codimension)) + { + coarray = true; + sym->attr.coarray_comp = 1; + } + + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp + && !c->attr.pointer) + { + coarray = true; + sym->attr.coarray_comp = 1; + } + + /* Looking for lock_type components. */ + if ((c->ts.type == BT_DERIVED + && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && CLASS_DATA (c)->ts.u.derived->intmod_sym_id + == ISOFORTRAN_LOCK_TYPE) + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp + && !allocatable && !pointer)) + { + lock_type = 1; + lock_comp = c; + sym->attr.lock_comp = 1; + } + + /* Looking for event_type components. */ + if ((c->ts.type == BT_DERIVED + && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + || (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && CLASS_DATA (c)->ts.u.derived->intmod_sym_id + == ISOFORTRAN_EVENT_TYPE) + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp + && !allocatable && !pointer)) + { + event_type = 1; + event_comp = c; + sym->attr.event_comp = 1; + } + + /* Check for F2008, C1302 - and recall that pointers may not be coarrays + (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7), + unless there are nondirect [allocatable or pointer] components + involved (cf. 1.3.33.1 and 1.3.33.3). */ + + if (pointer && !coarray && lock_type) + gfc_error ("Component %s at %L of type LOCK_TYPE must have a " + "codimension or be a subcomponent of a coarray, " + "which is not possible as the component has the " + "pointer attribute", c->name, &c->loc); + else if (pointer && !coarray && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.lock_comp) + gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " + "of type LOCK_TYPE, which must have a codimension or be a " + "subcomponent of a coarray", c->name, &c->loc); + + if (lock_type && allocatable && !coarray) + gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have " + "a codimension", c->name, &c->loc); + else if (lock_type && allocatable && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.lock_comp) + gfc_error ("Allocatable component %s at %L must have a codimension as " + "it has a noncoarray subcomponent of type LOCK_TYPE", + c->name, &c->loc); + + if (sym->attr.coarray_comp && !coarray && lock_type) + gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " + "subcomponent of type LOCK_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as already a coarray " + "subcomponent exists)", c->name, &c->loc, sym->name); + + if (sym->attr.lock_comp && coarray && !lock_type) + gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " + "subcomponent of type LOCK_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as %s at %L has a codimension or a " + "coarray subcomponent)", lock_comp->name, &lock_comp->loc, + sym->name, c->name, &c->loc); + + /* Similarly for EVENT TYPE. */ + + if (pointer && !coarray && event_type) + gfc_error ("Component %s at %L of type EVENT_TYPE must have a " + "codimension or be a subcomponent of a coarray, " + "which is not possible as the component has the " + "pointer attribute", c->name, &c->loc); + else if (pointer && !coarray && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.event_comp) + gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " + "of type EVENT_TYPE, which must have a codimension or be a " + "subcomponent of a coarray", c->name, &c->loc); + + if (event_type && allocatable && !coarray) + gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have " + "a codimension", c->name, &c->loc); + else if (event_type && allocatable && c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.event_comp) + gfc_error ("Allocatable component %s at %L must have a codimension as " + "it has a noncoarray subcomponent of type EVENT_TYPE", + c->name, &c->loc); + + if (sym->attr.coarray_comp && !coarray && event_type) + gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " + "subcomponent of type EVENT_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as already a coarray " + "subcomponent exists)", c->name, &c->loc, sym->name); + + if (sym->attr.event_comp && coarray && !event_type) + gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " + "subcomponent of type EVENT_TYPE must have a codimension or " + "be a subcomponent of a coarray. (Variables of type %s may " + "not have a codimension as %s at %L has a codimension or a " + "coarray subcomponent)", event_comp->name, &event_comp->loc, + sym->name, c->name, &c->loc); + + /* Look for private components. */ + if (sym->component_access == ACCESS_PRIVATE + || c->attr.access == ACCESS_PRIVATE + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp)) + sym->attr.private_comp = 1; + + if (lockp) *lockp = lock_comp; + if (eventp) *eventp = event_comp; +} + + +static void parse_struct_map (gfc_statement); + +/* Parse a union component definition within a structure definition. */ + +static void +parse_union (void) +{ + int compiling; + gfc_statement st; + gfc_state_data s; + gfc_component *c, *lock_comp = NULL, *event_comp = NULL; + gfc_symbol *un; + + accept_statement(ST_UNION); + push_state (&s, COMP_UNION, gfc_new_block); + un = gfc_new_block; + + compiling = 1; + + while (compiling) + { + st = next_statement (); + /* Only MAP declarations valid within a union. */ + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_MAP: + accept_statement (ST_MAP); + parse_struct_map (ST_MAP); + /* Add a component to the union for each map. */ + if (!gfc_add_component (un, gfc_new_block->name, &c)) + { + gfc_internal_error ("failed to create map component '%s'", + gfc_new_block->name); + reject_statement (); + return; + } + c->ts.type = BT_DERIVED; + c->ts.u.derived = gfc_new_block; + /* Normally components get their initialization expressions when they + are created in decl.c (build_struct) so we can look through the + flat component list for initializers during resolution. Unions and + maps create components along with their type definitions so we + have to generate initializers here. */ + c->initializer = gfc_default_initializer (&c->ts); + break; + + case ST_END_UNION: + compiling = 0; + accept_statement (ST_END_UNION); + break; + + default: + unexpected_statement (st); + break; + } + } + + for (c = un->components; c; c = c->next) + check_component (un, c, &lock_comp, &event_comp); + + /* Add the union as a component in its parent structure. */ + pop_state (); + if (!gfc_add_component (gfc_current_block (), un->name, &c)) + { + gfc_internal_error ("failed to create union component '%s'", un->name); + reject_statement (); + return; + } + c->ts.type = BT_UNION; + c->ts.u.derived = un; + c->initializer = gfc_default_initializer (&c->ts); + + un->attr.zero_comp = un->components == NULL; +} + + +/* Parse a STRUCTURE or MAP. */ + +static void +parse_struct_map (gfc_statement block) +{ + int compiling_type; + gfc_statement st; + gfc_state_data s; + gfc_symbol *sym; + gfc_component *c, *lock_comp = NULL, *event_comp = NULL; + gfc_compile_state comp; + gfc_statement ends; + + if (block == ST_STRUCTURE_DECL) + { + comp = COMP_STRUCTURE; + ends = ST_END_STRUCTURE; + } + else + { + gcc_assert (block == ST_MAP); + comp = COMP_MAP; + ends = ST_END_MAP; + } + + accept_statement(block); + push_state (&s, comp, gfc_new_block); + + gfc_new_block->component_access = ACCESS_PUBLIC; + compiling_type = 1; + + while (compiling_type) + { + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + /* Nested structure declarations will be captured as ST_DATA_DECL. */ + case ST_STRUCTURE_DECL: + /* Let a more specific error make it to decode_statement(). */ + if (gfc_error_check () == 0) + gfc_error ("Syntax error in nested structure declaration at %C"); + reject_statement (); + /* Skip the rest of this statement. */ + gfc_error_recovery (); + break; + + case ST_UNION: + accept_statement (ST_UNION); + parse_union (); + break; + + case ST_DATA_DECL: + /* The data declaration was a nested/ad-hoc STRUCTURE field. */ + accept_statement (ST_DATA_DECL); + if (gfc_new_block && gfc_new_block != gfc_current_block () + && gfc_new_block->attr.flavor == FL_STRUCT) + parse_struct_map (ST_STRUCTURE_DECL); + break; + + case ST_END_STRUCTURE: + case ST_END_MAP: + if (st == ends) + { + accept_statement (st); + compiling_type = 0; + } + else + unexpected_statement (st); + break; + + default: + unexpected_statement (st); + break; + } + } + + /* Validate each component. */ + sym = gfc_current_block (); + for (c = sym->components; c; c = c->next) + check_component (sym, c, &lock_comp, &event_comp); + + sym->attr.zero_comp = (sym->components == NULL); + + /* Allow parse_union to find this structure to add to its list of maps. */ + if (block == ST_MAP) + gfc_new_block = gfc_current_block (); + + pop_state (); +} + + +/* Parse a derived type. */ + +static void +parse_derived (void) +{ + int compiling_type, seen_private, seen_sequence, seen_component; + gfc_statement st; + gfc_state_data s; + gfc_symbol *sym; + gfc_component *c, *lock_comp = NULL, *event_comp = NULL; + + accept_statement (ST_DERIVED_DECL); + push_state (&s, COMP_DERIVED, gfc_new_block); + + gfc_new_block->component_access = ACCESS_PUBLIC; + seen_private = 0; + seen_sequence = 0; + seen_component = 0; + + compiling_type = 1; + + while (compiling_type) + { + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_DATA_DECL: + case ST_PROCEDURE: + accept_statement (st); + seen_component = 1; + break; + + case ST_FINAL: + gfc_error ("FINAL declaration at %C must be inside CONTAINS"); + break; + + case ST_END_TYPE: +endType: + compiling_type = 0; + + if (!seen_component) + gfc_notify_std (GFC_STD_F2003, "Derived type " + "definition at %C without components"); + + accept_statement (ST_END_TYPE); + break; + + case ST_PRIVATE: + if (!gfc_find_state (COMP_MODULE)) + { + gfc_error ("PRIVATE statement in TYPE at %C must be inside " + "a MODULE"); + break; + } + + if (seen_component) + { + gfc_error ("PRIVATE statement at %C must precede " + "structure components"); + break; + } + + if (seen_private) + gfc_error ("Duplicate PRIVATE statement at %C"); + + s.sym->component_access = ACCESS_PRIVATE; + + accept_statement (ST_PRIVATE); + seen_private = 1; + break; + + case ST_SEQUENCE: + if (seen_component) + { + gfc_error ("SEQUENCE statement at %C must precede " + "structure components"); + break; + } + + if (gfc_current_block ()->attr.sequence) + gfc_warning (0, "SEQUENCE attribute at %C already specified in " + "TYPE statement"); + + if (seen_sequence) + { + gfc_error ("Duplicate SEQUENCE statement at %C"); + } + + seen_sequence = 1; + gfc_add_sequence (&gfc_current_block ()->attr, + gfc_current_block ()->name, NULL); + break; + + case ST_CONTAINS: + gfc_notify_std (GFC_STD_F2003, + "CONTAINS block in derived type" + " definition at %C"); + + accept_statement (ST_CONTAINS); + parse_derived_contains (); + goto endType; + + default: + unexpected_statement (st); + break; + } + } + + /* need to verify that all fields of the derived type are + * interoperable with C if the type is declared to be bind(c) + */ + sym = gfc_current_block (); + for (c = sym->components; c; c = c->next) + check_component (sym, c, &lock_comp, &event_comp); + + if (!seen_component) + sym->attr.zero_comp = 1; + + pop_state (); +} + + +/* Parse an ENUM. */ + +static void +parse_enum (void) +{ + gfc_statement st; + int compiling_enum; + gfc_state_data s; + int seen_enumerator = 0; + + push_state (&s, COMP_ENUM, gfc_new_block); + + compiling_enum = 1; + + while (compiling_enum) + { + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + break; + + case ST_ENUMERATOR: + seen_enumerator = 1; + accept_statement (st); + break; + + case ST_END_ENUM: + compiling_enum = 0; + if (!seen_enumerator) + gfc_error ("ENUM declaration at %C has no ENUMERATORS"); + accept_statement (st); + break; + + default: + gfc_free_enum_history (); + unexpected_statement (st); + break; + } + } + pop_state (); +} + + +/* Parse an interface. We must be able to deal with the possibility + of recursive interfaces. The parse_spec() subroutine is mutually + recursive with parse_interface(). */ + +static gfc_statement parse_spec (gfc_statement); + +static void +parse_interface (void) +{ + gfc_compile_state new_state = COMP_NONE, current_state; + gfc_symbol *prog_unit, *sym; + gfc_interface_info save; + gfc_state_data s1, s2; + gfc_statement st; + + accept_statement (ST_INTERFACE); + + current_interface.ns = gfc_current_ns; + save = current_interface; + + sym = (current_interface.type == INTERFACE_GENERIC + || current_interface.type == INTERFACE_USER_OP) + ? gfc_new_block : NULL; + + push_state (&s1, COMP_INTERFACE, sym); + current_state = COMP_NONE; + +loop: + gfc_current_ns = gfc_get_namespace (current_interface.ns, 0); + + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_SUBROUTINE: + case ST_FUNCTION: + if (st == ST_SUBROUTINE) + new_state = COMP_SUBROUTINE; + else if (st == ST_FUNCTION) + new_state = COMP_FUNCTION; + if (gfc_new_block->attr.pointer) + { + gfc_new_block->attr.pointer = 0; + gfc_new_block->attr.proc_pointer = 1; + } + if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, + gfc_new_block->formal, NULL)) + { + reject_statement (); + gfc_free_namespace (gfc_current_ns); + goto loop; + } + /* F2008 C1210 forbids the IMPORT statement in module procedure + interface bodies and the flag is set to import symbols. */ + if (gfc_new_block->attr.module_procedure) + gfc_current_ns->has_import_set = 1; + break; + + case ST_PROCEDURE: + case ST_MODULE_PROC: /* The module procedure matcher makes + sure the context is correct. */ + accept_statement (st); + gfc_free_namespace (gfc_current_ns); + goto loop; + + case ST_END_INTERFACE: + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = current_interface.ns; + goto done; + + default: + gfc_error ("Unexpected %s statement in INTERFACE block at %C", + gfc_ascii_statement (st)); + reject_statement (); + gfc_free_namespace (gfc_current_ns); + goto loop; + } + + + /* Make sure that the generic name has the right attribute. */ + if (current_interface.type == INTERFACE_GENERIC + && current_state == COMP_NONE) + { + if (new_state == COMP_FUNCTION && sym) + gfc_add_function (&sym->attr, sym->name, NULL); + else if (new_state == COMP_SUBROUTINE && sym) + gfc_add_subroutine (&sym->attr, sym->name, NULL); + + current_state = new_state; + } + + if (current_interface.type == INTERFACE_ABSTRACT) + { + gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus); + if (gfc_is_intrinsic_typename (gfc_new_block->name)) + gfc_error ("Name %qs of ABSTRACT INTERFACE at %C " + "cannot be the same as an intrinsic type", + gfc_new_block->name); + } + + push_state (&s2, new_state, gfc_new_block); + accept_statement (st); + prog_unit = gfc_new_block; + prog_unit->formal_ns = gfc_current_ns; + if (prog_unit == prog_unit->formal_ns->proc_name + && prog_unit->ns != prog_unit->formal_ns) + prog_unit->refs++; + +decl: + /* Read data declaration statements. */ + st = parse_spec (ST_NONE); + in_specification_block = true; + + /* Since the interface block does not permit an IMPLICIT statement, + the default type for the function or the result must be taken + from the formal namespace. */ + if (new_state == COMP_FUNCTION) + { + if (prog_unit->result == prog_unit + && prog_unit->ts.type == BT_UNKNOWN) + gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns); + else if (prog_unit->result != prog_unit + && prog_unit->result->ts.type == BT_UNKNOWN) + gfc_set_default_type (prog_unit->result, 1, + prog_unit->formal_ns); + } + + if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION) + { + gfc_error ("Unexpected %s statement at %C in INTERFACE body", + gfc_ascii_statement (st)); + reject_statement (); + goto decl; + } + + /* Add EXTERNAL attribute to function or subroutine. */ + if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy) + gfc_add_external (&prog_unit->attr, &gfc_current_locus); + + current_interface = save; + gfc_add_interface (prog_unit); + pop_state (); + + if (current_interface.ns + && current_interface.ns->proc_name + && strcmp (current_interface.ns->proc_name->name, + prog_unit->name) == 0) + gfc_error ("INTERFACE procedure %qs at %L has the same name as the " + "enclosing procedure", prog_unit->name, + ¤t_interface.ns->proc_name->declared_at); + + goto loop; + +done: + pop_state (); +} + + +/* Associate function characteristics by going back to the function + declaration and rematching the prefix. */ + +static match +match_deferred_characteristics (gfc_typespec * ts) +{ + locus loc; + match m = MATCH_ERROR; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + loc = gfc_current_locus; + + gfc_current_locus = gfc_current_block ()->declared_at; + + gfc_clear_error (); + gfc_buffer_error (true); + m = gfc_match_prefix (ts); + gfc_buffer_error (false); + + if (ts->type == BT_DERIVED) + { + ts->kind = 0; + + if (!ts->u.derived) + m = MATCH_ERROR; + } + + /* Only permit one go at the characteristic association. */ + if (ts->kind == -1) + ts->kind = 0; + + /* Set the function locus correctly. If we have not found the + function name, there is an error. */ + if (m == MATCH_YES + && gfc_match ("function% %n", name) == MATCH_YES + && strcmp (name, gfc_current_block ()->name) == 0) + { + gfc_current_block ()->declared_at = gfc_current_locus; + gfc_commit_symbols (); + } + else + { + gfc_error_check (); + gfc_undo_symbols (); + } + + gfc_current_locus =loc; + return m; +} + + +/* Check specification-expressions in the function result of the currently + parsed block and ensure they are typed (give an IMPLICIT type if necessary). + For return types specified in a FUNCTION prefix, the IMPLICIT rules of the + scope are not yet parsed so this has to be delayed up to parse_spec. */ + +static void +check_function_result_typed (void) +{ + gfc_typespec ts; + + gcc_assert (gfc_current_state () == COMP_FUNCTION); + + if (!gfc_current_ns->proc_name->result) return; + + ts = gfc_current_ns->proc_name->result->ts; + + /* Check type-parameters, at the moment only CHARACTER lengths possible. */ + /* TODO: Extend when KIND type parameters are implemented. */ + if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length) + gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true); +} + + +/* Parse a set of specification statements. Returns the statement + that doesn't fit. */ + +static gfc_statement +parse_spec (gfc_statement st) +{ + st_state ss; + bool function_result_typed = false; + bool bad_characteristic = false; + gfc_typespec *ts; + + in_specification_block = true; + + verify_st_order (&ss, ST_NONE, false); + if (st == ST_NONE) + st = next_statement (); + + /* If we are not inside a function or don't have a result specified so far, + do nothing special about it. */ + if (gfc_current_state () != COMP_FUNCTION) + function_result_typed = true; + else + { + gfc_symbol* proc = gfc_current_ns->proc_name; + gcc_assert (proc); + + if (proc->result->ts.type == BT_UNKNOWN) + function_result_typed = true; + } + +loop: + + /* If we're inside a BLOCK construct, some statements are disallowed. + Check this here. Attribute declaration statements like INTENT, OPTIONAL + or VALUE are also disallowed, but they don't have a particular ST_* + key so we have to check for them individually in their matcher routine. */ + if (gfc_current_state () == COMP_BLOCK) + switch (st) + { + case ST_IMPLICIT: + case ST_IMPLICIT_NONE: + case ST_NAMELIST: + case ST_COMMON: + case ST_EQUIVALENCE: + case ST_STATEMENT_FUNCTION: + gfc_error ("%s statement is not allowed inside of BLOCK at %C", + gfc_ascii_statement (st)); + reject_statement (); + break; + + default: + break; + } + else if (gfc_current_state () == COMP_BLOCK_DATA) + /* Fortran 2008, C1116. */ + switch (st) + { + case ST_ATTR_DECL: + case ST_COMMON: + case ST_DATA: + case ST_DATA_DECL: + case ST_DERIVED_DECL: + case ST_END_BLOCK_DATA: + case ST_EQUIVALENCE: + case ST_IMPLICIT: + case ST_IMPLICIT_NONE: + case ST_OMP_THREADPRIVATE: + case ST_PARAMETER: + case ST_STRUCTURE_DECL: + case ST_TYPE: + case ST_USE: + break; + + case ST_NONE: + break; + + default: + gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C", + gfc_ascii_statement (st)); + reject_statement (); + break; + } + + /* If we find a statement that cannot be followed by an IMPLICIT statement + (and thus we can expect to see none any further), type the function result + if it has not yet been typed. Be careful not to give the END statement + to verify_st_order! */ + if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS) + { + bool verify_now = false; + + if (st == ST_END_FUNCTION || st == ST_CONTAINS) + verify_now = true; + else + { + st_state dummyss; + verify_st_order (&dummyss, ST_NONE, false); + verify_st_order (&dummyss, st, false); + + if (!verify_st_order (&dummyss, ST_IMPLICIT, true)) + verify_now = true; + } + + if (verify_now) + { + check_function_result_typed (); + function_result_typed = true; + } + } + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_IMPLICIT_NONE: + case ST_IMPLICIT: + if (!function_result_typed) + { + check_function_result_typed (); + function_result_typed = true; + } + goto declSt; + + case ST_FORMAT: + case ST_ENTRY: + case ST_DATA: /* Not allowed in interfaces */ + if (gfc_current_state () == COMP_INTERFACE) + break; + + /* Fall through */ + + case ST_USE: + case ST_IMPORT: + case ST_PARAMETER: + case ST_PUBLIC: + case ST_PRIVATE: + case ST_STRUCTURE_DECL: + case ST_DERIVED_DECL: + case_decl: + case_omp_decl: +declSt: + if (!verify_st_order (&ss, st, false)) + { + reject_statement (); + st = next_statement (); + goto loop; + } + + switch (st) + { + case ST_INTERFACE: + parse_interface (); + break; + + case ST_STRUCTURE_DECL: + parse_struct_map (ST_STRUCTURE_DECL); + break; + + case ST_DERIVED_DECL: + parse_derived (); + break; + + case ST_PUBLIC: + case ST_PRIVATE: + if (gfc_current_state () != COMP_MODULE) + { + gfc_error ("%s statement must appear in a MODULE", + gfc_ascii_statement (st)); + reject_statement (); + break; + } + + if (gfc_current_ns->default_access != ACCESS_UNKNOWN) + { + gfc_error ("%s statement at %C follows another accessibility " + "specification", gfc_ascii_statement (st)); + reject_statement (); + break; + } + + gfc_current_ns->default_access = (st == ST_PUBLIC) + ? ACCESS_PUBLIC : ACCESS_PRIVATE; + + break; + + case ST_STATEMENT_FUNCTION: + if (gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE) + { + unexpected_statement (st); + break; + } + + default: + break; + } + + accept_statement (st); + st = next_statement (); + goto loop; + + case ST_ENUM: + accept_statement (st); + parse_enum(); + st = next_statement (); + goto loop; + + case ST_GET_FCN_CHARACTERISTICS: + /* This statement triggers the association of a function's result + characteristics. */ + ts = &gfc_current_block ()->result->ts; + if (match_deferred_characteristics (ts) != MATCH_YES) + bad_characteristic = true; + + st = next_statement (); + goto loop; + + default: + break; + } + + /* If match_deferred_characteristics failed, then there is an error. */ + if (bad_characteristic) + { + ts = &gfc_current_block ()->result->ts; + if (ts->type != BT_DERIVED) + gfc_error ("Bad kind expression for function %qs at %L", + gfc_current_block ()->name, + &gfc_current_block ()->declared_at); + else + gfc_error ("The type for function %qs at %L is not accessible", + gfc_current_block ()->name, + &gfc_current_block ()->declared_at); + + gfc_current_block ()->ts.kind = 0; + /* Keep the derived type; if it's bad, it will be discovered later. */ + if (!(ts->type == BT_DERIVED && ts->u.derived)) + ts->type = BT_UNKNOWN; + } + + in_specification_block = false; + + return st; +} + + +/* Parse a WHERE block, (not a simple WHERE statement). */ + +static void +parse_where_block (void) +{ + int seen_empty_else; + gfc_code *top, *d; + gfc_state_data s; + gfc_statement st; + + accept_statement (ST_WHERE_BLOCK); + top = gfc_state_stack->tail; + + push_state (&s, COMP_WHERE, gfc_new_block); + + d = add_statement (); + d->expr1 = top->expr1; + d->op = EXEC_WHERE; + + top->expr1 = NULL; + top->block = d; + + seen_empty_else = 0; + + do + { + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_WHERE_BLOCK: + parse_where_block (); + break; + + case ST_ASSIGNMENT: + case ST_WHERE: + accept_statement (st); + break; + + case ST_ELSEWHERE: + if (seen_empty_else) + { + gfc_error ("ELSEWHERE statement at %C follows previous " + "unmasked ELSEWHERE"); + reject_statement (); + break; + } + + if (new_st.expr1 == NULL) + seen_empty_else = 1; + + d = new_level (gfc_state_stack->head); + d->op = EXEC_WHERE; + d->expr1 = new_st.expr1; + + accept_statement (st); + + break; + + case ST_END_WHERE: + accept_statement (st); + break; + + default: + gfc_error ("Unexpected %s statement in WHERE block at %C", + gfc_ascii_statement (st)); + reject_statement (); + break; + } + } + while (st != ST_END_WHERE); + + pop_state (); +} + + +/* Parse a FORALL block (not a simple FORALL statement). */ + +static void +parse_forall_block (void) +{ + gfc_code *top, *d; + gfc_state_data s; + gfc_statement st; + + accept_statement (ST_FORALL_BLOCK); + top = gfc_state_stack->tail; + + push_state (&s, COMP_FORALL, gfc_new_block); + + d = add_statement (); + d->op = EXEC_FORALL; + top->block = d; + + do + { + st = next_statement (); + switch (st) + { + + case ST_ASSIGNMENT: + case ST_POINTER_ASSIGNMENT: + case ST_WHERE: + case ST_FORALL: + accept_statement (st); + break; + + case ST_WHERE_BLOCK: + parse_where_block (); + break; + + case ST_FORALL_BLOCK: + parse_forall_block (); + break; + + case ST_END_FORALL: + accept_statement (st); + break; + + case ST_NONE: + unexpected_eof (); + + default: + gfc_error ("Unexpected %s statement in FORALL block at %C", + gfc_ascii_statement (st)); + + reject_statement (); + break; + } + } + while (st != ST_END_FORALL); + + pop_state (); +} + + +static gfc_statement parse_executable (gfc_statement); + +/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */ + +static void +parse_if_block (void) +{ + gfc_code *top, *d; + gfc_statement st; + locus else_locus; + gfc_state_data s; + int seen_else; + + seen_else = 0; + accept_statement (ST_IF_BLOCK); + + top = gfc_state_stack->tail; + push_state (&s, COMP_IF, gfc_new_block); + + new_st.op = EXEC_IF; + d = add_statement (); + + d->expr1 = top->expr1; + top->expr1 = NULL; + top->block = d; + + do + { + st = parse_executable (ST_NONE); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_ELSEIF: + if (seen_else) + { + gfc_error ("ELSE IF statement at %C cannot follow ELSE " + "statement at %L", &else_locus); + + reject_statement (); + break; + } + + d = new_level (gfc_state_stack->head); + d->op = EXEC_IF; + d->expr1 = new_st.expr1; + + accept_statement (st); + + break; + + case ST_ELSE: + if (seen_else) + { + gfc_error ("Duplicate ELSE statements at %L and %C", + &else_locus); + reject_statement (); + break; + } + + seen_else = 1; + else_locus = gfc_current_locus; + + d = new_level (gfc_state_stack->head); + d->op = EXEC_IF; + + accept_statement (st); + + break; + + case ST_ENDIF: + break; + + default: + unexpected_statement (st); + break; + } + } + while (st != ST_ENDIF); + + pop_state (); + accept_statement (st); +} + + +/* Parse a SELECT block. */ + +static void +parse_select_block (void) +{ + gfc_statement st; + gfc_code *cp; + gfc_state_data s; + + accept_statement (ST_SELECT_CASE); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_SELECT, gfc_new_block); + + /* Make sure that the next statement is a CASE or END SELECT. */ + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + if (st == ST_END_SELECT) + { + /* Empty SELECT CASE is OK. */ + accept_statement (st); + pop_state (); + return; + } + if (st == ST_CASE) + break; + + gfc_error ("Expected a CASE or END SELECT statement following SELECT " + "CASE at %C"); + + reject_statement (); + } + + /* At this point, we've got a nonempty select block. */ + cp = new_level (cp); + *cp = new_st; + + accept_statement (st); + + do + { + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CASE: + cp = new_level (gfc_state_stack->head); + *cp = new_st; + gfc_clear_new_st (); + + accept_statement (st); + /* Fall through */ + + case ST_END_SELECT: + break; + + /* Can't have an executable statement because of + parse_executable(). */ + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_SELECT); + + pop_state (); + accept_statement (st); +} + + +/* Pop the current selector from the SELECT TYPE stack. */ + +static void +select_type_pop (void) +{ + gfc_select_type_stack *old = select_type_stack; + select_type_stack = old->prev; + free (old); +} + + +/* Parse a SELECT TYPE construct (F03:R821). */ + +static void +parse_select_type_block (void) +{ + gfc_statement st; + gfc_code *cp; + gfc_state_data s; + + gfc_current_ns = new_st.ext.block.ns; + accept_statement (ST_SELECT_TYPE); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_SELECT_TYPE, gfc_new_block); + + /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT + or END SELECT. */ + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + if (st == ST_END_SELECT) + /* Empty SELECT CASE is OK. */ + goto done; + if (st == ST_TYPE_IS || st == ST_CLASS_IS) + break; + + gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement " + "following SELECT TYPE at %C"); + + reject_statement (); + } + + /* At this point, we've got a nonempty select block. */ + cp = new_level (cp); + *cp = new_st; + + accept_statement (st); + + do + { + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_TYPE_IS: + case ST_CLASS_IS: + cp = new_level (gfc_state_stack->head); + *cp = new_st; + gfc_clear_new_st (); + + accept_statement (st); + /* Fall through */ + + case ST_END_SELECT: + break; + + /* Can't have an executable statement because of + parse_executable(). */ + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_SELECT); + +done: + pop_state (); + accept_statement (st); + gfc_current_ns = gfc_current_ns->parent; + select_type_pop (); +} + + +/* Parse a SELECT RANK construct. */ + +static void +parse_select_rank_block (void) +{ + gfc_statement st; + gfc_code *cp; + gfc_state_data s; + + gfc_current_ns = new_st.ext.block.ns; + accept_statement (ST_SELECT_RANK); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_SELECT_RANK, gfc_new_block); + + /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */ + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + if (st == ST_END_SELECT) + /* Empty SELECT CASE is OK. */ + goto done; + if (st == ST_RANK) + break; + + gfc_error ("Expected RANK or RANK DEFAULT " + "following SELECT RANK at %C"); + + reject_statement (); + } + + /* At this point, we've got a nonempty select block. */ + cp = new_level (cp); + *cp = new_st; + + accept_statement (st); + + do + { + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_RANK: + cp = new_level (gfc_state_stack->head); + *cp = new_st; + gfc_clear_new_st (); + + accept_statement (st); + /* Fall through */ + + case ST_END_SELECT: + break; + + /* Can't have an executable statement because of + parse_executable(). */ + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_SELECT); + +done: + pop_state (); + accept_statement (st); + gfc_current_ns = gfc_current_ns->parent; + select_type_pop (); +} + + +/* Given a symbol, make sure it is not an iteration variable for a DO + statement. This subroutine is called when the symbol is seen in a + context that causes it to become redefined. If the symbol is an + iterator, we generate an error message and return nonzero. */ + +int +gfc_check_do_variable (gfc_symtree *st) +{ + gfc_state_data *s; + + if (!st) + return 0; + + for (s=gfc_state_stack; s; s = s->previous) + if (s->do_variable == st) + { + gfc_error_now ("Variable %qs at %C cannot be redefined inside " + "loop beginning at %L", st->name, &s->head->loc); + return 1; + } + + return 0; +} + + +/* Checks to see if the current statement label closes an enddo. + Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues + an error) if it incorrectly closes an ENDDO. */ + +static int +check_do_closure (void) +{ + gfc_state_data *p; + + if (gfc_statement_label == NULL) + return 0; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) + break; + + if (p == NULL) + return 0; /* No loops to close */ + + if (p->ext.end_do_label == gfc_statement_label) + { + if (p == gfc_state_stack) + return 1; + + gfc_error ("End of nonblock DO statement at %C is within another block"); + return 2; + } + + /* At this point, the label doesn't terminate the innermost loop. + Make sure it doesn't terminate another one. */ + for (; p; p = p->previous) + if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) + && p->ext.end_do_label == gfc_statement_label) + { + gfc_error ("End of nonblock DO statement at %C is interwoven " + "with another DO loop"); + return 2; + } + + return 0; +} + + +/* Parse a series of contained program units. */ + +static void parse_progunit (gfc_statement); + + +/* Parse a CRITICAL block. */ + +static void +parse_critical_block (void) +{ + gfc_code *top, *d; + gfc_state_data s, *sd; + gfc_statement st; + + for (sd = gfc_state_stack; sd; sd = sd->previous) + if (sd->state == COMP_OMP_STRUCTURED_BLOCK) + gfc_error_now (is_oacc (sd) + ? G_("CRITICAL block inside of OpenACC region at %C") + : G_("CRITICAL block inside of OpenMP region at %C")); + + s.ext.end_do_label = new_st.label1; + + accept_statement (ST_CRITICAL); + top = gfc_state_stack->tail; + + push_state (&s, COMP_CRITICAL, gfc_new_block); + + d = add_statement (); + d->op = EXEC_CRITICAL; + top->block = d; + + do + { + st = parse_executable (ST_NONE); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + break; + + case ST_END_CRITICAL: + if (s.ext.end_do_label != NULL + && s.ext.end_do_label != gfc_statement_label) + gfc_error_now ("Statement label in END CRITICAL at %C does not " + "match CRITICAL label"); + + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_NOP; + add_statement (); + } + break; + + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_CRITICAL); + + pop_state (); + accept_statement (st); +} + + +/* Set up the local namespace for a BLOCK construct. */ + +gfc_namespace* +gfc_build_block_ns (gfc_namespace *parent_ns) +{ + gfc_namespace* my_ns; + static int numblock = 1; + + my_ns = gfc_get_namespace (parent_ns, 1); + my_ns->construct_entities = 1; + + /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct + code generation (so it must not be NULL). + We set its recursive argument if our container procedure is recursive, so + that local variables are accordingly placed on the stack when it + will be necessary. */ + if (gfc_new_block) + my_ns->proc_name = gfc_new_block; + else + { + bool t; + char buffer[20]; /* Enough to hold "block@2147483648\n". */ + + snprintf(buffer, sizeof(buffer), "block@%d", numblock++); + gfc_get_symbol (buffer, my_ns, &my_ns->proc_name); + t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL, + my_ns->proc_name->name, NULL); + gcc_assert (t); + gfc_commit_symbol (my_ns->proc_name); + } + + if (parent_ns->proc_name) + my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive; + + return my_ns; +} + + +/* Parse a BLOCK construct. */ + +static void +parse_block_construct (void) +{ + gfc_namespace* my_ns; + gfc_namespace* my_parent; + gfc_state_data s; + + gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + new_st.ext.block.assoc = NULL; + accept_statement (ST_BLOCK); + + push_state (&s, COMP_BLOCK, my_ns->proc_name); + gfc_current_ns = my_ns; + my_parent = my_ns->parent; + + parse_progunit (ST_NONE); + + /* Don't depend on the value of gfc_current_ns; it might have been + reset if the block had errors and was cleaned up. */ + gfc_current_ns = my_parent; + + pop_state (); +} + + +/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct + behind the scenes with compiler-generated variables. */ + +static void +parse_associate (void) +{ + gfc_namespace* my_ns; + gfc_state_data s; + gfc_statement st; + gfc_association_list* a; + + gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + gcc_assert (new_st.ext.block.assoc); + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + for (a = new_st.ext.block.assoc; a; a = a->next) + { + gfc_symbol* sym; + gfc_ref *ref; + gfc_array_ref *array_ref; + + if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) + gcc_unreachable (); + + sym = a->st->n.sym; + sym->attr.flavor = FL_VARIABLE; + sym->assoc = a; + sym->declared_at = a->where; + gfc_set_sym_referenced (sym); + + /* Initialize the typespec. It is not available in all cases, + however, as it may only be set on the target during resolution. + Still, sometimes it helps to have it right now -- especially + for parsing component references on the associate-name + in case of association to a derived-type. */ + sym->ts = a->target->ts; + + /* Check if the target expression is array valued. This cannot always + be done by looking at target.rank, because that might not have been + set yet. Therefore traverse the chain of refs, looking for the last + array ref and evaluate that. */ + array_ref = NULL; + for (ref = a->target->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + array_ref = &ref->u.ar; + if (array_ref || a->target->rank) + { + gfc_array_spec *as; + int dim, rank = 0; + if (array_ref) + { + a->rankguessed = 1; + /* Count the dimension, that have a non-scalar extend. */ + for (dim = 0; dim < array_ref->dimen; ++dim) + if (array_ref->dimen_type[dim] != DIMEN_ELEMENT + && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN + && array_ref->end[dim] == NULL + && array_ref->start[dim] != NULL)) + ++rank; + } + else + rank = a->target->rank; + /* When the rank is greater than zero then sym will be an array. */ + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + { + if ((!CLASS_DATA (sym)->as && rank != 0) + || (CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->rank != rank)) + { + /* Don't just (re-)set the attr and as in the sym.ts, + because this modifies the target's attr and as. Copy the + data and do a build_class_symbol. */ + symbol_attribute attr = CLASS_DATA (a->target)->attr; + int corank = gfc_get_corank (a->target); + gfc_typespec type; + + if (rank || corank) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = corank; + attr.dimension = rank ? 1 : 0; + attr.codimension = corank ? 1 : 0; + } + else + { + as = NULL; + attr.dimension = attr.codimension = 0; + } + attr.class_ok = 0; + type = CLASS_DATA (sym)->ts; + if (!gfc_build_class_symbol (&type, + &attr, &as)) + gcc_unreachable (); + sym->ts = type; + sym->ts.type = BT_CLASS; + sym->attr.class_ok = 1; + } + else + sym->attr.class_ok = 1; + } + else if ((!sym->as && rank != 0) + || (sym->as && sym->as->rank != rank)) + { + as = gfc_get_array_spec (); + as->type = AS_DEFERRED; + as->rank = rank; + as->corank = gfc_get_corank (a->target); + sym->as = as; + sym->attr.dimension = 1; + if (as->corank) + sym->attr.codimension = 1; + } + } + } + + accept_statement (ST_ASSOCIATE); + push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); + +loop: + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case_end: + accept_statement (st); + my_ns->code = gfc_state_stack->head; + break; + + default: + unexpected_statement (st); + goto loop; + } + + gfc_current_ns = gfc_current_ns->parent; + pop_state (); +} + + +/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are + handled inside of parse_executable(), because they aren't really + loop statements. */ + +static void +parse_do_block (void) +{ + gfc_statement st; + gfc_code *top; + gfc_state_data s; + gfc_symtree *stree; + gfc_exec_op do_op; + + do_op = new_st.op; + s.ext.end_do_label = new_st.label1; + + if (new_st.ext.iterator != NULL) + { + stree = new_st.ext.iterator->var->symtree; + if (directive_unroll != -1) + { + new_st.ext.iterator->unroll = directive_unroll; + directive_unroll = -1; + } + if (directive_ivdep) + { + new_st.ext.iterator->ivdep = directive_ivdep; + directive_ivdep = false; + } + if (directive_vector) + { + new_st.ext.iterator->vector = directive_vector; + directive_vector = false; + } + if (directive_novector) + { + new_st.ext.iterator->novector = directive_novector; + directive_novector = false; + } + } + else + stree = NULL; + + accept_statement (ST_DO); + + top = gfc_state_stack->tail; + push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO, + gfc_new_block); + + s.do_variable = stree; + + top->block = new_level (top); + top->block->op = EXEC_DO; + +loop: + st = parse_executable (ST_NONE); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_ENDDO: + if (s.ext.end_do_label != NULL + && s.ext.end_do_label != gfc_statement_label) + gfc_error_now ("Statement label in ENDDO at %C doesn't match " + "DO label"); + + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_NOP; + add_statement (); + } + break; + + case ST_IMPLIED_ENDDO: + /* If the do-stmt of this DO construct has a do-construct-name, + the corresponding end-do must be an end-do-stmt (with a matching + name, but in that case we must have seen ST_ENDDO first). + We only complain about this in pedantic mode. */ + if (gfc_current_block () != NULL) + gfc_error_now ("Named block DO at %L requires matching ENDDO name", + &gfc_current_block()->declared_at); + + break; + + default: + unexpected_statement (st); + goto loop; + } + + pop_state (); + accept_statement (st); +} + + +/* Parse the statements of OpenMP do/parallel do. */ + +static gfc_statement +parse_omp_do (gfc_statement omp_st) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (omp_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_DO) + break; + else + unexpected_statement (st); + } + + parse_do_block (); + if (gfc_statement_label != NULL + && gfc_state_stack->previous != NULL + && gfc_state_stack->previous->state == COMP_DO + && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) + { + /* In + DO 100 I=1,10 + !$OMP DO + DO J=1,10 + ... + 100 CONTINUE + there should be no !$OMP END DO. */ + pop_state (); + return ST_IMPLIED_ENDDO; + } + + check_do_closure (); + pop_state (); + + st = next_statement (); + gfc_statement omp_end_st = ST_OMP_END_DO; + switch (omp_st) + { + case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break; + case ST_OMP_DISTRIBUTE_PARALLEL_DO: + omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO; + break; + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD; + break; + case ST_OMP_DISTRIBUTE_SIMD: + omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD; + break; + case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break; + case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break; + case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break; + case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break; + case ST_OMP_PARALLEL_DO_SIMD: + omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD; + break; + case ST_OMP_PARALLEL_LOOP: + omp_end_st = ST_OMP_END_PARALLEL_LOOP; + break; + case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break; + case ST_OMP_TARGET_PARALLEL_DO: + omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO; + break; + case ST_OMP_TARGET_PARALLEL_DO_SIMD: + omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD; + break; + case ST_OMP_TARGET_PARALLEL_LOOP: + omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP; + break; + case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: + omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE; + break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO; + break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + break; + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD; + break; + case ST_OMP_TARGET_TEAMS_LOOP: + omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP; + break; + case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break; + case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break; + case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break; + case ST_OMP_MASKED_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD; + break; + case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break; + case ST_OMP_MASTER_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP; + break; + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP; + break; + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD; + break; + case ST_OMP_TEAMS_DISTRIBUTE: + omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; + break; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO; + break; + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD; + break; + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: + omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD; + break; + case ST_OMP_TEAMS_LOOP: + omp_end_st = ST_OMP_END_TEAMS_LOOP; + break; + default: gcc_unreachable (); + } + if (st == omp_end_st) + { + if (new_st.op == EXEC_OMP_END_NOWAIT) + cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; + else + gcc_assert (new_st.op == EXEC_NOP); + gfc_clear_new_st (); + gfc_commit_symbols (); + gfc_warning_check (); + st = next_statement (); + } + return st; +} + + +/* Parse the statements of OpenMP atomic directive. */ + +static gfc_statement +parse_omp_oacc_atomic (bool omp_p) +{ + gfc_statement st, st_atomic, st_end_atomic; + gfc_code *cp, *np; + gfc_state_data s; + int count; + + if (omp_p) + { + st_atomic = ST_OMP_ATOMIC; + st_end_atomic = ST_OMP_END_ATOMIC; + } + else + { + st_atomic = ST_OACC_ATOMIC; + st_end_atomic = ST_OACC_END_ATOMIC; + } + accept_statement (st_atomic); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + np->ext.omp_clauses = cp->ext.omp_clauses; + cp->ext.omp_clauses = NULL; + count = 1 + np->ext.omp_clauses->capture; + + while (count) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + else if (np->ext.omp_clauses->compare + && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK)) + { + count--; + if (st == ST_IF_BLOCK) + { + parse_if_block (); + /* With else (or elseif). */ + if (gfc_state_stack->tail->block->block) + count--; + } + accept_statement (st); + } + else if (st == ST_ASSIGNMENT + && (!np->ext.omp_clauses->compare + || np->ext.omp_clauses->capture)) + { + accept_statement (st); + count--; + } + else + unexpected_statement (st); + } + + pop_state (); + + st = next_statement (); + if (st == st_end_atomic) + { + gfc_clear_new_st (); + gfc_commit_symbols (); + gfc_warning_check (); + st = next_statement (); + } + return st; +} + + +/* Parse the statements of an OpenACC structured block. */ + +static void +parse_oacc_structured_block (gfc_statement acc_st) +{ + gfc_statement st, acc_end_st; + gfc_code *cp, *np; + gfc_state_data s, *sd; + + for (sd = gfc_state_stack; sd; sd = sd->previous) + if (sd->state == COMP_CRITICAL) + gfc_error_now ("OpenACC directive inside of CRITICAL block at %C"); + + accept_statement (acc_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + switch (acc_st) + { + case ST_OACC_PARALLEL: + acc_end_st = ST_OACC_END_PARALLEL; + break; + case ST_OACC_KERNELS: + acc_end_st = ST_OACC_END_KERNELS; + break; + case ST_OACC_SERIAL: + acc_end_st = ST_OACC_END_SERIAL; + break; + case ST_OACC_DATA: + acc_end_st = ST_OACC_END_DATA; + break; + case ST_OACC_HOST_DATA: + acc_end_st = ST_OACC_END_HOST_DATA; + break; + default: + gcc_unreachable (); + } + + do + { + st = parse_executable (ST_NONE); + if (st == ST_NONE) + unexpected_eof (); + else if (st != acc_end_st) + { + gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st)); + reject_statement (); + } + } + while (st != acc_end_st); + + gcc_assert (new_st.op == EXEC_NOP); + + gfc_clear_new_st (); + gfc_commit_symbols (); + gfc_warning_check (); + pop_state (); +} + +/* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */ + +static gfc_statement +parse_oacc_loop (gfc_statement acc_st) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s, *sd; + + for (sd = gfc_state_stack; sd; sd = sd->previous) + if (sd->state == COMP_CRITICAL) + gfc_error_now ("OpenACC directive inside of CRITICAL block at %C"); + + accept_statement (acc_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_DO) + break; + else + { + gfc_error ("Expected DO loop at %C"); + reject_statement (); + } + } + + parse_do_block (); + if (gfc_statement_label != NULL + && gfc_state_stack->previous != NULL + && gfc_state_stack->previous->state == COMP_DO + && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) + { + pop_state (); + return ST_IMPLIED_ENDDO; + } + + check_do_closure (); + pop_state (); + + st = next_statement (); + if (st == ST_OACC_END_LOOP) + gfc_warning (0, "Redundant !$ACC END LOOP at %C"); + if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) || + (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) || + (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) || + (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP)) + { + gcc_assert (new_st.op == EXEC_NOP); + gfc_clear_new_st (); + gfc_commit_symbols (); + gfc_warning_check (); + st = next_statement (); + } + return st; +} + + +/* Parse the statements of an OpenMP structured block. */ + +static gfc_statement +parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) +{ + gfc_statement st, omp_end_st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (omp_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + switch (omp_st) + { + case ST_OMP_PARALLEL: + omp_end_st = ST_OMP_END_PARALLEL; + break; + case ST_OMP_PARALLEL_MASKED: + omp_end_st = ST_OMP_END_PARALLEL_MASKED; + break; + case ST_OMP_PARALLEL_MASTER: + omp_end_st = ST_OMP_END_PARALLEL_MASTER; + break; + case ST_OMP_PARALLEL_SECTIONS: + omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; + break; + case ST_OMP_SCOPE: + omp_end_st = ST_OMP_END_SCOPE; + break; + case ST_OMP_SECTIONS: + omp_end_st = ST_OMP_END_SECTIONS; + break; + case ST_OMP_ORDERED: + omp_end_st = ST_OMP_END_ORDERED; + break; + case ST_OMP_CRITICAL: + omp_end_st = ST_OMP_END_CRITICAL; + break; + case ST_OMP_MASKED: + omp_end_st = ST_OMP_END_MASKED; + break; + case ST_OMP_MASTER: + omp_end_st = ST_OMP_END_MASTER; + break; + case ST_OMP_SINGLE: + omp_end_st = ST_OMP_END_SINGLE; + break; + case ST_OMP_TARGET: + omp_end_st = ST_OMP_END_TARGET; + break; + case ST_OMP_TARGET_DATA: + omp_end_st = ST_OMP_END_TARGET_DATA; + break; + case ST_OMP_TARGET_PARALLEL: + omp_end_st = ST_OMP_END_TARGET_PARALLEL; + break; + case ST_OMP_TARGET_TEAMS: + omp_end_st = ST_OMP_END_TARGET_TEAMS; + break; + case ST_OMP_TASK: + omp_end_st = ST_OMP_END_TASK; + break; + case ST_OMP_TASKGROUP: + omp_end_st = ST_OMP_END_TASKGROUP; + break; + case ST_OMP_TEAMS: + omp_end_st = ST_OMP_END_TEAMS; + break; + case ST_OMP_TEAMS_DISTRIBUTE: + omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE; + break; + case ST_OMP_DISTRIBUTE: + omp_end_st = ST_OMP_END_DISTRIBUTE; + break; + case ST_OMP_WORKSHARE: + omp_end_st = ST_OMP_END_WORKSHARE; + break; + case ST_OMP_PARALLEL_WORKSHARE: + omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; + break; + default: + gcc_unreachable (); + } + + bool block_construct = false; + gfc_namespace *my_ns = NULL; + gfc_namespace *my_parent = NULL; + + st = next_statement (); + + if (st == ST_BLOCK) + { + /* Adjust state to a strictly-structured block, now that we found that + the body starts with a BLOCK construct. */ + s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK; + + block_construct = true; + gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + gfc_current_ns = my_ns; + my_parent = my_ns->parent; + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + new_st.ext.block.assoc = NULL; + accept_statement (ST_BLOCK); + st = parse_spec (ST_NONE); + } + + do + { + if (workshare_stmts_only) + { + /* Inside of !$omp workshare, only + scalar assignments + array assignments + where statements and constructs + forall statements and constructs + !$omp atomic + !$omp critical + !$omp parallel + are allowed. For !$omp critical these + restrictions apply recursively. */ + bool cycle = true; + + for (;;) + { + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_ASSIGNMENT: + case ST_WHERE: + case ST_FORALL: + accept_statement (st); + break; + + case ST_WHERE_BLOCK: + parse_where_block (); + break; + + case ST_FORALL_BLOCK: + parse_forall_block (); + break; + + case ST_OMP_PARALLEL: + case ST_OMP_PARALLEL_MASKED: + case ST_OMP_PARALLEL_MASTER: + case ST_OMP_PARALLEL_SECTIONS: + st = parse_omp_structured_block (st, false); + continue; + + case ST_OMP_PARALLEL_WORKSHARE: + case ST_OMP_CRITICAL: + st = parse_omp_structured_block (st, true); + continue; + + case ST_OMP_PARALLEL_DO: + case ST_OMP_PARALLEL_DO_SIMD: + st = parse_omp_do (st); + continue; + + case ST_OMP_ATOMIC: + st = parse_omp_oacc_atomic (true); + continue; + + default: + cycle = false; + break; + } + + if (!cycle) + break; + + st = next_statement (); + } + } + else + st = parse_executable (st); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_OMP_SECTION + && (omp_st == ST_OMP_SECTIONS + || omp_st == ST_OMP_PARALLEL_SECTIONS)) + { + np = new_level (np); + np->op = cp->op; + np->block = NULL; + st = next_statement (); + } + else if (block_construct && st == ST_END_BLOCK) + { + accept_statement (st); + gfc_current_ns = my_parent; + pop_state (); + + st = next_statement (); + if (st == omp_end_st) + { + accept_statement (st); + st = next_statement (); + } + return st; + } + else if (st != omp_end_st) + { + unexpected_statement (st); + st = next_statement (); + } + } + while (st != omp_end_st); + + switch (new_st.op) + { + case EXEC_OMP_END_NOWAIT: + cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; + break; + case EXEC_OMP_END_CRITICAL: + if (((cp->ext.omp_clauses->critical_name == NULL) + ^ (new_st.ext.omp_name == NULL)) + || (new_st.ext.omp_name != NULL + && strcmp (cp->ext.omp_clauses->critical_name, + new_st.ext.omp_name) != 0)) + gfc_error ("Name after !$omp critical and !$omp end critical does " + "not match at %C"); + free (CONST_CAST (char *, new_st.ext.omp_name)); + new_st.ext.omp_name = NULL; + break; + case EXEC_OMP_END_SINGLE: + cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] + = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]; + new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL; + gfc_free_omp_clauses (new_st.ext.omp_clauses); + break; + case EXEC_NOP: + break; + default: + gcc_unreachable (); + } + + gfc_clear_new_st (); + gfc_commit_symbols (); + gfc_warning_check (); + pop_state (); + st = next_statement (); + return st; +} + + +/* Accept a series of executable statements. We return the first + statement that doesn't fit to the caller. Any block statements are + passed on to the correct handler, which usually passes the buck + right back here. */ + +static gfc_statement +parse_executable (gfc_statement st) +{ + int close_flag; + + if (st == ST_NONE) + st = next_statement (); + + for (;;) + { + close_flag = check_do_closure (); + if (close_flag) + switch (st) + { + case ST_GOTO: + case ST_END_PROGRAM: + case ST_RETURN: + case ST_EXIT: + case ST_END_FUNCTION: + case ST_CYCLE: + case ST_PAUSE: + case ST_STOP: + case ST_ERROR_STOP: + case ST_END_SUBROUTINE: + + case ST_DO: + case ST_FORALL: + case ST_WHERE: + case ST_SELECT_CASE: + gfc_error ("%s statement at %C cannot terminate a non-block " + "DO loop", gfc_ascii_statement (st)); + break; + + default: + break; + } + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_DATA: + gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the " + "first executable statement"); + /* Fall through. */ + + case ST_FORMAT: + case ST_ENTRY: + case_executable: + accept_statement (st); + if (close_flag == 1) + return ST_IMPLIED_ENDDO; + break; + + case ST_BLOCK: + parse_block_construct (); + break; + + case ST_ASSOCIATE: + parse_associate (); + break; + + case ST_IF_BLOCK: + parse_if_block (); + break; + + case ST_SELECT_CASE: + parse_select_block (); + break; + + case ST_SELECT_TYPE: + parse_select_type_block (); + break; + + case ST_SELECT_RANK: + parse_select_rank_block (); + break; + + case ST_DO: + parse_do_block (); + if (check_do_closure () == 1) + return ST_IMPLIED_ENDDO; + break; + + case ST_CRITICAL: + parse_critical_block (); + break; + + case ST_WHERE_BLOCK: + parse_where_block (); + break; + + case ST_FORALL_BLOCK: + parse_forall_block (); + break; + + case ST_OACC_PARALLEL_LOOP: + case ST_OACC_KERNELS_LOOP: + case ST_OACC_SERIAL_LOOP: + case ST_OACC_LOOP: + st = parse_oacc_loop (st); + if (st == ST_IMPLIED_ENDDO) + return st; + continue; + + case ST_OACC_PARALLEL: + case ST_OACC_KERNELS: + case ST_OACC_SERIAL: + case ST_OACC_DATA: + case ST_OACC_HOST_DATA: + parse_oacc_structured_block (st); + break; + + case ST_OMP_PARALLEL: + case ST_OMP_PARALLEL_MASKED: + case ST_OMP_PARALLEL_MASTER: + case ST_OMP_PARALLEL_SECTIONS: + case ST_OMP_ORDERED: + case ST_OMP_CRITICAL: + case ST_OMP_MASKED: + case ST_OMP_MASTER: + case ST_OMP_SCOPE: + case ST_OMP_SECTIONS: + case ST_OMP_SINGLE: + case ST_OMP_TARGET: + case ST_OMP_TARGET_DATA: + case ST_OMP_TARGET_PARALLEL: + case ST_OMP_TARGET_TEAMS: + case ST_OMP_TEAMS: + case ST_OMP_TASK: + case ST_OMP_TASKGROUP: + st = parse_omp_structured_block (st, false); + continue; + + case ST_OMP_WORKSHARE: + case ST_OMP_PARALLEL_WORKSHARE: + st = parse_omp_structured_block (st, true); + continue; + + case ST_OMP_DISTRIBUTE: + case ST_OMP_DISTRIBUTE_PARALLEL_DO: + case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case ST_OMP_DISTRIBUTE_SIMD: + case ST_OMP_DO: + case ST_OMP_DO_SIMD: + case ST_OMP_LOOP: + case ST_OMP_PARALLEL_DO: + case ST_OMP_PARALLEL_DO_SIMD: + case ST_OMP_PARALLEL_LOOP: + case ST_OMP_PARALLEL_MASKED_TASKLOOP: + case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case ST_OMP_PARALLEL_MASTER_TASKLOOP: + case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case ST_OMP_MASKED_TASKLOOP: + case ST_OMP_MASKED_TASKLOOP_SIMD: + case ST_OMP_MASTER_TASKLOOP: + case ST_OMP_MASTER_TASKLOOP_SIMD: + case ST_OMP_SIMD: + case ST_OMP_TARGET_PARALLEL_DO: + case ST_OMP_TARGET_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_PARALLEL_LOOP: + case ST_OMP_TARGET_SIMD: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case ST_OMP_TARGET_TEAMS_LOOP: + case ST_OMP_TASKLOOP: + case ST_OMP_TASKLOOP_SIMD: + case ST_OMP_TEAMS_DISTRIBUTE: + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case ST_OMP_TEAMS_DISTRIBUTE_SIMD: + case ST_OMP_TEAMS_LOOP: + st = parse_omp_do (st); + if (st == ST_IMPLIED_ENDDO) + return st; + continue; + + case ST_OACC_ATOMIC: + st = parse_omp_oacc_atomic (false); + continue; + + case ST_OMP_ATOMIC: + st = parse_omp_oacc_atomic (true); + continue; + + default: + return st; + } + + if (directive_unroll != -1) + gfc_error ("% directive not at the start of a loop at %C"); + + if (directive_ivdep) + gfc_error ("% directive not at the start of a loop at %C"); + + if (directive_vector) + gfc_error ("% directive not at the start of a loop at %C"); + + if (directive_novector) + gfc_error ("% " + "directive not at the start of a loop at %C"); + + st = next_statement (); + } +} + + +/* Fix the symbols for sibling functions. These are incorrectly added to + the child namespace as the parser didn't know about this procedure. */ + +static void +gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) +{ + gfc_namespace *ns; + gfc_symtree *st; + gfc_symbol *old_sym; + + for (ns = siblings; ns; ns = ns->sibling) + { + st = gfc_find_symtree (ns->sym_root, sym->name); + + if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) + goto fixup_contained; + + if ((st->n.sym->attr.flavor == FL_DERIVED + && sym->attr.generic && sym->attr.function) + ||(sym->attr.flavor == FL_DERIVED + && st->n.sym->attr.generic && st->n.sym->attr.function)) + goto fixup_contained; + + old_sym = st->n.sym; + if (old_sym->ns == ns + && !old_sym->attr.contained + + /* By 14.6.1.3, host association should be excluded + for the following. */ + && !(old_sym->attr.external + || (old_sym->ts.type != BT_UNKNOWN + && !old_sym->attr.implicit_type) + || old_sym->attr.flavor == FL_PARAMETER + || old_sym->attr.use_assoc + || old_sym->attr.in_common + || old_sym->attr.in_equivalence + || old_sym->attr.data + || old_sym->attr.dummy + || old_sym->attr.result + || old_sym->attr.dimension + || old_sym->attr.allocatable + || old_sym->attr.intrinsic + || old_sym->attr.generic + || old_sym->attr.flavor == FL_NAMELIST + || old_sym->attr.flavor == FL_LABEL + || old_sym->attr.proc == PROC_ST_FUNCTION)) + { + /* Replace it with the symbol from the parent namespace. */ + st->n.sym = sym; + sym->refs++; + + gfc_release_symbol (old_sym); + } + +fixup_contained: + /* Do the same for any contained procedures. */ + gfc_fixup_sibling_symbols (sym, ns->contained); + } +} + +static void +parse_contained (int module) +{ + gfc_namespace *ns, *parent_ns, *tmp; + gfc_state_data s1, s2; + gfc_statement st; + gfc_symbol *sym; + gfc_entry_list *el; + locus old_loc; + int contains_statements = 0; + int seen_error = 0; + + push_state (&s1, COMP_CONTAINS, NULL); + parent_ns = gfc_current_ns; + + do + { + gfc_current_ns = gfc_get_namespace (parent_ns, 1); + + gfc_current_ns->sibling = parent_ns->contained; + parent_ns->contained = gfc_current_ns; + + next: + /* Process the next available statement. We come here if we got an error + and rejected the last statement. */ + old_loc = gfc_current_locus; + st = next_statement (); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_FUNCTION: + case ST_SUBROUTINE: + contains_statements = 1; + accept_statement (st); + + push_state (&s2, + (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE, + gfc_new_block); + + /* For internal procedures, create/update the symbol in the + parent namespace. */ + + if (!module) + { + if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym)) + gfc_error ("Contained procedure %qs at %C is already " + "ambiguous", gfc_new_block->name); + else + { + if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, + sym->name, + &gfc_new_block->declared_at)) + { + if (st == ST_FUNCTION) + gfc_add_function (&sym->attr, sym->name, + &gfc_new_block->declared_at); + else + gfc_add_subroutine (&sym->attr, sym->name, + &gfc_new_block->declared_at); + } + } + + gfc_commit_symbols (); + } + else + sym = gfc_new_block; + + /* Mark this as a contained function, so it isn't replaced + by other module functions. */ + sym->attr.contained = 1; + + /* Set implicit_pure so that it can be reset if any of the + tests for purity fail. This is used for some optimisation + during translation. */ + if (!sym->attr.pure) + sym->attr.implicit_pure = 1; + + parse_progunit (ST_NONE); + + /* Fix up any sibling functions that refer to this one. */ + gfc_fixup_sibling_symbols (sym, gfc_current_ns); + /* Or refer to any of its alternate entry points. */ + for (el = gfc_current_ns->entries; el; el = el->next) + gfc_fixup_sibling_symbols (el->sym, gfc_current_ns); + + gfc_current_ns->code = s2.head; + gfc_current_ns = parent_ns; + + pop_state (); + break; + + /* These statements are associated with the end of the host unit. */ + case ST_END_FUNCTION: + case ST_END_MODULE: + case ST_END_SUBMODULE: + case ST_END_PROGRAM: + case ST_END_SUBROUTINE: + accept_statement (st); + gfc_current_ns->code = s1.head; + break; + + default: + gfc_error ("Unexpected %s statement in CONTAINS section at %C", + gfc_ascii_statement (st)); + reject_statement (); + seen_error = 1; + goto next; + break; + } + } + while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE + && st != ST_END_MODULE && st != ST_END_SUBMODULE + && st != ST_END_PROGRAM); + + /* The first namespace in the list is guaranteed to not have + anything (worthwhile) in it. */ + tmp = gfc_current_ns; + gfc_current_ns = parent_ns; + if (seen_error && tmp->refs > 1) + gfc_free_namespace (tmp); + + ns = gfc_current_ns->contained; + gfc_current_ns->contained = ns->sibling; + gfc_free_namespace (ns); + + pop_state (); + if (!contains_statements) + gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without " + "FUNCTION or SUBROUTINE statement at %L", &old_loc); +} + + +/* The result variable in a MODULE PROCEDURE needs to be created and + its characteristics copied from the interface since it is neither + declared in the procedure declaration nor in the specification + part. */ + +static void +get_modproc_result (void) +{ + gfc_symbol *proc; + if (gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_CONTAINS + && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) + { + proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL; + if (proc != NULL + && proc->attr.function + && proc->tlink + && proc->tlink->result + && proc->tlink->result != proc->tlink) + { + gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1); + gfc_set_sym_referenced (proc->result); + proc->result->attr.if_source = IFSRC_DECL; + gfc_commit_symbol (proc->result); + } + } +} + + +/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */ + +static void +parse_progunit (gfc_statement st) +{ + gfc_state_data *p; + int n; + + gfc_adjust_builtins (); + + if (gfc_new_block + && gfc_new_block->abr_modproc_decl + && gfc_new_block->attr.function) + get_modproc_result (); + + st = parse_spec (st); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CONTAINS: + /* This is not allowed within BLOCK! */ + if (gfc_current_state () != COMP_BLOCK) + goto contains; + break; + + case_end: + accept_statement (st); + goto done; + + default: + break; + } + + if (gfc_current_state () == COMP_FUNCTION) + gfc_check_function_type (gfc_current_ns); + +loop: + for (;;) + { + st = parse_executable (st); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CONTAINS: + /* This is not allowed within BLOCK! */ + if (gfc_current_state () != COMP_BLOCK) + goto contains; + break; + + case_end: + accept_statement (st); + goto done; + + default: + break; + } + + unexpected_statement (st); + reject_statement (); + st = next_statement (); + } + +contains: + n = 0; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_CONTAINS) + n++; + + if (gfc_find_state (COMP_MODULE) == true + || gfc_find_state (COMP_SUBMODULE) == true) + n--; + + if (n > 0) + { + gfc_error ("CONTAINS statement at %C is already in a contained " + "program unit"); + reject_statement (); + st = next_statement (); + goto loop; + } + + parse_contained (0); + +done: + gfc_current_ns->code = gfc_state_stack->head; +} + + +/* Come here to complain about a global symbol already in use as + something else. */ + +void +gfc_global_used (gfc_gsymbol *sym, locus *where) +{ + const char *name; + + if (where == NULL) + where = &gfc_current_locus; + + switch(sym->type) + { + case GSYM_PROGRAM: + name = "PROGRAM"; + break; + case GSYM_FUNCTION: + name = "FUNCTION"; + break; + case GSYM_SUBROUTINE: + name = "SUBROUTINE"; + break; + case GSYM_COMMON: + name = "COMMON"; + break; + case GSYM_BLOCK_DATA: + name = "BLOCK DATA"; + break; + case GSYM_MODULE: + name = "MODULE"; + break; + default: + name = NULL; + } + + if (name) + { + if (sym->binding_label) + gfc_error ("Global binding name %qs at %L is already being used " + "as a %s at %L", sym->binding_label, where, name, + &sym->where); + else + gfc_error ("Global name %qs at %L is already being used as " + "a %s at %L", sym->name, where, name, &sym->where); + } + else + { + if (sym->binding_label) + gfc_error ("Global binding name %qs at %L is already being used " + "at %L", sym->binding_label, where, &sym->where); + else + gfc_error ("Global name %qs at %L is already being used at %L", + sym->name, where, &sym->where); + } +} + + +/* Parse a block data program unit. */ + +static void +parse_block_data (void) +{ + gfc_statement st; + static locus blank_locus; + static int blank_block=0; + gfc_gsymbol *s; + + gfc_current_ns->proc_name = gfc_new_block; + gfc_current_ns->is_block_data = 1; + + if (gfc_new_block == NULL) + { + if (blank_block) + gfc_error ("Blank BLOCK DATA at %C conflicts with " + "prior BLOCK DATA at %L", &blank_locus); + else + { + blank_block = 1; + blank_locus = gfc_current_locus; + } + } + else + { + s = gfc_get_gsymbol (gfc_new_block->name, false); + if (s->defined + || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) + gfc_global_used (s, &gfc_new_block->declared_at); + else + { + s->type = GSYM_BLOCK_DATA; + s->where = gfc_new_block->declared_at; + s->defined = 1; + } + } + + st = parse_spec (ST_NONE); + + while (st != ST_END_BLOCK_DATA) + { + gfc_error ("Unexpected %s statement in BLOCK DATA at %C", + gfc_ascii_statement (st)); + reject_statement (); + st = next_statement (); + } +} + + +/* Following the association of the ancestor (sub)module symbols, they + must be set host rather than use associated and all must be public. + They are flagged up by 'used_in_submodule' so that they can be set + DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the + linker chokes on multiple symbol definitions. */ + +static void +set_syms_host_assoc (gfc_symbol *sym) +{ + gfc_component *c; + const char dot[2] = "."; + /* Symbols take the form module.submodule_ or module.name_. */ + char parent1[2 * GFC_MAX_SYMBOL_LEN + 2]; + char parent2[2 * GFC_MAX_SYMBOL_LEN + 2]; + + if (sym == NULL) + return; + + if (sym->attr.module_procedure) + sym->attr.external = 0; + + sym->attr.use_assoc = 0; + sym->attr.host_assoc = 1; + sym->attr.used_in_submodule =1; + + if (sym->attr.flavor == FL_DERIVED) + { + /* Derived types with PRIVATE components that are declared in + modules other than the parent module must not be changed to be + PUBLIC. The 'use-assoc' attribute must be reset so that the + test in symbol.c(gfc_find_component) works correctly. This is + not necessary for PRIVATE symbols since they are not read from + the module. */ + memset(parent1, '\0', sizeof(parent1)); + memset(parent2, '\0', sizeof(parent2)); + strcpy (parent1, gfc_new_block->name); + strcpy (parent2, sym->module); + if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0) + { + for (c = sym->components; c; c = c->next) + c->attr.access = ACCESS_PUBLIC; + } + else + { + sym->attr.use_assoc = 1; + sym->attr.host_assoc = 0; + } + } +} + +/* Parse a module subprogram. */ + +static void +parse_module (void) +{ + gfc_statement st; + gfc_gsymbol *s; + bool error; + + s = gfc_get_gsymbol (gfc_new_block->name, false); + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE)) + gfc_global_used (s, &gfc_new_block->declared_at); + else + { + s->type = GSYM_MODULE; + s->where = gfc_new_block->declared_at; + s->defined = 1; + } + + /* Something is nulling the module_list after this point. This is good + since it allows us to 'USE' the parent modules that the submodule + inherits and to set (most) of the symbols as host associated. */ + if (gfc_current_state () == COMP_SUBMODULE) + { + use_modules (); + gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc); + } + + st = parse_spec (ST_NONE); + + error = false; +loop: + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CONTAINS: + parse_contained (1); + break; + + case ST_END_MODULE: + case ST_END_SUBMODULE: + accept_statement (st); + break; + + default: + gfc_error ("Unexpected %s statement in MODULE at %C", + gfc_ascii_statement (st)); + + error = true; + reject_statement (); + st = next_statement (); + goto loop; + } + + /* Make sure not to free the namespace twice on error. */ + if (!error) + s->ns = gfc_current_ns; +} + + +/* Add a procedure name to the global symbol table. */ + +static void +add_global_procedure (bool sub) +{ + gfc_gsymbol *s; + + /* Only in Fortran 2003: For procedures with a binding label also the Fortran + name is a global identifier. */ + if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008)) + { + s = gfc_get_gsymbol (gfc_new_block->name, false); + + if (s->defined + || (s->type != GSYM_UNKNOWN + && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) + { + gfc_global_used (s, &gfc_new_block->declared_at); + /* Silence follow-up errors. */ + gfc_new_block->binding_label = NULL; + } + else + { + s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + s->sym_name = gfc_new_block->name; + s->where = gfc_new_block->declared_at; + s->defined = 1; + s->ns = gfc_current_ns; + } + } + + /* Don't add the symbol multiple times. */ + if (gfc_new_block->binding_label + && (!gfc_notification_std (GFC_STD_F2008) + || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0)) + { + s = gfc_get_gsymbol (gfc_new_block->binding_label, true); + + if (s->defined + || (s->type != GSYM_UNKNOWN + && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) + { + gfc_global_used (s, &gfc_new_block->declared_at); + /* Silence follow-up errors. */ + gfc_new_block->binding_label = NULL; + } + else + { + s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + s->sym_name = gfc_new_block->name; + s->binding_label = gfc_new_block->binding_label; + s->where = gfc_new_block->declared_at; + s->defined = 1; + s->ns = gfc_current_ns; + } + } +} + + +/* Add a program to the global symbol table. */ + +static void +add_global_program (void) +{ + gfc_gsymbol *s; + + if (gfc_new_block == NULL) + return; + s = gfc_get_gsymbol (gfc_new_block->name, false); + + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM)) + gfc_global_used (s, &gfc_new_block->declared_at); + else + { + s->type = GSYM_PROGRAM; + s->where = gfc_new_block->declared_at; + s->defined = 1; + s->ns = gfc_current_ns; + } +} + + +/* Resolve all the program units. */ +static void +resolve_all_program_units (gfc_namespace *gfc_global_ns_list) +{ + gfc_derived_types = NULL; + gfc_current_ns = gfc_global_ns_list; + for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) + { + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) + continue; /* Already resolved. */ + + if (gfc_current_ns->proc_name) + gfc_current_locus = gfc_current_ns->proc_name->declared_at; + gfc_resolve (gfc_current_ns); + gfc_current_ns->derived_types = gfc_derived_types; + gfc_derived_types = NULL; + } +} + + +static void +clean_up_modules (gfc_gsymbol *&gsym) +{ + if (gsym == NULL) + return; + + clean_up_modules (gsym->left); + clean_up_modules (gsym->right); + + if (gsym->type != GSYM_MODULE) + return; + + if (gsym->ns) + { + gfc_current_ns = gsym->ns; + gfc_derived_types = gfc_current_ns->derived_types; + gfc_done_2 (); + gsym->ns = NULL; + } + free (gsym); + gsym = NULL; +} + + +/* Translate all the program units. This could be in a different order + to resolution if there are forward references in the file. */ +static void +translate_all_program_units (gfc_namespace *gfc_global_ns_list) +{ + int errors; + + gfc_current_ns = gfc_global_ns_list; + gfc_get_errors (NULL, &errors); + + /* We first translate all modules to make sure that later parts + of the program can use the decl. Then we translate the nonmodules. */ + + for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) + { + if (!gfc_current_ns->proc_name + || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) + continue; + + gfc_current_locus = gfc_current_ns->proc_name->declared_at; + gfc_derived_types = gfc_current_ns->derived_types; + gfc_generate_module_code (gfc_current_ns); + gfc_current_ns->translated = 1; + } + + gfc_current_ns = gfc_global_ns_list; + for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) + { + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) + continue; + + gfc_current_locus = gfc_current_ns->proc_name->declared_at; + gfc_derived_types = gfc_current_ns->derived_types; + gfc_generate_code (gfc_current_ns); + gfc_current_ns->translated = 1; + } + + /* Clean up all the namespaces after translation. */ + gfc_current_ns = gfc_global_ns_list; + for (;gfc_current_ns;) + { + gfc_namespace *ns; + + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE) + { + gfc_current_ns = gfc_current_ns->sibling; + continue; + } + + ns = gfc_current_ns->sibling; + gfc_derived_types = gfc_current_ns->derived_types; + gfc_done_2 (); + gfc_current_ns = ns; + } + + clean_up_modules (gfc_gsym_root); +} + + +/* Top level parser. */ + +bool +gfc_parse_file (void) +{ + int seen_program, errors_before, errors; + gfc_state_data top, s; + gfc_statement st; + locus prog_locus; + gfc_namespace *next; + + gfc_start_source_files (); + + top.state = COMP_NONE; + top.sym = NULL; + top.previous = NULL; + top.head = top.tail = NULL; + top.do_variable = NULL; + + gfc_state_stack = ⊤ + + gfc_clear_new_st (); + + gfc_statement_label = NULL; + + if (setjmp (eof_buf)) + return false; /* Come here on unexpected EOF */ + + /* Prepare the global namespace that will contain the + program units. */ + gfc_global_ns_list = next = NULL; + + seen_program = 0; + errors_before = 0; + + /* Exit early for empty files. */ + if (gfc_at_eof ()) + goto done; + + in_specification_block = true; +loop: + gfc_init_2 (); + st = next_statement (); + switch (st) + { + case ST_NONE: + gfc_done_2 (); + goto done; + + case ST_PROGRAM: + if (seen_program) + goto duplicate_main; + seen_program = 1; + prog_locus = gfc_current_locus; + + push_state (&s, COMP_PROGRAM, gfc_new_block); + main_program_symbol (gfc_current_ns, gfc_new_block->name); + accept_statement (st); + add_global_program (); + parse_progunit (ST_NONE); + goto prog_units; + + case ST_SUBROUTINE: + add_global_procedure (true); + push_state (&s, COMP_SUBROUTINE, gfc_new_block); + accept_statement (st); + parse_progunit (ST_NONE); + goto prog_units; + + case ST_FUNCTION: + add_global_procedure (false); + push_state (&s, COMP_FUNCTION, gfc_new_block); + accept_statement (st); + parse_progunit (ST_NONE); + goto prog_units; + + case ST_BLOCK_DATA: + push_state (&s, COMP_BLOCK_DATA, gfc_new_block); + accept_statement (st); + parse_block_data (); + break; + + case ST_MODULE: + push_state (&s, COMP_MODULE, gfc_new_block); + accept_statement (st); + + gfc_get_errors (NULL, &errors_before); + parse_module (); + break; + + case ST_SUBMODULE: + push_state (&s, COMP_SUBMODULE, gfc_new_block); + accept_statement (st); + + gfc_get_errors (NULL, &errors_before); + parse_module (); + break; + + /* Anything else starts a nameless main program block. */ + default: + if (seen_program) + goto duplicate_main; + seen_program = 1; + prog_locus = gfc_current_locus; + + push_state (&s, COMP_PROGRAM, gfc_new_block); + main_program_symbol (gfc_current_ns, "MAIN__"); + parse_progunit (st); + goto prog_units; + } + + /* Handle the non-program units. */ + gfc_current_ns->code = s.head; + + gfc_resolve (gfc_current_ns); + + /* Fix the implicit_pure attribute for those procedures who should + not have it. */ + while (gfc_fix_implicit_pure (gfc_current_ns)) + ; + + /* Dump the parse tree if requested. */ + if (flag_dump_fortran_original) + gfc_dump_parse_tree (gfc_current_ns, stdout); + + gfc_get_errors (NULL, &errors); + if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE) + { + gfc_dump_module (s.sym->name, errors_before == errors); + gfc_current_ns->derived_types = gfc_derived_types; + gfc_derived_types = NULL; + goto prog_units; + } + else + { + if (errors == 0) + gfc_generate_code (gfc_current_ns); + pop_state (); + gfc_done_2 (); + } + + goto loop; + +prog_units: + /* The main program and non-contained procedures are put + in the global namespace list, so that they can be processed + later and all their interfaces resolved. */ + gfc_current_ns->code = s.head; + if (next) + { + for (; next->sibling; next = next->sibling) + ; + next->sibling = gfc_current_ns; + } + else + gfc_global_ns_list = gfc_current_ns; + + next = gfc_current_ns; + + pop_state (); + goto loop; + +done: + /* Do the resolution. */ + resolve_all_program_units (gfc_global_ns_list); + + /* Go through all top-level namespaces and unset the implicit_pure + attribute for any procedures that call something not pure or + implicit_pure. Because the a procedure marked as not implicit_pure + in one sweep may be called by another routine, we repeat this + process until there are no more changes. */ + bool changed; + do + { + changed = false; + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + { + if (gfc_fix_implicit_pure (gfc_current_ns)) + changed = true; + } + } + while (changed); + + /* Fixup for external procedures and resolve 'omp requires'. */ + int omp_requires; + omp_requires = 0; + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + { + omp_requires |= gfc_current_ns->omp_requires; + gfc_check_externals (gfc_current_ns); + } + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + gfc_check_omp_requires (gfc_current_ns, omp_requires); + + /* Populate omp_requires_mask (needed for resolving OpenMP + metadirectives and declare variant). */ + switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + { + case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: + omp_requires_mask + = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST); + break; + case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: + omp_requires_mask + = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL); + break; + case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: + omp_requires_mask + = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED); + break; + } + + /* Do the parse tree dump. */ + gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; + + for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) + if (!gfc_current_ns->proc_name + || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) + { + gfc_dump_parse_tree (gfc_current_ns, stdout); + fputs ("------------------------------------------\n\n", stdout); + } + + /* Dump C prototypes. */ + if (flag_c_prototypes || flag_c_prototypes_external) + { + fprintf (stdout, + "#include \n" + "#ifdef __cplusplus\n" + "#include \n" + "#define __GFORTRAN_FLOAT_COMPLEX std::complex\n" + "#define __GFORTRAN_DOUBLE_COMPLEX std::complex\n" + "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex\n" + "extern \"C\" {\n" + "#else\n" + "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n" + "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n" + "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n" + "#endif\n\n"); + } + + /* First dump BIND(C) prototypes. */ + if (flag_c_prototypes) + { + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + gfc_dump_c_prototypes (gfc_current_ns, stdout); + } + + /* Dump external prototypes. */ + if (flag_c_prototypes_external) + gfc_dump_external_c_prototypes (stdout); + + if (flag_c_prototypes || flag_c_prototypes_external) + fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n"); + + /* Do the translation. */ + translate_all_program_units (gfc_global_ns_list); + + /* Dump the global symbol ist. We only do this here because part + of it is generated after mangling the identifiers in + trans-decl.c. */ + + if (flag_dump_fortran_global) + gfc_dump_global_symbols (stdout); + + gfc_end_source_files (); + return true; + +duplicate_main: + /* If we see a duplicate main program, shut down. If the second + instance is an implied main program, i.e. data decls or executable + statements, we're in for lots of errors. */ + gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); + reject_statement (); + gfc_done_2 (); + return true; +} + +/* Return true if this state data represents an OpenACC region. */ +bool +is_oacc (gfc_state_data *sd) +{ + switch (sd->construct->op) + { + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_LOOP: + case EXEC_OACC_UPDATE: + case EXEC_OACC_WAIT: + case EXEC_OACC_CACHE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ATOMIC: + case EXEC_OACC_ROUTINE: + return true; + + default: + return false; + } +} diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c deleted file mode 100644 index 3f01f67..0000000 --- a/gcc/fortran/primary.c +++ /dev/null @@ -1,4175 +0,0 @@ -/* Primary expression subroutines - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "arith.h" -#include "match.h" -#include "parse.h" -#include "constructor.h" - -int matching_actual_arglist = 0; - -/* Matches a kind-parameter expression, which is either a named - symbolic constant or a nonnegative integer constant. If - successful, sets the kind value to the correct integer. - The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING - symbol like e.g. 'c_int'. */ - -static match -match_kind_param (int *kind, int *is_iso_c) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - - *is_iso_c = 0; - - m = gfc_match_small_literal_int (kind, NULL); - if (m != MATCH_NO) - return m; - - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - if (gfc_find_symbol (name, NULL, 1, &sym)) - return MATCH_ERROR; - - if (sym == NULL) - return MATCH_NO; - - *is_iso_c = sym->attr.is_iso_c; - - if (sym->attr.flavor != FL_PARAMETER) - return MATCH_NO; - - if (sym->value == NULL) - return MATCH_NO; - - if (gfc_extract_int (sym->value, kind)) - return MATCH_NO; - - gfc_set_sym_referenced (sym); - - if (*kind < 0) - return MATCH_NO; - - return MATCH_YES; -} - - -/* Get a trailing kind-specification for non-character variables. - Returns: - * the integer kind value or - * -1 if an error was generated, - * -2 if no kind was found. - The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING - symbol like e.g. 'c_int'. */ - -static int -get_kind (int *is_iso_c) -{ - int kind; - match m; - - *is_iso_c = 0; - - if (gfc_match_char ('_') != MATCH_YES) - return -2; - - m = match_kind_param (&kind, is_iso_c); - if (m == MATCH_NO) - gfc_error ("Missing kind-parameter at %C"); - - return (m == MATCH_YES) ? kind : -1; -} - - -/* Given a character and a radix, see if the character is a valid - digit in that radix. */ - -int -gfc_check_digit (char c, int radix) -{ - int r; - - switch (radix) - { - case 2: - r = ('0' <= c && c <= '1'); - break; - - case 8: - r = ('0' <= c && c <= '7'); - break; - - case 10: - r = ('0' <= c && c <= '9'); - break; - - case 16: - r = ISXDIGIT (c); - break; - - default: - gfc_internal_error ("gfc_check_digit(): bad radix"); - } - - return r; -} - - -/* Match the digit string part of an integer if signflag is not set, - the signed digit string part if signflag is set. If the buffer - is NULL, we just count characters for the resolution pass. Returns - the number of characters matched, -1 for no match. */ - -static int -match_digits (int signflag, int radix, char *buffer) -{ - locus old_loc; - int length; - char c; - - length = 0; - c = gfc_next_ascii_char (); - - if (signflag && (c == '+' || c == '-')) - { - if (buffer != NULL) - *buffer++ = c; - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - length++; - } - - if (!gfc_check_digit (c, radix)) - return -1; - - length++; - if (buffer != NULL) - *buffer++ = c; - - for (;;) - { - old_loc = gfc_current_locus; - c = gfc_next_ascii_char (); - - if (!gfc_check_digit (c, radix)) - break; - - if (buffer != NULL) - *buffer++ = c; - length++; - } - - gfc_current_locus = old_loc; - - return length; -} - -/* Convert an integer string to an expression node. */ - -static gfc_expr * -convert_integer (const char *buffer, int kind, int radix, locus *where) -{ - gfc_expr *e; - const char *t; - - e = gfc_get_constant_expr (BT_INTEGER, kind, where); - /* A leading plus is allowed, but not by mpz_set_str. */ - if (buffer[0] == '+') - t = buffer + 1; - else - t = buffer; - mpz_set_str (e->value.integer, t, radix); - - return e; -} - - -/* Convert a real string to an expression node. */ - -static gfc_expr * -convert_real (const char *buffer, int kind, locus *where) -{ - gfc_expr *e; - - e = gfc_get_constant_expr (BT_REAL, kind, where); - mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE); - - return e; -} - - -/* Convert a pair of real, constant expression nodes to a single - complex expression node. */ - -static gfc_expr * -convert_complex (gfc_expr *real, gfc_expr *imag, int kind) -{ - gfc_expr *e; - - e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where); - mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real, - GFC_MPC_RND_MODE); - - return e; -} - - -/* Match an integer (digit string and optional kind). - A sign will be accepted if signflag is set. */ - -static match -match_integer_constant (gfc_expr **result, int signflag) -{ - int length, kind, is_iso_c; - locus old_loc; - char *buffer; - gfc_expr *e; - - old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - - length = match_digits (signflag, 10, NULL); - gfc_current_locus = old_loc; - if (length == -1) - return MATCH_NO; - - buffer = (char *) alloca (length + 1); - memset (buffer, '\0', length + 1); - - gfc_gobble_whitespace (); - - match_digits (signflag, 10, buffer); - - kind = get_kind (&is_iso_c); - if (kind == -2) - kind = gfc_default_integer_kind; - if (kind == -1) - return MATCH_ERROR; - - if (kind == 4 && flag_integer4_kind == 8) - kind = 8; - - if (gfc_validate_kind (BT_INTEGER, kind, true) < 0) - { - gfc_error ("Integer kind %d at %C not available", kind); - return MATCH_ERROR; - } - - e = convert_integer (buffer, kind, 10, &gfc_current_locus); - e->ts.is_c_interop = is_iso_c; - - if (gfc_range_check (e) != ARITH_OK) - { - gfc_error ("Integer too big for its kind at %C. This check can be " - "disabled with the option %<-fno-range-check%>"); - - gfc_free_expr (e); - return MATCH_ERROR; - } - - *result = e; - return MATCH_YES; -} - - -/* Match a Hollerith constant. */ - -static match -match_hollerith_constant (gfc_expr **result) -{ - locus old_loc; - gfc_expr *e = NULL; - int num, pad; - int i; - - old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - - if (match_integer_constant (&e, 0) == MATCH_YES - && gfc_match_char ('h') == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C")) - goto cleanup; - - if (gfc_extract_int (e, &num, 1)) - goto cleanup; - if (num == 0) - { - gfc_error ("Invalid Hollerith constant: %L must contain at least " - "one character", &old_loc); - goto cleanup; - } - if (e->ts.kind != gfc_default_integer_kind) - { - gfc_error ("Invalid Hollerith constant: Integer kind at %L " - "should be default", &old_loc); - goto cleanup; - } - else - { - gfc_free_expr (e); - e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind, - &gfc_current_locus); - - /* Calculate padding needed to fit default integer memory. */ - pad = gfc_default_integer_kind - (num % gfc_default_integer_kind); - - e->representation.string = XCNEWVEC (char, num + pad + 1); - - for (i = 0; i < num; i++) - { - gfc_char_t c = gfc_next_char_literal (INSTRING_WARN); - if (! gfc_wide_fits_in_byte (c)) - { - gfc_error ("Invalid Hollerith constant at %L contains a " - "wide character", &old_loc); - goto cleanup; - } - - e->representation.string[i] = (unsigned char) c; - } - - /* Now pad with blanks and end with a null char. */ - for (i = 0; i < pad; i++) - e->representation.string[num + i] = ' '; - - e->representation.string[num + i] = '\0'; - e->representation.length = num + pad; - e->ts.u.pad = pad; - - *result = e; - return MATCH_YES; - } - } - - gfc_free_expr (e); - gfc_current_locus = old_loc; - return MATCH_NO; - -cleanup: - gfc_free_expr (e); - return MATCH_ERROR; -} - - -/* Match a binary, octal or hexadecimal constant that can be found in - a DATA statement. The standard permits b'010...', o'73...', and - z'a1...' where b, o, and z can be capital letters. This function - also accepts postfixed forms of the constants: '01...'b, '73...'o, - and 'a1...'z. An additional extension is the use of x for z. */ - -static match -match_boz_constant (gfc_expr **result) -{ - int radix, length, x_hex; - locus old_loc, start_loc; - char *buffer, post, delim; - gfc_expr *e; - - start_loc = old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - - x_hex = 0; - switch (post = gfc_next_ascii_char ()) - { - case 'b': - radix = 2; - post = 0; - break; - case 'o': - radix = 8; - post = 0; - break; - case 'x': - x_hex = 1; - /* Fall through. */ - case 'z': - radix = 16; - post = 0; - break; - case '\'': - /* Fall through. */ - case '\"': - delim = post; - post = 1; - radix = 16; /* Set to accept any valid digit string. */ - break; - default: - goto backup; - } - - /* No whitespace allowed here. */ - - if (post == 0) - delim = gfc_next_ascii_char (); - - if (delim != '\'' && delim != '\"') - goto backup; - - if (x_hex - && gfc_invalid_boz (G_("Hexadecimal constant at %L uses " - "nonstandard X instead of Z"), &gfc_current_locus)) - return MATCH_ERROR; - - old_loc = gfc_current_locus; - - length = match_digits (0, radix, NULL); - if (length == -1) - { - gfc_error ("Empty set of digits in BOZ constant at %C"); - return MATCH_ERROR; - } - - if (gfc_next_ascii_char () != delim) - { - gfc_error ("Illegal character in BOZ constant at %C"); - return MATCH_ERROR; - } - - if (post == 1) - { - switch (gfc_next_ascii_char ()) - { - case 'b': - radix = 2; - break; - case 'o': - radix = 8; - break; - case 'x': - /* Fall through. */ - case 'z': - radix = 16; - break; - default: - goto backup; - } - - if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix " - "syntax"), &gfc_current_locus)) - return MATCH_ERROR; - } - - gfc_current_locus = old_loc; - - buffer = (char *) alloca (length + 1); - memset (buffer, '\0', length + 1); - - match_digits (0, radix, buffer); - gfc_next_ascii_char (); /* Eat delimiter. */ - if (post == 1) - gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */ - - e = gfc_get_expr (); - e->expr_type = EXPR_CONSTANT; - e->ts.type = BT_BOZ; - e->where = gfc_current_locus; - e->boz.rdx = radix; - e->boz.len = length; - e->boz.str = XCNEWVEC (char, length + 1); - strncpy (e->boz.str, buffer, length); - - if (!gfc_in_match_data () - && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA " - "statement at %L", &e->where))) - return MATCH_ERROR; - - *result = e; - return MATCH_YES; - -backup: - gfc_current_locus = start_loc; - return MATCH_NO; -} - - -/* Match a real constant of some sort. Allow a signed constant if signflag - is nonzero. */ - -static match -match_real_constant (gfc_expr **result, int signflag) -{ - int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent; - locus old_loc, temp_loc; - char *p, *buffer, c, exp_char; - gfc_expr *e; - bool negate; - - old_loc = gfc_current_locus; - gfc_gobble_whitespace (); - - e = NULL; - - default_exponent = 0; - count = 0; - seen_dp = 0; - seen_digits = 0; - exp_char = ' '; - negate = FALSE; - - c = gfc_next_ascii_char (); - if (signflag && (c == '+' || c == '-')) - { - if (c == '-') - negate = TRUE; - - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - } - - /* Scan significand. */ - for (;; c = gfc_next_ascii_char (), count++) - { - if (c == '.') - { - if (seen_dp) - goto done; - - /* Check to see if "." goes with a following operator like - ".eq.". */ - temp_loc = gfc_current_locus; - c = gfc_next_ascii_char (); - - if (c == 'e' || c == 'd' || c == 'q') - { - c = gfc_next_ascii_char (); - if (c == '.') - goto done; /* Operator named .e. or .d. */ - } - - if (ISALPHA (c)) - goto done; /* Distinguish 1.e9 from 1.eq.2 */ - - gfc_current_locus = temp_loc; - seen_dp = 1; - continue; - } - - if (ISDIGIT (c)) - { - seen_digits = 1; - continue; - } - - break; - } - - if (!seen_digits || (c != 'e' && c != 'd' && c != 'q')) - goto done; - exp_char = c; - - - if (c == 'q') - { - if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in " - "real-literal-constant at %C")) - return MATCH_ERROR; - else if (warn_real_q_constant) - gfc_warning (OPT_Wreal_q_constant, - "Extension: exponent-letter % in real-literal-constant " - "at %C"); - } - - /* Scan exponent. */ - c = gfc_next_ascii_char (); - count++; - - if (c == '+' || c == '-') - { /* optional sign */ - c = gfc_next_ascii_char (); - count++; - } - - if (!ISDIGIT (c)) - { - /* With -fdec, default exponent to 0 instead of complaining. */ - if (flag_dec) - default_exponent = 1; - else - { - gfc_error ("Missing exponent in real number at %C"); - return MATCH_ERROR; - } - } - - while (ISDIGIT (c)) - { - c = gfc_next_ascii_char (); - count++; - } - -done: - /* Check that we have a numeric constant. */ - if (!seen_digits || (!seen_dp && exp_char == ' ')) - { - gfc_current_locus = old_loc; - return MATCH_NO; - } - - /* Convert the number. */ - gfc_current_locus = old_loc; - gfc_gobble_whitespace (); - - buffer = (char *) alloca (count + default_exponent + 1); - memset (buffer, '\0', count + default_exponent + 1); - - p = buffer; - c = gfc_next_ascii_char (); - if (c == '+' || c == '-') - { - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - } - - /* Hack for mpfr_set_str(). */ - for (;;) - { - if (c == 'd' || c == 'q') - *p = 'e'; - else - *p = c; - p++; - if (--count == 0) - break; - - c = gfc_next_ascii_char (); - } - if (default_exponent) - *p++ = '0'; - - kind = get_kind (&is_iso_c); - if (kind == -1) - goto cleanup; - - if (kind == 4) - { - if (flag_real4_kind == 8) - kind = 8; - if (flag_real4_kind == 10) - kind = 10; - if (flag_real4_kind == 16) - kind = 16; - } - else if (kind == 8) - { - if (flag_real8_kind == 4) - kind = 4; - if (flag_real8_kind == 10) - kind = 10; - if (flag_real8_kind == 16) - kind = 16; - } - - switch (exp_char) - { - case 'd': - if (kind != -2) - { - gfc_error ("Real number at %C has a % exponent and an explicit " - "kind"); - goto cleanup; - } - kind = gfc_default_double_kind; - break; - - case 'q': - if (kind != -2) - { - gfc_error ("Real number at %C has a % exponent and an explicit " - "kind"); - goto cleanup; - } - - /* The maximum possible real kind type parameter is 16. First, try - that for the kind, then fallback to trying kind=10 (Intel 80 bit) - extended precision. If neither value works, just given up. */ - kind = 16; - if (gfc_validate_kind (BT_REAL, kind, true) < 0) - { - kind = 10; - if (gfc_validate_kind (BT_REAL, kind, true) < 0) - { - gfc_error ("Invalid exponent-letter % in " - "real-literal-constant at %C"); - goto cleanup; - } - } - break; - - default: - if (kind == -2) - kind = gfc_default_real_kind; - - if (gfc_validate_kind (BT_REAL, kind, true) < 0) - { - gfc_error ("Invalid real kind %d at %C", kind); - goto cleanup; - } - } - - e = convert_real (buffer, kind, &gfc_current_locus); - if (negate) - mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); - e->ts.is_c_interop = is_iso_c; - - switch (gfc_range_check (e)) - { - case ARITH_OK: - break; - case ARITH_OVERFLOW: - gfc_error ("Real constant overflows its kind at %C"); - goto cleanup; - - case ARITH_UNDERFLOW: - if (warn_underflow) - gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C"); - mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_range_check() returned bad value"); - } - - /* Warn about trailing digits which suggest the user added too many - trailing digits, which may cause the appearance of higher pecision - than the kind kan support. - - This is done by replacing the rightmost non-zero digit with zero - and comparing with the original value. If these are equal, we - assume the user supplied more digits than intended (or forgot to - convert to the correct kind). - */ - - if (warn_conversion_extra) - { - mpfr_t r; - char *c1; - bool did_break; - - c1 = strchr (buffer, 'e'); - if (c1 == NULL) - c1 = buffer + strlen(buffer); - - did_break = false; - for (p = c1; p > buffer;) - { - p--; - if (*p == '.') - continue; - - if (*p != '0') - { - *p = '0'; - did_break = true; - break; - } - } - - if (did_break) - { - mpfr_init (r); - mpfr_set_str (r, buffer, 10, GFC_RND_MODE); - if (negate) - mpfr_neg (r, r, GFC_RND_MODE); - - mpfr_sub (r, r, e->value.real, GFC_RND_MODE); - - if (mpfr_cmp_ui (r, 0) == 0) - gfc_warning (OPT_Wconversion_extra, "Non-significant digits " - "in %qs number at %C, maybe incorrect KIND", - gfc_typename (&e->ts)); - - mpfr_clear (r); - } - } - - *result = e; - return MATCH_YES; - -cleanup: - gfc_free_expr (e); - return MATCH_ERROR; -} - - -/* Match a substring reference. */ - -static match -match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred) -{ - gfc_expr *start, *end; - locus old_loc; - gfc_ref *ref; - match m; - - start = NULL; - end = NULL; - - old_loc = gfc_current_locus; - - m = gfc_match_char ('('); - if (m != MATCH_YES) - return MATCH_NO; - - if (gfc_match_char (':') != MATCH_YES) - { - if (init) - m = gfc_match_init_expr (&start); - else - m = gfc_match_expr (&start); - - if (m != MATCH_YES) - { - m = MATCH_NO; - goto cleanup; - } - - m = gfc_match_char (':'); - if (m != MATCH_YES) - goto cleanup; - } - - if (gfc_match_char (')') != MATCH_YES) - { - if (init) - m = gfc_match_init_expr (&end); - else - m = gfc_match_expr (&end); - - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - m = gfc_match_char (')'); - if (m == MATCH_NO) - goto syntax; - } - - /* Optimize away the (:) reference. */ - if (start == NULL && end == NULL && !deferred) - ref = NULL; - else - { - ref = gfc_get_ref (); - - ref->type = REF_SUBSTRING; - if (start == NULL) - start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); - ref->u.ss.start = start; - if (end == NULL && cl) - end = gfc_copy_expr (cl->length); - ref->u.ss.end = end; - ref->u.ss.length = cl; - } - - *result = ref; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in SUBSTRING specification at %C"); - m = MATCH_ERROR; - -cleanup: - gfc_free_expr (start); - gfc_free_expr (end); - - gfc_current_locus = old_loc; - return m; -} - - -/* Reads the next character of a string constant, taking care to - return doubled delimiters on the input as a single instance of - the delimiter. - - Special return values for "ret" argument are: - -1 End of the string, as determined by the delimiter - -2 Unterminated string detected - - Backslash codes are also expanded at this time. */ - -static gfc_char_t -next_string_char (gfc_char_t delimiter, int *ret) -{ - locus old_locus; - gfc_char_t c; - - c = gfc_next_char_literal (INSTRING_WARN); - *ret = 0; - - if (c == '\n') - { - *ret = -2; - return 0; - } - - if (flag_backslash && c == '\\') - { - old_locus = gfc_current_locus; - - if (gfc_match_special_char (&c) == MATCH_NO) - gfc_current_locus = old_locus; - - if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) - gfc_warning (0, "Extension: backslash character at %C"); - } - - if (c != delimiter) - return c; - - old_locus = gfc_current_locus; - c = gfc_next_char_literal (NONSTRING); - - if (c == delimiter) - return c; - gfc_current_locus = old_locus; - - *ret = -1; - return 0; -} - - -/* Special case of gfc_match_name() that matches a parameter kind name - before a string constant. This takes case of the weird but legal - case of: - - kind_____'string' - - where kind____ is a parameter. gfc_match_name() will happily slurp - up all the underscores, which leads to problems. If we return - MATCH_YES, the parse pointer points to the final underscore, which - is not part of the name. We never return MATCH_ERROR-- errors in - the name will be detected later. */ - -static match -match_charkind_name (char *name) -{ - locus old_loc; - char c, peek; - int len; - - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - if (!ISALPHA (c)) - return MATCH_NO; - - *name++ = c; - len = 1; - - for (;;) - { - old_loc = gfc_current_locus; - c = gfc_next_ascii_char (); - - if (c == '_') - { - peek = gfc_peek_ascii_char (); - - if (peek == '\'' || peek == '\"') - { - gfc_current_locus = old_loc; - *name = '\0'; - return MATCH_YES; - } - } - - if (!ISALNUM (c) - && c != '_' - && (c != '$' || !flag_dollar_ok)) - break; - - *name++ = c; - if (++len > GFC_MAX_SYMBOL_LEN) - break; - } - - return MATCH_NO; -} - - -/* See if the current input matches a character constant. Lots of - contortions have to be done to match the kind parameter which comes - before the actual string. The main consideration is that we don't - want to error out too quickly. For example, we don't actually do - any validation of the kinds until we have actually seen a legal - delimiter. Using match_kind_param() generates errors too quickly. */ - -static match -match_string_constant (gfc_expr **result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1], peek; - size_t length; - int kind,save_warn_ampersand, ret; - locus old_locus, start_locus; - gfc_symbol *sym; - gfc_expr *e; - match m; - gfc_char_t c, delimiter, *p; - - old_locus = gfc_current_locus; - - gfc_gobble_whitespace (); - - c = gfc_next_char (); - if (c == '\'' || c == '"') - { - kind = gfc_default_character_kind; - start_locus = gfc_current_locus; - goto got_delim; - } - - if (gfc_wide_is_digit (c)) - { - kind = 0; - - while (gfc_wide_is_digit (c)) - { - kind = kind * 10 + c - '0'; - if (kind > 9999999) - goto no_match; - c = gfc_next_char (); - } - - } - else - { - gfc_current_locus = old_locus; - - m = match_charkind_name (name); - if (m != MATCH_YES) - goto no_match; - - if (gfc_find_symbol (name, NULL, 1, &sym) - || sym == NULL - || sym->attr.flavor != FL_PARAMETER) - goto no_match; - - kind = -1; - c = gfc_next_char (); - } - - if (c == ' ') - { - gfc_gobble_whitespace (); - c = gfc_next_char (); - } - - if (c != '_') - goto no_match; - - gfc_gobble_whitespace (); - - c = gfc_next_char (); - if (c != '\'' && c != '"') - goto no_match; - - start_locus = gfc_current_locus; - - if (kind == -1) - { - if (gfc_extract_int (sym->value, &kind, 1)) - return MATCH_ERROR; - gfc_set_sym_referenced (sym); - } - - if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0) - { - gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind); - return MATCH_ERROR; - } - -got_delim: - /* Scan the string into a block of memory by first figuring out how - long it is, allocating the structure, then re-reading it. This - isn't particularly efficient, but string constants aren't that - common in most code. TODO: Use obstacks? */ - - delimiter = c; - length = 0; - - for (;;) - { - c = next_string_char (delimiter, &ret); - if (ret == -1) - break; - if (ret == -2) - { - gfc_current_locus = start_locus; - gfc_error ("Unterminated character constant beginning at %C"); - return MATCH_ERROR; - } - - length++; - } - - /* Peek at the next character to see if it is a b, o, z, or x for the - postfixed BOZ literal constants. */ - peek = gfc_peek_ascii_char (); - if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x') - goto no_match; - - e = gfc_get_character_expr (kind, &start_locus, NULL, length); - - gfc_current_locus = start_locus; - - /* We disable the warning for the following loop as the warning has already - been printed in the loop above. */ - save_warn_ampersand = warn_ampersand; - warn_ampersand = false; - - p = e->value.character.string; - for (size_t i = 0; i < length; i++) - { - c = next_string_char (delimiter, &ret); - - if (!gfc_check_character_range (c, kind)) - { - gfc_free_expr (e); - gfc_error ("Character %qs in string at %C is not representable " - "in character kind %d", gfc_print_wide_char (c), kind); - return MATCH_ERROR; - } - - *p++ = c; - } - - *p = '\0'; /* TODO: C-style string is for development/debug purposes. */ - warn_ampersand = save_warn_ampersand; - - next_string_char (delimiter, &ret); - if (ret != -1) - gfc_internal_error ("match_string_constant(): Delimiter not found"); - - if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO) - e->expr_type = EXPR_SUBSTRING; - - /* Substrings with constant starting and ending points are eligible as - designators (F2018, section 9.1). Simplify substrings to make them usable - e.g. in data statements. */ - if (e->expr_type == EXPR_SUBSTRING - && e->ref && e->ref->type == REF_SUBSTRING - && e->ref->u.ss.start->expr_type == EXPR_CONSTANT - && (e->ref->u.ss.end == NULL - || e->ref->u.ss.end->expr_type == EXPR_CONSTANT)) - { - gfc_expr *res; - ptrdiff_t istart, iend; - size_t length; - bool equal_length = false; - - /* Basic checks on substring starting and ending indices. */ - if (!gfc_resolve_substring (e->ref, &equal_length)) - return MATCH_ERROR; - - length = e->value.character.length; - istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer); - if (e->ref->u.ss.end == NULL) - iend = length; - else - iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer); - - if (istart <= iend) - { - if (istart < 1) - { - gfc_error ("Substring start index (%ld) at %L below 1", - (long) istart, &e->ref->u.ss.start->where); - return MATCH_ERROR; - } - if (iend > (ssize_t) length) - { - gfc_error ("Substring end index (%ld) at %L exceeds string " - "length", (long) iend, &e->ref->u.ss.end->where); - return MATCH_ERROR; - } - length = iend - istart + 1; - } - else - length = 0; - - res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where); - res->value.character.string = gfc_get_wide_string (length + 1); - res->value.character.length = length; - if (length > 0) - memcpy (res->value.character.string, - &e->value.character.string[istart - 1], - length * sizeof (gfc_char_t)); - res->value.character.string[length] = '\0'; - e = res; - } - - *result = e; - - return MATCH_YES; - -no_match: - gfc_current_locus = old_locus; - return MATCH_NO; -} - - -/* Match a .true. or .false. Returns 1 if a .true. was found, - 0 if a .false. was found, and -1 otherwise. */ -static int -match_logical_constant_string (void) -{ - locus orig_loc = gfc_current_locus; - - gfc_gobble_whitespace (); - if (gfc_next_ascii_char () == '.') - { - char ch = gfc_next_ascii_char (); - if (ch == 'f') - { - if (gfc_next_ascii_char () == 'a' - && gfc_next_ascii_char () == 'l' - && gfc_next_ascii_char () == 's' - && gfc_next_ascii_char () == 'e' - && gfc_next_ascii_char () == '.') - /* Matched ".false.". */ - return 0; - } - else if (ch == 't') - { - if (gfc_next_ascii_char () == 'r' - && gfc_next_ascii_char () == 'u' - && gfc_next_ascii_char () == 'e' - && gfc_next_ascii_char () == '.') - /* Matched ".true.". */ - return 1; - } - } - gfc_current_locus = orig_loc; - return -1; -} - -/* Match a .true. or .false. */ - -static match -match_logical_constant (gfc_expr **result) -{ - gfc_expr *e; - int i, kind, is_iso_c; - - i = match_logical_constant_string (); - if (i == -1) - return MATCH_NO; - - kind = get_kind (&is_iso_c); - if (kind == -1) - return MATCH_ERROR; - if (kind == -2) - kind = gfc_default_logical_kind; - - if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0) - { - gfc_error ("Bad kind for logical constant at %C"); - return MATCH_ERROR; - } - - e = gfc_get_logical_expr (kind, &gfc_current_locus, i); - e->ts.is_c_interop = is_iso_c; - - *result = e; - return MATCH_YES; -} - - -/* Match a real or imaginary part of a complex constant that is a - symbolic constant. */ - -static match -match_sym_complex_part (gfc_expr **result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - gfc_expr *e; - match m; - - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - - if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL) - return MATCH_NO; - - if (sym->attr.flavor != FL_PARAMETER) - { - /* Give the matcher for implied do-loops a chance to run. This yields - a much saner error message for "write(*,*) (i, i=1, 6" where the - right parenthesis is missing. */ - char c; - gfc_gobble_whitespace (); - c = gfc_peek_ascii_char (); - if (c == '=' || c == ',') - { - m = MATCH_NO; - } - else - { - gfc_error ("Expected PARAMETER symbol in complex constant at %C"); - m = MATCH_ERROR; - } - return m; - } - - if (!sym->value) - goto error; - - if (!gfc_numeric_ts (&sym->value->ts)) - { - gfc_error ("Numeric PARAMETER required in complex constant at %C"); - return MATCH_ERROR; - } - - if (sym->value->rank != 0) - { - gfc_error ("Scalar PARAMETER required in complex constant at %C"); - return MATCH_ERROR; - } - - if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in " - "complex constant at %C")) - return MATCH_ERROR; - - switch (sym->value->ts.type) - { - case BT_REAL: - e = gfc_copy_expr (sym->value); - break; - - case BT_COMPLEX: - e = gfc_complex2real (sym->value, sym->value->ts.kind); - if (e == NULL) - goto error; - break; - - case BT_INTEGER: - e = gfc_int2real (sym->value, gfc_default_real_kind); - if (e == NULL) - goto error; - break; - - default: - gfc_internal_error ("gfc_match_sym_complex_part(): Bad type"); - } - - *result = e; /* e is a scalar, real, constant expression. */ - return MATCH_YES; - -error: - gfc_error ("Error converting PARAMETER constant in complex constant at %C"); - return MATCH_ERROR; -} - - -/* Match a real or imaginary part of a complex number. */ - -static match -match_complex_part (gfc_expr **result) -{ - match m; - - m = match_sym_complex_part (result); - if (m != MATCH_NO) - return m; - - m = match_real_constant (result, 1); - if (m != MATCH_NO) - return m; - - return match_integer_constant (result, 1); -} - - -/* Try to match a complex constant. */ - -static match -match_complex_constant (gfc_expr **result) -{ - gfc_expr *e, *real, *imag; - gfc_error_buffer old_error; - gfc_typespec target; - locus old_loc; - int kind; - match m; - - old_loc = gfc_current_locus; - real = imag = e = NULL; - - m = gfc_match_char ('('); - if (m != MATCH_YES) - return m; - - gfc_push_error (&old_error); - - m = match_complex_part (&real); - if (m == MATCH_NO) - { - gfc_free_error (&old_error); - goto cleanup; - } - - if (gfc_match_char (',') == MATCH_NO) - { - /* It is possible that gfc_int2real issued a warning when - converting an integer to real. Throw this away here. */ - - gfc_clear_warning (); - gfc_pop_error (&old_error); - m = MATCH_NO; - goto cleanup; - } - - /* If m is error, then something was wrong with the real part and we - assume we have a complex constant because we've seen the ','. An - ambiguous case here is the start of an iterator list of some - sort. These sort of lists are matched prior to coming here. */ - - if (m == MATCH_ERROR) - { - gfc_free_error (&old_error); - goto cleanup; - } - gfc_pop_error (&old_error); - - m = match_complex_part (&imag); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - m = gfc_match_char (')'); - if (m == MATCH_NO) - { - /* Give the matcher for implied do-loops a chance to run. This - yields a much saner error message for (/ (i, 4=i, 6) /). */ - if (gfc_peek_ascii_char () == '=') - { - m = MATCH_ERROR; - goto cleanup; - } - else - goto syntax; - } - - if (m == MATCH_ERROR) - goto cleanup; - - /* Decide on the kind of this complex number. */ - if (real->ts.type == BT_REAL) - { - if (imag->ts.type == BT_REAL) - kind = gfc_kind_max (real, imag); - else - kind = real->ts.kind; - } - else - { - if (imag->ts.type == BT_REAL) - kind = imag->ts.kind; - else - kind = gfc_default_real_kind; - } - gfc_clear_ts (&target); - target.type = BT_REAL; - target.kind = kind; - - if (real->ts.type != BT_REAL || kind != real->ts.kind) - gfc_convert_type (real, &target, 2); - if (imag->ts.type != BT_REAL || kind != imag->ts.kind) - gfc_convert_type (imag, &target, 2); - - e = convert_complex (real, imag, kind); - e->where = gfc_current_locus; - - gfc_free_expr (real); - gfc_free_expr (imag); - - *result = e; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in COMPLEX constant at %C"); - m = MATCH_ERROR; - -cleanup: - gfc_free_expr (e); - gfc_free_expr (real); - gfc_free_expr (imag); - gfc_current_locus = old_loc; - - return m; -} - - -/* Match constants in any of several forms. Returns nonzero for a - match, zero for no match. */ - -match -gfc_match_literal_constant (gfc_expr **result, int signflag) -{ - match m; - - m = match_complex_constant (result); - if (m != MATCH_NO) - return m; - - m = match_string_constant (result); - if (m != MATCH_NO) - return m; - - m = match_boz_constant (result); - if (m != MATCH_NO) - return m; - - m = match_real_constant (result, signflag); - if (m != MATCH_NO) - return m; - - m = match_hollerith_constant (result); - if (m != MATCH_NO) - return m; - - m = match_integer_constant (result, signflag); - if (m != MATCH_NO) - return m; - - m = match_logical_constant (result); - if (m != MATCH_NO) - return m; - - return MATCH_NO; -} - - -/* This checks if a symbol is the return value of an encompassing function. - Function nesting can be maximally two levels deep, but we may have - additional local namespaces like BLOCK etc. */ - -bool -gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns) -{ - if (!sym->attr.function || (sym->result != sym)) - return false; - while (ns) - { - if (ns->proc_name == sym) - return true; - ns = ns->parent; - } - return false; -} - - -/* Match a single actual argument value. An actual argument is - usually an expression, but can also be a procedure name. If the - argument is a single name, it is not always possible to tell - whether the name is a dummy procedure or not. We treat these cases - by creating an argument that looks like a dummy procedure and - fixing things later during resolution. */ - -static match -match_actual_arg (gfc_expr **result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symtree *symtree; - locus where, w; - gfc_expr *e; - char c; - - gfc_gobble_whitespace (); - where = gfc_current_locus; - - switch (gfc_match_name (name)) - { - case MATCH_ERROR: - return MATCH_ERROR; - - case MATCH_NO: - break; - - case MATCH_YES: - w = gfc_current_locus; - gfc_gobble_whitespace (); - c = gfc_next_ascii_char (); - gfc_current_locus = w; - - if (c != ',' && c != ')') - break; - - if (gfc_find_sym_tree (name, NULL, 1, &symtree)) - break; - /* Handle error elsewhere. */ - - /* Eliminate a couple of common cases where we know we don't - have a function argument. */ - if (symtree == NULL) - { - gfc_get_sym_tree (name, NULL, &symtree, false); - gfc_set_sym_referenced (symtree->n.sym); - } - else - { - gfc_symbol *sym; - - sym = symtree->n.sym; - gfc_set_sym_referenced (sym); - if (sym->attr.flavor == FL_NAMELIST) - { - gfc_error ("Namelist %qs cannot be an argument at %L", - sym->name, &where); - break; - } - if (sym->attr.flavor != FL_PROCEDURE - && sym->attr.flavor != FL_UNKNOWN) - break; - - if (sym->attr.in_common && !sym->attr.proc_pointer) - { - if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, - sym->name, &sym->declared_at)) - return MATCH_ERROR; - break; - } - - /* If the symbol is a function with itself as the result and - is being defined, then we have a variable. */ - if (sym->attr.function && sym->result == sym) - { - if (gfc_is_function_return_value (sym, gfc_current_ns)) - break; - - if (sym->attr.entry - && (sym->ns == gfc_current_ns - || sym->ns == gfc_current_ns->parent)) - { - gfc_entry_list *el = NULL; - - for (el = sym->ns->entries; el; el = el->next) - if (sym == el->sym) - break; - - if (el) - break; - } - } - } - - e = gfc_get_expr (); /* Leave it unknown for now */ - e->symtree = symtree; - e->expr_type = EXPR_VARIABLE; - e->ts.type = BT_PROCEDURE; - e->where = where; - - *result = e; - return MATCH_YES; - } - - gfc_current_locus = where; - return gfc_match_expr (result); -} - - -/* Match a keyword argument or type parameter spec list.. */ - -static match -match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_actual_arglist *a; - locus name_locus; - match m; - - name_locus = gfc_current_locus; - m = gfc_match_name (name); - - if (m != MATCH_YES) - goto cleanup; - if (gfc_match_char ('=') != MATCH_YES) - { - m = MATCH_NO; - goto cleanup; - } - - if (pdt) - { - if (gfc_match_char ('*') == MATCH_YES) - { - actual->spec_type = SPEC_ASSUMED; - goto add_name; - } - else if (gfc_match_char (':') == MATCH_YES) - { - actual->spec_type = SPEC_DEFERRED; - goto add_name; - } - else - actual->spec_type = SPEC_EXPLICIT; - } - - m = match_actual_arg (&actual->expr); - if (m != MATCH_YES) - goto cleanup; - - /* Make sure this name has not appeared yet. */ -add_name: - if (name[0] != '\0') - { - for (a = base; a; a = a->next) - if (a->name != NULL && strcmp (a->name, name) == 0) - { - gfc_error ("Keyword %qs at %C has already appeared in the " - "current argument list", name); - return MATCH_ERROR; - } - } - - actual->name = gfc_get_string ("%s", name); - return MATCH_YES; - -cleanup: - gfc_current_locus = name_locus; - return m; -} - - -/* Match an argument list function, such as %VAL. */ - -static match -match_arg_list_function (gfc_actual_arglist *result) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; - match m; - - old_locus = gfc_current_locus; - - if (gfc_match_char ('%') != MATCH_YES) - { - m = MATCH_NO; - goto cleanup; - } - - m = gfc_match ("%n (", name); - if (m != MATCH_YES) - goto cleanup; - - if (name[0] != '\0') - { - switch (name[0]) - { - case 'l': - if (startswith (name, "loc")) - { - result->name = "%LOC"; - break; - } - /* FALLTHRU */ - case 'r': - if (startswith (name, "ref")) - { - result->name = "%REF"; - break; - } - /* FALLTHRU */ - case 'v': - if (startswith (name, "val")) - { - result->name = "%VAL"; - break; - } - /* FALLTHRU */ - default: - m = MATCH_ERROR; - goto cleanup; - } - } - - if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C")) - { - m = MATCH_ERROR; - goto cleanup; - } - - m = match_actual_arg (&result->expr); - if (m != MATCH_YES) - goto cleanup; - - if (gfc_match_char (')') != MATCH_YES) - { - m = MATCH_NO; - goto cleanup; - } - - return MATCH_YES; - -cleanup: - gfc_current_locus = old_locus; - return m; -} - - -/* Matches an actual argument list of a function or subroutine, from - the opening parenthesis to the closing parenthesis. The argument - list is assumed to allow keyword arguments because we don't know if - the symbol associated with the procedure has an implicit interface - or not. We make sure keywords are unique. If sub_flag is set, - we're matching the argument list of a subroutine. - - NOTE: An alternative use for this function is to match type parameter - spec lists, which are so similar to actual argument lists that the - machinery can be reused. This use is flagged by the optional argument - 'pdt'. */ - -match -gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) -{ - gfc_actual_arglist *head, *tail; - int seen_keyword; - gfc_st_label *label; - locus old_loc; - match m; - - *argp = tail = NULL; - old_loc = gfc_current_locus; - - seen_keyword = 0; - - if (gfc_match_char ('(') == MATCH_NO) - return (sub_flag) ? MATCH_YES : MATCH_NO; - - if (gfc_match_char (')') == MATCH_YES) - return MATCH_YES; - - head = NULL; - - matching_actual_arglist++; - - for (;;) - { - if (head == NULL) - head = tail = gfc_get_actual_arglist (); - else - { - tail->next = gfc_get_actual_arglist (); - tail = tail->next; - } - - if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES) - { - m = gfc_match_st_label (&label); - if (m == MATCH_NO) - gfc_error ("Expected alternate return label at %C"); - if (m != MATCH_YES) - goto cleanup; - - if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument " - "at %C")) - goto cleanup; - - tail->label = label; - goto next; - } - - if (pdt && !seen_keyword) - { - if (gfc_match_char (':') == MATCH_YES) - { - tail->spec_type = SPEC_DEFERRED; - goto next; - } - else if (gfc_match_char ('*') == MATCH_YES) - { - tail->spec_type = SPEC_ASSUMED; - goto next; - } - else - tail->spec_type = SPEC_EXPLICIT; - - m = match_keyword_arg (tail, head, pdt); - if (m == MATCH_YES) - { - seen_keyword = 1; - goto next; - } - if (m == MATCH_ERROR) - goto cleanup; - } - - /* After the first keyword argument is seen, the following - arguments must also have keywords. */ - if (seen_keyword) - { - m = match_keyword_arg (tail, head, pdt); - - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - gfc_error ("Missing keyword name in actual argument list at %C"); - goto cleanup; - } - - } - else - { - /* Try an argument list function, like %VAL. */ - m = match_arg_list_function (tail); - if (m == MATCH_ERROR) - goto cleanup; - - /* See if we have the first keyword argument. */ - if (m == MATCH_NO) - { - m = match_keyword_arg (tail, head, false); - if (m == MATCH_YES) - seen_keyword = 1; - if (m == MATCH_ERROR) - goto cleanup; - } - - if (m == MATCH_NO) - { - /* Try for a non-keyword argument. */ - m = match_actual_arg (&tail->expr); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - } - - - next: - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - } - - *argp = head; - matching_actual_arglist--; - return MATCH_YES; - -syntax: - gfc_error ("Syntax error in argument list at %C"); - -cleanup: - gfc_free_actual_arglist (head); - gfc_current_locus = old_loc; - matching_actual_arglist--; - return MATCH_ERROR; -} - - -/* Used by gfc_match_varspec() to extend the reference list by one - element. */ - -static gfc_ref * -extend_ref (gfc_expr *primary, gfc_ref *tail) -{ - if (primary->ref == NULL) - primary->ref = tail = gfc_get_ref (); - else - { - if (tail == NULL) - gfc_internal_error ("extend_ref(): Bad tail"); - tail->next = gfc_get_ref (); - tail = tail->next; - } - - return tail; -} - - -/* Used by gfc_match_varspec() to match an inquiry reference. */ - -static bool -is_inquiry_ref (const char *name, gfc_ref **ref) -{ - inquiry_type type; - - if (name == NULL) - return false; - - if (ref) *ref = NULL; - - if (strcmp (name, "re") == 0) - type = INQUIRY_RE; - else if (strcmp (name, "im") == 0) - type = INQUIRY_IM; - else if (strcmp (name, "kind") == 0) - type = INQUIRY_KIND; - else if (strcmp (name, "len") == 0) - type = INQUIRY_LEN; - else - return false; - - if (ref) - { - *ref = gfc_get_ref (); - (*ref)->type = REF_INQUIRY; - (*ref)->u.i = type; - } - - return true; -} - - -/* Match any additional specifications associated with the current - variable like member references or substrings. If equiv_flag is - set we only match stuff that is allowed inside an EQUIVALENCE - statement. sub_flag tells whether we expect a type-bound procedure found - to be a subroutine as part of CALL or a FUNCTION. For procedure pointer - components, 'ppc_arg' determines whether the PPC may be called (with an - argument list), or whether it may just be referred to as a pointer. */ - -match -gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, - bool ppc_arg) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_ref *substring, *tail, *tmp; - gfc_component *component = NULL; - gfc_component *previous = NULL; - gfc_symbol *sym = primary->symtree->n.sym; - gfc_expr *tgt_expr = NULL; - match m; - bool unknown; - bool inquiry; - bool intrinsic; - locus old_loc; - char sep; - - tail = NULL; - - gfc_gobble_whitespace (); - - if (gfc_peek_ascii_char () == '[') - { - if ((sym->ts.type != BT_CLASS && sym->attr.dimension) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.dimension)) - { - gfc_error ("Array section designator, e.g. '(:)', is required " - "besides the coarray designator '[...]' at %C"); - return MATCH_ERROR; - } - if ((sym->ts.type != BT_CLASS && !sym->attr.codimension) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && !CLASS_DATA (sym)->attr.codimension)) - { - gfc_error ("Coarray designator at %C but %qs is not a coarray", - sym->name); - return MATCH_ERROR; - } - } - - if (sym->assoc && sym->assoc->target) - tgt_expr = sym->assoc->target; - - /* For associate names, we may not yet know whether they are arrays or not. - If the selector expression is unambiguously an array; eg. a full array - or an array section, then the associate name must be an array and we can - fix it now. Otherwise, if parentheses follow and it is not a character - type, we have to assume that it actually is one for now. The final - decision will be made at resolution, of course. */ - if (sym->assoc - && gfc_peek_ascii_char () == '(' - && sym->ts.type != BT_CLASS - && !sym->attr.dimension) - { - gfc_ref *ref = NULL; - - if (!sym->assoc->dangling && tgt_expr) - { - if (tgt_expr->expr_type == EXPR_VARIABLE) - gfc_resolve_expr (tgt_expr); - - ref = tgt_expr->ref; - for (; ref; ref = ref->next) - if (ref->type == REF_ARRAY - && (ref->u.ar.type == AR_FULL - || ref->u.ar.type == AR_SECTION)) - break; - } - - if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER) - && sym->assoc->st - && sym->assoc->st->n.sym - && sym->assoc->st->n.sym->attr.dimension == 0)) - { - sym->attr.dimension = 1; - if (sym->as == NULL - && sym->assoc->st - && sym->assoc->st->n.sym - && sym->assoc->st->n.sym->as) - sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as); - } - } - else if (sym->ts.type == BT_CLASS - && tgt_expr - && tgt_expr->expr_type == EXPR_VARIABLE - && sym->ts.u.derived != tgt_expr->ts.u.derived) - { - gfc_resolve_expr (tgt_expr); - if (tgt_expr->rank) - sym->ts.u.derived = tgt_expr->ts.u.derived; - } - - if ((equiv_flag && gfc_peek_ascii_char () == '(') - || gfc_peek_ascii_char () == '[' || sym->attr.codimension - || (sym->attr.dimension && sym->ts.type != BT_CLASS - && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary) - && !(gfc_matching_procptr_assignment - && sym->attr.flavor == FL_PROCEDURE)) - || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym) - && (CLASS_DATA (sym)->attr.dimension - || CLASS_DATA (sym)->attr.codimension))) - { - gfc_array_spec *as; - - tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; - - /* In EQUIVALENCE, we don't know yet whether we are seeing - an array, character variable or array of character - variables. We'll leave the decision till resolve time. */ - - if (equiv_flag) - as = NULL; - else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) - as = CLASS_DATA (sym)->as; - else - as = sym->as; - - m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, - as ? as->corank : 0); - if (m != MATCH_YES) - return m; - - gfc_gobble_whitespace (); - if (equiv_flag && gfc_peek_ascii_char () == '(') - { - tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; - - m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0); - if (m != MATCH_YES) - return m; - } - } - - primary->ts = sym->ts; - - if (equiv_flag) - return MATCH_YES; - - /* With DEC extensions, member separator may be '.' or '%'. */ - sep = gfc_peek_ascii_char (); - m = gfc_match_member_sep (sym); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - inquiry = false; - if (m == MATCH_YES && sep == '%' - && primary->ts.type != BT_CLASS - && primary->ts.type != BT_DERIVED) - { - match mm; - old_loc = gfc_current_locus; - mm = gfc_match_name (name); - if (mm == MATCH_YES && is_inquiry_ref (name, &tmp)) - inquiry = true; - gfc_current_locus = old_loc; - } - - if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES - && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) - gfc_set_default_type (sym, 0, sym->ns); - - /* See if there is a usable typespec in the "no IMPLICIT type" error. */ - if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES) - { - bool permissible; - - /* These target expressions can be resolved at any time. */ - permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym - && (tgt_expr->symtree->n.sym->attr.use_assoc - || tgt_expr->symtree->n.sym->attr.host_assoc - || tgt_expr->symtree->n.sym->attr.if_source - == IFSRC_DECL); - permissible = permissible - || (tgt_expr && tgt_expr->expr_type == EXPR_OP); - - if (permissible) - { - gfc_resolve_expr (tgt_expr); - sym->ts = tgt_expr->ts; - } - - if (sym->ts.type == BT_UNKNOWN) - { - gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name); - return MATCH_ERROR; - } - } - else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) - && m == MATCH_YES && !inquiry) - { - gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C", - sep, sym->name); - return MATCH_ERROR; - } - - if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry) - || m != MATCH_YES) - goto check_substring; - - if (!inquiry) - sym = sym->ts.u.derived; - else - sym = NULL; - - for (;;) - { - bool t; - gfc_symtree *tbp; - - m = gfc_match_name (name); - if (m == MATCH_NO) - gfc_error ("Expected structure component name at %C"); - if (m != MATCH_YES) - return MATCH_ERROR; - - intrinsic = false; - if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED) - { - inquiry = is_inquiry_ref (name, &tmp); - if (inquiry) - sym = NULL; - - if (sep == '%') - { - if (tmp) - { - switch (tmp->u.i) - { - case INQUIRY_RE: - case INQUIRY_IM: - if (!gfc_notify_std (GFC_STD_F2008, - "RE or IM part_ref at %C")) - return MATCH_ERROR; - break; - - case INQUIRY_KIND: - if (!gfc_notify_std (GFC_STD_F2003, - "KIND part_ref at %C")) - return MATCH_ERROR; - break; - - case INQUIRY_LEN: - if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) - return MATCH_ERROR; - break; - } - - if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM) - && primary->ts.type != BT_COMPLEX) - { - gfc_error ("The RE or IM part_ref at %C must be " - "applied to a COMPLEX expression"); - return MATCH_ERROR; - } - else if (tmp->u.i == INQUIRY_LEN - && primary->ts.type != BT_CHARACTER) - { - gfc_error ("The LEN part_ref at %C must be applied " - "to a CHARACTER expression"); - return MATCH_ERROR; - } - } - if (primary->ts.type != BT_UNKNOWN) - intrinsic = true; - } - } - else - inquiry = false; - - if (sym && sym->f2k_derived) - tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus); - else - tbp = NULL; - - if (tbp) - { - gfc_symbol* tbp_sym; - - if (!t) - return MATCH_ERROR; - - gcc_assert (!tail || !tail->next); - - if (!(primary->expr_type == EXPR_VARIABLE - || (primary->expr_type == EXPR_STRUCTURE - && primary->symtree && primary->symtree->n.sym - && primary->symtree->n.sym->attr.flavor))) - return MATCH_ERROR; - - if (tbp->n.tb->is_generic) - tbp_sym = NULL; - else - tbp_sym = tbp->n.tb->u.specific->n.sym; - - primary->expr_type = EXPR_COMPCALL; - primary->value.compcall.tbp = tbp->n.tb; - primary->value.compcall.name = tbp->name; - primary->value.compcall.ignore_pass = 0; - primary->value.compcall.assign = 0; - primary->value.compcall.base_object = NULL; - gcc_assert (primary->symtree->n.sym->attr.referenced); - if (tbp_sym) - primary->ts = tbp_sym->ts; - else - gfc_clear_ts (&primary->ts); - - m = gfc_match_actual_arglist (tbp->n.tb->subroutine, - &primary->value.compcall.actual); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - { - if (sub_flag) - primary->value.compcall.actual = NULL; - else - { - gfc_error ("Expected argument list at %C"); - return MATCH_ERROR; - } - } - - break; - } - - previous = component; - - if (!inquiry && !intrinsic) - component = gfc_find_component (sym, name, false, false, &tmp); - else - component = NULL; - - if (intrinsic && !inquiry) - { - if (previous) - gfc_error ("%qs at %C is not an inquiry reference to an intrinsic " - "type component %qs", name, previous->name); - else - gfc_error ("%qs at %C is not an inquiry reference to an intrinsic " - "type component", name); - return MATCH_ERROR; - } - else if (component == NULL && !inquiry) - return MATCH_ERROR; - - /* Extend the reference chain determined by gfc_find_component or - is_inquiry_ref. */ - if (primary->ref == NULL) - primary->ref = tmp; - else - { - /* Set by the for loop below for the last component ref. */ - gcc_assert (tail != NULL); - tail->next = tmp; - } - - /* The reference chain may be longer than one hop for union - subcomponents; find the new tail. */ - for (tail = tmp; tail->next; tail = tail->next) - ; - - if (tmp && tmp->type == REF_INQUIRY) - { - if (!primary->where.lb || !primary->where.nextc) - primary->where = gfc_current_locus; - gfc_simplify_expr (primary, 0); - - if (primary->expr_type == EXPR_CONSTANT) - goto check_done; - - switch (tmp->u.i) - { - case INQUIRY_RE: - case INQUIRY_IM: - if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C")) - return MATCH_ERROR; - - if (primary->ts.type != BT_COMPLEX) - { - gfc_error ("The RE or IM part_ref at %C must be " - "applied to a COMPLEX expression"); - return MATCH_ERROR; - } - primary->ts.type = BT_REAL; - break; - - case INQUIRY_LEN: - if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) - return MATCH_ERROR; - - if (primary->ts.type != BT_CHARACTER) - { - gfc_error ("The LEN part_ref at %C must be applied " - "to a CHARACTER expression"); - return MATCH_ERROR; - } - primary->ts.u.cl = NULL; - primary->ts.type = BT_INTEGER; - primary->ts.kind = gfc_default_integer_kind; - break; - - case INQUIRY_KIND: - if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) - return MATCH_ERROR; - - if (primary->ts.type == BT_CLASS - || primary->ts.type == BT_DERIVED) - { - gfc_error ("The KIND part_ref at %C must be applied " - "to an expression of intrinsic type"); - return MATCH_ERROR; - } - primary->ts.type = BT_INTEGER; - primary->ts.kind = gfc_default_integer_kind; - break; - - default: - gcc_unreachable (); - } - - goto check_done; - } - - primary->ts = component->ts; - - if (component->attr.proc_pointer && ppc_arg) - { - /* Procedure pointer component call: Look for argument list. */ - m = gfc_match_actual_arglist (sub_flag, - &primary->value.compcall.actual); - if (m == MATCH_ERROR) - return MATCH_ERROR; - - if (m == MATCH_NO && !gfc_matching_ptr_assignment - && !gfc_matching_procptr_assignment && !matching_actual_arglist) - { - gfc_error ("Procedure pointer component %qs requires an " - "argument list at %C", component->name); - return MATCH_ERROR; - } - - if (m == MATCH_YES) - primary->expr_type = EXPR_PPC; - - break; - } - - if (component->as != NULL && !component->attr.proc_pointer) - { - tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; - - m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag, - component->as->corank); - if (m != MATCH_YES) - return m; - } - else if (component->ts.type == BT_CLASS && component->attr.class_ok - && CLASS_DATA (component)->as && !component->attr.proc_pointer) - { - tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; - - m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as, - equiv_flag, - CLASS_DATA (component)->as->corank); - if (m != MATCH_YES) - return m; - } - -check_done: - /* In principle, we could have eg. expr%re%kind so we must allow for - this possibility. */ - if (gfc_match_char ('%') == MATCH_YES) - { - if (component && (component->ts.type == BT_DERIVED - || component->ts.type == BT_CLASS)) - sym = component->ts.u.derived; - continue; - } - else if (inquiry) - break; - - if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS) - || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES) - break; - - if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS) - sym = component->ts.u.derived; - } - -check_substring: - unknown = false; - if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor)) - { - if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER) - { - gfc_set_default_type (sym, 0, sym->ns); - primary->ts = sym->ts; - unknown = true; - } - } - - if (primary->ts.type == BT_CHARACTER) - { - bool def = primary->ts.deferred == 1; - switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def)) - { - case MATCH_YES: - if (tail == NULL) - primary->ref = substring; - else - tail->next = substring; - - if (primary->expr_type == EXPR_CONSTANT) - primary->expr_type = EXPR_SUBSTRING; - - if (substring) - primary->ts.u.cl = NULL; - - break; - - case MATCH_NO: - if (unknown) - { - gfc_clear_ts (&primary->ts); - gfc_clear_ts (&sym->ts); - } - break; - - case MATCH_ERROR: - return MATCH_ERROR; - } - } - - /* F08:C611. */ - if (primary->ts.type == BT_DERIVED && primary->ref - && primary->ts.u.derived && primary->ts.u.derived->attr.abstract) - { - gfc_error ("Nonpolymorphic reference to abstract type at %C"); - return MATCH_ERROR; - } - - /* F08:C727. */ - if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary)) - { - gfc_error ("Coindexed procedure-pointer component at %C"); - return MATCH_ERROR; - } - - return MATCH_YES; -} - - -/* Given an expression that is a variable, figure out what the - ultimate variable's type and attribute is, traversing the reference - structures if necessary. - - This subroutine is trickier than it looks. We start at the base - symbol and store the attribute. Component references load a - completely new attribute. - - A couple of rules come into play. Subobjects of targets are always - targets themselves. If we see a component that goes through a - pointer, then the expression must also be a target, since the - pointer is associated with something (if it isn't core will soon be - dumped). If we see a full part or section of an array, the - expression is also an array. - - We can have at most one full array reference. */ - -symbol_attribute -gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) -{ - int dimension, codimension, pointer, allocatable, target, optional; - symbol_attribute attr; - gfc_ref *ref; - gfc_symbol *sym; - gfc_component *comp; - bool has_inquiry_part; - - if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) - gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable"); - - sym = expr->symtree->n.sym; - attr = sym->attr; - - optional = attr.optional; - if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) - { - dimension = CLASS_DATA (sym)->attr.dimension; - codimension = CLASS_DATA (sym)->attr.codimension; - pointer = CLASS_DATA (sym)->attr.class_pointer; - allocatable = CLASS_DATA (sym)->attr.allocatable; - optional |= CLASS_DATA (sym)->attr.optional; - } - else - { - dimension = attr.dimension; - codimension = attr.codimension; - pointer = attr.pointer; - allocatable = attr.allocatable; - } - - target = attr.target; - if (pointer || attr.proc_pointer) - target = 1; - - if (ts != NULL && expr->ts.type == BT_UNKNOWN) - *ts = sym->ts; - - has_inquiry_part = false; - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_INQUIRY) - { - has_inquiry_part = true; - optional = false; - break; - } - - for (ref = expr->ref; ref; ref = ref->next) - switch (ref->type) - { - case REF_ARRAY: - - switch (ref->u.ar.type) - { - case AR_FULL: - dimension = 1; - break; - - case AR_SECTION: - allocatable = pointer = 0; - dimension = 1; - optional = false; - break; - - case AR_ELEMENT: - /* Handle coarrays. */ - if (ref->u.ar.dimen > 0) - allocatable = pointer = optional = false; - break; - - case AR_UNKNOWN: - /* For standard conforming code, AR_UNKNOWN should not happen. - For nonconforming code, gfortran can end up here. Treat it - as a no-op. */ - break; - } - - break; - - case REF_COMPONENT: - optional = false; - comp = ref->u.c.component; - attr = comp->attr; - if (ts != NULL && !has_inquiry_part) - { - *ts = comp->ts; - /* Don't set the string length if a substring reference - follows. */ - if (ts->type == BT_CHARACTER - && ref->next && ref->next->type == REF_SUBSTRING) - ts->u.cl = NULL; - } - - if (comp->ts.type == BT_CLASS) - { - codimension = CLASS_DATA (comp)->attr.codimension; - pointer = CLASS_DATA (comp)->attr.class_pointer; - allocatable = CLASS_DATA (comp)->attr.allocatable; - } - else - { - codimension = comp->attr.codimension; - if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0) - pointer = comp->attr.class_pointer; - else - pointer = comp->attr.pointer; - allocatable = comp->attr.allocatable; - } - if (pointer || attr.proc_pointer) - target = 1; - - break; - - case REF_INQUIRY: - case REF_SUBSTRING: - allocatable = pointer = optional = false; - break; - } - - attr.dimension = dimension; - attr.codimension = codimension; - attr.pointer = pointer; - attr.allocatable = allocatable; - attr.target = target; - attr.save = sym->attr.save; - attr.optional = optional; - - return attr; -} - - -/* Return the attribute from a general expression. */ - -symbol_attribute -gfc_expr_attr (gfc_expr *e) -{ - symbol_attribute attr; - - switch (e->expr_type) - { - case EXPR_VARIABLE: - attr = gfc_variable_attr (e, NULL); - break; - - case EXPR_FUNCTION: - gfc_clear_attr (&attr); - - if (e->value.function.esym && e->value.function.esym->result) - { - gfc_symbol *sym = e->value.function.esym->result; - attr = sym->attr; - if (sym->ts.type == BT_CLASS) - { - attr.dimension = CLASS_DATA (sym)->attr.dimension; - attr.pointer = CLASS_DATA (sym)->attr.class_pointer; - attr.allocatable = CLASS_DATA (sym)->attr.allocatable; - } - } - else if (e->value.function.isym - && e->value.function.isym->transformational - && e->ts.type == BT_CLASS) - attr = CLASS_DATA (e)->attr; - else if (e->symtree) - attr = gfc_variable_attr (e, NULL); - - /* TODO: NULL() returns pointers. May have to take care of this - here. */ - - break; - - default: - gfc_clear_attr (&attr); - break; - } - - return attr; -} - - -/* Given an expression, figure out what the ultimate expression - attribute is. This routine is similar to gfc_variable_attr with - parts of gfc_expr_attr, but focuses more on the needs of - coarrays. For coarrays a codimension attribute is kind of - "infectious" being propagated once set and never cleared. - The coarray_comp is only set, when the expression refs a coarray - component. REFS_COMP is set when present to true only, when this EXPR - refs a (non-_data) component. To check whether EXPR refs an allocatable - component in a derived type coarray *refs_comp needs to be set and - coarray_comp has to false. */ - -static symbol_attribute -caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp) -{ - int dimension, codimension, pointer, allocatable, target, coarray_comp; - symbol_attribute attr; - gfc_ref *ref; - gfc_symbol *sym; - gfc_component *comp; - - if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) - gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable"); - - sym = expr->symtree->n.sym; - gfc_clear_attr (&attr); - - if (refs_comp) - *refs_comp = false; - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok) - { - dimension = CLASS_DATA (sym)->attr.dimension; - codimension = CLASS_DATA (sym)->attr.codimension; - pointer = CLASS_DATA (sym)->attr.class_pointer; - allocatable = CLASS_DATA (sym)->attr.allocatable; - attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp; - attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp; - } - else - { - dimension = sym->attr.dimension; - codimension = sym->attr.codimension; - pointer = sym->attr.pointer; - allocatable = sym->attr.allocatable; - attr.alloc_comp = sym->ts.type == BT_DERIVED - ? sym->ts.u.derived->attr.alloc_comp : 0; - attr.pointer_comp = sym->ts.type == BT_DERIVED - ? sym->ts.u.derived->attr.pointer_comp : 0; - } - - target = coarray_comp = 0; - if (pointer || attr.proc_pointer) - target = 1; - - for (ref = expr->ref; ref; ref = ref->next) - switch (ref->type) - { - case REF_ARRAY: - - switch (ref->u.ar.type) - { - case AR_FULL: - case AR_SECTION: - dimension = 1; - break; - - case AR_ELEMENT: - /* Handle coarrays. */ - if (ref->u.ar.dimen > 0 && !in_allocate) - allocatable = pointer = 0; - break; - - case AR_UNKNOWN: - /* If any of start, end or stride is not integer, there will - already have been an error issued. */ - int errors; - gfc_get_errors (NULL, &errors); - if (errors == 0) - gfc_internal_error ("gfc_caf_attr(): Bad array reference"); - } - - break; - - case REF_COMPONENT: - comp = ref->u.c.component; - - if (comp->ts.type == BT_CLASS) - { - /* Set coarray_comp only, when this component introduces the - coarray. */ - coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension; - codimension |= CLASS_DATA (comp)->attr.codimension; - pointer = CLASS_DATA (comp)->attr.class_pointer; - allocatable = CLASS_DATA (comp)->attr.allocatable; - } - else - { - /* Set coarray_comp only, when this component introduces the - coarray. */ - coarray_comp = !codimension && comp->attr.codimension; - codimension |= comp->attr.codimension; - pointer = comp->attr.pointer; - allocatable = comp->attr.allocatable; - } - - if (refs_comp && strcmp (comp->name, "_data") != 0 - && (ref->next == NULL - || (ref->next->type == REF_ARRAY && ref->next->next == NULL))) - *refs_comp = true; - - if (pointer || attr.proc_pointer) - target = 1; - - break; - - case REF_SUBSTRING: - case REF_INQUIRY: - allocatable = pointer = 0; - break; - } - - attr.dimension = dimension; - attr.codimension = codimension; - attr.pointer = pointer; - attr.allocatable = allocatable; - attr.target = target; - attr.save = sym->attr.save; - attr.coarray_comp = coarray_comp; - - return attr; -} - - -symbol_attribute -gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp) -{ - symbol_attribute attr; - - switch (e->expr_type) - { - case EXPR_VARIABLE: - attr = caf_variable_attr (e, in_allocate, refs_comp); - break; - - case EXPR_FUNCTION: - gfc_clear_attr (&attr); - - if (e->value.function.esym && e->value.function.esym->result) - { - gfc_symbol *sym = e->value.function.esym->result; - attr = sym->attr; - if (sym->ts.type == BT_CLASS) - { - attr.dimension = CLASS_DATA (sym)->attr.dimension; - attr.pointer = CLASS_DATA (sym)->attr.class_pointer; - attr.allocatable = CLASS_DATA (sym)->attr.allocatable; - attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp; - attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived - ->attr.pointer_comp; - } - } - else if (e->symtree) - attr = caf_variable_attr (e, in_allocate, refs_comp); - else - gfc_clear_attr (&attr); - break; - - default: - gfc_clear_attr (&attr); - break; - } - - return attr; -} - - -/* Match a structure constructor. The initial symbol has already been - seen. */ - -typedef struct gfc_structure_ctor_component -{ - char* name; - gfc_expr* val; - locus where; - struct gfc_structure_ctor_component* next; -} -gfc_structure_ctor_component; - -#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component) - -static void -gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp) -{ - free (comp->name); - gfc_free_expr (comp->val); - free (comp); -} - - -/* Translate the component list into the actual constructor by sorting it in - the order required; this also checks along the way that each and every - component actually has an initializer and handles default initializers - for components without explicit value given. */ -static bool -build_actual_constructor (gfc_structure_ctor_component **comp_head, - gfc_constructor_base *ctor_head, gfc_symbol *sym) -{ - gfc_structure_ctor_component *comp_iter; - gfc_component *comp; - - for (comp = sym->components; comp; comp = comp->next) - { - gfc_structure_ctor_component **next_ptr; - gfc_expr *value = NULL; - - /* Try to find the initializer for the current component by name. */ - next_ptr = comp_head; - for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next) - { - if (!strcmp (comp_iter->name, comp->name)) - break; - next_ptr = &comp_iter->next; - } - - /* If an extension, try building the parent derived type by building - a value expression for the parent derived type and calling self. */ - if (!comp_iter && comp == sym->components && sym->attr.extension) - { - value = gfc_get_structure_constructor_expr (comp->ts.type, - comp->ts.kind, - &gfc_current_locus); - value->ts = comp->ts; - - if (!build_actual_constructor (comp_head, - &value->value.constructor, - comp->ts.u.derived)) - { - gfc_free_expr (value); - return false; - } - - gfc_constructor_append_expr (ctor_head, value, NULL); - continue; - } - - /* If it was not found, apply NULL expression to set the component as - unallocated. Then try the default initializer if there's any; - otherwise, it's an error unless this is a deferred parameter. */ - if (!comp_iter) - { - /* F2018 7.5.10: If an allocatable component has no corresponding - component-data-source, then that component has an allocation - status of unallocated.... */ - if (comp->attr.allocatable - || (comp->ts.type == BT_CLASS - && CLASS_DATA (comp)->attr.allocatable)) - { - if (!gfc_notify_std (GFC_STD_F2008, "No initializer for " - "allocatable component %qs given in the " - "structure constructor at %C", comp->name)) - return false; - value = gfc_get_null_expr (&gfc_current_locus); - } - /* ....(Preceeding sentence) If a component with default - initialization has no corresponding component-data-source, then - the default initialization is applied to that component. */ - else if (comp->initializer) - { - if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor " - "with missing optional arguments at %C")) - return false; - value = gfc_copy_expr (comp->initializer); - } - /* Do not trap components such as the string length for deferred - length character components. */ - else if (!comp->attr.artificial) - { - gfc_error ("No initializer for component %qs given in the" - " structure constructor at %C", comp->name); - return false; - } - } - else - value = comp_iter->val; - - /* Add the value to the constructor chain built. */ - gfc_constructor_append_expr (ctor_head, value, NULL); - - /* Remove the entry from the component list. We don't want the expression - value to be free'd, so set it to NULL. */ - if (comp_iter) - { - *next_ptr = comp_iter->next; - comp_iter->val = NULL; - gfc_free_structure_ctor_component (comp_iter); - } - } - return true; -} - - -bool -gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr, - gfc_actual_arglist **arglist, - bool parent) -{ - gfc_actual_arglist *actual; - gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter; - gfc_constructor_base ctor_head = NULL; - gfc_component *comp; /* Is set NULL when named component is first seen */ - const char* last_name = NULL; - locus old_locus; - gfc_expr *expr; - - expr = parent ? *cexpr : e; - old_locus = gfc_current_locus; - if (parent) - ; /* gfc_current_locus = *arglist->expr ? ->where;*/ - else - gfc_current_locus = expr->where; - - comp_tail = comp_head = NULL; - - if (!parent && sym->attr.abstract) - { - gfc_error ("Cannot construct ABSTRACT type %qs at %L", - sym->name, &expr->where); - goto cleanup; - } - - comp = sym->components; - actual = parent ? *arglist : expr->value.function.actual; - for ( ; actual; ) - { - gfc_component *this_comp = NULL; - - if (!comp_head) - comp_tail = comp_head = gfc_get_structure_ctor_component (); - else - { - comp_tail->next = gfc_get_structure_ctor_component (); - comp_tail = comp_tail->next; - } - if (actual->name) - { - if (!gfc_notify_std (GFC_STD_F2003, "Structure" - " constructor with named arguments at %C")) - goto cleanup; - - comp_tail->name = xstrdup (actual->name); - last_name = comp_tail->name; - comp = NULL; - } - else - { - /* Components without name are not allowed after the first named - component initializer! */ - if (!comp || comp->attr.artificial) - { - if (last_name) - gfc_error ("Component initializer without name after component" - " named %s at %L", last_name, - actual->expr ? &actual->expr->where - : &gfc_current_locus); - else - gfc_error ("Too many components in structure constructor at " - "%L", actual->expr ? &actual->expr->where - : &gfc_current_locus); - goto cleanup; - } - - comp_tail->name = xstrdup (comp->name); - } - - /* Find the current component in the structure definition and check - its access is not private. */ - if (comp) - this_comp = gfc_find_component (sym, comp->name, false, false, NULL); - else - { - this_comp = gfc_find_component (sym, (const char *)comp_tail->name, - false, false, NULL); - comp = NULL; /* Reset needed! */ - } - - /* Here we can check if a component name is given which does not - correspond to any component of the defined structure. */ - if (!this_comp) - goto cleanup; - - /* For a constant string constructor, make sure the length is - correct; truncate of fill with blanks if needed. */ - if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable - && this_comp->ts.u.cl && this_comp->ts.u.cl->length - && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT - && actual->expr->ts.type == BT_CHARACTER - && actual->expr->expr_type == EXPR_CONSTANT) - { - ptrdiff_t c, e1; - c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer); - e1 = actual->expr->value.character.length; - - if (c != e1) - { - ptrdiff_t i, to; - gfc_char_t *dest; - dest = gfc_get_wide_string (c + 1); - - to = e1 < c ? e1 : c; - for (i = 0; i < to; i++) - dest[i] = actual->expr->value.character.string[i]; - - for (i = e1; i < c; i++) - dest[i] = ' '; - - dest[c] = '\0'; - free (actual->expr->value.character.string); - - actual->expr->value.character.length = c; - actual->expr->value.character.string = dest; - - if (warn_line_truncation && c < e1) - gfc_warning_now (OPT_Wcharacter_truncation, - "CHARACTER expression will be truncated " - "in constructor (%ld/%ld) at %L", (long int) c, - (long int) e1, &actual->expr->where); - } - } - - comp_tail->val = actual->expr; - if (actual->expr != NULL) - comp_tail->where = actual->expr->where; - actual->expr = NULL; - - /* Check if this component is already given a value. */ - for (comp_iter = comp_head; comp_iter != comp_tail; - comp_iter = comp_iter->next) - { - gcc_assert (comp_iter); - if (!strcmp (comp_iter->name, comp_tail->name)) - { - gfc_error ("Component %qs is initialized twice in the structure" - " constructor at %L", comp_tail->name, - comp_tail->val ? &comp_tail->where - : &gfc_current_locus); - goto cleanup; - } - } - - /* F2008, R457/C725, for PURE C1283. */ - if (this_comp->attr.pointer && comp_tail->val - && gfc_is_coindexed (comp_tail->val)) - { - gfc_error ("Coindexed expression to pointer component %qs in " - "structure constructor at %L", comp_tail->name, - &comp_tail->where); - goto cleanup; - } - - /* If not explicitly a parent constructor, gather up the components - and build one. */ - if (comp && comp == sym->components - && sym->attr.extension - && comp_tail->val - && (!gfc_bt_struct (comp_tail->val->ts.type) - || - comp_tail->val->ts.u.derived != this_comp->ts.u.derived)) - { - bool m; - gfc_actual_arglist *arg_null = NULL; - - actual->expr = comp_tail->val; - comp_tail->val = NULL; - - m = gfc_convert_to_structure_constructor (NULL, - comp->ts.u.derived, &comp_tail->val, - comp->ts.u.derived->attr.zero_comp - ? &arg_null : &actual, true); - if (!m) - goto cleanup; - - if (comp->ts.u.derived->attr.zero_comp) - { - comp = comp->next; - continue; - } - } - - if (comp) - comp = comp->next; - if (parent && !comp) - break; - - if (actual) - actual = actual->next; - } - - if (!build_actual_constructor (&comp_head, &ctor_head, sym)) - goto cleanup; - - /* No component should be left, as this should have caused an error in the - loop constructing the component-list (name that does not correspond to any - component in the structure definition). */ - if (comp_head && sym->attr.extension) - { - for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next) - { - gfc_error ("component %qs at %L has already been set by a " - "parent derived type constructor", comp_iter->name, - &comp_iter->where); - } - goto cleanup; - } - else - gcc_assert (!comp_head); - - if (parent) - { - expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus); - expr->ts.u.derived = sym; - expr->value.constructor = ctor_head; - *cexpr = expr; - } - else - { - expr->ts.u.derived = sym; - expr->ts.kind = 0; - expr->ts.type = BT_DERIVED; - expr->value.constructor = ctor_head; - expr->expr_type = EXPR_STRUCTURE; - } - - gfc_current_locus = old_locus; - if (parent) - *arglist = actual; - return true; - - cleanup: - gfc_current_locus = old_locus; - - for (comp_iter = comp_head; comp_iter; ) - { - gfc_structure_ctor_component *next = comp_iter->next; - gfc_free_structure_ctor_component (comp_iter); - comp_iter = next; - } - gfc_constructor_free (ctor_head); - - return false; -} - - -match -gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) -{ - match m; - gfc_expr *e; - gfc_symtree *symtree; - bool t = true; - - gfc_get_ha_sym_tree (sym->name, &symtree); - - e = gfc_get_expr (); - e->symtree = symtree; - e->expr_type = EXPR_FUNCTION; - e->where = gfc_current_locus; - - gcc_assert (gfc_fl_struct (sym->attr.flavor) - && symtree->n.sym->attr.flavor == FL_PROCEDURE); - e->value.function.esym = sym; - e->symtree->n.sym->attr.generic = 1; - - m = gfc_match_actual_arglist (0, &e->value.function.actual); - if (m != MATCH_YES) - { - gfc_free_expr (e); - return m; - } - - if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)) - { - gfc_free_expr (e); - return MATCH_ERROR; - } - - /* If a structure constructor is in a DATA statement, then each entity - in the structure constructor must be a constant. Try to reduce the - expression here. */ - if (gfc_in_match_data ()) - t = gfc_reduce_init_expr (e); - - if (t) - { - *result = e; - return MATCH_YES; - } - else - { - gfc_free_expr (e); - return MATCH_ERROR; - } -} - - -/* If the symbol is an implicit do loop index and implicitly typed, - it should not be host associated. Provide a symtree from the - current namespace. */ -static match -check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym) -{ - if ((*sym)->attr.flavor == FL_VARIABLE - && (*sym)->ns != gfc_current_ns - && (*sym)->attr.implied_index - && (*sym)->attr.implicit_type - && !(*sym)->attr.use_assoc) - { - int i; - i = gfc_get_sym_tree ((*sym)->name, NULL, st, false); - if (i) - return MATCH_ERROR; - *sym = (*st)->n.sym; - } - return MATCH_YES; -} - - -/* Procedure pointer as function result: Replace the function symbol by the - auto-generated hidden result variable named "ppr@". */ - -static bool -replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st) -{ - /* Check for procedure pointer result variable. */ - if ((*sym)->attr.function && !(*sym)->attr.external - && (*sym)->result && (*sym)->result != *sym - && (*sym)->result->attr.proc_pointer - && (*sym) == gfc_current_ns->proc_name - && (*sym) == (*sym)->result->ns->proc_name - && strcmp ("ppr@", (*sym)->result->name) == 0) - { - /* Automatic replacement with "hidden" result variable. */ - (*sym)->result->attr.referenced = (*sym)->attr.referenced; - *sym = (*sym)->result; - *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name); - return true; - } - return false; -} - - -/* Matches a variable name followed by anything that might follow it-- - array reference, argument list of a function, etc. */ - -match -gfc_match_rvalue (gfc_expr **result) -{ - gfc_actual_arglist *actual_arglist; - char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1]; - gfc_state_data *st; - gfc_symbol *sym; - gfc_symtree *symtree; - locus where, old_loc; - gfc_expr *e; - match m, m2; - int i; - gfc_typespec *ts; - bool implicit_char; - gfc_ref *ref; - - m = gfc_match ("%%loc"); - if (m == MATCH_YES) - { - if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C")) - return MATCH_ERROR; - strncpy (name, "loc", 4); - } - - else - { - m = gfc_match_name (name); - if (m != MATCH_YES) - return m; - } - - /* Check if the symbol exists. */ - if (gfc_find_sym_tree (name, NULL, 1, &symtree)) - return MATCH_ERROR; - - /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT - type. For derived types we create a generic symbol which links to the - derived type symbol; STRUCTUREs are simpler and must not conflict with - variables. */ - if (!symtree) - if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree)) - return MATCH_ERROR; - if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) - { - if (gfc_find_state (COMP_INTERFACE) - && !gfc_current_ns->has_import_set) - i = gfc_get_sym_tree (name, NULL, &symtree, false); - else - i = gfc_get_ha_sym_tree (name, &symtree); - if (i) - return MATCH_ERROR; - } - - - sym = symtree->n.sym; - e = NULL; - where = gfc_current_locus; - - replace_hidden_procptr_result (&sym, &symtree); - - /* If this is an implicit do loop index and implicitly typed, - it should not be host associated. */ - m = check_for_implicit_index (&symtree, &sym); - if (m != MATCH_YES) - return m; - - gfc_set_sym_referenced (sym); - sym->attr.implied_index = 0; - - if (sym->attr.function && sym->result == sym) - { - /* See if this is a directly recursive function call. */ - gfc_gobble_whitespace (); - if (sym->attr.recursive - && gfc_peek_ascii_char () == '(' - && gfc_current_ns->proc_name == sym - && !sym->attr.dimension) - { - gfc_error ("%qs at %C is the name of a recursive function " - "and so refers to the result variable. Use an " - "explicit RESULT variable for direct recursion " - "(12.5.2.1)", sym->name); - return MATCH_ERROR; - } - - if (gfc_is_function_return_value (sym, gfc_current_ns)) - goto variable; - - if (sym->attr.entry - && (sym->ns == gfc_current_ns - || sym->ns == gfc_current_ns->parent)) - { - gfc_entry_list *el = NULL; - - for (el = sym->ns->entries; el; el = el->next) - if (sym == el->sym) - goto variable; - } - } - - if (gfc_matching_procptr_assignment) - { - /* It can be a procedure or a derived-type procedure or a not-yet-known - type. */ - if (sym->attr.flavor != FL_UNKNOWN - && sym->attr.flavor != FL_PROCEDURE - && sym->attr.flavor != FL_PARAMETER - && sym->attr.flavor != FL_VARIABLE) - { - gfc_error ("Symbol at %C is not appropriate for an expression"); - return MATCH_ERROR; - } - goto procptr0; - } - - if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) - goto function0; - - if (sym->attr.generic) - goto generic_function; - - switch (sym->attr.flavor) - { - case FL_VARIABLE: - variable: - e = gfc_get_expr (); - - e->expr_type = EXPR_VARIABLE; - e->symtree = symtree; - - m = gfc_match_varspec (e, 0, false, true); - break; - - case FL_PARAMETER: - /* A statement of the form "REAL, parameter :: a(0:10) = 1" will - end up here. Unfortunately, sym->value->expr_type is set to - EXPR_CONSTANT, and so the if () branch would be followed without - the !sym->as check. */ - if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as) - e = gfc_copy_expr (sym->value); - else - { - e = gfc_get_expr (); - e->expr_type = EXPR_VARIABLE; - } - - e->symtree = symtree; - m = gfc_match_varspec (e, 0, false, true); - - if (sym->ts.is_c_interop || sym->ts.is_iso_c) - break; - - /* Variable array references to derived type parameters cause - all sorts of headaches in simplification. Treating such - expressions as variable works just fine for all array - references. */ - if (sym->value && sym->ts.type == BT_DERIVED && e->ref) - { - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY) - break; - - if (ref == NULL || ref->u.ar.type == AR_FULL) - break; - - ref = e->ref; - e->ref = NULL; - gfc_free_expr (e); - e = gfc_get_expr (); - e->expr_type = EXPR_VARIABLE; - e->symtree = symtree; - e->ref = ref; - } - - break; - - case FL_STRUCT: - case FL_DERIVED: - sym = gfc_use_derived (sym); - if (sym == NULL) - m = MATCH_ERROR; - else - goto generic_function; - break; - - /* If we're here, then the name is known to be the name of a - procedure, yet it is not sure to be the name of a function. */ - case FL_PROCEDURE: - - /* Procedure Pointer Assignments. */ - procptr0: - if (gfc_matching_procptr_assignment) - { - gfc_gobble_whitespace (); - if (!sym->attr.dimension && gfc_peek_ascii_char () == '(') - /* Parse functions returning a procptr. */ - goto function0; - - e = gfc_get_expr (); - e->expr_type = EXPR_VARIABLE; - e->symtree = symtree; - m = gfc_match_varspec (e, 0, false, true); - if (!e->ref && sym->attr.flavor == FL_UNKNOWN - && sym->ts.type == BT_UNKNOWN - && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL)) - { - m = MATCH_ERROR; - break; - } - break; - } - - if (sym->attr.subroutine) - { - gfc_error ("Unexpected use of subroutine name %qs at %C", - sym->name); - m = MATCH_ERROR; - break; - } - - /* At this point, the name has to be a non-statement function. - If the name is the same as the current function being - compiled, then we have a variable reference (to the function - result) if the name is non-recursive. */ - - st = gfc_enclosing_unit (NULL); - - if (st != NULL - && st->state == COMP_FUNCTION - && st->sym == sym - && !sym->attr.recursive) - { - e = gfc_get_expr (); - e->symtree = symtree; - e->expr_type = EXPR_VARIABLE; - - m = gfc_match_varspec (e, 0, false, true); - break; - } - - /* Match a function reference. */ - function0: - m = gfc_match_actual_arglist (0, &actual_arglist); - if (m == MATCH_NO) - { - if (sym->attr.proc == PROC_ST_FUNCTION) - gfc_error ("Statement function %qs requires argument list at %C", - sym->name); - else - gfc_error ("Function %qs requires an argument list at %C", - sym->name); - - m = MATCH_ERROR; - break; - } - - if (m != MATCH_YES) - { - m = MATCH_ERROR; - break; - } - - gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ - sym = symtree->n.sym; - - replace_hidden_procptr_result (&sym, &symtree); - - e = gfc_get_expr (); - e->symtree = symtree; - e->expr_type = EXPR_FUNCTION; - e->value.function.actual = actual_arglist; - e->where = gfc_current_locus; - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok - && CLASS_DATA (sym)->as) - e->rank = CLASS_DATA (sym)->as->rank; - else if (sym->as != NULL) - e->rank = sym->as->rank; - - if (!sym->attr.function - && !gfc_add_function (&sym->attr, sym->name, NULL)) - { - m = MATCH_ERROR; - break; - } - - /* Check here for the existence of at least one argument for the - iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The - argument(s) given will be checked in gfc_iso_c_func_interface, - during resolution of the function call. */ - if (sym->attr.is_iso_c == 1 - && (sym->from_intmod == INTMOD_ISO_C_BINDING - && (sym->intmod_sym_id == ISOCBINDING_LOC - || sym->intmod_sym_id == ISOCBINDING_FUNLOC - || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED))) - { - /* make sure we were given a param */ - if (actual_arglist == NULL) - { - gfc_error ("Missing argument to %qs at %C", sym->name); - m = MATCH_ERROR; - break; - } - } - - if (sym->result == NULL) - sym->result = sym; - - gfc_gobble_whitespace (); - /* F08:C612. */ - if (gfc_peek_ascii_char() == '%') - { - gfc_error ("The leftmost part-ref in a data-ref cannot be a " - "function reference at %C"); - m = MATCH_ERROR; - break; - } - - m = MATCH_YES; - break; - - case FL_UNKNOWN: - - /* Special case for derived type variables that get their types - via an IMPLICIT statement. This can't wait for the - resolution phase. */ - - old_loc = gfc_current_locus; - if (gfc_match_member_sep (sym) == MATCH_YES - && sym->ts.type == BT_UNKNOWN - && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) - gfc_set_default_type (sym, 0, sym->ns); - gfc_current_locus = old_loc; - - /* If the symbol has a (co)dimension attribute, the expression is a - variable. */ - - if (sym->attr.dimension || sym->attr.codimension) - { - if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) - { - m = MATCH_ERROR; - break; - } - - e = gfc_get_expr (); - e->symtree = symtree; - e->expr_type = EXPR_VARIABLE; - m = gfc_match_varspec (e, 0, false, true); - break; - } - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok - && (CLASS_DATA (sym)->attr.dimension - || CLASS_DATA (sym)->attr.codimension)) - { - if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) - { - m = MATCH_ERROR; - break; - } - - e = gfc_get_expr (); - e->symtree = symtree; - e->expr_type = EXPR_VARIABLE; - m = gfc_match_varspec (e, 0, false, true); - break; - } - - /* Name is not an array, so we peek to see if a '(' implies a - function call or a substring reference. Otherwise the - variable is just a scalar. */ - - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () != '(') - { - /* Assume a scalar variable */ - e = gfc_get_expr (); - e->symtree = symtree; - e->expr_type = EXPR_VARIABLE; - - if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) - { - m = MATCH_ERROR; - break; - } - - /*FIXME:??? gfc_match_varspec does set this for us: */ - e->ts = sym->ts; - m = gfc_match_varspec (e, 0, false, true); - break; - } - - /* See if this is a function reference with a keyword argument - as first argument. We do this because otherwise a spurious - symbol would end up in the symbol table. */ - - old_loc = gfc_current_locus; - m2 = gfc_match (" ( %n =", argname); - gfc_current_locus = old_loc; - - e = gfc_get_expr (); - e->symtree = symtree; - - if (m2 != MATCH_YES) - { - /* Try to figure out whether we're dealing with a character type. - We're peeking ahead here, because we don't want to call - match_substring if we're dealing with an implicitly typed - non-character variable. */ - implicit_char = false; - if (sym->ts.type == BT_UNKNOWN) - { - ts = gfc_get_default_type (sym->name, NULL); - if (ts->type == BT_CHARACTER) - implicit_char = true; - } - - /* See if this could possibly be a substring reference of a name - that we're not sure is a variable yet. */ - - if ((implicit_char || sym->ts.type == BT_CHARACTER) - && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES) - { - - e->expr_type = EXPR_VARIABLE; - - if (sym->attr.flavor != FL_VARIABLE - && !gfc_add_flavor (&sym->attr, FL_VARIABLE, - sym->name, NULL)) - { - m = MATCH_ERROR; - break; - } - - if (sym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (sym, 1, NULL)) - { - m = MATCH_ERROR; - break; - } - - e->ts = sym->ts; - if (e->ref) - e->ts.u.cl = NULL; - m = MATCH_YES; - break; - } - } - - /* Give up, assume we have a function. */ - - gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ - sym = symtree->n.sym; - e->expr_type = EXPR_FUNCTION; - - if (!sym->attr.function - && !gfc_add_function (&sym->attr, sym->name, NULL)) - { - m = MATCH_ERROR; - break; - } - - sym->result = sym; - - m = gfc_match_actual_arglist (0, &e->value.function.actual); - if (m == MATCH_NO) - gfc_error ("Missing argument list in function %qs at %C", sym->name); - - if (m != MATCH_YES) - { - m = MATCH_ERROR; - break; - } - - /* If our new function returns a character, array or structure - type, it might have subsequent references. */ - - m = gfc_match_varspec (e, 0, false, true); - if (m == MATCH_NO) - m = MATCH_YES; - - break; - - generic_function: - /* Look for symbol first; if not found, look for STRUCTURE type symbol - specially. Creates a generic symbol for derived types. */ - gfc_find_sym_tree (name, NULL, 1, &symtree); - if (!symtree) - gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree); - if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) - gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ - - e = gfc_get_expr (); - e->symtree = symtree; - e->expr_type = EXPR_FUNCTION; - - if (gfc_fl_struct (sym->attr.flavor)) - { - e->value.function.esym = sym; - e->symtree->n.sym->attr.generic = 1; - } - - m = gfc_match_actual_arglist (0, &e->value.function.actual); - break; - - case FL_NAMELIST: - m = MATCH_ERROR; - break; - - default: - gfc_error ("Symbol at %C is not appropriate for an expression"); - return MATCH_ERROR; - } - - if (m == MATCH_YES) - { - e->where = where; - *result = e; - } - else - gfc_free_expr (e); - - return m; -} - - -/* Match a variable, i.e. something that can be assigned to. This - starts as a symbol, can be a structure component or an array - reference. It can be a function if the function doesn't have a - separate RESULT variable. If the symbol has not been previously - seen, we assume it is a variable. - - This function is called by two interface functions: - gfc_match_variable, which has host_flag = 1, and - gfc_match_equiv_variable, with host_flag = 0, to restrict the - match of the symbol to the local scope. */ - -static match -match_variable (gfc_expr **result, int equiv_flag, int host_flag) -{ - gfc_symbol *sym, *dt_sym; - gfc_symtree *st; - gfc_expr *expr; - locus where, old_loc; - match m; - - /* Since nothing has any business being an lvalue in a module - specification block, an interface block or a contains section, - we force the changed_symbols mechanism to work by setting - host_flag to 0. This prevents valid symbols that have the name - of keywords, such as 'end', being turned into variables by - failed matching to assignments for, e.g., END INTERFACE. */ - if (gfc_current_state () == COMP_MODULE - || gfc_current_state () == COMP_SUBMODULE - || gfc_current_state () == COMP_INTERFACE - || gfc_current_state () == COMP_CONTAINS) - host_flag = 0; - - where = gfc_current_locus; - m = gfc_match_sym_tree (&st, host_flag); - if (m != MATCH_YES) - return m; - - sym = st->n.sym; - - /* If this is an implicit do loop index and implicitly typed, - it should not be host associated. */ - m = check_for_implicit_index (&st, &sym); - if (m != MATCH_YES) - return m; - - sym->attr.implied_index = 0; - - gfc_set_sym_referenced (sym); - - /* STRUCTUREs may share names with variables, but derived types may not. */ - if (sym->attr.flavor == FL_PROCEDURE && sym->generic - && (dt_sym = gfc_find_dt_in_generic (sym))) - { - if (dt_sym->attr.flavor == FL_DERIVED) - gfc_error ("Derived type %qs cannot be used as a variable at %C", - sym->name); - return MATCH_ERROR; - } - - switch (sym->attr.flavor) - { - case FL_VARIABLE: - /* Everything is alright. */ - break; - - case FL_UNKNOWN: - { - sym_flavor flavor = FL_UNKNOWN; - - gfc_gobble_whitespace (); - - if (sym->attr.external || sym->attr.procedure - || sym->attr.function || sym->attr.subroutine) - flavor = FL_PROCEDURE; - - /* If it is not a procedure, is not typed and is host associated, - we cannot give it a flavor yet. */ - else if (sym->ns == gfc_current_ns->parent - && sym->ts.type == BT_UNKNOWN) - break; - - /* These are definitive indicators that this is a variable. */ - else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN - || sym->attr.pointer || sym->as != NULL) - flavor = FL_VARIABLE; - - if (flavor != FL_UNKNOWN - && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL)) - return MATCH_ERROR; - } - break; - - case FL_PARAMETER: - if (equiv_flag) - { - gfc_error ("Named constant at %C in an EQUIVALENCE"); - return MATCH_ERROR; - } - /* Otherwise this is checked for and an error given in the - variable definition context checks. */ - break; - - case FL_PROCEDURE: - /* Check for a nonrecursive function result variable. */ - if (sym->attr.function - && !sym->attr.external - && sym->result == sym - && (gfc_is_function_return_value (sym, gfc_current_ns) - || (sym->attr.entry - && sym->ns == gfc_current_ns) - || (sym->attr.entry - && sym->ns == gfc_current_ns->parent))) - { - /* If a function result is a derived type, then the derived - type may still have to be resolved. */ - - if (sym->ts.type == BT_DERIVED - && gfc_use_derived (sym->ts.u.derived) == NULL) - return MATCH_ERROR; - break; - } - - if (sym->attr.proc_pointer - || replace_hidden_procptr_result (&sym, &st)) - break; - - /* Fall through to error */ - gcc_fallthrough (); - - default: - gfc_error ("%qs at %C is not a variable", sym->name); - return MATCH_ERROR; - } - - /* Special case for derived type variables that get their types - via an IMPLICIT statement. This can't wait for the - resolution phase. */ - - { - gfc_namespace * implicit_ns; - - if (gfc_current_ns->proc_name == sym) - implicit_ns = gfc_current_ns; - else - implicit_ns = sym->ns; - - old_loc = gfc_current_locus; - if (gfc_match_member_sep (sym) == MATCH_YES - && sym->ts.type == BT_UNKNOWN - && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED) - gfc_set_default_type (sym, 0, implicit_ns); - gfc_current_locus = old_loc; - } - - expr = gfc_get_expr (); - - expr->expr_type = EXPR_VARIABLE; - expr->symtree = st; - expr->ts = sym->ts; - expr->where = where; - - /* Now see if we have to do more. */ - m = gfc_match_varspec (expr, equiv_flag, false, false); - if (m != MATCH_YES) - { - gfc_free_expr (expr); - return m; - } - - *result = expr; - return MATCH_YES; -} - - -match -gfc_match_variable (gfc_expr **result, int equiv_flag) -{ - return match_variable (result, equiv_flag, 1); -} - - -match -gfc_match_equiv_variable (gfc_expr **result) -{ - return match_variable (result, 1, 0); -} - diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc new file mode 100644 index 0000000..3f01f67 --- /dev/null +++ b/gcc/fortran/primary.cc @@ -0,0 +1,4175 @@ +/* Primary expression subroutines + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "arith.h" +#include "match.h" +#include "parse.h" +#include "constructor.h" + +int matching_actual_arglist = 0; + +/* Matches a kind-parameter expression, which is either a named + symbolic constant or a nonnegative integer constant. If + successful, sets the kind value to the correct integer. + The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING + symbol like e.g. 'c_int'. */ + +static match +match_kind_param (int *kind, int *is_iso_c) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + *is_iso_c = 0; + + m = gfc_match_small_literal_int (kind, NULL); + if (m != MATCH_NO) + return m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym == NULL) + return MATCH_NO; + + *is_iso_c = sym->attr.is_iso_c; + + if (sym->attr.flavor != FL_PARAMETER) + return MATCH_NO; + + if (sym->value == NULL) + return MATCH_NO; + + if (gfc_extract_int (sym->value, kind)) + return MATCH_NO; + + gfc_set_sym_referenced (sym); + + if (*kind < 0) + return MATCH_NO; + + return MATCH_YES; +} + + +/* Get a trailing kind-specification for non-character variables. + Returns: + * the integer kind value or + * -1 if an error was generated, + * -2 if no kind was found. + The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING + symbol like e.g. 'c_int'. */ + +static int +get_kind (int *is_iso_c) +{ + int kind; + match m; + + *is_iso_c = 0; + + if (gfc_match_char ('_') != MATCH_YES) + return -2; + + m = match_kind_param (&kind, is_iso_c); + if (m == MATCH_NO) + gfc_error ("Missing kind-parameter at %C"); + + return (m == MATCH_YES) ? kind : -1; +} + + +/* Given a character and a radix, see if the character is a valid + digit in that radix. */ + +int +gfc_check_digit (char c, int radix) +{ + int r; + + switch (radix) + { + case 2: + r = ('0' <= c && c <= '1'); + break; + + case 8: + r = ('0' <= c && c <= '7'); + break; + + case 10: + r = ('0' <= c && c <= '9'); + break; + + case 16: + r = ISXDIGIT (c); + break; + + default: + gfc_internal_error ("gfc_check_digit(): bad radix"); + } + + return r; +} + + +/* Match the digit string part of an integer if signflag is not set, + the signed digit string part if signflag is set. If the buffer + is NULL, we just count characters for the resolution pass. Returns + the number of characters matched, -1 for no match. */ + +static int +match_digits (int signflag, int radix, char *buffer) +{ + locus old_loc; + int length; + char c; + + length = 0; + c = gfc_next_ascii_char (); + + if (signflag && (c == '+' || c == '-')) + { + if (buffer != NULL) + *buffer++ = c; + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + length++; + } + + if (!gfc_check_digit (c, radix)) + return -1; + + length++; + if (buffer != NULL) + *buffer++ = c; + + for (;;) + { + old_loc = gfc_current_locus; + c = gfc_next_ascii_char (); + + if (!gfc_check_digit (c, radix)) + break; + + if (buffer != NULL) + *buffer++ = c; + length++; + } + + gfc_current_locus = old_loc; + + return length; +} + +/* Convert an integer string to an expression node. */ + +static gfc_expr * +convert_integer (const char *buffer, int kind, int radix, locus *where) +{ + gfc_expr *e; + const char *t; + + e = gfc_get_constant_expr (BT_INTEGER, kind, where); + /* A leading plus is allowed, but not by mpz_set_str. */ + if (buffer[0] == '+') + t = buffer + 1; + else + t = buffer; + mpz_set_str (e->value.integer, t, radix); + + return e; +} + + +/* Convert a real string to an expression node. */ + +static gfc_expr * +convert_real (const char *buffer, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_constant_expr (BT_REAL, kind, where); + mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE); + + return e; +} + + +/* Convert a pair of real, constant expression nodes to a single + complex expression node. */ + +static gfc_expr * +convert_complex (gfc_expr *real, gfc_expr *imag, int kind) +{ + gfc_expr *e; + + e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where); + mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real, + GFC_MPC_RND_MODE); + + return e; +} + + +/* Match an integer (digit string and optional kind). + A sign will be accepted if signflag is set. */ + +static match +match_integer_constant (gfc_expr **result, int signflag) +{ + int length, kind, is_iso_c; + locus old_loc; + char *buffer; + gfc_expr *e; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + length = match_digits (signflag, 10, NULL); + gfc_current_locus = old_loc; + if (length == -1) + return MATCH_NO; + + buffer = (char *) alloca (length + 1); + memset (buffer, '\0', length + 1); + + gfc_gobble_whitespace (); + + match_digits (signflag, 10, buffer); + + kind = get_kind (&is_iso_c); + if (kind == -2) + kind = gfc_default_integer_kind; + if (kind == -1) + return MATCH_ERROR; + + if (kind == 4 && flag_integer4_kind == 8) + kind = 8; + + if (gfc_validate_kind (BT_INTEGER, kind, true) < 0) + { + gfc_error ("Integer kind %d at %C not available", kind); + return MATCH_ERROR; + } + + e = convert_integer (buffer, kind, 10, &gfc_current_locus); + e->ts.is_c_interop = is_iso_c; + + if (gfc_range_check (e) != ARITH_OK) + { + gfc_error ("Integer too big for its kind at %C. This check can be " + "disabled with the option %<-fno-range-check%>"); + + gfc_free_expr (e); + return MATCH_ERROR; + } + + *result = e; + return MATCH_YES; +} + + +/* Match a Hollerith constant. */ + +static match +match_hollerith_constant (gfc_expr **result) +{ + locus old_loc; + gfc_expr *e = NULL; + int num, pad; + int i; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + if (match_integer_constant (&e, 0) == MATCH_YES + && gfc_match_char ('h') == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C")) + goto cleanup; + + if (gfc_extract_int (e, &num, 1)) + goto cleanup; + if (num == 0) + { + gfc_error ("Invalid Hollerith constant: %L must contain at least " + "one character", &old_loc); + goto cleanup; + } + if (e->ts.kind != gfc_default_integer_kind) + { + gfc_error ("Invalid Hollerith constant: Integer kind at %L " + "should be default", &old_loc); + goto cleanup; + } + else + { + gfc_free_expr (e); + e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind, + &gfc_current_locus); + + /* Calculate padding needed to fit default integer memory. */ + pad = gfc_default_integer_kind - (num % gfc_default_integer_kind); + + e->representation.string = XCNEWVEC (char, num + pad + 1); + + for (i = 0; i < num; i++) + { + gfc_char_t c = gfc_next_char_literal (INSTRING_WARN); + if (! gfc_wide_fits_in_byte (c)) + { + gfc_error ("Invalid Hollerith constant at %L contains a " + "wide character", &old_loc); + goto cleanup; + } + + e->representation.string[i] = (unsigned char) c; + } + + /* Now pad with blanks and end with a null char. */ + for (i = 0; i < pad; i++) + e->representation.string[num + i] = ' '; + + e->representation.string[num + i] = '\0'; + e->representation.length = num + pad; + e->ts.u.pad = pad; + + *result = e; + return MATCH_YES; + } + } + + gfc_free_expr (e); + gfc_current_locus = old_loc; + return MATCH_NO; + +cleanup: + gfc_free_expr (e); + return MATCH_ERROR; +} + + +/* Match a binary, octal or hexadecimal constant that can be found in + a DATA statement. The standard permits b'010...', o'73...', and + z'a1...' where b, o, and z can be capital letters. This function + also accepts postfixed forms of the constants: '01...'b, '73...'o, + and 'a1...'z. An additional extension is the use of x for z. */ + +static match +match_boz_constant (gfc_expr **result) +{ + int radix, length, x_hex; + locus old_loc, start_loc; + char *buffer, post, delim; + gfc_expr *e; + + start_loc = old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + x_hex = 0; + switch (post = gfc_next_ascii_char ()) + { + case 'b': + radix = 2; + post = 0; + break; + case 'o': + radix = 8; + post = 0; + break; + case 'x': + x_hex = 1; + /* Fall through. */ + case 'z': + radix = 16; + post = 0; + break; + case '\'': + /* Fall through. */ + case '\"': + delim = post; + post = 1; + radix = 16; /* Set to accept any valid digit string. */ + break; + default: + goto backup; + } + + /* No whitespace allowed here. */ + + if (post == 0) + delim = gfc_next_ascii_char (); + + if (delim != '\'' && delim != '\"') + goto backup; + + if (x_hex + && gfc_invalid_boz (G_("Hexadecimal constant at %L uses " + "nonstandard X instead of Z"), &gfc_current_locus)) + return MATCH_ERROR; + + old_loc = gfc_current_locus; + + length = match_digits (0, radix, NULL); + if (length == -1) + { + gfc_error ("Empty set of digits in BOZ constant at %C"); + return MATCH_ERROR; + } + + if (gfc_next_ascii_char () != delim) + { + gfc_error ("Illegal character in BOZ constant at %C"); + return MATCH_ERROR; + } + + if (post == 1) + { + switch (gfc_next_ascii_char ()) + { + case 'b': + radix = 2; + break; + case 'o': + radix = 8; + break; + case 'x': + /* Fall through. */ + case 'z': + radix = 16; + break; + default: + goto backup; + } + + if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix " + "syntax"), &gfc_current_locus)) + return MATCH_ERROR; + } + + gfc_current_locus = old_loc; + + buffer = (char *) alloca (length + 1); + memset (buffer, '\0', length + 1); + + match_digits (0, radix, buffer); + gfc_next_ascii_char (); /* Eat delimiter. */ + if (post == 1) + gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */ + + e = gfc_get_expr (); + e->expr_type = EXPR_CONSTANT; + e->ts.type = BT_BOZ; + e->where = gfc_current_locus; + e->boz.rdx = radix; + e->boz.len = length; + e->boz.str = XCNEWVEC (char, length + 1); + strncpy (e->boz.str, buffer, length); + + if (!gfc_in_match_data () + && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA " + "statement at %L", &e->where))) + return MATCH_ERROR; + + *result = e; + return MATCH_YES; + +backup: + gfc_current_locus = start_loc; + return MATCH_NO; +} + + +/* Match a real constant of some sort. Allow a signed constant if signflag + is nonzero. */ + +static match +match_real_constant (gfc_expr **result, int signflag) +{ + int kind, count, seen_dp, seen_digits, is_iso_c, default_exponent; + locus old_loc, temp_loc; + char *p, *buffer, c, exp_char; + gfc_expr *e; + bool negate; + + old_loc = gfc_current_locus; + gfc_gobble_whitespace (); + + e = NULL; + + default_exponent = 0; + count = 0; + seen_dp = 0; + seen_digits = 0; + exp_char = ' '; + negate = FALSE; + + c = gfc_next_ascii_char (); + if (signflag && (c == '+' || c == '-')) + { + if (c == '-') + negate = TRUE; + + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + } + + /* Scan significand. */ + for (;; c = gfc_next_ascii_char (), count++) + { + if (c == '.') + { + if (seen_dp) + goto done; + + /* Check to see if "." goes with a following operator like + ".eq.". */ + temp_loc = gfc_current_locus; + c = gfc_next_ascii_char (); + + if (c == 'e' || c == 'd' || c == 'q') + { + c = gfc_next_ascii_char (); + if (c == '.') + goto done; /* Operator named .e. or .d. */ + } + + if (ISALPHA (c)) + goto done; /* Distinguish 1.e9 from 1.eq.2 */ + + gfc_current_locus = temp_loc; + seen_dp = 1; + continue; + } + + if (ISDIGIT (c)) + { + seen_digits = 1; + continue; + } + + break; + } + + if (!seen_digits || (c != 'e' && c != 'd' && c != 'q')) + goto done; + exp_char = c; + + + if (c == 'q') + { + if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in " + "real-literal-constant at %C")) + return MATCH_ERROR; + else if (warn_real_q_constant) + gfc_warning (OPT_Wreal_q_constant, + "Extension: exponent-letter % in real-literal-constant " + "at %C"); + } + + /* Scan exponent. */ + c = gfc_next_ascii_char (); + count++; + + if (c == '+' || c == '-') + { /* optional sign */ + c = gfc_next_ascii_char (); + count++; + } + + if (!ISDIGIT (c)) + { + /* With -fdec, default exponent to 0 instead of complaining. */ + if (flag_dec) + default_exponent = 1; + else + { + gfc_error ("Missing exponent in real number at %C"); + return MATCH_ERROR; + } + } + + while (ISDIGIT (c)) + { + c = gfc_next_ascii_char (); + count++; + } + +done: + /* Check that we have a numeric constant. */ + if (!seen_digits || (!seen_dp && exp_char == ' ')) + { + gfc_current_locus = old_loc; + return MATCH_NO; + } + + /* Convert the number. */ + gfc_current_locus = old_loc; + gfc_gobble_whitespace (); + + buffer = (char *) alloca (count + default_exponent + 1); + memset (buffer, '\0', count + default_exponent + 1); + + p = buffer; + c = gfc_next_ascii_char (); + if (c == '+' || c == '-') + { + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + } + + /* Hack for mpfr_set_str(). */ + for (;;) + { + if (c == 'd' || c == 'q') + *p = 'e'; + else + *p = c; + p++; + if (--count == 0) + break; + + c = gfc_next_ascii_char (); + } + if (default_exponent) + *p++ = '0'; + + kind = get_kind (&is_iso_c); + if (kind == -1) + goto cleanup; + + if (kind == 4) + { + if (flag_real4_kind == 8) + kind = 8; + if (flag_real4_kind == 10) + kind = 10; + if (flag_real4_kind == 16) + kind = 16; + } + else if (kind == 8) + { + if (flag_real8_kind == 4) + kind = 4; + if (flag_real8_kind == 10) + kind = 10; + if (flag_real8_kind == 16) + kind = 16; + } + + switch (exp_char) + { + case 'd': + if (kind != -2) + { + gfc_error ("Real number at %C has a % exponent and an explicit " + "kind"); + goto cleanup; + } + kind = gfc_default_double_kind; + break; + + case 'q': + if (kind != -2) + { + gfc_error ("Real number at %C has a % exponent and an explicit " + "kind"); + goto cleanup; + } + + /* The maximum possible real kind type parameter is 16. First, try + that for the kind, then fallback to trying kind=10 (Intel 80 bit) + extended precision. If neither value works, just given up. */ + kind = 16; + if (gfc_validate_kind (BT_REAL, kind, true) < 0) + { + kind = 10; + if (gfc_validate_kind (BT_REAL, kind, true) < 0) + { + gfc_error ("Invalid exponent-letter % in " + "real-literal-constant at %C"); + goto cleanup; + } + } + break; + + default: + if (kind == -2) + kind = gfc_default_real_kind; + + if (gfc_validate_kind (BT_REAL, kind, true) < 0) + { + gfc_error ("Invalid real kind %d at %C", kind); + goto cleanup; + } + } + + e = convert_real (buffer, kind, &gfc_current_locus); + if (negate) + mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); + e->ts.is_c_interop = is_iso_c; + + switch (gfc_range_check (e)) + { + case ARITH_OK: + break; + case ARITH_OVERFLOW: + gfc_error ("Real constant overflows its kind at %C"); + goto cleanup; + + case ARITH_UNDERFLOW: + if (warn_underflow) + gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C"); + mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_range_check() returned bad value"); + } + + /* Warn about trailing digits which suggest the user added too many + trailing digits, which may cause the appearance of higher pecision + than the kind kan support. + + This is done by replacing the rightmost non-zero digit with zero + and comparing with the original value. If these are equal, we + assume the user supplied more digits than intended (or forgot to + convert to the correct kind). + */ + + if (warn_conversion_extra) + { + mpfr_t r; + char *c1; + bool did_break; + + c1 = strchr (buffer, 'e'); + if (c1 == NULL) + c1 = buffer + strlen(buffer); + + did_break = false; + for (p = c1; p > buffer;) + { + p--; + if (*p == '.') + continue; + + if (*p != '0') + { + *p = '0'; + did_break = true; + break; + } + } + + if (did_break) + { + mpfr_init (r); + mpfr_set_str (r, buffer, 10, GFC_RND_MODE); + if (negate) + mpfr_neg (r, r, GFC_RND_MODE); + + mpfr_sub (r, r, e->value.real, GFC_RND_MODE); + + if (mpfr_cmp_ui (r, 0) == 0) + gfc_warning (OPT_Wconversion_extra, "Non-significant digits " + "in %qs number at %C, maybe incorrect KIND", + gfc_typename (&e->ts)); + + mpfr_clear (r); + } + } + + *result = e; + return MATCH_YES; + +cleanup: + gfc_free_expr (e); + return MATCH_ERROR; +} + + +/* Match a substring reference. */ + +static match +match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred) +{ + gfc_expr *start, *end; + locus old_loc; + gfc_ref *ref; + match m; + + start = NULL; + end = NULL; + + old_loc = gfc_current_locus; + + m = gfc_match_char ('('); + if (m != MATCH_YES) + return MATCH_NO; + + if (gfc_match_char (':') != MATCH_YES) + { + if (init) + m = gfc_match_init_expr (&start); + else + m = gfc_match_expr (&start); + + if (m != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match_char (':'); + if (m != MATCH_YES) + goto cleanup; + } + + if (gfc_match_char (')') != MATCH_YES) + { + if (init) + m = gfc_match_init_expr (&end); + else + m = gfc_match_expr (&end); + + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + } + + /* Optimize away the (:) reference. */ + if (start == NULL && end == NULL && !deferred) + ref = NULL; + else + { + ref = gfc_get_ref (); + + ref->type = REF_SUBSTRING; + if (start == NULL) + start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); + ref->u.ss.start = start; + if (end == NULL && cl) + end = gfc_copy_expr (cl->length); + ref->u.ss.end = end; + ref->u.ss.length = cl; + } + + *result = ref; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in SUBSTRING specification at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_expr (start); + gfc_free_expr (end); + + gfc_current_locus = old_loc; + return m; +} + + +/* Reads the next character of a string constant, taking care to + return doubled delimiters on the input as a single instance of + the delimiter. + + Special return values for "ret" argument are: + -1 End of the string, as determined by the delimiter + -2 Unterminated string detected + + Backslash codes are also expanded at this time. */ + +static gfc_char_t +next_string_char (gfc_char_t delimiter, int *ret) +{ + locus old_locus; + gfc_char_t c; + + c = gfc_next_char_literal (INSTRING_WARN); + *ret = 0; + + if (c == '\n') + { + *ret = -2; + return 0; + } + + if (flag_backslash && c == '\\') + { + old_locus = gfc_current_locus; + + if (gfc_match_special_char (&c) == MATCH_NO) + gfc_current_locus = old_locus; + + if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) + gfc_warning (0, "Extension: backslash character at %C"); + } + + if (c != delimiter) + return c; + + old_locus = gfc_current_locus; + c = gfc_next_char_literal (NONSTRING); + + if (c == delimiter) + return c; + gfc_current_locus = old_locus; + + *ret = -1; + return 0; +} + + +/* Special case of gfc_match_name() that matches a parameter kind name + before a string constant. This takes case of the weird but legal + case of: + + kind_____'string' + + where kind____ is a parameter. gfc_match_name() will happily slurp + up all the underscores, which leads to problems. If we return + MATCH_YES, the parse pointer points to the final underscore, which + is not part of the name. We never return MATCH_ERROR-- errors in + the name will be detected later. */ + +static match +match_charkind_name (char *name) +{ + locus old_loc; + char c, peek; + int len; + + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + if (!ISALPHA (c)) + return MATCH_NO; + + *name++ = c; + len = 1; + + for (;;) + { + old_loc = gfc_current_locus; + c = gfc_next_ascii_char (); + + if (c == '_') + { + peek = gfc_peek_ascii_char (); + + if (peek == '\'' || peek == '\"') + { + gfc_current_locus = old_loc; + *name = '\0'; + return MATCH_YES; + } + } + + if (!ISALNUM (c) + && c != '_' + && (c != '$' || !flag_dollar_ok)) + break; + + *name++ = c; + if (++len > GFC_MAX_SYMBOL_LEN) + break; + } + + return MATCH_NO; +} + + +/* See if the current input matches a character constant. Lots of + contortions have to be done to match the kind parameter which comes + before the actual string. The main consideration is that we don't + want to error out too quickly. For example, we don't actually do + any validation of the kinds until we have actually seen a legal + delimiter. Using match_kind_param() generates errors too quickly. */ + +static match +match_string_constant (gfc_expr **result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1], peek; + size_t length; + int kind,save_warn_ampersand, ret; + locus old_locus, start_locus; + gfc_symbol *sym; + gfc_expr *e; + match m; + gfc_char_t c, delimiter, *p; + + old_locus = gfc_current_locus; + + gfc_gobble_whitespace (); + + c = gfc_next_char (); + if (c == '\'' || c == '"') + { + kind = gfc_default_character_kind; + start_locus = gfc_current_locus; + goto got_delim; + } + + if (gfc_wide_is_digit (c)) + { + kind = 0; + + while (gfc_wide_is_digit (c)) + { + kind = kind * 10 + c - '0'; + if (kind > 9999999) + goto no_match; + c = gfc_next_char (); + } + + } + else + { + gfc_current_locus = old_locus; + + m = match_charkind_name (name); + if (m != MATCH_YES) + goto no_match; + + if (gfc_find_symbol (name, NULL, 1, &sym) + || sym == NULL + || sym->attr.flavor != FL_PARAMETER) + goto no_match; + + kind = -1; + c = gfc_next_char (); + } + + if (c == ' ') + { + gfc_gobble_whitespace (); + c = gfc_next_char (); + } + + if (c != '_') + goto no_match; + + gfc_gobble_whitespace (); + + c = gfc_next_char (); + if (c != '\'' && c != '"') + goto no_match; + + start_locus = gfc_current_locus; + + if (kind == -1) + { + if (gfc_extract_int (sym->value, &kind, 1)) + return MATCH_ERROR; + gfc_set_sym_referenced (sym); + } + + if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0) + { + gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind); + return MATCH_ERROR; + } + +got_delim: + /* Scan the string into a block of memory by first figuring out how + long it is, allocating the structure, then re-reading it. This + isn't particularly efficient, but string constants aren't that + common in most code. TODO: Use obstacks? */ + + delimiter = c; + length = 0; + + for (;;) + { + c = next_string_char (delimiter, &ret); + if (ret == -1) + break; + if (ret == -2) + { + gfc_current_locus = start_locus; + gfc_error ("Unterminated character constant beginning at %C"); + return MATCH_ERROR; + } + + length++; + } + + /* Peek at the next character to see if it is a b, o, z, or x for the + postfixed BOZ literal constants. */ + peek = gfc_peek_ascii_char (); + if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x') + goto no_match; + + e = gfc_get_character_expr (kind, &start_locus, NULL, length); + + gfc_current_locus = start_locus; + + /* We disable the warning for the following loop as the warning has already + been printed in the loop above. */ + save_warn_ampersand = warn_ampersand; + warn_ampersand = false; + + p = e->value.character.string; + for (size_t i = 0; i < length; i++) + { + c = next_string_char (delimiter, &ret); + + if (!gfc_check_character_range (c, kind)) + { + gfc_free_expr (e); + gfc_error ("Character %qs in string at %C is not representable " + "in character kind %d", gfc_print_wide_char (c), kind); + return MATCH_ERROR; + } + + *p++ = c; + } + + *p = '\0'; /* TODO: C-style string is for development/debug purposes. */ + warn_ampersand = save_warn_ampersand; + + next_string_char (delimiter, &ret); + if (ret != -1) + gfc_internal_error ("match_string_constant(): Delimiter not found"); + + if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO) + e->expr_type = EXPR_SUBSTRING; + + /* Substrings with constant starting and ending points are eligible as + designators (F2018, section 9.1). Simplify substrings to make them usable + e.g. in data statements. */ + if (e->expr_type == EXPR_SUBSTRING + && e->ref && e->ref->type == REF_SUBSTRING + && e->ref->u.ss.start->expr_type == EXPR_CONSTANT + && (e->ref->u.ss.end == NULL + || e->ref->u.ss.end->expr_type == EXPR_CONSTANT)) + { + gfc_expr *res; + ptrdiff_t istart, iend; + size_t length; + bool equal_length = false; + + /* Basic checks on substring starting and ending indices. */ + if (!gfc_resolve_substring (e->ref, &equal_length)) + return MATCH_ERROR; + + length = e->value.character.length; + istart = gfc_mpz_get_hwi (e->ref->u.ss.start->value.integer); + if (e->ref->u.ss.end == NULL) + iend = length; + else + iend = gfc_mpz_get_hwi (e->ref->u.ss.end->value.integer); + + if (istart <= iend) + { + if (istart < 1) + { + gfc_error ("Substring start index (%ld) at %L below 1", + (long) istart, &e->ref->u.ss.start->where); + return MATCH_ERROR; + } + if (iend > (ssize_t) length) + { + gfc_error ("Substring end index (%ld) at %L exceeds string " + "length", (long) iend, &e->ref->u.ss.end->where); + return MATCH_ERROR; + } + length = iend - istart + 1; + } + else + length = 0; + + res = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where); + res->value.character.string = gfc_get_wide_string (length + 1); + res->value.character.length = length; + if (length > 0) + memcpy (res->value.character.string, + &e->value.character.string[istart - 1], + length * sizeof (gfc_char_t)); + res->value.character.string[length] = '\0'; + e = res; + } + + *result = e; + + return MATCH_YES; + +no_match: + gfc_current_locus = old_locus; + return MATCH_NO; +} + + +/* Match a .true. or .false. Returns 1 if a .true. was found, + 0 if a .false. was found, and -1 otherwise. */ +static int +match_logical_constant_string (void) +{ + locus orig_loc = gfc_current_locus; + + gfc_gobble_whitespace (); + if (gfc_next_ascii_char () == '.') + { + char ch = gfc_next_ascii_char (); + if (ch == 'f') + { + if (gfc_next_ascii_char () == 'a' + && gfc_next_ascii_char () == 'l' + && gfc_next_ascii_char () == 's' + && gfc_next_ascii_char () == 'e' + && gfc_next_ascii_char () == '.') + /* Matched ".false.". */ + return 0; + } + else if (ch == 't') + { + if (gfc_next_ascii_char () == 'r' + && gfc_next_ascii_char () == 'u' + && gfc_next_ascii_char () == 'e' + && gfc_next_ascii_char () == '.') + /* Matched ".true.". */ + return 1; + } + } + gfc_current_locus = orig_loc; + return -1; +} + +/* Match a .true. or .false. */ + +static match +match_logical_constant (gfc_expr **result) +{ + gfc_expr *e; + int i, kind, is_iso_c; + + i = match_logical_constant_string (); + if (i == -1) + return MATCH_NO; + + kind = get_kind (&is_iso_c); + if (kind == -1) + return MATCH_ERROR; + if (kind == -2) + kind = gfc_default_logical_kind; + + if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0) + { + gfc_error ("Bad kind for logical constant at %C"); + return MATCH_ERROR; + } + + e = gfc_get_logical_expr (kind, &gfc_current_locus, i); + e->ts.is_c_interop = is_iso_c; + + *result = e; + return MATCH_YES; +} + + +/* Match a real or imaginary part of a complex constant that is a + symbolic constant. */ + +static match +match_sym_complex_part (gfc_expr **result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + gfc_expr *e; + match m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL) + return MATCH_NO; + + if (sym->attr.flavor != FL_PARAMETER) + { + /* Give the matcher for implied do-loops a chance to run. This yields + a much saner error message for "write(*,*) (i, i=1, 6" where the + right parenthesis is missing. */ + char c; + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + if (c == '=' || c == ',') + { + m = MATCH_NO; + } + else + { + gfc_error ("Expected PARAMETER symbol in complex constant at %C"); + m = MATCH_ERROR; + } + return m; + } + + if (!sym->value) + goto error; + + if (!gfc_numeric_ts (&sym->value->ts)) + { + gfc_error ("Numeric PARAMETER required in complex constant at %C"); + return MATCH_ERROR; + } + + if (sym->value->rank != 0) + { + gfc_error ("Scalar PARAMETER required in complex constant at %C"); + return MATCH_ERROR; + } + + if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in " + "complex constant at %C")) + return MATCH_ERROR; + + switch (sym->value->ts.type) + { + case BT_REAL: + e = gfc_copy_expr (sym->value); + break; + + case BT_COMPLEX: + e = gfc_complex2real (sym->value, sym->value->ts.kind); + if (e == NULL) + goto error; + break; + + case BT_INTEGER: + e = gfc_int2real (sym->value, gfc_default_real_kind); + if (e == NULL) + goto error; + break; + + default: + gfc_internal_error ("gfc_match_sym_complex_part(): Bad type"); + } + + *result = e; /* e is a scalar, real, constant expression. */ + return MATCH_YES; + +error: + gfc_error ("Error converting PARAMETER constant in complex constant at %C"); + return MATCH_ERROR; +} + + +/* Match a real or imaginary part of a complex number. */ + +static match +match_complex_part (gfc_expr **result) +{ + match m; + + m = match_sym_complex_part (result); + if (m != MATCH_NO) + return m; + + m = match_real_constant (result, 1); + if (m != MATCH_NO) + return m; + + return match_integer_constant (result, 1); +} + + +/* Try to match a complex constant. */ + +static match +match_complex_constant (gfc_expr **result) +{ + gfc_expr *e, *real, *imag; + gfc_error_buffer old_error; + gfc_typespec target; + locus old_loc; + int kind; + match m; + + old_loc = gfc_current_locus; + real = imag = e = NULL; + + m = gfc_match_char ('('); + if (m != MATCH_YES) + return m; + + gfc_push_error (&old_error); + + m = match_complex_part (&real); + if (m == MATCH_NO) + { + gfc_free_error (&old_error); + goto cleanup; + } + + if (gfc_match_char (',') == MATCH_NO) + { + /* It is possible that gfc_int2real issued a warning when + converting an integer to real. Throw this away here. */ + + gfc_clear_warning (); + gfc_pop_error (&old_error); + m = MATCH_NO; + goto cleanup; + } + + /* If m is error, then something was wrong with the real part and we + assume we have a complex constant because we've seen the ','. An + ambiguous case here is the start of an iterator list of some + sort. These sort of lists are matched prior to coming here. */ + + if (m == MATCH_ERROR) + { + gfc_free_error (&old_error); + goto cleanup; + } + gfc_pop_error (&old_error); + + m = match_complex_part (&imag); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + { + /* Give the matcher for implied do-loops a chance to run. This + yields a much saner error message for (/ (i, 4=i, 6) /). */ + if (gfc_peek_ascii_char () == '=') + { + m = MATCH_ERROR; + goto cleanup; + } + else + goto syntax; + } + + if (m == MATCH_ERROR) + goto cleanup; + + /* Decide on the kind of this complex number. */ + if (real->ts.type == BT_REAL) + { + if (imag->ts.type == BT_REAL) + kind = gfc_kind_max (real, imag); + else + kind = real->ts.kind; + } + else + { + if (imag->ts.type == BT_REAL) + kind = imag->ts.kind; + else + kind = gfc_default_real_kind; + } + gfc_clear_ts (&target); + target.type = BT_REAL; + target.kind = kind; + + if (real->ts.type != BT_REAL || kind != real->ts.kind) + gfc_convert_type (real, &target, 2); + if (imag->ts.type != BT_REAL || kind != imag->ts.kind) + gfc_convert_type (imag, &target, 2); + + e = convert_complex (real, imag, kind); + e->where = gfc_current_locus; + + gfc_free_expr (real); + gfc_free_expr (imag); + + *result = e; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in COMPLEX constant at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_expr (e); + gfc_free_expr (real); + gfc_free_expr (imag); + gfc_current_locus = old_loc; + + return m; +} + + +/* Match constants in any of several forms. Returns nonzero for a + match, zero for no match. */ + +match +gfc_match_literal_constant (gfc_expr **result, int signflag) +{ + match m; + + m = match_complex_constant (result); + if (m != MATCH_NO) + return m; + + m = match_string_constant (result); + if (m != MATCH_NO) + return m; + + m = match_boz_constant (result); + if (m != MATCH_NO) + return m; + + m = match_real_constant (result, signflag); + if (m != MATCH_NO) + return m; + + m = match_hollerith_constant (result); + if (m != MATCH_NO) + return m; + + m = match_integer_constant (result, signflag); + if (m != MATCH_NO) + return m; + + m = match_logical_constant (result); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* This checks if a symbol is the return value of an encompassing function. + Function nesting can be maximally two levels deep, but we may have + additional local namespaces like BLOCK etc. */ + +bool +gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns) +{ + if (!sym->attr.function || (sym->result != sym)) + return false; + while (ns) + { + if (ns->proc_name == sym) + return true; + ns = ns->parent; + } + return false; +} + + +/* Match a single actual argument value. An actual argument is + usually an expression, but can also be a procedure name. If the + argument is a single name, it is not always possible to tell + whether the name is a dummy procedure or not. We treat these cases + by creating an argument that looks like a dummy procedure and + fixing things later during resolution. */ + +static match +match_actual_arg (gfc_expr **result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree *symtree; + locus where, w; + gfc_expr *e; + char c; + + gfc_gobble_whitespace (); + where = gfc_current_locus; + + switch (gfc_match_name (name)) + { + case MATCH_ERROR: + return MATCH_ERROR; + + case MATCH_NO: + break; + + case MATCH_YES: + w = gfc_current_locus; + gfc_gobble_whitespace (); + c = gfc_next_ascii_char (); + gfc_current_locus = w; + + if (c != ',' && c != ')') + break; + + if (gfc_find_sym_tree (name, NULL, 1, &symtree)) + break; + /* Handle error elsewhere. */ + + /* Eliminate a couple of common cases where we know we don't + have a function argument. */ + if (symtree == NULL) + { + gfc_get_sym_tree (name, NULL, &symtree, false); + gfc_set_sym_referenced (symtree->n.sym); + } + else + { + gfc_symbol *sym; + + sym = symtree->n.sym; + gfc_set_sym_referenced (sym); + if (sym->attr.flavor == FL_NAMELIST) + { + gfc_error ("Namelist %qs cannot be an argument at %L", + sym->name, &where); + break; + } + if (sym->attr.flavor != FL_PROCEDURE + && sym->attr.flavor != FL_UNKNOWN) + break; + + if (sym->attr.in_common && !sym->attr.proc_pointer) + { + if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, + sym->name, &sym->declared_at)) + return MATCH_ERROR; + break; + } + + /* If the symbol is a function with itself as the result and + is being defined, then we have a variable. */ + if (sym->attr.function && sym->result == sym) + { + if (gfc_is_function_return_value (sym, gfc_current_ns)) + break; + + if (sym->attr.entry + && (sym->ns == gfc_current_ns + || sym->ns == gfc_current_ns->parent)) + { + gfc_entry_list *el = NULL; + + for (el = sym->ns->entries; el; el = el->next) + if (sym == el->sym) + break; + + if (el) + break; + } + } + } + + e = gfc_get_expr (); /* Leave it unknown for now */ + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + e->ts.type = BT_PROCEDURE; + e->where = where; + + *result = e; + return MATCH_YES; + } + + gfc_current_locus = where; + return gfc_match_expr (result); +} + + +/* Match a keyword argument or type parameter spec list.. */ + +static match +match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_actual_arglist *a; + locus name_locus; + match m; + + name_locus = gfc_current_locus; + m = gfc_match_name (name); + + if (m != MATCH_YES) + goto cleanup; + if (gfc_match_char ('=') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + if (pdt) + { + if (gfc_match_char ('*') == MATCH_YES) + { + actual->spec_type = SPEC_ASSUMED; + goto add_name; + } + else if (gfc_match_char (':') == MATCH_YES) + { + actual->spec_type = SPEC_DEFERRED; + goto add_name; + } + else + actual->spec_type = SPEC_EXPLICIT; + } + + m = match_actual_arg (&actual->expr); + if (m != MATCH_YES) + goto cleanup; + + /* Make sure this name has not appeared yet. */ +add_name: + if (name[0] != '\0') + { + for (a = base; a; a = a->next) + if (a->name != NULL && strcmp (a->name, name) == 0) + { + gfc_error ("Keyword %qs at %C has already appeared in the " + "current argument list", name); + return MATCH_ERROR; + } + } + + actual->name = gfc_get_string ("%s", name); + return MATCH_YES; + +cleanup: + gfc_current_locus = name_locus; + return m; +} + + +/* Match an argument list function, such as %VAL. */ + +static match +match_arg_list_function (gfc_actual_arglist *result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + match m; + + old_locus = gfc_current_locus; + + if (gfc_match_char ('%') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match ("%n (", name); + if (m != MATCH_YES) + goto cleanup; + + if (name[0] != '\0') + { + switch (name[0]) + { + case 'l': + if (startswith (name, "loc")) + { + result->name = "%LOC"; + break; + } + /* FALLTHRU */ + case 'r': + if (startswith (name, "ref")) + { + result->name = "%REF"; + break; + } + /* FALLTHRU */ + case 'v': + if (startswith (name, "val")) + { + result->name = "%VAL"; + break; + } + /* FALLTHRU */ + default: + m = MATCH_ERROR; + goto cleanup; + } + } + + if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C")) + { + m = MATCH_ERROR; + goto cleanup; + } + + m = match_actual_arg (&result->expr); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + return MATCH_YES; + +cleanup: + gfc_current_locus = old_locus; + return m; +} + + +/* Matches an actual argument list of a function or subroutine, from + the opening parenthesis to the closing parenthesis. The argument + list is assumed to allow keyword arguments because we don't know if + the symbol associated with the procedure has an implicit interface + or not. We make sure keywords are unique. If sub_flag is set, + we're matching the argument list of a subroutine. + + NOTE: An alternative use for this function is to match type parameter + spec lists, which are so similar to actual argument lists that the + machinery can be reused. This use is flagged by the optional argument + 'pdt'. */ + +match +gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) +{ + gfc_actual_arglist *head, *tail; + int seen_keyword; + gfc_st_label *label; + locus old_loc; + match m; + + *argp = tail = NULL; + old_loc = gfc_current_locus; + + seen_keyword = 0; + + if (gfc_match_char ('(') == MATCH_NO) + return (sub_flag) ? MATCH_YES : MATCH_NO; + + if (gfc_match_char (')') == MATCH_YES) + return MATCH_YES; + + head = NULL; + + matching_actual_arglist++; + + for (;;) + { + if (head == NULL) + head = tail = gfc_get_actual_arglist (); + else + { + tail->next = gfc_get_actual_arglist (); + tail = tail->next; + } + + if (sub_flag && !pdt && gfc_match_char ('*') == MATCH_YES) + { + m = gfc_match_st_label (&label); + if (m == MATCH_NO) + gfc_error ("Expected alternate return label at %C"); + if (m != MATCH_YES) + goto cleanup; + + if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument " + "at %C")) + goto cleanup; + + tail->label = label; + goto next; + } + + if (pdt && !seen_keyword) + { + if (gfc_match_char (':') == MATCH_YES) + { + tail->spec_type = SPEC_DEFERRED; + goto next; + } + else if (gfc_match_char ('*') == MATCH_YES) + { + tail->spec_type = SPEC_ASSUMED; + goto next; + } + else + tail->spec_type = SPEC_EXPLICIT; + + m = match_keyword_arg (tail, head, pdt); + if (m == MATCH_YES) + { + seen_keyword = 1; + goto next; + } + if (m == MATCH_ERROR) + goto cleanup; + } + + /* After the first keyword argument is seen, the following + arguments must also have keywords. */ + if (seen_keyword) + { + m = match_keyword_arg (tail, head, pdt); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + gfc_error ("Missing keyword name in actual argument list at %C"); + goto cleanup; + } + + } + else + { + /* Try an argument list function, like %VAL. */ + m = match_arg_list_function (tail); + if (m == MATCH_ERROR) + goto cleanup; + + /* See if we have the first keyword argument. */ + if (m == MATCH_NO) + { + m = match_keyword_arg (tail, head, false); + if (m == MATCH_YES) + seen_keyword = 1; + if (m == MATCH_ERROR) + goto cleanup; + } + + if (m == MATCH_NO) + { + /* Try for a non-keyword argument. */ + m = match_actual_arg (&tail->expr); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + } + + + next: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + *argp = head; + matching_actual_arglist--; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in argument list at %C"); + +cleanup: + gfc_free_actual_arglist (head); + gfc_current_locus = old_loc; + matching_actual_arglist--; + return MATCH_ERROR; +} + + +/* Used by gfc_match_varspec() to extend the reference list by one + element. */ + +static gfc_ref * +extend_ref (gfc_expr *primary, gfc_ref *tail) +{ + if (primary->ref == NULL) + primary->ref = tail = gfc_get_ref (); + else + { + if (tail == NULL) + gfc_internal_error ("extend_ref(): Bad tail"); + tail->next = gfc_get_ref (); + tail = tail->next; + } + + return tail; +} + + +/* Used by gfc_match_varspec() to match an inquiry reference. */ + +static bool +is_inquiry_ref (const char *name, gfc_ref **ref) +{ + inquiry_type type; + + if (name == NULL) + return false; + + if (ref) *ref = NULL; + + if (strcmp (name, "re") == 0) + type = INQUIRY_RE; + else if (strcmp (name, "im") == 0) + type = INQUIRY_IM; + else if (strcmp (name, "kind") == 0) + type = INQUIRY_KIND; + else if (strcmp (name, "len") == 0) + type = INQUIRY_LEN; + else + return false; + + if (ref) + { + *ref = gfc_get_ref (); + (*ref)->type = REF_INQUIRY; + (*ref)->u.i = type; + } + + return true; +} + + +/* Match any additional specifications associated with the current + variable like member references or substrings. If equiv_flag is + set we only match stuff that is allowed inside an EQUIVALENCE + statement. sub_flag tells whether we expect a type-bound procedure found + to be a subroutine as part of CALL or a FUNCTION. For procedure pointer + components, 'ppc_arg' determines whether the PPC may be called (with an + argument list), or whether it may just be referred to as a pointer. */ + +match +gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, + bool ppc_arg) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_ref *substring, *tail, *tmp; + gfc_component *component = NULL; + gfc_component *previous = NULL; + gfc_symbol *sym = primary->symtree->n.sym; + gfc_expr *tgt_expr = NULL; + match m; + bool unknown; + bool inquiry; + bool intrinsic; + locus old_loc; + char sep; + + tail = NULL; + + gfc_gobble_whitespace (); + + if (gfc_peek_ascii_char () == '[') + { + if ((sym->ts.type != BT_CLASS && sym->attr.dimension) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.dimension)) + { + gfc_error ("Array section designator, e.g. '(:)', is required " + "besides the coarray designator '[...]' at %C"); + return MATCH_ERROR; + } + if ((sym->ts.type != BT_CLASS && !sym->attr.codimension) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && !CLASS_DATA (sym)->attr.codimension)) + { + gfc_error ("Coarray designator at %C but %qs is not a coarray", + sym->name); + return MATCH_ERROR; + } + } + + if (sym->assoc && sym->assoc->target) + tgt_expr = sym->assoc->target; + + /* For associate names, we may not yet know whether they are arrays or not. + If the selector expression is unambiguously an array; eg. a full array + or an array section, then the associate name must be an array and we can + fix it now. Otherwise, if parentheses follow and it is not a character + type, we have to assume that it actually is one for now. The final + decision will be made at resolution, of course. */ + if (sym->assoc + && gfc_peek_ascii_char () == '(' + && sym->ts.type != BT_CLASS + && !sym->attr.dimension) + { + gfc_ref *ref = NULL; + + if (!sym->assoc->dangling && tgt_expr) + { + if (tgt_expr->expr_type == EXPR_VARIABLE) + gfc_resolve_expr (tgt_expr); + + ref = tgt_expr->ref; + for (; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && (ref->u.ar.type == AR_FULL + || ref->u.ar.type == AR_SECTION)) + break; + } + + if (ref || (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER) + && sym->assoc->st + && sym->assoc->st->n.sym + && sym->assoc->st->n.sym->attr.dimension == 0)) + { + sym->attr.dimension = 1; + if (sym->as == NULL + && sym->assoc->st + && sym->assoc->st->n.sym + && sym->assoc->st->n.sym->as) + sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as); + } + } + else if (sym->ts.type == BT_CLASS + && tgt_expr + && tgt_expr->expr_type == EXPR_VARIABLE + && sym->ts.u.derived != tgt_expr->ts.u.derived) + { + gfc_resolve_expr (tgt_expr); + if (tgt_expr->rank) + sym->ts.u.derived = tgt_expr->ts.u.derived; + } + + if ((equiv_flag && gfc_peek_ascii_char () == '(') + || gfc_peek_ascii_char () == '[' || sym->attr.codimension + || (sym->attr.dimension && sym->ts.type != BT_CLASS + && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary) + && !(gfc_matching_procptr_assignment + && sym->attr.flavor == FL_PROCEDURE)) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension))) + { + gfc_array_spec *as; + + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + + /* In EQUIVALENCE, we don't know yet whether we are seeing + an array, character variable or array of character + variables. We'll leave the decision till resolve time. */ + + if (equiv_flag) + as = NULL; + else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + as = CLASS_DATA (sym)->as; + else + as = sym->as; + + m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, + as ? as->corank : 0); + if (m != MATCH_YES) + return m; + + gfc_gobble_whitespace (); + if (equiv_flag && gfc_peek_ascii_char () == '(') + { + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + + m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0); + if (m != MATCH_YES) + return m; + } + } + + primary->ts = sym->ts; + + if (equiv_flag) + return MATCH_YES; + + /* With DEC extensions, member separator may be '.' or '%'. */ + sep = gfc_peek_ascii_char (); + m = gfc_match_member_sep (sym); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + inquiry = false; + if (m == MATCH_YES && sep == '%' + && primary->ts.type != BT_CLASS + && primary->ts.type != BT_DERIVED) + { + match mm; + old_loc = gfc_current_locus; + mm = gfc_match_name (name); + if (mm == MATCH_YES && is_inquiry_ref (name, &tmp)) + inquiry = true; + gfc_current_locus = old_loc; + } + + if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES + && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) + gfc_set_default_type (sym, 0, sym->ns); + + /* See if there is a usable typespec in the "no IMPLICIT type" error. */ + if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES) + { + bool permissible; + + /* These target expressions can be resolved at any time. */ + permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym + && (tgt_expr->symtree->n.sym->attr.use_assoc + || tgt_expr->symtree->n.sym->attr.host_assoc + || tgt_expr->symtree->n.sym->attr.if_source + == IFSRC_DECL); + permissible = permissible + || (tgt_expr && tgt_expr->expr_type == EXPR_OP); + + if (permissible) + { + gfc_resolve_expr (tgt_expr); + sym->ts = tgt_expr->ts; + } + + if (sym->ts.type == BT_UNKNOWN) + { + gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name); + return MATCH_ERROR; + } + } + else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) + && m == MATCH_YES && !inquiry) + { + gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C", + sep, sym->name); + return MATCH_ERROR; + } + + if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && !inquiry) + || m != MATCH_YES) + goto check_substring; + + if (!inquiry) + sym = sym->ts.u.derived; + else + sym = NULL; + + for (;;) + { + bool t; + gfc_symtree *tbp; + + m = gfc_match_name (name); + if (m == MATCH_NO) + gfc_error ("Expected structure component name at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + + intrinsic = false; + if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED) + { + inquiry = is_inquiry_ref (name, &tmp); + if (inquiry) + sym = NULL; + + if (sep == '%') + { + if (tmp) + { + switch (tmp->u.i) + { + case INQUIRY_RE: + case INQUIRY_IM: + if (!gfc_notify_std (GFC_STD_F2008, + "RE or IM part_ref at %C")) + return MATCH_ERROR; + break; + + case INQUIRY_KIND: + if (!gfc_notify_std (GFC_STD_F2003, + "KIND part_ref at %C")) + return MATCH_ERROR; + break; + + case INQUIRY_LEN: + if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) + return MATCH_ERROR; + break; + } + + if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM) + && primary->ts.type != BT_COMPLEX) + { + gfc_error ("The RE or IM part_ref at %C must be " + "applied to a COMPLEX expression"); + return MATCH_ERROR; + } + else if (tmp->u.i == INQUIRY_LEN + && primary->ts.type != BT_CHARACTER) + { + gfc_error ("The LEN part_ref at %C must be applied " + "to a CHARACTER expression"); + return MATCH_ERROR; + } + } + if (primary->ts.type != BT_UNKNOWN) + intrinsic = true; + } + } + else + inquiry = false; + + if (sym && sym->f2k_derived) + tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus); + else + tbp = NULL; + + if (tbp) + { + gfc_symbol* tbp_sym; + + if (!t) + return MATCH_ERROR; + + gcc_assert (!tail || !tail->next); + + if (!(primary->expr_type == EXPR_VARIABLE + || (primary->expr_type == EXPR_STRUCTURE + && primary->symtree && primary->symtree->n.sym + && primary->symtree->n.sym->attr.flavor))) + return MATCH_ERROR; + + if (tbp->n.tb->is_generic) + tbp_sym = NULL; + else + tbp_sym = tbp->n.tb->u.specific->n.sym; + + primary->expr_type = EXPR_COMPCALL; + primary->value.compcall.tbp = tbp->n.tb; + primary->value.compcall.name = tbp->name; + primary->value.compcall.ignore_pass = 0; + primary->value.compcall.assign = 0; + primary->value.compcall.base_object = NULL; + gcc_assert (primary->symtree->n.sym->attr.referenced); + if (tbp_sym) + primary->ts = tbp_sym->ts; + else + gfc_clear_ts (&primary->ts); + + m = gfc_match_actual_arglist (tbp->n.tb->subroutine, + &primary->value.compcall.actual); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + { + if (sub_flag) + primary->value.compcall.actual = NULL; + else + { + gfc_error ("Expected argument list at %C"); + return MATCH_ERROR; + } + } + + break; + } + + previous = component; + + if (!inquiry && !intrinsic) + component = gfc_find_component (sym, name, false, false, &tmp); + else + component = NULL; + + if (intrinsic && !inquiry) + { + if (previous) + gfc_error ("%qs at %C is not an inquiry reference to an intrinsic " + "type component %qs", name, previous->name); + else + gfc_error ("%qs at %C is not an inquiry reference to an intrinsic " + "type component", name); + return MATCH_ERROR; + } + else if (component == NULL && !inquiry) + return MATCH_ERROR; + + /* Extend the reference chain determined by gfc_find_component or + is_inquiry_ref. */ + if (primary->ref == NULL) + primary->ref = tmp; + else + { + /* Set by the for loop below for the last component ref. */ + gcc_assert (tail != NULL); + tail->next = tmp; + } + + /* The reference chain may be longer than one hop for union + subcomponents; find the new tail. */ + for (tail = tmp; tail->next; tail = tail->next) + ; + + if (tmp && tmp->type == REF_INQUIRY) + { + if (!primary->where.lb || !primary->where.nextc) + primary->where = gfc_current_locus; + gfc_simplify_expr (primary, 0); + + if (primary->expr_type == EXPR_CONSTANT) + goto check_done; + + switch (tmp->u.i) + { + case INQUIRY_RE: + case INQUIRY_IM: + if (!gfc_notify_std (GFC_STD_F2008, "RE or IM part_ref at %C")) + return MATCH_ERROR; + + if (primary->ts.type != BT_COMPLEX) + { + gfc_error ("The RE or IM part_ref at %C must be " + "applied to a COMPLEX expression"); + return MATCH_ERROR; + } + primary->ts.type = BT_REAL; + break; + + case INQUIRY_LEN: + if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) + return MATCH_ERROR; + + if (primary->ts.type != BT_CHARACTER) + { + gfc_error ("The LEN part_ref at %C must be applied " + "to a CHARACTER expression"); + return MATCH_ERROR; + } + primary->ts.u.cl = NULL; + primary->ts.type = BT_INTEGER; + primary->ts.kind = gfc_default_integer_kind; + break; + + case INQUIRY_KIND: + if (!gfc_notify_std (GFC_STD_F2003, "KIND part_ref at %C")) + return MATCH_ERROR; + + if (primary->ts.type == BT_CLASS + || primary->ts.type == BT_DERIVED) + { + gfc_error ("The KIND part_ref at %C must be applied " + "to an expression of intrinsic type"); + return MATCH_ERROR; + } + primary->ts.type = BT_INTEGER; + primary->ts.kind = gfc_default_integer_kind; + break; + + default: + gcc_unreachable (); + } + + goto check_done; + } + + primary->ts = component->ts; + + if (component->attr.proc_pointer && ppc_arg) + { + /* Procedure pointer component call: Look for argument list. */ + m = gfc_match_actual_arglist (sub_flag, + &primary->value.compcall.actual); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (m == MATCH_NO && !gfc_matching_ptr_assignment + && !gfc_matching_procptr_assignment && !matching_actual_arglist) + { + gfc_error ("Procedure pointer component %qs requires an " + "argument list at %C", component->name); + return MATCH_ERROR; + } + + if (m == MATCH_YES) + primary->expr_type = EXPR_PPC; + + break; + } + + if (component->as != NULL && !component->attr.proc_pointer) + { + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + + m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag, + component->as->corank); + if (m != MATCH_YES) + return m; + } + else if (component->ts.type == BT_CLASS && component->attr.class_ok + && CLASS_DATA (component)->as && !component->attr.proc_pointer) + { + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + + m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as, + equiv_flag, + CLASS_DATA (component)->as->corank); + if (m != MATCH_YES) + return m; + } + +check_done: + /* In principle, we could have eg. expr%re%kind so we must allow for + this possibility. */ + if (gfc_match_char ('%') == MATCH_YES) + { + if (component && (component->ts.type == BT_DERIVED + || component->ts.type == BT_CLASS)) + sym = component->ts.u.derived; + continue; + } + else if (inquiry) + break; + + if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS) + || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES) + break; + + if (component->ts.type == BT_DERIVED || component->ts.type == BT_CLASS) + sym = component->ts.u.derived; + } + +check_substring: + unknown = false; + if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor)) + { + if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER) + { + gfc_set_default_type (sym, 0, sym->ns); + primary->ts = sym->ts; + unknown = true; + } + } + + if (primary->ts.type == BT_CHARACTER) + { + bool def = primary->ts.deferred == 1; + switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def)) + { + case MATCH_YES: + if (tail == NULL) + primary->ref = substring; + else + tail->next = substring; + + if (primary->expr_type == EXPR_CONSTANT) + primary->expr_type = EXPR_SUBSTRING; + + if (substring) + primary->ts.u.cl = NULL; + + break; + + case MATCH_NO: + if (unknown) + { + gfc_clear_ts (&primary->ts); + gfc_clear_ts (&sym->ts); + } + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + } + + /* F08:C611. */ + if (primary->ts.type == BT_DERIVED && primary->ref + && primary->ts.u.derived && primary->ts.u.derived->attr.abstract) + { + gfc_error ("Nonpolymorphic reference to abstract type at %C"); + return MATCH_ERROR; + } + + /* F08:C727. */ + if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary)) + { + gfc_error ("Coindexed procedure-pointer component at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Given an expression that is a variable, figure out what the + ultimate variable's type and attribute is, traversing the reference + structures if necessary. + + This subroutine is trickier than it looks. We start at the base + symbol and store the attribute. Component references load a + completely new attribute. + + A couple of rules come into play. Subobjects of targets are always + targets themselves. If we see a component that goes through a + pointer, then the expression must also be a target, since the + pointer is associated with something (if it isn't core will soon be + dumped). If we see a full part or section of an array, the + expression is also an array. + + We can have at most one full array reference. */ + +symbol_attribute +gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) +{ + int dimension, codimension, pointer, allocatable, target, optional; + symbol_attribute attr; + gfc_ref *ref; + gfc_symbol *sym; + gfc_component *comp; + bool has_inquiry_part; + + if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) + gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable"); + + sym = expr->symtree->n.sym; + attr = sym->attr; + + optional = attr.optional; + if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) + { + dimension = CLASS_DATA (sym)->attr.dimension; + codimension = CLASS_DATA (sym)->attr.codimension; + pointer = CLASS_DATA (sym)->attr.class_pointer; + allocatable = CLASS_DATA (sym)->attr.allocatable; + optional |= CLASS_DATA (sym)->attr.optional; + } + else + { + dimension = attr.dimension; + codimension = attr.codimension; + pointer = attr.pointer; + allocatable = attr.allocatable; + } + + target = attr.target; + if (pointer || attr.proc_pointer) + target = 1; + + if (ts != NULL && expr->ts.type == BT_UNKNOWN) + *ts = sym->ts; + + has_inquiry_part = false; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_INQUIRY) + { + has_inquiry_part = true; + optional = false; + break; + } + + for (ref = expr->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + + switch (ref->u.ar.type) + { + case AR_FULL: + dimension = 1; + break; + + case AR_SECTION: + allocatable = pointer = 0; + dimension = 1; + optional = false; + break; + + case AR_ELEMENT: + /* Handle coarrays. */ + if (ref->u.ar.dimen > 0) + allocatable = pointer = optional = false; + break; + + case AR_UNKNOWN: + /* For standard conforming code, AR_UNKNOWN should not happen. + For nonconforming code, gfortran can end up here. Treat it + as a no-op. */ + break; + } + + break; + + case REF_COMPONENT: + optional = false; + comp = ref->u.c.component; + attr = comp->attr; + if (ts != NULL && !has_inquiry_part) + { + *ts = comp->ts; + /* Don't set the string length if a substring reference + follows. */ + if (ts->type == BT_CHARACTER + && ref->next && ref->next->type == REF_SUBSTRING) + ts->u.cl = NULL; + } + + if (comp->ts.type == BT_CLASS) + { + codimension = CLASS_DATA (comp)->attr.codimension; + pointer = CLASS_DATA (comp)->attr.class_pointer; + allocatable = CLASS_DATA (comp)->attr.allocatable; + } + else + { + codimension = comp->attr.codimension; + if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0) + pointer = comp->attr.class_pointer; + else + pointer = comp->attr.pointer; + allocatable = comp->attr.allocatable; + } + if (pointer || attr.proc_pointer) + target = 1; + + break; + + case REF_INQUIRY: + case REF_SUBSTRING: + allocatable = pointer = optional = false; + break; + } + + attr.dimension = dimension; + attr.codimension = codimension; + attr.pointer = pointer; + attr.allocatable = allocatable; + attr.target = target; + attr.save = sym->attr.save; + attr.optional = optional; + + return attr; +} + + +/* Return the attribute from a general expression. */ + +symbol_attribute +gfc_expr_attr (gfc_expr *e) +{ + symbol_attribute attr; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + attr = gfc_variable_attr (e, NULL); + break; + + case EXPR_FUNCTION: + gfc_clear_attr (&attr); + + if (e->value.function.esym && e->value.function.esym->result) + { + gfc_symbol *sym = e->value.function.esym->result; + attr = sym->attr; + if (sym->ts.type == BT_CLASS) + { + attr.dimension = CLASS_DATA (sym)->attr.dimension; + attr.pointer = CLASS_DATA (sym)->attr.class_pointer; + attr.allocatable = CLASS_DATA (sym)->attr.allocatable; + } + } + else if (e->value.function.isym + && e->value.function.isym->transformational + && e->ts.type == BT_CLASS) + attr = CLASS_DATA (e)->attr; + else if (e->symtree) + attr = gfc_variable_attr (e, NULL); + + /* TODO: NULL() returns pointers. May have to take care of this + here. */ + + break; + + default: + gfc_clear_attr (&attr); + break; + } + + return attr; +} + + +/* Given an expression, figure out what the ultimate expression + attribute is. This routine is similar to gfc_variable_attr with + parts of gfc_expr_attr, but focuses more on the needs of + coarrays. For coarrays a codimension attribute is kind of + "infectious" being propagated once set and never cleared. + The coarray_comp is only set, when the expression refs a coarray + component. REFS_COMP is set when present to true only, when this EXPR + refs a (non-_data) component. To check whether EXPR refs an allocatable + component in a derived type coarray *refs_comp needs to be set and + coarray_comp has to false. */ + +static symbol_attribute +caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp) +{ + int dimension, codimension, pointer, allocatable, target, coarray_comp; + symbol_attribute attr; + gfc_ref *ref; + gfc_symbol *sym; + gfc_component *comp; + + if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION) + gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable"); + + sym = expr->symtree->n.sym; + gfc_clear_attr (&attr); + + if (refs_comp) + *refs_comp = false; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + { + dimension = CLASS_DATA (sym)->attr.dimension; + codimension = CLASS_DATA (sym)->attr.codimension; + pointer = CLASS_DATA (sym)->attr.class_pointer; + allocatable = CLASS_DATA (sym)->attr.allocatable; + attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp; + attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp; + } + else + { + dimension = sym->attr.dimension; + codimension = sym->attr.codimension; + pointer = sym->attr.pointer; + allocatable = sym->attr.allocatable; + attr.alloc_comp = sym->ts.type == BT_DERIVED + ? sym->ts.u.derived->attr.alloc_comp : 0; + attr.pointer_comp = sym->ts.type == BT_DERIVED + ? sym->ts.u.derived->attr.pointer_comp : 0; + } + + target = coarray_comp = 0; + if (pointer || attr.proc_pointer) + target = 1; + + for (ref = expr->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + + switch (ref->u.ar.type) + { + case AR_FULL: + case AR_SECTION: + dimension = 1; + break; + + case AR_ELEMENT: + /* Handle coarrays. */ + if (ref->u.ar.dimen > 0 && !in_allocate) + allocatable = pointer = 0; + break; + + case AR_UNKNOWN: + /* If any of start, end or stride is not integer, there will + already have been an error issued. */ + int errors; + gfc_get_errors (NULL, &errors); + if (errors == 0) + gfc_internal_error ("gfc_caf_attr(): Bad array reference"); + } + + break; + + case REF_COMPONENT: + comp = ref->u.c.component; + + if (comp->ts.type == BT_CLASS) + { + /* Set coarray_comp only, when this component introduces the + coarray. */ + coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension; + codimension |= CLASS_DATA (comp)->attr.codimension; + pointer = CLASS_DATA (comp)->attr.class_pointer; + allocatable = CLASS_DATA (comp)->attr.allocatable; + } + else + { + /* Set coarray_comp only, when this component introduces the + coarray. */ + coarray_comp = !codimension && comp->attr.codimension; + codimension |= comp->attr.codimension; + pointer = comp->attr.pointer; + allocatable = comp->attr.allocatable; + } + + if (refs_comp && strcmp (comp->name, "_data") != 0 + && (ref->next == NULL + || (ref->next->type == REF_ARRAY && ref->next->next == NULL))) + *refs_comp = true; + + if (pointer || attr.proc_pointer) + target = 1; + + break; + + case REF_SUBSTRING: + case REF_INQUIRY: + allocatable = pointer = 0; + break; + } + + attr.dimension = dimension; + attr.codimension = codimension; + attr.pointer = pointer; + attr.allocatable = allocatable; + attr.target = target; + attr.save = sym->attr.save; + attr.coarray_comp = coarray_comp; + + return attr; +} + + +symbol_attribute +gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp) +{ + symbol_attribute attr; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + attr = caf_variable_attr (e, in_allocate, refs_comp); + break; + + case EXPR_FUNCTION: + gfc_clear_attr (&attr); + + if (e->value.function.esym && e->value.function.esym->result) + { + gfc_symbol *sym = e->value.function.esym->result; + attr = sym->attr; + if (sym->ts.type == BT_CLASS) + { + attr.dimension = CLASS_DATA (sym)->attr.dimension; + attr.pointer = CLASS_DATA (sym)->attr.class_pointer; + attr.allocatable = CLASS_DATA (sym)->attr.allocatable; + attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp; + attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived + ->attr.pointer_comp; + } + } + else if (e->symtree) + attr = caf_variable_attr (e, in_allocate, refs_comp); + else + gfc_clear_attr (&attr); + break; + + default: + gfc_clear_attr (&attr); + break; + } + + return attr; +} + + +/* Match a structure constructor. The initial symbol has already been + seen. */ + +typedef struct gfc_structure_ctor_component +{ + char* name; + gfc_expr* val; + locus where; + struct gfc_structure_ctor_component* next; +} +gfc_structure_ctor_component; + +#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component) + +static void +gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp) +{ + free (comp->name); + gfc_free_expr (comp->val); + free (comp); +} + + +/* Translate the component list into the actual constructor by sorting it in + the order required; this also checks along the way that each and every + component actually has an initializer and handles default initializers + for components without explicit value given. */ +static bool +build_actual_constructor (gfc_structure_ctor_component **comp_head, + gfc_constructor_base *ctor_head, gfc_symbol *sym) +{ + gfc_structure_ctor_component *comp_iter; + gfc_component *comp; + + for (comp = sym->components; comp; comp = comp->next) + { + gfc_structure_ctor_component **next_ptr; + gfc_expr *value = NULL; + + /* Try to find the initializer for the current component by name. */ + next_ptr = comp_head; + for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next) + { + if (!strcmp (comp_iter->name, comp->name)) + break; + next_ptr = &comp_iter->next; + } + + /* If an extension, try building the parent derived type by building + a value expression for the parent derived type and calling self. */ + if (!comp_iter && comp == sym->components && sym->attr.extension) + { + value = gfc_get_structure_constructor_expr (comp->ts.type, + comp->ts.kind, + &gfc_current_locus); + value->ts = comp->ts; + + if (!build_actual_constructor (comp_head, + &value->value.constructor, + comp->ts.u.derived)) + { + gfc_free_expr (value); + return false; + } + + gfc_constructor_append_expr (ctor_head, value, NULL); + continue; + } + + /* If it was not found, apply NULL expression to set the component as + unallocated. Then try the default initializer if there's any; + otherwise, it's an error unless this is a deferred parameter. */ + if (!comp_iter) + { + /* F2018 7.5.10: If an allocatable component has no corresponding + component-data-source, then that component has an allocation + status of unallocated.... */ + if (comp->attr.allocatable + || (comp->ts.type == BT_CLASS + && CLASS_DATA (comp)->attr.allocatable)) + { + if (!gfc_notify_std (GFC_STD_F2008, "No initializer for " + "allocatable component %qs given in the " + "structure constructor at %C", comp->name)) + return false; + value = gfc_get_null_expr (&gfc_current_locus); + } + /* ....(Preceeding sentence) If a component with default + initialization has no corresponding component-data-source, then + the default initialization is applied to that component. */ + else if (comp->initializer) + { + if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor " + "with missing optional arguments at %C")) + return false; + value = gfc_copy_expr (comp->initializer); + } + /* Do not trap components such as the string length for deferred + length character components. */ + else if (!comp->attr.artificial) + { + gfc_error ("No initializer for component %qs given in the" + " structure constructor at %C", comp->name); + return false; + } + } + else + value = comp_iter->val; + + /* Add the value to the constructor chain built. */ + gfc_constructor_append_expr (ctor_head, value, NULL); + + /* Remove the entry from the component list. We don't want the expression + value to be free'd, so set it to NULL. */ + if (comp_iter) + { + *next_ptr = comp_iter->next; + comp_iter->val = NULL; + gfc_free_structure_ctor_component (comp_iter); + } + } + return true; +} + + +bool +gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr, + gfc_actual_arglist **arglist, + bool parent) +{ + gfc_actual_arglist *actual; + gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter; + gfc_constructor_base ctor_head = NULL; + gfc_component *comp; /* Is set NULL when named component is first seen */ + const char* last_name = NULL; + locus old_locus; + gfc_expr *expr; + + expr = parent ? *cexpr : e; + old_locus = gfc_current_locus; + if (parent) + ; /* gfc_current_locus = *arglist->expr ? ->where;*/ + else + gfc_current_locus = expr->where; + + comp_tail = comp_head = NULL; + + if (!parent && sym->attr.abstract) + { + gfc_error ("Cannot construct ABSTRACT type %qs at %L", + sym->name, &expr->where); + goto cleanup; + } + + comp = sym->components; + actual = parent ? *arglist : expr->value.function.actual; + for ( ; actual; ) + { + gfc_component *this_comp = NULL; + + if (!comp_head) + comp_tail = comp_head = gfc_get_structure_ctor_component (); + else + { + comp_tail->next = gfc_get_structure_ctor_component (); + comp_tail = comp_tail->next; + } + if (actual->name) + { + if (!gfc_notify_std (GFC_STD_F2003, "Structure" + " constructor with named arguments at %C")) + goto cleanup; + + comp_tail->name = xstrdup (actual->name); + last_name = comp_tail->name; + comp = NULL; + } + else + { + /* Components without name are not allowed after the first named + component initializer! */ + if (!comp || comp->attr.artificial) + { + if (last_name) + gfc_error ("Component initializer without name after component" + " named %s at %L", last_name, + actual->expr ? &actual->expr->where + : &gfc_current_locus); + else + gfc_error ("Too many components in structure constructor at " + "%L", actual->expr ? &actual->expr->where + : &gfc_current_locus); + goto cleanup; + } + + comp_tail->name = xstrdup (comp->name); + } + + /* Find the current component in the structure definition and check + its access is not private. */ + if (comp) + this_comp = gfc_find_component (sym, comp->name, false, false, NULL); + else + { + this_comp = gfc_find_component (sym, (const char *)comp_tail->name, + false, false, NULL); + comp = NULL; /* Reset needed! */ + } + + /* Here we can check if a component name is given which does not + correspond to any component of the defined structure. */ + if (!this_comp) + goto cleanup; + + /* For a constant string constructor, make sure the length is + correct; truncate of fill with blanks if needed. */ + if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable + && this_comp->ts.u.cl && this_comp->ts.u.cl->length + && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT + && actual->expr->ts.type == BT_CHARACTER + && actual->expr->expr_type == EXPR_CONSTANT) + { + ptrdiff_t c, e1; + c = gfc_mpz_get_hwi (this_comp->ts.u.cl->length->value.integer); + e1 = actual->expr->value.character.length; + + if (c != e1) + { + ptrdiff_t i, to; + gfc_char_t *dest; + dest = gfc_get_wide_string (c + 1); + + to = e1 < c ? e1 : c; + for (i = 0; i < to; i++) + dest[i] = actual->expr->value.character.string[i]; + + for (i = e1; i < c; i++) + dest[i] = ' '; + + dest[c] = '\0'; + free (actual->expr->value.character.string); + + actual->expr->value.character.length = c; + actual->expr->value.character.string = dest; + + if (warn_line_truncation && c < e1) + gfc_warning_now (OPT_Wcharacter_truncation, + "CHARACTER expression will be truncated " + "in constructor (%ld/%ld) at %L", (long int) c, + (long int) e1, &actual->expr->where); + } + } + + comp_tail->val = actual->expr; + if (actual->expr != NULL) + comp_tail->where = actual->expr->where; + actual->expr = NULL; + + /* Check if this component is already given a value. */ + for (comp_iter = comp_head; comp_iter != comp_tail; + comp_iter = comp_iter->next) + { + gcc_assert (comp_iter); + if (!strcmp (comp_iter->name, comp_tail->name)) + { + gfc_error ("Component %qs is initialized twice in the structure" + " constructor at %L", comp_tail->name, + comp_tail->val ? &comp_tail->where + : &gfc_current_locus); + goto cleanup; + } + } + + /* F2008, R457/C725, for PURE C1283. */ + if (this_comp->attr.pointer && comp_tail->val + && gfc_is_coindexed (comp_tail->val)) + { + gfc_error ("Coindexed expression to pointer component %qs in " + "structure constructor at %L", comp_tail->name, + &comp_tail->where); + goto cleanup; + } + + /* If not explicitly a parent constructor, gather up the components + and build one. */ + if (comp && comp == sym->components + && sym->attr.extension + && comp_tail->val + && (!gfc_bt_struct (comp_tail->val->ts.type) + || + comp_tail->val->ts.u.derived != this_comp->ts.u.derived)) + { + bool m; + gfc_actual_arglist *arg_null = NULL; + + actual->expr = comp_tail->val; + comp_tail->val = NULL; + + m = gfc_convert_to_structure_constructor (NULL, + comp->ts.u.derived, &comp_tail->val, + comp->ts.u.derived->attr.zero_comp + ? &arg_null : &actual, true); + if (!m) + goto cleanup; + + if (comp->ts.u.derived->attr.zero_comp) + { + comp = comp->next; + continue; + } + } + + if (comp) + comp = comp->next; + if (parent && !comp) + break; + + if (actual) + actual = actual->next; + } + + if (!build_actual_constructor (&comp_head, &ctor_head, sym)) + goto cleanup; + + /* No component should be left, as this should have caused an error in the + loop constructing the component-list (name that does not correspond to any + component in the structure definition). */ + if (comp_head && sym->attr.extension) + { + for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next) + { + gfc_error ("component %qs at %L has already been set by a " + "parent derived type constructor", comp_iter->name, + &comp_iter->where); + } + goto cleanup; + } + else + gcc_assert (!comp_head); + + if (parent) + { + expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus); + expr->ts.u.derived = sym; + expr->value.constructor = ctor_head; + *cexpr = expr; + } + else + { + expr->ts.u.derived = sym; + expr->ts.kind = 0; + expr->ts.type = BT_DERIVED; + expr->value.constructor = ctor_head; + expr->expr_type = EXPR_STRUCTURE; + } + + gfc_current_locus = old_locus; + if (parent) + *arglist = actual; + return true; + + cleanup: + gfc_current_locus = old_locus; + + for (comp_iter = comp_head; comp_iter; ) + { + gfc_structure_ctor_component *next = comp_iter->next; + gfc_free_structure_ctor_component (comp_iter); + comp_iter = next; + } + gfc_constructor_free (ctor_head); + + return false; +} + + +match +gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result) +{ + match m; + gfc_expr *e; + gfc_symtree *symtree; + bool t = true; + + gfc_get_ha_sym_tree (sym->name, &symtree); + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_FUNCTION; + e->where = gfc_current_locus; + + gcc_assert (gfc_fl_struct (sym->attr.flavor) + && symtree->n.sym->attr.flavor == FL_PROCEDURE); + e->value.function.esym = sym; + e->symtree->n.sym->attr.generic = 1; + + m = gfc_match_actual_arglist (0, &e->value.function.actual); + if (m != MATCH_YES) + { + gfc_free_expr (e); + return m; + } + + if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + + /* If a structure constructor is in a DATA statement, then each entity + in the structure constructor must be a constant. Try to reduce the + expression here. */ + if (gfc_in_match_data ()) + t = gfc_reduce_init_expr (e); + + if (t) + { + *result = e; + return MATCH_YES; + } + else + { + gfc_free_expr (e); + return MATCH_ERROR; + } +} + + +/* If the symbol is an implicit do loop index and implicitly typed, + it should not be host associated. Provide a symtree from the + current namespace. */ +static match +check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym) +{ + if ((*sym)->attr.flavor == FL_VARIABLE + && (*sym)->ns != gfc_current_ns + && (*sym)->attr.implied_index + && (*sym)->attr.implicit_type + && !(*sym)->attr.use_assoc) + { + int i; + i = gfc_get_sym_tree ((*sym)->name, NULL, st, false); + if (i) + return MATCH_ERROR; + *sym = (*st)->n.sym; + } + return MATCH_YES; +} + + +/* Procedure pointer as function result: Replace the function symbol by the + auto-generated hidden result variable named "ppr@". */ + +static bool +replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st) +{ + /* Check for procedure pointer result variable. */ + if ((*sym)->attr.function && !(*sym)->attr.external + && (*sym)->result && (*sym)->result != *sym + && (*sym)->result->attr.proc_pointer + && (*sym) == gfc_current_ns->proc_name + && (*sym) == (*sym)->result->ns->proc_name + && strcmp ("ppr@", (*sym)->result->name) == 0) + { + /* Automatic replacement with "hidden" result variable. */ + (*sym)->result->attr.referenced = (*sym)->attr.referenced; + *sym = (*sym)->result; + *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name); + return true; + } + return false; +} + + +/* Matches a variable name followed by anything that might follow it-- + array reference, argument list of a function, etc. */ + +match +gfc_match_rvalue (gfc_expr **result) +{ + gfc_actual_arglist *actual_arglist; + char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1]; + gfc_state_data *st; + gfc_symbol *sym; + gfc_symtree *symtree; + locus where, old_loc; + gfc_expr *e; + match m, m2; + int i; + gfc_typespec *ts; + bool implicit_char; + gfc_ref *ref; + + m = gfc_match ("%%loc"); + if (m == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C")) + return MATCH_ERROR; + strncpy (name, "loc", 4); + } + + else + { + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + } + + /* Check if the symbol exists. */ + if (gfc_find_sym_tree (name, NULL, 1, &symtree)) + return MATCH_ERROR; + + /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT + type. For derived types we create a generic symbol which links to the + derived type symbol; STRUCTUREs are simpler and must not conflict with + variables. */ + if (!symtree) + if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree)) + return MATCH_ERROR; + if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) + { + if (gfc_find_state (COMP_INTERFACE) + && !gfc_current_ns->has_import_set) + i = gfc_get_sym_tree (name, NULL, &symtree, false); + else + i = gfc_get_ha_sym_tree (name, &symtree); + if (i) + return MATCH_ERROR; + } + + + sym = symtree->n.sym; + e = NULL; + where = gfc_current_locus; + + replace_hidden_procptr_result (&sym, &symtree); + + /* If this is an implicit do loop index and implicitly typed, + it should not be host associated. */ + m = check_for_implicit_index (&symtree, &sym); + if (m != MATCH_YES) + return m; + + gfc_set_sym_referenced (sym); + sym->attr.implied_index = 0; + + if (sym->attr.function && sym->result == sym) + { + /* See if this is a directly recursive function call. */ + gfc_gobble_whitespace (); + if (sym->attr.recursive + && gfc_peek_ascii_char () == '(' + && gfc_current_ns->proc_name == sym + && !sym->attr.dimension) + { + gfc_error ("%qs at %C is the name of a recursive function " + "and so refers to the result variable. Use an " + "explicit RESULT variable for direct recursion " + "(12.5.2.1)", sym->name); + return MATCH_ERROR; + } + + if (gfc_is_function_return_value (sym, gfc_current_ns)) + goto variable; + + if (sym->attr.entry + && (sym->ns == gfc_current_ns + || sym->ns == gfc_current_ns->parent)) + { + gfc_entry_list *el = NULL; + + for (el = sym->ns->entries; el; el = el->next) + if (sym == el->sym) + goto variable; + } + } + + if (gfc_matching_procptr_assignment) + { + /* It can be a procedure or a derived-type procedure or a not-yet-known + type. */ + if (sym->attr.flavor != FL_UNKNOWN + && sym->attr.flavor != FL_PROCEDURE + && sym->attr.flavor != FL_PARAMETER + && sym->attr.flavor != FL_VARIABLE) + { + gfc_error ("Symbol at %C is not appropriate for an expression"); + return MATCH_ERROR; + } + goto procptr0; + } + + if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) + goto function0; + + if (sym->attr.generic) + goto generic_function; + + switch (sym->attr.flavor) + { + case FL_VARIABLE: + variable: + e = gfc_get_expr (); + + e->expr_type = EXPR_VARIABLE; + e->symtree = symtree; + + m = gfc_match_varspec (e, 0, false, true); + break; + + case FL_PARAMETER: + /* A statement of the form "REAL, parameter :: a(0:10) = 1" will + end up here. Unfortunately, sym->value->expr_type is set to + EXPR_CONSTANT, and so the if () branch would be followed without + the !sym->as check. */ + if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as) + e = gfc_copy_expr (sym->value); + else + { + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + } + + e->symtree = symtree; + m = gfc_match_varspec (e, 0, false, true); + + if (sym->ts.is_c_interop || sym->ts.is_iso_c) + break; + + /* Variable array references to derived type parameters cause + all sorts of headaches in simplification. Treating such + expressions as variable works just fine for all array + references. */ + if (sym->value && sym->ts.type == BT_DERIVED && e->ref) + { + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + break; + + if (ref == NULL || ref->u.ar.type == AR_FULL) + break; + + ref = e->ref; + e->ref = NULL; + gfc_free_expr (e); + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + e->symtree = symtree; + e->ref = ref; + } + + break; + + case FL_STRUCT: + case FL_DERIVED: + sym = gfc_use_derived (sym); + if (sym == NULL) + m = MATCH_ERROR; + else + goto generic_function; + break; + + /* If we're here, then the name is known to be the name of a + procedure, yet it is not sure to be the name of a function. */ + case FL_PROCEDURE: + + /* Procedure Pointer Assignments. */ + procptr0: + if (gfc_matching_procptr_assignment) + { + gfc_gobble_whitespace (); + if (!sym->attr.dimension && gfc_peek_ascii_char () == '(') + /* Parse functions returning a procptr. */ + goto function0; + + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + e->symtree = symtree; + m = gfc_match_varspec (e, 0, false, true); + if (!e->ref && sym->attr.flavor == FL_UNKNOWN + && sym->ts.type == BT_UNKNOWN + && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL)) + { + m = MATCH_ERROR; + break; + } + break; + } + + if (sym->attr.subroutine) + { + gfc_error ("Unexpected use of subroutine name %qs at %C", + sym->name); + m = MATCH_ERROR; + break; + } + + /* At this point, the name has to be a non-statement function. + If the name is the same as the current function being + compiled, then we have a variable reference (to the function + result) if the name is non-recursive. */ + + st = gfc_enclosing_unit (NULL); + + if (st != NULL + && st->state == COMP_FUNCTION + && st->sym == sym + && !sym->attr.recursive) + { + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + + m = gfc_match_varspec (e, 0, false, true); + break; + } + + /* Match a function reference. */ + function0: + m = gfc_match_actual_arglist (0, &actual_arglist); + if (m == MATCH_NO) + { + if (sym->attr.proc == PROC_ST_FUNCTION) + gfc_error ("Statement function %qs requires argument list at %C", + sym->name); + else + gfc_error ("Function %qs requires an argument list at %C", + sym->name); + + m = MATCH_ERROR; + break; + } + + if (m != MATCH_YES) + { + m = MATCH_ERROR; + break; + } + + gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ + sym = symtree->n.sym; + + replace_hidden_procptr_result (&sym, &symtree); + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_FUNCTION; + e->value.function.actual = actual_arglist; + e->where = gfc_current_locus; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as) + e->rank = CLASS_DATA (sym)->as->rank; + else if (sym->as != NULL) + e->rank = sym->as->rank; + + if (!sym->attr.function + && !gfc_add_function (&sym->attr, sym->name, NULL)) + { + m = MATCH_ERROR; + break; + } + + /* Check here for the existence of at least one argument for the + iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The + argument(s) given will be checked in gfc_iso_c_func_interface, + during resolution of the function call. */ + if (sym->attr.is_iso_c == 1 + && (sym->from_intmod == INTMOD_ISO_C_BINDING + && (sym->intmod_sym_id == ISOCBINDING_LOC + || sym->intmod_sym_id == ISOCBINDING_FUNLOC + || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED))) + { + /* make sure we were given a param */ + if (actual_arglist == NULL) + { + gfc_error ("Missing argument to %qs at %C", sym->name); + m = MATCH_ERROR; + break; + } + } + + if (sym->result == NULL) + sym->result = sym; + + gfc_gobble_whitespace (); + /* F08:C612. */ + if (gfc_peek_ascii_char() == '%') + { + gfc_error ("The leftmost part-ref in a data-ref cannot be a " + "function reference at %C"); + m = MATCH_ERROR; + break; + } + + m = MATCH_YES; + break; + + case FL_UNKNOWN: + + /* Special case for derived type variables that get their types + via an IMPLICIT statement. This can't wait for the + resolution phase. */ + + old_loc = gfc_current_locus; + if (gfc_match_member_sep (sym) == MATCH_YES + && sym->ts.type == BT_UNKNOWN + && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED) + gfc_set_default_type (sym, 0, sym->ns); + gfc_current_locus = old_loc; + + /* If the symbol has a (co)dimension attribute, the expression is a + variable. */ + + if (sym->attr.dimension || sym->attr.codimension) + { + if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) + { + m = MATCH_ERROR; + break; + } + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + m = gfc_match_varspec (e, 0, false, true); + break; + } + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension)) + { + if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) + { + m = MATCH_ERROR; + break; + } + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + m = gfc_match_varspec (e, 0, false, true); + break; + } + + /* Name is not an array, so we peek to see if a '(' implies a + function call or a substring reference. Otherwise the + variable is just a scalar. */ + + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () != '(') + { + /* Assume a scalar variable */ + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + + if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL)) + { + m = MATCH_ERROR; + break; + } + + /*FIXME:??? gfc_match_varspec does set this for us: */ + e->ts = sym->ts; + m = gfc_match_varspec (e, 0, false, true); + break; + } + + /* See if this is a function reference with a keyword argument + as first argument. We do this because otherwise a spurious + symbol would end up in the symbol table. */ + + old_loc = gfc_current_locus; + m2 = gfc_match (" ( %n =", argname); + gfc_current_locus = old_loc; + + e = gfc_get_expr (); + e->symtree = symtree; + + if (m2 != MATCH_YES) + { + /* Try to figure out whether we're dealing with a character type. + We're peeking ahead here, because we don't want to call + match_substring if we're dealing with an implicitly typed + non-character variable. */ + implicit_char = false; + if (sym->ts.type == BT_UNKNOWN) + { + ts = gfc_get_default_type (sym->name, NULL); + if (ts->type == BT_CHARACTER) + implicit_char = true; + } + + /* See if this could possibly be a substring reference of a name + that we're not sure is a variable yet. */ + + if ((implicit_char || sym->ts.type == BT_CHARACTER) + && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES) + { + + e->expr_type = EXPR_VARIABLE; + + if (sym->attr.flavor != FL_VARIABLE + && !gfc_add_flavor (&sym->attr, FL_VARIABLE, + sym->name, NULL)) + { + m = MATCH_ERROR; + break; + } + + if (sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (sym, 1, NULL)) + { + m = MATCH_ERROR; + break; + } + + e->ts = sym->ts; + if (e->ref) + e->ts.u.cl = NULL; + m = MATCH_YES; + break; + } + } + + /* Give up, assume we have a function. */ + + gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ + sym = symtree->n.sym; + e->expr_type = EXPR_FUNCTION; + + if (!sym->attr.function + && !gfc_add_function (&sym->attr, sym->name, NULL)) + { + m = MATCH_ERROR; + break; + } + + sym->result = sym; + + m = gfc_match_actual_arglist (0, &e->value.function.actual); + if (m == MATCH_NO) + gfc_error ("Missing argument list in function %qs at %C", sym->name); + + if (m != MATCH_YES) + { + m = MATCH_ERROR; + break; + } + + /* If our new function returns a character, array or structure + type, it might have subsequent references. */ + + m = gfc_match_varspec (e, 0, false, true); + if (m == MATCH_NO) + m = MATCH_YES; + + break; + + generic_function: + /* Look for symbol first; if not found, look for STRUCTURE type symbol + specially. Creates a generic symbol for derived types. */ + gfc_find_sym_tree (name, NULL, 1, &symtree); + if (!symtree) + gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree); + if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT) + gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */ + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_FUNCTION; + + if (gfc_fl_struct (sym->attr.flavor)) + { + e->value.function.esym = sym; + e->symtree->n.sym->attr.generic = 1; + } + + m = gfc_match_actual_arglist (0, &e->value.function.actual); + break; + + case FL_NAMELIST: + m = MATCH_ERROR; + break; + + default: + gfc_error ("Symbol at %C is not appropriate for an expression"); + return MATCH_ERROR; + } + + if (m == MATCH_YES) + { + e->where = where; + *result = e; + } + else + gfc_free_expr (e); + + return m; +} + + +/* Match a variable, i.e. something that can be assigned to. This + starts as a symbol, can be a structure component or an array + reference. It can be a function if the function doesn't have a + separate RESULT variable. If the symbol has not been previously + seen, we assume it is a variable. + + This function is called by two interface functions: + gfc_match_variable, which has host_flag = 1, and + gfc_match_equiv_variable, with host_flag = 0, to restrict the + match of the symbol to the local scope. */ + +static match +match_variable (gfc_expr **result, int equiv_flag, int host_flag) +{ + gfc_symbol *sym, *dt_sym; + gfc_symtree *st; + gfc_expr *expr; + locus where, old_loc; + match m; + + /* Since nothing has any business being an lvalue in a module + specification block, an interface block or a contains section, + we force the changed_symbols mechanism to work by setting + host_flag to 0. This prevents valid symbols that have the name + of keywords, such as 'end', being turned into variables by + failed matching to assignments for, e.g., END INTERFACE. */ + if (gfc_current_state () == COMP_MODULE + || gfc_current_state () == COMP_SUBMODULE + || gfc_current_state () == COMP_INTERFACE + || gfc_current_state () == COMP_CONTAINS) + host_flag = 0; + + where = gfc_current_locus; + m = gfc_match_sym_tree (&st, host_flag); + if (m != MATCH_YES) + return m; + + sym = st->n.sym; + + /* If this is an implicit do loop index and implicitly typed, + it should not be host associated. */ + m = check_for_implicit_index (&st, &sym); + if (m != MATCH_YES) + return m; + + sym->attr.implied_index = 0; + + gfc_set_sym_referenced (sym); + + /* STRUCTUREs may share names with variables, but derived types may not. */ + if (sym->attr.flavor == FL_PROCEDURE && sym->generic + && (dt_sym = gfc_find_dt_in_generic (sym))) + { + if (dt_sym->attr.flavor == FL_DERIVED) + gfc_error ("Derived type %qs cannot be used as a variable at %C", + sym->name); + return MATCH_ERROR; + } + + switch (sym->attr.flavor) + { + case FL_VARIABLE: + /* Everything is alright. */ + break; + + case FL_UNKNOWN: + { + sym_flavor flavor = FL_UNKNOWN; + + gfc_gobble_whitespace (); + + if (sym->attr.external || sym->attr.procedure + || sym->attr.function || sym->attr.subroutine) + flavor = FL_PROCEDURE; + + /* If it is not a procedure, is not typed and is host associated, + we cannot give it a flavor yet. */ + else if (sym->ns == gfc_current_ns->parent + && sym->ts.type == BT_UNKNOWN) + break; + + /* These are definitive indicators that this is a variable. */ + else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN + || sym->attr.pointer || sym->as != NULL) + flavor = FL_VARIABLE; + + if (flavor != FL_UNKNOWN + && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL)) + return MATCH_ERROR; + } + break; + + case FL_PARAMETER: + if (equiv_flag) + { + gfc_error ("Named constant at %C in an EQUIVALENCE"); + return MATCH_ERROR; + } + /* Otherwise this is checked for and an error given in the + variable definition context checks. */ + break; + + case FL_PROCEDURE: + /* Check for a nonrecursive function result variable. */ + if (sym->attr.function + && !sym->attr.external + && sym->result == sym + && (gfc_is_function_return_value (sym, gfc_current_ns) + || (sym->attr.entry + && sym->ns == gfc_current_ns) + || (sym->attr.entry + && sym->ns == gfc_current_ns->parent))) + { + /* If a function result is a derived type, then the derived + type may still have to be resolved. */ + + if (sym->ts.type == BT_DERIVED + && gfc_use_derived (sym->ts.u.derived) == NULL) + return MATCH_ERROR; + break; + } + + if (sym->attr.proc_pointer + || replace_hidden_procptr_result (&sym, &st)) + break; + + /* Fall through to error */ + gcc_fallthrough (); + + default: + gfc_error ("%qs at %C is not a variable", sym->name); + return MATCH_ERROR; + } + + /* Special case for derived type variables that get their types + via an IMPLICIT statement. This can't wait for the + resolution phase. */ + + { + gfc_namespace * implicit_ns; + + if (gfc_current_ns->proc_name == sym) + implicit_ns = gfc_current_ns; + else + implicit_ns = sym->ns; + + old_loc = gfc_current_locus; + if (gfc_match_member_sep (sym) == MATCH_YES + && sym->ts.type == BT_UNKNOWN + && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED) + gfc_set_default_type (sym, 0, implicit_ns); + gfc_current_locus = old_loc; + } + + expr = gfc_get_expr (); + + expr->expr_type = EXPR_VARIABLE; + expr->symtree = st; + expr->ts = sym->ts; + expr->where = where; + + /* Now see if we have to do more. */ + m = gfc_match_varspec (expr, equiv_flag, false, false); + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return m; + } + + *result = expr; + return MATCH_YES; +} + + +match +gfc_match_variable (gfc_expr **result, int equiv_flag) +{ + return match_variable (result, equiv_flag, 1); +} + + +match +gfc_match_equiv_variable (gfc_expr **result) +{ + return match_variable (result, 1, 0); +} + diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c deleted file mode 100644 index 43eeefe..0000000 --- a/gcc/fortran/resolve.c +++ /dev/null @@ -1,17582 +0,0 @@ -/* Perform type resolution on the various structures. - Copyright (C) 2001-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "bitmap.h" -#include "gfortran.h" -#include "arith.h" /* For gfc_compare_expr(). */ -#include "dependency.h" -#include "data.h" -#include "target-memory.h" /* for gfc_simplify_transfer */ -#include "constructor.h" - -/* Types used in equivalence statements. */ - -enum seq_type -{ - SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED -}; - -/* Stack to keep track of the nesting of blocks as we move through the - code. See resolve_branch() and gfc_resolve_code(). */ - -typedef struct code_stack -{ - struct gfc_code *head, *current; - struct code_stack *prev; - - /* This bitmap keeps track of the targets valid for a branch from - inside this block except for END {IF|SELECT}s of enclosing - blocks. */ - bitmap reachable_labels; -} -code_stack; - -static code_stack *cs_base = NULL; - - -/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ - -static int forall_flag; -int gfc_do_concurrent_flag; - -/* True when we are resolving an expression that is an actual argument to - a procedure. */ -static bool actual_arg = false; -/* True when we are resolving an expression that is the first actual argument - to a procedure. */ -static bool first_actual_arg = false; - - -/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ - -static int omp_workshare_flag; - -/* True if we are processing a formal arglist. The corresponding function - resets the flag each time that it is read. */ -static bool formal_arg_flag = false; - -/* True if we are resolving a specification expression. */ -static bool specification_expr = false; - -/* The id of the last entry seen. */ -static int current_entry_id; - -/* We use bitmaps to determine if a branch target is valid. */ -static bitmap_obstack labels_obstack; - -/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ -static bool inquiry_argument = false; - - -bool -gfc_is_formal_arg (void) -{ - return formal_arg_flag; -} - -/* Is the symbol host associated? */ -static bool -is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) -{ - for (ns = ns->parent; ns; ns = ns->parent) - { - if (sym->ns == ns) - return true; - } - - return false; -} - -/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is - an ABSTRACT derived-type. If where is not NULL, an error message with that - locus is printed, optionally using name. */ - -static bool -resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) -{ - if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract) - { - if (where) - { - if (name) - gfc_error ("%qs at %L is of the ABSTRACT type %qs", - name, where, ts->u.derived->name); - else - gfc_error ("ABSTRACT type %qs used at %L", - ts->u.derived->name, where); - } - - return false; - } - - return true; -} - - -static bool -check_proc_interface (gfc_symbol *ifc, locus *where) -{ - /* Several checks for F08:C1216. */ - if (ifc->attr.procedure) - { - gfc_error ("Interface %qs at %L is declared " - "in a later PROCEDURE statement", ifc->name, where); - return false; - } - if (ifc->generic) - { - /* For generic interfaces, check if there is - a specific procedure with the same name. */ - gfc_interface *gen = ifc->generic; - while (gen && strcmp (gen->sym->name, ifc->name) != 0) - gen = gen->next; - if (!gen) - { - gfc_error ("Interface %qs at %L may not be generic", - ifc->name, where); - return false; - } - } - if (ifc->attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Interface %qs at %L may not be a statement function", - ifc->name, where); - return false; - } - if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) - || gfc_is_intrinsic (ifc, 1, ifc->declared_at)) - ifc->attr.intrinsic = 1; - if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0)) - { - gfc_error ("Intrinsic procedure %qs not allowed in " - "PROCEDURE statement at %L", ifc->name, where); - return false; - } - if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') - { - gfc_error ("Interface %qs at %L must be explicit", ifc->name, where); - return false; - } - return true; -} - - -static void resolve_symbol (gfc_symbol *sym); - - -/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ - -static bool -resolve_procedure_interface (gfc_symbol *sym) -{ - gfc_symbol *ifc = sym->ts.interface; - - if (!ifc) - return true; - - if (ifc == sym) - { - gfc_error ("PROCEDURE %qs at %L may not be used as its own interface", - sym->name, &sym->declared_at); - return false; - } - if (!check_proc_interface (ifc, &sym->declared_at)) - return false; - - if (ifc->attr.if_source || ifc->attr.intrinsic) - { - /* Resolve interface and copy attributes. */ - resolve_symbol (ifc); - if (ifc->attr.intrinsic) - gfc_resolve_intrinsic (ifc, &ifc->declared_at); - - if (ifc->result) - { - sym->ts = ifc->result->ts; - sym->attr.allocatable = ifc->result->attr.allocatable; - sym->attr.pointer = ifc->result->attr.pointer; - sym->attr.dimension = ifc->result->attr.dimension; - sym->attr.class_ok = ifc->result->attr.class_ok; - sym->as = gfc_copy_array_spec (ifc->result->as); - sym->result = sym; - } - else - { - sym->ts = ifc->ts; - sym->attr.allocatable = ifc->attr.allocatable; - sym->attr.pointer = ifc->attr.pointer; - sym->attr.dimension = ifc->attr.dimension; - sym->attr.class_ok = ifc->attr.class_ok; - sym->as = gfc_copy_array_spec (ifc->as); - } - sym->ts.interface = ifc; - sym->attr.function = ifc->attr.function; - sym->attr.subroutine = ifc->attr.subroutine; - - sym->attr.pure = ifc->attr.pure; - sym->attr.elemental = ifc->attr.elemental; - sym->attr.contiguous = ifc->attr.contiguous; - sym->attr.recursive = ifc->attr.recursive; - sym->attr.always_explicit = ifc->attr.always_explicit; - sym->attr.ext_attr |= ifc->attr.ext_attr; - sym->attr.is_bind_c = ifc->attr.is_bind_c; - /* Copy char length. */ - if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) - { - sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved - && !gfc_resolve_expr (sym->ts.u.cl->length)) - return false; - } - } - - return true; -} - - -/* Resolve types of formal argument lists. These have to be done early so that - the formal argument lists of module procedures can be copied to the - containing module before the individual procedures are resolved - individually. We also resolve argument lists of procedures in interface - blocks because they are self-contained scoping units. - - Since a dummy argument cannot be a non-dummy procedure, the only - resort left for untyped names are the IMPLICIT types. */ - -void -gfc_resolve_formal_arglist (gfc_symbol *proc) -{ - gfc_formal_arglist *f; - gfc_symbol *sym; - bool saved_specification_expr; - int i; - - if (proc->result != NULL) - sym = proc->result; - else - sym = proc; - - if (gfc_elemental (proc) - || sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->rank != 0)) - { - proc->attr.always_explicit = 1; - sym->attr.always_explicit = 1; - } - - formal_arg_flag = true; - - for (f = proc->formal; f; f = f->next) - { - gfc_array_spec *as; - - sym = f->sym; - - if (sym == NULL) - { - /* Alternate return placeholder. */ - if (gfc_elemental (proc)) - gfc_error ("Alternate return specifier in elemental subroutine " - "%qs at %L is not allowed", proc->name, - &proc->declared_at); - if (proc->attr.function) - gfc_error ("Alternate return specifier in function " - "%qs at %L is not allowed", proc->name, - &proc->declared_at); - continue; - } - else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL - && !resolve_procedure_interface (sym)) - return; - - if (strcmp (proc->name, sym->name) == 0) - { - gfc_error ("Self-referential argument " - "%qs at %L is not allowed", sym->name, - &proc->declared_at); - return; - } - - if (sym->attr.if_source != IFSRC_UNKNOWN) - gfc_resolve_formal_arglist (sym); - - if (sym->attr.subroutine || sym->attr.external) - { - if (sym->attr.flavor == FL_UNKNOWN) - gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at); - } - else - { - if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic - && (!sym->attr.function || sym->result == sym)) - gfc_set_default_type (sym, 1, sym->ns); - } - - as = sym->ts.type == BT_CLASS && sym->attr.class_ok - ? CLASS_DATA (sym)->as : sym->as; - - saved_specification_expr = specification_expr; - specification_expr = true; - gfc_resolve_array_spec (as, 0); - specification_expr = saved_specification_expr; - - /* We can't tell if an array with dimension (:) is assumed or deferred - shape until we know if it has the pointer or allocatable attributes. - */ - if (as && as->rank > 0 && as->type == AS_DEFERRED - && ((sym->ts.type != BT_CLASS - && !(sym->attr.pointer || sym->attr.allocatable)) - || (sym->ts.type == BT_CLASS - && !(CLASS_DATA (sym)->attr.class_pointer - || CLASS_DATA (sym)->attr.allocatable))) - && sym->attr.flavor != FL_PROCEDURE) - { - as->type = AS_ASSUMED_SHAPE; - for (i = 0; i < as->rank; i++) - as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - } - - if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE) - || (as && as->type == AS_ASSUMED_RANK) - || sym->attr.pointer || sym->attr.allocatable || sym->attr.target - || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && (CLASS_DATA (sym)->attr.class_pointer - || CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.target)) - || sym->attr.optional) - { - proc->attr.always_explicit = 1; - if (proc->result) - proc->result->attr.always_explicit = 1; - } - - /* If the flavor is unknown at this point, it has to be a variable. - A procedure specification would have already set the type. */ - - if (sym->attr.flavor == FL_UNKNOWN) - gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); - - if (gfc_pure (proc)) - { - if (sym->attr.flavor == FL_PROCEDURE) - { - /* F08:C1279. */ - if (!gfc_pure (sym)) - { - gfc_error ("Dummy procedure %qs of PURE procedure at %L must " - "also be PURE", sym->name, &sym->declared_at); - continue; - } - } - else if (!sym->attr.pointer) - { - if (proc->attr.function && sym->attr.intent != INTENT_IN) - { - if (sym->attr.value) - gfc_notify_std (GFC_STD_F2008, "Argument %qs" - " of pure function %qs at %L with VALUE " - "attribute but without INTENT(IN)", - sym->name, proc->name, &sym->declared_at); - else - gfc_error ("Argument %qs of pure function %qs at %L must " - "be INTENT(IN) or VALUE", sym->name, proc->name, - &sym->declared_at); - } - - if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) - { - if (sym->attr.value) - gfc_notify_std (GFC_STD_F2008, "Argument %qs" - " of pure subroutine %qs at %L with VALUE " - "attribute but without INTENT", sym->name, - proc->name, &sym->declared_at); - else - gfc_error ("Argument %qs of pure subroutine %qs at %L " - "must have its INTENT specified or have the " - "VALUE attribute", sym->name, proc->name, - &sym->declared_at); - } - } - - /* F08:C1278a. */ - if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) - { - gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L" - " may not be polymorphic", sym->name, proc->name, - &sym->declared_at); - continue; - } - } - - if (proc->attr.implicit_pure) - { - if (sym->attr.flavor == FL_PROCEDURE) - { - if (!gfc_pure (sym)) - proc->attr.implicit_pure = 0; - } - else if (!sym->attr.pointer) - { - if (proc->attr.function && sym->attr.intent != INTENT_IN - && !sym->value) - proc->attr.implicit_pure = 0; - - if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN - && !sym->value) - proc->attr.implicit_pure = 0; - } - } - - if (gfc_elemental (proc)) - { - /* F08:C1289. */ - if (sym->attr.codimension - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.codimension)) - { - gfc_error ("Coarray dummy argument %qs at %L to elemental " - "procedure", sym->name, &sym->declared_at); - continue; - } - - if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->as)) - { - gfc_error ("Argument %qs of elemental procedure at %L must " - "be scalar", sym->name, &sym->declared_at); - continue; - } - - if (sym->attr.allocatable - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.allocatable)) - { - gfc_error ("Argument %qs of elemental procedure at %L cannot " - "have the ALLOCATABLE attribute", sym->name, - &sym->declared_at); - continue; - } - - if (sym->attr.pointer - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.class_pointer)) - { - gfc_error ("Argument %qs of elemental procedure at %L cannot " - "have the POINTER attribute", sym->name, - &sym->declared_at); - continue; - } - - if (sym->attr.flavor == FL_PROCEDURE) - { - gfc_error ("Dummy procedure %qs not allowed in elemental " - "procedure %qs at %L", sym->name, proc->name, - &sym->declared_at); - continue; - } - - /* Fortran 2008 Corrigendum 1, C1290a. */ - if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value) - { - gfc_error ("Argument %qs of elemental procedure %qs at %L must " - "have its INTENT specified or have the VALUE " - "attribute", sym->name, proc->name, - &sym->declared_at); - continue; - } - } - - /* Each dummy shall be specified to be scalar. */ - if (proc->attr.proc == PROC_ST_FUNCTION) - { - if (sym->as != NULL) - { - /* F03:C1263 (R1238) The function-name and each dummy-arg-name - shall be specified, explicitly or implicitly, to be scalar. */ - gfc_error ("Argument '%s' of statement function '%s' at %L " - "must be scalar", sym->name, proc->name, - &proc->declared_at); - continue; - } - - if (sym->ts.type == BT_CHARACTER) - { - gfc_charlen *cl = sym->ts.u.cl; - if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Character-valued argument %qs of statement " - "function at %L must have constant length", - sym->name, &sym->declared_at); - continue; - } - } - } - } - formal_arg_flag = false; -} - - -/* Work function called when searching for symbols that have argument lists - associated with them. */ - -static void -find_arglists (gfc_symbol *sym) -{ - if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns - || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic) - return; - - gfc_resolve_formal_arglist (sym); -} - - -/* Given a namespace, resolve all formal argument lists within the namespace. - */ - -static void -resolve_formal_arglists (gfc_namespace *ns) -{ - if (ns == NULL) - return; - - gfc_traverse_ns (ns, find_arglists); -} - - -static void -resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) -{ - bool t; - - if (sym && sym->attr.flavor == FL_PROCEDURE - && sym->ns->parent - && sym->ns->parent->proc_name - && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE - && !strcmp (sym->name, sym->ns->parent->proc_name->name)) - gfc_error ("Contained procedure %qs at %L has the same name as its " - "encompassing procedure", sym->name, &sym->declared_at); - - /* If this namespace is not a function or an entry master function, - ignore it. */ - if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE) - || sym->attr.entry_master) - return; - - if (!sym->result) - return; - - /* Try to find out of what the return type is. */ - if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL) - { - t = gfc_set_default_type (sym->result, 0, ns); - - if (!t && !sym->result->attr.untyped) - { - if (sym->result == sym) - gfc_error ("Contained function %qs at %L has no IMPLICIT type", - sym->name, &sym->declared_at); - else if (!sym->result->attr.proc_pointer) - gfc_error ("Result %qs of contained function %qs at %L has " - "no IMPLICIT type", sym->result->name, sym->name, - &sym->result->declared_at); - sym->result->attr.untyped = 1; - } - } - - /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value - type, lists the only ways a character length value of * can be used: - dummy arguments of procedures, named constants, function results and - in allocate statements if the allocate_object is an assumed length dummy - in external functions. Internal function results and results of module - procedures are not on this list, ergo, not permitted. */ - - if (sym->result->ts.type == BT_CHARACTER) - { - gfc_charlen *cl = sym->result->ts.u.cl; - if ((!cl || !cl->length) && !sym->result->ts.deferred) - { - /* See if this is a module-procedure and adapt error message - accordingly. */ - bool module_proc; - gcc_assert (ns->parent && ns->parent->proc_name); - module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE); - - gfc_error (module_proc - ? G_("Character-valued module procedure %qs at %L" - " must not be assumed length") - : G_("Character-valued internal function %qs at %L" - " must not be assumed length"), - sym->name, &sym->declared_at); - } - } -} - - -/* Add NEW_ARGS to the formal argument list of PROC, taking care not to - introduce duplicates. */ - -static void -merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) -{ - gfc_formal_arglist *f, *new_arglist; - gfc_symbol *new_sym; - - for (; new_args != NULL; new_args = new_args->next) - { - new_sym = new_args->sym; - /* See if this arg is already in the formal argument list. */ - for (f = proc->formal; f; f = f->next) - { - if (new_sym == f->sym) - break; - } - - if (f) - continue; - - /* Add a new argument. Argument order is not important. */ - new_arglist = gfc_get_formal_arglist (); - new_arglist->sym = new_sym; - new_arglist->next = proc->formal; - proc->formal = new_arglist; - } -} - - -/* Flag the arguments that are not present in all entries. */ - -static void -check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) -{ - gfc_formal_arglist *f, *head; - head = new_args; - - for (f = proc->formal; f; f = f->next) - { - if (f->sym == NULL) - continue; - - for (new_args = head; new_args; new_args = new_args->next) - { - if (new_args->sym == f->sym) - break; - } - - if (new_args) - continue; - - f->sym->attr.not_always_present = 1; - } -} - - -/* Resolve alternate entry points. If a symbol has multiple entry points we - create a new master symbol for the main routine, and turn the existing - symbol into an entry point. */ - -static void -resolve_entries (gfc_namespace *ns) -{ - gfc_namespace *old_ns; - gfc_code *c; - gfc_symbol *proc; - gfc_entry_list *el; - char name[GFC_MAX_SYMBOL_LEN + 1]; - static int master_count = 0; - - if (ns->proc_name == NULL) - return; - - /* No need to do anything if this procedure doesn't have alternate entry - points. */ - if (!ns->entries) - return; - - /* We may already have resolved alternate entry points. */ - if (ns->proc_name->attr.entry_master) - return; - - /* If this isn't a procedure something has gone horribly wrong. */ - gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE); - - /* Remember the current namespace. */ - old_ns = gfc_current_ns; - - gfc_current_ns = ns; - - /* Add the main entry point to the list of entry points. */ - el = gfc_get_entry_list (); - el->sym = ns->proc_name; - el->id = 0; - el->next = ns->entries; - ns->entries = el; - ns->proc_name->attr.entry = 1; - - /* If it is a module function, it needs to be in the right namespace - so that gfc_get_fake_result_decl can gather up the results. The - need for this arose in get_proc_name, where these beasts were - left in their own namespace, to keep prior references linked to - the entry declaration.*/ - if (ns->proc_name->attr.function - && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) - el->sym->ns = ns; - - /* Do the same for entries where the master is not a module - procedure. These are retained in the module namespace because - of the module procedure declaration. */ - for (el = el->next; el; el = el->next) - if (el->sym->ns->proc_name->attr.flavor == FL_MODULE - && el->sym->attr.mod_proc) - el->sym->ns = ns; - el = ns->entries; - - /* Add an entry statement for it. */ - c = gfc_get_code (EXEC_ENTRY); - c->ext.entry = el; - c->next = ns->code; - ns->code = c; - - /* Create a new symbol for the master function. */ - /* Give the internal function a unique name (within this file). - Also include the function name so the user has some hope of figuring - out what is going on. */ - snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", - master_count++, ns->proc_name->name); - gfc_get_ha_symbol (name, &proc); - gcc_assert (proc != NULL); - - gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL); - if (ns->proc_name->attr.subroutine) - gfc_add_subroutine (&proc->attr, proc->name, NULL); - else - { - gfc_symbol *sym; - gfc_typespec *ts, *fts; - gfc_array_spec *as, *fas; - gfc_add_function (&proc->attr, proc->name, NULL); - proc->result = proc; - fas = ns->entries->sym->as; - fas = fas ? fas : ns->entries->sym->result->as; - fts = &ns->entries->sym->result->ts; - if (fts->type == BT_UNKNOWN) - fts = gfc_get_default_type (ns->entries->sym->result->name, NULL); - for (el = ns->entries->next; el; el = el->next) - { - ts = &el->sym->result->ts; - as = el->sym->as; - as = as ? as : el->sym->result->as; - if (ts->type == BT_UNKNOWN) - ts = gfc_get_default_type (el->sym->result->name, NULL); - - if (! gfc_compare_types (ts, fts) - || (el->sym->result->attr.dimension - != ns->entries->sym->result->attr.dimension) - || (el->sym->result->attr.pointer - != ns->entries->sym->result->attr.pointer)) - break; - else if (as && fas && ns->entries->sym->result != el->sym->result - && gfc_compare_array_spec (as, fas) == 0) - gfc_error ("Function %s at %L has entries with mismatched " - "array specifications", ns->entries->sym->name, - &ns->entries->sym->declared_at); - /* The characteristics need to match and thus both need to have - the same string length, i.e. both len=*, or both len=4. - Having both len= is also possible, but difficult to - check at compile time. */ - else if (ts->type == BT_CHARACTER - && (el->sym->result->attr.allocatable - != ns->entries->sym->result->attr.allocatable)) - { - gfc_error ("Function %s at %L has entry %s with mismatched " - "characteristics", ns->entries->sym->name, - &ns->entries->sym->declared_at, el->sym->name); - goto cleanup; - } - else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl - && (((ts->u.cl->length && !fts->u.cl->length) - ||(!ts->u.cl->length && fts->u.cl->length)) - || (ts->u.cl->length - && ts->u.cl->length->expr_type - != fts->u.cl->length->expr_type) - || (ts->u.cl->length - && ts->u.cl->length->expr_type == EXPR_CONSTANT - && mpz_cmp (ts->u.cl->length->value.integer, - fts->u.cl->length->value.integer) != 0))) - gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " - "entries returning variables of different " - "string lengths", ns->entries->sym->name, - &ns->entries->sym->declared_at); - } - - if (el == NULL) - { - sym = ns->entries->sym->result; - /* All result types the same. */ - proc->ts = *fts; - if (sym->attr.dimension) - gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); - if (sym->attr.pointer) - gfc_add_pointer (&proc->attr, NULL); - } - else - { - /* Otherwise the result will be passed through a union by - reference. */ - proc->attr.mixed_entry_master = 1; - for (el = ns->entries; el; el = el->next) - { - sym = el->sym->result; - if (sym->attr.dimension) - { - if (el == ns->entries) - gfc_error ("FUNCTION result %s cannot be an array in " - "FUNCTION %s at %L", sym->name, - ns->entries->sym->name, &sym->declared_at); - else - gfc_error ("ENTRY result %s cannot be an array in " - "FUNCTION %s at %L", sym->name, - ns->entries->sym->name, &sym->declared_at); - } - else if (sym->attr.pointer) - { - if (el == ns->entries) - gfc_error ("FUNCTION result %s cannot be a POINTER in " - "FUNCTION %s at %L", sym->name, - ns->entries->sym->name, &sym->declared_at); - else - gfc_error ("ENTRY result %s cannot be a POINTER in " - "FUNCTION %s at %L", sym->name, - ns->entries->sym->name, &sym->declared_at); - } - else - { - ts = &sym->ts; - if (ts->type == BT_UNKNOWN) - ts = gfc_get_default_type (sym->name, NULL); - switch (ts->type) - { - case BT_INTEGER: - if (ts->kind == gfc_default_integer_kind) - sym = NULL; - break; - case BT_REAL: - if (ts->kind == gfc_default_real_kind - || ts->kind == gfc_default_double_kind) - sym = NULL; - break; - case BT_COMPLEX: - if (ts->kind == gfc_default_complex_kind) - sym = NULL; - break; - case BT_LOGICAL: - if (ts->kind == gfc_default_logical_kind) - sym = NULL; - break; - case BT_UNKNOWN: - /* We will issue error elsewhere. */ - sym = NULL; - break; - default: - break; - } - if (sym) - { - if (el == ns->entries) - gfc_error ("FUNCTION result %s cannot be of type %s " - "in FUNCTION %s at %L", sym->name, - gfc_typename (ts), ns->entries->sym->name, - &sym->declared_at); - else - gfc_error ("ENTRY result %s cannot be of type %s " - "in FUNCTION %s at %L", sym->name, - gfc_typename (ts), ns->entries->sym->name, - &sym->declared_at); - } - } - } - } - } - -cleanup: - proc->attr.access = ACCESS_PRIVATE; - proc->attr.entry_master = 1; - - /* Merge all the entry point arguments. */ - for (el = ns->entries; el; el = el->next) - merge_argument_lists (proc, el->sym->formal); - - /* Check the master formal arguments for any that are not - present in all entry points. */ - for (el = ns->entries; el; el = el->next) - check_argument_lists (proc, el->sym->formal); - - /* Use the master function for the function body. */ - ns->proc_name = proc; - - /* Finalize the new symbols. */ - gfc_commit_symbols (); - - /* Restore the original namespace. */ - gfc_current_ns = old_ns; -} - - -/* Resolve common variables. */ -static void -resolve_common_vars (gfc_common_head *common_block, bool named_common) -{ - gfc_symbol *csym = common_block->head; - gfc_gsymbol *gsym; - - for (; csym; csym = csym->common_next) - { - gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name); - if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM)) - gfc_error_now ("Global entity %qs at %L cannot appear in a " - "COMMON block at %L", gsym->name, - &gsym->where, &csym->common_block->where); - - /* gfc_add_in_common may have been called before, but the reported errors - have been ignored to continue parsing. - We do the checks again here. */ - if (!csym->attr.use_assoc) - { - gfc_add_in_common (&csym->attr, csym->name, &common_block->where); - gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L", - &common_block->where); - } - - if (csym->value || csym->attr.data) - { - if (!csym->ns->is_block_data) - gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON " - "but only in BLOCK DATA initialization is " - "allowed", csym->name, &csym->declared_at); - else if (!named_common) - gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is " - "in a blank COMMON but initialization is only " - "allowed in named common blocks", csym->name, - &csym->declared_at); - } - - if (UNLIMITED_POLY (csym)) - gfc_error_now ("%qs at %L cannot appear in COMMON " - "[F2008:C5100]", csym->name, &csym->declared_at); - - if (csym->ts.type != BT_DERIVED) - continue; - - if (!(csym->ts.u.derived->attr.sequence - || csym->ts.u.derived->attr.is_bind_c)) - gfc_error_now ("Derived type variable %qs in COMMON at %L " - "has neither the SEQUENCE nor the BIND(C) " - "attribute", csym->name, &csym->declared_at); - if (csym->ts.u.derived->attr.alloc_comp) - gfc_error_now ("Derived type variable %qs in COMMON at %L " - "has an ultimate component that is " - "allocatable", csym->name, &csym->declared_at); - if (gfc_has_default_initializer (csym->ts.u.derived)) - gfc_error_now ("Derived type variable %qs in COMMON at %L " - "may not have default initializer", csym->name, - &csym->declared_at); - - if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer) - gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at); - } -} - -/* Resolve common blocks. */ -static void -resolve_common_blocks (gfc_symtree *common_root) -{ - gfc_symbol *sym; - gfc_gsymbol * gsym; - - if (common_root == NULL) - return; - - if (common_root->left) - resolve_common_blocks (common_root->left); - if (common_root->right) - resolve_common_blocks (common_root->right); - - resolve_common_vars (common_root->n.common, true); - - /* The common name is a global name - in Fortran 2003 also if it has a - C binding name, since Fortran 2008 only the C binding name is a global - identifier. */ - if (!common_root->n.common->binding_label - || gfc_notification_std (GFC_STD_F2008)) - { - gsym = gfc_find_gsymbol (gfc_gsym_root, - common_root->n.common->name); - - if (gsym && gfc_notification_std (GFC_STD_F2008) - && gsym->type == GSYM_COMMON - && ((common_root->n.common->binding_label - && (!gsym->binding_label - || strcmp (common_root->n.common->binding_label, - gsym->binding_label) != 0)) - || (!common_root->n.common->binding_label - && gsym->binding_label))) - { - gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global " - "identifier and must thus have the same binding name " - "as the same-named COMMON block at %L: %s vs %s", - common_root->n.common->name, &common_root->n.common->where, - &gsym->where, - common_root->n.common->binding_label - ? common_root->n.common->binding_label : "(blank)", - gsym->binding_label ? gsym->binding_label : "(blank)"); - return; - } - - if (gsym && gsym->type != GSYM_COMMON - && !common_root->n.common->binding_label) - { - gfc_error ("COMMON block %qs at %L uses the same global identifier " - "as entity at %L", - common_root->n.common->name, &common_root->n.common->where, - &gsym->where); - return; - } - if (gsym && gsym->type != GSYM_COMMON) - { - gfc_error ("Fortran 2008: COMMON block %qs with binding label at " - "%L sharing the identifier with global non-COMMON-block " - "entity at %L", common_root->n.common->name, - &common_root->n.common->where, &gsym->where); - return; - } - if (!gsym) - { - gsym = gfc_get_gsymbol (common_root->n.common->name, false); - gsym->type = GSYM_COMMON; - gsym->where = common_root->n.common->where; - gsym->defined = 1; - } - gsym->used = 1; - } - - if (common_root->n.common->binding_label) - { - gsym = gfc_find_gsymbol (gfc_gsym_root, - common_root->n.common->binding_label); - if (gsym && gsym->type != GSYM_COMMON) - { - gfc_error ("COMMON block at %L with binding label %qs uses the same " - "global identifier as entity at %L", - &common_root->n.common->where, - common_root->n.common->binding_label, &gsym->where); - return; - } - if (!gsym) - { - gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true); - gsym->type = GSYM_COMMON; - gsym->where = common_root->n.common->where; - gsym->defined = 1; - } - gsym->used = 1; - } - - gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); - if (sym == NULL) - return; - - if (sym->attr.flavor == FL_PARAMETER) - gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L", - sym->name, &common_root->n.common->where, &sym->declared_at); - - if (sym->attr.external) - gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute", - sym->name, &common_root->n.common->where); - - if (sym->attr.intrinsic) - gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", - sym->name, &common_root->n.common->where); - else if (sym->attr.result - || gfc_is_function_return_value (sym, gfc_current_ns)) - gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " - "that is also a function result", sym->name, - &common_root->n.common->where); - else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL - && sym->attr.proc != PROC_ST_FUNCTION) - gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " - "that is also a global procedure", sym->name, - &common_root->n.common->where); -} - - -/* Resolve contained function types. Because contained functions can call one - another, they have to be worked out before any of the contained procedures - can be resolved. - - The good news is that if a function doesn't already have a type, the only - way it can get one is through an IMPLICIT type or a RESULT variable, because - by definition contained functions are contained namespace they're contained - in, not in a sibling or parent namespace. */ - -static void -resolve_contained_functions (gfc_namespace *ns) -{ - gfc_namespace *child; - gfc_entry_list *el; - - resolve_formal_arglists (ns); - - for (child = ns->contained; child; child = child->sibling) - { - /* Resolve alternate entry points first. */ - resolve_entries (child); - - /* Then check function return types. */ - resolve_contained_fntype (child->proc_name, child); - for (el = child->entries; el; el = el->next) - resolve_contained_fntype (el->sym, child); - } -} - - - -/* A Parameterized Derived Type constructor must contain values for - the PDT KIND parameters or they must have a default initializer. - Go through the constructor picking out the KIND expressions, - storing them in 'param_list' and then call gfc_get_pdt_instance - to obtain the PDT instance. */ - -static gfc_actual_arglist *param_list, *param_tail, *param; - -static bool -get_pdt_spec_expr (gfc_component *c, gfc_expr *expr) -{ - param = gfc_get_actual_arglist (); - if (!param_list) - param_list = param_tail = param; - else - { - param_tail->next = param; - param_tail = param_tail->next; - } - - param_tail->name = c->name; - if (expr) - param_tail->expr = gfc_copy_expr (expr); - else if (c->initializer) - param_tail->expr = gfc_copy_expr (c->initializer); - else - { - param_tail->spec_type = SPEC_ASSUMED; - if (c->attr.pdt_kind) - { - gfc_error ("The KIND parameter %qs in the PDT constructor " - "at %C has no value", param->name); - return false; - } - } - - return true; -} - -static bool -get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr, - gfc_symbol *derived) -{ - gfc_constructor *cons = NULL; - gfc_component *comp; - bool t = true; - - if (expr && expr->expr_type == EXPR_STRUCTURE) - cons = gfc_constructor_first (expr->value.constructor); - else if (constr) - cons = *constr; - gcc_assert (cons); - - comp = derived->components; - - for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) - { - if (cons->expr - && cons->expr->expr_type == EXPR_STRUCTURE - && comp->ts.type == BT_DERIVED) - { - t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived); - if (!t) - return t; - } - else if (comp->ts.type == BT_DERIVED) - { - t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived); - if (!t) - return t; - } - else if ((comp->attr.pdt_kind || comp->attr.pdt_len) - && derived->attr.pdt_template) - { - t = get_pdt_spec_expr (comp, cons->expr); - if (!t) - return t; - } - } - return t; -} - - -static bool resolve_fl_derived0 (gfc_symbol *sym); -static bool resolve_fl_struct (gfc_symbol *sym); - - -/* Resolve all of the elements of a structure constructor and make sure that - the types are correct. The 'init' flag indicates that the given - constructor is an initializer. */ - -static bool -resolve_structure_cons (gfc_expr *expr, int init) -{ - gfc_constructor *cons; - gfc_component *comp; - bool t; - symbol_attribute a; - - t = true; - - if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION) - { - if (expr->ts.u.derived->attr.flavor == FL_DERIVED) - resolve_fl_derived0 (expr->ts.u.derived); - else - resolve_fl_struct (expr->ts.u.derived); - - /* If this is a Parameterized Derived Type template, find the - instance corresponding to the PDT kind parameters. */ - if (expr->ts.u.derived->attr.pdt_template) - { - param_list = NULL; - t = get_pdt_constructor (expr, NULL, expr->ts.u.derived); - if (!t) - return t; - gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL); - - expr->param_list = gfc_copy_actual_arglist (param_list); - - if (param_list) - gfc_free_actual_arglist (param_list); - - if (!expr->ts.u.derived->attr.pdt_type) - return false; - } - } - - cons = gfc_constructor_first (expr->value.constructor); - - /* A constructor may have references if it is the result of substituting a - parameter variable. In this case we just pull out the component we - want. */ - if (expr->ref) - comp = expr->ref->u.c.sym->components; - else - comp = expr->ts.u.derived->components; - - for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) - { - int rank; - - if (!cons->expr) - continue; - - /* Unions use an EXPR_NULL contrived expression to tell the translation - phase to generate an initializer of the appropriate length. - Ignore it here. */ - if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL) - continue; - - if (!gfc_resolve_expr (cons->expr)) - { - t = false; - continue; - } - - rank = comp->as ? comp->as->rank : 0; - if (comp->ts.type == BT_CLASS - && !comp->ts.u.derived->attr.unlimited_polymorphic - && CLASS_DATA (comp)->as) - rank = CLASS_DATA (comp)->as->rank; - - if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank - && (comp->attr.allocatable || cons->expr->rank)) - { - gfc_error ("The rank of the element in the structure " - "constructor at %L does not match that of the " - "component (%d/%d)", &cons->expr->where, - cons->expr->rank, rank); - t = false; - } - - /* If we don't have the right type, try to convert it. */ - - if (!comp->attr.proc_pointer && - !gfc_compare_types (&cons->expr->ts, &comp->ts)) - { - if (strcmp (comp->name, "_extends") == 0) - { - /* Can afford to be brutal with the _extends initializer. - The derived type can get lost because it is PRIVATE - but it is not usage constrained by the standard. */ - cons->expr->ts = comp->ts; - } - else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) - { - gfc_error ("The element in the structure constructor at %L, " - "for pointer component %qs, is %s but should be %s", - &cons->expr->where, comp->name, - gfc_basic_typename (cons->expr->ts.type), - gfc_basic_typename (comp->ts.type)); - t = false; - } - else - { - bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); - if (t) - t = t2; - } - } - - /* For strings, the length of the constructor should be the same as - the one of the structure, ensure this if the lengths are known at - compile time and when we are dealing with PARAMETER or structure - constructors. */ - if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl - && comp->ts.u.cl->length - && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT - && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length - && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT - && cons->expr->rank != 0 - && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, - comp->ts.u.cl->length->value.integer) != 0) - { - if (cons->expr->expr_type == EXPR_VARIABLE - && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER) - { - /* Wrap the parameter in an array constructor (EXPR_ARRAY) - to make use of the gfc_resolve_character_array_constructor - machinery. The expression is later simplified away to - an array of string literals. */ - gfc_expr *para = cons->expr; - cons->expr = gfc_get_expr (); - cons->expr->ts = para->ts; - cons->expr->where = para->where; - cons->expr->expr_type = EXPR_ARRAY; - cons->expr->rank = para->rank; - cons->expr->shape = gfc_copy_shape (para->shape, para->rank); - gfc_constructor_append_expr (&cons->expr->value.constructor, - para, &cons->expr->where); - } - - if (cons->expr->expr_type == EXPR_ARRAY) - { - /* Rely on the cleanup of the namespace to deal correctly with - the old charlen. (There was a block here that attempted to - remove the charlen but broke the chain in so doing.) */ - cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - cons->expr->ts.u.cl->length_from_typespec = true; - cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length); - gfc_resolve_character_array_constructor (cons->expr); - } - } - - if (cons->expr->expr_type == EXPR_NULL - && !(comp->attr.pointer || comp->attr.allocatable - || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID - || (comp->ts.type == BT_CLASS - && (CLASS_DATA (comp)->attr.class_pointer - || CLASS_DATA (comp)->attr.allocatable)))) - { - t = false; - gfc_error ("The NULL in the structure constructor at %L is " - "being applied to component %qs, which is neither " - "a POINTER nor ALLOCATABLE", &cons->expr->where, - comp->name); - } - - if (comp->attr.proc_pointer && comp->ts.interface) - { - /* Check procedure pointer interface. */ - gfc_symbol *s2 = NULL; - gfc_component *c2; - const char *name; - char err[200]; - - c2 = gfc_get_proc_ptr_comp (cons->expr); - if (c2) - { - s2 = c2->ts.interface; - name = c2->name; - } - else if (cons->expr->expr_type == EXPR_FUNCTION) - { - s2 = cons->expr->symtree->n.sym->result; - name = cons->expr->symtree->n.sym->result->name; - } - else if (cons->expr->expr_type != EXPR_NULL) - { - s2 = cons->expr->symtree->n.sym; - name = cons->expr->symtree->n.sym->name; - } - - if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, - err, sizeof (err), NULL, NULL)) - { - gfc_error_opt (0, "Interface mismatch for procedure-pointer " - "component %qs in structure constructor at %L:" - " %s", comp->name, &cons->expr->where, err); - return false; - } - } - - /* Validate shape, except for dynamic or PDT arrays. */ - if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank - && comp->as && !comp->attr.allocatable && !comp->attr.pointer - && !comp->attr.pdt_array) - { - mpz_t len; - mpz_init (len); - for (int n = 0; n < rank; n++) - { - if (comp->as->upper[n]->expr_type != EXPR_CONSTANT - || comp->as->lower[n]->expr_type != EXPR_CONSTANT) - { - gfc_error ("Bad array spec of component %qs referenced in " - "structure constructor at %L", - comp->name, &cons->expr->where); - t = false; - break; - }; - mpz_set_ui (len, 1); - mpz_add (len, len, comp->as->upper[n]->value.integer); - mpz_sub (len, len, comp->as->lower[n]->value.integer); - if (mpz_cmp (cons->expr->shape[n], len) != 0) - { - gfc_error ("The shape of component %qs in the structure " - "constructor at %L differs from the shape of the " - "declared component for dimension %d (%ld/%ld)", - comp->name, &cons->expr->where, n+1, - mpz_get_si (cons->expr->shape[n]), - mpz_get_si (len)); - t = false; - } - } - mpz_clear (len); - } - - if (!comp->attr.pointer || comp->attr.proc_pointer - || cons->expr->expr_type == EXPR_NULL) - continue; - - a = gfc_expr_attr (cons->expr); - - if (!a.pointer && !a.target) - { - t = false; - gfc_error ("The element in the structure constructor at %L, " - "for pointer component %qs should be a POINTER or " - "a TARGET", &cons->expr->where, comp->name); - } - - if (init) - { - /* F08:C461. Additional checks for pointer initialization. */ - if (a.allocatable) - { - t = false; - gfc_error ("Pointer initialization target at %L " - "must not be ALLOCATABLE", &cons->expr->where); - } - if (!a.save) - { - t = false; - gfc_error ("Pointer initialization target at %L " - "must have the SAVE attribute", &cons->expr->where); - } - } - - /* F2003, C1272 (3). */ - bool impure = cons->expr->expr_type == EXPR_VARIABLE - && (gfc_impure_variable (cons->expr->symtree->n.sym) - || gfc_is_coindexed (cons->expr)); - if (impure && gfc_pure (NULL)) - { - t = false; - gfc_error ("Invalid expression in the structure constructor for " - "pointer component %qs at %L in PURE procedure", - comp->name, &cons->expr->where); - } - - if (impure) - gfc_unset_implicit_pure (NULL); - } - - return t; -} - - -/****************** Expression name resolution ******************/ - -/* Returns 0 if a symbol was not declared with a type or - attribute declaration statement, nonzero otherwise. */ - -static int -was_declared (gfc_symbol *sym) -{ - symbol_attribute a; - - a = sym->attr; - - if (!a.implicit_type && sym->ts.type != BT_UNKNOWN) - return 1; - - if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic - || a.optional || a.pointer || a.save || a.target || a.volatile_ - || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN - || a.asynchronous || a.codimension) - return 1; - - return 0; -} - - -/* Determine if a symbol is generic or not. */ - -static int -generic_sym (gfc_symbol *sym) -{ - gfc_symbol *s; - - if (sym->attr.generic || - (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name))) - return 1; - - if (was_declared (sym) || sym->ns->parent == NULL) - return 0; - - gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); - - if (s != NULL) - { - if (s == sym) - return 0; - else - return generic_sym (s); - } - - return 0; -} - - -/* Determine if a symbol is specific or not. */ - -static int -specific_sym (gfc_symbol *sym) -{ - gfc_symbol *s; - - if (sym->attr.if_source == IFSRC_IFBODY - || sym->attr.proc == PROC_MODULE - || sym->attr.proc == PROC_INTERNAL - || sym->attr.proc == PROC_ST_FUNCTION - || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name)) - || sym->attr.external) - return 1; - - if (was_declared (sym) || sym->ns->parent == NULL) - return 0; - - gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); - - return (s == NULL) ? 0 : specific_sym (s); -} - - -/* Figure out if the procedure is specific, generic or unknown. */ - -enum proc_type -{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }; - -static proc_type -procedure_kind (gfc_symbol *sym) -{ - if (generic_sym (sym)) - return PTYPE_GENERIC; - - if (specific_sym (sym)) - return PTYPE_SPECIFIC; - - return PTYPE_UNKNOWN; -} - -/* Check references to assumed size arrays. The flag need_full_assumed_size - is nonzero when matching actual arguments. */ - -static int need_full_assumed_size = 0; - -static bool -check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e) -{ - if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) - return false; - - /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong. - What should it be? */ - if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL) - && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) - && (e->ref->u.ar.type == AR_FULL)) - { - gfc_error ("The upper bound in the last dimension must " - "appear in the reference to the assumed size " - "array %qs at %L", sym->name, &e->where); - return true; - } - return false; -} - - -/* Look for bad assumed size array references in argument expressions - of elemental and array valued intrinsic procedures. Since this is - called from procedure resolution functions, it only recurses at - operators. */ - -static bool -resolve_assumed_size_actual (gfc_expr *e) -{ - if (e == NULL) - return false; - - switch (e->expr_type) - { - case EXPR_VARIABLE: - if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e)) - return true; - break; - - case EXPR_OP: - if (resolve_assumed_size_actual (e->value.op.op1) - || resolve_assumed_size_actual (e->value.op.op2)) - return true; - break; - - default: - break; - } - return false; -} - - -/* Check a generic procedure, passed as an actual argument, to see if - there is a matching specific name. If none, it is an error, and if - more than one, the reference is ambiguous. */ -static int -count_specific_procs (gfc_expr *e) -{ - int n; - gfc_interface *p; - gfc_symbol *sym; - - n = 0; - sym = e->symtree->n.sym; - - for (p = sym->generic; p; p = p->next) - if (strcmp (sym->name, p->sym->name) == 0) - { - e->symtree = gfc_find_symtree (p->sym->ns->sym_root, - sym->name); - n++; - } - - if (n > 1) - gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, - &e->where); - - if (n == 0) - gfc_error ("GENERIC procedure %qs is not allowed as an actual " - "argument at %L", sym->name, &e->where); - - return n; -} - - -/* See if a call to sym could possibly be a not allowed RECURSION because of - a missing RECURSIVE declaration. This means that either sym is the current - context itself, or sym is the parent of a contained procedure calling its - non-RECURSIVE containing procedure. - This also works if sym is an ENTRY. */ - -static bool -is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) -{ - gfc_symbol* proc_sym; - gfc_symbol* context_proc; - gfc_namespace* real_context; - - if (sym->attr.flavor == FL_PROGRAM - || gfc_fl_struct (sym->attr.flavor)) - return false; - - /* If we've got an ENTRY, find real procedure. */ - if (sym->attr.entry && sym->ns->entries) - proc_sym = sym->ns->entries->sym; - else - proc_sym = sym; - - /* If sym is RECURSIVE, all is well of course. */ - if (proc_sym->attr.recursive || flag_recursive) - return false; - - /* Find the context procedure's "real" symbol if it has entries. - We look for a procedure symbol, so recurse on the parents if we don't - find one (like in case of a BLOCK construct). */ - for (real_context = context; ; real_context = real_context->parent) - { - /* We should find something, eventually! */ - gcc_assert (real_context); - - context_proc = (real_context->entries ? real_context->entries->sym - : real_context->proc_name); - - /* In some special cases, there may not be a proc_name, like for this - invalid code: - real(bad_kind()) function foo () ... - when checking the call to bad_kind (). - In these cases, we simply return here and assume that the - call is ok. */ - if (!context_proc) - return false; - - if (context_proc->attr.flavor != FL_LABEL) - break; - } - - /* A call from sym's body to itself is recursion, of course. */ - if (context_proc == proc_sym) - return true; - - /* The same is true if context is a contained procedure and sym the - containing one. */ - if (context_proc->attr.contained) - { - gfc_symbol* parent_proc; - - gcc_assert (context->parent); - parent_proc = (context->parent->entries ? context->parent->entries->sym - : context->parent->proc_name); - - if (parent_proc == proc_sym) - return true; - } - - return false; -} - - -/* Resolve an intrinsic procedure: Set its function/subroutine attribute, - its typespec and formal argument list. */ - -bool -gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) -{ - gfc_intrinsic_sym* isym = NULL; - const char* symstd; - - if (sym->resolve_symbol_called >= 2) - return true; - - sym->resolve_symbol_called = 2; - - /* Already resolved. */ - if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) - return true; - - /* We already know this one is an intrinsic, so we don't call - gfc_is_intrinsic for full checking but rather use gfc_find_function and - gfc_find_subroutine directly to check whether it is a function or - subroutine. */ - - if (sym->intmod_sym_id && sym->attr.subroutine) - { - gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); - isym = gfc_intrinsic_subroutine_by_id (id); - } - else if (sym->intmod_sym_id) - { - gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); - isym = gfc_intrinsic_function_by_id (id); - } - else if (!sym->attr.subroutine) - isym = gfc_find_function (sym->name); - - if (isym && !sym->attr.subroutine) - { - if (sym->ts.type != BT_UNKNOWN && warn_surprising - && !sym->attr.implicit_type) - gfc_warning (OPT_Wsurprising, - "Type specified for intrinsic function %qs at %L is" - " ignored", sym->name, &sym->declared_at); - - if (!sym->attr.function && - !gfc_add_function(&sym->attr, sym->name, loc)) - return false; - - sym->ts = isym->ts; - } - else if (isym || (isym = gfc_find_subroutine (sym->name))) - { - if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) - { - gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" - " specifier", sym->name, &sym->declared_at); - return false; - } - - if (!sym->attr.subroutine && - !gfc_add_subroutine(&sym->attr, sym->name, loc)) - return false; - } - else - { - gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, - &sym->declared_at); - return false; - } - - gfc_copy_formal_args_intr (sym, isym, NULL); - - sym->attr.pure = isym->pure; - sym->attr.elemental = isym->elemental; - - /* Check it is actually available in the standard settings. */ - if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) - { - gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not " - "available in the current standard settings but %s. Use " - "an appropriate %<-std=*%> option or enable " - "%<-fall-intrinsics%> in order to use it.", - sym->name, &sym->declared_at, symstd); - return false; - } - - return true; -} - - -/* Resolve a procedure expression, like passing it to a called procedure or as - RHS for a procedure pointer assignment. */ - -static bool -resolve_procedure_expression (gfc_expr* expr) -{ - gfc_symbol* sym; - - if (expr->expr_type != EXPR_VARIABLE) - return true; - gcc_assert (expr->symtree); - - sym = expr->symtree->n.sym; - - if (sym->attr.intrinsic) - gfc_resolve_intrinsic (sym, &expr->where); - - if (sym->attr.flavor != FL_PROCEDURE - || (sym->attr.function && sym->result == sym)) - return true; - - /* A non-RECURSIVE procedure that is used as procedure expression within its - own body is in danger of being called recursively. */ - if (is_illegal_recursion (sym, gfc_current_ns)) - gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" - " itself recursively. Declare it RECURSIVE or use" - " %<-frecursive%>", sym->name, &expr->where); - - return true; -} - - -/* Check that name is not a derived type. */ - -static bool -is_dt_name (const char *name) -{ - gfc_symbol *dt_list, *dt_first; - - dt_list = dt_first = gfc_derived_types; - for (; dt_list; dt_list = dt_list->dt_next) - { - if (strcmp(dt_list->name, name) == 0) - return true; - if (dt_first == dt_list->dt_next) - break; - } - return false; -} - - -/* Resolve an actual argument list. Most of the time, this is just - resolving the expressions in the list. - The exception is that we sometimes have to decide whether arguments - that look like procedure arguments are really simple variable - references. */ - -static bool -resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, - bool no_formal_args) -{ - gfc_symbol *sym; - gfc_symtree *parent_st; - gfc_expr *e; - gfc_component *comp; - int save_need_full_assumed_size; - bool return_value = false; - bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; - - actual_arg = true; - first_actual_arg = true; - - for (; arg; arg = arg->next) - { - e = arg->expr; - if (e == NULL) - { - /* Check the label is a valid branching target. */ - if (arg->label) - { - if (arg->label->defined == ST_LABEL_UNKNOWN) - { - gfc_error ("Label %d referenced at %L is never defined", - arg->label->value, &arg->label->where); - goto cleanup; - } - } - first_actual_arg = false; - continue; - } - - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.generic - && no_formal_args - && count_specific_procs (e) != 1) - goto cleanup; - - if (e->ts.type != BT_PROCEDURE) - { - save_need_full_assumed_size = need_full_assumed_size; - if (e->expr_type != EXPR_VARIABLE) - need_full_assumed_size = 0; - if (!gfc_resolve_expr (e)) - goto cleanup; - need_full_assumed_size = save_need_full_assumed_size; - goto argument_list; - } - - /* See if the expression node should really be a variable reference. */ - - sym = e->symtree->n.sym; - - if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name)) - { - gfc_error ("Derived type %qs is used as an actual " - "argument at %L", sym->name, &e->where); - goto cleanup; - } - - if (sym->attr.flavor == FL_PROCEDURE - || sym->attr.intrinsic - || sym->attr.external) - { - int actual_ok; - - /* If a procedure is not already determined to be something else - check if it is intrinsic. */ - if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) - sym->attr.intrinsic = 1; - - if (sym->attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Statement function %qs at %L is not allowed as an " - "actual argument", sym->name, &e->where); - } - - actual_ok = gfc_intrinsic_actual_ok (sym->name, - sym->attr.subroutine); - if (sym->attr.intrinsic && actual_ok == 0) - { - gfc_error ("Intrinsic %qs at %L is not allowed as an " - "actual argument", sym->name, &e->where); - } - - if (sym->attr.contained && !sym->attr.use_assoc - && sym->ns->proc_name->attr.flavor != FL_MODULE) - { - if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is" - " used as actual argument at %L", - sym->name, &e->where)) - goto cleanup; - } - - if (sym->attr.elemental && !sym->attr.intrinsic) - { - gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " - "allowed as an actual argument at %L", sym->name, - &e->where); - } - - /* Check if a generic interface has a specific procedure - with the same name before emitting an error. */ - if (sym->attr.generic && count_specific_procs (e) != 1) - goto cleanup; - - /* Just in case a specific was found for the expression. */ - sym = e->symtree->n.sym; - - /* If the symbol is the function that names the current (or - parent) scope, then we really have a variable reference. */ - - if (gfc_is_function_return_value (sym, sym->ns)) - goto got_variable; - - /* If all else fails, see if we have a specific intrinsic. */ - if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) - { - gfc_intrinsic_sym *isym; - - isym = gfc_find_function (sym->name); - if (isym == NULL || !isym->specific) - { - gfc_error ("Unable to find a specific INTRINSIC procedure " - "for the reference %qs at %L", sym->name, - &e->where); - goto cleanup; - } - sym->ts = isym->ts; - sym->attr.intrinsic = 1; - sym->attr.function = 1; - } - - if (!gfc_resolve_expr (e)) - goto cleanup; - goto argument_list; - } - - /* See if the name is a module procedure in a parent unit. */ - - if (was_declared (sym) || sym->ns->parent == NULL) - goto got_variable; - - if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) - { - gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); - goto cleanup; - } - - if (parent_st == NULL) - goto got_variable; - - sym = parent_st->n.sym; - e->symtree = parent_st; /* Point to the right thing. */ - - if (sym->attr.flavor == FL_PROCEDURE - || sym->attr.intrinsic - || sym->attr.external) - { - if (!gfc_resolve_expr (e)) - goto cleanup; - goto argument_list; - } - - got_variable: - e->expr_type = EXPR_VARIABLE; - e->ts = sym->ts; - if ((sym->as != NULL && sym->ts.type != BT_CLASS) - || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && CLASS_DATA (sym)->as)) - { - e->rank = sym->ts.type == BT_CLASS - ? CLASS_DATA (sym)->as->rank : sym->as->rank; - e->ref = gfc_get_ref (); - e->ref->type = REF_ARRAY; - e->ref->u.ar.type = AR_FULL; - e->ref->u.ar.as = sym->ts.type == BT_CLASS - ? CLASS_DATA (sym)->as : sym->as; - } - - /* Expressions are assigned a default ts.type of BT_PROCEDURE in - primary.c (match_actual_arg). If above code determines that it - is a variable instead, it needs to be resolved as it was not - done at the beginning of this function. */ - save_need_full_assumed_size = need_full_assumed_size; - if (e->expr_type != EXPR_VARIABLE) - need_full_assumed_size = 0; - if (!gfc_resolve_expr (e)) - goto cleanup; - need_full_assumed_size = save_need_full_assumed_size; - - argument_list: - /* Check argument list functions %VAL, %LOC and %REF. There is - nothing to do for %REF. */ - if (arg->name && arg->name[0] == '%') - { - if (strcmp ("%VAL", arg->name) == 0) - { - if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED) - { - gfc_error ("By-value argument at %L is not of numeric " - "type", &e->where); - goto cleanup; - } - - if (e->rank) - { - gfc_error ("By-value argument at %L cannot be an array or " - "an array section", &e->where); - goto cleanup; - } - - /* Intrinsics are still PROC_UNKNOWN here. However, - since same file external procedures are not resolvable - in gfortran, it is a good deal easier to leave them to - intrinsic.c. */ - if (ptype != PROC_UNKNOWN - && ptype != PROC_DUMMY - && ptype != PROC_EXTERNAL - && ptype != PROC_MODULE) - { - gfc_error ("By-value argument at %L is not allowed " - "in this context", &e->where); - goto cleanup; - } - } - - /* Statement functions have already been excluded above. */ - else if (strcmp ("%LOC", arg->name) == 0 - && e->ts.type == BT_PROCEDURE) - { - if (e->symtree->n.sym->attr.proc == PROC_INTERNAL) - { - gfc_error ("Passing internal procedure at %L by location " - "not allowed", &e->where); - goto cleanup; - } - } - } - - comp = gfc_get_proc_ptr_comp(e); - if (e->expr_type == EXPR_VARIABLE - && comp && comp->attr.elemental) - { - gfc_error ("ELEMENTAL procedure pointer component %qs is not " - "allowed as an actual argument at %L", comp->name, - &e->where); - } - - /* Fortran 2008, C1237. */ - if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) - && gfc_has_ultimate_pointer (e)) - { - gfc_error ("Coindexed actual argument at %L with ultimate pointer " - "component", &e->where); - goto cleanup; - } - - first_actual_arg = false; - } - - return_value = true; - -cleanup: - actual_arg = actual_arg_sav; - first_actual_arg = first_actual_arg_sav; - - return return_value; -} - - -/* Do the checks of the actual argument list that are specific to elemental - procedures. If called with c == NULL, we have a function, otherwise if - expr == NULL, we have a subroutine. */ - -static bool -resolve_elemental_actual (gfc_expr *expr, gfc_code *c) -{ - gfc_actual_arglist *arg0; - gfc_actual_arglist *arg; - gfc_symbol *esym = NULL; - gfc_intrinsic_sym *isym = NULL; - gfc_expr *e = NULL; - gfc_intrinsic_arg *iformal = NULL; - gfc_formal_arglist *eformal = NULL; - bool formal_optional = false; - bool set_by_optional = false; - int i; - int rank = 0; - - /* Is this an elemental procedure? */ - if (expr && expr->value.function.actual != NULL) - { - if (expr->value.function.esym != NULL - && expr->value.function.esym->attr.elemental) - { - arg0 = expr->value.function.actual; - esym = expr->value.function.esym; - } - else if (expr->value.function.isym != NULL - && expr->value.function.isym->elemental) - { - arg0 = expr->value.function.actual; - isym = expr->value.function.isym; - } - else - return true; - } - else if (c && c->ext.actual != NULL) - { - arg0 = c->ext.actual; - - if (c->resolved_sym) - esym = c->resolved_sym; - else - esym = c->symtree->n.sym; - gcc_assert (esym); - - if (!esym->attr.elemental) - return true; - } - else - return true; - - /* The rank of an elemental is the rank of its array argument(s). */ - for (arg = arg0; arg; arg = arg->next) - { - if (arg->expr != NULL && arg->expr->rank != 0) - { - rank = arg->expr->rank; - if (arg->expr->expr_type == EXPR_VARIABLE - && arg->expr->symtree->n.sym->attr.optional) - set_by_optional = true; - - /* Function specific; set the result rank and shape. */ - if (expr) - { - expr->rank = rank; - if (!expr->shape && arg->expr->shape) - { - expr->shape = gfc_get_shape (rank); - for (i = 0; i < rank; i++) - mpz_init_set (expr->shape[i], arg->expr->shape[i]); - } - } - break; - } - } - - /* If it is an array, it shall not be supplied as an actual argument - to an elemental procedure unless an array of the same rank is supplied - as an actual argument corresponding to a nonoptional dummy argument of - that elemental procedure(12.4.1.5). */ - formal_optional = false; - if (isym) - iformal = isym->formal; - else - eformal = esym->formal; - - for (arg = arg0; arg; arg = arg->next) - { - if (eformal) - { - if (eformal->sym && eformal->sym->attr.optional) - formal_optional = true; - eformal = eformal->next; - } - else if (isym && iformal) - { - if (iformal->optional) - formal_optional = true; - iformal = iformal->next; - } - else if (isym) - formal_optional = true; - - if (pedantic && arg->expr != NULL - && arg->expr->expr_type == EXPR_VARIABLE - && arg->expr->symtree->n.sym->attr.optional - && formal_optional - && arg->expr->rank - && (set_by_optional || arg->expr->rank != rank) - && !(isym && isym->id == GFC_ISYM_CONVERSION)) - { - bool t = false; - gfc_actual_arglist *a; - - /* Scan the argument list for a non-optional argument with the - same rank as arg. */ - for (a = arg0; a; a = a->next) - if (a != arg - && a->expr->rank == arg->expr->rank - && !a->expr->symtree->n.sym->attr.optional) - { - t = true; - break; - } - - if (!t) - gfc_warning (OPT_Wpedantic, - "%qs at %L is an array and OPTIONAL; If it is not " - "present, then it cannot be the actual argument of " - "an ELEMENTAL procedure unless there is a non-optional" - " argument with the same rank " - "(Fortran 2018, 15.5.2.12)", - arg->expr->symtree->n.sym->name, &arg->expr->where); - } - } - - for (arg = arg0; arg; arg = arg->next) - { - if (arg->expr == NULL || arg->expr->rank == 0) - continue; - - /* Being elemental, the last upper bound of an assumed size array - argument must be present. */ - if (resolve_assumed_size_actual (arg->expr)) - return false; - - /* Elemental procedure's array actual arguments must conform. */ - if (e != NULL) - { - if (!gfc_check_conformance (arg->expr, e, _("elemental procedure"))) - return false; - } - else - e = arg->expr; - } - - /* INTENT(OUT) is only allowed for subroutines; if any actual argument - is an array, the intent inout/out variable needs to be also an array. */ - if (rank > 0 && esym && expr == NULL) - for (eformal = esym->formal, arg = arg0; arg && eformal; - arg = arg->next, eformal = eformal->next) - if ((eformal->sym->attr.intent == INTENT_OUT - || eformal->sym->attr.intent == INTENT_INOUT) - && arg->expr && arg->expr->rank == 0) - { - gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " - "ELEMENTAL subroutine %qs is a scalar, but another " - "actual argument is an array", &arg->expr->where, - (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" - : "INOUT", eformal->sym->name, esym->name); - return false; - } - return true; -} - - -/* This function does the checking of references to global procedures - as defined in sections 18.1 and 14.1, respectively, of the Fortran - 77 and 95 standards. It checks for a gsymbol for the name, making - one if it does not already exist. If it already exists, then the - reference being resolved must correspond to the type of gsymbol. - Otherwise, the new symbol is equipped with the attributes of the - reference. The corresponding code that is called in creating - global entities is parse.c. - - In addition, for all but -std=legacy, the gsymbols are used to - check the interfaces of external procedures from the same file. - The namespace of the gsymbol is resolved and then, once this is - done the interface is checked. */ - - -static bool -not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns) -{ - if (!gsym_ns->proc_name->attr.recursive) - return true; - - if (sym->ns == gsym_ns) - return false; - - if (sym->ns->parent && sym->ns->parent == gsym_ns) - return false; - - return true; -} - -static bool -not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) -{ - if (gsym_ns->entries) - { - gfc_entry_list *entry = gsym_ns->entries; - - for (; entry; entry = entry->next) - { - if (strcmp (sym->name, entry->sym->name) == 0) - { - if (strcmp (gsym_ns->proc_name->name, - sym->ns->proc_name->name) == 0) - return false; - - if (sym->ns->parent - && strcmp (gsym_ns->proc_name->name, - sym->ns->parent->proc_name->name) == 0) - return false; - } - } - } - return true; -} - - -/* Check for the requirement of an explicit interface. F08:12.4.2.2. */ - -bool -gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) -{ - gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym); - - for ( ; arg; arg = arg->next) - { - if (!arg->sym) - continue; - - if (arg->sym->attr.allocatable) /* (2a) */ - { - strncpy (errmsg, _("allocatable argument"), err_len); - return true; - } - else if (arg->sym->attr.asynchronous) - { - strncpy (errmsg, _("asynchronous argument"), err_len); - return true; - } - else if (arg->sym->attr.optional) - { - strncpy (errmsg, _("optional argument"), err_len); - return true; - } - else if (arg->sym->attr.pointer) - { - strncpy (errmsg, _("pointer argument"), err_len); - return true; - } - else if (arg->sym->attr.target) - { - strncpy (errmsg, _("target argument"), err_len); - return true; - } - else if (arg->sym->attr.value) - { - strncpy (errmsg, _("value argument"), err_len); - return true; - } - else if (arg->sym->attr.volatile_) - { - strncpy (errmsg, _("volatile argument"), err_len); - return true; - } - else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */ - { - strncpy (errmsg, _("assumed-shape argument"), err_len); - return true; - } - else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */ - { - strncpy (errmsg, _("assumed-rank argument"), err_len); - return true; - } - else if (arg->sym->attr.codimension) /* (2c) */ - { - strncpy (errmsg, _("coarray argument"), err_len); - return true; - } - else if (false) /* (2d) TODO: parametrized derived type */ - { - strncpy (errmsg, _("parametrized derived type argument"), err_len); - return true; - } - else if (arg->sym->ts.type == BT_CLASS) /* (2e) */ - { - strncpy (errmsg, _("polymorphic argument"), err_len); - return true; - } - else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - { - strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len); - return true; - } - else if (arg->sym->ts.type == BT_ASSUMED) - { - /* As assumed-type is unlimited polymorphic (cf. above). - See also TS 29113, Note 6.1. */ - strncpy (errmsg, _("assumed-type argument"), err_len); - return true; - } - } - - if (sym->attr.function) - { - gfc_symbol *res = sym->result ? sym->result : sym; - - if (res->attr.dimension) /* (3a) */ - { - strncpy (errmsg, _("array result"), err_len); - return true; - } - else if (res->attr.pointer || res->attr.allocatable) /* (3b) */ - { - strncpy (errmsg, _("pointer or allocatable result"), err_len); - return true; - } - else if (res->ts.type == BT_CHARACTER && res->ts.u.cl - && res->ts.u.cl->length - && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */ - { - strncpy (errmsg, _("result with non-constant character length"), err_len); - return true; - } - } - - if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */ - { - strncpy (errmsg, _("elemental procedure"), err_len); - return true; - } - else if (sym->attr.is_bind_c) /* (5) */ - { - strncpy (errmsg, _("bind(c) procedure"), err_len); - return true; - } - - return false; -} - - -static void -resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) -{ - gfc_gsymbol * gsym; - gfc_namespace *ns; - enum gfc_symbol_type type; - char reason[200]; - - type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; - - gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name, - sym->binding_label != NULL); - - if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) - gfc_global_used (gsym, where); - - if ((sym->attr.if_source == IFSRC_UNKNOWN - || sym->attr.if_source == IFSRC_IFBODY) - && gsym->type != GSYM_UNKNOWN - && !gsym->binding_label - && gsym->ns - && gsym->ns->proc_name - && not_in_recursive (sym, gsym->ns) - && not_entry_self_reference (sym, gsym->ns)) - { - gfc_symbol *def_sym; - def_sym = gsym->ns->proc_name; - - if (gsym->ns->resolved != -1) - { - - /* Resolve the gsymbol namespace if needed. */ - if (!gsym->ns->resolved) - { - gfc_symbol *old_dt_list; - - /* Stash away derived types so that the backend_decls - do not get mixed up. */ - old_dt_list = gfc_derived_types; - gfc_derived_types = NULL; - - gfc_resolve (gsym->ns); - - /* Store the new derived types with the global namespace. */ - if (gfc_derived_types) - gsym->ns->derived_types = gfc_derived_types; - - /* Restore the derived types of this namespace. */ - gfc_derived_types = old_dt_list; - } - - /* Make sure that translation for the gsymbol occurs before - the procedure currently being resolved. */ - ns = gfc_global_ns_list; - for (; ns && ns != gsym->ns; ns = ns->sibling) - { - if (ns->sibling == gsym->ns) - { - ns->sibling = gsym->ns->sibling; - gsym->ns->sibling = gfc_global_ns_list; - gfc_global_ns_list = gsym->ns; - break; - } - } - - /* This can happen if a binding name has been specified. */ - if (gsym->binding_label && gsym->sym_name != def_sym->name) - gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym); - - if (def_sym->attr.entry_master || def_sym->attr.entry) - { - gfc_entry_list *entry; - for (entry = gsym->ns->entries; entry; entry = entry->next) - if (strcmp (entry->sym->name, sym->name) == 0) - { - def_sym = entry->sym; - break; - } - } - } - - if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) - { - gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", - sym->name, &sym->declared_at, gfc_typename (&sym->ts), - gfc_typename (&def_sym->ts)); - goto done; - } - - if (sym->attr.if_source == IFSRC_UNKNOWN - && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) - { - gfc_error ("Explicit interface required for %qs at %L: %s", - sym->name, &sym->declared_at, reason); - goto done; - } - - bool bad_result_characteristics; - if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, - reason, sizeof(reason), NULL, NULL, - &bad_result_characteristics)) - { - /* Turn erros into warnings with -std=gnu and -std=legacy, - unless a function returns a wrong type, which can lead - to all kinds of ICEs and wrong code. */ - - if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU) - && !bad_result_characteristics) - gfc_errors_to_warnings (true); - - gfc_error ("Interface mismatch in global procedure %qs at %L: %s", - sym->name, &sym->declared_at, reason); - sym->error = 1; - gfc_errors_to_warnings (false); - goto done; - } - } - -done: - - if (gsym->type == GSYM_UNKNOWN) - { - gsym->type = type; - gsym->where = *where; - } - - gsym->used = 1; -} - - -/************* Function resolution *************/ - -/* Resolve a function call known to be generic. - Section 14.1.2.4.1. */ - -static match -resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) -{ - gfc_symbol *s; - - if (sym->attr.generic) - { - s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual); - if (s != NULL) - { - expr->value.function.name = s->name; - expr->value.function.esym = s; - - if (s->ts.type != BT_UNKNOWN) - expr->ts = s->ts; - else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN) - expr->ts = s->result->ts; - - if (s->as != NULL) - expr->rank = s->as->rank; - else if (s->result != NULL && s->result->as != NULL) - expr->rank = s->result->as->rank; - - gfc_set_sym_referenced (expr->value.function.esym); - - return MATCH_YES; - } - - /* TODO: Need to search for elemental references in generic - interface. */ - } - - if (sym->attr.intrinsic) - return gfc_intrinsic_func_interface (expr, 0); - - return MATCH_NO; -} - - -static bool -resolve_generic_f (gfc_expr *expr) -{ - gfc_symbol *sym; - match m; - gfc_interface *intr = NULL; - - sym = expr->symtree->n.sym; - - for (;;) - { - m = resolve_generic_f0 (expr, sym); - if (m == MATCH_YES) - return true; - else if (m == MATCH_ERROR) - return false; - -generic: - if (!intr) - for (intr = sym->generic; intr; intr = intr->next) - if (gfc_fl_struct (intr->sym->attr.flavor)) - break; - - if (sym->ns->parent == NULL) - break; - gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); - - if (sym == NULL) - break; - if (!generic_sym (sym)) - goto generic; - } - - /* Last ditch attempt. See if the reference is to an intrinsic - that possesses a matching interface. 14.1.2.4 */ - if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) - { - if (gfc_init_expr_flag) - gfc_error ("Function %qs in initialization expression at %L " - "must be an intrinsic function", - expr->symtree->n.sym->name, &expr->where); - else - gfc_error ("There is no specific function for the generic %qs " - "at %L", expr->symtree->n.sym->name, &expr->where); - return false; - } - - if (intr) - { - if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, - NULL, false)) - return false; - if (!gfc_use_derived (expr->ts.u.derived)) - return false; - return resolve_structure_cons (expr, 0); - } - - m = gfc_intrinsic_func_interface (expr, 0); - if (m == MATCH_YES) - return true; - - if (m == MATCH_NO) - gfc_error ("Generic function %qs at %L is not consistent with a " - "specific intrinsic interface", expr->symtree->n.sym->name, - &expr->where); - - return false; -} - - -/* Resolve a function call known to be specific. */ - -static match -resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) -{ - match m; - - if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) - { - if (sym->attr.dummy) - { - sym->attr.proc = PROC_DUMMY; - goto found; - } - - sym->attr.proc = PROC_EXTERNAL; - goto found; - } - - if (sym->attr.proc == PROC_MODULE - || sym->attr.proc == PROC_ST_FUNCTION - || sym->attr.proc == PROC_INTERNAL) - goto found; - - if (sym->attr.intrinsic) - { - m = gfc_intrinsic_func_interface (expr, 1); - if (m == MATCH_YES) - return MATCH_YES; - if (m == MATCH_NO) - gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " - "with an intrinsic", sym->name, &expr->where); - - return MATCH_ERROR; - } - - return MATCH_NO; - -found: - gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); - - if (sym->result) - expr->ts = sym->result->ts; - else - expr->ts = sym->ts; - expr->value.function.name = sym->name; - expr->value.function.esym = sym; - /* Prevent crash when sym->ts.u.derived->components is not set due to previous - error(s). */ - if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)) - return MATCH_ERROR; - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) - expr->rank = CLASS_DATA (sym)->as->rank; - else if (sym->as != NULL) - expr->rank = sym->as->rank; - - return MATCH_YES; -} - - -static bool -resolve_specific_f (gfc_expr *expr) -{ - gfc_symbol *sym; - match m; - - sym = expr->symtree->n.sym; - - for (;;) - { - m = resolve_specific_f0 (sym, expr); - if (m == MATCH_YES) - return true; - if (m == MATCH_ERROR) - return false; - - if (sym->ns->parent == NULL) - break; - - gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); - - if (sym == NULL) - break; - } - - gfc_error ("Unable to resolve the specific function %qs at %L", - expr->symtree->n.sym->name, &expr->where); - - return true; -} - -/* Recursively append candidate SYM to CANDIDATES. Store the number of - candidates in CANDIDATES_LEN. */ - -static void -lookup_function_fuzzy_find_candidates (gfc_symtree *sym, - char **&candidates, - size_t &candidates_len) -{ - gfc_symtree *p; - - if (sym == NULL) - return; - if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external) - && sym->n.sym->attr.flavor == FL_PROCEDURE) - vec_push (candidates, candidates_len, sym->name); - - p = sym->left; - if (p) - lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); - - p = sym->right; - if (p) - lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); -} - - -/* Lookup function FN fuzzily, taking names in SYMROOT into account. */ - -const char* -gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot) -{ - char **candidates = NULL; - size_t candidates_len = 0; - lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len); - return gfc_closest_fuzzy_match (fn, candidates); -} - - -/* Resolve a procedure call not known to be generic nor specific. */ - -static bool -resolve_unknown_f (gfc_expr *expr) -{ - gfc_symbol *sym; - gfc_typespec *ts; - - sym = expr->symtree->n.sym; - - if (sym->attr.dummy) - { - sym->attr.proc = PROC_DUMMY; - expr->value.function.name = sym->name; - goto set_type; - } - - /* See if we have an intrinsic function reference. */ - - if (gfc_is_intrinsic (sym, 0, expr->where)) - { - if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) - return true; - return false; - } - - /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */ - /* Intrinsics were handled above, only non-intrinsics left here. */ - if (sym->attr.flavor == FL_PROCEDURE - && sym->attr.implicit_type - && sym->ns - && sym->ns->has_implicit_none_export) - { - gfc_error ("Missing explicit declaration with EXTERNAL attribute " - "for symbol %qs at %L", sym->name, &sym->declared_at); - sym->error = 1; - return false; - } - - /* The reference is to an external name. */ - - sym->attr.proc = PROC_EXTERNAL; - expr->value.function.name = sym->name; - expr->value.function.esym = expr->symtree->n.sym; - - if (sym->as != NULL) - expr->rank = sym->as->rank; - - /* Type of the expression is either the type of the symbol or the - default type of the symbol. */ - -set_type: - gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); - - if (sym->ts.type != BT_UNKNOWN) - expr->ts = sym->ts; - else - { - ts = gfc_get_default_type (sym->name, sym->ns); - - if (ts->type == BT_UNKNOWN) - { - const char *guessed - = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); - if (guessed) - gfc_error ("Function %qs at %L has no IMPLICIT type" - "; did you mean %qs?", - sym->name, &expr->where, guessed); - else - gfc_error ("Function %qs at %L has no IMPLICIT type", - sym->name, &expr->where); - return false; - } - else - expr->ts = *ts; - } - - return true; -} - - -/* Return true, if the symbol is an external procedure. */ -static bool -is_external_proc (gfc_symbol *sym) -{ - if (!sym->attr.dummy && !sym->attr.contained - && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) - && sym->attr.proc != PROC_ST_FUNCTION - && !sym->attr.proc_pointer - && !sym->attr.use_assoc - && sym->name) - return true; - - return false; -} - - -/* Figure out if a function reference is pure or not. Also set the name - of the function for a potential error message. Return nonzero if the - function is PURE, zero if not. */ -static int -pure_stmt_function (gfc_expr *, gfc_symbol *); - -int -gfc_pure_function (gfc_expr *e, const char **name) -{ - int pure; - gfc_component *comp; - - *name = NULL; - - if (e->symtree != NULL - && e->symtree->n.sym != NULL - && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) - return pure_stmt_function (e, e->symtree->n.sym); - - comp = gfc_get_proc_ptr_comp (e); - if (comp) - { - pure = gfc_pure (comp->ts.interface); - *name = comp->name; - } - else if (e->value.function.esym) - { - pure = gfc_pure (e->value.function.esym); - *name = e->value.function.esym->name; - } - else if (e->value.function.isym) - { - pure = e->value.function.isym->pure - || e->value.function.isym->elemental; - *name = e->value.function.isym->name; - } - else - { - /* Implicit functions are not pure. */ - pure = 0; - *name = e->value.function.name; - } - - return pure; -} - - -/* Check if the expression is a reference to an implicitly pure function. */ - -int -gfc_implicit_pure_function (gfc_expr *e) -{ - gfc_component *comp = gfc_get_proc_ptr_comp (e); - if (comp) - return gfc_implicit_pure (comp->ts.interface); - else if (e->value.function.esym) - return gfc_implicit_pure (e->value.function.esym); - else - return 0; -} - - -static bool -impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym, - int *f ATTRIBUTE_UNUSED) -{ - const char *name; - - /* Don't bother recursing into other statement functions - since they will be checked individually for purity. */ - if (e->expr_type != EXPR_FUNCTION - || !e->symtree - || e->symtree->n.sym == sym - || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) - return false; - - return gfc_pure_function (e, &name) ? false : true; -} - - -static int -pure_stmt_function (gfc_expr *e, gfc_symbol *sym) -{ - return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1; -} - - -/* Check if an impure function is allowed in the current context. */ - -static bool check_pure_function (gfc_expr *e) -{ - const char *name = NULL; - if (!gfc_pure_function (e, &name) && name) - { - if (forall_flag) - { - gfc_error ("Reference to impure function %qs at %L inside a " - "FORALL %s", name, &e->where, - forall_flag == 2 ? "mask" : "block"); - return false; - } - else if (gfc_do_concurrent_flag) - { - gfc_error ("Reference to impure function %qs at %L inside a " - "DO CONCURRENT %s", name, &e->where, - gfc_do_concurrent_flag == 2 ? "mask" : "block"); - return false; - } - else if (gfc_pure (NULL)) - { - gfc_error ("Reference to impure function %qs at %L " - "within a PURE procedure", name, &e->where); - return false; - } - if (!gfc_implicit_pure_function (e)) - gfc_unset_implicit_pure (NULL); - } - return true; -} - - -/* Update current procedure's array_outer_dependency flag, considering - a call to procedure SYM. */ - -static void -update_current_proc_array_outer_dependency (gfc_symbol *sym) -{ - /* Check to see if this is a sibling function that has not yet - been resolved. */ - gfc_namespace *sibling = gfc_current_ns->sibling; - for (; sibling; sibling = sibling->sibling) - { - if (sibling->proc_name == sym) - { - gfc_resolve (sibling); - break; - } - } - - /* If SYM has references to outer arrays, so has the procedure calling - SYM. If SYM is a procedure pointer, we can assume the worst. */ - if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer) - && gfc_current_ns->proc_name) - gfc_current_ns->proc_name->attr.array_outer_dependency = 1; -} - - -/* Resolve a function call, which means resolving the arguments, then figuring - out which entity the name refers to. */ - -static bool -resolve_function (gfc_expr *expr) -{ - gfc_actual_arglist *arg; - gfc_symbol *sym; - bool t; - int temp; - procedure_type p = PROC_INTRINSIC; - bool no_formal_args; - - sym = NULL; - if (expr->symtree) - sym = expr->symtree->n.sym; - - /* If this is a procedure pointer component, it has already been resolved. */ - if (gfc_is_proc_ptr_comp (expr)) - return true; - - /* Avoid re-resolving the arguments of caf_get, which can lead to inserting - another caf_get. */ - if (sym && sym->attr.intrinsic - && (sym->intmod_sym_id == GFC_ISYM_CAF_GET - || sym->intmod_sym_id == GFC_ISYM_CAF_SEND)) - return true; - - if (expr->ref) - { - gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name, - &expr->where); - return false; - } - - if (sym && sym->attr.intrinsic - && !gfc_resolve_intrinsic (sym, &expr->where)) - return false; - - if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) - { - gfc_error ("%qs at %L is not a function", sym->name, &expr->where); - return false; - } - - /* If this is a deferred TBP with an abstract interface (which may - of course be referenced), expr->value.function.esym will be set. */ - if (sym && sym->attr.abstract && !expr->value.function.esym) - { - gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", - sym->name, &expr->where); - return false; - } - - /* If this is a deferred TBP with an abstract interface, its result - cannot be an assumed length character (F2003: C418). */ - if (sym && sym->attr.abstract && sym->attr.function - && sym->result->ts.u.cl - && sym->result->ts.u.cl->length == NULL - && !sym->result->ts.deferred) - { - gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed " - "character length result (F2008: C418)", sym->name, - &sym->declared_at); - return false; - } - - /* Switch off assumed size checking and do this again for certain kinds - of procedure, once the procedure itself is resolved. */ - need_full_assumed_size++; - - if (expr->symtree && expr->symtree->n.sym) - p = expr->symtree->n.sym->attr.proc; - - if (expr->value.function.isym && expr->value.function.isym->inquiry) - inquiry_argument = true; - no_formal_args = sym && is_external_proc (sym) - && gfc_sym_get_dummy_args (sym) == NULL; - - if (!resolve_actual_arglist (expr->value.function.actual, - p, no_formal_args)) - { - inquiry_argument = false; - return false; - } - - inquiry_argument = false; - - /* Resume assumed_size checking. */ - need_full_assumed_size--; - - /* If the procedure is external, check for usage. */ - if (sym && is_external_proc (sym)) - resolve_global_procedure (sym, &expr->where, 0); - - if (sym && sym->ts.type == BT_CHARACTER - && sym->ts.u.cl - && sym->ts.u.cl->length == NULL - && !sym->attr.dummy - && !sym->ts.deferred - && expr->value.function.esym == NULL - && !sym->attr.contained) - { - /* Internal procedures are taken care of in resolve_contained_fntype. */ - gfc_error ("Function %qs is declared CHARACTER(*) and cannot " - "be used at %L since it is not a dummy argument", - sym->name, &expr->where); - return false; - } - - /* See if function is already resolved. */ - - if (expr->value.function.name != NULL - || expr->value.function.isym != NULL) - { - if (expr->ts.type == BT_UNKNOWN) - expr->ts = sym->ts; - t = true; - } - else - { - /* Apply the rules of section 14.1.2. */ - - switch (procedure_kind (sym)) - { - case PTYPE_GENERIC: - t = resolve_generic_f (expr); - break; - - case PTYPE_SPECIFIC: - t = resolve_specific_f (expr); - break; - - case PTYPE_UNKNOWN: - t = resolve_unknown_f (expr); - break; - - default: - gfc_internal_error ("resolve_function(): bad function type"); - } - } - - /* If the expression is still a function (it might have simplified), - then we check to see if we are calling an elemental function. */ - - if (expr->expr_type != EXPR_FUNCTION) - return t; - - /* Walk the argument list looking for invalid BOZ. */ - for (arg = expr->value.function.actual; arg; arg = arg->next) - if (arg->expr && arg->expr->ts.type == BT_BOZ) - { - gfc_error ("A BOZ literal constant at %L cannot appear as an " - "actual argument in a function reference", - &arg->expr->where); - return false; - } - - temp = need_full_assumed_size; - need_full_assumed_size = 0; - - if (!resolve_elemental_actual (expr, NULL)) - return false; - - if (omp_workshare_flag - && expr->value.function.esym - && ! gfc_elemental (expr->value.function.esym)) - { - gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed " - "in WORKSHARE construct", expr->value.function.esym->name, - &expr->where); - t = false; - } - -#define GENERIC_ID expr->value.function.isym->id - else if (expr->value.function.actual != NULL - && expr->value.function.isym != NULL - && GENERIC_ID != GFC_ISYM_LBOUND - && GENERIC_ID != GFC_ISYM_LCOBOUND - && GENERIC_ID != GFC_ISYM_UCOBOUND - && GENERIC_ID != GFC_ISYM_LEN - && GENERIC_ID != GFC_ISYM_LOC - && GENERIC_ID != GFC_ISYM_C_LOC - && GENERIC_ID != GFC_ISYM_PRESENT) - { - /* Array intrinsics must also have the last upper bound of an - assumed size array argument. UBOUND and SIZE have to be - excluded from the check if the second argument is anything - than a constant. */ - - for (arg = expr->value.function.actual; arg; arg = arg->next) - { - if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE) - && arg == expr->value.function.actual - && arg->next != NULL && arg->next->expr) - { - if (arg->next->expr->expr_type != EXPR_CONSTANT) - break; - - if (arg->next->name && strcmp (arg->next->name, "kind") == 0) - break; - - if ((int)mpz_get_si (arg->next->expr->value.integer) - < arg->expr->rank) - break; - } - - if (arg->expr != NULL - && arg->expr->rank > 0 - && resolve_assumed_size_actual (arg->expr)) - return false; - } - } -#undef GENERIC_ID - - need_full_assumed_size = temp; - - if (!check_pure_function(expr)) - t = false; - - /* Functions without the RECURSIVE attribution are not allowed to - * call themselves. */ - if (expr->value.function.esym && !expr->value.function.esym->attr.recursive) - { - gfc_symbol *esym; - esym = expr->value.function.esym; - - if (is_illegal_recursion (esym, gfc_current_ns)) - { - if (esym->attr.entry && esym->ns->entries) - gfc_error ("ENTRY %qs at %L cannot be called recursively, as" - " function %qs is not RECURSIVE", - esym->name, &expr->where, esym->ns->entries->sym->name); - else - gfc_error ("Function %qs at %L cannot be called recursively, as it" - " is not RECURSIVE", esym->name, &expr->where); - - t = false; - } - } - - /* Character lengths of use associated functions may contains references to - symbols not referenced from the current program unit otherwise. Make sure - those symbols are marked as referenced. */ - - if (expr->ts.type == BT_CHARACTER && expr->value.function.esym - && expr->value.function.esym->attr.use_assoc) - { - gfc_expr_set_symbols_referenced (expr->ts.u.cl->length); - } - - /* Make sure that the expression has a typespec that works. */ - if (expr->ts.type == BT_UNKNOWN) - { - if (expr->symtree->n.sym->result - && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN - && !expr->symtree->n.sym->result->attr.proc_pointer) - expr->ts = expr->symtree->n.sym->result->ts; - } - - if (!expr->ref && !expr->value.function.isym) - { - if (expr->value.function.esym) - update_current_proc_array_outer_dependency (expr->value.function.esym); - else - update_current_proc_array_outer_dependency (sym); - } - else if (expr->ref) - /* typebound procedure: Assume the worst. */ - gfc_current_ns->proc_name->attr.array_outer_dependency = 1; - - if (expr->value.function.esym - && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED)) - gfc_warning (OPT_Wdeprecated_declarations, - "Using function %qs at %L is deprecated", - sym->name, &expr->where); - return t; -} - - -/************* Subroutine resolution *************/ - -static bool -pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) -{ - if (gfc_pure (sym)) - return true; - - if (forall_flag) - { - gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", - name, loc); - return false; - } - else if (gfc_do_concurrent_flag) - { - gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " - "PURE", name, loc); - return false; - } - else if (gfc_pure (NULL)) - { - gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc); - return false; - } - - gfc_unset_implicit_pure (NULL); - return true; -} - - -static match -resolve_generic_s0 (gfc_code *c, gfc_symbol *sym) -{ - gfc_symbol *s; - - if (sym->attr.generic) - { - s = gfc_search_interface (sym->generic, 1, &c->ext.actual); - if (s != NULL) - { - c->resolved_sym = s; - if (!pure_subroutine (s, s->name, &c->loc)) - return MATCH_ERROR; - return MATCH_YES; - } - - /* TODO: Need to search for elemental references in generic interface. */ - } - - if (sym->attr.intrinsic) - return gfc_intrinsic_sub_interface (c, 0); - - return MATCH_NO; -} - - -static bool -resolve_generic_s (gfc_code *c) -{ - gfc_symbol *sym; - match m; - - sym = c->symtree->n.sym; - - for (;;) - { - m = resolve_generic_s0 (c, sym); - if (m == MATCH_YES) - return true; - else if (m == MATCH_ERROR) - return false; - -generic: - if (sym->ns->parent == NULL) - break; - gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); - - if (sym == NULL) - break; - if (!generic_sym (sym)) - goto generic; - } - - /* Last ditch attempt. See if the reference is to an intrinsic - that possesses a matching interface. 14.1.2.4 */ - sym = c->symtree->n.sym; - - if (!gfc_is_intrinsic (sym, 1, c->loc)) - { - gfc_error ("There is no specific subroutine for the generic %qs at %L", - sym->name, &c->loc); - return false; - } - - m = gfc_intrinsic_sub_interface (c, 0); - if (m == MATCH_YES) - return true; - if (m == MATCH_NO) - gfc_error ("Generic subroutine %qs at %L is not consistent with an " - "intrinsic subroutine interface", sym->name, &c->loc); - - return false; -} - - -/* Resolve a subroutine call known to be specific. */ - -static match -resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) -{ - match m; - - if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) - { - if (sym->attr.dummy) - { - sym->attr.proc = PROC_DUMMY; - goto found; - } - - sym->attr.proc = PROC_EXTERNAL; - goto found; - } - - if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL) - goto found; - - if (sym->attr.intrinsic) - { - m = gfc_intrinsic_sub_interface (c, 1); - if (m == MATCH_YES) - return MATCH_YES; - if (m == MATCH_NO) - gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible " - "with an intrinsic", sym->name, &c->loc); - - return MATCH_ERROR; - } - - return MATCH_NO; - -found: - gfc_procedure_use (sym, &c->ext.actual, &c->loc); - - c->resolved_sym = sym; - if (!pure_subroutine (sym, sym->name, &c->loc)) - return MATCH_ERROR; - - return MATCH_YES; -} - - -static bool -resolve_specific_s (gfc_code *c) -{ - gfc_symbol *sym; - match m; - - sym = c->symtree->n.sym; - - for (;;) - { - m = resolve_specific_s0 (c, sym); - if (m == MATCH_YES) - return true; - if (m == MATCH_ERROR) - return false; - - if (sym->ns->parent == NULL) - break; - - gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); - - if (sym == NULL) - break; - } - - sym = c->symtree->n.sym; - gfc_error ("Unable to resolve the specific subroutine %qs at %L", - sym->name, &c->loc); - - return false; -} - - -/* Resolve a subroutine call not known to be generic nor specific. */ - -static bool -resolve_unknown_s (gfc_code *c) -{ - gfc_symbol *sym; - - sym = c->symtree->n.sym; - - if (sym->attr.dummy) - { - sym->attr.proc = PROC_DUMMY; - goto found; - } - - /* See if we have an intrinsic function reference. */ - - if (gfc_is_intrinsic (sym, 1, c->loc)) - { - if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES) - return true; - return false; - } - - /* The reference is to an external name. */ - -found: - gfc_procedure_use (sym, &c->ext.actual, &c->loc); - - c->resolved_sym = sym; - - return pure_subroutine (sym, sym->name, &c->loc); -} - - -/* Resolve a subroutine call. Although it was tempting to use the same code - for functions, subroutines and functions are stored differently and this - makes things awkward. */ - -static bool -resolve_call (gfc_code *c) -{ - bool t; - procedure_type ptype = PROC_INTRINSIC; - gfc_symbol *csym, *sym; - bool no_formal_args; - - csym = c->symtree ? c->symtree->n.sym : NULL; - - if (csym && csym->ts.type != BT_UNKNOWN) - { - gfc_error ("%qs at %L has a type, which is not consistent with " - "the CALL at %L", csym->name, &csym->declared_at, &c->loc); - return false; - } - - if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) - { - gfc_symtree *st; - gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st); - sym = st ? st->n.sym : NULL; - if (sym && csym != sym - && sym->ns == gfc_current_ns - && sym->attr.flavor == FL_PROCEDURE - && sym->attr.contained) - { - sym->refs++; - if (csym->attr.generic) - c->symtree->n.sym = sym; - else - c->symtree = st; - csym = c->symtree->n.sym; - } - } - - /* If this ia a deferred TBP, c->expr1 will be set. */ - if (!c->expr1 && csym) - { - if (csym->attr.abstract) - { - gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", - csym->name, &c->loc); - return false; - } - - /* Subroutines without the RECURSIVE attribution are not allowed to - call themselves. */ - if (is_illegal_recursion (csym, gfc_current_ns)) - { - if (csym->attr.entry && csym->ns->entries) - gfc_error ("ENTRY %qs at %L cannot be called recursively, " - "as subroutine %qs is not RECURSIVE", - csym->name, &c->loc, csym->ns->entries->sym->name); - else - gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, " - "as it is not RECURSIVE", csym->name, &c->loc); - - t = false; - } - } - - /* Switch off assumed size checking and do this again for certain kinds - of procedure, once the procedure itself is resolved. */ - need_full_assumed_size++; - - if (csym) - ptype = csym->attr.proc; - - no_formal_args = csym && is_external_proc (csym) - && gfc_sym_get_dummy_args (csym) == NULL; - if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args)) - return false; - - /* Resume assumed_size checking. */ - need_full_assumed_size--; - - /* If external, check for usage. */ - if (csym && is_external_proc (csym)) - resolve_global_procedure (csym, &c->loc, 1); - - t = true; - if (c->resolved_sym == NULL) - { - c->resolved_isym = NULL; - switch (procedure_kind (csym)) - { - case PTYPE_GENERIC: - t = resolve_generic_s (c); - break; - - case PTYPE_SPECIFIC: - t = resolve_specific_s (c); - break; - - case PTYPE_UNKNOWN: - t = resolve_unknown_s (c); - break; - - default: - gfc_internal_error ("resolve_subroutine(): bad function type"); - } - } - - /* Some checks of elemental subroutine actual arguments. */ - if (!resolve_elemental_actual (NULL, c)) - return false; - - if (!c->expr1) - update_current_proc_array_outer_dependency (csym); - else - /* Typebound procedure: Assume the worst. */ - gfc_current_ns->proc_name->attr.array_outer_dependency = 1; - - if (c->resolved_sym - && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED)) - gfc_warning (OPT_Wdeprecated_declarations, - "Using subroutine %qs at %L is deprecated", - c->resolved_sym->name, &c->loc); - - return t; -} - - -/* Compare the shapes of two arrays that have non-NULL shapes. If both - op1->shape and op2->shape are non-NULL return true if their shapes - match. If both op1->shape and op2->shape are non-NULL return false - if their shapes do not match. If either op1->shape or op2->shape is - NULL, return true. */ - -static bool -compare_shapes (gfc_expr *op1, gfc_expr *op2) -{ - bool t; - int i; - - t = true; - - if (op1->shape != NULL && op2->shape != NULL) - { - for (i = 0; i < op1->rank; i++) - { - if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) - { - gfc_error ("Shapes for operands at %L and %L are not conformable", - &op1->where, &op2->where); - t = false; - break; - } - } - } - - return t; -} - -/* Convert a logical operator to the corresponding bitwise intrinsic call. - For example A .AND. B becomes IAND(A, B). */ -static gfc_expr * -logical_to_bitwise (gfc_expr *e) -{ - gfc_expr *tmp, *op1, *op2; - gfc_isym_id isym; - gfc_actual_arglist *args = NULL; - - gcc_assert (e->expr_type == EXPR_OP); - - isym = GFC_ISYM_NONE; - op1 = e->value.op.op1; - op2 = e->value.op.op2; - - switch (e->value.op.op) - { - case INTRINSIC_NOT: - isym = GFC_ISYM_NOT; - break; - case INTRINSIC_AND: - isym = GFC_ISYM_IAND; - break; - case INTRINSIC_OR: - isym = GFC_ISYM_IOR; - break; - case INTRINSIC_NEQV: - isym = GFC_ISYM_IEOR; - break; - case INTRINSIC_EQV: - /* "Bitwise eqv" is just the complement of NEQV === IEOR. - Change the old expression to NEQV, which will get replaced by IEOR, - and wrap it in NOT. */ - tmp = gfc_copy_expr (e); - tmp->value.op.op = INTRINSIC_NEQV; - tmp = logical_to_bitwise (tmp); - isym = GFC_ISYM_NOT; - op1 = tmp; - op2 = NULL; - break; - default: - gfc_internal_error ("logical_to_bitwise(): Bad intrinsic"); - } - - /* Inherit the original operation's operands as arguments. */ - args = gfc_get_actual_arglist (); - args->expr = op1; - if (op2) - { - args->next = gfc_get_actual_arglist (); - args->next->expr = op2; - } - - /* Convert the expression to a function call. */ - e->expr_type = EXPR_FUNCTION; - e->value.function.actual = args; - e->value.function.isym = gfc_intrinsic_function_by_id (isym); - e->value.function.name = e->value.function.isym->name; - e->value.function.esym = NULL; - - /* Make up a pre-resolved function call symtree if we need to. */ - if (!e->symtree || !e->symtree->n.sym) - { - gfc_symbol *sym; - gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree); - sym = e->symtree->n.sym; - sym->result = sym; - sym->attr.flavor = FL_PROCEDURE; - sym->attr.function = 1; - sym->attr.elemental = 1; - sym->attr.pure = 1; - sym->attr.referenced = 1; - gfc_intrinsic_symbol (sym); - gfc_commit_symbol (sym); - } - - args->name = e->value.function.isym->formal->name; - if (e->value.function.isym->formal->next) - args->next->name = e->value.function.isym->formal->next->name; - - return e; -} - -/* Recursively append candidate UOP to CANDIDATES. Store the number of - candidates in CANDIDATES_LEN. */ -static void -lookup_uop_fuzzy_find_candidates (gfc_symtree *uop, - char **&candidates, - size_t &candidates_len) -{ - gfc_symtree *p; - - if (uop == NULL) - return; - - /* Not sure how to properly filter here. Use all for a start. - n.uop.op is NULL for empty interface operators (is that legal?) disregard - these as i suppose they don't make terribly sense. */ - - if (uop->n.uop->op != NULL) - vec_push (candidates, candidates_len, uop->name); - - p = uop->left; - if (p) - lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); - - p = uop->right; - if (p) - lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); -} - -/* Lookup user-operator OP fuzzily, taking names in UOP into account. */ - -static const char* -lookup_uop_fuzzy (const char *op, gfc_symtree *uop) -{ - char **candidates = NULL; - size_t candidates_len = 0; - lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len); - return gfc_closest_fuzzy_match (op, candidates); -} - - -/* Callback finding an impure function as an operand to an .and. or - .or. expression. Remember the last function warned about to - avoid double warnings when recursing. */ - -static int -impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - gfc_expr *f = *e; - const char *name; - static gfc_expr *last = NULL; - bool *found = (bool *) data; - - if (f->expr_type == EXPR_FUNCTION) - { - *found = 1; - if (f != last && !gfc_pure_function (f, &name) - && !gfc_implicit_pure_function (f)) - { - if (name) - gfc_warning (OPT_Wfunction_elimination, - "Impure function %qs at %L might not be evaluated", - name, &f->where); - else - gfc_warning (OPT_Wfunction_elimination, - "Impure function at %L might not be evaluated", - &f->where); - } - last = f; - } - - return 0; -} - -/* Return true if TYPE is character based, false otherwise. */ - -static int -is_character_based (bt type) -{ - return type == BT_CHARACTER || type == BT_HOLLERITH; -} - - -/* If expression is a hollerith, convert it to character and issue a warning - for the conversion. */ - -static void -convert_hollerith_to_character (gfc_expr *e) -{ - if (e->ts.type == BT_HOLLERITH) - { - gfc_typespec t; - gfc_clear_ts (&t); - t.type = BT_CHARACTER; - t.kind = e->ts.kind; - gfc_convert_type_warn (e, &t, 2, 1); - } -} - -/* Convert to numeric and issue a warning for the conversion. */ - -static void -convert_to_numeric (gfc_expr *a, gfc_expr *b) -{ - gfc_typespec t; - gfc_clear_ts (&t); - t.type = b->ts.type; - t.kind = b->ts.kind; - gfc_convert_type_warn (a, &t, 2, 1); -} - -/* Resolve an operator expression node. This can involve replacing the - operation with a user defined function call. */ - -static bool -resolve_operator (gfc_expr *e) -{ - gfc_expr *op1, *op2; - /* One error uses 3 names; additional space for wording (also via gettext). */ - char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50]; - bool dual_locus_error; - bool t = true; - - /* Resolve all subnodes-- give them types. */ - - switch (e->value.op.op) - { - default: - if (!gfc_resolve_expr (e->value.op.op2)) - t = false; - - /* Fall through. */ - - case INTRINSIC_NOT: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - case INTRINSIC_PARENTHESES: - if (!gfc_resolve_expr (e->value.op.op1)) - return false; - if (e->value.op.op1 - && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2) - { - gfc_error ("BOZ literal constant at %L cannot be an operand of " - "unary operator %qs", &e->value.op.op1->where, - gfc_op2string (e->value.op.op)); - return false; - } - break; - } - - /* Typecheck the new node. */ - - op1 = e->value.op.op1; - op2 = e->value.op.op2; - if (op1 == NULL && op2 == NULL) - return false; - /* Error out if op2 did not resolve. We already diagnosed op1. */ - if (t == false) - return false; - - dual_locus_error = false; - - /* op1 and op2 cannot both be BOZ. */ - if (op1 && op1->ts.type == BT_BOZ - && op2 && op2->ts.type == BT_BOZ) - { - gfc_error ("Operands at %L and %L cannot appear as operands of " - "binary operator %qs", &op1->where, &op2->where, - gfc_op2string (e->value.op.op)); - return false; - } - - if ((op1 && op1->expr_type == EXPR_NULL) - || (op2 && op2->expr_type == EXPR_NULL)) - { - snprintf (msg, sizeof (msg), - _("Invalid context for NULL() pointer at %%L")); - goto bad_op; - } - - switch (e->value.op.op) - { - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - if (op1->ts.type == BT_INTEGER - || op1->ts.type == BT_REAL - || op1->ts.type == BT_COMPLEX) - { - e->ts = op1->ts; - break; - } - - snprintf (msg, sizeof (msg), - _("Operand of unary numeric operator %%<%s%%> at %%L is %s"), - gfc_op2string (e->value.op.op), gfc_typename (e)); - goto bad_op; - - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: - if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) - { - gfc_type_convert_binary (e, 1); - break; - } - - if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED) - snprintf (msg, sizeof (msg), - _("Unexpected derived-type entities in binary intrinsic " - "numeric operator %%<%s%%> at %%L"), - gfc_op2string (e->value.op.op)); - else - snprintf (msg, sizeof(msg), - _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"), - gfc_op2string (e->value.op.op), gfc_typename (op1), - gfc_typename (op2)); - goto bad_op; - - case INTRINSIC_CONCAT: - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER - && op1->ts.kind == op2->ts.kind) - { - e->ts.type = BT_CHARACTER; - e->ts.kind = op1->ts.kind; - break; - } - - snprintf (msg, sizeof (msg), - _("Operands of string concatenation operator at %%L are %s/%s"), - gfc_typename (op1), gfc_typename (op2)); - goto bad_op; - - case INTRINSIC_AND: - case INTRINSIC_OR: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: - if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) - { - e->ts.type = BT_LOGICAL; - e->ts.kind = gfc_kind_max (op1, op2); - if (op1->ts.kind < e->ts.kind) - gfc_convert_type (op1, &e->ts, 2); - else if (op2->ts.kind < e->ts.kind) - gfc_convert_type (op2, &e->ts, 2); - - if (flag_frontend_optimize && - (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR)) - { - /* Warn about short-circuiting - with impure function as second operand. */ - bool op2_f = false; - gfc_expr_walker (&op2, impure_function_callback, &op2_f); - } - break; - } - - /* Logical ops on integers become bitwise ops with -fdec. */ - else if (flag_dec - && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER)) - { - e->ts.type = BT_INTEGER; - e->ts.kind = gfc_kind_max (op1, op2); - if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind) - gfc_convert_type (op1, &e->ts, 1); - if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind) - gfc_convert_type (op2, &e->ts, 1); - e = logical_to_bitwise (e); - goto simplify_op; - } - - snprintf (msg, sizeof (msg), - _("Operands of logical operator %%<%s%%> at %%L are %s/%s"), - gfc_op2string (e->value.op.op), gfc_typename (op1), - gfc_typename (op2)); - - goto bad_op; - - case INTRINSIC_NOT: - /* Logical ops on integers become bitwise ops with -fdec. */ - if (flag_dec && op1->ts.type == BT_INTEGER) - { - e->ts.type = BT_INTEGER; - e->ts.kind = op1->ts.kind; - e = logical_to_bitwise (e); - goto simplify_op; - } - - if (op1->ts.type == BT_LOGICAL) - { - e->ts.type = BT_LOGICAL; - e->ts.kind = op1->ts.kind; - break; - } - - snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"), - gfc_typename (op1)); - goto bad_op; - - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) - { - strcpy (msg, _("COMPLEX quantities cannot be compared at %L")); - goto bad_op; - } - - /* Fall through. */ - - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - - if (flag_dec - && is_character_based (op1->ts.type) - && is_character_based (op2->ts.type)) - { - convert_hollerith_to_character (op1); - convert_hollerith_to_character (op2); - } - - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER - && op1->ts.kind == op2->ts.kind) - { - e->ts.type = BT_LOGICAL; - e->ts.kind = gfc_default_logical_kind; - break; - } - - /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */ - if (op1->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear " - "as an operand of a relational operator"), - &op1->where)) - return false; - - if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind)) - return false; - - if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind)) - return false; - } - - /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */ - if (op2->ts.type == BT_BOZ) - { - if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear" - " as an operand of a relational operator"), - &op2->where)) - return false; - - if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind)) - return false; - - if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind)) - return false; - } - if (flag_dec - && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts)) - convert_to_numeric (op1, op2); - - if (flag_dec - && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH) - convert_to_numeric (op2, op1); - - if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) - { - gfc_type_convert_binary (e, 1); - - e->ts.type = BT_LOGICAL; - e->ts.kind = gfc_default_logical_kind; - - if (warn_compare_reals) - { - gfc_intrinsic_op op = e->value.op.op; - - /* Type conversion has made sure that the types of op1 and op2 - agree, so it is only necessary to check the first one. */ - if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX) - && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS - || op == INTRINSIC_NE || op == INTRINSIC_NE_OS)) - { - const char *msg; - - if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS) - msg = G_("Equality comparison for %s at %L"); - else - msg = G_("Inequality comparison for %s at %L"); - - gfc_warning (OPT_Wcompare_reals, msg, - gfc_typename (op1), &op1->where); - } - } - - break; - } - - if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) - snprintf (msg, sizeof (msg), - _("Logicals at %%L must be compared with %s instead of %s"), - (e->value.op.op == INTRINSIC_EQ - || e->value.op.op == INTRINSIC_EQ_OS) - ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); - else - snprintf (msg, sizeof (msg), - _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"), - gfc_op2string (e->value.op.op), gfc_typename (op1), - gfc_typename (op2)); - - goto bad_op; - - case INTRINSIC_USER: - if (e->value.op.uop->op == NULL) - { - const char *name = e->value.op.uop->name; - const char *guessed; - guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root); - if (guessed) - snprintf (msg, sizeof (msg), - _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"), - name, guessed); - else - snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"), - name); - } - else if (op2 == NULL) - snprintf (msg, sizeof (msg), - _("Operand of user operator %%<%s%%> at %%L is %s"), - e->value.op.uop->name, gfc_typename (op1)); - else - { - snprintf (msg, sizeof (msg), - _("Operands of user operator %%<%s%%> at %%L are %s/%s"), - e->value.op.uop->name, gfc_typename (op1), - gfc_typename (op2)); - e->value.op.uop->op->sym->attr.referenced = 1; - } - - goto bad_op; - - case INTRINSIC_PARENTHESES: - e->ts = op1->ts; - if (e->ts.type == BT_CHARACTER) - e->ts.u.cl = op1->ts.u.cl; - break; - - default: - gfc_internal_error ("resolve_operator(): Bad intrinsic"); - } - - /* Deal with arrayness of an operand through an operator. */ - - switch (e->value.op.op) - { - case INTRINSIC_PLUS: - case INTRINSIC_MINUS: - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: - case INTRINSIC_CONCAT: - case INTRINSIC_AND: - case INTRINSIC_OR: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: - case INTRINSIC_EQ: - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: - case INTRINSIC_GT: - case INTRINSIC_GT_OS: - case INTRINSIC_GE: - case INTRINSIC_GE_OS: - case INTRINSIC_LT: - case INTRINSIC_LT_OS: - case INTRINSIC_LE: - case INTRINSIC_LE_OS: - - if (op1->rank == 0 && op2->rank == 0) - e->rank = 0; - - if (op1->rank == 0 && op2->rank != 0) - { - e->rank = op2->rank; - - if (e->shape == NULL) - e->shape = gfc_copy_shape (op2->shape, op2->rank); - } - - if (op1->rank != 0 && op2->rank == 0) - { - e->rank = op1->rank; - - if (e->shape == NULL) - e->shape = gfc_copy_shape (op1->shape, op1->rank); - } - - if (op1->rank != 0 && op2->rank != 0) - { - if (op1->rank == op2->rank) - { - e->rank = op1->rank; - if (e->shape == NULL) - { - t = compare_shapes (op1, op2); - if (!t) - e->shape = NULL; - else - e->shape = gfc_copy_shape (op1->shape, op1->rank); - } - } - else - { - /* Allow higher level expressions to work. */ - e->rank = 0; - - /* Try user-defined operators, and otherwise throw an error. */ - dual_locus_error = true; - snprintf (msg, sizeof (msg), - _("Inconsistent ranks for operator at %%L and %%L")); - goto bad_op; - } - } - - break; - - case INTRINSIC_PARENTHESES: - case INTRINSIC_NOT: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - /* Simply copy arrayness attribute */ - e->rank = op1->rank; - - if (e->shape == NULL) - e->shape = gfc_copy_shape (op1->shape, op1->rank); - - break; - - default: - break; - } - -simplify_op: - - /* Attempt to simplify the expression. */ - if (t) - { - t = gfc_simplify_expr (e, 0); - /* Some calls do not succeed in simplification and return false - even though there is no error; e.g. variable references to - PARAMETER arrays. */ - if (!gfc_is_constant_expr (e)) - t = true; - } - return t; - -bad_op: - - { - match m = gfc_extend_expr (e); - if (m == MATCH_YES) - return true; - if (m == MATCH_ERROR) - return false; - } - - if (dual_locus_error) - gfc_error (msg, &op1->where, &op2->where); - else - gfc_error (msg, &e->where); - - return false; -} - - -/************** Array resolution subroutines **************/ - -enum compare_result -{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }; - -/* Compare two integer expressions. */ - -static compare_result -compare_bound (gfc_expr *a, gfc_expr *b) -{ - int i; - - if (a == NULL || a->expr_type != EXPR_CONSTANT - || b == NULL || b->expr_type != EXPR_CONSTANT) - return CMP_UNKNOWN; - - /* If either of the types isn't INTEGER, we must have - raised an error earlier. */ - - if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER) - return CMP_UNKNOWN; - - i = mpz_cmp (a->value.integer, b->value.integer); - - if (i < 0) - return CMP_LT; - if (i > 0) - return CMP_GT; - return CMP_EQ; -} - - -/* Compare an integer expression with an integer. */ - -static compare_result -compare_bound_int (gfc_expr *a, int b) -{ - int i; - - if (a == NULL || a->expr_type != EXPR_CONSTANT) - return CMP_UNKNOWN; - - if (a->ts.type != BT_INTEGER) - gfc_internal_error ("compare_bound_int(): Bad expression"); - - i = mpz_cmp_si (a->value.integer, b); - - if (i < 0) - return CMP_LT; - if (i > 0) - return CMP_GT; - return CMP_EQ; -} - - -/* Compare an integer expression with a mpz_t. */ - -static compare_result -compare_bound_mpz_t (gfc_expr *a, mpz_t b) -{ - int i; - - if (a == NULL || a->expr_type != EXPR_CONSTANT) - return CMP_UNKNOWN; - - if (a->ts.type != BT_INTEGER) - gfc_internal_error ("compare_bound_int(): Bad expression"); - - i = mpz_cmp (a->value.integer, b); - - if (i < 0) - return CMP_LT; - if (i > 0) - return CMP_GT; - return CMP_EQ; -} - - -/* Compute the last value of a sequence given by a triplet. - Return 0 if it wasn't able to compute the last value, or if the - sequence if empty, and 1 otherwise. */ - -static int -compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end, - gfc_expr *stride, mpz_t last) -{ - mpz_t rem; - - if (start == NULL || start->expr_type != EXPR_CONSTANT - || end == NULL || end->expr_type != EXPR_CONSTANT - || (stride != NULL && stride->expr_type != EXPR_CONSTANT)) - return 0; - - if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER - || (stride != NULL && stride->ts.type != BT_INTEGER)) - return 0; - - if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ) - { - if (compare_bound (start, end) == CMP_GT) - return 0; - mpz_set (last, end->value.integer); - return 1; - } - - if (compare_bound_int (stride, 0) == CMP_GT) - { - /* Stride is positive */ - if (mpz_cmp (start->value.integer, end->value.integer) > 0) - return 0; - } - else - { - /* Stride is negative */ - if (mpz_cmp (start->value.integer, end->value.integer) < 0) - return 0; - } - - mpz_init (rem); - mpz_sub (rem, end->value.integer, start->value.integer); - mpz_tdiv_r (rem, rem, stride->value.integer); - mpz_sub (last, end->value.integer, rem); - mpz_clear (rem); - - return 1; -} - - -/* Compare a single dimension of an array reference to the array - specification. */ - -static bool -check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) -{ - mpz_t last_value; - - if (ar->dimen_type[i] == DIMEN_STAR) - { - gcc_assert (ar->stride[i] == NULL); - /* This implies [*] as [*:] and [*:3] are not possible. */ - if (ar->start[i] == NULL) - { - gcc_assert (ar->end[i] == NULL); - return true; - } - } - -/* Given start, end and stride values, calculate the minimum and - maximum referenced indexes. */ - - switch (ar->dimen_type[i]) - { - case DIMEN_VECTOR: - case DIMEN_THIS_IMAGE: - break; - - case DIMEN_STAR: - case DIMEN_ELEMENT: - if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) - { - if (i < as->rank) - gfc_warning (0, "Array reference at %L is out of bounds " - "(%ld < %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->lower[i]->value.integer), i+1); - else - gfc_warning (0, "Array reference at %L is out of bounds " - "(%ld < %ld) in codimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->lower[i]->value.integer), - i + 1 - as->rank); - return true; - } - if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) - { - if (i < as->rank) - gfc_warning (0, "Array reference at %L is out of bounds " - "(%ld > %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->upper[i]->value.integer), i+1); - else - gfc_warning (0, "Array reference at %L is out of bounds " - "(%ld > %ld) in codimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->upper[i]->value.integer), - i + 1 - as->rank); - return true; - } - - break; - - case DIMEN_RANGE: - { -#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i]) -#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i]) - - compare_result comp_start_end = compare_bound (AR_START, AR_END); - - /* Check for zero stride, which is not allowed. */ - if (compare_bound_int (ar->stride[i], 0) == CMP_EQ) - { - gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]); - return false; - } - - /* if start == len || (stride > 0 && start < len) - || (stride < 0 && start > len), - then the array section contains at least one element. In this - case, there is an out-of-bounds access if - (start < lower || start > upper). */ - if (compare_bound (AR_START, AR_END) == CMP_EQ - || ((compare_bound_int (ar->stride[i], 0) == CMP_GT - || ar->stride[i] == NULL) && comp_start_end == CMP_LT) - || (compare_bound_int (ar->stride[i], 0) == CMP_LT - && comp_start_end == CMP_GT)) - { - if (compare_bound (AR_START, as->lower[i]) == CMP_LT) - { - gfc_warning (0, "Lower array reference at %L is out of bounds " - "(%ld < %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (AR_START->value.integer), - mpz_get_si (as->lower[i]->value.integer), i+1); - return true; - } - if (compare_bound (AR_START, as->upper[i]) == CMP_GT) - { - gfc_warning (0, "Lower array reference at %L is out of bounds " - "(%ld > %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (AR_START->value.integer), - mpz_get_si (as->upper[i]->value.integer), i+1); - return true; - } - } - - /* If we can compute the highest index of the array section, - then it also has to be between lower and upper. */ - mpz_init (last_value); - if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i], - last_value)) - { - if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT) - { - gfc_warning (0, "Upper array reference at %L is out of bounds " - "(%ld < %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (last_value), - mpz_get_si (as->lower[i]->value.integer), i+1); - mpz_clear (last_value); - return true; - } - if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) - { - gfc_warning (0, "Upper array reference at %L is out of bounds " - "(%ld > %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (last_value), - mpz_get_si (as->upper[i]->value.integer), i+1); - mpz_clear (last_value); - return true; - } - } - mpz_clear (last_value); - -#undef AR_START -#undef AR_END - } - break; - - default: - gfc_internal_error ("check_dimension(): Bad array reference"); - } - - return true; -} - - -/* Compare an array reference with an array specification. */ - -static bool -compare_spec_to_ref (gfc_array_ref *ar) -{ - gfc_array_spec *as; - int i; - - as = ar->as; - i = as->rank - 1; - /* TODO: Full array sections are only allowed as actual parameters. */ - if (as->type == AS_ASSUMED_SIZE - && (/*ar->type == AR_FULL - ||*/ (ar->type == AR_SECTION - && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL))) - { - gfc_error ("Rightmost upper bound of assumed size array section " - "not specified at %L", &ar->where); - return false; - } - - if (ar->type == AR_FULL) - return true; - - if (as->rank != ar->dimen) - { - gfc_error ("Rank mismatch in array reference at %L (%d/%d)", - &ar->where, ar->dimen, as->rank); - return false; - } - - /* ar->codimen == 0 is a local array. */ - if (as->corank != ar->codimen && ar->codimen != 0) - { - gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", - &ar->where, ar->codimen, as->corank); - return false; - } - - for (i = 0; i < as->rank; i++) - if (!check_dimension (i, ar, as)) - return false; - - /* Local access has no coarray spec. */ - if (ar->codimen != 0) - for (i = as->rank; i < as->rank + as->corank; i++) - { - if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate - && ar->dimen_type[i] != DIMEN_THIS_IMAGE) - { - gfc_error ("Coindex of codimension %d must be a scalar at %L", - i + 1 - as->rank, &ar->where); - return false; - } - if (!check_dimension (i, ar, as)) - return false; - } - - return true; -} - - -/* Resolve one part of an array index. */ - -static bool -gfc_resolve_index_1 (gfc_expr *index, int check_scalar, - int force_index_integer_kind) -{ - gfc_typespec ts; - - if (index == NULL) - return true; - - if (!gfc_resolve_expr (index)) - return false; - - if (check_scalar && index->rank != 0) - { - gfc_error ("Array index at %L must be scalar", &index->where); - return false; - } - - if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) - { - gfc_error ("Array index at %L must be of INTEGER type, found %s", - &index->where, gfc_basic_typename (index->ts.type)); - return false; - } - - if (index->ts.type == BT_REAL) - if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", - &index->where)) - return false; - - if ((index->ts.kind != gfc_index_integer_kind - && force_index_integer_kind) - || index->ts.type != BT_INTEGER) - { - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = gfc_index_integer_kind; - - gfc_convert_type_warn (index, &ts, 2, 0); - } - - return true; -} - -/* Resolve one part of an array index. */ - -bool -gfc_resolve_index (gfc_expr *index, int check_scalar) -{ - return gfc_resolve_index_1 (index, check_scalar, 1); -} - -/* Resolve a dim argument to an intrinsic function. */ - -bool -gfc_resolve_dim_arg (gfc_expr *dim) -{ - if (dim == NULL) - return true; - - if (!gfc_resolve_expr (dim)) - return false; - - if (dim->rank != 0) - { - gfc_error ("Argument dim at %L must be scalar", &dim->where); - return false; - - } - - if (dim->ts.type != BT_INTEGER) - { - gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); - return false; - } - - if (dim->ts.kind != gfc_index_integer_kind) - { - gfc_typespec ts; - - gfc_clear_ts (&ts); - ts.type = BT_INTEGER; - ts.kind = gfc_index_integer_kind; - - gfc_convert_type_warn (dim, &ts, 2, 0); - } - - return true; -} - -/* Given an expression that contains array references, update those array - references to point to the right array specifications. While this is - filled in during matching, this information is difficult to save and load - in a module, so we take care of it here. - - The idea here is that the original array reference comes from the - base symbol. We traverse the list of reference structures, setting - the stored reference to references. Component references can - provide an additional array specification. */ -static void -resolve_assoc_var (gfc_symbol* sym, bool resolve_target); - -static void -find_array_spec (gfc_expr *e) -{ - gfc_array_spec *as; - gfc_component *c; - gfc_ref *ref; - bool class_as = false; - - if (e->symtree->n.sym->assoc) - { - if (e->symtree->n.sym->assoc->target) - gfc_resolve_expr (e->symtree->n.sym->assoc->target); - resolve_assoc_var (e->symtree->n.sym, false); - } - - if (e->symtree->n.sym->ts.type == BT_CLASS) - { - as = CLASS_DATA (e->symtree->n.sym)->as; - class_as = true; - } - else - as = e->symtree->n.sym->as; - - for (ref = e->ref; ref; ref = ref->next) - switch (ref->type) - { - case REF_ARRAY: - if (as == NULL) - gfc_internal_error ("find_array_spec(): Missing spec"); - - ref->u.ar.as = as; - as = NULL; - break; - - case REF_COMPONENT: - c = ref->u.c.component; - if (c->attr.dimension) - { - if (as != NULL && !(class_as && as == c->as)) - gfc_internal_error ("find_array_spec(): unused as(1)"); - as = c->as; - } - - break; - - case REF_SUBSTRING: - case REF_INQUIRY: - break; - } - - if (as != NULL) - gfc_internal_error ("find_array_spec(): unused as(2)"); -} - - -/* Resolve an array reference. */ - -static bool -resolve_array_ref (gfc_array_ref *ar) -{ - int i, check_scalar; - gfc_expr *e; - - for (i = 0; i < ar->dimen + ar->codimen; i++) - { - check_scalar = ar->dimen_type[i] == DIMEN_RANGE; - - /* Do not force gfc_index_integer_kind for the start. We can - do fine with any integer kind. This avoids temporary arrays - created for indexing with a vector. */ - if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0)) - return false; - if (!gfc_resolve_index (ar->end[i], check_scalar)) - return false; - if (!gfc_resolve_index (ar->stride[i], check_scalar)) - return false; - - e = ar->start[i]; - - if (ar->dimen_type[i] == DIMEN_UNKNOWN) - switch (e->rank) - { - case 0: - ar->dimen_type[i] = DIMEN_ELEMENT; - break; - - case 1: - ar->dimen_type[i] = DIMEN_VECTOR; - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->ts.type == BT_DERIVED) - ar->start[i] = gfc_get_parentheses (e); - break; - - default: - gfc_error ("Array index at %L is an array of rank %d", - &ar->c_where[i], e->rank); - return false; - } - - /* Fill in the upper bound, which may be lower than the - specified one for something like a(2:10:5), which is - identical to a(2:7:5). Only relevant for strides not equal - to one. Don't try a division by zero. */ - if (ar->dimen_type[i] == DIMEN_RANGE - && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT - && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0 - && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0) - { - mpz_t size, end; - - if (gfc_ref_dimen_size (ar, i, &size, &end)) - { - if (ar->end[i] == NULL) - { - ar->end[i] = - gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, - &ar->where); - mpz_set (ar->end[i]->value.integer, end); - } - else if (ar->end[i]->ts.type == BT_INTEGER - && ar->end[i]->expr_type == EXPR_CONSTANT) - { - mpz_set (ar->end[i]->value.integer, end); - } - else - gcc_unreachable (); - - mpz_clear (size); - mpz_clear (end); - } - } - } - - if (ar->type == AR_FULL) - { - if (ar->as->rank == 0) - ar->type = AR_ELEMENT; - - /* Make sure array is the same as array(:,:), this way - we don't need to special case all the time. */ - ar->dimen = ar->as->rank; - for (i = 0; i < ar->dimen; i++) - { - ar->dimen_type[i] = DIMEN_RANGE; - - gcc_assert (ar->start[i] == NULL); - gcc_assert (ar->end[i] == NULL); - gcc_assert (ar->stride[i] == NULL); - } - } - - /* If the reference type is unknown, figure out what kind it is. */ - - if (ar->type == AR_UNKNOWN) - { - ar->type = AR_ELEMENT; - for (i = 0; i < ar->dimen; i++) - if (ar->dimen_type[i] == DIMEN_RANGE - || ar->dimen_type[i] == DIMEN_VECTOR) - { - ar->type = AR_SECTION; - break; - } - } - - if (!ar->as->cray_pointee && !compare_spec_to_ref (ar)) - return false; - - if (ar->as->corank && ar->codimen == 0) - { - int n; - ar->codimen = ar->as->corank; - for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) - ar->dimen_type[n] = DIMEN_THIS_IMAGE; - } - - return true; -} - - -bool -gfc_resolve_substring (gfc_ref *ref, bool *equal_length) -{ - int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); - - if (ref->u.ss.start != NULL) - { - if (!gfc_resolve_expr (ref->u.ss.start)) - return false; - - if (ref->u.ss.start->ts.type != BT_INTEGER) - { - gfc_error ("Substring start index at %L must be of type INTEGER", - &ref->u.ss.start->where); - return false; - } - - if (ref->u.ss.start->rank != 0) - { - gfc_error ("Substring start index at %L must be scalar", - &ref->u.ss.start->where); - return false; - } - - if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT - && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ - || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) - { - gfc_error ("Substring start index at %L is less than one", - &ref->u.ss.start->where); - return false; - } - } - - if (ref->u.ss.end != NULL) - { - if (!gfc_resolve_expr (ref->u.ss.end)) - return false; - - if (ref->u.ss.end->ts.type != BT_INTEGER) - { - gfc_error ("Substring end index at %L must be of type INTEGER", - &ref->u.ss.end->where); - return false; - } - - if (ref->u.ss.end->rank != 0) - { - gfc_error ("Substring end index at %L must be scalar", - &ref->u.ss.end->where); - return false; - } - - if (ref->u.ss.length != NULL - && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT - && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ - || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) - { - gfc_error ("Substring end index at %L exceeds the string length", - &ref->u.ss.start->where); - return false; - } - - if (compare_bound_mpz_t (ref->u.ss.end, - gfc_integer_kinds[k].huge) == CMP_GT - && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ - || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) - { - gfc_error ("Substring end index at %L is too large", - &ref->u.ss.end->where); - return false; - } - /* If the substring has the same length as the original - variable, the reference itself can be deleted. */ - - if (ref->u.ss.length != NULL - && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ - && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ) - *equal_length = true; - } - - return true; -} - - -/* This function supplies missing substring charlens. */ - -void -gfc_resolve_substring_charlen (gfc_expr *e) -{ - gfc_ref *char_ref; - gfc_expr *start, *end; - gfc_typespec *ts = NULL; - mpz_t diff; - - for (char_ref = e->ref; char_ref; char_ref = char_ref->next) - { - if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY) - break; - if (char_ref->type == REF_COMPONENT) - ts = &char_ref->u.c.component->ts; - } - - if (!char_ref || char_ref->type == REF_INQUIRY) - return; - - gcc_assert (char_ref->next == NULL); - - if (e->ts.u.cl) - { - if (e->ts.u.cl->length) - gfc_free_expr (e->ts.u.cl->length); - else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy) - return; - } - - if (!e->ts.u.cl) - e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - - if (char_ref->u.ss.start) - start = gfc_copy_expr (char_ref->u.ss.start); - else - start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); - - if (char_ref->u.ss.end) - end = gfc_copy_expr (char_ref->u.ss.end); - else if (e->expr_type == EXPR_VARIABLE) - { - if (!ts) - ts = &e->symtree->n.sym->ts; - end = gfc_copy_expr (ts->u.cl->length); - } - else - end = NULL; - - if (!start || !end) - { - gfc_free_expr (start); - gfc_free_expr (end); - return; - } - - /* Length = (end - start + 1). - Check first whether it has a constant length. */ - if (gfc_dep_difference (end, start, &diff)) - { - gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, - &e->where); - - mpz_add_ui (len->value.integer, diff, 1); - mpz_clear (diff); - e->ts.u.cl->length = len; - /* The check for length < 0 is handled below */ - } - else - { - e->ts.u.cl->length = gfc_subtract (end, start); - e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, - gfc_get_int_expr (gfc_charlen_int_kind, - NULL, 1)); - } - - /* F2008, 6.4.1: Both the starting point and the ending point shall - be within the range 1, 2, ..., n unless the starting point exceeds - the ending point, in which case the substring has length zero. */ - - if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0) - mpz_set_si (e->ts.u.cl->length->value.integer, 0); - - e->ts.u.cl->length->ts.type = BT_INTEGER; - e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; - - /* Make sure that the length is simplified. */ - gfc_simplify_expr (e->ts.u.cl->length, 1); - gfc_resolve_expr (e->ts.u.cl->length); -} - - -/* Resolve subtype references. */ - -bool -gfc_resolve_ref (gfc_expr *expr) -{ - int current_part_dimension, n_components, seen_part_dimension, dim; - gfc_ref *ref, **prev, *array_ref; - bool equal_length; - - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) - { - find_array_spec (expr); - break; - } - - for (prev = &expr->ref; *prev != NULL; - prev = *prev == NULL ? prev : &(*prev)->next) - switch ((*prev)->type) - { - case REF_ARRAY: - if (!resolve_array_ref (&(*prev)->u.ar)) - return false; - break; - - case REF_COMPONENT: - case REF_INQUIRY: - break; - - case REF_SUBSTRING: - equal_length = false; - if (!gfc_resolve_substring (*prev, &equal_length)) - return false; - - if (expr->expr_type != EXPR_SUBSTRING && equal_length) - { - /* Remove the reference and move the charlen, if any. */ - ref = *prev; - *prev = ref->next; - ref->next = NULL; - expr->ts.u.cl = ref->u.ss.length; - ref->u.ss.length = NULL; - gfc_free_ref_list (ref); - } - break; - } - - /* Check constraints on part references. */ - - current_part_dimension = 0; - seen_part_dimension = 0; - n_components = 0; - array_ref = NULL; - - for (ref = expr->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - array_ref = ref; - switch (ref->u.ar.type) - { - case AR_FULL: - /* Coarray scalar. */ - if (ref->u.ar.as->rank == 0) - { - current_part_dimension = 0; - break; - } - /* Fall through. */ - case AR_SECTION: - current_part_dimension = 1; - break; - - case AR_ELEMENT: - array_ref = NULL; - current_part_dimension = 0; - break; - - case AR_UNKNOWN: - gfc_internal_error ("resolve_ref(): Bad array reference"); - } - - break; - - case REF_COMPONENT: - if (current_part_dimension || seen_part_dimension) - { - /* F03:C614. */ - if (ref->u.c.component->attr.pointer - || ref->u.c.component->attr.proc_pointer - || (ref->u.c.component->ts.type == BT_CLASS - && CLASS_DATA (ref->u.c.component)->attr.pointer)) - { - gfc_error ("Component to the right of a part reference " - "with nonzero rank must not have the POINTER " - "attribute at %L", &expr->where); - return false; - } - else if (ref->u.c.component->attr.allocatable - || (ref->u.c.component->ts.type == BT_CLASS - && CLASS_DATA (ref->u.c.component)->attr.allocatable)) - - { - gfc_error ("Component to the right of a part reference " - "with nonzero rank must not have the ALLOCATABLE " - "attribute at %L", &expr->where); - return false; - } - } - - n_components++; - break; - - case REF_SUBSTRING: - break; - - case REF_INQUIRY: - /* Implement requirement in note 9.7 of F2018 that the result of the - LEN inquiry be a scalar. */ - if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred) - { - array_ref->u.ar.type = AR_ELEMENT; - expr->rank = 0; - /* INQUIRY_LEN is not evaluated from the rest of the expr - but directly from the string length. This means that setting - the array indices to one does not matter but might trigger - a runtime bounds error. Suppress the check. */ - expr->no_bounds_check = 1; - for (dim = 0; dim < array_ref->u.ar.dimen; dim++) - { - array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT; - if (array_ref->u.ar.start[dim]) - gfc_free_expr (array_ref->u.ar.start[dim]); - array_ref->u.ar.start[dim] - = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - if (array_ref->u.ar.end[dim]) - gfc_free_expr (array_ref->u.ar.end[dim]); - if (array_ref->u.ar.stride[dim]) - gfc_free_expr (array_ref->u.ar.stride[dim]); - } - } - break; - } - - if (((ref->type == REF_COMPONENT && n_components > 1) - || ref->next == NULL) - && current_part_dimension - && seen_part_dimension) - { - gfc_error ("Two or more part references with nonzero rank must " - "not be specified at %L", &expr->where); - return false; - } - - if (ref->type == REF_COMPONENT) - { - if (current_part_dimension) - seen_part_dimension = 1; - - /* reset to make sure */ - current_part_dimension = 0; - } - } - - return true; -} - - -/* Given an expression, determine its shape. This is easier than it sounds. - Leaves the shape array NULL if it is not possible to determine the shape. */ - -static void -expression_shape (gfc_expr *e) -{ - mpz_t array[GFC_MAX_DIMENSIONS]; - int i; - - if (e->rank <= 0 || e->shape != NULL) - return; - - for (i = 0; i < e->rank; i++) - if (!gfc_array_dimen_size (e, i, &array[i])) - goto fail; - - e->shape = gfc_get_shape (e->rank); - - memcpy (e->shape, array, e->rank * sizeof (mpz_t)); - - return; - -fail: - for (i--; i >= 0; i--) - mpz_clear (array[i]); -} - - -/* Given a variable expression node, compute the rank of the expression by - examining the base symbol and any reference structures it may have. */ - -void -gfc_expression_rank (gfc_expr *e) -{ - gfc_ref *ref; - int i, rank; - - /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that - could lead to serious confusion... */ - gcc_assert (e->expr_type != EXPR_COMPCALL); - - if (e->ref == NULL) - { - if (e->expr_type == EXPR_ARRAY) - goto done; - /* Constructors can have a rank different from one via RESHAPE(). */ - - e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL) - ? 0 : e->symtree->n.sym->as->rank); - goto done; - } - - rank = 0; - - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer - && ref->u.c.component->attr.function && !ref->next) - rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0; - - if (ref->type != REF_ARRAY) - continue; - - if (ref->u.ar.type == AR_FULL) - { - rank = ref->u.ar.as->rank; - break; - } - - if (ref->u.ar.type == AR_SECTION) - { - /* Figure out the rank of the section. */ - if (rank != 0) - gfc_internal_error ("gfc_expression_rank(): Two array specs"); - - for (i = 0; i < ref->u.ar.dimen; i++) - if (ref->u.ar.dimen_type[i] == DIMEN_RANGE - || ref->u.ar.dimen_type[i] == DIMEN_VECTOR) - rank++; - - break; - } - } - - e->rank = rank; - -done: - expression_shape (e); -} - - -static void -add_caf_get_intrinsic (gfc_expr *e) -{ - gfc_expr *wrapper, *tmp_expr; - gfc_ref *ref; - int n; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - break; - if (ref == NULL) - return; - - for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) - if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) - return; - - tmp_expr = XCNEW (gfc_expr); - *tmp_expr = *e; - wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET, - "caf_get", tmp_expr->where, 1, tmp_expr); - wrapper->ts = e->ts; - wrapper->rank = e->rank; - if (e->rank) - wrapper->shape = gfc_copy_shape (e->shape, e->rank); - *e = *wrapper; - free (wrapper); -} - - -static void -remove_caf_get_intrinsic (gfc_expr *e) -{ - gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym - && e->value.function.isym->id == GFC_ISYM_CAF_GET); - gfc_expr *e2 = e->value.function.actual->expr; - e->value.function.actual->expr = NULL; - gfc_free_actual_arglist (e->value.function.actual); - gfc_free_shape (&e->shape, e->rank); - *e = *e2; - free (e2); -} - - -/* Resolve a variable expression. */ - -static bool -resolve_variable (gfc_expr *e) -{ - gfc_symbol *sym; - bool t; - - t = true; - - if (e->symtree == NULL) - return false; - sym = e->symtree->n.sym; - - /* Use same check as for TYPE(*) below; this check has to be before TYPE(*) - as ts.type is set to BT_ASSUMED in resolve_symbol. */ - if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - { - if (!actual_arg || inquiry_argument) - { - gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only " - "be used as actual argument", sym->name, &e->where); - return false; - } - } - /* TS 29113, 407b. */ - else if (e->ts.type == BT_ASSUMED) - { - if (!actual_arg) - { - gfc_error ("Assumed-type variable %s at %L may only be used " - "as actual argument", sym->name, &e->where); - return false; - } - else if (inquiry_argument && !first_actual_arg) - { - /* FIXME: It doesn't work reliably as inquiry_argument is not set - for all inquiry functions in resolve_function; the reason is - that the function-name resolution happens too late in that - function. */ - gfc_error ("Assumed-type variable %s at %L as actual argument to " - "an inquiry function shall be the first argument", - sym->name, &e->where); - return false; - } - } - /* TS 29113, C535b. */ - else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym) - && CLASS_DATA (sym)->as - && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) - || (sym->ts.type != BT_CLASS && sym->as - && sym->as->type == AS_ASSUMED_RANK)) - && !sym->attr.select_rank_temporary) - { - if (!actual_arg - && !(cs_base && cs_base->current - && cs_base->current->op == EXEC_SELECT_RANK)) - { - gfc_error ("Assumed-rank variable %s at %L may only be used as " - "actual argument", sym->name, &e->where); - return false; - } - else if (inquiry_argument && !first_actual_arg) - { - /* FIXME: It doesn't work reliably as inquiry_argument is not set - for all inquiry functions in resolve_function; the reason is - that the function-name resolution happens too late in that - function. */ - gfc_error ("Assumed-rank variable %s at %L as actual argument " - "to an inquiry function shall be the first argument", - sym->name, &e->where); - return false; - } - } - - if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref - && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL - && e->ref->next == NULL)) - { - gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have " - "a subobject reference", sym->name, &e->ref->u.ar.where); - return false; - } - /* TS 29113, 407b. */ - else if (e->ts.type == BT_ASSUMED && e->ref - && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL - && e->ref->next == NULL)) - { - gfc_error ("Assumed-type variable %s at %L shall not have a subobject " - "reference", sym->name, &e->ref->u.ar.where); - return false; - } - - /* TS 29113, C535b. */ - if (((sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym) - && CLASS_DATA (sym)->as - && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) - || (sym->ts.type != BT_CLASS && sym->as - && sym->as->type == AS_ASSUMED_RANK)) - && e->ref - && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL - && e->ref->next == NULL)) - { - gfc_error ("Assumed-rank variable %s at %L shall not have a subobject " - "reference", sym->name, &e->ref->u.ar.where); - return false; - } - - /* For variables that are used in an associate (target => object) where - the object's basetype is array valued while the target is scalar, - the ts' type of the component refs is still array valued, which - can't be translated that way. */ - if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS - && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS - && sym->assoc->target->ts.u.derived - && CLASS_DATA (sym->assoc->target) - && CLASS_DATA (sym->assoc->target)->as) - { - gfc_ref *ref = e->ref; - while (ref) - { - switch (ref->type) - { - case REF_COMPONENT: - ref->u.c.sym = sym->ts.u.derived; - /* Stop the loop. */ - ref = NULL; - break; - default: - ref = ref->next; - break; - } - } - } - - /* If this is an associate-name, it may be parsed with an array reference - in error even though the target is scalar. Fail directly in this case. - TODO Understand why class scalar expressions must be excluded. */ - if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0)) - { - if (sym->ts.type == BT_CLASS) - gfc_fix_class_refs (e); - if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) - return false; - else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY)) - { - /* This can happen because the parser did not detect that the - associate name is an array and the expression had no array - part_ref. */ - gfc_ref *ref = gfc_get_ref (); - ref->type = REF_ARRAY; - ref->u.ar.type = AR_FULL; - if (sym->as) - { - ref->u.ar.as = sym->as; - ref->u.ar.dimen = sym->as->rank; - } - ref->next = e->ref; - e->ref = ref; - - } - } - - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) - sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); - - /* On the other hand, the parser may not have known this is an array; - in this case, we have to add a FULL reference. */ - if (sym->assoc && sym->attr.dimension && !e->ref) - { - e->ref = gfc_get_ref (); - e->ref->type = REF_ARRAY; - e->ref->u.ar.type = AR_FULL; - e->ref->u.ar.dimen = 0; - } - - /* Like above, but for class types, where the checking whether an array - ref is present is more complicated. Furthermore make sure not to add - the full array ref to _vptr or _len refs. */ - if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived - && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.dimension - && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype)) - { - gfc_ref *ref, *newref; - - newref = gfc_get_ref (); - newref->type = REF_ARRAY; - newref->u.ar.type = AR_FULL; - newref->u.ar.dimen = 0; - /* Because this is an associate var and the first ref either is a ref to - the _data component or not, no traversal of the ref chain is - needed. The array ref needs to be inserted after the _data ref, - or when that is not present, which may happend for polymorphic - types, then at the first position. */ - ref = e->ref; - if (!ref) - e->ref = newref; - else if (ref->type == REF_COMPONENT - && strcmp ("_data", ref->u.c.component->name) == 0) - { - if (!ref->next || ref->next->type != REF_ARRAY) - { - newref->next = ref->next; - ref->next = newref; - } - else - /* Array ref present already. */ - gfc_free_ref_list (newref); - } - else if (ref->type == REF_ARRAY) - /* Array ref present already. */ - gfc_free_ref_list (newref); - else - { - newref->next = ref; - e->ref = newref; - } - } - - if (e->ref && !gfc_resolve_ref (e)) - return false; - - if (sym->attr.flavor == FL_PROCEDURE - && (!sym->attr.function - || (sym->attr.function && sym->result - && sym->result->attr.proc_pointer - && !sym->result->attr.function))) - { - e->ts.type = BT_PROCEDURE; - goto resolve_procedure; - } - - if (sym->ts.type != BT_UNKNOWN) - gfc_variable_attr (e, &e->ts); - else if (sym->attr.flavor == FL_PROCEDURE - && sym->attr.function && sym->result - && sym->result->ts.type != BT_UNKNOWN - && sym->result->attr.proc_pointer) - e->ts = sym->result->ts; - else - { - /* Must be a simple variable reference. */ - if (!gfc_set_default_type (sym, 1, sym->ns)) - return false; - e->ts = sym->ts; - } - - if (check_assumed_size_reference (sym, e)) - return false; - - /* Deal with forward references to entries during gfc_resolve_code, to - satisfy, at least partially, 12.5.2.5. */ - if (gfc_current_ns->entries - && current_entry_id == sym->entry_id - && cs_base - && cs_base->current - && cs_base->current->op != EXEC_ENTRY) - { - gfc_entry_list *entry; - gfc_formal_arglist *formal; - int n; - bool seen, saved_specification_expr; - - /* If the symbol is a dummy... */ - if (sym->attr.dummy && sym->ns == gfc_current_ns) - { - entry = gfc_current_ns->entries; - seen = false; - - /* ...test if the symbol is a parameter of previous entries. */ - for (; entry && entry->id <= current_entry_id; entry = entry->next) - for (formal = entry->sym->formal; formal; formal = formal->next) - { - if (formal->sym && sym->name == formal->sym->name) - { - seen = true; - break; - } - } - - /* If it has not been seen as a dummy, this is an error. */ - if (!seen) - { - if (specification_expr) - gfc_error ("Variable %qs, used in a specification expression" - ", is referenced at %L before the ENTRY statement " - "in which it is a parameter", - sym->name, &cs_base->current->loc); - else - gfc_error ("Variable %qs is used at %L before the ENTRY " - "statement in which it is a parameter", - sym->name, &cs_base->current->loc); - t = false; - } - } - - /* Now do the same check on the specification expressions. */ - saved_specification_expr = specification_expr; - specification_expr = true; - if (sym->ts.type == BT_CHARACTER - && !gfc_resolve_expr (sym->ts.u.cl->length)) - t = false; - - if (sym->as) - for (n = 0; n < sym->as->rank; n++) - { - if (!gfc_resolve_expr (sym->as->lower[n])) - t = false; - if (!gfc_resolve_expr (sym->as->upper[n])) - t = false; - } - specification_expr = saved_specification_expr; - - if (t) - /* Update the symbol's entry level. */ - sym->entry_id = current_entry_id + 1; - } - - /* If a symbol has been host_associated mark it. This is used latter, - to identify if aliasing is possible via host association. */ - if (sym->attr.flavor == FL_VARIABLE - && gfc_current_ns->parent - && (gfc_current_ns->parent == sym->ns - || (gfc_current_ns->parent->parent - && gfc_current_ns->parent->parent == sym->ns))) - sym->attr.host_assoc = 1; - - if (gfc_current_ns->proc_name - && sym->attr.dimension - && (sym->ns != gfc_current_ns - || sym->attr.use_assoc - || sym->attr.in_common)) - gfc_current_ns->proc_name->attr.array_outer_dependency = 1; - -resolve_procedure: - if (t && !resolve_procedure_expression (e)) - t = false; - - /* F2008, C617 and C1229. */ - if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) - && gfc_is_coindexed (e)) - { - gfc_ref *ref, *ref2 = NULL; - - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT) - ref2 = ref; - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) - break; - } - - for ( ; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - - /* Expression itself is not coindexed object. */ - if (ref && e->ts.type == BT_CLASS) - { - gfc_error ("Polymorphic subobject of coindexed object at %L", - &e->where); - t = false; - } - - /* Expression itself is coindexed object. */ - if (ref == NULL) - { - gfc_component *c; - c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components; - for ( ; c; c = c->next) - if (c->attr.allocatable && c->ts.type == BT_CLASS) - { - gfc_error ("Coindexed object with polymorphic allocatable " - "subcomponent at %L", &e->where); - t = false; - break; - } - } - } - - if (t) - gfc_expression_rank (e); - - if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e)) - add_caf_get_intrinsic (e); - - if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result) - gfc_warning (OPT_Wdeprecated_declarations, - "Using variable %qs at %L is deprecated", - sym->name, &e->where); - /* Simplify cases where access to a parameter array results in a - single constant. Suppress errors since those will have been - issued before, as warnings. */ - if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER) - { - gfc_push_suppress_errors (); - gfc_simplify_expr (e, 1); - gfc_pop_suppress_errors (); - } - - return t; -} - - -/* Checks to see that the correct symbol has been host associated. - The only situation where this arises is that in which a twice - contained function is parsed after the host association is made. - Therefore, on detecting this, change the symbol in the expression - and convert the array reference into an actual arglist if the old - symbol is a variable. */ -static bool -check_host_association (gfc_expr *e) -{ - gfc_symbol *sym, *old_sym; - gfc_symtree *st; - int n; - gfc_ref *ref; - gfc_actual_arglist *arg, *tail = NULL; - bool retval = e->expr_type == EXPR_FUNCTION; - - /* If the expression is the result of substitution in - interface.c(gfc_extend_expr) because there is no way in - which the host association can be wrong. */ - if (e->symtree == NULL - || e->symtree->n.sym == NULL - || e->user_operator) - return retval; - - old_sym = e->symtree->n.sym; - - if (gfc_current_ns->parent - && old_sym->ns != gfc_current_ns) - { - /* Use the 'USE' name so that renamed module symbols are - correctly handled. */ - gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym); - - if (sym && old_sym != sym - && sym->ts.type == old_sym->ts.type - && sym->attr.flavor == FL_PROCEDURE - && sym->attr.contained) - { - /* Clear the shape, since it might not be valid. */ - gfc_free_shape (&e->shape, e->rank); - - /* Give the expression the right symtree! */ - gfc_find_sym_tree (e->symtree->name, NULL, 1, &st); - gcc_assert (st != NULL); - - if (old_sym->attr.flavor == FL_PROCEDURE - || e->expr_type == EXPR_FUNCTION) - { - /* Original was function so point to the new symbol, since - the actual argument list is already attached to the - expression. */ - e->value.function.esym = NULL; - e->symtree = st; - } - else - { - /* Original was variable so convert array references into - an actual arglist. This does not need any checking now - since resolve_function will take care of it. */ - e->value.function.actual = NULL; - e->expr_type = EXPR_FUNCTION; - e->symtree = st; - - /* Ambiguity will not arise if the array reference is not - the last reference. */ - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->next == NULL) - break; - - if ((ref == NULL || ref->type != REF_ARRAY) - && sym->attr.proc == PROC_INTERNAL) - { - gfc_error ("%qs at %L is host associated at %L into " - "a contained procedure with an internal " - "procedure of the same name", sym->name, - &old_sym->declared_at, &e->where); - return false; - } - - gcc_assert (ref->type == REF_ARRAY); - - /* Grab the start expressions from the array ref and - copy them into actual arguments. */ - for (n = 0; n < ref->u.ar.dimen; n++) - { - arg = gfc_get_actual_arglist (); - arg->expr = gfc_copy_expr (ref->u.ar.start[n]); - if (e->value.function.actual == NULL) - tail = e->value.function.actual = arg; - else - { - tail->next = arg; - tail = arg; - } - } - - /* Dump the reference list and set the rank. */ - gfc_free_ref_list (e->ref); - e->ref = NULL; - e->rank = sym->as ? sym->as->rank : 0; - } - - gfc_resolve_expr (e); - sym->refs++; - } - } - /* This might have changed! */ - return e->expr_type == EXPR_FUNCTION; -} - - -static void -gfc_resolve_character_operator (gfc_expr *e) -{ - gfc_expr *op1 = e->value.op.op1; - gfc_expr *op2 = e->value.op.op2; - gfc_expr *e1 = NULL; - gfc_expr *e2 = NULL; - - gcc_assert (e->value.op.op == INTRINSIC_CONCAT); - - if (op1->ts.u.cl && op1->ts.u.cl->length) - e1 = gfc_copy_expr (op1->ts.u.cl->length); - else if (op1->expr_type == EXPR_CONSTANT) - e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, - op1->value.character.length); - - if (op2->ts.u.cl && op2->ts.u.cl->length) - e2 = gfc_copy_expr (op2->ts.u.cl->length); - else if (op2->expr_type == EXPR_CONSTANT) - e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, - op2->value.character.length); - - e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - - if (!e1 || !e2) - { - gfc_free_expr (e1); - gfc_free_expr (e2); - - return; - } - - e->ts.u.cl->length = gfc_add (e1, e2); - e->ts.u.cl->length->ts.type = BT_INTEGER; - e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; - gfc_simplify_expr (e->ts.u.cl->length, 0); - gfc_resolve_expr (e->ts.u.cl->length); - - return; -} - - -/* Ensure that an character expression has a charlen and, if possible, a - length expression. */ - -static void -fixup_charlen (gfc_expr *e) -{ - /* The cases fall through so that changes in expression type and the need - for multiple fixes are picked up. In all circumstances, a charlen should - be available for the middle end to hang a backend_decl on. */ - switch (e->expr_type) - { - case EXPR_OP: - gfc_resolve_character_operator (e); - /* FALLTHRU */ - - case EXPR_ARRAY: - if (e->expr_type == EXPR_ARRAY) - gfc_resolve_character_array_constructor (e); - /* FALLTHRU */ - - case EXPR_SUBSTRING: - if (!e->ts.u.cl && e->ref) - gfc_resolve_substring_charlen (e); - /* FALLTHRU */ - - default: - if (!e->ts.u.cl) - e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - - break; - } -} - - -/* Update an actual argument to include the passed-object for type-bound - procedures at the right position. */ - -static gfc_actual_arglist* -update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos, - const char *name) -{ - gcc_assert (argpos > 0); - - if (argpos == 1) - { - gfc_actual_arglist* result; - - result = gfc_get_actual_arglist (); - result->expr = po; - result->next = lst; - if (name) - result->name = name; - - return result; - } - - if (lst) - lst->next = update_arglist_pass (lst->next, po, argpos - 1, name); - else - lst = update_arglist_pass (NULL, po, argpos - 1, name); - return lst; -} - - -/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */ - -static gfc_expr* -extract_compcall_passed_object (gfc_expr* e) -{ - gfc_expr* po; - - if (e->expr_type == EXPR_UNKNOWN) - { - gfc_error ("Error in typebound call at %L", - &e->where); - return NULL; - } - - gcc_assert (e->expr_type == EXPR_COMPCALL); - - if (e->value.compcall.base_object) - po = gfc_copy_expr (e->value.compcall.base_object); - else - { - po = gfc_get_expr (); - po->expr_type = EXPR_VARIABLE; - po->symtree = e->symtree; - po->ref = gfc_copy_ref (e->ref); - po->where = e->where; - } - - if (!gfc_resolve_expr (po)) - return NULL; - - return po; -} - - -/* Update the arglist of an EXPR_COMPCALL expression to include the - passed-object. */ - -static bool -update_compcall_arglist (gfc_expr* e) -{ - gfc_expr* po; - gfc_typebound_proc* tbp; - - tbp = e->value.compcall.tbp; - - if (tbp->error) - return false; - - po = extract_compcall_passed_object (e); - if (!po) - return false; - - if (tbp->nopass || e->value.compcall.ignore_pass) - { - gfc_free_expr (po); - return true; - } - - if (tbp->pass_arg_num <= 0) - return false; - - e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, - tbp->pass_arg_num, - tbp->pass_arg); - - return true; -} - - -/* Extract the passed object from a PPC call (a copy of it). */ - -static gfc_expr* -extract_ppc_passed_object (gfc_expr *e) -{ - gfc_expr *po; - gfc_ref **ref; - - po = gfc_get_expr (); - po->expr_type = EXPR_VARIABLE; - po->symtree = e->symtree; - po->ref = gfc_copy_ref (e->ref); - po->where = e->where; - - /* Remove PPC reference. */ - ref = &po->ref; - while ((*ref)->next) - ref = &(*ref)->next; - gfc_free_ref_list (*ref); - *ref = NULL; - - if (!gfc_resolve_expr (po)) - return NULL; - - return po; -} - - -/* Update the actual arglist of a procedure pointer component to include the - passed-object. */ - -static bool -update_ppc_arglist (gfc_expr* e) -{ - gfc_expr* po; - gfc_component *ppc; - gfc_typebound_proc* tb; - - ppc = gfc_get_proc_ptr_comp (e); - if (!ppc) - return false; - - tb = ppc->tb; - - if (tb->error) - return false; - else if (tb->nopass) - return true; - - po = extract_ppc_passed_object (e); - if (!po) - return false; - - /* F08:R739. */ - if (po->rank != 0) - { - gfc_error ("Passed-object at %L must be scalar", &e->where); - return false; - } - - /* F08:C611. */ - if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract) - { - gfc_error ("Base object for procedure-pointer component call at %L is of" - " ABSTRACT type %qs", &e->where, po->ts.u.derived->name); - return false; - } - - gcc_assert (tb->pass_arg_num > 0); - e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, - tb->pass_arg_num, - tb->pass_arg); - - return true; -} - - -/* Check that the object a TBP is called on is valid, i.e. it must not be - of ABSTRACT type (as in subobject%abstract_parent%tbp()). */ - -static bool -check_typebound_baseobject (gfc_expr* e) -{ - gfc_expr* base; - bool return_value = false; - - base = extract_compcall_passed_object (e); - if (!base) - return false; - - if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS) - { - gfc_error ("Error in typebound call at %L", &e->where); - goto cleanup; - } - - if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok) - return false; - - /* F08:C611. */ - if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) - { - gfc_error ("Base object for type-bound procedure call at %L is of" - " ABSTRACT type %qs", &e->where, base->ts.u.derived->name); - goto cleanup; - } - - /* F08:C1230. If the procedure called is NOPASS, - the base object must be scalar. */ - if (e->value.compcall.tbp->nopass && base->rank != 0) - { - gfc_error ("Base object for NOPASS type-bound procedure call at %L must" - " be scalar", &e->where); - goto cleanup; - } - - return_value = true; - -cleanup: - gfc_free_expr (base); - return return_value; -} - - -/* Resolve a call to a type-bound procedure, either function or subroutine, - statically from the data in an EXPR_COMPCALL expression. The adapted - arglist and the target-procedure symtree are returned. */ - -static bool -resolve_typebound_static (gfc_expr* e, gfc_symtree** target, - gfc_actual_arglist** actual) -{ - gcc_assert (e->expr_type == EXPR_COMPCALL); - gcc_assert (!e->value.compcall.tbp->is_generic); - - /* Update the actual arglist for PASS. */ - if (!update_compcall_arglist (e)) - return false; - - *actual = e->value.compcall.actual; - *target = e->value.compcall.tbp->u.specific; - - gfc_free_ref_list (e->ref); - e->ref = NULL; - e->value.compcall.actual = NULL; - - /* If we find a deferred typebound procedure, check for derived types - that an overriding typebound procedure has not been missed. */ - if (e->value.compcall.name - && !e->value.compcall.tbp->non_overridable - && e->value.compcall.base_object - && e->value.compcall.base_object->ts.type == BT_DERIVED) - { - gfc_symtree *st; - gfc_symbol *derived; - - /* Use the derived type of the base_object. */ - derived = e->value.compcall.base_object->ts.u.derived; - st = NULL; - - /* If necessary, go through the inheritance chain. */ - while (!st && derived) - { - /* Look for the typebound procedure 'name'. */ - if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) - st = gfc_find_symtree (derived->f2k_derived->tb_sym_root, - e->value.compcall.name); - if (!st) - derived = gfc_get_derived_super_type (derived); - } - - /* Now find the specific name in the derived type namespace. */ - if (st && st->n.tb && st->n.tb->u.specific) - gfc_find_sym_tree (st->n.tb->u.specific->name, - derived->ns, 1, &st); - if (st) - *target = st; - } - return true; -} - - -/* Get the ultimate declared type from an expression. In addition, - return the last class/derived type reference and the copy of the - reference list. If check_types is set true, derived types are - identified as well as class references. */ -static gfc_symbol* -get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, - gfc_expr *e, bool check_types) -{ - gfc_symbol *declared; - gfc_ref *ref; - - declared = NULL; - if (class_ref) - *class_ref = NULL; - if (new_ref) - *new_ref = gfc_copy_ref (e->ref); - - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type != REF_COMPONENT) - continue; - - if ((ref->u.c.component->ts.type == BT_CLASS - || (check_types && gfc_bt_struct (ref->u.c.component->ts.type))) - && ref->u.c.component->attr.flavor != FL_PROCEDURE) - { - declared = ref->u.c.component->ts.u.derived; - if (class_ref) - *class_ref = ref; - } - } - - if (declared == NULL) - declared = e->symtree->n.sym->ts.u.derived; - - return declared; -} - - -/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out - which of the specific bindings (if any) matches the arglist and transform - the expression into a call of that binding. */ - -static bool -resolve_typebound_generic_call (gfc_expr* e, const char **name) -{ - gfc_typebound_proc* genproc; - const char* genname; - gfc_symtree *st; - gfc_symbol *derived; - - gcc_assert (e->expr_type == EXPR_COMPCALL); - genname = e->value.compcall.name; - genproc = e->value.compcall.tbp; - - if (!genproc->is_generic) - return true; - - /* Try the bindings on this type and in the inheritance hierarchy. */ - for (; genproc; genproc = genproc->overridden) - { - gfc_tbp_generic* g; - - gcc_assert (genproc->is_generic); - for (g = genproc->u.generic; g; g = g->next) - { - gfc_symbol* target; - gfc_actual_arglist* args; - bool matches; - - gcc_assert (g->specific); - - if (g->specific->error) - continue; - - target = g->specific->u.specific->n.sym; - - /* Get the right arglist by handling PASS/NOPASS. */ - args = gfc_copy_actual_arglist (e->value.compcall.actual); - if (!g->specific->nopass) - { - gfc_expr* po; - po = extract_compcall_passed_object (e); - if (!po) - { - gfc_free_actual_arglist (args); - return false; - } - - gcc_assert (g->specific->pass_arg_num > 0); - gcc_assert (!g->specific->error); - args = update_arglist_pass (args, po, g->specific->pass_arg_num, - g->specific->pass_arg); - } - resolve_actual_arglist (args, target->attr.proc, - is_external_proc (target) - && gfc_sym_get_dummy_args (target) == NULL); - - /* Check if this arglist matches the formal. */ - matches = gfc_arglist_matches_symbol (&args, target); - - /* Clean up and break out of the loop if we've found it. */ - gfc_free_actual_arglist (args); - if (matches) - { - e->value.compcall.tbp = g->specific; - genname = g->specific_st->name; - /* Pass along the name for CLASS methods, where the vtab - procedure pointer component has to be referenced. */ - if (name) - *name = genname; - goto success; - } - } - } - - /* Nothing matching found! */ - gfc_error ("Found no matching specific binding for the call to the GENERIC" - " %qs at %L", genname, &e->where); - return false; - -success: - /* Make sure that we have the right specific instance for the name. */ - derived = get_declared_from_expr (NULL, NULL, e, true); - - st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); - if (st) - e->value.compcall.tbp = st->n.tb; - - return true; -} - - -/* Resolve a call to a type-bound subroutine. */ - -static bool -resolve_typebound_call (gfc_code* c, const char **name, bool *overridable) -{ - gfc_actual_arglist* newactual; - gfc_symtree* target; - - /* Check that's really a SUBROUTINE. */ - if (!c->expr1->value.compcall.tbp->subroutine) - { - if (!c->expr1->value.compcall.tbp->is_generic - && c->expr1->value.compcall.tbp->u.specific - && c->expr1->value.compcall.tbp->u.specific->n.sym - && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine) - c->expr1->value.compcall.tbp->subroutine = 1; - else - { - gfc_error ("%qs at %L should be a SUBROUTINE", - c->expr1->value.compcall.name, &c->loc); - return false; - } - } - - if (!check_typebound_baseobject (c->expr1)) - return false; - - /* Pass along the name for CLASS methods, where the vtab - procedure pointer component has to be referenced. */ - if (name) - *name = c->expr1->value.compcall.name; - - if (!resolve_typebound_generic_call (c->expr1, name)) - return false; - - /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */ - if (overridable) - *overridable = !c->expr1->value.compcall.tbp->non_overridable; - - /* Transform into an ordinary EXEC_CALL for now. */ - - if (!resolve_typebound_static (c->expr1, &target, &newactual)) - return false; - - c->ext.actual = newactual; - c->symtree = target; - c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); - - gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); - - gfc_free_expr (c->expr1); - c->expr1 = gfc_get_expr (); - c->expr1->expr_type = EXPR_FUNCTION; - c->expr1->symtree = target; - c->expr1->where = c->loc; - - return resolve_call (c); -} - - -/* Resolve a component-call expression. */ -static bool -resolve_compcall (gfc_expr* e, const char **name) -{ - gfc_actual_arglist* newactual; - gfc_symtree* target; - - /* Check that's really a FUNCTION. */ - if (!e->value.compcall.tbp->function) - { - gfc_error ("%qs at %L should be a FUNCTION", - e->value.compcall.name, &e->where); - return false; - } - - - /* These must not be assign-calls! */ - gcc_assert (!e->value.compcall.assign); - - if (!check_typebound_baseobject (e)) - return false; - - /* Pass along the name for CLASS methods, where the vtab - procedure pointer component has to be referenced. */ - if (name) - *name = e->value.compcall.name; - - if (!resolve_typebound_generic_call (e, name)) - return false; - gcc_assert (!e->value.compcall.tbp->is_generic); - - /* Take the rank from the function's symbol. */ - if (e->value.compcall.tbp->u.specific->n.sym->as) - e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank; - - /* For now, we simply transform it into an EXPR_FUNCTION call with the same - arglist to the TBP's binding target. */ - - if (!resolve_typebound_static (e, &target, &newactual)) - return false; - - e->value.function.actual = newactual; - e->value.function.name = NULL; - e->value.function.esym = target->n.sym; - e->value.function.isym = NULL; - e->symtree = target; - e->ts = target->n.sym->ts; - e->expr_type = EXPR_FUNCTION; - - /* Resolution is not necessary if this is a class subroutine; this - function only has to identify the specific proc. Resolution of - the call will be done next in resolve_typebound_call. */ - return gfc_resolve_expr (e); -} - - -static bool resolve_fl_derived (gfc_symbol *sym); - - -/* Resolve a typebound function, or 'method'. First separate all - the non-CLASS references by calling resolve_compcall directly. */ - -static bool -resolve_typebound_function (gfc_expr* e) -{ - gfc_symbol *declared; - gfc_component *c; - gfc_ref *new_ref; - gfc_ref *class_ref; - gfc_symtree *st; - const char *name; - gfc_typespec ts; - gfc_expr *expr; - bool overridable; - - st = e->symtree; - - /* Deal with typebound operators for CLASS objects. */ - expr = e->value.compcall.base_object; - overridable = !e->value.compcall.tbp->non_overridable; - if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) - { - /* Since the typebound operators are generic, we have to ensure - that any delays in resolution are corrected and that the vtab - is present. */ - ts = expr->ts; - declared = ts.u.derived; - c = gfc_find_component (declared, "_vptr", true, true, NULL); - if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); - - if (!resolve_compcall (e, &name)) - return false; - - /* Use the generic name if it is there. */ - name = name ? name : e->value.function.esym->name; - e->symtree = expr->symtree; - e->ref = gfc_copy_ref (expr->ref); - get_declared_from_expr (&class_ref, NULL, e, false); - - /* Trim away the extraneous references that emerge from nested - use of interface.c (extend_expr). */ - if (class_ref && class_ref->next) - { - gfc_free_ref_list (class_ref->next); - class_ref->next = NULL; - } - else if (e->ref && !class_ref && expr->ts.type != BT_CLASS) - { - gfc_free_ref_list (e->ref); - e->ref = NULL; - } - - gfc_add_vptr_component (e); - gfc_add_component_ref (e, name); - e->value.function.esym = NULL; - if (expr->expr_type != EXPR_VARIABLE) - e->base_expr = expr; - return true; - } - - if (st == NULL) - return resolve_compcall (e, NULL); - - if (!gfc_resolve_ref (e)) - return false; - - /* Get the CLASS declared type. */ - declared = get_declared_from_expr (&class_ref, &new_ref, e, true); - - if (!resolve_fl_derived (declared)) - return false; - - /* Weed out cases of the ultimate component being a derived type. */ - if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) - || (!class_ref && st->n.sym->ts.type != BT_CLASS)) - { - gfc_free_ref_list (new_ref); - return resolve_compcall (e, NULL); - } - - c = gfc_find_component (declared, "_data", true, true, NULL); - - /* Treat the call as if it is a typebound procedure, in order to roll - out the correct name for the specific function. */ - if (!resolve_compcall (e, &name)) - { - gfc_free_ref_list (new_ref); - return false; - } - ts = e->ts; - - if (overridable) - { - /* Convert the expression to a procedure pointer component call. */ - e->value.function.esym = NULL; - e->symtree = st; - - if (new_ref) - e->ref = new_ref; - - /* '_vptr' points to the vtab, which contains the procedure pointers. */ - gfc_add_vptr_component (e); - gfc_add_component_ref (e, name); - - /* Recover the typespec for the expression. This is really only - necessary for generic procedures, where the additional call - to gfc_add_component_ref seems to throw the collection of the - correct typespec. */ - e->ts = ts; - } - else if (new_ref) - gfc_free_ref_list (new_ref); - - return true; -} - -/* Resolve a typebound subroutine, or 'method'. First separate all - the non-CLASS references by calling resolve_typebound_call - directly. */ - -static bool -resolve_typebound_subroutine (gfc_code *code) -{ - gfc_symbol *declared; - gfc_component *c; - gfc_ref *new_ref; - gfc_ref *class_ref; - gfc_symtree *st; - const char *name; - gfc_typespec ts; - gfc_expr *expr; - bool overridable; - - st = code->expr1->symtree; - - /* Deal with typebound operators for CLASS objects. */ - expr = code->expr1->value.compcall.base_object; - overridable = !code->expr1->value.compcall.tbp->non_overridable; - if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) - { - /* If the base_object is not a variable, the corresponding actual - argument expression must be stored in e->base_expression so - that the corresponding tree temporary can be used as the base - object in gfc_conv_procedure_call. */ - if (expr->expr_type != EXPR_VARIABLE) - { - gfc_actual_arglist *args; - - args= code->expr1->value.function.actual; - for (; args; args = args->next) - if (expr == args->expr) - expr = args->expr; - } - - /* Since the typebound operators are generic, we have to ensure - that any delays in resolution are corrected and that the vtab - is present. */ - declared = expr->ts.u.derived; - c = gfc_find_component (declared, "_vptr", true, true, NULL); - if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); - - if (!resolve_typebound_call (code, &name, NULL)) - return false; - - /* Use the generic name if it is there. */ - name = name ? name : code->expr1->value.function.esym->name; - code->expr1->symtree = expr->symtree; - code->expr1->ref = gfc_copy_ref (expr->ref); - - /* Trim away the extraneous references that emerge from nested - use of interface.c (extend_expr). */ - get_declared_from_expr (&class_ref, NULL, code->expr1, false); - if (class_ref && class_ref->next) - { - gfc_free_ref_list (class_ref->next); - class_ref->next = NULL; - } - else if (code->expr1->ref && !class_ref) - { - gfc_free_ref_list (code->expr1->ref); - code->expr1->ref = NULL; - } - - /* Now use the procedure in the vtable. */ - gfc_add_vptr_component (code->expr1); - gfc_add_component_ref (code->expr1, name); - code->expr1->value.function.esym = NULL; - if (expr->expr_type != EXPR_VARIABLE) - code->expr1->base_expr = expr; - return true; - } - - if (st == NULL) - return resolve_typebound_call (code, NULL, NULL); - - if (!gfc_resolve_ref (code->expr1)) - return false; - - /* Get the CLASS declared type. */ - get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); - - /* Weed out cases of the ultimate component being a derived type. */ - if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) - || (!class_ref && st->n.sym->ts.type != BT_CLASS)) - { - gfc_free_ref_list (new_ref); - return resolve_typebound_call (code, NULL, NULL); - } - - if (!resolve_typebound_call (code, &name, &overridable)) - { - gfc_free_ref_list (new_ref); - return false; - } - ts = code->expr1->ts; - - if (overridable) - { - /* Convert the expression to a procedure pointer component call. */ - code->expr1->value.function.esym = NULL; - code->expr1->symtree = st; - - if (new_ref) - code->expr1->ref = new_ref; - - /* '_vptr' points to the vtab, which contains the procedure pointers. */ - gfc_add_vptr_component (code->expr1); - gfc_add_component_ref (code->expr1, name); - - /* Recover the typespec for the expression. This is really only - necessary for generic procedures, where the additional call - to gfc_add_component_ref seems to throw the collection of the - correct typespec. */ - code->expr1->ts = ts; - } - else if (new_ref) - gfc_free_ref_list (new_ref); - - return true; -} - - -/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */ - -static bool -resolve_ppc_call (gfc_code* c) -{ - gfc_component *comp; - - comp = gfc_get_proc_ptr_comp (c->expr1); - gcc_assert (comp != NULL); - - c->resolved_sym = c->expr1->symtree->n.sym; - c->expr1->expr_type = EXPR_VARIABLE; - - if (!comp->attr.subroutine) - gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); - - if (!gfc_resolve_ref (c->expr1)) - return false; - - if (!update_ppc_arglist (c->expr1)) - return false; - - c->ext.actual = c->expr1->value.compcall.actual; - - if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, - !(comp->ts.interface - && comp->ts.interface->formal))) - return false; - - if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where)) - return false; - - gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where); - - return true; -} - - -/* Resolve a Function Call to a Procedure Pointer Component (Function). */ - -static bool -resolve_expr_ppc (gfc_expr* e) -{ - gfc_component *comp; - - comp = gfc_get_proc_ptr_comp (e); - gcc_assert (comp != NULL); - - /* Convert to EXPR_FUNCTION. */ - e->expr_type = EXPR_FUNCTION; - e->value.function.isym = NULL; - e->value.function.actual = e->value.compcall.actual; - e->ts = comp->ts; - if (comp->as != NULL) - e->rank = comp->as->rank; - - if (!comp->attr.function) - gfc_add_function (&comp->attr, comp->name, &e->where); - - if (!gfc_resolve_ref (e)) - return false; - - if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, - !(comp->ts.interface - && comp->ts.interface->formal))) - return false; - - if (!update_ppc_arglist (e)) - return false; - - if (!check_pure_function(e)) - return false; - - gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); - - return true; -} - - -static bool -gfc_is_expandable_expr (gfc_expr *e) -{ - gfc_constructor *con; - - if (e->expr_type == EXPR_ARRAY) - { - /* Traverse the constructor looking for variables that are flavor - parameter. Parameters must be expanded since they are fully used at - compile time. */ - con = gfc_constructor_first (e->value.constructor); - for (; con; con = gfc_constructor_next (con)) - { - if (con->expr->expr_type == EXPR_VARIABLE - && con->expr->symtree - && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER - || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) - return true; - if (con->expr->expr_type == EXPR_ARRAY - && gfc_is_expandable_expr (con->expr)) - return true; - } - } - - return false; -} - - -/* Sometimes variables in specification expressions of the result - of module procedures in submodules wind up not being the 'real' - dummy. Find this, if possible, in the namespace of the first - formal argument. */ - -static void -fixup_unique_dummy (gfc_expr *e) -{ - gfc_symtree *st = NULL; - gfc_symbol *s = NULL; - - if (e->symtree->n.sym->ns->proc_name - && e->symtree->n.sym->ns->proc_name->formal) - s = e->symtree->n.sym->ns->proc_name->formal->sym; - - if (s != NULL) - st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name); - - if (st != NULL - && st->n.sym != NULL - && st->n.sym->attr.dummy) - e->symtree = st; -} - -/* Resolve an expression. That is, make sure that types of operands agree - with their operators, intrinsic operators are converted to function calls - for overloaded types and unresolved function references are resolved. */ - -bool -gfc_resolve_expr (gfc_expr *e) -{ - bool t; - bool inquiry_save, actual_arg_save, first_actual_arg_save; - - if (e == NULL || e->do_not_resolve_again) - return true; - - /* inquiry_argument only applies to variables. */ - inquiry_save = inquiry_argument; - actual_arg_save = actual_arg; - first_actual_arg_save = first_actual_arg; - - if (e->expr_type != EXPR_VARIABLE) - { - inquiry_argument = false; - actual_arg = false; - first_actual_arg = false; - } - else if (e->symtree != NULL - && *e->symtree->name == '@' - && e->symtree->n.sym->attr.dummy) - { - /* Deal with submodule specification expressions that are not - found to be referenced in module.c(read_cleanup). */ - fixup_unique_dummy (e); - } - - switch (e->expr_type) - { - case EXPR_OP: - t = resolve_operator (e); - break; - - case EXPR_FUNCTION: - case EXPR_VARIABLE: - - if (check_host_association (e)) - t = resolve_function (e); - else - t = resolve_variable (e); - - if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref - && e->ref->type != REF_SUBSTRING) - gfc_resolve_substring_charlen (e); - - break; - - case EXPR_COMPCALL: - t = resolve_typebound_function (e); - break; - - case EXPR_SUBSTRING: - t = gfc_resolve_ref (e); - break; - - case EXPR_CONSTANT: - case EXPR_NULL: - t = true; - break; - - case EXPR_PPC: - t = resolve_expr_ppc (e); - break; - - case EXPR_ARRAY: - t = false; - if (!gfc_resolve_ref (e)) - break; - - t = gfc_resolve_array_constructor (e); - /* Also try to expand a constructor. */ - if (t) - { - gfc_expression_rank (e); - if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) - gfc_expand_constructor (e, false); - } - - /* This provides the opportunity for the length of constructors with - character valued function elements to propagate the string length - to the expression. */ - if (t && e->ts.type == BT_CHARACTER) - { - /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER - here rather then add a duplicate test for it above. */ - gfc_expand_constructor (e, false); - t = gfc_resolve_character_array_constructor (e); - } - - break; - - case EXPR_STRUCTURE: - t = gfc_resolve_ref (e); - if (!t) - break; - - t = resolve_structure_cons (e, 0); - if (!t) - break; - - t = gfc_simplify_expr (e, 0); - break; - - default: - gfc_internal_error ("gfc_resolve_expr(): Bad expression type"); - } - - if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl) - fixup_charlen (e); - - inquiry_argument = inquiry_save; - actual_arg = actual_arg_save; - first_actual_arg = first_actual_arg_save; - - /* For some reason, resolving these expressions a second time mangles - the typespec of the expression itself. */ - if (t && e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.select_rank_temporary - && UNLIMITED_POLY (e->symtree->n.sym)) - e->do_not_resolve_again = 1; - - return t; -} - - -/* Resolve an expression from an iterator. They must be scalar and have - INTEGER or (optionally) REAL type. */ - -static bool -gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, - const char *name_msgid) -{ - if (!gfc_resolve_expr (expr)) - return false; - - if (expr->rank != 0) - { - gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where); - return false; - } - - if (expr->ts.type != BT_INTEGER) - { - if (expr->ts.type == BT_REAL) - { - if (real_ok) - return gfc_notify_std (GFC_STD_F95_DEL, - "%s at %L must be integer", - _(name_msgid), &expr->where); - else - { - gfc_error ("%s at %L must be INTEGER", _(name_msgid), - &expr->where); - return false; - } - } - else - { - gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); - return false; - } - } - return true; -} - - -/* Resolve the expressions in an iterator structure. If REAL_OK is - false allow only INTEGER type iterators, otherwise allow REAL types. - Set own_scope to true for ac-implied-do and data-implied-do as those - have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */ - -bool -gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) -{ - if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")) - return false; - - if (!gfc_check_vardef_context (iter->var, false, false, own_scope, - _("iterator variable"))) - return false; - - if (!gfc_resolve_iterator_expr (iter->start, real_ok, - "Start expression in DO loop")) - return false; - - if (!gfc_resolve_iterator_expr (iter->end, real_ok, - "End expression in DO loop")) - return false; - - if (!gfc_resolve_iterator_expr (iter->step, real_ok, - "Step expression in DO loop")) - return false; - - /* Convert start, end, and step to the same type as var. */ - if (iter->start->ts.kind != iter->var->ts.kind - || iter->start->ts.type != iter->var->ts.type) - gfc_convert_type (iter->start, &iter->var->ts, 1); - - if (iter->end->ts.kind != iter->var->ts.kind - || iter->end->ts.type != iter->var->ts.type) - gfc_convert_type (iter->end, &iter->var->ts, 1); - - if (iter->step->ts.kind != iter->var->ts.kind - || iter->step->ts.type != iter->var->ts.type) - gfc_convert_type (iter->step, &iter->var->ts, 1); - - if (iter->step->expr_type == EXPR_CONSTANT) - { - if ((iter->step->ts.type == BT_INTEGER - && mpz_cmp_ui (iter->step->value.integer, 0) == 0) - || (iter->step->ts.type == BT_REAL - && mpfr_sgn (iter->step->value.real) == 0)) - { - gfc_error ("Step expression in DO loop at %L cannot be zero", - &iter->step->where); - return false; - } - } - - if (iter->start->expr_type == EXPR_CONSTANT - && iter->end->expr_type == EXPR_CONSTANT - && iter->step->expr_type == EXPR_CONSTANT) - { - int sgn, cmp; - if (iter->start->ts.type == BT_INTEGER) - { - sgn = mpz_cmp_ui (iter->step->value.integer, 0); - cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer); - } - else - { - sgn = mpfr_sgn (iter->step->value.real); - cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real); - } - if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))) - gfc_warning (OPT_Wzerotrip, - "DO loop at %L will be executed zero times", - &iter->step->where); - } - - if (iter->end->expr_type == EXPR_CONSTANT - && iter->end->ts.type == BT_INTEGER - && iter->step->expr_type == EXPR_CONSTANT - && iter->step->ts.type == BT_INTEGER - && (mpz_cmp_si (iter->step->value.integer, -1L) == 0 - || mpz_cmp_si (iter->step->value.integer, 1L) == 0)) - { - bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0; - int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false); - - if (is_step_positive - && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0) - gfc_warning (OPT_Wundefined_do_loop, - "DO loop at %L is undefined as it overflows", - &iter->step->where); - else if (!is_step_positive - && mpz_cmp (iter->end->value.integer, - gfc_integer_kinds[k].min_int) == 0) - gfc_warning (OPT_Wundefined_do_loop, - "DO loop at %L is undefined as it underflows", - &iter->step->where); - } - - return true; -} - - -/* Traversal function for find_forall_index. f == 2 signals that - that variable itself is not to be checked - only the references. */ - -static bool -forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) -{ - if (expr->expr_type != EXPR_VARIABLE) - return false; - - /* A scalar assignment */ - if (!expr->ref || *f == 1) - { - if (expr->symtree->n.sym == sym) - return true; - else - return false; - } - - if (*f == 2) - *f = 1; - return false; -} - - -/* Check whether the FORALL index appears in the expression or not. - Returns true if SYM is found in EXPR. */ - -bool -find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f) -{ - if (gfc_traverse_expr (expr, sym, forall_index, f)) - return true; - else - return false; -} - - -/* Resolve a list of FORALL iterators. The FORALL index-name is constrained - to be a scalar INTEGER variable. The subscripts and stride are scalar - INTEGERs, and if stride is a constant it must be nonzero. - Furthermore "A subscript or stride in a forall-triplet-spec shall - not contain a reference to any index-name in the - forall-triplet-spec-list in which it appears." (7.5.4.1) */ - -static void -resolve_forall_iterators (gfc_forall_iterator *it) -{ - gfc_forall_iterator *iter, *iter2; - - for (iter = it; iter; iter = iter->next) - { - if (gfc_resolve_expr (iter->var) - && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)) - gfc_error ("FORALL index-name at %L must be a scalar INTEGER", - &iter->var->where); - - if (gfc_resolve_expr (iter->start) - && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)) - gfc_error ("FORALL start expression at %L must be a scalar INTEGER", - &iter->start->where); - if (iter->var->ts.kind != iter->start->ts.kind) - gfc_convert_type (iter->start, &iter->var->ts, 1); - - if (gfc_resolve_expr (iter->end) - && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)) - gfc_error ("FORALL end expression at %L must be a scalar INTEGER", - &iter->end->where); - if (iter->var->ts.kind != iter->end->ts.kind) - gfc_convert_type (iter->end, &iter->var->ts, 1); - - if (gfc_resolve_expr (iter->stride)) - { - if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0) - gfc_error ("FORALL stride expression at %L must be a scalar %s", - &iter->stride->where, "INTEGER"); - - if (iter->stride->expr_type == EXPR_CONSTANT - && mpz_cmp_ui (iter->stride->value.integer, 0) == 0) - gfc_error ("FORALL stride expression at %L cannot be zero", - &iter->stride->where); - } - if (iter->var->ts.kind != iter->stride->ts.kind) - gfc_convert_type (iter->stride, &iter->var->ts, 1); - } - - for (iter = it; iter; iter = iter->next) - for (iter2 = iter; iter2; iter2 = iter2->next) - { - if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0) - || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0) - || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0)) - gfc_error ("FORALL index %qs may not appear in triplet " - "specification at %L", iter->var->symtree->name, - &iter2->start->where); - } -} - - -/* Given a pointer to a symbol that is a derived type, see if it's - inaccessible, i.e. if it's defined in another module and the components are - PRIVATE. The search is recursive if necessary. Returns zero if no - inaccessible components are found, nonzero otherwise. */ - -static int -derived_inaccessible (gfc_symbol *sym) -{ - gfc_component *c; - - if (sym->attr.use_assoc && sym->attr.private_comp) - return 1; - - for (c = sym->components; c; c = c->next) - { - /* Prevent an infinite loop through this function. */ - if (c->ts.type == BT_DERIVED && c->attr.pointer - && sym == c->ts.u.derived) - continue; - - if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived)) - return 1; - } - - return 0; -} - - -/* Resolve the argument of a deallocate expression. The expression must be - a pointer or a full array. */ - -static bool -resolve_deallocate_expr (gfc_expr *e) -{ - symbol_attribute attr; - int allocatable, pointer; - gfc_ref *ref; - gfc_symbol *sym; - gfc_component *c; - bool unlimited; - - if (!gfc_resolve_expr (e)) - return false; - - if (e->expr_type != EXPR_VARIABLE) - goto bad; - - sym = e->symtree->n.sym; - unlimited = UNLIMITED_POLY(sym); - - if (sym->ts.type == BT_CLASS) - { - allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.class_pointer; - } - else - { - allocatable = sym->attr.allocatable; - pointer = sym->attr.pointer; - } - for (ref = e->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - if (ref->u.ar.type != AR_FULL - && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0 - && ref->u.ar.codimen && gfc_ref_this_image (ref))) - allocatable = 0; - break; - - case REF_COMPONENT: - c = ref->u.c.component; - if (c->ts.type == BT_CLASS) - { - allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.class_pointer; - } - else - { - allocatable = c->attr.allocatable; - pointer = c->attr.pointer; - } - break; - - case REF_SUBSTRING: - case REF_INQUIRY: - allocatable = 0; - break; - } - } - - attr = gfc_expr_attr (e); - - if (allocatable == 0 && attr.pointer == 0 && !unlimited) - { - bad: - gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", - &e->where); - return false; - } - - /* F2008, C644. */ - if (gfc_is_coindexed (e)) - { - gfc_error ("Coindexed allocatable object at %L", &e->where); - return false; - } - - if (pointer - && !gfc_check_vardef_context (e, true, true, false, - _("DEALLOCATE object"))) - return false; - if (!gfc_check_vardef_context (e, false, true, false, - _("DEALLOCATE object"))) - return false; - - return true; -} - - -/* Returns true if the expression e contains a reference to the symbol sym. */ -static bool -sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) -{ - if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym) - return true; - - return false; -} - -bool -gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) -{ - return gfc_traverse_expr (e, sym, sym_in_expr, 0); -} - - -/* Given the expression node e for an allocatable/pointer of derived type to be - allocated, get the expression node to be initialized afterwards (needed for - derived types with default initializers, and derived types with allocatable - components that need nullification.) */ - -gfc_expr * -gfc_expr_to_initialize (gfc_expr *e) -{ - gfc_expr *result; - gfc_ref *ref; - int i; - - result = gfc_copy_expr (e); - - /* Change the last array reference from AR_ELEMENT to AR_FULL. */ - for (ref = result->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->next == NULL) - { - if (ref->u.ar.dimen == 0 - && ref->u.ar.as && ref->u.ar.as->corank) - return result; - - ref->u.ar.type = AR_FULL; - - for (i = 0; i < ref->u.ar.dimen; i++) - ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL; - - break; - } - - gfc_free_shape (&result->shape, result->rank); - - /* Recalculate rank, shape, etc. */ - gfc_resolve_expr (result); - return result; -} - - -/* If the last ref of an expression is an array ref, return a copy of the - expression with that one removed. Otherwise, a copy of the original - expression. This is used for allocate-expressions and pointer assignment - LHS, where there may be an array specification that needs to be stripped - off when using gfc_check_vardef_context. */ - -static gfc_expr* -remove_last_array_ref (gfc_expr* e) -{ - gfc_expr* e2; - gfc_ref** r; - - e2 = gfc_copy_expr (e); - for (r = &e2->ref; *r; r = &(*r)->next) - if ((*r)->type == REF_ARRAY && !(*r)->next) - { - gfc_free_ref_list (*r); - *r = NULL; - break; - } - - return e2; -} - - -/* Used in resolve_allocate_expr to check that a allocation-object and - a source-expr are conformable. This does not catch all possible - cases; in particular a runtime checking is needed. */ - -static bool -conformable_arrays (gfc_expr *e1, gfc_expr *e2) -{ - gfc_ref *tail; - for (tail = e2->ref; tail && tail->next; tail = tail->next); - - /* First compare rank. */ - if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) - || (!tail && e1->rank != e2->rank)) - { - gfc_error ("Source-expr at %L must be scalar or have the " - "same rank as the allocate-object at %L", - &e1->where, &e2->where); - return false; - } - - if (e1->shape) - { - int i; - mpz_t s; - - mpz_init (s); - - for (i = 0; i < e1->rank; i++) - { - if (tail->u.ar.start[i] == NULL) - break; - - if (tail->u.ar.end[i]) - { - mpz_set (s, tail->u.ar.end[i]->value.integer); - mpz_sub (s, s, tail->u.ar.start[i]->value.integer); - mpz_add_ui (s, s, 1); - } - else - { - mpz_set (s, tail->u.ar.start[i]->value.integer); - } - - if (mpz_cmp (e1->shape[i], s) != 0) - { - gfc_error ("Source-expr at %L and allocate-object at %L must " - "have the same shape", &e1->where, &e2->where); - mpz_clear (s); - return false; - } - } - - mpz_clear (s); - } - - return true; -} - - -/* Resolve the expression in an ALLOCATE statement, doing the additional - checks to see whether the expression is OK or not. The expression must - have a trailing array reference that gives the size of the array. */ - -static bool -resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) -{ - int i, pointer, allocatable, dimension, is_abstract; - int codimension; - bool coindexed; - bool unlimited; - symbol_attribute attr; - gfc_ref *ref, *ref2; - gfc_expr *e2; - gfc_array_ref *ar; - gfc_symbol *sym = NULL; - gfc_alloc *a; - gfc_component *c; - bool t; - - /* Mark the utmost array component as being in allocate to allow DIMEN_STAR - checking of coarrays. */ - for (ref = e->ref; ref; ref = ref->next) - if (ref->next == NULL) - break; - - if (ref && ref->type == REF_ARRAY) - ref->u.ar.in_allocate = true; - - if (!gfc_resolve_expr (e)) - goto failure; - - /* Make sure the expression is allocatable or a pointer. If it is - pointer, the next-to-last reference must be a pointer. */ - - ref2 = NULL; - if (e->symtree) - sym = e->symtree->n.sym; - - /* Check whether ultimate component is abstract and CLASS. */ - is_abstract = 0; - - /* Is the allocate-object unlimited polymorphic? */ - unlimited = UNLIMITED_POLY(e); - - if (e->expr_type != EXPR_VARIABLE) - { - allocatable = 0; - attr = gfc_expr_attr (e); - pointer = attr.pointer; - dimension = attr.dimension; - codimension = attr.codimension; - } - else - { - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) - { - allocatable = CLASS_DATA (sym)->attr.allocatable; - pointer = CLASS_DATA (sym)->attr.class_pointer; - dimension = CLASS_DATA (sym)->attr.dimension; - codimension = CLASS_DATA (sym)->attr.codimension; - is_abstract = CLASS_DATA (sym)->attr.abstract; - } - else - { - allocatable = sym->attr.allocatable; - pointer = sym->attr.pointer; - dimension = sym->attr.dimension; - codimension = sym->attr.codimension; - } - - coindexed = false; - - for (ref = e->ref; ref; ref2 = ref, ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - if (ref->u.ar.codimen > 0) - { - int n; - for (n = ref->u.ar.dimen; - n < ref->u.ar.dimen + ref->u.ar.codimen; n++) - if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) - { - coindexed = true; - break; - } - } - - if (ref->next != NULL) - pointer = 0; - break; - - case REF_COMPONENT: - /* F2008, C644. */ - if (coindexed) - { - gfc_error ("Coindexed allocatable object at %L", - &e->where); - goto failure; - } - - c = ref->u.c.component; - if (c->ts.type == BT_CLASS) - { - allocatable = CLASS_DATA (c)->attr.allocatable; - pointer = CLASS_DATA (c)->attr.class_pointer; - dimension = CLASS_DATA (c)->attr.dimension; - codimension = CLASS_DATA (c)->attr.codimension; - is_abstract = CLASS_DATA (c)->attr.abstract; - } - else - { - allocatable = c->attr.allocatable; - pointer = c->attr.pointer; - dimension = c->attr.dimension; - codimension = c->attr.codimension; - is_abstract = c->attr.abstract; - } - break; - - case REF_SUBSTRING: - case REF_INQUIRY: - allocatable = 0; - pointer = 0; - break; - } - } - } - - /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data - pointer or an allocatable variable. */ - if (allocatable == 0 && pointer == 0) - { - gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", - &e->where); - goto failure; - } - - /* Some checks for the SOURCE tag. */ - if (code->expr3) - { - /* Check F03:C631. */ - if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) - { - gfc_error ("Type of entity at %L is type incompatible with " - "source-expr at %L", &e->where, &code->expr3->where); - goto failure; - } - - /* Check F03:C632 and restriction following Note 6.18. */ - if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e)) - goto failure; - - /* Check F03:C633. */ - if (code->expr3->ts.kind != e->ts.kind && !unlimited) - { - gfc_error ("The allocate-object at %L and the source-expr at %L " - "shall have the same kind type parameter", - &e->where, &code->expr3->where); - goto failure; - } - - /* Check F2008, C642. */ - if (code->expr3->ts.type == BT_DERIVED - && ((codimension && gfc_expr_attr (code->expr3).lock_comp) - || (code->expr3->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && code->expr3->ts.u.derived->intmod_sym_id - == ISOFORTRAN_LOCK_TYPE))) - { - gfc_error ("The source-expr at %L shall neither be of type " - "LOCK_TYPE nor have a LOCK_TYPE component if " - "allocate-object at %L is a coarray", - &code->expr3->where, &e->where); - goto failure; - } - - /* Check TS18508, C702/C703. */ - if (code->expr3->ts.type == BT_DERIVED - && ((codimension && gfc_expr_attr (code->expr3).event_comp) - || (code->expr3->ts.u.derived->from_intmod - == INTMOD_ISO_FORTRAN_ENV - && code->expr3->ts.u.derived->intmod_sym_id - == ISOFORTRAN_EVENT_TYPE))) - { - gfc_error ("The source-expr at %L shall neither be of type " - "EVENT_TYPE nor have a EVENT_TYPE component if " - "allocate-object at %L is a coarray", - &code->expr3->where, &e->where); - goto failure; - } - } - - /* Check F08:C629. */ - if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN - && !code->expr3) - { - gcc_assert (e->ts.type == BT_CLASS); - gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " - "type-spec or source-expr", sym->name, &e->where); - goto failure; - } - - /* Check F08:C632. */ - if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred - && !UNLIMITED_POLY (e)) - { - int cmp; - - if (!e->ts.u.cl->length) - goto failure; - - cmp = gfc_dep_compare_expr (e->ts.u.cl->length, - code->ext.alloc.ts.u.cl->length); - if (cmp == 1 || cmp == -1 || cmp == -3) - { - gfc_error ("Allocating %s at %L with type-spec requires the same " - "character-length parameter as in the declaration", - sym->name, &e->where); - goto failure; - } - } - - /* In the variable definition context checks, gfc_expr_attr is used - on the expression. This is fooled by the array specification - present in e, thus we have to eliminate that one temporarily. */ - e2 = remove_last_array_ref (e); - t = true; - if (t && pointer) - t = gfc_check_vardef_context (e2, true, true, false, - _("ALLOCATE object")); - if (t) - t = gfc_check_vardef_context (e2, false, true, false, - _("ALLOCATE object")); - gfc_free_expr (e2); - if (!t) - goto failure; - - if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension - && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED) - { - /* For class arrays, the initialization with SOURCE is done - using _copy and trans_call. It is convenient to exploit that - when the allocated type is different from the declared type but - no SOURCE exists by setting expr3. */ - code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); - } - else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED - && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) - { - /* We have to zero initialize the integer variable. */ - code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0); - } - - if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) - { - /* Make sure the vtab symbol is present when - the module variables are generated. */ - gfc_typespec ts = e->ts; - if (code->expr3) - ts = code->expr3->ts; - else if (code->ext.alloc.ts.type == BT_DERIVED) - ts = code->ext.alloc.ts; - - /* Finding the vtab also publishes the type's symbol. Therefore this - statement is necessary. */ - gfc_find_derived_vtab (ts.u.derived); - } - else if (unlimited && !UNLIMITED_POLY (code->expr3)) - { - /* Again, make sure the vtab symbol is present when - the module variables are generated. */ - gfc_typespec *ts = NULL; - if (code->expr3) - ts = &code->expr3->ts; - else - ts = &code->ext.alloc.ts; - - gcc_assert (ts); - - /* Finding the vtab also publishes the type's symbol. Therefore this - statement is necessary. */ - gfc_find_vtab (ts); - } - - if (dimension == 0 && codimension == 0) - goto success; - - /* Make sure the last reference node is an array specification. */ - - if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL - || (dimension && ref2->u.ar.dimen == 0)) - { - /* F08:C633. */ - if (code->expr3) - { - if (!gfc_notify_std (GFC_STD_F2008, "Array specification required " - "in ALLOCATE statement at %L", &e->where)) - goto failure; - if (code->expr3->rank != 0) - *array_alloc_wo_spec = true; - else - { - gfc_error ("Array specification or array-valued SOURCE= " - "expression required in ALLOCATE statement at %L", - &e->where); - goto failure; - } - } - else - { - gfc_error ("Array specification required in ALLOCATE statement " - "at %L", &e->where); - goto failure; - } - } - - /* Make sure that the array section reference makes sense in the - context of an ALLOCATE specification. */ - - ar = &ref2->u.ar; - - if (codimension) - for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) - { - switch (ar->dimen_type[i]) - { - case DIMEN_THIS_IMAGE: - gfc_error ("Coarray specification required in ALLOCATE statement " - "at %L", &e->where); - goto failure; - - case DIMEN_RANGE: - if (ar->start[i] == 0 || ar->end[i] == 0) - { - /* If ar->stride[i] is NULL, we issued a previous error. */ - if (ar->stride[i] == NULL) - gfc_error ("Bad array specification in ALLOCATE statement " - "at %L", &e->where); - goto failure; - } - else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1) - { - gfc_error ("Upper cobound is less than lower cobound at %L", - &ar->start[i]->where); - goto failure; - } - break; - - case DIMEN_ELEMENT: - if (ar->start[i]->expr_type == EXPR_CONSTANT) - { - gcc_assert (ar->start[i]->ts.type == BT_INTEGER); - if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0) - { - gfc_error ("Upper cobound is less than lower cobound " - "of 1 at %L", &ar->start[i]->where); - goto failure; - } - } - break; - - case DIMEN_STAR: - break; - - default: - gfc_error ("Bad array specification in ALLOCATE statement at %L", - &e->where); - goto failure; - - } - } - for (i = 0; i < ar->dimen; i++) - { - if (ar->type == AR_ELEMENT || ar->type == AR_FULL) - goto check_symbols; - - switch (ar->dimen_type[i]) - { - case DIMEN_ELEMENT: - break; - - case DIMEN_RANGE: - if (ar->start[i] != NULL - && ar->end[i] != NULL - && ar->stride[i] == NULL) - break; - - /* Fall through. */ - - case DIMEN_UNKNOWN: - case DIMEN_VECTOR: - case DIMEN_STAR: - case DIMEN_THIS_IMAGE: - gfc_error ("Bad array specification in ALLOCATE statement at %L", - &e->where); - goto failure; - } - -check_symbols: - for (a = code->ext.alloc.list; a; a = a->next) - { - sym = a->expr->symtree->n.sym; - - /* TODO - check derived type components. */ - if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS) - continue; - - if ((ar->start[i] != NULL - && gfc_find_sym_in_expr (sym, ar->start[i])) - || (ar->end[i] != NULL - && gfc_find_sym_in_expr (sym, ar->end[i]))) - { - gfc_error ("%qs must not appear in the array specification at " - "%L in the same ALLOCATE statement where it is " - "itself allocated", sym->name, &ar->where); - goto failure; - } - } - } - - for (i = ar->dimen; i < ar->codimen + ar->dimen; i++) - { - if (ar->dimen_type[i] == DIMEN_ELEMENT - || ar->dimen_type[i] == DIMEN_RANGE) - { - if (i == (ar->dimen + ar->codimen - 1)) - { - gfc_error ("Expected '*' in coindex specification in ALLOCATE " - "statement at %L", &e->where); - goto failure; - } - continue; - } - - if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1) - && ar->stride[i] == NULL) - break; - - gfc_error ("Bad coarray specification in ALLOCATE statement at %L", - &e->where); - goto failure; - } - -success: - return true; - -failure: - return false; -} - - -static void -resolve_allocate_deallocate (gfc_code *code, const char *fcn) -{ - gfc_expr *stat, *errmsg, *pe, *qe; - gfc_alloc *a, *p, *q; - - stat = code->expr1; - errmsg = code->expr2; - - /* Check the stat variable. */ - if (stat) - { - if (!gfc_check_vardef_context (stat, false, false, false, - _("STAT variable"))) - goto done_stat; - - if (stat->ts.type != BT_INTEGER - || stat->rank > 0) - gfc_error ("Stat-variable at %L must be a scalar INTEGER " - "variable", &stat->where); - - if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL) - goto done_stat; - - /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated - * within the ALLOCATE or DEALLOCATE statement in which it appears ... - */ - for (p = code->ext.alloc.list; p; p = p->next) - if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) - { - gfc_ref *ref1, *ref2; - bool found = true; - - for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; - ref1 = ref1->next, ref2 = ref2->next) - { - if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) - continue; - if (ref1->u.c.component->name != ref2->u.c.component->name) - { - found = false; - break; - } - } - - if (found) - { - gfc_error ("Stat-variable at %L shall not be %sd within " - "the same %s statement", &stat->where, fcn, fcn); - break; - } - } - } - -done_stat: - - /* Check the errmsg variable. */ - if (errmsg) - { - if (!stat) - gfc_warning (0, "ERRMSG at %L is useless without a STAT tag", - &errmsg->where); - - if (!gfc_check_vardef_context (errmsg, false, false, false, - _("ERRMSG variable"))) - goto done_errmsg; - - /* F18:R928 alloc-opt is ERRMSG = errmsg-variable - F18:R930 errmsg-variable is scalar-default-char-variable - F18:R906 default-char-variable is variable - F18:C906 default-char-variable shall be default character. */ - if (errmsg->ts.type != BT_CHARACTER - || errmsg->rank > 0 - || errmsg->ts.kind != gfc_default_character_kind) - gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER " - "variable", &errmsg->where); - - if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL) - goto done_errmsg; - - /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated - * within the ALLOCATE or DEALLOCATE statement in which it appears ... - */ - for (p = code->ext.alloc.list; p; p = p->next) - if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) - { - gfc_ref *ref1, *ref2; - bool found = true; - - for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; - ref1 = ref1->next, ref2 = ref2->next) - { - if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) - continue; - if (ref1->u.c.component->name != ref2->u.c.component->name) - { - found = false; - break; - } - } - - if (found) - { - gfc_error ("Errmsg-variable at %L shall not be %sd within " - "the same %s statement", &errmsg->where, fcn, fcn); - break; - } - } - } - -done_errmsg: - - /* Check that an allocate-object appears only once in the statement. */ - - for (p = code->ext.alloc.list; p; p = p->next) - { - pe = p->expr; - for (q = p->next; q; q = q->next) - { - qe = q->expr; - if (pe->symtree->n.sym->name == qe->symtree->n.sym->name) - { - /* This is a potential collision. */ - gfc_ref *pr = pe->ref; - gfc_ref *qr = qe->ref; - - /* Follow the references until - a) They start to differ, in which case there is no error; - you can deallocate a%b and a%c in a single statement - b) Both of them stop, which is an error - c) One of them stops, which is also an error. */ - while (1) - { - if (pr == NULL && qr == NULL) - { - gfc_error ("Allocate-object at %L also appears at %L", - &pe->where, &qe->where); - break; - } - else if (pr != NULL && qr == NULL) - { - gfc_error ("Allocate-object at %L is subobject of" - " object at %L", &pe->where, &qe->where); - break; - } - else if (pr == NULL && qr != NULL) - { - gfc_error ("Allocate-object at %L is subobject of" - " object at %L", &qe->where, &pe->where); - break; - } - /* Here, pr != NULL && qr != NULL */ - gcc_assert(pr->type == qr->type); - if (pr->type == REF_ARRAY) - { - /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)), - which are legal. */ - gcc_assert (qr->type == REF_ARRAY); - - if (pr->next && qr->next) - { - int i; - gfc_array_ref *par = &(pr->u.ar); - gfc_array_ref *qar = &(qr->u.ar); - - for (i=0; idimen; i++) - { - if ((par->start[i] != NULL - || qar->start[i] != NULL) - && gfc_dep_compare_expr (par->start[i], - qar->start[i]) != 0) - goto break_label; - } - } - } - else - { - if (pr->u.c.component->name != qr->u.c.component->name) - break; - } - - pr = pr->next; - qr = qr->next; - } - break_label: - ; - } - } - } - - if (strcmp (fcn, "ALLOCATE") == 0) - { - bool arr_alloc_wo_spec = false; - - /* Resolving the expr3 in the loop over all objects to allocate would - execute loop invariant code for each loop item. Therefore do it just - once here. */ - if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_DERIVED) - { - /* Default initialization via MOLD (non-polymorphic). */ - gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); - if (rhs != NULL) - { - gfc_resolve_expr (rhs); - gfc_free_expr (code->expr3); - code->expr3 = rhs; - } - } - for (a = code->ext.alloc.list; a; a = a->next) - resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec); - - if (arr_alloc_wo_spec && code->expr3) - { - /* Mark the allocate to have to take the array specification - from the expr3. */ - code->ext.alloc.arr_spec_from_expr3 = 1; - } - } - else - { - for (a = code->ext.alloc.list; a; a = a->next) - resolve_deallocate_expr (a->expr); - } -} - - -/************ SELECT CASE resolution subroutines ************/ - -/* Callback function for our mergesort variant. Determines interval - overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for - op1 > op2. Assumes we're not dealing with the default case. - We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:). - There are nine situations to check. */ - -static int -compare_cases (const gfc_case *op1, const gfc_case *op2) -{ - int retval; - - if (op1->low == NULL) /* op1 = (:L) */ - { - /* op2 = (:N), so overlap. */ - retval = 0; - /* op2 = (M:) or (M:N), L < M */ - if (op2->low != NULL - && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) - retval = -1; - } - else if (op1->high == NULL) /* op1 = (K:) */ - { - /* op2 = (M:), so overlap. */ - retval = 0; - /* op2 = (:N) or (M:N), K > N */ - if (op2->high != NULL - && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) - retval = 1; - } - else /* op1 = (K:L) */ - { - if (op2->low == NULL) /* op2 = (:N), K > N */ - retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) - ? 1 : 0; - else if (op2->high == NULL) /* op2 = (M:), L < M */ - retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) - ? -1 : 0; - else /* op2 = (M:N) */ - { - retval = 0; - /* L < M */ - if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) - retval = -1; - /* K > N */ - else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) - retval = 1; - } - } - - return retval; -} - - -/* Merge-sort a double linked case list, detecting overlap in the - process. LIST is the head of the double linked case list before it - is sorted. Returns the head of the sorted list if we don't see any - overlap, or NULL otherwise. */ - -static gfc_case * -check_case_overlap (gfc_case *list) -{ - gfc_case *p, *q, *e, *tail; - int insize, nmerges, psize, qsize, cmp, overlap_seen; - - /* If the passed list was empty, return immediately. */ - if (!list) - return NULL; - - overlap_seen = 0; - insize = 1; - - /* Loop unconditionally. The only exit from this loop is a return - statement, when we've finished sorting the case list. */ - for (;;) - { - p = list; - list = NULL; - tail = NULL; - - /* Count the number of merges we do in this pass. */ - nmerges = 0; - - /* Loop while there exists a merge to be done. */ - while (p) - { - int i; - - /* Count this merge. */ - nmerges++; - - /* Cut the list in two pieces by stepping INSIZE places - forward in the list, starting from P. */ - psize = 0; - q = p; - for (i = 0; i < insize; i++) - { - psize++; - q = q->right; - if (!q) - break; - } - qsize = insize; - - /* Now we have two lists. Merge them! */ - while (psize > 0 || (qsize > 0 && q != NULL)) - { - /* See from which the next case to merge comes from. */ - if (psize == 0) - { - /* P is empty so the next case must come from Q. */ - e = q; - q = q->right; - qsize--; - } - else if (qsize == 0 || q == NULL) - { - /* Q is empty. */ - e = p; - p = p->right; - psize--; - } - else - { - cmp = compare_cases (p, q); - if (cmp < 0) - { - /* The whole case range for P is less than the - one for Q. */ - e = p; - p = p->right; - psize--; - } - else if (cmp > 0) - { - /* The whole case range for Q is greater than - the case range for P. */ - e = q; - q = q->right; - qsize--; - } - else - { - /* The cases overlap, or they are the same - element in the list. Either way, we must - issue an error and get the next case from P. */ - /* FIXME: Sort P and Q by line number. */ - gfc_error ("CASE label at %L overlaps with CASE " - "label at %L", &p->where, &q->where); - overlap_seen = 1; - e = p; - p = p->right; - psize--; - } - } - - /* Add the next element to the merged list. */ - if (tail) - tail->right = e; - else - list = e; - e->left = tail; - tail = e; - } - - /* P has now stepped INSIZE places along, and so has Q. So - they're the same. */ - p = q; - } - tail->right = NULL; - - /* If we have done only one merge or none at all, we've - finished sorting the cases. */ - if (nmerges <= 1) - { - if (!overlap_seen) - return list; - else - return NULL; - } - - /* Otherwise repeat, merging lists twice the size. */ - insize *= 2; - } -} - - -/* Check to see if an expression is suitable for use in a CASE statement. - Makes sure that all case expressions are scalar constants of the same - type. Return false if anything is wrong. */ - -static bool -validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) -{ - if (e == NULL) return true; - - if (e->ts.type != case_expr->ts.type) - { - gfc_error ("Expression in CASE statement at %L must be of type %s", - &e->where, gfc_basic_typename (case_expr->ts.type)); - return false; - } - - /* C805 (R808) For a given case-construct, each case-value shall be of - the same type as case-expr. For character type, length differences - are allowed, but the kind type parameters shall be the same. */ - - if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind) - { - gfc_error ("Expression in CASE statement at %L must be of kind %d", - &e->where, case_expr->ts.kind); - return false; - } - - /* Convert the case value kind to that of case expression kind, - if needed */ - - if (e->ts.kind != case_expr->ts.kind) - gfc_convert_type_warn (e, &case_expr->ts, 2, 0); - - if (e->rank != 0) - { - gfc_error ("Expression in CASE statement at %L must be scalar", - &e->where); - return false; - } - - return true; -} - - -/* Given a completely parsed select statement, we: - - - Validate all expressions and code within the SELECT. - - Make sure that the selection expression is not of the wrong type. - - Make sure that no case ranges overlap. - - Eliminate unreachable cases and unreachable code resulting from - removing case labels. - - The standard does allow unreachable cases, e.g. CASE (5:3). But - they are a hassle for code generation, and to prevent that, we just - cut them out here. This is not necessary for overlapping cases - because they are illegal and we never even try to generate code. - - We have the additional caveat that a SELECT construct could have - been a computed GOTO in the source code. Fortunately we can fairly - easily work around that here: The case_expr for a "real" SELECT CASE - is in code->expr1, but for a computed GOTO it is in code->expr2. All - we have to do is make sure that the case_expr is a scalar integer - expression. */ - -static void -resolve_select (gfc_code *code, bool select_type) -{ - gfc_code *body; - gfc_expr *case_expr; - gfc_case *cp, *default_case, *tail, *head; - int seen_unreachable; - int seen_logical; - int ncases; - bt type; - bool t; - - if (code->expr1 == NULL) - { - /* This was actually a computed GOTO statement. */ - case_expr = code->expr2; - if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0) - gfc_error ("Selection expression in computed GOTO statement " - "at %L must be a scalar integer expression", - &case_expr->where); - - /* Further checking is not necessary because this SELECT was built - by the compiler, so it should always be OK. Just move the - case_expr from expr2 to expr so that we can handle computed - GOTOs as normal SELECTs from here on. */ - code->expr1 = code->expr2; - code->expr2 = NULL; - return; - } - - case_expr = code->expr1; - type = case_expr->ts.type; - - /* F08:C830. */ - if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER) - { - gfc_error ("Argument of SELECT statement at %L cannot be %s", - &case_expr->where, gfc_typename (case_expr)); - - /* Punt. Going on here just produce more garbage error messages. */ - return; - } - - /* F08:R842. */ - if (!select_type && case_expr->rank != 0) - { - gfc_error ("Argument of SELECT statement at %L must be a scalar " - "expression", &case_expr->where); - - /* Punt. */ - return; - } - - /* Raise a warning if an INTEGER case value exceeds the range of - the case-expr. Later, all expressions will be promoted to the - largest kind of all case-labels. */ - - if (type == BT_INTEGER) - for (body = code->block; body; body = body->block) - for (cp = body->ext.block.case_list; cp; cp = cp->next) - { - if (cp->low - && gfc_check_integer_range (cp->low->value.integer, - case_expr->ts.kind) != ARITH_OK) - gfc_warning (0, "Expression in CASE statement at %L is " - "not in the range of %s", &cp->low->where, - gfc_typename (case_expr)); - - if (cp->high - && cp->low != cp->high - && gfc_check_integer_range (cp->high->value.integer, - case_expr->ts.kind) != ARITH_OK) - gfc_warning (0, "Expression in CASE statement at %L is " - "not in the range of %s", &cp->high->where, - gfc_typename (case_expr)); - } - - /* PR 19168 has a long discussion concerning a mismatch of the kinds - of the SELECT CASE expression and its CASE values. Walk the lists - of case values, and if we find a mismatch, promote case_expr to - the appropriate kind. */ - - if (type == BT_LOGICAL || type == BT_INTEGER) - { - for (body = code->block; body; body = body->block) - { - /* Walk the case label list. */ - for (cp = body->ext.block.case_list; cp; cp = cp->next) - { - /* Intercept the DEFAULT case. It does not have a kind. */ - if (cp->low == NULL && cp->high == NULL) - continue; - - /* Unreachable case ranges are discarded, so ignore. */ - if (cp->low != NULL && cp->high != NULL - && cp->low != cp->high - && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) - continue; - - if (cp->low != NULL - && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low)) - gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0); - - if (cp->high != NULL - && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high)) - gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0); - } - } - } - - /* Assume there is no DEFAULT case. */ - default_case = NULL; - head = tail = NULL; - ncases = 0; - seen_logical = 0; - - for (body = code->block; body; body = body->block) - { - /* Assume the CASE list is OK, and all CASE labels can be matched. */ - t = true; - seen_unreachable = 0; - - /* Walk the case label list, making sure that all case labels - are legal. */ - for (cp = body->ext.block.case_list; cp; cp = cp->next) - { - /* Count the number of cases in the whole construct. */ - ncases++; - - /* Intercept the DEFAULT case. */ - if (cp->low == NULL && cp->high == NULL) - { - if (default_case != NULL) - { - gfc_error ("The DEFAULT CASE at %L cannot be followed " - "by a second DEFAULT CASE at %L", - &default_case->where, &cp->where); - t = false; - break; - } - else - { - default_case = cp; - continue; - } - } - - /* Deal with single value cases and case ranges. Errors are - issued from the validation function. */ - if (!validate_case_label_expr (cp->low, case_expr) - || !validate_case_label_expr (cp->high, case_expr)) - { - t = false; - break; - } - - if (type == BT_LOGICAL - && ((cp->low == NULL || cp->high == NULL) - || cp->low != cp->high)) - { - gfc_error ("Logical range in CASE statement at %L is not " - "allowed", - cp->low ? &cp->low->where : &cp->high->where); - t = false; - break; - } - - if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT) - { - int value; - value = cp->low->value.logical == 0 ? 2 : 1; - if (value & seen_logical) - { - gfc_error ("Constant logical value in CASE statement " - "is repeated at %L", - &cp->low->where); - t = false; - break; - } - seen_logical |= value; - } - - if (cp->low != NULL && cp->high != NULL - && cp->low != cp->high - && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) - { - if (warn_surprising) - gfc_warning (OPT_Wsurprising, - "Range specification at %L can never be matched", - &cp->where); - - cp->unreachable = 1; - seen_unreachable = 1; - } - else - { - /* If the case range can be matched, it can also overlap with - other cases. To make sure it does not, we put it in a - double linked list here. We sort that with a merge sort - later on to detect any overlapping cases. */ - if (!head) - { - head = tail = cp; - head->right = head->left = NULL; - } - else - { - tail->right = cp; - tail->right->left = tail; - tail = tail->right; - tail->right = NULL; - } - } - } - - /* It there was a failure in the previous case label, give up - for this case label list. Continue with the next block. */ - if (!t) - continue; - - /* See if any case labels that are unreachable have been seen. - If so, we eliminate them. This is a bit of a kludge because - the case lists for a single case statement (label) is a - single forward linked lists. */ - if (seen_unreachable) - { - /* Advance until the first case in the list is reachable. */ - while (body->ext.block.case_list != NULL - && body->ext.block.case_list->unreachable) - { - gfc_case *n = body->ext.block.case_list; - body->ext.block.case_list = body->ext.block.case_list->next; - n->next = NULL; - gfc_free_case_list (n); - } - - /* Strip all other unreachable cases. */ - if (body->ext.block.case_list) - { - for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next) - { - if (cp->next->unreachable) - { - gfc_case *n = cp->next; - cp->next = cp->next->next; - n->next = NULL; - gfc_free_case_list (n); - } - } - } - } - } - - /* See if there were overlapping cases. If the check returns NULL, - there was overlap. In that case we don't do anything. If head - is non-NULL, we prepend the DEFAULT case. The sorted list can - then used during code generation for SELECT CASE constructs with - a case expression of a CHARACTER type. */ - if (head) - { - head = check_case_overlap (head); - - /* Prepend the default_case if it is there. */ - if (head != NULL && default_case) - { - default_case->left = NULL; - default_case->right = head; - head->left = default_case; - } - } - - /* Eliminate dead blocks that may be the result if we've seen - unreachable case labels for a block. */ - for (body = code; body && body->block; body = body->block) - { - if (body->block->ext.block.case_list == NULL) - { - /* Cut the unreachable block from the code chain. */ - gfc_code *c = body->block; - body->block = c->block; - - /* Kill the dead block, but not the blocks below it. */ - c->block = NULL; - gfc_free_statements (c); - } - } - - /* More than two cases is legal but insane for logical selects. - Issue a warning for it. */ - if (warn_surprising && type == BT_LOGICAL && ncases > 2) - gfc_warning (OPT_Wsurprising, - "Logical SELECT CASE block at %L has more that two cases", - &code->loc); -} - - -/* Check if a derived type is extensible. */ - -bool -gfc_type_is_extensible (gfc_symbol *sym) -{ - return !(sym->attr.is_bind_c || sym->attr.sequence - || (sym->attr.is_class - && sym->components->ts.u.derived->attr.unlimited_polymorphic)); -} - - -static void -resolve_types (gfc_namespace *ns); - -/* Resolve an associate-name: Resolve target and ensure the type-spec is - correct as well as possibly the array-spec. */ - -static void -resolve_assoc_var (gfc_symbol* sym, bool resolve_target) -{ - gfc_expr* target; - - gcc_assert (sym->assoc); - gcc_assert (sym->attr.flavor == FL_VARIABLE); - - /* If this is for SELECT TYPE, the target may not yet be set. In that - case, return. Resolution will be called later manually again when - this is done. */ - target = sym->assoc->target; - if (!target) - return; - gcc_assert (!sym->assoc->dangling); - - if (resolve_target && !gfc_resolve_expr (target)) - return; - - /* For variable targets, we get some attributes from the target. */ - if (target->expr_type == EXPR_VARIABLE) - { - gfc_symbol *tsym, *dsym; - - gcc_assert (target->symtree); - tsym = target->symtree->n.sym; - - if (gfc_expr_attr (target).proc_pointer) - { - gfc_error ("Associating entity %qs at %L is a procedure pointer", - tsym->name, &target->where); - return; - } - - if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic - && (dsym = gfc_find_dt_in_generic (tsym)) != NULL - && dsym->attr.flavor == FL_DERIVED) - { - gfc_error ("Derived type %qs cannot be used as a variable at %L", - tsym->name, &target->where); - return; - } - - if (tsym->attr.flavor == FL_PROCEDURE) - { - bool is_error = true; - if (tsym->attr.function && tsym->result == tsym) - for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent) - if (tsym == ns->proc_name) - { - is_error = false; - break; - } - if (is_error) - { - gfc_error ("Associating entity %qs at %L is a procedure name", - tsym->name, &target->where); - return; - } - } - - sym->attr.asynchronous = tsym->attr.asynchronous; - sym->attr.volatile_ = tsym->attr.volatile_; - - sym->attr.target = tsym->attr.target - || gfc_expr_attr (target).pointer; - if (is_subref_array (target)) - sym->attr.subref_array_pointer = 1; - } - else if (target->ts.type == BT_PROCEDURE) - { - gfc_error ("Associating selector-expression at %L yields a procedure", - &target->where); - return; - } - - if (target->expr_type == EXPR_NULL) - { - gfc_error ("Selector at %L cannot be NULL()", &target->where); - return; - } - else if (target->ts.type == BT_UNKNOWN) - { - gfc_error ("Selector at %L has no type", &target->where); - return; - } - - /* Get type if this was not already set. Note that it can be - some other type than the target in case this is a SELECT TYPE - selector! So we must not update when the type is already there. */ - if (sym->ts.type == BT_UNKNOWN) - sym->ts = target->ts; - - gcc_assert (sym->ts.type != BT_UNKNOWN); - - /* See if this is a valid association-to-variable. */ - sym->assoc->variable = (target->expr_type == EXPR_VARIABLE - && !gfc_has_vector_subscript (target)); - - /* Finally resolve if this is an array or not. */ - if (sym->attr.dimension && target->rank == 0) - { - /* primary.c makes the assumption that a reference to an associate - name followed by a left parenthesis is an array reference. */ - if (sym->ts.type != BT_CHARACTER) - gfc_error ("Associate-name %qs at %L is used as array", - sym->name, &sym->declared_at); - sym->attr.dimension = 0; - return; - } - - - /* We cannot deal with class selectors that need temporaries. */ - if (target->ts.type == BT_CLASS - && gfc_ref_needs_temporary_p (target->ref)) - { - gfc_error ("CLASS selector at %L needs a temporary which is not " - "yet implemented", &target->where); - return; - } - - if (target->ts.type == BT_CLASS) - gfc_fix_class_refs (target); - - if (target->rank != 0 && !sym->attr.select_rank_temporary) - { - gfc_array_spec *as; - /* The rank may be incorrectly guessed at parsing, therefore make sure - it is corrected now. */ - if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed)) - { - if (!sym->as) - sym->as = gfc_get_array_spec (); - as = sym->as; - as->rank = target->rank; - as->type = AS_DEFERRED; - as->corank = gfc_get_corank (target); - sym->attr.dimension = 1; - if (as->corank != 0) - sym->attr.codimension = 1; - } - else if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym) - && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) - { - if (!CLASS_DATA (sym)->as) - CLASS_DATA (sym)->as = gfc_get_array_spec (); - as = CLASS_DATA (sym)->as; - as->rank = target->rank; - as->type = AS_DEFERRED; - as->corank = gfc_get_corank (target); - CLASS_DATA (sym)->attr.dimension = 1; - if (as->corank != 0) - CLASS_DATA (sym)->attr.codimension = 1; - } - } - else if (!sym->attr.select_rank_temporary) - { - /* target's rank is 0, but the type of the sym is still array valued, - which has to be corrected. */ - if (sym->ts.type == BT_CLASS && sym->ts.u.derived - && CLASS_DATA (sym) && CLASS_DATA (sym)->as) - { - gfc_array_spec *as; - symbol_attribute attr; - /* The associated variable's type is still the array type - correct this now. */ - gfc_typespec *ts = &target->ts; - gfc_ref *ref; - gfc_component *c; - for (ref = target->ref; ref != NULL; ref = ref->next) - { - switch (ref->type) - { - case REF_COMPONENT: - ts = &ref->u.c.component->ts; - break; - case REF_ARRAY: - if (ts->type == BT_CLASS) - ts = &ts->u.derived->components->ts; - break; - default: - break; - } - } - /* Create a scalar instance of the current class type. Because the - rank of a class array goes into its name, the type has to be - rebuild. The alternative of (re-)setting just the attributes - and as in the current type, destroys the type also in other - places. */ - as = NULL; - sym->ts = *ts; - sym->ts.type = BT_CLASS; - attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; - attr.class_ok = 0; - attr.associate_var = 1; - attr.dimension = attr.codimension = 0; - attr.class_pointer = 1; - if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) - gcc_unreachable (); - /* Make sure the _vptr is set. */ - c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL); - if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); - CLASS_DATA (sym)->attr.pointer = 1; - CLASS_DATA (sym)->attr.class_pointer = 1; - gfc_set_sym_referenced (sym->ts.u.derived); - gfc_commit_symbol (sym->ts.u.derived); - /* _vptr now has the _vtab in it, change it to the _vtype. */ - if (c->ts.u.derived->attr.vtab) - c->ts.u.derived = c->ts.u.derived->ts.u.derived; - c->ts.u.derived->ns->types_resolved = 0; - resolve_types (c->ts.u.derived->ns); - } - } - - /* Mark this as an associate variable. */ - sym->attr.associate_var = 1; - - /* Fix up the type-spec for CHARACTER types. */ - if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary) - { - if (!sym->ts.u.cl) - sym->ts.u.cl = target->ts.u.cl; - - if (sym->ts.deferred && target->expr_type == EXPR_VARIABLE - && target->symtree->n.sym->attr.dummy - && sym->ts.u.cl == target->ts.u.cl) - { - sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); - sym->ts.deferred = 1; - } - - if (!sym->ts.u.cl->length - && !sym->ts.deferred - && target->expr_type == EXPR_CONSTANT) - { - sym->ts.u.cl->length = - gfc_get_int_expr (gfc_charlen_int_kind, NULL, - target->value.character.length); - } - else if ((!sym->ts.u.cl->length - || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) - && target->expr_type != EXPR_VARIABLE) - { - sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); - sym->ts.deferred = 1; - - /* This is reset in trans-stmt.c after the assignment - of the target expression to the associate name. */ - sym->attr.allocatable = 1; - } - } - - /* If the target is a good class object, so is the associate variable. */ - if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) - sym->attr.class_ok = 1; -} - - -/* Ensure that SELECT TYPE expressions have the correct rank and a full - array reference, where necessary. The symbols are artificial and so - the dimension attribute and arrayspec can also be set. In addition, - sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS. - This is corrected here as well.*/ - -static void -fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, - int rank, gfc_ref *ref) -{ - gfc_ref *nref = (*expr1)->ref; - gfc_symbol *sym1 = (*expr1)->symtree->n.sym; - gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL; - (*expr1)->rank = rank; - if (sym1->ts.type == BT_CLASS) - { - if ((*expr1)->ts.type != BT_CLASS) - (*expr1)->ts = sym1->ts; - - CLASS_DATA (sym1)->attr.dimension = 1; - if (CLASS_DATA (sym1)->as == NULL && sym2) - CLASS_DATA (sym1)->as - = gfc_copy_array_spec (CLASS_DATA (sym2)->as); - } - else - { - sym1->attr.dimension = 1; - if (sym1->as == NULL && sym2) - sym1->as = gfc_copy_array_spec (sym2->as); - } - - for (; nref; nref = nref->next) - if (nref->next == NULL) - break; - - if (ref && nref && nref->type != REF_ARRAY) - nref->next = gfc_copy_ref (ref); - else if (ref && !nref) - (*expr1)->ref = gfc_copy_ref (ref); -} - - -static gfc_expr * -build_loc_call (gfc_expr *sym_expr) -{ - gfc_expr *loc_call; - loc_call = gfc_get_expr (); - loc_call->expr_type = EXPR_FUNCTION; - gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false); - loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE; - loc_call->symtree->n.sym->attr.intrinsic = 1; - loc_call->symtree->n.sym->result = loc_call->symtree->n.sym; - gfc_commit_symbol (loc_call->symtree->n.sym); - loc_call->ts.type = BT_INTEGER; - loc_call->ts.kind = gfc_index_integer_kind; - loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC); - loc_call->value.function.actual = gfc_get_actual_arglist (); - loc_call->value.function.actual->expr = sym_expr; - loc_call->where = sym_expr->where; - return loc_call; -} - -/* Resolve a SELECT TYPE statement. */ - -static void -resolve_select_type (gfc_code *code, gfc_namespace *old_ns) -{ - gfc_symbol *selector_type; - gfc_code *body, *new_st, *if_st, *tail; - gfc_code *class_is = NULL, *default_case = NULL; - gfc_case *c; - gfc_symtree *st; - char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; - gfc_namespace *ns; - int error = 0; - int rank = 0; - gfc_ref* ref = NULL; - gfc_expr *selector_expr = NULL; - - ns = code->ext.block.ns; - gfc_resolve (ns); - - /* Check for F03:C813. */ - if (code->expr1->ts.type != BT_CLASS - && !(code->expr2 && code->expr2->ts.type == BT_CLASS)) - { - gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " - "at %L", &code->loc); - return; - } - - if (!code->expr1->symtree->n.sym->attr.class_ok) - return; - - if (code->expr2) - { - gfc_ref *ref2 = NULL; - for (ref = code->expr2->ref; ref != NULL; ref = ref->next) - if (ref->type == REF_COMPONENT - && ref->u.c.component->ts.type == BT_CLASS) - ref2 = ref; - - if (ref2) - { - if (code->expr1->symtree->n.sym->attr.untyped) - code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts; - selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived; - } - else - { - if (code->expr1->symtree->n.sym->attr.untyped) - code->expr1->symtree->n.sym->ts = code->expr2->ts; - selector_type = CLASS_DATA (code->expr2) - ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived; - } - - if (code->expr2->rank - && code->expr1->ts.type == BT_CLASS - && CLASS_DATA (code->expr1)->as) - CLASS_DATA (code->expr1)->as->rank = code->expr2->rank; - - /* F2008: C803 The selector expression must not be coindexed. */ - if (gfc_is_coindexed (code->expr2)) - { - gfc_error ("Selector at %L must not be coindexed", - &code->expr2->where); - return; - } - - } - else - { - selector_type = CLASS_DATA (code->expr1)->ts.u.derived; - - if (gfc_is_coindexed (code->expr1)) - { - gfc_error ("Selector at %L must not be coindexed", - &code->expr1->where); - return; - } - } - - /* Loop over TYPE IS / CLASS IS cases. */ - for (body = code->block; body; body = body->block) - { - c = body->ext.block.case_list; - - if (!error) - { - /* Check for repeated cases. */ - for (tail = code->block; tail; tail = tail->block) - { - gfc_case *d = tail->ext.block.case_list; - if (tail == body) - break; - - if (c->ts.type == d->ts.type - && ((c->ts.type == BT_DERIVED - && c->ts.u.derived && d->ts.u.derived - && !strcmp (c->ts.u.derived->name, - d->ts.u.derived->name)) - || c->ts.type == BT_UNKNOWN - || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.kind == d->ts.kind))) - { - gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L", - &c->where, &d->where); - return; - } - } - } - - /* Check F03:C815. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && selector_type - && !selector_type->attr.unlimited_polymorphic - && !gfc_type_is_extensible (c->ts.u.derived)) - { - gfc_error ("Derived type %qs at %L must be extensible", - c->ts.u.derived->name, &c->where); - error++; - continue; - } - - /* Check F03:C816. */ - if (c->ts.type != BT_UNKNOWN - && selector_type && !selector_type->attr.unlimited_polymorphic - && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) - || !gfc_type_is_extension_of (selector_type, c->ts.u.derived))) - { - if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - gfc_error ("Derived type %qs at %L must be an extension of %qs", - c->ts.u.derived->name, &c->where, selector_type->name); - else - gfc_error ("Unexpected intrinsic type %qs at %L", - gfc_basic_typename (c->ts.type), &c->where); - error++; - continue; - } - - /* Check F03:C814. */ - if (c->ts.type == BT_CHARACTER - && (c->ts.u.cl->length != NULL || c->ts.deferred)) - { - gfc_error ("The type-spec at %L shall specify that each length " - "type parameter is assumed", &c->where); - error++; - continue; - } - - /* Intercept the DEFAULT case. */ - if (c->ts.type == BT_UNKNOWN) - { - /* Check F03:C818. */ - if (default_case) - { - gfc_error ("The DEFAULT CASE at %L cannot be followed " - "by a second DEFAULT CASE at %L", - &default_case->ext.block.case_list->where, &c->where); - error++; - continue; - } - - default_case = body; - } - } - - if (error > 0) - return; - - /* Transform SELECT TYPE statement to BLOCK and associate selector to - target if present. If there are any EXIT statements referring to the - SELECT TYPE construct, this is no problem because the gfc_code - reference stays the same and EXIT is equally possible from the BLOCK - it is changed to. */ - code->op = EXEC_BLOCK; - if (code->expr2) - { - gfc_association_list* assoc; - - assoc = gfc_get_association_list (); - assoc->st = code->expr1->symtree; - assoc->target = gfc_copy_expr (code->expr2); - assoc->target->where = code->expr2->where; - /* assoc->variable will be set by resolve_assoc_var. */ - - code->ext.block.assoc = assoc; - code->expr1->symtree->n.sym->assoc = assoc; - - resolve_assoc_var (code->expr1->symtree->n.sym, false); - } - else - code->ext.block.assoc = NULL; - - /* Ensure that the selector rank and arrayspec are available to - correct expressions in which they might be missing. */ - if (code->expr2 && code->expr2->rank) - { - rank = code->expr2->rank; - for (ref = code->expr2->ref; ref; ref = ref->next) - if (ref->next == NULL) - break; - if (ref && ref->type == REF_ARRAY) - ref = gfc_copy_ref (ref); - - /* Fixup expr1 if necessary. */ - if (rank) - fixup_array_ref (&code->expr1, code->expr2, rank, ref); - } - else if (code->expr1->rank) - { - rank = code->expr1->rank; - for (ref = code->expr1->ref; ref; ref = ref->next) - if (ref->next == NULL) - break; - if (ref && ref->type == REF_ARRAY) - ref = gfc_copy_ref (ref); - } - - /* Add EXEC_SELECT to switch on type. */ - new_st = gfc_get_code (code->op); - new_st->expr1 = code->expr1; - new_st->expr2 = code->expr2; - new_st->block = code->block; - code->expr1 = code->expr2 = NULL; - code->block = NULL; - if (!ns->code) - ns->code = new_st; - else - ns->code->next = new_st; - code = new_st; - code->op = EXEC_SELECT_TYPE; - - /* Use the intrinsic LOC function to generate an integer expression - for the vtable of the selector. Note that the rank of the selector - expression has to be set to zero. */ - gfc_add_vptr_component (code->expr1); - code->expr1->rank = 0; - code->expr1 = build_loc_call (code->expr1); - selector_expr = code->expr1->value.function.actual->expr; - - /* Loop over TYPE IS / CLASS IS cases. */ - for (body = code->block; body; body = body->block) - { - gfc_symbol *vtab; - gfc_expr *e; - c = body->ext.block.case_list; - - /* Generate an index integer expression for address of the - TYPE/CLASS vtable and store it in c->low. The hash expression - is stored in c->high and is used to resolve intrinsic cases. */ - if (c->ts.type != BT_UNKNOWN) - { - if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - { - vtab = gfc_find_derived_vtab (c->ts.u.derived); - gcc_assert (vtab); - c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL, - c->ts.u.derived->hash_value); - } - else - { - vtab = gfc_find_vtab (&c->ts); - gcc_assert (vtab && CLASS_DATA (vtab)->initializer); - e = CLASS_DATA (vtab)->initializer; - c->high = gfc_copy_expr (e); - if (c->high->ts.kind != gfc_integer_4_kind) - { - gfc_typespec ts; - ts.kind = gfc_integer_4_kind; - ts.type = BT_INTEGER; - gfc_convert_type_warn (c->high, &ts, 2, 0); - } - } - - e = gfc_lval_expr_from_sym (vtab); - c->low = build_loc_call (e); - } - else - continue; - - /* Associate temporary to selector. This should only be done - when this case is actually true, so build a new ASSOCIATE - that does precisely this here (instead of using the - 'global' one). */ - - if (c->ts.type == BT_CLASS) - sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); - else if (c->ts.type == BT_DERIVED) - sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); - else if (c->ts.type == BT_CHARACTER) - { - HOST_WIDE_INT charlen = 0; - if (c->ts.u.cl && c->ts.u.cl->length - && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) - charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); - snprintf (name, sizeof (name), - "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (c->ts.type), charlen, c->ts.kind); - } - else - sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), - c->ts.kind); - - st = gfc_find_symtree (ns->sym_root, name); - gcc_assert (st->n.sym->assoc); - st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); - st->n.sym->assoc->target->where = selector_expr->where; - if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) - { - gfc_add_data_component (st->n.sym->assoc->target); - /* Fixup the target expression if necessary. */ - if (rank) - fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref); - } - - new_st = gfc_get_code (EXEC_BLOCK); - new_st->ext.block.ns = gfc_build_block_ns (ns); - new_st->ext.block.ns->code = body->next; - body->next = new_st; - - /* Chain in the new list only if it is marked as dangling. Otherwise - there is a CASE label overlap and this is already used. Just ignore, - the error is diagnosed elsewhere. */ - if (st->n.sym->assoc->dangling) - { - new_st->ext.block.assoc = st->n.sym->assoc; - st->n.sym->assoc->dangling = 0; - } - - resolve_assoc_var (st->n.sym, false); - } - - /* Take out CLASS IS cases for separate treatment. */ - body = code; - while (body && body->block) - { - if (body->block->ext.block.case_list->ts.type == BT_CLASS) - { - /* Add to class_is list. */ - if (class_is == NULL) - { - class_is = body->block; - tail = class_is; - } - else - { - for (tail = class_is; tail->block; tail = tail->block) ; - tail->block = body->block; - tail = tail->block; - } - /* Remove from EXEC_SELECT list. */ - body->block = body->block->block; - tail->block = NULL; - } - else - body = body->block; - } - - if (class_is) - { - gfc_symbol *vtab; - - if (!default_case) - { - /* Add a default case to hold the CLASS IS cases. */ - for (tail = code; tail->block; tail = tail->block) ; - tail->block = gfc_get_code (EXEC_SELECT_TYPE); - tail = tail->block; - tail->ext.block.case_list = gfc_get_case (); - tail->ext.block.case_list->ts.type = BT_UNKNOWN; - tail->next = NULL; - default_case = tail; - } - - /* More than one CLASS IS block? */ - if (class_is->block) - { - gfc_code **c1,*c2; - bool swapped; - /* Sort CLASS IS blocks by extension level. */ - do - { - swapped = false; - for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) - { - c2 = (*c1)->block; - /* F03:C817 (check for doubles). */ - if ((*c1)->ext.block.case_list->ts.u.derived->hash_value - == c2->ext.block.case_list->ts.u.derived->hash_value) - { - gfc_error ("Double CLASS IS block in SELECT TYPE " - "statement at %L", - &c2->ext.block.case_list->where); - return; - } - if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension - < c2->ext.block.case_list->ts.u.derived->attr.extension) - { - /* Swap. */ - (*c1)->block = c2->block; - c2->block = *c1; - *c1 = c2; - swapped = true; - } - } - } - while (swapped); - } - - /* Generate IF chain. */ - if_st = gfc_get_code (EXEC_IF); - new_st = if_st; - for (body = class_is; body; body = body->block) - { - new_st->block = gfc_get_code (EXEC_IF); - new_st = new_st->block; - /* Set up IF condition: Call _gfortran_is_extension_of. */ - new_st->expr1 = gfc_get_expr (); - new_st->expr1->expr_type = EXPR_FUNCTION; - new_st->expr1->ts.type = BT_LOGICAL; - new_st->expr1->ts.kind = 4; - new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); - new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym); - new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF; - /* Set up arguments. */ - new_st->expr1->value.function.actual = gfc_get_actual_arglist (); - new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree); - new_st->expr1->value.function.actual->expr->where = code->loc; - new_st->expr1->where = code->loc; - gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); - vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); - st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); - new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); - new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); - new_st->expr1->value.function.actual->next->expr->where = code->loc; - /* Set up types in formal arg list. */ - new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg); - new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts; - new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg); - new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts; - - new_st->next = body->next; - } - if (default_case->next) - { - new_st->block = gfc_get_code (EXEC_IF); - new_st = new_st->block; - new_st->next = default_case->next; - } - - /* Replace CLASS DEFAULT code by the IF chain. */ - default_case->next = if_st; - } - - /* Resolve the internal code. This cannot be done earlier because - it requires that the sym->assoc of selectors is set already. */ - gfc_current_ns = ns; - gfc_resolve_blocks (code->block, gfc_current_ns); - gfc_current_ns = old_ns; - - if (ref) - free (ref); -} - - -/* Resolve a SELECT RANK statement. */ - -static void -resolve_select_rank (gfc_code *code, gfc_namespace *old_ns) -{ - gfc_namespace *ns; - gfc_code *body, *new_st, *tail; - gfc_case *c; - char tname[GFC_MAX_SYMBOL_LEN + 7]; - char name[2 * GFC_MAX_SYMBOL_LEN]; - gfc_symtree *st; - gfc_expr *selector_expr = NULL; - int case_value; - HOST_WIDE_INT charlen = 0; - - ns = code->ext.block.ns; - gfc_resolve (ns); - - code->op = EXEC_BLOCK; - if (code->expr2) - { - gfc_association_list* assoc; - - assoc = gfc_get_association_list (); - assoc->st = code->expr1->symtree; - assoc->target = gfc_copy_expr (code->expr2); - assoc->target->where = code->expr2->where; - /* assoc->variable will be set by resolve_assoc_var. */ - - code->ext.block.assoc = assoc; - code->expr1->symtree->n.sym->assoc = assoc; - - resolve_assoc_var (code->expr1->symtree->n.sym, false); - } - else - code->ext.block.assoc = NULL; - - /* Loop over RANK cases. Note that returning on the errors causes a - cascade of further errors because the case blocks do not compile - correctly. */ - for (body = code->block; body; body = body->block) - { - c = body->ext.block.case_list; - if (c->low) - case_value = (int) mpz_get_si (c->low->value.integer); - else - case_value = -2; - - /* Check for repeated cases. */ - for (tail = code->block; tail; tail = tail->block) - { - gfc_case *d = tail->ext.block.case_list; - int case_value2; - - if (tail == body) - break; - - /* Check F2018: C1153. */ - if (!c->low && !d->low) - gfc_error ("RANK DEFAULT at %L is repeated at %L", - &c->where, &d->where); - - if (!c->low || !d->low) - continue; - - /* Check F2018: C1153. */ - case_value2 = (int) mpz_get_si (d->low->value.integer); - if ((case_value == case_value2) && case_value == -1) - gfc_error ("RANK (*) at %L is repeated at %L", - &c->where, &d->where); - else if (case_value == case_value2) - gfc_error ("RANK (%i) at %L is repeated at %L", - case_value, &c->where, &d->where); - } - - if (!c->low) - continue; - - /* Check F2018: C1155. */ - if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable - || gfc_expr_attr (code->expr1).pointer)) - gfc_error ("RANK (*) at %L cannot be used with the pointer or " - "allocatable selector at %L", &c->where, &code->expr1->where); - - if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable - || gfc_expr_attr (code->expr1).pointer)) - gfc_error ("RANK (*) at %L cannot be used with the pointer or " - "allocatable selector at %L", &c->where, &code->expr1->where); - } - - /* Add EXEC_SELECT to switch on rank. */ - new_st = gfc_get_code (code->op); - new_st->expr1 = code->expr1; - new_st->expr2 = code->expr2; - new_st->block = code->block; - code->expr1 = code->expr2 = NULL; - code->block = NULL; - if (!ns->code) - ns->code = new_st; - else - ns->code->next = new_st; - code = new_st; - code->op = EXEC_SELECT_RANK; - - selector_expr = code->expr1; - - /* Loop over SELECT RANK cases. */ - for (body = code->block; body; body = body->block) - { - c = body->ext.block.case_list; - int case_value; - - /* Pass on the default case. */ - if (c->low == NULL) - continue; - - /* Associate temporary to selector. This should only be done - when this case is actually true, so build a new ASSOCIATE - that does precisely this here (instead of using the - 'global' one). */ - if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length - && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) - charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); - - if (c->ts.type == BT_CLASS) - sprintf (tname, "class_%s", c->ts.u.derived->name); - else if (c->ts.type == BT_DERIVED) - sprintf (tname, "type_%s", c->ts.u.derived->name); - else if (c->ts.type != BT_CHARACTER) - sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind); - else - sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (c->ts.type), charlen, c->ts.kind); - - case_value = (int) mpz_get_si (c->low->value.integer); - if (case_value >= 0) - sprintf (name, "__tmp_%s_rank_%d", tname, case_value); - else - sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value); - - st = gfc_find_symtree (ns->sym_root, name); - gcc_assert (st->n.sym->assoc); - - st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); - st->n.sym->assoc->target->where = selector_expr->where; - - new_st = gfc_get_code (EXEC_BLOCK); - new_st->ext.block.ns = gfc_build_block_ns (ns); - new_st->ext.block.ns->code = body->next; - body->next = new_st; - - /* Chain in the new list only if it is marked as dangling. Otherwise - there is a CASE label overlap and this is already used. Just ignore, - the error is diagnosed elsewhere. */ - if (st->n.sym->assoc->dangling) - { - new_st->ext.block.assoc = st->n.sym->assoc; - st->n.sym->assoc->dangling = 0; - } - - resolve_assoc_var (st->n.sym, false); - } - - gfc_current_ns = ns; - gfc_resolve_blocks (code->block, gfc_current_ns); - gfc_current_ns = old_ns; -} - - -/* Resolve a transfer statement. This is making sure that: - -- a derived type being transferred has only non-pointer components - -- a derived type being transferred doesn't have private components, unless - it's being transferred from the module where the type was defined - -- we're not trying to transfer a whole assumed size array. */ - -static void -resolve_transfer (gfc_code *code) -{ - gfc_symbol *sym, *derived; - gfc_ref *ref; - gfc_expr *exp; - bool write = false; - bool formatted = false; - gfc_dt *dt = code->ext.dt; - gfc_symbol *dtio_sub = NULL; - - exp = code->expr1; - - while (exp != NULL && exp->expr_type == EXPR_OP - && exp->value.op.op == INTRINSIC_PARENTHESES) - exp = exp->value.op.op1; - - if (exp && exp->expr_type == EXPR_NULL - && code->ext.dt) - { - gfc_error ("Invalid context for NULL () intrinsic at %L", - &exp->where); - return; - } - - if (exp == NULL || (exp->expr_type != EXPR_VARIABLE - && exp->expr_type != EXPR_FUNCTION - && exp->expr_type != EXPR_STRUCTURE)) - return; - - /* If we are reading, the variable will be changed. Note that - code->ext.dt may be NULL if the TRANSFER is related to - an INQUIRE statement -- but in this case, we are not reading, either. */ - if (dt && dt->dt_io_kind->value.iokind == M_READ - && !gfc_check_vardef_context (exp, false, false, false, - _("item in READ"))) - return; - - const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE - || exp->expr_type == EXPR_FUNCTION - ? &exp->ts : &exp->symtree->n.sym->ts; - - /* Go to actual component transferred. */ - for (ref = exp->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - ts = &ref->u.c.component->ts; - - if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE - && (ts->type == BT_DERIVED || ts->type == BT_CLASS)) - { - derived = ts->u.derived; - - /* Determine when to use the formatted DTIO procedure. */ - if (dt && (dt->format_expr || dt->format_label)) - formatted = true; - - write = dt->dt_io_kind->value.iokind == M_WRITE - || dt->dt_io_kind->value.iokind == M_PRINT; - dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted); - - if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE) - { - dt->udtio = exp; - sym = exp->symtree->n.sym->ns->proc_name; - /* Check to see if this is a nested DTIO call, with the - dummy as the io-list object. */ - if (sym && sym == dtio_sub && sym->formal - && sym->formal->sym == exp->symtree->n.sym - && exp->ref == NULL) - { - if (!sym->attr.recursive) - { - gfc_error ("DTIO %s procedure at %L must be recursive", - sym->name, &sym->declared_at); - return; - } - } - } - } - - if (ts->type == BT_CLASS && dtio_sub == NULL) - { - gfc_error ("Data transfer element at %L cannot be polymorphic unless " - "it is processed by a defined input/output procedure", - &code->loc); - return; - } - - if (ts->type == BT_DERIVED) - { - /* Check that transferred derived type doesn't contain POINTER - components unless it is processed by a defined input/output - procedure". */ - if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL) - { - gfc_error ("Data transfer element at %L cannot have POINTER " - "components unless it is processed by a defined " - "input/output procedure", &code->loc); - return; - } - - /* F08:C935. */ - if (ts->u.derived->attr.proc_pointer_comp) - { - gfc_error ("Data transfer element at %L cannot have " - "procedure pointer components", &code->loc); - return; - } - - if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL) - { - gfc_error ("Data transfer element at %L cannot have ALLOCATABLE " - "components unless it is processed by a defined " - "input/output procedure", &code->loc); - return; - } - - /* C_PTR and C_FUNPTR have private components which means they cannot - be printed. However, if -std=gnu and not -pedantic, allow - the component to be printed to help debugging. */ - if (ts->u.derived->ts.f90_type == BT_VOID) - { - if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L " - "cannot have PRIVATE components", &code->loc)) - return; - } - else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL) - { - gfc_error ("Data transfer element at %L cannot have " - "PRIVATE components unless it is processed by " - "a defined input/output procedure", &code->loc); - return; - } - } - - if (exp->expr_type == EXPR_STRUCTURE) - return; - - sym = exp->symtree->n.sym; - - if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref - && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL) - { - gfc_error ("Data transfer element at %L cannot be a full reference to " - "an assumed-size array", &code->loc); - return; - } -} - - -/*********** Toplevel code resolution subroutines ***********/ - -/* Find the set of labels that are reachable from this block. We also - record the last statement in each block. */ - -static void -find_reachable_labels (gfc_code *block) -{ - gfc_code *c; - - if (!block) - return; - - cs_base->reachable_labels = bitmap_alloc (&labels_obstack); - - /* Collect labels in this block. We don't keep those corresponding - to END {IF|SELECT}, these are checked in resolve_branch by going - up through the code_stack. */ - for (c = block; c; c = c->next) - { - if (c->here && c->op != EXEC_END_NESTED_BLOCK) - bitmap_set_bit (cs_base->reachable_labels, c->here->value); - } - - /* Merge with labels from parent block. */ - if (cs_base->prev) - { - gcc_assert (cs_base->prev->reachable_labels); - bitmap_ior_into (cs_base->reachable_labels, - cs_base->prev->reachable_labels); - } -} - - -static void -resolve_lock_unlock_event (gfc_code *code) -{ - if (code->expr1->expr_type == EXPR_FUNCTION - && code->expr1->value.function.isym - && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) - remove_caf_get_intrinsic (code->expr1); - - if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK) - && (code->expr1->ts.type != BT_DERIVED - || code->expr1->expr_type != EXPR_VARIABLE - || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE - || code->expr1->rank != 0 - || (!gfc_is_coarray (code->expr1) && - !gfc_is_coindexed (code->expr1)))) - gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", - &code->expr1->where); - else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT) - && (code->expr1->ts.type != BT_DERIVED - || code->expr1->expr_type != EXPR_VARIABLE - || code->expr1->ts.u.derived->from_intmod - != INTMOD_ISO_FORTRAN_ENV - || code->expr1->ts.u.derived->intmod_sym_id - != ISOFORTRAN_EVENT_TYPE - || code->expr1->rank != 0)) - gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE", - &code->expr1->where); - else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1) - && !gfc_is_coindexed (code->expr1)) - gfc_error ("Event variable argument at %L must be a coarray or coindexed", - &code->expr1->where); - else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1)) - gfc_error ("Event variable argument at %L must be a coarray but not " - "coindexed", &code->expr1->where); - - /* Check STAT. */ - if (code->expr2 - && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 - || code->expr2->expr_type != EXPR_VARIABLE)) - gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", - &code->expr2->where); - - if (code->expr2 - && !gfc_check_vardef_context (code->expr2, false, false, false, - _("STAT variable"))) - return; - - /* Check ERRMSG. */ - if (code->expr3 - && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 - || code->expr3->expr_type != EXPR_VARIABLE)) - gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", - &code->expr3->where); - - if (code->expr3 - && !gfc_check_vardef_context (code->expr3, false, false, false, - _("ERRMSG variable"))) - return; - - /* Check for LOCK the ACQUIRED_LOCK. */ - if (code->op != EXEC_EVENT_WAIT && code->expr4 - && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0 - || code->expr4->expr_type != EXPR_VARIABLE)) - gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL " - "variable", &code->expr4->where); - - if (code->op != EXEC_EVENT_WAIT && code->expr4 - && !gfc_check_vardef_context (code->expr4, false, false, false, - _("ACQUIRED_LOCK variable"))) - return; - - /* Check for EVENT WAIT the UNTIL_COUNT. */ - if (code->op == EXEC_EVENT_WAIT && code->expr4) - { - if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER - || code->expr4->rank != 0) - gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER " - "expression", &code->expr4->where); - } -} - - -static void -resolve_critical (gfc_code *code) -{ - gfc_symtree *symtree; - gfc_symbol *lock_type; - char name[GFC_MAX_SYMBOL_LEN]; - static int serial = 0; - - if (flag_coarray != GFC_FCOARRAY_LIB) - return; - - symtree = gfc_find_symtree (gfc_current_ns->sym_root, - GFC_PREFIX ("lock_type")); - if (symtree) - lock_type = symtree->n.sym; - else - { - if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree, - false) != 0) - gcc_unreachable (); - lock_type = symtree->n.sym; - lock_type->attr.flavor = FL_DERIVED; - lock_type->attr.zero_comp = 1; - lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV; - lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE; - } - - sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++); - if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0) - gcc_unreachable (); - - code->resolved_sym = symtree->n.sym; - symtree->n.sym->attr.flavor = FL_VARIABLE; - symtree->n.sym->attr.referenced = 1; - symtree->n.sym->attr.artificial = 1; - symtree->n.sym->attr.codimension = 1; - symtree->n.sym->ts.type = BT_DERIVED; - symtree->n.sym->ts.u.derived = lock_type; - symtree->n.sym->as = gfc_get_array_spec (); - symtree->n.sym->as->corank = 1; - symtree->n.sym->as->type = AS_EXPLICIT; - symtree->n.sym->as->cotype = AS_EXPLICIT; - symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, 1); - gfc_commit_symbols(); -} - - -static void -resolve_sync (gfc_code *code) -{ - /* Check imageset. The * case matches expr1 == NULL. */ - if (code->expr1) - { - if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1) - gfc_error ("Imageset argument at %L must be a scalar or rank-1 " - "INTEGER expression", &code->expr1->where); - if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0 - && mpz_cmp_si (code->expr1->value.integer, 1) < 0) - gfc_error ("Imageset argument at %L must between 1 and num_images()", - &code->expr1->where); - else if (code->expr1->expr_type == EXPR_ARRAY - && gfc_simplify_expr (code->expr1, 0)) - { - gfc_constructor *cons; - cons = gfc_constructor_first (code->expr1->value.constructor); - for (; cons; cons = gfc_constructor_next (cons)) - if (cons->expr->expr_type == EXPR_CONSTANT - && mpz_cmp_si (cons->expr->value.integer, 1) < 0) - gfc_error ("Imageset argument at %L must between 1 and " - "num_images()", &cons->expr->where); - } - } - - /* Check STAT. */ - gfc_resolve_expr (code->expr2); - if (code->expr2) - { - if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0) - gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", - &code->expr2->where); - else - gfc_check_vardef_context (code->expr2, false, false, false, - _("STAT variable")); - } - - /* Check ERRMSG. */ - gfc_resolve_expr (code->expr3); - if (code->expr3) - { - if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0) - gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", - &code->expr3->where); - else - gfc_check_vardef_context (code->expr3, false, false, false, - _("ERRMSG variable")); - } -} - - -/* Given a branch to a label, see if the branch is conforming. - The code node describes where the branch is located. */ - -static void -resolve_branch (gfc_st_label *label, gfc_code *code) -{ - code_stack *stack; - - if (label == NULL) - return; - - /* Step one: is this a valid branching target? */ - - if (label->defined == ST_LABEL_UNKNOWN) - { - gfc_error ("Label %d referenced at %L is never defined", label->value, - &code->loc); - return; - } - - if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) - { - gfc_error ("Statement at %L is not a valid branch target statement " - "for the branch statement at %L", &label->where, &code->loc); - return; - } - - /* Step two: make sure this branch is not a branch to itself ;-) */ - - if (code->here == label) - { - gfc_warning (0, - "Branch at %L may result in an infinite loop", &code->loc); - return; - } - - /* Step three: See if the label is in the same block as the - branching statement. The hard work has been done by setting up - the bitmap reachable_labels. */ - - if (bitmap_bit_p (cs_base->reachable_labels, label->value)) - { - /* Check now whether there is a CRITICAL construct; if so, check - whether the label is still visible outside of the CRITICAL block, - which is invalid. */ - for (stack = cs_base; stack; stack = stack->prev) - { - if (stack->current->op == EXEC_CRITICAL - && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves CRITICAL construct for " - "label at %L", &code->loc, &label->where); - else if (stack->current->op == EXEC_DO_CONCURRENT - && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " - "for label at %L", &code->loc, &label->where); - } - - return; - } - - /* Step four: If we haven't found the label in the bitmap, it may - still be the label of the END of the enclosing block, in which - case we find it by going up the code_stack. */ - - for (stack = cs_base; stack; stack = stack->prev) - { - if (stack->current->next && stack->current->next->here == label) - break; - if (stack->current->op == EXEC_CRITICAL) - { - /* Note: A label at END CRITICAL does not leave the CRITICAL - construct as END CRITICAL is still part of it. */ - gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" - " at %L", &code->loc, &label->where); - return; - } - else if (stack->current->op == EXEC_DO_CONCURRENT) - { - gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " - "label at %L", &code->loc, &label->where); - return; - } - } - - if (stack) - { - gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK); - return; - } - - /* The label is not in an enclosing block, so illegal. This was - allowed in Fortran 66, so we allow it as extension. No - further checks are necessary in this case. */ - gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block " - "as the GOTO statement at %L", &label->where, - &code->loc); - return; -} - - -/* Check whether EXPR1 has the same shape as EXPR2. */ - -static bool -resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) -{ - mpz_t shape[GFC_MAX_DIMENSIONS]; - mpz_t shape2[GFC_MAX_DIMENSIONS]; - bool result = false; - int i; - - /* Compare the rank. */ - if (expr1->rank != expr2->rank) - return result; - - /* Compare the size of each dimension. */ - for (i=0; irank; i++) - { - if (!gfc_array_dimen_size (expr1, i, &shape[i])) - goto ignore; - - if (!gfc_array_dimen_size (expr2, i, &shape2[i])) - goto ignore; - - if (mpz_cmp (shape[i], shape2[i])) - goto over; - } - - /* When either of the two expression is an assumed size array, we - ignore the comparison of dimension sizes. */ -ignore: - result = true; - -over: - gfc_clear_shape (shape, i); - gfc_clear_shape (shape2, i); - return result; -} - - -/* Check whether a WHERE assignment target or a WHERE mask expression - has the same shape as the outmost WHERE mask expression. */ - -static void -resolve_where (gfc_code *code, gfc_expr *mask) -{ - gfc_code *cblock; - gfc_code *cnext; - gfc_expr *e = NULL; - - cblock = code->block; - - /* Store the first WHERE mask-expr of the WHERE statement or construct. - In case of nested WHERE, only the outmost one is stored. */ - if (mask == NULL) /* outmost WHERE */ - e = cblock->expr1; - else /* inner WHERE */ - e = mask; - - while (cblock) - { - if (cblock->expr1) - { - /* Check if the mask-expr has a consistent shape with the - outmost WHERE mask-expr. */ - if (!resolve_where_shape (cblock->expr1, e)) - gfc_error ("WHERE mask at %L has inconsistent shape", - &cblock->expr1->where); - } - - /* the assignment statement of a WHERE statement, or the first - statement in where-body-construct of a WHERE construct */ - cnext = cblock->next; - while (cnext) - { - switch (cnext->op) - { - /* WHERE assignment statement */ - case EXEC_ASSIGN: - - /* Check shape consistent for WHERE assignment target. */ - if (e && !resolve_where_shape (cnext->expr1, e)) - gfc_error ("WHERE assignment target at %L has " - "inconsistent shape", &cnext->expr1->where); - break; - - - case EXEC_ASSIGN_CALL: - resolve_call (cnext); - if (!cnext->resolved_sym->attr.elemental) - gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", - &cnext->ext.actual->expr->where); - break; - - /* WHERE or WHERE construct is part of a where-body-construct */ - case EXEC_WHERE: - resolve_where (cnext, e); - break; - - default: - gfc_error ("Unsupported statement inside WHERE at %L", - &cnext->loc); - } - /* the next statement within the same where-body-construct */ - cnext = cnext->next; - } - /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ - cblock = cblock->block; - } -} - - -/* Resolve assignment in FORALL construct. - NVAR is the number of FORALL index variables, and VAR_EXPR records the - FORALL index variables. */ - -static void -gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) -{ - int n; - - for (n = 0; n < nvar; n++) - { - gfc_symbol *forall_index; - - forall_index = var_expr[n]->symtree->n.sym; - - /* Check whether the assignment target is one of the FORALL index - variable. */ - if ((code->expr1->expr_type == EXPR_VARIABLE) - && (code->expr1->symtree->n.sym == forall_index)) - gfc_error ("Assignment to a FORALL index variable at %L", - &code->expr1->where); - else - { - /* If one of the FORALL index variables doesn't appear in the - assignment variable, then there could be a many-to-one - assignment. Emit a warning rather than an error because the - mask could be resolving this problem. */ - if (!find_forall_index (code->expr1, forall_index, 0)) - gfc_warning (0, "The FORALL with index %qs is not used on the " - "left side of the assignment at %L and so might " - "cause multiple assignment to this object", - var_expr[n]->symtree->name, &code->expr1->where); - } - } -} - - -/* Resolve WHERE statement in FORALL construct. */ - -static void -gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, - gfc_expr **var_expr) -{ - gfc_code *cblock; - gfc_code *cnext; - - cblock = code->block; - while (cblock) - { - /* the assignment statement of a WHERE statement, or the first - statement in where-body-construct of a WHERE construct */ - cnext = cblock->next; - while (cnext) - { - switch (cnext->op) - { - /* WHERE assignment statement */ - case EXEC_ASSIGN: - gfc_resolve_assign_in_forall (cnext, nvar, var_expr); - break; - - /* WHERE operator assignment statement */ - case EXEC_ASSIGN_CALL: - resolve_call (cnext); - if (!cnext->resolved_sym->attr.elemental) - gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", - &cnext->ext.actual->expr->where); - break; - - /* WHERE or WHERE construct is part of a where-body-construct */ - case EXEC_WHERE: - gfc_resolve_where_code_in_forall (cnext, nvar, var_expr); - break; - - default: - gfc_error ("Unsupported statement inside WHERE at %L", - &cnext->loc); - } - /* the next statement within the same where-body-construct */ - cnext = cnext->next; - } - /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ - cblock = cblock->block; - } -} - - -/* Traverse the FORALL body to check whether the following errors exist: - 1. For assignment, check if a many-to-one assignment happens. - 2. For WHERE statement, check the WHERE body to see if there is any - many-to-one assignment. */ - -static void -gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) -{ - gfc_code *c; - - c = code->block->next; - while (c) - { - switch (c->op) - { - case EXEC_ASSIGN: - case EXEC_POINTER_ASSIGN: - gfc_resolve_assign_in_forall (c, nvar, var_expr); - break; - - case EXEC_ASSIGN_CALL: - resolve_call (c); - break; - - /* Because the gfc_resolve_blocks() will handle the nested FORALL, - there is no need to handle it here. */ - case EXEC_FORALL: - break; - case EXEC_WHERE: - gfc_resolve_where_code_in_forall(c, nvar, var_expr); - break; - default: - break; - } - /* The next statement in the FORALL body. */ - c = c->next; - } -} - - -/* Counts the number of iterators needed inside a forall construct, including - nested forall constructs. This is used to allocate the needed memory - in gfc_resolve_forall. */ - -static int -gfc_count_forall_iterators (gfc_code *code) -{ - int max_iters, sub_iters, current_iters; - gfc_forall_iterator *fa; - - gcc_assert(code->op == EXEC_FORALL); - max_iters = 0; - current_iters = 0; - - for (fa = code->ext.forall_iterator; fa; fa = fa->next) - current_iters ++; - - code = code->block->next; - - while (code) - { - if (code->op == EXEC_FORALL) - { - sub_iters = gfc_count_forall_iterators (code); - if (sub_iters > max_iters) - max_iters = sub_iters; - } - code = code->next; - } - - return current_iters + max_iters; -} - - -/* Given a FORALL construct, first resolve the FORALL iterator, then call - gfc_resolve_forall_body to resolve the FORALL body. */ - -static void -gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) -{ - static gfc_expr **var_expr; - static int total_var = 0; - static int nvar = 0; - int i, old_nvar, tmp; - gfc_forall_iterator *fa; - - old_nvar = nvar; - - if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) - return; - - /* Start to resolve a FORALL construct */ - if (forall_save == 0) - { - /* Count the total number of FORALL indices in the nested FORALL - construct in order to allocate the VAR_EXPR with proper size. */ - total_var = gfc_count_forall_iterators (code); - - /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */ - var_expr = XCNEWVEC (gfc_expr *, total_var); - } - - /* The information about FORALL iterator, including FORALL indices start, end - and stride. An outer FORALL indice cannot appear in start, end or stride. */ - for (fa = code->ext.forall_iterator; fa; fa = fa->next) - { - /* Fortran 20008: C738 (R753). */ - if (fa->var->ref && fa->var->ref->type == REF_ARRAY) - { - gfc_error ("FORALL index-name at %L must be a scalar variable " - "of type integer", &fa->var->where); - continue; - } - - /* Check if any outer FORALL index name is the same as the current - one. */ - for (i = 0; i < nvar; i++) - { - if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) - gfc_error ("An outer FORALL construct already has an index " - "with this name %L", &fa->var->where); - } - - /* Record the current FORALL index. */ - var_expr[nvar] = gfc_copy_expr (fa->var); - - nvar++; - - /* No memory leak. */ - gcc_assert (nvar <= total_var); - } - - /* Resolve the FORALL body. */ - gfc_resolve_forall_body (code, nvar, var_expr); - - /* May call gfc_resolve_forall to resolve the inner FORALL loop. */ - gfc_resolve_blocks (code->block, ns); - - tmp = nvar; - nvar = old_nvar; - /* Free only the VAR_EXPRs allocated in this frame. */ - for (i = nvar; i < tmp; i++) - gfc_free_expr (var_expr[i]); - - if (nvar == 0) - { - /* We are in the outermost FORALL construct. */ - gcc_assert (forall_save == 0); - - /* VAR_EXPR is not needed any more. */ - free (var_expr); - total_var = 0; - } -} - - -/* Resolve a BLOCK construct statement. */ - -static void -resolve_block_construct (gfc_code* code) -{ - /* Resolve the BLOCK's namespace. */ - gfc_resolve (code->ext.block.ns); - - /* For an ASSOCIATE block, the associations (and their targets) are already - resolved during resolve_symbol. */ -} - - -/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and - DO code nodes. */ - -void -gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) -{ - bool t; - - for (; b; b = b->block) - { - t = gfc_resolve_expr (b->expr1); - if (!gfc_resolve_expr (b->expr2)) - t = false; - - switch (b->op) - { - case EXEC_IF: - if (t && b->expr1 != NULL - && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) - gfc_error ("IF clause at %L requires a scalar LOGICAL expression", - &b->expr1->where); - break; - - case EXEC_WHERE: - if (t - && b->expr1 != NULL - && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0)) - gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array", - &b->expr1->where); - break; - - case EXEC_GOTO: - resolve_branch (b->label1, b); - break; - - case EXEC_BLOCK: - resolve_block_construct (b); - break; - - case EXEC_SELECT: - case EXEC_SELECT_TYPE: - case EXEC_SELECT_RANK: - case EXEC_FORALL: - case EXEC_DO: - case EXEC_DO_WHILE: - case EXEC_DO_CONCURRENT: - case EXEC_CRITICAL: - case EXEC_READ: - case EXEC_WRITE: - case EXEC_IOLENGTH: - case EXEC_WAIT: - break; - - case EXEC_OMP_ATOMIC: - case EXEC_OACC_ATOMIC: - { - /* Verify this before calling gfc_resolve_code, which might - change it. */ - gcc_assert (b->op == EXEC_OMP_ATOMIC - || (b->next && b->next->op == EXEC_ASSIGN)); - } - break; - - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OACC_ROUTINE: - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_ERROR: - case EXEC_OMP_LOOP: - case EXEC_OMP_MASKED: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_ORDERED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_WORKSHARE: - break; - - default: - gfc_internal_error ("gfc_resolve_blocks(): Bad block type"); - } - - gfc_resolve_code (b->next, ns); - } -} - - -/* Does everything to resolve an ordinary assignment. Returns true - if this is an interface assignment. */ -static bool -resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) -{ - bool rval = false; - gfc_expr *lhs; - gfc_expr *rhs; - int n; - gfc_ref *ref; - symbol_attribute attr; - - if (gfc_extend_assign (code, ns)) - { - gfc_expr** rhsptr; - - if (code->op == EXEC_ASSIGN_CALL) - { - lhs = code->ext.actual->expr; - rhsptr = &code->ext.actual->next->expr; - } - else - { - gfc_actual_arglist* args; - gfc_typebound_proc* tbp; - - gcc_assert (code->op == EXEC_COMPCALL); - - args = code->expr1->value.compcall.actual; - lhs = args->expr; - rhsptr = &args->next->expr; - - tbp = code->expr1->value.compcall.tbp; - gcc_assert (!tbp->is_generic); - } - - /* Make a temporary rhs when there is a default initializer - and rhs is the same symbol as the lhs. */ - if ((*rhsptr)->expr_type == EXPR_VARIABLE - && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED - && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) - && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) - *rhsptr = gfc_get_parentheses (*rhsptr); - - return true; - } - - lhs = code->expr1; - rhs = code->expr2; - - if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) - && rhs->ts.type == BT_CHARACTER - && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) - { - /* Use of -fdec-char-conversions allows assignment of character data - to non-character variables. This not permited for nonconstant - strings. */ - gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs), - gfc_typename (lhs), &rhs->where); - return false; - } - - /* Handle the case of a BOZ literal on the RHS. */ - if (rhs->ts.type == BT_BOZ) - { - if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA " - "statement value nor an actual argument of " - "INT/REAL/DBLE/CMPLX intrinsic subprogram", - &rhs->where)) - return false; - - switch (lhs->ts.type) - { - case BT_INTEGER: - if (!gfc_boz2int (rhs, lhs->ts.kind)) - return false; - break; - case BT_REAL: - if (!gfc_boz2real (rhs, lhs->ts.kind)) - return false; - break; - default: - gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where); - return false; - } - } - - if (lhs->ts.type == BT_CHARACTER && warn_character_truncation) - { - HOST_WIDE_INT llen = 0, rlen = 0; - if (lhs->ts.u.cl != NULL - && lhs->ts.u.cl->length != NULL - && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) - llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer); - - if (rhs->expr_type == EXPR_CONSTANT) - rlen = rhs->value.character.length; - - else if (rhs->ts.u.cl != NULL - && rhs->ts.u.cl->length != NULL - && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) - rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer); - - if (rlen && llen && rlen > llen) - gfc_warning_now (OPT_Wcharacter_truncation, - "CHARACTER expression will be truncated " - "in assignment (%ld/%ld) at %L", - (long) llen, (long) rlen, &code->loc); - } - - /* Ensure that a vector index expression for the lvalue is evaluated - to a temporary if the lvalue symbol is referenced in it. */ - if (lhs->rank) - { - for (ref = lhs->ref; ref; ref= ref->next) - if (ref->type == REF_ARRAY) - { - for (n = 0; n < ref->u.ar.dimen; n++) - if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR - && gfc_find_sym_in_expr (lhs->symtree->n.sym, - ref->u.ar.start[n])) - ref->u.ar.start[n] - = gfc_get_parentheses (ref->u.ar.start[n]); - } - } - - if (gfc_pure (NULL)) - { - if (lhs->ts.type == BT_DERIVED - && lhs->expr_type == EXPR_VARIABLE - && lhs->ts.u.derived->attr.pointer_comp - && rhs->expr_type == EXPR_VARIABLE - && (gfc_impure_variable (rhs->symtree->n.sym) - || gfc_is_coindexed (rhs))) - { - /* F2008, C1283. */ - if (gfc_is_coindexed (rhs)) - gfc_error ("Coindexed expression at %L is assigned to " - "a derived type variable with a POINTER " - "component in a PURE procedure", - &rhs->where); - else - /* F2008, C1283 (4). */ - gfc_error ("In a pure subprogram an INTENT(IN) dummy argument " - "shall not be used as the expr at %L of an intrinsic " - "assignment statement in which the variable is of a " - "derived type if the derived type has a pointer " - "component at any level of component selection.", - &rhs->where); - return rval; - } - - /* Fortran 2008, C1283. */ - if (gfc_is_coindexed (lhs)) - { - gfc_error ("Assignment to coindexed variable at %L in a PURE " - "procedure", &rhs->where); - return rval; - } - } - - if (gfc_implicit_pure (NULL)) - { - if (lhs->expr_type == EXPR_VARIABLE - && lhs->symtree->n.sym != gfc_current_ns->proc_name - && lhs->symtree->n.sym->ns != gfc_current_ns) - gfc_unset_implicit_pure (NULL); - - if (lhs->ts.type == BT_DERIVED - && lhs->expr_type == EXPR_VARIABLE - && lhs->ts.u.derived->attr.pointer_comp - && rhs->expr_type == EXPR_VARIABLE - && (gfc_impure_variable (rhs->symtree->n.sym) - || gfc_is_coindexed (rhs))) - gfc_unset_implicit_pure (NULL); - - /* Fortran 2008, C1283. */ - if (gfc_is_coindexed (lhs)) - gfc_unset_implicit_pure (NULL); - } - - /* F2008, 7.2.1.2. */ - attr = gfc_expr_attr (lhs); - if (lhs->ts.type == BT_CLASS && attr.allocatable) - { - if (attr.codimension) - { - gfc_error ("Assignment to polymorphic coarray at %L is not " - "permitted", &lhs->where); - return false; - } - if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable " - "polymorphic variable at %L", &lhs->where)) - return false; - if (!flag_realloc_lhs) - { - gfc_error ("Assignment to an allocatable polymorphic variable at %L " - "requires %<-frealloc-lhs%>", &lhs->where); - return false; - } - } - else if (lhs->ts.type == BT_CLASS) - { - gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic " - "assignment at %L - check that there is a matching specific " - "subroutine for '=' operator", &lhs->where); - return false; - } - - bool lhs_coindexed = gfc_is_coindexed (lhs); - - /* F2008, Section 7.2.1.2. */ - if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs)) - { - gfc_error ("Coindexed variable must not have an allocatable ultimate " - "component in assignment at %L", &lhs->where); - return false; - } - - /* Assign the 'data' of a class object to a derived type. */ - if (lhs->ts.type == BT_DERIVED - && rhs->ts.type == BT_CLASS - && rhs->expr_type != EXPR_ARRAY) - gfc_add_data_component (rhs); - - /* Make sure there is a vtable and, in particular, a _copy for the - rhs type. */ - if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS) - gfc_find_vtab (&rhs->ts); - - bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB - && (lhs_coindexed - || (code->expr2->expr_type == EXPR_FUNCTION - && code->expr2->value.function.isym - && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET - && (code->expr1->rank == 0 || code->expr2->rank != 0) - && !gfc_expr_attr (rhs).allocatable - && !gfc_has_vector_subscript (rhs))); - - gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send); - - /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable. - Additionally, insert this code when the RHS is a CAF as we then use the - GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if - the LHS is (re)allocatable or has a vector subscript. If the LHS is a - noncoindexed array and the RHS is a coindexed scalar, use the normal code - path. */ - if (caf_convert_to_send) - { - if (code->expr2->expr_type == EXPR_FUNCTION - && code->expr2->value.function.isym - && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET) - remove_caf_get_intrinsic (code->expr2); - code->op = EXEC_CALL; - gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true); - code->resolved_sym = code->symtree->n.sym; - code->resolved_sym->attr.flavor = FL_PROCEDURE; - code->resolved_sym->attr.intrinsic = 1; - code->resolved_sym->attr.subroutine = 1; - code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); - gfc_commit_symbol (code->resolved_sym); - code->ext.actual = gfc_get_actual_arglist (); - code->ext.actual->expr = lhs; - code->ext.actual->next = gfc_get_actual_arglist (); - code->ext.actual->next->expr = rhs; - code->expr1 = NULL; - code->expr2 = NULL; - } - - return false; -} - - -/* Add a component reference onto an expression. */ - -static void -add_comp_ref (gfc_expr *e, gfc_component *c) -{ - gfc_ref **ref; - ref = &(e->ref); - while (*ref) - ref = &((*ref)->next); - *ref = gfc_get_ref (); - (*ref)->type = REF_COMPONENT; - (*ref)->u.c.sym = e->ts.u.derived; - (*ref)->u.c.component = c; - e->ts = c->ts; - - /* Add a full array ref, as necessary. */ - if (c->as) - { - gfc_add_full_array_ref (e, c->as); - e->rank = c->as->rank; - } -} - - -/* Build an assignment. Keep the argument 'op' for future use, so that - pointer assignments can be made. */ - -static gfc_code * -build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, - gfc_component *comp1, gfc_component *comp2, locus loc) -{ - gfc_code *this_code; - - this_code = gfc_get_code (op); - this_code->next = NULL; - this_code->expr1 = gfc_copy_expr (expr1); - this_code->expr2 = gfc_copy_expr (expr2); - this_code->loc = loc; - if (comp1 && comp2) - { - add_comp_ref (this_code->expr1, comp1); - add_comp_ref (this_code->expr2, comp2); - } - - return this_code; -} - - -/* Makes a temporary variable expression based on the characteristics of - a given variable expression. */ - -static gfc_expr* -get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) -{ - static int serial = 0; - char name[GFC_MAX_SYMBOL_LEN]; - gfc_symtree *tmp; - gfc_array_spec *as; - gfc_array_ref *aref; - gfc_ref *ref; - - sprintf (name, GFC_PREFIX("DA%d"), serial++); - gfc_get_sym_tree (name, ns, &tmp, false); - gfc_add_type (tmp->n.sym, &e->ts, NULL); - - if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER) - tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, - e->value.character.length); - - as = NULL; - ref = NULL; - aref = NULL; - - /* Obtain the arrayspec for the temporary. */ - if (e->rank && e->expr_type != EXPR_ARRAY - && e->expr_type != EXPR_FUNCTION - && e->expr_type != EXPR_OP) - { - aref = gfc_find_array_ref (e); - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->as == aref->as) - as = aref->as; - else - { - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT - && ref->u.c.component->as == aref->as) - { - as = aref->as; - break; - } - } - } - - /* Add the attributes and the arrayspec to the temporary. */ - tmp->n.sym->attr = gfc_expr_attr (e); - tmp->n.sym->attr.function = 0; - tmp->n.sym->attr.proc_pointer = 0; - tmp->n.sym->attr.result = 0; - tmp->n.sym->attr.flavor = FL_VARIABLE; - tmp->n.sym->attr.dummy = 0; - tmp->n.sym->attr.use_assoc = 0; - tmp->n.sym->attr.intent = INTENT_UNKNOWN; - - if (as) - { - tmp->n.sym->as = gfc_copy_array_spec (as); - if (!ref) - ref = e->ref; - if (as->type == AS_DEFERRED) - tmp->n.sym->attr.allocatable = 1; - } - else if (e->rank && (e->expr_type == EXPR_ARRAY - || e->expr_type == EXPR_FUNCTION - || e->expr_type == EXPR_OP)) - { - tmp->n.sym->as = gfc_get_array_spec (); - tmp->n.sym->as->type = AS_DEFERRED; - tmp->n.sym->as->rank = e->rank; - tmp->n.sym->attr.allocatable = 1; - tmp->n.sym->attr.dimension = 1; - } - else - tmp->n.sym->attr.dimension = 0; - - gfc_set_sym_referenced (tmp->n.sym); - gfc_commit_symbol (tmp->n.sym); - e = gfc_lval_expr_from_sym (tmp->n.sym); - - /* Should the lhs be a section, use its array ref for the - temporary expression. */ - if (aref && aref->type != AR_FULL) - { - gfc_free_ref_list (e->ref); - e->ref = gfc_copy_ref (ref); - } - return e; -} - - -/* Add one line of code to the code chain, making sure that 'head' and - 'tail' are appropriately updated. */ - -static void -add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail) -{ - gcc_assert (this_code); - if (*head == NULL) - *head = *tail = *this_code; - else - *tail = gfc_append_code (*tail, *this_code); - *this_code = NULL; -} - - -/* Counts the potential number of part array references that would - result from resolution of typebound defined assignments. */ - -static int -nonscalar_typebound_assign (gfc_symbol *derived, int depth) -{ - gfc_component *c; - int c_depth = 0, t_depth; - - for (c= derived->components; c; c = c->next) - { - if ((!gfc_bt_struct (c->ts.type) - || c->attr.pointer - || c->attr.allocatable - || c->attr.proc_pointer_comp - || c->attr.class_pointer - || c->attr.proc_pointer) - && !c->attr.defined_assign_comp) - continue; - - if (c->as && c_depth == 0) - c_depth = 1; - - if (c->ts.u.derived->attr.defined_assign_comp) - t_depth = nonscalar_typebound_assign (c->ts.u.derived, - c->as ? 1 : 0); - else - t_depth = 0; - - c_depth = t_depth > c_depth ? t_depth : c_depth; - } - return depth + c_depth; -} - - -/* Implement 7.2.1.3 of the F08 standard: - "An intrinsic assignment where the variable is of derived type is - performed as if each component of the variable were assigned from the - corresponding component of expr using pointer assignment (7.2.2) for - each pointer component, defined assignment for each nonpointer - nonallocatable component of a type that has a type-bound defined - assignment consistent with the component, intrinsic assignment for - each other nonpointer nonallocatable component, ..." - - The pointer assignments are taken care of by the intrinsic - assignment of the structure itself. This function recursively adds - defined assignments where required. The recursion is accomplished - by calling gfc_resolve_code. - - When the lhs in a defined assignment has intent INOUT, we need a - temporary for the lhs. In pseudo-code: - - ! Only call function lhs once. - if (lhs is not a constant or an variable) - temp_x = expr2 - expr2 => temp_x - ! Do the intrinsic assignment - expr1 = expr2 - ! Now do the defined assignments - do over components with typebound defined assignment [%cmp] - #if one component's assignment procedure is INOUT - t1 = expr1 - #if expr2 non-variable - temp_x = expr2 - expr2 => temp_x - # endif - expr1 = expr2 - # for each cmp - t1%cmp {defined=} expr2%cmp - expr1%cmp = t1%cmp - #else - expr1 = expr2 - - # for each cmp - expr1%cmp {defined=} expr2%cmp - #endif - */ - -/* The temporary assignments have to be put on top of the additional - code to avoid the result being changed by the intrinsic assignment. - */ -static int component_assignment_level = 0; -static gfc_code *tmp_head = NULL, *tmp_tail = NULL; - -static void -generate_component_assignments (gfc_code **code, gfc_namespace *ns) -{ - gfc_component *comp1, *comp2; - gfc_code *this_code = NULL, *head = NULL, *tail = NULL; - gfc_expr *t1; - int error_count, depth; - - gfc_get_errors (NULL, &error_count); - - /* Filter out continuing processing after an error. */ - if (error_count - || (*code)->expr1->ts.type != BT_DERIVED - || (*code)->expr2->ts.type != BT_DERIVED) - return; - - /* TODO: Handle more than one part array reference in assignments. */ - depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived, - (*code)->expr1->rank ? 1 : 0); - if (depth > 1) - { - gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not " - "done because multiple part array references would " - "occur in intermediate expressions.", &(*code)->loc); - return; - } - - component_assignment_level++; - - /* Create a temporary so that functions get called only once. */ - if ((*code)->expr2->expr_type != EXPR_VARIABLE - && (*code)->expr2->expr_type != EXPR_CONSTANT) - { - gfc_expr *tmp_expr; - - /* Assign the rhs to the temporary. */ - tmp_expr = get_temp_from_expr ((*code)->expr1, ns); - this_code = build_assignment (EXEC_ASSIGN, - tmp_expr, (*code)->expr2, - NULL, NULL, (*code)->loc); - /* Add the code and substitute the rhs expression. */ - add_code_to_chain (&this_code, &tmp_head, &tmp_tail); - gfc_free_expr ((*code)->expr2); - (*code)->expr2 = tmp_expr; - } - - /* Do the intrinsic assignment. This is not needed if the lhs is one - of the temporaries generated here, since the intrinsic assignment - to the final result already does this. */ - if ((*code)->expr1->symtree->n.sym->name[2] != '@') - { - this_code = build_assignment (EXEC_ASSIGN, - (*code)->expr1, (*code)->expr2, - NULL, NULL, (*code)->loc); - add_code_to_chain (&this_code, &head, &tail); - } - - comp1 = (*code)->expr1->ts.u.derived->components; - comp2 = (*code)->expr2->ts.u.derived->components; - - t1 = NULL; - for (; comp1; comp1 = comp1->next, comp2 = comp2->next) - { - bool inout = false; - - /* The intrinsic assignment does the right thing for pointers - of all kinds and allocatable components. */ - if (!gfc_bt_struct (comp1->ts.type) - || comp1->attr.pointer - || comp1->attr.allocatable - || comp1->attr.proc_pointer_comp - || comp1->attr.class_pointer - || comp1->attr.proc_pointer) - continue; - - /* Make an assigment for this component. */ - this_code = build_assignment (EXEC_ASSIGN, - (*code)->expr1, (*code)->expr2, - comp1, comp2, (*code)->loc); - - /* Convert the assignment if there is a defined assignment for - this type. Otherwise, using the call from gfc_resolve_code, - recurse into its components. */ - gfc_resolve_code (this_code, ns); - - if (this_code->op == EXEC_ASSIGN_CALL) - { - gfc_formal_arglist *dummy_args; - gfc_symbol *rsym; - /* Check that there is a typebound defined assignment. If not, - then this must be a module defined assignment. We cannot - use the defined_assign_comp attribute here because it must - be this derived type that has the defined assignment and not - a parent type. */ - if (!(comp1->ts.u.derived->f2k_derived - && comp1->ts.u.derived->f2k_derived - ->tb_op[INTRINSIC_ASSIGN])) - { - gfc_free_statements (this_code); - this_code = NULL; - continue; - } - - /* If the first argument of the subroutine has intent INOUT - a temporary must be generated and used instead. */ - rsym = this_code->resolved_sym; - dummy_args = gfc_sym_get_dummy_args (rsym); - if (dummy_args - && dummy_args->sym->attr.intent == INTENT_INOUT) - { - gfc_code *temp_code; - inout = true; - - /* Build the temporary required for the assignment and put - it at the head of the generated code. */ - if (!t1) - { - t1 = get_temp_from_expr ((*code)->expr1, ns); - temp_code = build_assignment (EXEC_ASSIGN, - t1, (*code)->expr1, - NULL, NULL, (*code)->loc); - - /* For allocatable LHS, check whether it is allocated. Note - that allocatable components with defined assignment are - not yet support. See PR 57696. */ - if ((*code)->expr1->symtree->n.sym->attr.allocatable) - { - gfc_code *block; - gfc_expr *e = - gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); - block = gfc_get_code (EXEC_IF); - block->block = gfc_get_code (EXEC_IF); - block->block->expr1 - = gfc_build_intrinsic_call (ns, - GFC_ISYM_ALLOCATED, "allocated", - (*code)->loc, 1, e); - block->block->next = temp_code; - temp_code = block; - } - add_code_to_chain (&temp_code, &tmp_head, &tmp_tail); - } - - /* Replace the first actual arg with the component of the - temporary. */ - gfc_free_expr (this_code->ext.actual->expr); - this_code->ext.actual->expr = gfc_copy_expr (t1); - add_comp_ref (this_code->ext.actual->expr, comp1); - - /* If the LHS variable is allocatable and wasn't allocated and - the temporary is allocatable, pointer assign the address of - the freshly allocated LHS to the temporary. */ - if ((*code)->expr1->symtree->n.sym->attr.allocatable - && gfc_expr_attr ((*code)->expr1).allocatable) - { - gfc_code *block; - gfc_expr *cond; - - cond = gfc_get_expr (); - cond->ts.type = BT_LOGICAL; - cond->ts.kind = gfc_default_logical_kind; - cond->expr_type = EXPR_OP; - cond->where = (*code)->loc; - cond->value.op.op = INTRINSIC_NOT; - cond->value.op.op1 = gfc_build_intrinsic_call (ns, - GFC_ISYM_ALLOCATED, "allocated", - (*code)->loc, 1, gfc_copy_expr (t1)); - block = gfc_get_code (EXEC_IF); - block->block = gfc_get_code (EXEC_IF); - block->block->expr1 = cond; - block->block->next = build_assignment (EXEC_POINTER_ASSIGN, - t1, (*code)->expr1, - NULL, NULL, (*code)->loc); - add_code_to_chain (&block, &head, &tail); - } - } - } - else if (this_code->op == EXEC_ASSIGN && !this_code->next) - { - /* Don't add intrinsic assignments since they are already - effected by the intrinsic assignment of the structure. */ - gfc_free_statements (this_code); - this_code = NULL; - continue; - } - - add_code_to_chain (&this_code, &head, &tail); - - if (t1 && inout) - { - /* Transfer the value to the final result. */ - this_code = build_assignment (EXEC_ASSIGN, - (*code)->expr1, t1, - comp1, comp2, (*code)->loc); - add_code_to_chain (&this_code, &head, &tail); - } - } - - /* Put the temporary assignments at the top of the generated code. */ - if (tmp_head && component_assignment_level == 1) - { - gfc_append_code (tmp_head, head); - head = tmp_head; - tmp_head = tmp_tail = NULL; - } - - // If we did a pointer assignment - thus, we need to ensure that the LHS is - // not accidentally deallocated. Hence, nullify t1. - if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable - && gfc_expr_attr ((*code)->expr1).allocatable) - { - gfc_code *block; - gfc_expr *cond; - gfc_expr *e; - - e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); - cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated", - (*code)->loc, 2, gfc_copy_expr (t1), e); - block = gfc_get_code (EXEC_IF); - block->block = gfc_get_code (EXEC_IF); - block->block->expr1 = cond; - block->block->next = build_assignment (EXEC_POINTER_ASSIGN, - t1, gfc_get_null_expr (&(*code)->loc), - NULL, NULL, (*code)->loc); - gfc_append_code (tail, block); - tail = block; - } - - /* Now attach the remaining code chain to the input code. Step on - to the end of the new code since resolution is complete. */ - gcc_assert ((*code)->op == EXEC_ASSIGN); - tail->next = (*code)->next; - /* Overwrite 'code' because this would place the intrinsic assignment - before the temporary for the lhs is created. */ - gfc_free_expr ((*code)->expr1); - gfc_free_expr ((*code)->expr2); - **code = *head; - if (head != tail) - free (head); - *code = tail; - - component_assignment_level--; -} - - -/* F2008: Pointer function assignments are of the form: - ptr_fcn (args) = expr - This function breaks these assignments into two statements: - temporary_pointer => ptr_fcn(args) - temporary_pointer = expr */ - -static bool -resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns) -{ - gfc_expr *tmp_ptr_expr; - gfc_code *this_code; - gfc_component *comp; - gfc_symbol *s; - - if ((*code)->expr1->expr_type != EXPR_FUNCTION) - return false; - - /* Even if standard does not support this feature, continue to build - the two statements to avoid upsetting frontend_passes.c. */ - gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at " - "%L", &(*code)->loc); - - comp = gfc_get_proc_ptr_comp ((*code)->expr1); - - if (comp) - s = comp->ts.interface; - else - s = (*code)->expr1->symtree->n.sym; - - if (s == NULL || !s->result->attr.pointer) - { - gfc_error ("The function result on the lhs of the assignment at " - "%L must have the pointer attribute.", - &(*code)->expr1->where); - (*code)->op = EXEC_NOP; - return false; - } - - tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns); - - /* get_temp_from_expression is set up for ordinary assignments. To that - end, where array bounds are not known, arrays are made allocatable. - Change the temporary to a pointer here. */ - tmp_ptr_expr->symtree->n.sym->attr.pointer = 1; - tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0; - tmp_ptr_expr->where = (*code)->loc; - - this_code = build_assignment (EXEC_ASSIGN, - tmp_ptr_expr, (*code)->expr2, - NULL, NULL, (*code)->loc); - this_code->next = (*code)->next; - (*code)->next = this_code; - (*code)->op = EXEC_POINTER_ASSIGN; - (*code)->expr2 = (*code)->expr1; - (*code)->expr1 = tmp_ptr_expr; - - return true; -} - - -/* Deferred character length assignments from an operator expression - require a temporary because the character length of the lhs can - change in the course of the assignment. */ - -static bool -deferred_op_assign (gfc_code **code, gfc_namespace *ns) -{ - gfc_expr *tmp_expr; - gfc_code *this_code; - - if (!((*code)->expr1->ts.type == BT_CHARACTER - && (*code)->expr1->ts.deferred && (*code)->expr1->rank - && (*code)->expr2->expr_type == EXPR_OP)) - return false; - - if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1)) - return false; - - if (gfc_expr_attr ((*code)->expr1).pointer) - return false; - - tmp_expr = get_temp_from_expr ((*code)->expr1, ns); - tmp_expr->where = (*code)->loc; - - /* A new charlen is required to ensure that the variable string - length is different to that of the original lhs. */ - tmp_expr->ts.u.cl = gfc_get_charlen(); - tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl; - tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next; - (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl; - - tmp_expr->symtree->n.sym->ts.deferred = 1; - - this_code = build_assignment (EXEC_ASSIGN, - (*code)->expr1, - gfc_copy_expr (tmp_expr), - NULL, NULL, (*code)->loc); - - (*code)->expr1 = tmp_expr; - - this_code->next = (*code)->next; - (*code)->next = this_code; - - return true; -} - - -/* Given a block of code, recursively resolve everything pointed to by this - code block. */ - -void -gfc_resolve_code (gfc_code *code, gfc_namespace *ns) -{ - int omp_workshare_save; - int forall_save, do_concurrent_save; - code_stack frame; - bool t; - - frame.prev = cs_base; - frame.head = code; - cs_base = &frame; - - find_reachable_labels (code); - - for (; code; code = code->next) - { - frame.current = code; - forall_save = forall_flag; - do_concurrent_save = gfc_do_concurrent_flag; - - if (code->op == EXEC_FORALL) - { - forall_flag = 1; - gfc_resolve_forall (code, ns, forall_save); - forall_flag = 2; - } - else if (code->block) - { - omp_workshare_save = -1; - switch (code->op) - { - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - gfc_resolve_oacc_blocks (code, ns); - break; - case EXEC_OMP_PARALLEL_WORKSHARE: - omp_workshare_save = omp_workshare_flag; - omp_workshare_flag = 1; - gfc_resolve_omp_parallel_blocks (code, ns); - break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - omp_workshare_save = omp_workshare_flag; - omp_workshare_flag = 0; - gfc_resolve_omp_parallel_blocks (code, ns); - break; - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_SIMD: - case EXEC_OMP_TARGET_SIMD: - gfc_resolve_omp_do_blocks (code, ns); - break; - case EXEC_SELECT_TYPE: - case EXEC_SELECT_RANK: - /* Blocks are handled in resolve_select_type/rank because we - have to transform the SELECT TYPE into ASSOCIATE first. */ - break; - case EXEC_DO_CONCURRENT: - gfc_do_concurrent_flag = 1; - gfc_resolve_blocks (code->block, ns); - gfc_do_concurrent_flag = 2; - break; - case EXEC_OMP_WORKSHARE: - omp_workshare_save = omp_workshare_flag; - omp_workshare_flag = 1; - /* FALL THROUGH */ - default: - gfc_resolve_blocks (code->block, ns); - break; - } - - if (omp_workshare_save != -1) - omp_workshare_flag = omp_workshare_save; - } -start: - t = true; - if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) - t = gfc_resolve_expr (code->expr1); - forall_flag = forall_save; - gfc_do_concurrent_flag = do_concurrent_save; - - if (!gfc_resolve_expr (code->expr2)) - t = false; - - if (code->op == EXEC_ALLOCATE - && !gfc_resolve_expr (code->expr3)) - t = false; - - switch (code->op) - { - case EXEC_NOP: - case EXEC_END_BLOCK: - case EXEC_END_NESTED_BLOCK: - case EXEC_CYCLE: - case EXEC_PAUSE: - case EXEC_STOP: - case EXEC_ERROR_STOP: - case EXEC_EXIT: - case EXEC_CONTINUE: - case EXEC_DT_END: - case EXEC_ASSIGN_CALL: - break; - - case EXEC_CRITICAL: - resolve_critical (code); - break; - - case EXEC_SYNC_ALL: - case EXEC_SYNC_IMAGES: - case EXEC_SYNC_MEMORY: - resolve_sync (code); - break; - - case EXEC_LOCK: - case EXEC_UNLOCK: - case EXEC_EVENT_POST: - case EXEC_EVENT_WAIT: - resolve_lock_unlock_event (code); - break; - - case EXEC_FAIL_IMAGE: - case EXEC_FORM_TEAM: - case EXEC_CHANGE_TEAM: - case EXEC_END_TEAM: - case EXEC_SYNC_TEAM: - break; - - case EXEC_ENTRY: - /* Keep track of which entry we are up to. */ - current_entry_id = code->ext.entry->id; - break; - - case EXEC_WHERE: - resolve_where (code, NULL); - break; - - case EXEC_GOTO: - if (code->expr1 != NULL) - { - if (code->expr1->expr_type != EXPR_VARIABLE - || code->expr1->ts.type != BT_INTEGER - || (code->expr1->ref - && code->expr1->ref->type == REF_ARRAY) - || code->expr1->symtree == NULL - || (code->expr1->symtree->n.sym - && (code->expr1->symtree->n.sym->attr.flavor - == FL_PARAMETER))) - gfc_error ("ASSIGNED GOTO statement at %L requires a " - "scalar INTEGER variable", &code->expr1->where); - else if (code->expr1->symtree->n.sym - && code->expr1->symtree->n.sym->attr.assign != 1) - gfc_error ("Variable %qs has not been assigned a target " - "label at %L", code->expr1->symtree->n.sym->name, - &code->expr1->where); - } - else - resolve_branch (code->label1, code); - break; - - case EXEC_RETURN: - if (code->expr1 != NULL - && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) - gfc_error ("Alternate RETURN statement at %L requires a SCALAR-" - "INTEGER return specifier", &code->expr1->where); - break; - - case EXEC_INIT_ASSIGN: - case EXEC_END_PROCEDURE: - break; - - case EXEC_ASSIGN: - if (!t) - break; - - if (code->expr1->ts.type == BT_CLASS) - gfc_find_vtab (&code->expr2->ts); - - /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on - the LHS. */ - if (code->expr1->expr_type == EXPR_FUNCTION - && code->expr1->value.function.isym - && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) - remove_caf_get_intrinsic (code->expr1); - - /* If this is a pointer function in an lvalue variable context, - the new code will have to be resolved afresh. This is also the - case with an error, where the code is transformed into NOP to - prevent ICEs downstream. */ - if (resolve_ptr_fcn_assign (&code, ns) - || code->op == EXEC_NOP) - goto start; - - if (!gfc_check_vardef_context (code->expr1, false, false, false, - _("assignment"))) - break; - - if (resolve_ordinary_assign (code, ns)) - { - if (omp_workshare_flag) - { - gfc_error ("Expected intrinsic assignment in OMP WORKSHARE " - "at %L", &code->loc); - break; - } - if (code->op == EXEC_COMPCALL) - goto compcall; - else - goto call; - } - - /* Check for dependencies in deferred character length array - assignments and generate a temporary, if necessary. */ - if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns)) - break; - - /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ - if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED - && code->expr1->ts.u.derived - && code->expr1->ts.u.derived->attr.defined_assign_comp) - generate_component_assignments (&code, ns); - - break; - - case EXEC_LABEL_ASSIGN: - if (code->label1->defined == ST_LABEL_UNKNOWN) - gfc_error ("Label %d referenced at %L is never defined", - code->label1->value, &code->label1->where); - if (t - && (code->expr1->expr_type != EXPR_VARIABLE - || code->expr1->symtree->n.sym->ts.type != BT_INTEGER - || code->expr1->symtree->n.sym->ts.kind - != gfc_default_integer_kind - || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER - || code->expr1->symtree->n.sym->as != NULL)) - gfc_error ("ASSIGN statement at %L requires a scalar " - "default INTEGER variable", &code->expr1->where); - break; - - case EXEC_POINTER_ASSIGN: - { - gfc_expr* e; - - if (!t) - break; - - /* This is both a variable definition and pointer assignment - context, so check both of them. For rank remapping, a final - array ref may be present on the LHS and fool gfc_expr_attr - used in gfc_check_vardef_context. Remove it. */ - e = remove_last_array_ref (code->expr1); - t = gfc_check_vardef_context (e, true, false, false, - _("pointer assignment")); - if (t) - t = gfc_check_vardef_context (e, false, false, false, - _("pointer assignment")); - gfc_free_expr (e); - - t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t; - - if (!t) - break; - - /* Assigning a class object always is a regular assign. */ - if (code->expr2->ts.type == BT_CLASS - && code->expr1->ts.type == BT_CLASS - && CLASS_DATA (code->expr2) - && !CLASS_DATA (code->expr2)->attr.dimension - && !(gfc_expr_attr (code->expr1).proc_pointer - && code->expr2->expr_type == EXPR_VARIABLE - && code->expr2->symtree->n.sym->attr.flavor - == FL_PROCEDURE)) - code->op = EXEC_ASSIGN; - break; - } - - case EXEC_ARITHMETIC_IF: - { - gfc_expr *e = code->expr1; - - gfc_resolve_expr (e); - if (e->expr_type == EXPR_NULL) - gfc_error ("Invalid NULL at %L", &e->where); - - if (t && (e->rank > 0 - || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER))) - gfc_error ("Arithmetic IF statement at %L requires a scalar " - "REAL or INTEGER expression", &e->where); - - resolve_branch (code->label1, code); - resolve_branch (code->label2, code); - resolve_branch (code->label3, code); - } - break; - - case EXEC_IF: - if (t && code->expr1 != NULL - && (code->expr1->ts.type != BT_LOGICAL - || code->expr1->rank != 0)) - gfc_error ("IF clause at %L requires a scalar LOGICAL expression", - &code->expr1->where); - break; - - case EXEC_CALL: - call: - resolve_call (code); - break; - - case EXEC_COMPCALL: - compcall: - resolve_typebound_subroutine (code); - break; - - case EXEC_CALL_PPC: - resolve_ppc_call (code); - break; - - case EXEC_SELECT: - /* Select is complicated. Also, a SELECT construct could be - a transformed computed GOTO. */ - resolve_select (code, false); - break; - - case EXEC_SELECT_TYPE: - resolve_select_type (code, ns); - break; - - case EXEC_SELECT_RANK: - resolve_select_rank (code, ns); - break; - - case EXEC_BLOCK: - resolve_block_construct (code); - break; - - case EXEC_DO: - if (code->ext.iterator != NULL) - { - gfc_iterator *iter = code->ext.iterator; - if (gfc_resolve_iterator (iter, true, false)) - gfc_resolve_do_iterator (code, iter->var->symtree->n.sym, - true); - } - break; - - case EXEC_DO_WHILE: - if (code->expr1 == NULL) - gfc_internal_error ("gfc_resolve_code(): No expression on " - "DO WHILE"); - if (t - && (code->expr1->rank != 0 - || code->expr1->ts.type != BT_LOGICAL)) - gfc_error ("Exit condition of DO WHILE loop at %L must be " - "a scalar LOGICAL expression", &code->expr1->where); - break; - - case EXEC_ALLOCATE: - if (t) - resolve_allocate_deallocate (code, "ALLOCATE"); - - break; - - case EXEC_DEALLOCATE: - if (t) - resolve_allocate_deallocate (code, "DEALLOCATE"); - - break; - - case EXEC_OPEN: - if (!gfc_resolve_open (code->ext.open, &code->loc)) - break; - - resolve_branch (code->ext.open->err, code); - break; - - case EXEC_CLOSE: - if (!gfc_resolve_close (code->ext.close, &code->loc)) - break; - - resolve_branch (code->ext.close->err, code); - break; - - case EXEC_BACKSPACE: - case EXEC_ENDFILE: - case EXEC_REWIND: - case EXEC_FLUSH: - if (!gfc_resolve_filepos (code->ext.filepos, &code->loc)) - break; - - resolve_branch (code->ext.filepos->err, code); - break; - - case EXEC_INQUIRE: - if (!gfc_resolve_inquire (code->ext.inquire)) - break; - - resolve_branch (code->ext.inquire->err, code); - break; - - case EXEC_IOLENGTH: - gcc_assert (code->ext.inquire != NULL); - if (!gfc_resolve_inquire (code->ext.inquire)) - break; - - resolve_branch (code->ext.inquire->err, code); - break; - - case EXEC_WAIT: - if (!gfc_resolve_wait (code->ext.wait)) - break; - - resolve_branch (code->ext.wait->err, code); - resolve_branch (code->ext.wait->end, code); - resolve_branch (code->ext.wait->eor, code); - break; - - case EXEC_READ: - case EXEC_WRITE: - if (!gfc_resolve_dt (code, code->ext.dt, &code->loc)) - break; - - resolve_branch (code->ext.dt->err, code); - resolve_branch (code->ext.dt->end, code); - resolve_branch (code->ext.dt->eor, code); - break; - - case EXEC_TRANSFER: - resolve_transfer (code); - break; - - case EXEC_DO_CONCURRENT: - case EXEC_FORALL: - resolve_forall_iterators (code->ext.forall_iterator); - - if (code->expr1 != NULL - && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank)) - gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL " - "expression", &code->expr1->where); - break; - - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OACC_ATOMIC: - case EXEC_OACC_DECLARE: - gfc_resolve_oacc_directive (code, ns); - break; - - case EXEC_OMP_ATOMIC: - case EXEC_OMP_BARRIER: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_CRITICAL: - case EXEC_OMP_FLUSH: - case EXEC_OMP_DEPOBJ: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_ERROR: - case EXEC_OMP_LOOP: - case EXEC_OMP_MASTER: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_MASKED: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_ORDERED: - case EXEC_OMP_SCAN: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_WORKSHARE: - gfc_resolve_omp_directive (code, ns); - break; - - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - omp_workshare_save = omp_workshare_flag; - omp_workshare_flag = 0; - gfc_resolve_omp_directive (code, ns); - omp_workshare_flag = omp_workshare_save; - break; - - default: - gfc_internal_error ("gfc_resolve_code(): Bad statement code"); - } - } - - cs_base = frame.prev; -} - - -/* Resolve initial values and make sure they are compatible with - the variable. */ - -static void -resolve_values (gfc_symbol *sym) -{ - bool t; - - if (sym->value == NULL) - return; - - if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced) - gfc_warning (OPT_Wdeprecated_declarations, - "Using parameter %qs declared at %L is deprecated", - sym->name, &sym->declared_at); - - if (sym->value->expr_type == EXPR_STRUCTURE) - t= resolve_structure_cons (sym->value, 1); - else - t = gfc_resolve_expr (sym->value); - - if (!t) - return; - - gfc_check_assign_symbol (sym, NULL, sym->value); -} - - -/* Verify any BIND(C) derived types in the namespace so we can report errors - for them once, rather than for each variable declared of that type. */ - -static void -resolve_bind_c_derived_types (gfc_symbol *derived_sym) -{ - if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED - && derived_sym->attr.is_bind_c == 1) - verify_bind_c_derived_type (derived_sym); - - return; -} - - -/* Check the interfaces of DTIO procedures associated with derived - type 'sym'. These procedures can either have typebound bindings or - can appear in DTIO generic interfaces. */ - -static void -gfc_verify_DTIO_procedures (gfc_symbol *sym) -{ - if (!sym || sym->attr.flavor != FL_DERIVED) - return; - - gfc_check_dtio_interfaces (sym); - - return; -} - -/* Verify that any binding labels used in a given namespace do not collide - with the names or binding labels of any global symbols. Multiple INTERFACE - for the same procedure are permitted. */ - -static void -gfc_verify_binding_labels (gfc_symbol *sym) -{ - gfc_gsymbol *gsym; - const char *module; - - if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c - || sym->attr.flavor == FL_DERIVED || !sym->binding_label) - return; - - gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label); - - if (sym->module) - module = sym->module; - else if (sym->ns && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE) - module = sym->ns->proc_name->name; - else if (sym->ns && sym->ns->parent - && sym->ns && sym->ns->parent->proc_name - && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) - module = sym->ns->parent->proc_name->name; - else - module = NULL; - - if (!gsym - || (!gsym->defined - && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE))) - { - if (!gsym) - gsym = gfc_get_gsymbol (sym->binding_label, true); - gsym->where = sym->declared_at; - gsym->sym_name = sym->name; - gsym->binding_label = sym->binding_label; - gsym->ns = sym->ns; - gsym->mod_name = module; - if (sym->attr.function) - gsym->type = GSYM_FUNCTION; - else if (sym->attr.subroutine) - gsym->type = GSYM_SUBROUTINE; - /* Mark as variable/procedure as defined, unless its an INTERFACE. */ - gsym->defined = sym->attr.if_source != IFSRC_IFBODY; - return; - } - - if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) - { - gfc_error ("Variable %qs with binding label %qs at %L uses the same global " - "identifier as entity at %L", sym->name, - sym->binding_label, &sym->declared_at, &gsym->where); - /* Clear the binding label to prevent checking multiple times. */ - sym->binding_label = NULL; - return; - } - - if (sym->attr.flavor == FL_VARIABLE && module - && (strcmp (module, gsym->mod_name) != 0 - || strcmp (sym->name, gsym->sym_name) != 0)) - { - /* This can only happen if the variable is defined in a module - if it - isn't the same module, reject it. */ - gfc_error ("Variable %qs from module %qs with binding label %qs at %L " - "uses the same global identifier as entity at %L from module %qs", - sym->name, module, sym->binding_label, - &sym->declared_at, &gsym->where, gsym->mod_name); - sym->binding_label = NULL; - return; - } - - if ((sym->attr.function || sym->attr.subroutine) - && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION) - || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY)) - && (sym != gsym->ns->proc_name && sym->attr.entry == 0) - && (module != gsym->mod_name - || strcmp (gsym->sym_name, sym->name) != 0 - || (module && strcmp (module, gsym->mod_name) != 0))) - { - /* Print an error if the procedure is defined multiple times; we have to - exclude references to the same procedure via module association or - multiple checks for the same procedure. */ - gfc_error ("Procedure %qs with binding label %qs at %L uses the same " - "global identifier as entity at %L", sym->name, - sym->binding_label, &sym->declared_at, &gsym->where); - sym->binding_label = NULL; - } -} - - -/* Resolve an index expression. */ - -static bool -resolve_index_expr (gfc_expr *e) -{ - if (!gfc_resolve_expr (e)) - return false; - - if (!gfc_simplify_expr (e, 0)) - return false; - - if (!gfc_specification_expr (e)) - return false; - - return true; -} - - -/* Resolve a charlen structure. */ - -static bool -resolve_charlen (gfc_charlen *cl) -{ - int k; - bool saved_specification_expr; - - if (cl->resolved) - return true; - - cl->resolved = 1; - saved_specification_expr = specification_expr; - specification_expr = true; - - if (cl->length_from_typespec) - { - if (!gfc_resolve_expr (cl->length)) - { - specification_expr = saved_specification_expr; - return false; - } - - if (!gfc_simplify_expr (cl->length, 0)) - { - specification_expr = saved_specification_expr; - return false; - } - - /* cl->length has been resolved. It should have an integer type. */ - if (cl->length - && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0)) - { - gfc_error ("Scalar INTEGER expression expected at %L", - &cl->length->where); - return false; - } - } - else - { - if (!resolve_index_expr (cl->length)) - { - specification_expr = saved_specification_expr; - return false; - } - } - - /* F2008, 4.4.3.2: If the character length parameter value evaluates to - a negative value, the length of character entities declared is zero. */ - if (cl->length && cl->length->expr_type == EXPR_CONSTANT - && mpz_sgn (cl->length->value.integer) < 0) - gfc_replace_expr (cl->length, - gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0)); - - /* Check that the character length is not too large. */ - k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); - if (cl->length && cl->length->expr_type == EXPR_CONSTANT - && cl->length->ts.type == BT_INTEGER - && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0) - { - gfc_error ("String length at %L is too large", &cl->length->where); - specification_expr = saved_specification_expr; - return false; - } - - specification_expr = saved_specification_expr; - return true; -} - - -/* Test for non-constant shape arrays. */ - -static bool -is_non_constant_shape_array (gfc_symbol *sym) -{ - gfc_expr *e; - int i; - bool not_constant; - - not_constant = false; - if (sym->as != NULL) - { - /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that - has not been simplified; parameter array references. Do the - simplification now. */ - for (i = 0; i < sym->as->rank + sym->as->corank; i++) - { - if (i == GFC_MAX_DIMENSIONS) - break; - - e = sym->as->lower[i]; - if (e && (!resolve_index_expr(e) - || !gfc_is_constant_expr (e))) - not_constant = true; - e = sym->as->upper[i]; - if (e && (!resolve_index_expr(e) - || !gfc_is_constant_expr (e))) - not_constant = true; - } - } - return not_constant; -} - -/* Given a symbol and an initialization expression, add code to initialize - the symbol to the function entry. */ -static void -build_init_assign (gfc_symbol *sym, gfc_expr *init) -{ - gfc_expr *lval; - gfc_code *init_st; - gfc_namespace *ns = sym->ns; - - /* Search for the function namespace if this is a contained - function without an explicit result. */ - if (sym->attr.function && sym == sym->result - && sym->name != sym->ns->proc_name->name) - { - ns = ns->contained; - for (;ns; ns = ns->sibling) - if (strcmp (ns->proc_name->name, sym->name) == 0) - break; - } - - if (ns == NULL) - { - gfc_free_expr (init); - return; - } - - /* Build an l-value expression for the result. */ - lval = gfc_lval_expr_from_sym (sym); - - /* Add the code at scope entry. */ - init_st = gfc_get_code (EXEC_INIT_ASSIGN); - init_st->next = ns->code; - ns->code = init_st; - - /* Assign the default initializer to the l-value. */ - init_st->loc = sym->declared_at; - init_st->expr1 = lval; - init_st->expr2 = init; -} - - -/* Whether or not we can generate a default initializer for a symbol. */ - -static bool -can_generate_init (gfc_symbol *sym) -{ - symbol_attribute *a; - if (!sym) - return false; - a = &sym->attr; - - /* These symbols should never have a default initialization. */ - return !( - a->allocatable - || a->external - || a->pointer - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) - && (CLASS_DATA (sym)->attr.class_pointer - || CLASS_DATA (sym)->attr.proc_pointer)) - || a->in_equivalence - || a->in_common - || a->data - || sym->module - || a->cray_pointee - || a->cray_pointer - || sym->assoc - || (!a->referenced && !a->result) - || (a->dummy && (a->intent != INTENT_OUT - || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)) - || (a->function && sym != sym->result) - ); -} - - -/* Assign the default initializer to a derived type variable or result. */ - -static void -apply_default_init (gfc_symbol *sym) -{ - gfc_expr *init = NULL; - - if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function) - return; - - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) - init = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); - - if (init == NULL && sym->ts.type != BT_CLASS) - return; - - build_init_assign (sym, init); - sym->attr.referenced = 1; -} - - -/* Build an initializer for a local. Returns null if the symbol should not have - a default initialization. */ - -static gfc_expr * -build_default_init_expr (gfc_symbol *sym) -{ - /* These symbols should never have a default initialization. */ - if (sym->attr.allocatable - || sym->attr.external - || sym->attr.dummy - || sym->attr.pointer - || sym->attr.in_equivalence - || sym->attr.in_common - || sym->attr.data - || sym->module - || sym->attr.cray_pointee - || sym->attr.cray_pointer - || sym->assoc) - return NULL; - - /* Get the appropriate init expression. */ - return gfc_build_default_init_expr (&sym->ts, &sym->declared_at); -} - -/* Add an initialization expression to a local variable. */ -static void -apply_default_init_local (gfc_symbol *sym) -{ - gfc_expr *init = NULL; - - /* The symbol should be a variable or a function return value. */ - if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function) - || (sym->attr.function && sym->result != sym)) - return; - - /* Try to build the initializer expression. If we can't initialize - this symbol, then init will be NULL. */ - init = build_default_init_expr (sym); - if (init == NULL) - return; - - /* For saved variables, we don't want to add an initializer at function - entry, so we just add a static initializer. Note that automatic variables - are stack allocated even with -fno-automatic; we have also to exclude - result variable, which are also nonstatic. */ - if (!sym->attr.automatic - && (sym->attr.save || sym->ns->save_all - || (flag_max_stack_var_size == 0 && !sym->attr.result - && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive) - && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))) - { - /* Don't clobber an existing initializer! */ - gcc_assert (sym->value == NULL); - sym->value = init; - return; - } - - build_init_assign (sym, init); -} - - -/* Resolution of common features of flavors variable and procedure. */ - -static bool -resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) -{ - gfc_array_spec *as; - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym)) - as = CLASS_DATA (sym)->as; - else - as = sym->as; - - /* Constraints on deferred shape variable. */ - if (as == NULL || as->type != AS_DEFERRED) - { - bool pointer, allocatable, dimension; - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym)) - { - pointer = CLASS_DATA (sym)->attr.class_pointer; - allocatable = CLASS_DATA (sym)->attr.allocatable; - dimension = CLASS_DATA (sym)->attr.dimension; - } - else - { - pointer = sym->attr.pointer && !sym->attr.select_type_temporary; - allocatable = sym->attr.allocatable; - dimension = sym->attr.dimension; - } - - if (allocatable) - { - if (dimension && as->type != AS_ASSUMED_RANK) - { - gfc_error ("Allocatable array %qs at %L must have a deferred " - "shape or assumed rank", sym->name, &sym->declared_at); - return false; - } - else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object " - "%qs at %L may not be ALLOCATABLE", - sym->name, &sym->declared_at)) - return false; - } - - if (pointer && dimension && as->type != AS_ASSUMED_RANK) - { - gfc_error ("Array pointer %qs at %L must have a deferred shape or " - "assumed rank", sym->name, &sym->declared_at); - sym->error = 1; - return false; - } - } - else - { - if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer - && sym->ts.type != BT_CLASS && !sym->assoc) - { - gfc_error ("Array %qs at %L cannot have a deferred shape", - sym->name, &sym->declared_at); - return false; - } - } - - /* Constraints on polymorphic variables. */ - if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) - { - /* F03:C502. */ - if (sym->attr.class_ok - && sym->ts.u.derived - && !sym->attr.select_type_temporary - && !UNLIMITED_POLY (sym) - && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) - { - gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible", - CLASS_DATA (sym)->ts.u.derived->name, sym->name, - &sym->declared_at); - return false; - } - - /* F03:C509. */ - /* Assume that use associated symbols were checked in the module ns. - Class-variables that are associate-names are also something special - and excepted from the test. */ - if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc) - { - gfc_error ("CLASS variable %qs at %L must be dummy, allocatable " - "or pointer", sym->name, &sym->declared_at); - return false; - } - } - - return true; -} - - -/* Additional checks for symbols with flavor variable and derived - type. To be called from resolve_fl_variable. */ - -static bool -resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) -{ - gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); - - /* Check to see if a derived type is blocked from being host - associated by the presence of another class I symbol in the same - namespace. 14.6.1.3 of the standard and the discussion on - comp.lang.fortran. */ - if (sym->ts.u.derived - && sym->ns != sym->ts.u.derived->ns - && !sym->ts.u.derived->attr.use_assoc - && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY) - { - gfc_symbol *s; - gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); - if (s && s->attr.generic) - s = gfc_find_dt_in_generic (s); - if (s && !gfc_fl_struct (s->attr.flavor)) - { - gfc_error ("The type %qs cannot be host associated at %L " - "because it is blocked by an incompatible object " - "of the same name declared at %L", - sym->ts.u.derived->name, &sym->declared_at, - &s->declared_at); - return false; - } - } - - /* 4th constraint in section 11.3: "If an object of a type for which - component-initialization is specified (R429) appears in the - specification-part of a module and does not have the ALLOCATABLE - or POINTER attribute, the object shall have the SAVE attribute." - - The check for initializers is performed with - gfc_has_default_initializer because gfc_default_initializer generates - a hidden default for allocatable components. */ - if (!(sym->value || no_init_flag) && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE - && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save - && !sym->attr.pointer && !sym->attr.allocatable - && gfc_has_default_initializer (sym->ts.u.derived) - && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable " - "%qs at %L, needed due to the default " - "initialization", sym->name, &sym->declared_at)) - return false; - - /* Assign default initializer. */ - if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) - && (!no_init_flag - || (sym->attr.intent == INTENT_OUT - && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))) - sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); - - return true; -} - - -/* F2008, C402 (R401): A colon shall not be used as a type-param-value - except in the declaration of an entity or component that has the POINTER - or ALLOCATABLE attribute. */ - -static bool -deferred_requirements (gfc_symbol *sym) -{ - if (sym->ts.deferred - && !(sym->attr.pointer - || sym->attr.allocatable - || sym->attr.associate_var - || sym->attr.omp_udr_artificial_var)) - { - /* If a function has a result variable, only check the variable. */ - if (sym->result && sym->name != sym->result->name) - return true; - - gfc_error ("Entity %qs at %L has a deferred type parameter and " - "requires either the POINTER or ALLOCATABLE attribute", - sym->name, &sym->declared_at); - return false; - } - return true; -} - - -/* Resolve symbols with flavor variable. */ - -static bool -resolve_fl_variable (gfc_symbol *sym, int mp_flag) -{ - const char *auto_save_msg = "Automatic object %qs at %L cannot have the " - "SAVE attribute"; - - if (!resolve_fl_var_and_proc (sym, mp_flag)) - return false; - - /* Set this flag to check that variables are parameters of all entries. - This check is effected by the call to gfc_resolve_expr through - is_non_constant_shape_array. */ - bool saved_specification_expr = specification_expr; - specification_expr = true; - - if (sym->ns->proc_name - && (sym->ns->proc_name->attr.flavor == FL_MODULE - || sym->ns->proc_name->attr.is_main_program) - && !sym->attr.use_assoc - && !sym->attr.allocatable - && !sym->attr.pointer - && is_non_constant_shape_array (sym)) - { - /* F08:C541. The shape of an array defined in a main program or module - * needs to be constant. */ - gfc_error ("The module or main program array %qs at %L must " - "have constant shape", sym->name, &sym->declared_at); - specification_expr = saved_specification_expr; - return false; - } - - /* Constraints on deferred type parameter. */ - if (!deferred_requirements (sym)) - return false; - - if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var) - { - /* Make sure that character string variables with assumed length are - dummy arguments. */ - gfc_expr *e = NULL; - - if (sym->ts.u.cl) - e = sym->ts.u.cl->length; - else - return false; - - if (e == NULL && !sym->attr.dummy && !sym->attr.result - && !sym->ts.deferred && !sym->attr.select_type_temporary - && !sym->attr.omp_udr_artificial_var) - { - gfc_error ("Entity with assumed character length at %L must be a " - "dummy argument or a PARAMETER", &sym->declared_at); - specification_expr = saved_specification_expr; - return false; - } - - if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) - { - gfc_error (auto_save_msg, sym->name, &sym->declared_at); - specification_expr = saved_specification_expr; - return false; - } - - if (!gfc_is_constant_expr (e) - && !(e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.flavor == FL_PARAMETER)) - { - if (!sym->attr.use_assoc && sym->ns->proc_name - && (sym->ns->proc_name->attr.flavor == FL_MODULE - || sym->ns->proc_name->attr.is_main_program)) - { - gfc_error ("%qs at %L must have constant character length " - "in this context", sym->name, &sym->declared_at); - specification_expr = saved_specification_expr; - return false; - } - if (sym->attr.in_common) - { - gfc_error ("COMMON variable %qs at %L must have constant " - "character length", sym->name, &sym->declared_at); - specification_expr = saved_specification_expr; - return false; - } - } - } - - if (sym->value == NULL && sym->attr.referenced) - apply_default_init_local (sym); /* Try to apply a default initialization. */ - - /* Determine if the symbol may not have an initializer. */ - int no_init_flag = 0, automatic_flag = 0; - if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy - || sym->attr.intrinsic || sym->attr.result) - no_init_flag = 1; - else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer - && is_non_constant_shape_array (sym)) - { - no_init_flag = automatic_flag = 1; - - /* Also, they must not have the SAVE attribute. - SAVE_IMPLICIT is checked below. */ - if (sym->as && sym->attr.codimension) - { - int corank = sym->as->corank; - sym->as->corank = 0; - no_init_flag = automatic_flag = is_non_constant_shape_array (sym); - sym->as->corank = corank; - } - if (automatic_flag && sym->attr.save == SAVE_EXPLICIT) - { - gfc_error (auto_save_msg, sym->name, &sym->declared_at); - specification_expr = saved_specification_expr; - return false; - } - } - - /* Ensure that any initializer is simplified. */ - if (sym->value) - gfc_simplify_expr (sym->value, 1); - - /* Reject illegal initializers. */ - if (!sym->mark && sym->value) - { - if (sym->attr.allocatable || (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.allocatable)) - gfc_error ("Allocatable %qs at %L cannot have an initializer", - sym->name, &sym->declared_at); - else if (sym->attr.external) - gfc_error ("External %qs at %L cannot have an initializer", - sym->name, &sym->declared_at); - else if (sym->attr.dummy) - gfc_error ("Dummy %qs at %L cannot have an initializer", - sym->name, &sym->declared_at); - else if (sym->attr.intrinsic) - gfc_error ("Intrinsic %qs at %L cannot have an initializer", - sym->name, &sym->declared_at); - else if (sym->attr.result) - gfc_error ("Function result %qs at %L cannot have an initializer", - sym->name, &sym->declared_at); - else if (automatic_flag) - gfc_error ("Automatic array %qs at %L cannot have an initializer", - sym->name, &sym->declared_at); - else - goto no_init_error; - specification_expr = saved_specification_expr; - return false; - } - -no_init_error: - if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) - { - bool res = resolve_fl_variable_derived (sym, no_init_flag); - specification_expr = saved_specification_expr; - return res; - } - - specification_expr = saved_specification_expr; - return true; -} - - -/* Compare the dummy characteristics of a module procedure interface - declaration with the corresponding declaration in a submodule. */ -static gfc_formal_arglist *new_formal; -static char errmsg[200]; - -static void -compare_fsyms (gfc_symbol *sym) -{ - gfc_symbol *fsym; - - if (sym == NULL || new_formal == NULL) - return; - - fsym = new_formal->sym; - - if (sym == fsym) - return; - - if (strcmp (sym->name, fsym->name) == 0) - { - if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200)) - gfc_error ("%s at %L", errmsg, &fsym->declared_at); - } -} - - -/* Resolve a procedure. */ - -static bool -resolve_fl_procedure (gfc_symbol *sym, int mp_flag) -{ - gfc_formal_arglist *arg; - bool allocatable_or_pointer = false; - - if (sym->attr.function - && !resolve_fl_var_and_proc (sym, mp_flag)) - return false; - - /* Constraints on deferred type parameter. */ - if (!deferred_requirements (sym)) - return false; - - if (sym->ts.type == BT_CHARACTER) - { - gfc_charlen *cl = sym->ts.u.cl; - - if (cl && cl->length && gfc_is_constant_expr (cl->length) - && !resolve_charlen (cl)) - return false; - - if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) - && sym->attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Character-valued statement function %qs at %L must " - "have constant length", sym->name, &sym->declared_at); - return false; - } - } - - /* Ensure that derived type for are not of a private type. Internal - module procedures are excluded by 2.2.3.3 - i.e., they are not - externally accessible and can access all the objects accessible in - the host. */ - if (!(sym->ns->parent && sym->ns->parent->proc_name - && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) - && gfc_check_symbol_access (sym)) - { - gfc_interface *iface; - - for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next) - { - if (arg->sym - && arg->sym->ts.type == BT_DERIVED - && arg->sym->ts.u.derived - && !arg->sym->ts.u.derived->attr.use_assoc - && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type " - "and cannot be a dummy argument" - " of %qs, which is PUBLIC at %L", - arg->sym->name, sym->name, - &sym->declared_at)) - { - /* Stop this message from recurring. */ - arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; - return false; - } - } - - /* PUBLIC interfaces may expose PRIVATE procedures that take types - PRIVATE to the containing module. */ - for (iface = sym->generic; iface; iface = iface->next) - { - for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next) - { - if (arg->sym - && arg->sym->ts.type == BT_DERIVED - && !arg->sym->ts.u.derived->attr.use_assoc - && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in " - "PUBLIC interface %qs at %L " - "takes dummy arguments of %qs which " - "is PRIVATE", iface->sym->name, - sym->name, &iface->sym->declared_at, - gfc_typename(&arg->sym->ts))) - { - /* Stop this message from recurring. */ - arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; - return false; - } - } - } - } - - if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION - && !sym->attr.proc_pointer) - { - gfc_error ("Function %qs at %L cannot have an initializer", - sym->name, &sym->declared_at); - - /* Make sure no second error is issued for this. */ - sym->value->error = 1; - return false; - } - - /* An external symbol may not have an initializer because it is taken to be - a procedure. Exception: Procedure Pointers. */ - if (sym->attr.external && sym->value && !sym->attr.proc_pointer) - { - gfc_error ("External object %qs at %L may not have an initializer", - sym->name, &sym->declared_at); - return false; - } - - /* An elemental function is required to return a scalar 12.7.1 */ - if (sym->attr.elemental && sym->attr.function - && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && CLASS_DATA (sym)->as))) - { - gfc_error ("ELEMENTAL function %qs at %L must have a scalar " - "result", sym->name, &sym->declared_at); - /* Reset so that the error only occurs once. */ - sym->attr.elemental = 0; - return false; - } - - if (sym->attr.proc == PROC_ST_FUNCTION - && (sym->attr.allocatable || sym->attr.pointer)) - { - gfc_error ("Statement function %qs at %L may not have pointer or " - "allocatable attribute", sym->name, &sym->declared_at); - return false; - } - - /* 5.1.1.5 of the Standard: A function name declared with an asterisk - char-len-param shall not be array-valued, pointer-valued, recursive - or pure. ....snip... A character value of * may only be used in the - following ways: (i) Dummy arg of procedure - dummy associates with - actual length; (ii) To declare a named constant; or (iii) External - function - but length must be declared in calling scoping unit. */ - if (sym->attr.function - && sym->ts.type == BT_CHARACTER && !sym->ts.deferred - && sym->ts.u.cl && sym->ts.u.cl->length == NULL) - { - if ((sym->as && sym->as->rank) || (sym->attr.pointer) - || (sym->attr.recursive) || (sym->attr.pure)) - { - if (sym->as && sym->as->rank) - gfc_error ("CHARACTER(*) function %qs at %L cannot be " - "array-valued", sym->name, &sym->declared_at); - - if (sym->attr.pointer) - gfc_error ("CHARACTER(*) function %qs at %L cannot be " - "pointer-valued", sym->name, &sym->declared_at); - - if (sym->attr.pure) - gfc_error ("CHARACTER(*) function %qs at %L cannot be " - "pure", sym->name, &sym->declared_at); - - if (sym->attr.recursive) - gfc_error ("CHARACTER(*) function %qs at %L cannot be " - "recursive", sym->name, &sym->declared_at); - - return false; - } - - /* Appendix B.2 of the standard. Contained functions give an - error anyway. Deferred character length is an F2003 feature. - Don't warn on intrinsic conversion functions, which start - with two underscores. */ - if (!sym->attr.contained && !sym->ts.deferred - && (sym->name[0] != '_' || sym->name[1] != '_')) - gfc_notify_std (GFC_STD_F95_OBS, - "CHARACTER(*) function %qs at %L", - sym->name, &sym->declared_at); - } - - /* F2008, C1218. */ - if (sym->attr.elemental) - { - if (sym->attr.proc_pointer) - { - const char* name = (sym->attr.result ? sym->ns->proc_name->name - : sym->name); - gfc_error ("Procedure pointer %qs at %L shall not be elemental", - name, &sym->declared_at); - return false; - } - if (sym->attr.dummy) - { - gfc_error ("Dummy procedure %qs at %L shall not be elemental", - sym->name, &sym->declared_at); - return false; - } - } - - /* F2018, C15100: "The result of an elemental function shall be scalar, - and shall not have the POINTER or ALLOCATABLE attribute." The scalar - pointer is tested and caught elsewhere. */ - if (sym->result) - allocatable_or_pointer = sym->result->ts.type == BT_CLASS - && CLASS_DATA (sym->result) ? - (CLASS_DATA (sym->result)->attr.allocatable - || CLASS_DATA (sym->result)->attr.pointer) : - (sym->result->attr.allocatable - || sym->result->attr.pointer); - - if (sym->attr.elemental && sym->result - && allocatable_or_pointer) - { - gfc_error ("Function result variable %qs at %L of elemental " - "function %qs shall not have an ALLOCATABLE or POINTER " - "attribute", sym->result->name, - &sym->result->declared_at, sym->name); - return false; - } - - if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) - { - gfc_formal_arglist *curr_arg; - int has_non_interop_arg = 0; - - if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, - sym->common_block)) - { - /* Clear these to prevent looking at them again if there was an - error. */ - sym->attr.is_bind_c = 0; - sym->attr.is_c_interop = 0; - sym->ts.is_c_interop = 0; - } - else - { - /* So far, no errors have been found. */ - sym->attr.is_c_interop = 1; - sym->ts.is_c_interop = 1; - } - - curr_arg = gfc_sym_get_dummy_args (sym); - while (curr_arg != NULL) - { - /* Skip implicitly typed dummy args here. */ - if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0) - if (!gfc_verify_c_interop_param (curr_arg->sym)) - /* If something is found to fail, record the fact so we - can mark the symbol for the procedure as not being - BIND(C) to try and prevent multiple errors being - reported. */ - has_non_interop_arg = 1; - - curr_arg = curr_arg->next; - } - - /* See if any of the arguments were not interoperable and if so, clear - the procedure symbol to prevent duplicate error messages. */ - if (has_non_interop_arg != 0) - { - sym->attr.is_c_interop = 0; - sym->ts.is_c_interop = 0; - sym->attr.is_bind_c = 0; - } - } - - if (!sym->attr.proc_pointer) - { - if (sym->attr.save == SAVE_EXPLICIT) - { - gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " - "in %qs at %L", sym->name, &sym->declared_at); - return false; - } - if (sym->attr.intent) - { - gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " - "in %qs at %L", sym->name, &sym->declared_at); - return false; - } - if (sym->attr.subroutine && sym->attr.result) - { - gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " - "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at); - return false; - } - if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure - && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) - || sym->attr.contained)) - { - gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " - "in %qs at %L", sym->name, &sym->declared_at); - return false; - } - if (strcmp ("ppr@", sym->name) == 0) - { - gfc_error ("Procedure pointer result %qs at %L " - "is missing the pointer attribute", - sym->ns->proc_name->name, &sym->declared_at); - return false; - } - } - - /* Assume that a procedure whose body is not known has references - to external arrays. */ - if (sym->attr.if_source != IFSRC_DECL) - sym->attr.array_outer_dependency = 1; - - /* Compare the characteristics of a module procedure with the - interface declaration. Ideally this would be done with - gfc_compare_interfaces but, at present, the formal interface - cannot be copied to the ts.interface. */ - if (sym->attr.module_procedure - && sym->attr.if_source == IFSRC_DECL) - { - gfc_symbol *iface; - char name[2*GFC_MAX_SYMBOL_LEN + 1]; - char *module_name; - char *submodule_name; - strcpy (name, sym->ns->proc_name->name); - module_name = strtok (name, "."); - submodule_name = strtok (NULL, "."); - - iface = sym->tlink; - sym->tlink = NULL; - - /* Make sure that the result uses the correct charlen for deferred - length results. */ - if (iface && sym->result - && iface->ts.type == BT_CHARACTER - && iface->ts.deferred) - sym->result->ts.u.cl = iface->ts.u.cl; - - if (iface == NULL) - goto check_formal; - - /* Check the procedure characteristics. */ - if (sym->attr.elemental != iface->attr.elemental) - { - gfc_error ("Mismatch in ELEMENTAL attribute between MODULE " - "PROCEDURE at %L and its interface in %s", - &sym->declared_at, module_name); - return false; - } - - if (sym->attr.pure != iface->attr.pure) - { - gfc_error ("Mismatch in PURE attribute between MODULE " - "PROCEDURE at %L and its interface in %s", - &sym->declared_at, module_name); - return false; - } - - if (sym->attr.recursive != iface->attr.recursive) - { - gfc_error ("Mismatch in RECURSIVE attribute between MODULE " - "PROCEDURE at %L and its interface in %s", - &sym->declared_at, module_name); - return false; - } - - /* Check the result characteristics. */ - if (!gfc_check_result_characteristics (sym, iface, errmsg, 200)) - { - gfc_error ("%s between the MODULE PROCEDURE declaration " - "in MODULE %qs and the declaration at %L in " - "(SUB)MODULE %qs", - errmsg, module_name, &sym->declared_at, - submodule_name ? submodule_name : module_name); - return false; - } - -check_formal: - /* Check the characteristics of the formal arguments. */ - if (sym->formal && sym->formal_ns) - { - for (arg = sym->formal; arg && arg->sym; arg = arg->next) - { - new_formal = arg; - gfc_traverse_ns (sym->formal_ns, compare_fsyms); - } - } - } - return true; -} - - -/* Resolve a list of finalizer procedures. That is, after they have hopefully - been defined and we now know their defined arguments, check that they fulfill - the requirements of the standard for procedures used as finalizers. */ - -static bool -gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) -{ - gfc_finalizer* list; - gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ - bool result = true; - bool seen_scalar = false; - gfc_symbol *vtab; - gfc_component *c; - gfc_symbol *parent = gfc_get_derived_super_type (derived); - - if (parent) - gfc_resolve_finalizers (parent, finalizable); - - /* Ensure that derived-type components have a their finalizers resolved. */ - bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers; - for (c = derived->components; c; c = c->next) - if (c->ts.type == BT_DERIVED - && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable) - { - bool has_final2 = false; - if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2)) - return false; /* Error. */ - has_final = has_final || has_final2; - } - /* Return early if not finalizable. */ - if (!has_final) - { - if (finalizable) - *finalizable = false; - return true; - } - - /* Walk over the list of finalizer-procedures, check them, and if any one - does not fit in with the standard's definition, print an error and remove - it from the list. */ - prev_link = &derived->f2k_derived->finalizers; - for (list = derived->f2k_derived->finalizers; list; list = *prev_link) - { - gfc_formal_arglist *dummy_args; - gfc_symbol* arg; - gfc_finalizer* i; - int my_rank; - - /* Skip this finalizer if we already resolved it. */ - if (list->proc_tree) - { - if (list->proc_tree->n.sym->formal->sym->as == NULL - || list->proc_tree->n.sym->formal->sym->as->rank == 0) - seen_scalar = true; - prev_link = &(list->next); - continue; - } - - /* Check this exists and is a SUBROUTINE. */ - if (!list->proc_sym->attr.subroutine) - { - gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE", - list->proc_sym->name, &list->where); - goto error; - } - - /* We should have exactly one argument. */ - dummy_args = gfc_sym_get_dummy_args (list->proc_sym); - if (!dummy_args || dummy_args->next) - { - gfc_error ("FINAL procedure at %L must have exactly one argument", - &list->where); - goto error; - } - arg = dummy_args->sym; - - /* This argument must be of our type. */ - if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) - { - gfc_error ("Argument of FINAL procedure at %L must be of type %qs", - &arg->declared_at, derived->name); - goto error; - } - - /* It must neither be a pointer nor allocatable nor optional. */ - if (arg->attr.pointer) - { - gfc_error ("Argument of FINAL procedure at %L must not be a POINTER", - &arg->declared_at); - goto error; - } - if (arg->attr.allocatable) - { - gfc_error ("Argument of FINAL procedure at %L must not be" - " ALLOCATABLE", &arg->declared_at); - goto error; - } - if (arg->attr.optional) - { - gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL", - &arg->declared_at); - goto error; - } - - /* It must not be INTENT(OUT). */ - if (arg->attr.intent == INTENT_OUT) - { - gfc_error ("Argument of FINAL procedure at %L must not be" - " INTENT(OUT)", &arg->declared_at); - goto error; - } - - /* Warn if the procedure is non-scalar and not assumed shape. */ - if (warn_surprising && arg->as && arg->as->rank != 0 - && arg->as->type != AS_ASSUMED_SHAPE) - gfc_warning (OPT_Wsurprising, - "Non-scalar FINAL procedure at %L should have assumed" - " shape argument", &arg->declared_at); - - /* Check that it does not match in kind and rank with a FINAL procedure - defined earlier. To really loop over the *earlier* declarations, - we need to walk the tail of the list as new ones were pushed at the - front. */ - /* TODO: Handle kind parameters once they are implemented. */ - my_rank = (arg->as ? arg->as->rank : 0); - for (i = list->next; i; i = i->next) - { - gfc_formal_arglist *dummy_args; - - /* Argument list might be empty; that is an error signalled earlier, - but we nevertheless continued resolving. */ - dummy_args = gfc_sym_get_dummy_args (i->proc_sym); - if (dummy_args) - { - gfc_symbol* i_arg = dummy_args->sym; - const int i_rank = (i_arg->as ? i_arg->as->rank : 0); - if (i_rank == my_rank) - { - gfc_error ("FINAL procedure %qs declared at %L has the same" - " rank (%d) as %qs", - list->proc_sym->name, &list->where, my_rank, - i->proc_sym->name); - goto error; - } - } - } - - /* Is this the/a scalar finalizer procedure? */ - if (my_rank == 0) - seen_scalar = true; - - /* Find the symtree for this procedure. */ - gcc_assert (!list->proc_tree); - list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); - - prev_link = &list->next; - continue; - - /* Remove wrong nodes immediately from the list so we don't risk any - troubles in the future when they might fail later expectations. */ -error: - i = list; - *prev_link = list->next; - gfc_free_finalizer (i); - result = false; - } - - if (result == false) - return false; - - /* Warn if we haven't seen a scalar finalizer procedure (but we know there - were nodes in the list, must have been for arrays. It is surely a good - idea to have a scalar version there if there's something to finalize. */ - if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar) - gfc_warning (OPT_Wsurprising, - "Only array FINAL procedures declared for derived type %qs" - " defined at %L, suggest also scalar one", - derived->name, &derived->declared_at); - - vtab = gfc_find_derived_vtab (derived); - c = vtab->ts.u.derived->components->next->next->next->next->next; - gfc_set_sym_referenced (c->initializer->symtree->n.sym); - - if (finalizable) - *finalizable = true; - - return true; -} - - -/* Check if two GENERIC targets are ambiguous and emit an error is they are. */ - -static bool -check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, - const char* generic_name, locus where) -{ - gfc_symbol *sym1, *sym2; - const char *pass1, *pass2; - gfc_formal_arglist *dummy_args; - - gcc_assert (t1->specific && t2->specific); - gcc_assert (!t1->specific->is_generic); - gcc_assert (!t2->specific->is_generic); - gcc_assert (t1->is_operator == t2->is_operator); - - sym1 = t1->specific->u.specific->n.sym; - sym2 = t2->specific->u.specific->n.sym; - - if (sym1 == sym2) - return true; - - /* Both must be SUBROUTINEs or both must be FUNCTIONs. */ - if (sym1->attr.subroutine != sym2->attr.subroutine - || sym1->attr.function != sym2->attr.function) - { - gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for" - " GENERIC %qs at %L", - sym1->name, sym2->name, generic_name, &where); - return false; - } - - /* Determine PASS arguments. */ - if (t1->specific->nopass) - pass1 = NULL; - else if (t1->specific->pass_arg) - pass1 = t1->specific->pass_arg; - else - { - dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym); - if (dummy_args) - pass1 = dummy_args->sym->name; - else - pass1 = NULL; - } - if (t2->specific->nopass) - pass2 = NULL; - else if (t2->specific->pass_arg) - pass2 = t2->specific->pass_arg; - else - { - dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym); - if (dummy_args) - pass2 = dummy_args->sym->name; - else - pass2 = NULL; - } - - /* Compare the interfaces. */ - if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, - NULL, 0, pass1, pass2)) - { - gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous", - sym1->name, sym2->name, generic_name, &where); - return false; - } - - return true; -} - - -/* Worker function for resolving a generic procedure binding; this is used to - resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures. - - The difference between those cases is finding possible inherited bindings - that are overridden, as one has to look for them in tb_sym_root, - tb_uop_root or tb_op, respectively. Thus the caller must already find - the super-type and set p->overridden correctly. */ - -static bool -resolve_tb_generic_targets (gfc_symbol* super_type, - gfc_typebound_proc* p, const char* name) -{ - gfc_tbp_generic* target; - gfc_symtree* first_target; - gfc_symtree* inherited; - - gcc_assert (p && p->is_generic); - - /* Try to find the specific bindings for the symtrees in our target-list. */ - gcc_assert (p->u.generic); - for (target = p->u.generic; target; target = target->next) - if (!target->specific) - { - gfc_typebound_proc* overridden_tbp; - gfc_tbp_generic* g; - const char* target_name; - - target_name = target->specific_st->name; - - /* Defined for this type directly. */ - if (target->specific_st->n.tb && !target->specific_st->n.tb->error) - { - target->specific = target->specific_st->n.tb; - goto specific_found; - } - - /* Look for an inherited specific binding. */ - if (super_type) - { - inherited = gfc_find_typebound_proc (super_type, NULL, target_name, - true, NULL); - - if (inherited) - { - gcc_assert (inherited->n.tb); - target->specific = inherited->n.tb; - goto specific_found; - } - } - - gfc_error ("Undefined specific binding %qs as target of GENERIC %qs" - " at %L", target_name, name, &p->where); - return false; - - /* Once we've found the specific binding, check it is not ambiguous with - other specifics already found or inherited for the same GENERIC. */ -specific_found: - gcc_assert (target->specific); - - /* This must really be a specific binding! */ - if (target->specific->is_generic) - { - gfc_error ("GENERIC %qs at %L must target a specific binding," - " %qs is GENERIC, too", name, &p->where, target_name); - return false; - } - - /* Check those already resolved on this type directly. */ - for (g = p->u.generic; g; g = g->next) - if (g != target && g->specific - && !check_generic_tbp_ambiguity (target, g, name, p->where)) - return false; - - /* Check for ambiguity with inherited specific targets. */ - for (overridden_tbp = p->overridden; overridden_tbp; - overridden_tbp = overridden_tbp->overridden) - if (overridden_tbp->is_generic) - { - for (g = overridden_tbp->u.generic; g; g = g->next) - { - gcc_assert (g->specific); - if (!check_generic_tbp_ambiguity (target, g, name, p->where)) - return false; - } - } - } - - /* If we attempt to "overwrite" a specific binding, this is an error. */ - if (p->overridden && !p->overridden->is_generic) - { - gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with" - " the same name", name, &p->where); - return false; - } - - /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as - all must have the same attributes here. */ - first_target = p->u.generic->specific->u.specific; - gcc_assert (first_target); - p->subroutine = first_target->n.sym->attr.subroutine; - p->function = first_target->n.sym->attr.function; - - return true; -} - - -/* Resolve a GENERIC procedure binding for a derived type. */ - -static bool -resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) -{ - gfc_symbol* super_type; - - /* Find the overridden binding if any. */ - st->n.tb->overridden = NULL; - super_type = gfc_get_derived_super_type (derived); - if (super_type) - { - gfc_symtree* overridden; - overridden = gfc_find_typebound_proc (super_type, NULL, st->name, - true, NULL); - - if (overridden && overridden->n.tb) - st->n.tb->overridden = overridden->n.tb; - } - - /* Resolve using worker function. */ - return resolve_tb_generic_targets (super_type, st->n.tb, st->name); -} - - -/* Retrieve the target-procedure of an operator binding and do some checks in - common for intrinsic and user-defined type-bound operators. */ - -static gfc_symbol* -get_checked_tb_operator_target (gfc_tbp_generic* target, locus where) -{ - gfc_symbol* target_proc; - - gcc_assert (target->specific && !target->specific->is_generic); - target_proc = target->specific->u.specific->n.sym; - gcc_assert (target_proc); - - /* F08:C468. All operator bindings must have a passed-object dummy argument. */ - if (target->specific->nopass) - { - gfc_error ("Type-bound operator at %L cannot be NOPASS", &where); - return NULL; - } - - return target_proc; -} - - -/* Resolve a type-bound intrinsic operator. */ - -static bool -resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, - gfc_typebound_proc* p) -{ - gfc_symbol* super_type; - gfc_tbp_generic* target; - - /* If there's already an error here, do nothing (but don't fail again). */ - if (p->error) - return true; - - /* Operators should always be GENERIC bindings. */ - gcc_assert (p->is_generic); - - /* Look for an overridden binding. */ - super_type = gfc_get_derived_super_type (derived); - if (super_type && super_type->f2k_derived) - p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL, - op, true, NULL); - else - p->overridden = NULL; - - /* Resolve general GENERIC properties using worker function. */ - if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op))) - goto error; - - /* Check the targets to be procedures of correct interface. */ - for (target = p->u.generic; target; target = target->next) - { - gfc_symbol* target_proc; - - target_proc = get_checked_tb_operator_target (target, p->where); - if (!target_proc) - goto error; - - if (!gfc_check_operator_interface (target_proc, op, p->where)) - goto error; - - /* Add target to non-typebound operator list. */ - if (!target->specific->deferred && !derived->attr.use_assoc - && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns) - { - gfc_interface *head, *intr; - - /* Preempt 'gfc_check_new_interface' for submodules, where the - mechanism for handling module procedures winds up resolving - operator interfaces twice and would otherwise cause an error. */ - for (intr = derived->ns->op[op]; intr; intr = intr->next) - if (intr->sym == target_proc - && target_proc->attr.used_in_submodule) - return true; - - if (!gfc_check_new_interface (derived->ns->op[op], - target_proc, p->where)) - return false; - head = derived->ns->op[op]; - intr = gfc_get_interface (); - intr->sym = target_proc; - intr->where = p->where; - intr->next = head; - derived->ns->op[op] = intr; - } - } - - return true; - -error: - p->error = 1; - return false; -} - - -/* Resolve a type-bound user operator (tree-walker callback). */ - -static gfc_symbol* resolve_bindings_derived; -static bool resolve_bindings_result; - -static bool check_uop_procedure (gfc_symbol* sym, locus where); - -static void -resolve_typebound_user_op (gfc_symtree* stree) -{ - gfc_symbol* super_type; - gfc_tbp_generic* target; - - gcc_assert (stree && stree->n.tb); - - if (stree->n.tb->error) - return; - - /* Operators should always be GENERIC bindings. */ - gcc_assert (stree->n.tb->is_generic); - - /* Find overridden procedure, if any. */ - super_type = gfc_get_derived_super_type (resolve_bindings_derived); - if (super_type && super_type->f2k_derived) - { - gfc_symtree* overridden; - overridden = gfc_find_typebound_user_op (super_type, NULL, - stree->name, true, NULL); - - if (overridden && overridden->n.tb) - stree->n.tb->overridden = overridden->n.tb; - } - else - stree->n.tb->overridden = NULL; - - /* Resolve basically using worker function. */ - if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)) - goto error; - - /* Check the targets to be functions of correct interface. */ - for (target = stree->n.tb->u.generic; target; target = target->next) - { - gfc_symbol* target_proc; - - target_proc = get_checked_tb_operator_target (target, stree->n.tb->where); - if (!target_proc) - goto error; - - if (!check_uop_procedure (target_proc, stree->n.tb->where)) - goto error; - } - - return; - -error: - resolve_bindings_result = false; - stree->n.tb->error = 1; -} - - -/* Resolve the type-bound procedures for a derived type. */ - -static void -resolve_typebound_procedure (gfc_symtree* stree) -{ - gfc_symbol* proc; - locus where; - gfc_symbol* me_arg; - gfc_symbol* super_type; - gfc_component* comp; - - gcc_assert (stree); - - /* Undefined specific symbol from GENERIC target definition. */ - if (!stree->n.tb) - return; - - if (stree->n.tb->error) - return; - - /* If this is a GENERIC binding, use that routine. */ - if (stree->n.tb->is_generic) - { - if (!resolve_typebound_generic (resolve_bindings_derived, stree)) - goto error; - return; - } - - /* Get the target-procedure to check it. */ - gcc_assert (!stree->n.tb->is_generic); - gcc_assert (stree->n.tb->u.specific); - proc = stree->n.tb->u.specific->n.sym; - where = stree->n.tb->where; - - /* Default access should already be resolved from the parser. */ - gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN); - - if (stree->n.tb->deferred) - { - if (!check_proc_interface (proc, &where)) - goto error; - } - else - { - /* If proc has not been resolved at this point, proc->name may - actually be a USE associated entity. See PR fortran/89647. */ - if (!proc->resolve_symbol_called - && proc->attr.function == 0 && proc->attr.subroutine == 0) - { - gfc_symbol *tmp; - gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp); - if (tmp && tmp->attr.use_assoc) - { - proc->module = tmp->module; - proc->attr.proc = tmp->attr.proc; - proc->attr.function = tmp->attr.function; - proc->attr.subroutine = tmp->attr.subroutine; - proc->attr.use_assoc = tmp->attr.use_assoc; - proc->ts = tmp->ts; - proc->result = tmp->result; - } - } - - /* Check for F08:C465. */ - if ((!proc->attr.subroutine && !proc->attr.function) - || (proc->attr.proc != PROC_MODULE - && proc->attr.if_source != IFSRC_IFBODY - && !proc->attr.module_procedure) - || proc->attr.abstract) - { - gfc_error ("%qs must be a module procedure or an external " - "procedure with an explicit interface at %L", - proc->name, &where); - goto error; - } - } - - stree->n.tb->subroutine = proc->attr.subroutine; - stree->n.tb->function = proc->attr.function; - - /* Find the super-type of the current derived type. We could do this once and - store in a global if speed is needed, but as long as not I believe this is - more readable and clearer. */ - super_type = gfc_get_derived_super_type (resolve_bindings_derived); - - /* If PASS, resolve and check arguments if not already resolved / loaded - from a .mod file. */ - if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0) - { - gfc_formal_arglist *dummy_args; - - dummy_args = gfc_sym_get_dummy_args (proc); - if (stree->n.tb->pass_arg) - { - gfc_formal_arglist *i; - - /* If an explicit passing argument name is given, walk the arg-list - and look for it. */ - - me_arg = NULL; - stree->n.tb->pass_arg_num = 1; - for (i = dummy_args; i; i = i->next) - { - if (!strcmp (i->sym->name, stree->n.tb->pass_arg)) - { - me_arg = i->sym; - break; - } - ++stree->n.tb->pass_arg_num; - } - - if (!me_arg) - { - gfc_error ("Procedure %qs with PASS(%s) at %L has no" - " argument %qs", - proc->name, stree->n.tb->pass_arg, &where, - stree->n.tb->pass_arg); - goto error; - } - } - else - { - /* Otherwise, take the first one; there should in fact be at least - one. */ - stree->n.tb->pass_arg_num = 1; - if (!dummy_args) - { - gfc_error ("Procedure %qs with PASS at %L must have at" - " least one argument", proc->name, &where); - goto error; - } - me_arg = dummy_args->sym; - } - - /* Now check that the argument-type matches and the passed-object - dummy argument is generally fine. */ - - gcc_assert (me_arg); - - if (me_arg->ts.type != BT_CLASS) - { - gfc_error ("Non-polymorphic passed-object dummy argument of %qs" - " at %L", proc->name, &where); - goto error; - } - - if (CLASS_DATA (me_arg)->ts.u.derived - != resolve_bindings_derived) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" - " the derived-type %qs", me_arg->name, proc->name, - me_arg->name, &where, resolve_bindings_derived->name); - goto error; - } - - gcc_assert (me_arg->ts.type == BT_CLASS); - if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) - { - gfc_error ("Passed-object dummy argument of %qs at %L must be" - " scalar", proc->name, &where); - goto error; - } - if (CLASS_DATA (me_arg)->attr.allocatable) - { - gfc_error ("Passed-object dummy argument of %qs at %L must not" - " be ALLOCATABLE", proc->name, &where); - goto error; - } - if (CLASS_DATA (me_arg)->attr.class_pointer) - { - gfc_error ("Passed-object dummy argument of %qs at %L must not" - " be POINTER", proc->name, &where); - goto error; - } - } - - /* If we are extending some type, check that we don't override a procedure - flagged NON_OVERRIDABLE. */ - stree->n.tb->overridden = NULL; - if (super_type) - { - gfc_symtree* overridden; - overridden = gfc_find_typebound_proc (super_type, NULL, - stree->name, true, NULL); - - if (overridden) - { - if (overridden->n.tb) - stree->n.tb->overridden = overridden->n.tb; - - if (!gfc_check_typebound_override (stree, overridden)) - goto error; - } - } - - /* See if there's a name collision with a component directly in this type. */ - for (comp = resolve_bindings_derived->components; comp; comp = comp->next) - if (!strcmp (comp->name, stree->name)) - { - gfc_error ("Procedure %qs at %L has the same name as a component of" - " %qs", - stree->name, &where, resolve_bindings_derived->name); - goto error; - } - - /* Try to find a name collision with an inherited component. */ - if (super_type && gfc_find_component (super_type, stree->name, true, true, - NULL)) - { - gfc_error ("Procedure %qs at %L has the same name as an inherited" - " component of %qs", - stree->name, &where, resolve_bindings_derived->name); - goto error; - } - - stree->n.tb->error = 0; - return; - -error: - resolve_bindings_result = false; - stree->n.tb->error = 1; -} - - -static bool -resolve_typebound_procedures (gfc_symbol* derived) -{ - int op; - gfc_symbol* super_type; - - if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) - return true; - - super_type = gfc_get_derived_super_type (derived); - if (super_type) - resolve_symbol (super_type); - - resolve_bindings_derived = derived; - resolve_bindings_result = true; - - if (derived->f2k_derived->tb_sym_root) - gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, - &resolve_typebound_procedure); - - if (derived->f2k_derived->tb_uop_root) - gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, - &resolve_typebound_user_op); - - for (op = 0; op != GFC_INTRINSIC_OPS; ++op) - { - gfc_typebound_proc* p = derived->f2k_derived->tb_op[op]; - if (p && !resolve_typebound_intrinsic_op (derived, - (gfc_intrinsic_op)op, p)) - resolve_bindings_result = false; - } - - return resolve_bindings_result; -} - - -/* Add a derived type to the dt_list. The dt_list is used in trans-types.c - to give all identical derived types the same backend_decl. */ -static void -add_dt_to_dt_list (gfc_symbol *derived) -{ - if (!derived->dt_next) - { - if (gfc_derived_types) - { - derived->dt_next = gfc_derived_types->dt_next; - gfc_derived_types->dt_next = derived; - } - else - { - derived->dt_next = derived; - } - gfc_derived_types = derived; - } -} - - -/* Ensure that a derived-type is really not abstract, meaning that every - inherited DEFERRED binding is overridden by a non-DEFERRED one. */ - -static bool -ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) -{ - if (!st) - return true; - - if (!ensure_not_abstract_walker (sub, st->left)) - return false; - if (!ensure_not_abstract_walker (sub, st->right)) - return false; - - if (st->n.tb && st->n.tb->deferred) - { - gfc_symtree* overriding; - overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); - if (!overriding) - return false; - gcc_assert (overriding->n.tb); - if (overriding->n.tb->deferred) - { - gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because" - " %qs is DEFERRED and not overridden", - sub->name, &sub->declared_at, st->name); - return false; - } - } - - return true; -} - -static bool -ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) -{ - /* The algorithm used here is to recursively travel up the ancestry of sub - and for each ancestor-type, check all bindings. If any of them is - DEFERRED, look it up starting from sub and see if the found (overriding) - binding is not DEFERRED. - This is not the most efficient way to do this, but it should be ok and is - clearer than something sophisticated. */ - - gcc_assert (ancestor && !sub->attr.abstract); - - if (!ancestor->attr.abstract) - return true; - - /* Walk bindings of this ancestor. */ - if (ancestor->f2k_derived) - { - bool t; - t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root); - if (!t) - return false; - } - - /* Find next ancestor type and recurse on it. */ - ancestor = gfc_get_derived_super_type (ancestor); - if (ancestor) - return ensure_not_abstract (sub, ancestor); - - return true; -} - - -/* This check for typebound defined assignments is done recursively - since the order in which derived types are resolved is not always in - order of the declarations. */ - -static void -check_defined_assignments (gfc_symbol *derived) -{ - gfc_component *c; - - for (c = derived->components; c; c = c->next) - { - if (!gfc_bt_struct (c->ts.type) - || c->attr.pointer - || c->attr.allocatable - || c->attr.proc_pointer_comp - || c->attr.class_pointer - || c->attr.proc_pointer) - continue; - - if (c->ts.u.derived->attr.defined_assign_comp - || (c->ts.u.derived->f2k_derived - && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN])) - { - derived->attr.defined_assign_comp = 1; - return; - } - - check_defined_assignments (c->ts.u.derived); - if (c->ts.u.derived->attr.defined_assign_comp) - { - derived->attr.defined_assign_comp = 1; - return; - } - } -} - - -/* Resolve a single component of a derived type or structure. */ - -static bool -resolve_component (gfc_component *c, gfc_symbol *sym) -{ - gfc_symbol *super_type; - symbol_attribute *attr; - - if (c->attr.artificial) - return true; - - /* Do not allow vtype components to be resolved in nameless namespaces - such as block data because the procedure pointers will cause ICEs - and vtables are not needed in these contexts. */ - if (sym->attr.vtype && sym->attr.use_assoc - && sym->ns->proc_name == NULL) - return true; - - /* F2008, C442. */ - if ((!sym->attr.is_class || c != sym->components) - && c->attr.codimension - && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) - { - gfc_error ("Coarray component %qs at %L must be allocatable with " - "deferred shape", c->name, &c->loc); - return false; - } - - /* F2008, C443. */ - if (c->attr.codimension && c->ts.type == BT_DERIVED - && c->ts.u.derived->ts.is_iso_c) - { - gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " - "shall not be a coarray", c->name, &c->loc); - return false; - } - - /* F2008, C444. */ - if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp - && (c->attr.codimension || c->attr.pointer || c->attr.dimension - || c->attr.allocatable)) - { - gfc_error ("Component %qs at %L with coarray component " - "shall be a nonpointer, nonallocatable scalar", - c->name, &c->loc); - return false; - } - - /* F2008, C448. */ - if (c->ts.type == BT_CLASS) - { - if (c->attr.class_ok && CLASS_DATA (c)) - { - attr = &(CLASS_DATA (c)->attr); - - /* Fix up contiguous attribute. */ - if (c->attr.contiguous) - attr->contiguous = 1; - } - else - attr = NULL; - } - else - attr = &c->attr; - - if (attr && attr->contiguous && (!attr->dimension || !attr->pointer)) - { - gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " - "is not an array pointer", c->name, &c->loc); - return false; - } - - /* F2003, 15.2.1 - length has to be one. */ - if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER - && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL - || !gfc_is_constant_expr (c->ts.u.cl->length) - || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0)) - { - gfc_error ("Component %qs of BIND(C) type at %L must have length one", - c->name, &c->loc); - return false; - } - - if (c->attr.proc_pointer && c->ts.interface) - { - gfc_symbol *ifc = c->ts.interface; - - if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc)) - { - c->tb->error = 1; - return false; - } - - if (ifc->attr.if_source || ifc->attr.intrinsic) - { - /* Resolve interface and copy attributes. */ - if (ifc->formal && !ifc->formal_ns) - resolve_symbol (ifc); - if (ifc->attr.intrinsic) - gfc_resolve_intrinsic (ifc, &ifc->declared_at); - - if (ifc->result) - { - c->ts = ifc->result->ts; - c->attr.allocatable = ifc->result->attr.allocatable; - c->attr.pointer = ifc->result->attr.pointer; - c->attr.dimension = ifc->result->attr.dimension; - c->as = gfc_copy_array_spec (ifc->result->as); - c->attr.class_ok = ifc->result->attr.class_ok; - } - else - { - c->ts = ifc->ts; - c->attr.allocatable = ifc->attr.allocatable; - c->attr.pointer = ifc->attr.pointer; - c->attr.dimension = ifc->attr.dimension; - c->as = gfc_copy_array_spec (ifc->as); - c->attr.class_ok = ifc->attr.class_ok; - } - c->ts.interface = ifc; - c->attr.function = ifc->attr.function; - c->attr.subroutine = ifc->attr.subroutine; - - c->attr.pure = ifc->attr.pure; - c->attr.elemental = ifc->attr.elemental; - c->attr.recursive = ifc->attr.recursive; - c->attr.always_explicit = ifc->attr.always_explicit; - c->attr.ext_attr |= ifc->attr.ext_attr; - /* Copy char length. */ - if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) - { - gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); - if (cl->length && !cl->resolved - && !gfc_resolve_expr (cl->length)) - { - c->tb->error = 1; - return false; - } - c->ts.u.cl = cl; - } - } - } - else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) - { - /* Since PPCs are not implicitly typed, a PPC without an explicit - interface must be a subroutine. */ - gfc_add_subroutine (&c->attr, c->name, &c->loc); - } - - /* Procedure pointer components: Check PASS arg. */ - if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 - && !sym->attr.vtype) - { - gfc_symbol* me_arg; - - if (c->tb->pass_arg) - { - gfc_formal_arglist* i; - - /* If an explicit passing argument name is given, walk the arg-list - and look for it. */ - - me_arg = NULL; - c->tb->pass_arg_num = 1; - for (i = c->ts.interface->formal; i; i = i->next) - { - if (!strcmp (i->sym->name, c->tb->pass_arg)) - { - me_arg = i->sym; - break; - } - c->tb->pass_arg_num++; - } - - if (!me_arg) - { - gfc_error ("Procedure pointer component %qs with PASS(%s) " - "at %L has no argument %qs", c->name, - c->tb->pass_arg, &c->loc, c->tb->pass_arg); - c->tb->error = 1; - return false; - } - } - else - { - /* Otherwise, take the first one; there should in fact be at least - one. */ - c->tb->pass_arg_num = 1; - if (!c->ts.interface->formal) - { - gfc_error ("Procedure pointer component %qs with PASS at %L " - "must have at least one argument", - c->name, &c->loc); - c->tb->error = 1; - return false; - } - me_arg = c->ts.interface->formal->sym; - } - - /* Now check that the argument-type matches. */ - gcc_assert (me_arg); - if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) - || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) - || (me_arg->ts.type == BT_CLASS - && CLASS_DATA (me_arg)->ts.u.derived != sym)) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" - " the derived type %qs", me_arg->name, c->name, - me_arg->name, &c->loc, sym->name); - c->tb->error = 1; - return false; - } - - /* Check for F03:C453. */ - if (CLASS_DATA (me_arg)->attr.dimension) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "must be scalar", me_arg->name, c->name, me_arg->name, - &c->loc); - c->tb->error = 1; - return false; - } - - if (CLASS_DATA (me_arg)->attr.class_pointer) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "may not have the POINTER attribute", me_arg->name, - c->name, me_arg->name, &c->loc); - c->tb->error = 1; - return false; - } - - if (CLASS_DATA (me_arg)->attr.allocatable) - { - gfc_error ("Argument %qs of %qs with PASS(%s) at %L " - "may not be ALLOCATABLE", me_arg->name, c->name, - me_arg->name, &c->loc); - c->tb->error = 1; - return false; - } - - if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) - { - gfc_error ("Non-polymorphic passed-object dummy argument of %qs" - " at %L", c->name, &c->loc); - return false; - } - - } - - /* Check type-spec if this is not the parent-type component. */ - if (((sym->attr.is_class - && (!sym->components->ts.u.derived->attr.extension - || c != sym->components->ts.u.derived->components)) - || (!sym->attr.is_class - && (!sym->attr.extension || c != sym->components))) - && !sym->attr.vtype - && !resolve_typespec_used (&c->ts, &c->loc, c->name)) - return false; - - super_type = gfc_get_derived_super_type (sym); - - /* If this type is an extension, set the accessibility of the parent - component. */ - if (super_type - && ((sym->attr.is_class - && c == sym->components->ts.u.derived->components) - || (!sym->attr.is_class && c == sym->components)) - && strcmp (super_type->name, c->name) == 0) - c->attr.access = super_type->attr.access; - - /* If this type is an extension, see if this component has the same name - as an inherited type-bound procedure. */ - if (super_type && !sym->attr.is_class - && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) - { - gfc_error ("Component %qs of %qs at %L has the same name as an" - " inherited type-bound procedure", - c->name, sym->name, &c->loc); - return false; - } - - if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer - && !c->ts.deferred) - { - if (c->ts.u.cl->length == NULL - || (!resolve_charlen(c->ts.u.cl)) - || !gfc_is_constant_expr (c->ts.u.cl->length)) - { - gfc_error ("Character length of component %qs needs to " - "be a constant specification expression at %L", - c->name, - c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); - return false; - } - } - - if (c->ts.type == BT_CHARACTER && c->ts.deferred - && !c->attr.pointer && !c->attr.allocatable) - { - gfc_error ("Character component %qs of %qs at %L with deferred " - "length must be a POINTER or ALLOCATABLE", - c->name, sym->name, &c->loc); - return false; - } - - /* Add the hidden deferred length field. */ - if (c->ts.type == BT_CHARACTER - && (c->ts.deferred || c->attr.pdt_string) - && !c->attr.function - && !sym->attr.is_class) - { - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *strlen; - sprintf (name, "_%s_length", c->name); - strlen = gfc_find_component (sym, name, true, true, NULL); - if (strlen == NULL) - { - if (!gfc_add_component (sym, name, &strlen)) - return false; - strlen->ts.type = BT_INTEGER; - strlen->ts.kind = gfc_charlen_int_kind; - strlen->attr.access = ACCESS_PRIVATE; - strlen->attr.artificial = 1; - } - } - - if (c->ts.type == BT_DERIVED - && sym->component_access != ACCESS_PRIVATE - && gfc_check_symbol_access (sym) - && !is_sym_host_assoc (c->ts.u.derived, sym->ns) - && !c->ts.u.derived->attr.use_assoc - && !gfc_check_symbol_access (c->ts.u.derived) - && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " - "PRIVATE type and cannot be a component of " - "%qs, which is PUBLIC at %L", c->name, - sym->name, &sym->declared_at)) - return false; - - if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) - { - gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " - "type %s", c->name, &c->loc, sym->name); - return false; - } - - if (sym->attr.sequence) - { - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) - { - gfc_error ("Component %s of SEQUENCE type declared at %L does " - "not have the SEQUENCE attribute", - c->ts.u.derived->name, &sym->declared_at); - return false; - } - } - - if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) - c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); - else if (c->ts.type == BT_CLASS && c->attr.class_ok - && CLASS_DATA (c)->ts.u.derived->attr.generic) - CLASS_DATA (c)->ts.u.derived - = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); - - /* If an allocatable component derived type is of the same type as - the enclosing derived type, we need a vtable generating so that - the __deallocate procedure is created. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived == sym && c->attr.allocatable == 1) - gfc_find_vtab (&c->ts); - - /* Ensure that all the derived type components are put on the - derived type list; even in formal namespaces, where derived type - pointer components might not have been declared. */ - if (c->ts.type == BT_DERIVED - && c->ts.u.derived - && c->ts.u.derived->components - && c->attr.pointer - && sym != c->ts.u.derived) - add_dt_to_dt_list (c->ts.u.derived); - - if (c->as && c->as->type != AS_DEFERRED - && (c->attr.pointer || c->attr.allocatable)) - return false; - - if (!gfc_resolve_array_spec (c->as, - !(c->attr.pointer || c->attr.proc_pointer - || c->attr.allocatable))) - return false; - - if (c->initializer && !sym->attr.vtype - && !c->attr.pdt_kind && !c->attr.pdt_len - && !gfc_check_assign_symbol (sym, c, c->initializer)) - return false; - - return true; -} - - -/* Be nice about the locus for a structure expression - show the locus of the - first non-null sub-expression if we can. */ - -static locus * -cons_where (gfc_expr *struct_expr) -{ - gfc_constructor *cons; - - gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE); - - cons = gfc_constructor_first (struct_expr->value.constructor); - for (; cons; cons = gfc_constructor_next (cons)) - { - if (cons->expr && cons->expr->expr_type != EXPR_NULL) - return &cons->expr->where; - } - - return &struct_expr->where; -} - -/* Resolve the components of a structure type. Much less work than derived - types. */ - -static bool -resolve_fl_struct (gfc_symbol *sym) -{ - gfc_component *c; - gfc_expr *init = NULL; - bool success; - - /* Make sure UNIONs do not have overlapping initializers. */ - if (sym->attr.flavor == FL_UNION) - { - for (c = sym->components; c; c = c->next) - { - if (init && c->initializer) - { - gfc_error ("Conflicting initializers in union at %L and %L", - cons_where (init), cons_where (c->initializer)); - gfc_free_expr (c->initializer); - c->initializer = NULL; - } - if (init == NULL) - init = c->initializer; - } - } - - success = true; - for (c = sym->components; c; c = c->next) - if (!resolve_component (c, sym)) - success = false; - - if (!success) - return false; - - if (sym->components) - add_dt_to_dt_list (sym); - - return true; -} - - -/* Resolve the components of a derived type. This does not have to wait until - resolution stage, but can be done as soon as the dt declaration has been - parsed. */ - -static bool -resolve_fl_derived0 (gfc_symbol *sym) -{ - gfc_symbol* super_type; - gfc_component *c; - gfc_formal_arglist *f; - bool success; - - if (sym->attr.unlimited_polymorphic) - return true; - - super_type = gfc_get_derived_super_type (sym); - - /* F2008, C432. */ - if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) - { - gfc_error ("As extending type %qs at %L has a coarray component, " - "parent type %qs shall also have one", sym->name, - &sym->declared_at, super_type->name); - return false; - } - - /* Ensure the extended type gets resolved before we do. */ - if (super_type && !resolve_fl_derived0 (super_type)) - return false; - - /* An ABSTRACT type must be extensible. */ - if (sym->attr.abstract && !gfc_type_is_extensible (sym)) - { - gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", - sym->name, &sym->declared_at); - return false; - } - - c = (sym->attr.is_class) ? sym->components->ts.u.derived->components - : sym->components; - - success = true; - for ( ; c != NULL; c = c->next) - if (!resolve_component (c, sym)) - success = false; - - if (!success) - return false; - - /* Now add the caf token field, where needed. */ - if (flag_coarray != GFC_FCOARRAY_NONE - && !sym->attr.is_class && !sym->attr.vtype) - { - for (c = sym->components; c; c = c->next) - if (!c->attr.dimension && !c->attr.codimension - && (c->attr.allocatable || c->attr.pointer)) - { - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *token; - sprintf (name, "_caf_%s", c->name); - token = gfc_find_component (sym, name, true, true, NULL); - if (token == NULL) - { - if (!gfc_add_component (sym, name, &token)) - return false; - token->ts.type = BT_VOID; - token->ts.kind = gfc_default_integer_kind; - token->attr.access = ACCESS_PRIVATE; - token->attr.artificial = 1; - token->attr.caf_token = 1; - } - } - } - - check_defined_assignments (sym); - - if (!sym->attr.defined_assign_comp && super_type) - sym->attr.defined_assign_comp - = super_type->attr.defined_assign_comp; - - /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that - all DEFERRED bindings are overridden. */ - if (super_type && super_type->attr.abstract && !sym->attr.abstract - && !sym->attr.is_class - && !ensure_not_abstract (sym, super_type)) - return false; - - /* Check that there is a component for every PDT parameter. */ - if (sym->attr.pdt_template) - { - for (f = sym->formal; f; f = f->next) - { - if (!f->sym) - continue; - c = gfc_find_component (sym, f->sym->name, true, true, NULL); - if (c == NULL) - { - gfc_error ("Parameterized type %qs does not have a component " - "corresponding to parameter %qs at %L", sym->name, - f->sym->name, &sym->declared_at); - break; - } - } - } - - /* Add derived type to the derived type list. */ - add_dt_to_dt_list (sym); - - return true; -} - - -/* The following procedure does the full resolution of a derived type, - including resolution of all type-bound procedures (if present). In contrast - to 'resolve_fl_derived0' this can only be done after the module has been - parsed completely. */ - -static bool -resolve_fl_derived (gfc_symbol *sym) -{ - gfc_symbol *gen_dt = NULL; - - if (sym->attr.unlimited_polymorphic) - return true; - - if (!sym->attr.is_class) - gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); - if (gen_dt && gen_dt->generic && gen_dt->generic->next - && (!gen_dt->generic->sym->attr.use_assoc - || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) - && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function " - "%qs at %L being the same name as derived " - "type at %L", sym->name, - gen_dt->generic->sym == sym - ? gen_dt->generic->next->sym->name - : gen_dt->generic->sym->name, - gen_dt->generic->sym == sym - ? &gen_dt->generic->next->sym->declared_at - : &gen_dt->generic->sym->declared_at, - &sym->declared_at)) - return false; - - if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc) - { - gfc_error ("Derived type %qs at %L has not been declared", - sym->name, &sym->declared_at); - return false; - } - - /* Resolve the finalizer procedures. */ - if (!gfc_resolve_finalizers (sym, NULL)) - return false; - - if (sym->attr.is_class && sym->ts.u.derived == NULL) - { - /* Fix up incomplete CLASS symbols. */ - gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL); - gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL); - - /* Nothing more to do for unlimited polymorphic entities. */ - if (data->ts.u.derived->attr.unlimited_polymorphic) - return true; - else if (vptr->ts.u.derived == NULL) - { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); - gcc_assert (vtab); - vptr->ts.u.derived = vtab->ts.u.derived; - if (!resolve_fl_derived0 (vptr->ts.u.derived)) - return false; - } - } - - if (!resolve_fl_derived0 (sym)) - return false; - - /* Resolve the type-bound procedures. */ - if (!resolve_typebound_procedures (sym)) - return false; - - /* Generate module vtables subject to their accessibility and their not - being vtables or pdt templates. If this is not done class declarations - in external procedures wind up with their own version and so SELECT TYPE - fails because the vptrs do not have the same address. */ - if (gfc_option.allow_std & GFC_STD_F2003 - && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE - && sym->attr.access != ACCESS_PRIVATE - && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template)) - { - gfc_symbol *vtab = gfc_find_derived_vtab (sym); - gfc_set_sym_referenced (vtab); - } - - return true; -} - - -static bool -resolve_fl_namelist (gfc_symbol *sym) -{ - gfc_namelist *nl; - gfc_symbol *nlsym; - - for (nl = sym->namelist; nl; nl = nl->next) - { - /* Check again, the check in match only works if NAMELIST comes - after the decl. */ - if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE) - { - gfc_error ("Assumed size array %qs in namelist %qs at %L is not " - "allowed", nl->sym->name, sym->name, &sym->declared_at); - return false; - } - - if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE - && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " - "with assumed shape in namelist %qs at %L", - nl->sym->name, sym->name, &sym->declared_at)) - return false; - - if (is_non_constant_shape_array (nl->sym) - && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " - "with nonconstant shape in namelist %qs at %L", - nl->sym->name, sym->name, &sym->declared_at)) - return false; - - if (nl->sym->ts.type == BT_CHARACTER - && (nl->sym->ts.u.cl->length == NULL - || !gfc_is_constant_expr (nl->sym->ts.u.cl->length)) - && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with " - "nonconstant character length in " - "namelist %qs at %L", nl->sym->name, - sym->name, &sym->declared_at)) - return false; - - } - - /* Reject PRIVATE objects in a PUBLIC namelist. */ - if (gfc_check_symbol_access (sym)) - { - for (nl = sym->namelist; nl; nl = nl->next) - { - if (!nl->sym->attr.use_assoc - && !is_sym_host_assoc (nl->sym, sym->ns) - && !gfc_check_symbol_access (nl->sym)) - { - gfc_error ("NAMELIST object %qs was declared PRIVATE and " - "cannot be member of PUBLIC namelist %qs at %L", - nl->sym->name, sym->name, &sym->declared_at); - return false; - } - - if (nl->sym->ts.type == BT_DERIVED - && (nl->sym->ts.u.derived->attr.alloc_comp - || nl->sym->ts.u.derived->attr.pointer_comp)) - { - if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " - "namelist %qs at %L with ALLOCATABLE " - "or POINTER components", nl->sym->name, - sym->name, &sym->declared_at)) - return false; - return true; - } - - /* Types with private components that came here by USE-association. */ - if (nl->sym->ts.type == BT_DERIVED - && derived_inaccessible (nl->sym->ts.u.derived)) - { - gfc_error ("NAMELIST object %qs has use-associated PRIVATE " - "components and cannot be member of namelist %qs at %L", - nl->sym->name, sym->name, &sym->declared_at); - return false; - } - - /* Types with private components that are defined in the same module. */ - if (nl->sym->ts.type == BT_DERIVED - && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns) - && nl->sym->ts.u.derived->attr.private_comp) - { - gfc_error ("NAMELIST object %qs has PRIVATE components and " - "cannot be a member of PUBLIC namelist %qs at %L", - nl->sym->name, sym->name, &sym->declared_at); - return false; - } - } - } - - - /* 14.1.2 A module or internal procedure represent local entities - of the same type as a namelist member and so are not allowed. */ - for (nl = sym->namelist; nl; nl = nl->next) - { - if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE) - continue; - - if (nl->sym->attr.function && nl->sym == nl->sym->result) - if ((nl->sym == sym->ns->proc_name) - || - (sym->ns->parent && nl->sym == sym->ns->parent->proc_name)) - continue; - - nlsym = NULL; - if (nl->sym->name) - gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym); - if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) - { - gfc_error ("PROCEDURE attribute conflicts with NAMELIST " - "attribute in %qs at %L", nlsym->name, - &sym->declared_at); - return false; - } - } - - return true; -} - - -static bool -resolve_fl_parameter (gfc_symbol *sym) -{ - /* A parameter array's shape needs to be constant. */ - if (sym->as != NULL - && (sym->as->type == AS_DEFERRED - || is_non_constant_shape_array (sym))) - { - gfc_error ("Parameter array %qs at %L cannot be automatic " - "or of deferred shape", sym->name, &sym->declared_at); - return false; - } - - /* Constraints on deferred type parameter. */ - if (!deferred_requirements (sym)) - return false; - - /* Make sure a parameter that has been implicitly typed still - matches the implicit type, since PARAMETER statements can precede - IMPLICIT statements. */ - if (sym->attr.implicit_type - && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name, - sym->ns))) - { - gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a " - "later IMPLICIT type", sym->name, &sym->declared_at); - return false; - } - - /* Make sure the types of derived parameters are consistent. This - type checking is deferred until resolution because the type may - refer to a derived type from the host. */ - if (sym->ts.type == BT_DERIVED - && !gfc_compare_types (&sym->ts, &sym->value->ts)) - { - gfc_error ("Incompatible derived type in PARAMETER at %L", - &sym->value->where); - return false; - } - - /* F03:C509,C514. */ - if (sym->ts.type == BT_CLASS) - { - gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute", - sym->name, &sym->declared_at); - return false; - } - - return true; -} - - -/* Called by resolve_symbol to check PDTs. */ - -static void -resolve_pdt (gfc_symbol* sym) -{ - gfc_symbol *derived = NULL; - gfc_actual_arglist *param; - gfc_component *c; - bool const_len_exprs = true; - bool assumed_len_exprs = false; - symbol_attribute *attr; - - if (sym->ts.type == BT_DERIVED) - { - derived = sym->ts.u.derived; - attr = &(sym->attr); - } - else if (sym->ts.type == BT_CLASS) - { - derived = CLASS_DATA (sym)->ts.u.derived; - attr = &(CLASS_DATA (sym)->attr); - } - else - gcc_unreachable (); - - gcc_assert (derived->attr.pdt_type); - - for (param = sym->param_list; param; param = param->next) - { - c = gfc_find_component (derived, param->name, false, true, NULL); - gcc_assert (c); - if (c->attr.pdt_kind) - continue; - - if (param->expr && !gfc_is_constant_expr (param->expr) - && c->attr.pdt_len) - const_len_exprs = false; - else if (param->spec_type == SPEC_ASSUMED) - assumed_len_exprs = true; - - if (param->spec_type == SPEC_DEFERRED - && !attr->allocatable && !attr->pointer) - gfc_error ("The object %qs at %L has a deferred LEN " - "parameter %qs and is neither allocatable " - "nor a pointer", sym->name, &sym->declared_at, - param->name); - - } - - if (!const_len_exprs - && (sym->ns->proc_name->attr.is_main_program - || sym->ns->proc_name->attr.flavor == FL_MODULE - || sym->attr.save != SAVE_NONE)) - gfc_error ("The AUTOMATIC object %qs at %L must not have the " - "SAVE attribute or be a variable declared in the " - "main program, a module or a submodule(F08/C513)", - sym->name, &sym->declared_at); - - if (assumed_len_exprs && !(sym->attr.dummy - || sym->attr.select_type_temporary || sym->attr.associate_var)) - gfc_error ("The object %qs at %L with ASSUMED type parameters " - "must be a dummy or a SELECT TYPE selector(F08/4.2)", - sym->name, &sym->declared_at); -} - - -/* Do anything necessary to resolve a symbol. Right now, we just - assume that an otherwise unknown symbol is a variable. This sort - of thing commonly happens for symbols in module. */ - -static void -resolve_symbol (gfc_symbol *sym) -{ - int check_constant, mp_flag; - gfc_symtree *symtree; - gfc_symtree *this_symtree; - gfc_namespace *ns; - gfc_component *c; - symbol_attribute class_attr; - gfc_array_spec *as; - bool saved_specification_expr; - - if (sym->resolve_symbol_called >= 1) - return; - sym->resolve_symbol_called = 1; - - /* No symbol will ever have union type; only components can be unions. - Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION - (just like derived type declaration symbols have flavor FL_DERIVED). */ - gcc_assert (sym->ts.type != BT_UNION); - - /* Coarrayed polymorphic objects with allocatable or pointer components are - yet unsupported for -fcoarray=lib. */ - if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS - && sym->ts.u.derived && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.codimension - && CLASS_DATA (sym)->ts.u.derived - && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp - || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp)) - { - gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) " - "type coarrays at %L are unsupported", &sym->declared_at); - return; - } - - if (sym->attr.artificial) - return; - - if (sym->attr.unlimited_polymorphic) - return; - - if (sym->attr.flavor == FL_UNKNOWN - || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic - && !sym->attr.generic && !sym->attr.external - && sym->attr.if_source == IFSRC_UNKNOWN - && sym->ts.type == BT_UNKNOWN)) - { - - /* If we find that a flavorless symbol is an interface in one of the - parent namespaces, find its symtree in this namespace, free the - symbol and set the symtree to point to the interface symbol. */ - for (ns = gfc_current_ns->parent; ns; ns = ns->parent) - { - symtree = gfc_find_symtree (ns->sym_root, sym->name); - if (symtree && (symtree->n.sym->generic || - (symtree->n.sym->attr.flavor == FL_PROCEDURE - && sym->ns->construct_entities))) - { - this_symtree = gfc_find_symtree (gfc_current_ns->sym_root, - sym->name); - if (this_symtree->n.sym == sym) - { - symtree->n.sym->refs++; - gfc_release_symbol (sym); - this_symtree->n.sym = symtree->n.sym; - return; - } - } - } - - /* Otherwise give it a flavor according to such attributes as - it has. */ - if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0 - && sym->attr.intrinsic == 0) - sym->attr.flavor = FL_VARIABLE; - else if (sym->attr.flavor == FL_UNKNOWN) - { - sym->attr.flavor = FL_PROCEDURE; - if (sym->attr.dimension) - sym->attr.function = 1; - } - } - - if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function) - gfc_add_function (&sym->attr, sym->name, &sym->declared_at); - - if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL - && !resolve_procedure_interface (sym)) - return; - - if (sym->attr.is_protected && !sym->attr.proc_pointer - && (sym->attr.procedure || sym->attr.external)) - { - if (sym->attr.external) - gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute " - "at %L", &sym->declared_at); - else - gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute " - "at %L", &sym->declared_at); - - return; - } - - if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym)) - return; - - else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION) - && !resolve_fl_struct (sym)) - return; - - /* Symbols that are module procedures with results (functions) have - the types and array specification copied for type checking in - procedures that call them, as well as for saving to a module - file. These symbols can't stand the scrutiny that their results - can. */ - mp_flag = (sym->result != NULL && sym->result != sym); - - /* Make sure that the intrinsic is consistent with its internal - representation. This needs to be done before assigning a default - type to avoid spurious warnings. */ - if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic - && !gfc_resolve_intrinsic (sym, &sym->declared_at)) - return; - - /* Resolve associate names. */ - if (sym->assoc) - resolve_assoc_var (sym, true); - - /* Assign default type to symbols that need one and don't have one. */ - if (sym->ts.type == BT_UNKNOWN) - { - if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER) - { - gfc_set_default_type (sym, 1, NULL); - } - - if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external - && !sym->attr.function && !sym->attr.subroutine - && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN) - gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at); - - if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function) - { - /* The specific case of an external procedure should emit an error - in the case that there is no implicit type. */ - if (!mp_flag) - { - if (!sym->attr.mixed_entry_master) - gfc_set_default_type (sym, sym->attr.external, NULL); - } - else - { - /* Result may be in another namespace. */ - resolve_symbol (sym->result); - - if (!sym->result->attr.proc_pointer) - { - sym->ts = sym->result->ts; - sym->as = gfc_copy_array_spec (sym->result->as); - sym->attr.dimension = sym->result->attr.dimension; - sym->attr.pointer = sym->result->attr.pointer; - sym->attr.allocatable = sym->result->attr.allocatable; - sym->attr.contiguous = sym->result->attr.contiguous; - } - } - } - } - else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function) - { - bool saved_specification_expr = specification_expr; - bool saved_formal_arg_flag = formal_arg_flag; - - specification_expr = true; - formal_arg_flag = true; - gfc_resolve_array_spec (sym->result->as, false); - formal_arg_flag = saved_formal_arg_flag; - specification_expr = saved_specification_expr; - } - - if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) - { - as = CLASS_DATA (sym)->as; - class_attr = CLASS_DATA (sym)->attr; - class_attr.pointer = class_attr.class_pointer; - } - else - { - class_attr = sym->attr; - as = sym->as; - } - - /* F2008, C530. */ - if (sym->attr.contiguous - && (!class_attr.dimension - || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK - && !class_attr.pointer))) - { - gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an " - "array pointer or an assumed-shape or assumed-rank array", - sym->name, &sym->declared_at); - return; - } - - /* Assumed size arrays and assumed shape arrays must be dummy - arguments. Array-spec's of implied-shape should have been resolved to - AS_EXPLICIT already. */ - - if (as) - { - /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad - specification expression. */ - if (as->type == AS_IMPLIED_SHAPE) - { - int i; - for (i=0; irank; i++) - { - if (as->lower[i] != NULL && as->upper[i] == NULL) - { - gfc_error ("Bad specification for assumed size array at %L", - &as->lower[i]->where); - return; - } - } - gcc_unreachable(); - } - - if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed) - || as->type == AS_ASSUMED_SHAPE) - && !sym->attr.dummy && !sym->attr.select_type_temporary) - { - if (as->type == AS_ASSUMED_SIZE) - gfc_error ("Assumed size array at %L must be a dummy argument", - &sym->declared_at); - else - gfc_error ("Assumed shape array at %L must be a dummy argument", - &sym->declared_at); - return; - } - /* TS 29113, C535a. */ - if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy - && !sym->attr.select_type_temporary - && !(cs_base && cs_base->current - && cs_base->current->op == EXEC_SELECT_RANK)) - { - gfc_error ("Assumed-rank array at %L must be a dummy argument", - &sym->declared_at); - return; - } - if (as->type == AS_ASSUMED_RANK - && (sym->attr.codimension || sym->attr.value)) - { - gfc_error ("Assumed-rank array at %L may not have the VALUE or " - "CODIMENSION attribute", &sym->declared_at); - return; - } - } - - /* Make sure symbols with known intent or optional are really dummy - variable. Because of ENTRY statement, this has to be deferred - until resolution time. */ - - if (!sym->attr.dummy - && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN)) - { - gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at); - return; - } - - if (sym->attr.value && !sym->attr.dummy) - { - gfc_error ("%qs at %L cannot have the VALUE attribute because " - "it is not a dummy argument", sym->name, &sym->declared_at); - return; - } - - if (sym->attr.value && sym->ts.type == BT_CHARACTER) - { - gfc_charlen *cl = sym->ts.u.cl; - if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) - { - gfc_error ("Character dummy variable %qs at %L with VALUE " - "attribute must have constant length", - sym->name, &sym->declared_at); - return; - } - - if (sym->ts.is_c_interop - && mpz_cmp_si (cl->length->value.integer, 1) != 0) - { - gfc_error ("C interoperable character dummy variable %qs at %L " - "with VALUE attribute must have length one", - sym->name, &sym->declared_at); - return; - } - } - - if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c - && sym->ts.u.derived->attr.generic) - { - sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); - if (!sym->ts.u.derived) - { - gfc_error ("The derived type %qs at %L is of type %qs, " - "which has not been defined", sym->name, - &sym->declared_at, sym->ts.u.derived->name); - sym->ts.type = BT_UNKNOWN; - return; - } - } - - /* Use the same constraints as TYPE(*), except for the type check - and that only scalars and assumed-size arrays are permitted. */ - if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) - { - if (!sym->attr.dummy) - { - gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " - "a dummy argument", sym->name, &sym->declared_at); - return; - } - - if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER - && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL - && sym->ts.type != BT_COMPLEX) - { - gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " - "of type TYPE(*) or of an numeric intrinsic type", - sym->name, &sym->declared_at); - return; - } - - if (sym->attr.allocatable || sym->attr.codimension - || sym->attr.pointer || sym->attr.value) - { - gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " - "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE " - "attribute", sym->name, &sym->declared_at); - return; - } - - if (sym->attr.intent == INTENT_OUT) - { - gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " - "have the INTENT(OUT) attribute", - sym->name, &sym->declared_at); - return; - } - if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE) - { - gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall " - "either be a scalar or an assumed-size array", - sym->name, &sym->declared_at); - return; - } - - /* Set the type to TYPE(*) and add a dimension(*) to ensure - NO_ARG_CHECK is correctly handled in trans*.c, e.g. with - packing. */ - sym->ts.type = BT_ASSUMED; - sym->as = gfc_get_array_spec (); - sym->as->type = AS_ASSUMED_SIZE; - sym->as->rank = 1; - sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - } - else if (sym->ts.type == BT_ASSUMED) - { - /* TS 29113, C407a. */ - if (!sym->attr.dummy) - { - gfc_error ("Assumed type of variable %s at %L is only permitted " - "for dummy variables", sym->name, &sym->declared_at); - return; - } - if (sym->attr.allocatable || sym->attr.codimension - || sym->attr.pointer || sym->attr.value) - { - gfc_error ("Assumed-type variable %s at %L may not have the " - "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute", - sym->name, &sym->declared_at); - return; - } - if (sym->attr.intent == INTENT_OUT) - { - gfc_error ("Assumed-type variable %s at %L may not have the " - "INTENT(OUT) attribute", - sym->name, &sym->declared_at); - return; - } - if (sym->attr.dimension && sym->as->type == AS_EXPLICIT) - { - gfc_error ("Assumed-type variable %s at %L shall not be an " - "explicit-shape array", sym->name, &sym->declared_at); - return; - } - } - - /* If the symbol is marked as bind(c), that it is declared at module level - scope and verify its type and kind. Do not do the latter for symbols - that are implicitly typed because that is handled in - gfc_set_default_type. Handle dummy arguments and procedure definitions - separately. Also, anything that is use associated is not handled here - but instead is handled in the module it is declared in. Finally, derived - type definitions are allowed to be BIND(C) since that only implies that - they're interoperable, and they are checked fully for interoperability - when a variable is declared of that type. */ - if (sym->attr.is_bind_c && sym->attr.use_assoc == 0 - && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE - && sym->attr.flavor != FL_DERIVED) - { - bool t = true; - - /* First, make sure the variable is declared at the - module-level scope (J3/04-007, Section 15.3). */ - if (sym->ns->proc_name->attr.flavor != FL_MODULE && - sym->attr.in_common == 0) - { - gfc_error ("Variable %qs at %L cannot be BIND(C) because it " - "is neither a COMMON block nor declared at the " - "module level scope", sym->name, &(sym->declared_at)); - t = false; - } - else if (sym->ts.type == BT_CHARACTER - && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL - || !gfc_is_constant_expr (sym->ts.u.cl->length) - || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0)) - { - gfc_error ("BIND(C) Variable %qs at %L must have length one", - sym->name, &sym->declared_at); - t = false; - } - else if (sym->common_head != NULL && sym->attr.implicit_type == 0) - { - t = verify_com_block_vars_c_interop (sym->common_head); - } - else if (sym->attr.implicit_type == 0) - { - /* If type() declaration, we need to verify that the components - of the given type are all C interoperable, etc. */ - if (sym->ts.type == BT_DERIVED && - sym->ts.u.derived->attr.is_c_interop != 1) - { - /* Make sure the user marked the derived type as BIND(C). If - not, call the verify routine. This could print an error - for the derived type more than once if multiple variables - of that type are declared. */ - if (sym->ts.u.derived->attr.is_bind_c != 1) - verify_bind_c_derived_type (sym->ts.u.derived); - t = false; - } - - /* Verify the variable itself as C interoperable if it - is BIND(C). It is not possible for this to succeed if - the verify_bind_c_derived_type failed, so don't have to handle - any error returned by verify_bind_c_derived_type. */ - t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, - sym->common_block); - } - - if (!t) - { - /* clear the is_bind_c flag to prevent reporting errors more than - once if something failed. */ - sym->attr.is_bind_c = 0; - return; - } - } - - /* If a derived type symbol has reached this point, without its - type being declared, we have an error. Notice that most - conditions that produce undefined derived types have already - been dealt with. However, the likes of: - implicit type(t) (t) ..... call foo (t) will get us here if - the type is not declared in the scope of the implicit - statement. Change the type to BT_UNKNOWN, both because it is so - and to prevent an ICE. */ - if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c - && sym->ts.u.derived->components == NULL - && !sym->ts.u.derived->attr.zero_comp) - { - gfc_error ("The derived type %qs at %L is of type %qs, " - "which has not been defined", sym->name, - &sym->declared_at, sym->ts.u.derived->name); - sym->ts.type = BT_UNKNOWN; - return; - } - - /* Make sure that the derived type has been resolved and that the - derived type is visible in the symbol's namespace, if it is a - module function and is not PRIVATE. */ - if (sym->ts.type == BT_DERIVED - && sym->ts.u.derived->attr.use_assoc - && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE - && !resolve_fl_derived (sym->ts.u.derived)) - return; - - /* Unless the derived-type declaration is use associated, Fortran 95 - does not allow public entries of private derived types. - See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation - 161 in 95-006r3. */ - if (sym->ts.type == BT_DERIVED - && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE - && !sym->ts.u.derived->attr.use_assoc - && gfc_check_symbol_access (sym) - && !gfc_check_symbol_access (sym->ts.u.derived) - && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE " - "derived type %qs", - (sym->attr.flavor == FL_PARAMETER) - ? "parameter" : "variable", - sym->name, &sym->declared_at, - sym->ts.u.derived->name)) - return; - - /* F2008, C1302. */ - if (sym->ts.type == BT_DERIVED - && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) - || sym->ts.u.derived->attr.lock_comp) - && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) - { - gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of " - "type LOCK_TYPE must be a coarray", sym->name, - &sym->declared_at); - return; - } - - /* TS18508, C702/C703. */ - if (sym->ts.type == BT_DERIVED - && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) - || sym->ts.u.derived->attr.event_comp) - && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) - { - gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of " - "type EVENT_TYPE must be a coarray", sym->name, - &sym->declared_at); - return; - } - - /* An assumed-size array with INTENT(OUT) shall not be of a type for which - default initialization is defined (5.1.2.4.4). */ - if (sym->ts.type == BT_DERIVED - && sym->attr.dummy - && sym->attr.intent == INTENT_OUT - && sym->as - && sym->as->type == AS_ASSUMED_SIZE) - { - for (c = sym->ts.u.derived->components; c; c = c->next) - { - if (c->initializer) - { - gfc_error ("The INTENT(OUT) dummy argument %qs at %L is " - "ASSUMED SIZE and so cannot have a default initializer", - sym->name, &sym->declared_at); - return; - } - } - } - - /* F2008, C542. */ - if (sym->ts.type == BT_DERIVED && sym->attr.dummy - && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp) - { - gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be " - "INTENT(OUT)", sym->name, &sym->declared_at); - return; - } - - /* TS18508. */ - if (sym->ts.type == BT_DERIVED && sym->attr.dummy - && sym->attr.intent == INTENT_OUT && sym->attr.event_comp) - { - gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be " - "INTENT(OUT)", sym->name, &sym->declared_at); - return; - } - - /* F2008, C525. */ - if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) - || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.coarray_comp)) - || class_attr.codimension) - && (sym->attr.result || sym->result == sym)) - { - gfc_error ("Function result %qs at %L shall not be a coarray or have " - "a coarray component", sym->name, &sym->declared_at); - return; - } - - /* F2008, C524. */ - if (sym->attr.codimension && sym->ts.type == BT_DERIVED - && sym->ts.u.derived->ts.is_iso_c) - { - gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " - "shall not be a coarray", sym->name, &sym->declared_at); - return; - } - - /* F2008, C525. */ - if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) - || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.coarray_comp)) - && (class_attr.codimension || class_attr.pointer || class_attr.dimension - || class_attr.allocatable)) - { - gfc_error ("Variable %qs at %L with coarray component shall be a " - "nonpointer, nonallocatable scalar, which is not a coarray", - sym->name, &sym->declared_at); - return; - } - - /* F2008, C526. The function-result case was handled above. */ - if (class_attr.codimension - && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save - || sym->attr.select_type_temporary - || sym->attr.associate_var - || (sym->ns->save_all && !sym->attr.automatic) - || sym->ns->proc_name->attr.flavor == FL_MODULE - || sym->ns->proc_name->attr.is_main_program - || sym->attr.function || sym->attr.result || sym->attr.use_assoc)) - { - gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE " - "nor a dummy argument", sym->name, &sym->declared_at); - return; - } - /* F2008, C528. */ - else if (class_attr.codimension && !sym->attr.select_type_temporary - && !class_attr.allocatable && as && as->cotype == AS_DEFERRED) - { - gfc_error ("Coarray variable %qs at %L shall not have codimensions with " - "deferred shape", sym->name, &sym->declared_at); - return; - } - else if (class_attr.codimension && class_attr.allocatable && as - && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED)) - { - gfc_error ("Allocatable coarray variable %qs at %L must have " - "deferred shape", sym->name, &sym->declared_at); - return; - } - - /* F2008, C541. */ - if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) - || (sym->ts.type == BT_CLASS && sym->attr.class_ok - && sym->ts.u.derived && CLASS_DATA (sym) - && CLASS_DATA (sym)->attr.coarray_comp)) - || (class_attr.codimension && class_attr.allocatable)) - && sym->attr.dummy && sym->attr.intent == INTENT_OUT) - { - gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an " - "allocatable coarray or have coarray components", - sym->name, &sym->declared_at); - return; - } - - if (class_attr.codimension && sym->attr.dummy - && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) - { - gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) " - "procedure %qs", sym->name, &sym->declared_at, - sym->ns->proc_name->name); - return; - } - - if (sym->ts.type == BT_LOGICAL - && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym) - || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name - && sym->ns->proc_name->attr.is_bind_c))) - { - int i; - for (i = 0; gfc_logical_kinds[i].kind; i++) - if (gfc_logical_kinds[i].kind == sym->ts.kind) - break; - if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy - && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at " - "%L with non-C_Bool kind in BIND(C) procedure " - "%qs", sym->name, &sym->declared_at, - sym->ns->proc_name->name)) - return; - else if (!gfc_logical_kinds[i].c_bool - && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable " - "%qs at %L with non-C_Bool kind in " - "BIND(C) procedure %qs", sym->name, - &sym->declared_at, - sym->attr.function ? sym->name - : sym->ns->proc_name->name)) - return; - } - - switch (sym->attr.flavor) - { - case FL_VARIABLE: - if (!resolve_fl_variable (sym, mp_flag)) - return; - break; - - case FL_PROCEDURE: - if (sym->formal && !sym->formal_ns) - { - /* Check that none of the arguments are a namelist. */ - gfc_formal_arglist *formal = sym->formal; - - for (; formal; formal = formal->next) - if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST) - { - gfc_error ("Namelist %qs cannot be an argument to " - "subroutine or function at %L", - formal->sym->name, &sym->declared_at); - return; - } - } - - if (!resolve_fl_procedure (sym, mp_flag)) - return; - break; - - case FL_NAMELIST: - if (!resolve_fl_namelist (sym)) - return; - break; - - case FL_PARAMETER: - if (!resolve_fl_parameter (sym)) - return; - break; - - default: - break; - } - - /* Resolve array specifier. Check as well some constraints - on COMMON blocks. */ - - check_constant = sym->attr.in_common && !sym->attr.pointer; - - /* Set the formal_arg_flag so that check_conflict will not throw - an error for host associated variables in the specification - expression for an array_valued function. */ - if ((sym->attr.function || sym->attr.result) && sym->as) - formal_arg_flag = true; - - saved_specification_expr = specification_expr; - specification_expr = true; - gfc_resolve_array_spec (sym->as, check_constant); - specification_expr = saved_specification_expr; - - formal_arg_flag = false; - - /* Resolve formal namespaces. */ - if (sym->formal_ns && sym->formal_ns != gfc_current_ns - && !sym->attr.contained && !sym->attr.intrinsic) - gfc_resolve (sym->formal_ns); - - /* Make sure the formal namespace is present. */ - if (sym->formal && !sym->formal_ns) - { - gfc_formal_arglist *formal = sym->formal; - while (formal && !formal->sym) - formal = formal->next; - - if (formal) - { - sym->formal_ns = formal->sym->ns; - if (sym->formal_ns && sym->ns != formal->sym->ns) - sym->formal_ns->refs++; - } - } - - /* Check threadprivate restrictions. */ - if (sym->attr.threadprivate - && !(sym->attr.save || sym->attr.data || sym->attr.in_common) - && !(sym->ns->save_all && !sym->attr.automatic) - && sym->module == NULL - && (sym->ns->proc_name == NULL - || (sym->ns->proc_name->attr.flavor != FL_MODULE - && !sym->ns->proc_name->attr.is_main_program))) - gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); - - /* Check omp declare target restrictions. */ - if (sym->attr.omp_declare_target - && sym->attr.flavor == FL_VARIABLE - && !sym->attr.save - && !(sym->ns->save_all && !sym->attr.automatic) - && (!sym->attr.in_common - && sym->module == NULL - && (sym->ns->proc_name == NULL - || (sym->ns->proc_name->attr.flavor != FL_MODULE - && !sym->ns->proc_name->attr.is_main_program)))) - gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd", - sym->name, &sym->declared_at); - - /* If we have come this far we can apply default-initializers, as - described in 14.7.5, to those variables that have not already - been assigned one. */ - if (sym->ts.type == BT_DERIVED - && !sym->value - && !sym->attr.allocatable - && !sym->attr.alloc_comp) - { - symbol_attribute *a = &sym->attr; - - if ((!a->save && !a->dummy && !a->pointer - && !a->in_common && !a->use_assoc - && a->referenced - && !((a->function || a->result) - && (!a->dimension - || sym->ts.u.derived->attr.alloc_comp - || sym->ts.u.derived->attr.pointer_comp)) - && !(a->function && sym != sym->result)) - || (a->dummy && !a->pointer && a->intent == INTENT_OUT - && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)) - apply_default_init (sym); - else if (a->function && sym->result && a->access != ACCESS_PRIVATE - && (sym->ts.u.derived->attr.alloc_comp - || sym->ts.u.derived->attr.pointer_comp)) - /* Mark the result symbol to be referenced, when it has allocatable - components. */ - sym->result->attr.referenced = 1; - } - - if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns - && sym->attr.dummy && sym->attr.intent == INTENT_OUT - && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY - && !CLASS_DATA (sym)->attr.class_pointer - && !CLASS_DATA (sym)->attr.allocatable) - apply_default_init (sym); - - /* If this symbol has a type-spec, check it. */ - if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER - || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) - if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)) - return; - - if (sym->param_list) - resolve_pdt (sym); -} - - -/************* Resolve DATA statements *************/ - -static struct -{ - gfc_data_value *vnode; - mpz_t left; -} -values; - - -/* Advance the values structure to point to the next value in the data list. */ - -static bool -next_data_value (void) -{ - while (mpz_cmp_ui (values.left, 0) == 0) - { - - if (values.vnode->next == NULL) - return false; - - values.vnode = values.vnode->next; - mpz_set (values.left, values.vnode->repeat); - } - - return true; -} - - -static bool -check_data_variable (gfc_data_variable *var, locus *where) -{ - gfc_expr *e; - mpz_t size; - mpz_t offset; - bool t; - ar_type mark = AR_UNKNOWN; - int i; - mpz_t section_index[GFC_MAX_DIMENSIONS]; - gfc_ref *ref; - gfc_array_ref *ar; - gfc_symbol *sym; - int has_pointer; - - if (!gfc_resolve_expr (var->expr)) - return false; - - ar = NULL; - mpz_init_set_si (offset, 0); - e = var->expr; - - if (e->expr_type == EXPR_FUNCTION && e->value.function.isym - && e->value.function.isym->id == GFC_ISYM_CAF_GET) - e = e->value.function.actual->expr; - - if (e->expr_type != EXPR_VARIABLE) - { - gfc_error ("Expecting definable entity near %L", where); - return false; - } - - sym = e->symtree->n.sym; - - if (sym->ns->is_block_data && !sym->attr.in_common) - { - gfc_error ("BLOCK DATA element %qs at %L must be in COMMON", - sym->name, &sym->declared_at); - return false; - } - - if (e->ref == NULL && sym->as) - { - gfc_error ("DATA array %qs at %L must be specified in a previous" - " declaration", sym->name, where); - return false; - } - - if (gfc_is_coindexed (e)) - { - gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name, - where); - return false; - } - - has_pointer = sym->attr.pointer; - - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) - has_pointer = 1; - - if (has_pointer) - { - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL) - { - gfc_error ("DATA element %qs at %L is a pointer and so must " - "be a full array", sym->name, where); - return false; - } - - if (values.vnode->expr->expr_type == EXPR_CONSTANT) - { - gfc_error ("DATA object near %L has the pointer attribute " - "and the corresponding DATA value is not a valid " - "initial-data-target", where); - return false; - } - } - - if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable) - { - gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE " - "attribute", ref->u.c.component->name, &e->where); - return false; - } - } - - if (e->rank == 0 || has_pointer) - { - mpz_init_set_ui (size, 1); - ref = NULL; - } - else - { - ref = e->ref; - - /* Find the array section reference. */ - for (ref = e->ref; ref; ref = ref->next) - { - if (ref->type != REF_ARRAY) - continue; - if (ref->u.ar.type == AR_ELEMENT) - continue; - break; - } - gcc_assert (ref); - - /* Set marks according to the reference pattern. */ - switch (ref->u.ar.type) - { - case AR_FULL: - mark = AR_FULL; - break; - - case AR_SECTION: - ar = &ref->u.ar; - /* Get the start position of array section. */ - gfc_get_section_index (ar, section_index, &offset); - mark = AR_SECTION; - break; - - default: - gcc_unreachable (); - } - - if (!gfc_array_size (e, &size)) - { - gfc_error ("Nonconstant array section at %L in DATA statement", - where); - mpz_clear (offset); - return false; - } - } - - t = true; - - while (mpz_cmp_ui (size, 0) > 0) - { - if (!next_data_value ()) - { - gfc_error ("DATA statement at %L has more variables than values", - where); - t = false; - break; - } - - t = gfc_check_assign (var->expr, values.vnode->expr, 0); - if (!t) - break; - - /* If we have more than one element left in the repeat count, - and we have more than one element left in the target variable, - then create a range assignment. */ - /* FIXME: Only done for full arrays for now, since array sections - seem tricky. */ - if (mark == AR_FULL && ref && ref->next == NULL - && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0) - { - mpz_t range; - - if (mpz_cmp (size, values.left) >= 0) - { - mpz_init_set (range, values.left); - mpz_sub (size, size, values.left); - mpz_set_ui (values.left, 0); - } - else - { - mpz_init_set (range, size); - mpz_sub (values.left, values.left, size); - mpz_set_ui (size, 0); - } - - t = gfc_assign_data_value (var->expr, values.vnode->expr, - offset, &range); - - mpz_add (offset, offset, range); - mpz_clear (range); - - if (!t) - break; - } - - /* Assign initial value to symbol. */ - else - { - mpz_sub_ui (values.left, values.left, 1); - mpz_sub_ui (size, size, 1); - - t = gfc_assign_data_value (var->expr, values.vnode->expr, - offset, NULL); - if (!t) - break; - - if (mark == AR_FULL) - mpz_add_ui (offset, offset, 1); - - /* Modify the array section indexes and recalculate the offset - for next element. */ - else if (mark == AR_SECTION) - gfc_advance_section (section_index, ar, &offset); - } - } - - if (mark == AR_SECTION) - { - for (i = 0; i < ar->dimen; i++) - mpz_clear (section_index[i]); - } - - mpz_clear (size); - mpz_clear (offset); - - return t; -} - - -static bool traverse_data_var (gfc_data_variable *, locus *); - -/* Iterate over a list of elements in a DATA statement. */ - -static bool -traverse_data_list (gfc_data_variable *var, locus *where) -{ - mpz_t trip; - iterator_stack frame; - gfc_expr *e, *start, *end, *step; - bool retval = true; - - mpz_init (frame.value); - mpz_init (trip); - - start = gfc_copy_expr (var->iter.start); - end = gfc_copy_expr (var->iter.end); - step = gfc_copy_expr (var->iter.step); - - if (!gfc_simplify_expr (start, 1) - || start->expr_type != EXPR_CONSTANT) - { - gfc_error ("start of implied-do loop at %L could not be " - "simplified to a constant value", &start->where); - retval = false; - goto cleanup; - } - if (!gfc_simplify_expr (end, 1) - || end->expr_type != EXPR_CONSTANT) - { - gfc_error ("end of implied-do loop at %L could not be " - "simplified to a constant value", &end->where); - retval = false; - goto cleanup; - } - if (!gfc_simplify_expr (step, 1) - || step->expr_type != EXPR_CONSTANT) - { - gfc_error ("step of implied-do loop at %L could not be " - "simplified to a constant value", &step->where); - retval = false; - goto cleanup; - } - if (mpz_cmp_si (step->value.integer, 0) == 0) - { - gfc_error ("step of implied-do loop at %L shall not be zero", - &step->where); - retval = false; - goto cleanup; - } - - mpz_set (trip, end->value.integer); - mpz_sub (trip, trip, start->value.integer); - mpz_add (trip, trip, step->value.integer); - - mpz_div (trip, trip, step->value.integer); - - mpz_set (frame.value, start->value.integer); - - frame.prev = iter_stack; - frame.variable = var->iter.var->symtree; - iter_stack = &frame; - - while (mpz_cmp_ui (trip, 0) > 0) - { - if (!traverse_data_var (var->list, where)) - { - retval = false; - goto cleanup; - } - - e = gfc_copy_expr (var->expr); - if (!gfc_simplify_expr (e, 1)) - { - gfc_free_expr (e); - retval = false; - goto cleanup; - } - - mpz_add (frame.value, frame.value, step->value.integer); - - mpz_sub_ui (trip, trip, 1); - } - -cleanup: - mpz_clear (frame.value); - mpz_clear (trip); - - gfc_free_expr (start); - gfc_free_expr (end); - gfc_free_expr (step); - - iter_stack = frame.prev; - return retval; -} - - -/* Type resolve variables in the variable list of a DATA statement. */ - -static bool -traverse_data_var (gfc_data_variable *var, locus *where) -{ - bool t; - - for (; var; var = var->next) - { - if (var->expr == NULL) - t = traverse_data_list (var, where); - else - t = check_data_variable (var, where); - - if (!t) - return false; - } - - return true; -} - - -/* Resolve the expressions and iterators associated with a data statement. - This is separate from the assignment checking because data lists should - only be resolved once. */ - -static bool -resolve_data_variables (gfc_data_variable *d) -{ - for (; d; d = d->next) - { - if (d->list == NULL) - { - if (!gfc_resolve_expr (d->expr)) - return false; - } - else - { - if (!gfc_resolve_iterator (&d->iter, false, true)) - return false; - - if (!resolve_data_variables (d->list)) - return false; - } - } - - return true; -} - - -/* Resolve a single DATA statement. We implement this by storing a pointer to - the value list into static variables, and then recursively traversing the - variables list, expanding iterators and such. */ - -static void -resolve_data (gfc_data *d) -{ - - if (!resolve_data_variables (d->var)) - return; - - values.vnode = d->value; - if (d->value == NULL) - mpz_set_ui (values.left, 0); - else - mpz_set (values.left, d->value->repeat); - - if (!traverse_data_var (d->var, &d->where)) - return; - - /* At this point, we better not have any values left. */ - - if (next_data_value ()) - gfc_error ("DATA statement at %L has more values than variables", - &d->where); -} - - -/* 12.6 Constraint: In a pure subprogram any variable which is in common or - accessed by host or use association, is a dummy argument to a pure function, - is a dummy argument with INTENT (IN) to a pure subroutine, or an object that - is storage associated with any such variable, shall not be used in the - following contexts: (clients of this function). */ - -/* Determines if a variable is not 'pure', i.e., not assignable within a pure - procedure. Returns zero if assignment is OK, nonzero if there is a - problem. */ -int -gfc_impure_variable (gfc_symbol *sym) -{ - gfc_symbol *proc; - gfc_namespace *ns; - - if (sym->attr.use_assoc || sym->attr.in_common) - return 1; - - /* Check if the symbol's ns is inside the pure procedure. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - if (ns == sym->ns) - break; - if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function) - return 1; - } - - proc = sym->ns->proc_name; - if (sym->attr.dummy - && !sym->attr.value - && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN) - || proc->attr.function)) - return 1; - - /* TODO: Sort out what can be storage associated, if anything, and include - it here. In principle equivalences should be scanned but it does not - seem to be possible to storage associate an impure variable this way. */ - return 0; -} - - -/* Test whether a symbol is pure or not. For a NULL pointer, checks if the - current namespace is inside a pure procedure. */ - -int -gfc_pure (gfc_symbol *sym) -{ - symbol_attribute attr; - gfc_namespace *ns; - - if (sym == NULL) - { - /* Check if the current namespace or one of its parents - belongs to a pure procedure. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - sym = ns->proc_name; - if (sym == NULL) - return 0; - attr = sym->attr; - if (attr.flavor == FL_PROCEDURE && attr.pure) - return 1; - } - return 0; - } - - attr = sym->attr; - - return attr.flavor == FL_PROCEDURE && attr.pure; -} - - -/* Test whether a symbol is implicitly pure or not. For a NULL pointer, - checks if the current namespace is implicitly pure. Note that this - function returns false for a PURE procedure. */ - -int -gfc_implicit_pure (gfc_symbol *sym) -{ - gfc_namespace *ns; - - if (sym == NULL) - { - /* Check if the current procedure is implicit_pure. Walk up - the procedure list until we find a procedure. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - sym = ns->proc_name; - if (sym == NULL) - return 0; - - if (sym->attr.flavor == FL_PROCEDURE) - break; - } - } - - return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure - && !sym->attr.pure; -} - - -void -gfc_unset_implicit_pure (gfc_symbol *sym) -{ - gfc_namespace *ns; - - if (sym == NULL) - { - /* Check if the current procedure is implicit_pure. Walk up - the procedure list until we find a procedure. */ - for (ns = gfc_current_ns; ns; ns = ns->parent) - { - sym = ns->proc_name; - if (sym == NULL) - return; - - if (sym->attr.flavor == FL_PROCEDURE) - break; - } - } - - if (sym->attr.flavor == FL_PROCEDURE) - sym->attr.implicit_pure = 0; - else - sym->attr.pure = 0; -} - - -/* Test whether the current procedure is elemental or not. */ - -int -gfc_elemental (gfc_symbol *sym) -{ - symbol_attribute attr; - - if (sym == NULL) - sym = gfc_current_ns->proc_name; - if (sym == NULL) - return 0; - attr = sym->attr; - - return attr.flavor == FL_PROCEDURE && attr.elemental; -} - - -/* Warn about unused labels. */ - -static void -warn_unused_fortran_label (gfc_st_label *label) -{ - if (label == NULL) - return; - - warn_unused_fortran_label (label->left); - - if (label->defined == ST_LABEL_UNKNOWN) - return; - - switch (label->referenced) - { - case ST_LABEL_UNKNOWN: - gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used", - label->value, &label->where); - break; - - case ST_LABEL_BAD_TARGET: - gfc_warning (OPT_Wunused_label, - "Label %d at %L defined but cannot be used", - label->value, &label->where); - break; - - default: - break; - } - - warn_unused_fortran_label (label->right); -} - - -/* Returns the sequence type of a symbol or sequence. */ - -static seq_type -sequence_type (gfc_typespec ts) -{ - seq_type result; - gfc_component *c; - - switch (ts.type) - { - case BT_DERIVED: - - if (ts.u.derived->components == NULL) - return SEQ_NONDEFAULT; - - result = sequence_type (ts.u.derived->components->ts); - for (c = ts.u.derived->components->next; c; c = c->next) - if (sequence_type (c->ts) != result) - return SEQ_MIXED; - - return result; - - case BT_CHARACTER: - if (ts.kind != gfc_default_character_kind) - return SEQ_NONDEFAULT; - - return SEQ_CHARACTER; - - case BT_INTEGER: - if (ts.kind != gfc_default_integer_kind) - return SEQ_NONDEFAULT; - - return SEQ_NUMERIC; - - case BT_REAL: - if (!(ts.kind == gfc_default_real_kind - || ts.kind == gfc_default_double_kind)) - return SEQ_NONDEFAULT; - - return SEQ_NUMERIC; - - case BT_COMPLEX: - if (ts.kind != gfc_default_complex_kind) - return SEQ_NONDEFAULT; - - return SEQ_NUMERIC; - - case BT_LOGICAL: - if (ts.kind != gfc_default_logical_kind) - return SEQ_NONDEFAULT; - - return SEQ_NUMERIC; - - default: - return SEQ_NONDEFAULT; - } -} - - -/* Resolve derived type EQUIVALENCE object. */ - -static bool -resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) -{ - gfc_component *c = derived->components; - - if (!derived) - return true; - - /* Shall not be an object of nonsequence derived type. */ - if (!derived->attr.sequence) - { - gfc_error ("Derived type variable %qs at %L must have SEQUENCE " - "attribute to be an EQUIVALENCE object", sym->name, - &e->where); - return false; - } - - /* Shall not have allocatable components. */ - if (derived->attr.alloc_comp) - { - gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE " - "components to be an EQUIVALENCE object",sym->name, - &e->where); - return false; - } - - if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived)) - { - gfc_error ("Derived type variable %qs at %L with default " - "initialization cannot be in EQUIVALENCE with a variable " - "in COMMON", sym->name, &e->where); - return false; - } - - for (; c ; c = c->next) - { - if (gfc_bt_struct (c->ts.type) - && (!resolve_equivalence_derived(c->ts.u.derived, sym, e))) - return false; - - /* Shall not be an object of sequence derived type containing a pointer - in the structure. */ - if (c->attr.pointer) - { - gfc_error ("Derived type variable %qs at %L with pointer " - "component(s) cannot be an EQUIVALENCE object", - sym->name, &e->where); - return false; - } - } - return true; -} - - -/* Resolve equivalence object. - An EQUIVALENCE object shall not be a dummy argument, a pointer, a target, - an allocatable array, an object of nonsequence derived type, an object of - sequence derived type containing a pointer at any level of component - selection, an automatic object, a function name, an entry name, a result - name, a named constant, a structure component, or a subobject of any of - the preceding objects. A substring shall not have length zero. A - derived type shall not have components with default initialization nor - shall two objects of an equivalence group be initialized. - Either all or none of the objects shall have an protected attribute. - The simple constraints are done in symbol.c(check_conflict) and the rest - are implemented here. */ - -static void -resolve_equivalence (gfc_equiv *eq) -{ - gfc_symbol *sym; - gfc_symbol *first_sym; - gfc_expr *e; - gfc_ref *r; - locus *last_where = NULL; - seq_type eq_type, last_eq_type; - gfc_typespec *last_ts; - int object, cnt_protected; - const char *msg; - - last_ts = &eq->expr->symtree->n.sym->ts; - - first_sym = eq->expr->symtree->n.sym; - - cnt_protected = 0; - - for (object = 1; eq; eq = eq->eq, object++) - { - e = eq->expr; - - e->ts = e->symtree->n.sym->ts; - /* match_varspec might not know yet if it is seeing - array reference or substring reference, as it doesn't - know the types. */ - if (e->ref && e->ref->type == REF_ARRAY) - { - gfc_ref *ref = e->ref; - sym = e->symtree->n.sym; - - if (sym->attr.dimension) - { - ref->u.ar.as = sym->as; - ref = ref->next; - } - - /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */ - if (e->ts.type == BT_CHARACTER - && ref - && ref->type == REF_ARRAY - && ref->u.ar.dimen == 1 - && ref->u.ar.dimen_type[0] == DIMEN_RANGE - && ref->u.ar.stride[0] == NULL) - { - gfc_expr *start = ref->u.ar.start[0]; - gfc_expr *end = ref->u.ar.end[0]; - void *mem = NULL; - - /* Optimize away the (:) reference. */ - if (start == NULL && end == NULL) - { - if (e->ref == ref) - e->ref = ref->next; - else - e->ref->next = ref->next; - mem = ref; - } - else - { - ref->type = REF_SUBSTRING; - if (start == NULL) - start = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, 1); - ref->u.ss.start = start; - if (end == NULL && e->ts.u.cl) - end = gfc_copy_expr (e->ts.u.cl->length); - ref->u.ss.end = end; - ref->u.ss.length = e->ts.u.cl; - e->ts.u.cl = NULL; - } - ref = ref->next; - free (mem); - } - - /* Any further ref is an error. */ - if (ref) - { - gcc_assert (ref->type == REF_ARRAY); - gfc_error ("Syntax error in EQUIVALENCE statement at %L", - &ref->u.ar.where); - continue; - } - } - - if (!gfc_resolve_expr (e)) - continue; - - sym = e->symtree->n.sym; - - if (sym->attr.is_protected) - cnt_protected++; - if (cnt_protected > 0 && cnt_protected != object) - { - gfc_error ("Either all or none of the objects in the " - "EQUIVALENCE set at %L shall have the " - "PROTECTED attribute", - &e->where); - break; - } - - /* Shall not equivalence common block variables in a PURE procedure. */ - if (sym->ns->proc_name - && sym->ns->proc_name->attr.pure - && sym->attr.in_common) - { - /* Need to check for symbols that may have entered the pure - procedure via a USE statement. */ - bool saw_sym = false; - if (sym->ns->use_stmts) - { - gfc_use_rename *r; - for (r = sym->ns->use_stmts->rename; r; r = r->next) - if (strcmp(r->use_name, sym->name) == 0) saw_sym = true; - } - else - saw_sym = true; - - if (saw_sym) - gfc_error ("COMMON block member %qs at %L cannot be an " - "EQUIVALENCE object in the pure procedure %qs", - sym->name, &e->where, sym->ns->proc_name->name); - break; - } - - /* Shall not be a named constant. */ - if (e->expr_type == EXPR_CONSTANT) - { - gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE " - "object", sym->name, &e->where); - continue; - } - - if (e->ts.type == BT_DERIVED - && !resolve_equivalence_derived (e->ts.u.derived, sym, e)) - continue; - - /* Check that the types correspond correctly: - Note 5.28: - A numeric sequence structure may be equivalenced to another sequence - structure, an object of default integer type, default real type, double - precision real type, default logical type such that components of the - structure ultimately only become associated to objects of the same - kind. A character sequence structure may be equivalenced to an object - of default character kind or another character sequence structure. - Other objects may be equivalenced only to objects of the same type and - kind parameters. */ - - /* Identical types are unconditionally OK. */ - if (object == 1 || gfc_compare_types (last_ts, &sym->ts)) - goto identical_types; - - last_eq_type = sequence_type (*last_ts); - eq_type = sequence_type (sym->ts); - - /* Since the pair of objects is not of the same type, mixed or - non-default sequences can be rejected. */ - - msg = "Sequence %s with mixed components in EQUIVALENCE " - "statement at %L with different type objects"; - if ((object ==2 - && last_eq_type == SEQ_MIXED - && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) - || (eq_type == SEQ_MIXED - && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) - continue; - - msg = "Non-default type object or sequence %s in EQUIVALENCE " - "statement at %L with objects of different type"; - if ((object ==2 - && last_eq_type == SEQ_NONDEFAULT - && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) - || (eq_type == SEQ_NONDEFAULT - && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) - continue; - - msg ="Non-CHARACTER object %qs in default CHARACTER " - "EQUIVALENCE statement at %L"; - if (last_eq_type == SEQ_CHARACTER - && eq_type != SEQ_CHARACTER - && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) - continue; - - msg ="Non-NUMERIC object %qs in default NUMERIC " - "EQUIVALENCE statement at %L"; - if (last_eq_type == SEQ_NUMERIC - && eq_type != SEQ_NUMERIC - && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) - continue; - -identical_types: - - last_ts =&sym->ts; - last_where = &e->where; - - if (!e->ref) - continue; - - /* Shall not be an automatic array. */ - if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym)) - { - gfc_error ("Array %qs at %L with non-constant bounds cannot be " - "an EQUIVALENCE object", sym->name, &e->where); - continue; - } - - r = e->ref; - while (r) - { - /* Shall not be a structure component. */ - if (r->type == REF_COMPONENT) - { - gfc_error ("Structure component %qs at %L cannot be an " - "EQUIVALENCE object", - r->u.c.component->name, &e->where); - break; - } - - /* A substring shall not have length zero. */ - if (r->type == REF_SUBSTRING) - { - if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT) - { - gfc_error ("Substring at %L has length zero", - &r->u.ss.start->where); - break; - } - } - r = r->next; - } - } -} - - -/* Function called by resolve_fntype to flag other symbols used in the - length type parameter specification of function results. */ - -static bool -flag_fn_result_spec (gfc_expr *expr, - gfc_symbol *sym, - int *f ATTRIBUTE_UNUSED) -{ - gfc_namespace *ns; - gfc_symbol *s; - - if (expr->expr_type == EXPR_VARIABLE) - { - s = expr->symtree->n.sym; - for (ns = s->ns; ns; ns = ns->parent) - if (!ns->parent) - break; - - if (sym == s) - { - gfc_error ("Self reference in character length expression " - "for %qs at %L", sym->name, &expr->where); - return true; - } - - if (!s->fn_result_spec - && s->attr.flavor == FL_PARAMETER) - { - /* Function contained in a module.... */ - if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE) - { - gfc_symtree *st; - s->fn_result_spec = 1; - /* Make sure that this symbol is translated as a module - variable. */ - st = gfc_get_unique_symtree (ns); - st->n.sym = s; - s->refs++; - } - /* ... which is use associated and called. */ - else if (s->attr.use_assoc || s->attr.used_in_submodule - || - /* External function matched with an interface. */ - (s->ns->proc_name - && ((s->ns == ns - && s->ns->proc_name->attr.if_source == IFSRC_DECL) - || s->ns->proc_name->attr.if_source == IFSRC_IFBODY) - && s->ns->proc_name->attr.function)) - s->fn_result_spec = 1; - } - } - return false; -} - - -/* Resolve function and ENTRY types, issue diagnostics if needed. */ - -static void -resolve_fntype (gfc_namespace *ns) -{ - gfc_entry_list *el; - gfc_symbol *sym; - - if (ns->proc_name == NULL || !ns->proc_name->attr.function) - return; - - /* If there are any entries, ns->proc_name is the entry master - synthetic symbol and ns->entries->sym actual FUNCTION symbol. */ - if (ns->entries) - sym = ns->entries->sym; - else - sym = ns->proc_name; - if (sym->result == sym - && sym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (sym, 0, NULL) - && !sym->attr.untyped) - { - gfc_error ("Function %qs at %L has no IMPLICIT type", - sym->name, &sym->declared_at); - sym->attr.untyped = 1; - } - - if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc - && !sym->attr.contained - && !gfc_check_symbol_access (sym->ts.u.derived) - && gfc_check_symbol_access (sym)) - { - gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at " - "%L of PRIVATE type %qs", sym->name, - &sym->declared_at, sym->ts.u.derived->name); - } - - if (ns->entries) - for (el = ns->entries->next; el; el = el->next) - { - if (el->sym->result == el->sym - && el->sym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (el->sym, 0, NULL) - && !el->sym->attr.untyped) - { - gfc_error ("ENTRY %qs at %L has no IMPLICIT type", - el->sym->name, &el->sym->declared_at); - el->sym->attr.untyped = 1; - } - } - - if (sym->ts.type == BT_CHARACTER) - gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0); -} - - -/* 12.3.2.1.1 Defined operators. */ - -static bool -check_uop_procedure (gfc_symbol *sym, locus where) -{ - gfc_formal_arglist *formal; - - if (!sym->attr.function) - { - gfc_error ("User operator procedure %qs at %L must be a FUNCTION", - sym->name, &where); - return false; - } - - if (sym->ts.type == BT_CHARACTER - && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred) - && !(sym->result && ((sym->result->ts.u.cl - && sym->result->ts.u.cl->length) || sym->result->ts.deferred))) - { - gfc_error ("User operator procedure %qs at %L cannot be assumed " - "character length", sym->name, &where); - return false; - } - - formal = gfc_sym_get_dummy_args (sym); - if (!formal || !formal->sym) - { - gfc_error ("User operator procedure %qs at %L must have at least " - "one argument", sym->name, &where); - return false; - } - - if (formal->sym->attr.intent != INTENT_IN) - { - gfc_error ("First argument of operator interface at %L must be " - "INTENT(IN)", &where); - return false; - } - - if (formal->sym->attr.optional) - { - gfc_error ("First argument of operator interface at %L cannot be " - "optional", &where); - return false; - } - - formal = formal->next; - if (!formal || !formal->sym) - return true; - - if (formal->sym->attr.intent != INTENT_IN) - { - gfc_error ("Second argument of operator interface at %L must be " - "INTENT(IN)", &where); - return false; - } - - if (formal->sym->attr.optional) - { - gfc_error ("Second argument of operator interface at %L cannot be " - "optional", &where); - return false; - } - - if (formal->next) - { - gfc_error ("Operator interface at %L must have, at most, two " - "arguments", &where); - return false; - } - - return true; -} - -static void -gfc_resolve_uops (gfc_symtree *symtree) -{ - gfc_interface *itr; - - if (symtree == NULL) - return; - - gfc_resolve_uops (symtree->left); - gfc_resolve_uops (symtree->right); - - for (itr = symtree->n.uop->op; itr; itr = itr->next) - check_uop_procedure (itr->sym, itr->sym->declared_at); -} - - -/* Examine all of the expressions associated with a program unit, - assign types to all intermediate expressions, make sure that all - assignments are to compatible types and figure out which names - refer to which functions or subroutines. It doesn't check code - block, which is handled by gfc_resolve_code. */ - -static void -resolve_types (gfc_namespace *ns) -{ - gfc_namespace *n; - gfc_charlen *cl; - gfc_data *d; - gfc_equiv *eq; - gfc_namespace* old_ns = gfc_current_ns; - bool recursive = ns->proc_name && ns->proc_name->attr.recursive; - - if (ns->types_resolved) - return; - - /* Check that all IMPLICIT types are ok. */ - if (!ns->seen_implicit_none) - { - unsigned letter; - for (letter = 0; letter != GFC_LETTERS; ++letter) - if (ns->set_flag[letter] - && !resolve_typespec_used (&ns->default_type[letter], - &ns->implicit_loc[letter], NULL)) - return; - } - - gfc_current_ns = ns; - - resolve_entries (ns); - - resolve_common_vars (&ns->blank_common, false); - resolve_common_blocks (ns->common_root); - - resolve_contained_functions (ns); - - if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE - && ns->proc_name->attr.if_source == IFSRC_IFBODY) - gfc_resolve_formal_arglist (ns->proc_name); - - gfc_traverse_ns (ns, resolve_bind_c_derived_types); - - for (cl = ns->cl_list; cl; cl = cl->next) - resolve_charlen (cl); - - gfc_traverse_ns (ns, resolve_symbol); - - resolve_fntype (ns); - - for (n = ns->contained; n; n = n->sibling) - { - if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name)) - gfc_error ("Contained procedure %qs at %L of a PURE procedure must " - "also be PURE", n->proc_name->name, - &n->proc_name->declared_at); - - resolve_types (n); - } - - forall_flag = 0; - gfc_do_concurrent_flag = 0; - gfc_check_interfaces (ns); - - gfc_traverse_ns (ns, resolve_values); - - if (ns->save_all || (!flag_automatic && !recursive)) - gfc_save_all (ns); - - iter_stack = NULL; - for (d = ns->data; d; d = d->next) - resolve_data (d); - - iter_stack = NULL; - gfc_traverse_ns (ns, gfc_formalize_init_value); - - gfc_traverse_ns (ns, gfc_verify_binding_labels); - - for (eq = ns->equiv; eq; eq = eq->next) - resolve_equivalence (eq); - - /* Warn about unused labels. */ - if (warn_unused_label) - warn_unused_fortran_label (ns->st_labels); - - gfc_resolve_uops (ns->uop_root); - - gfc_traverse_ns (ns, gfc_verify_DTIO_procedures); - - gfc_resolve_omp_declare_simd (ns); - - gfc_resolve_omp_udrs (ns->omp_udr_root); - - ns->types_resolved = 1; - - gfc_current_ns = old_ns; -} - - -/* Call gfc_resolve_code recursively. */ - -static void -resolve_codes (gfc_namespace *ns) -{ - gfc_namespace *n; - bitmap_obstack old_obstack; - - if (ns->resolved == 1) - return; - - for (n = ns->contained; n; n = n->sibling) - resolve_codes (n); - - gfc_current_ns = ns; - - /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */ - if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)) - cs_base = NULL; - - /* Set to an out of range value. */ - current_entry_id = -1; - - old_obstack = labels_obstack; - bitmap_obstack_initialize (&labels_obstack); - - gfc_resolve_oacc_declare (ns); - gfc_resolve_oacc_routines (ns); - gfc_resolve_omp_local_vars (ns); - gfc_resolve_code (ns->code, ns); - - bitmap_obstack_release (&labels_obstack); - labels_obstack = old_obstack; -} - - -/* This function is called after a complete program unit has been compiled. - Its purpose is to examine all of the expressions associated with a program - unit, assign types to all intermediate expressions, make sure that all - assignments are to compatible types and figure out which names refer to - which functions or subroutines. */ - -void -gfc_resolve (gfc_namespace *ns) -{ - gfc_namespace *old_ns; - code_stack *old_cs_base; - struct gfc_omp_saved_state old_omp_state; - - if (ns->resolved) - return; - - ns->resolved = -1; - old_ns = gfc_current_ns; - old_cs_base = cs_base; - - /* As gfc_resolve can be called during resolution of an OpenMP construct - body, we should clear any state associated to it, so that say NS's - DO loops are not interpreted as OpenMP loops. */ - if (!ns->construct_entities) - gfc_omp_save_and_clear_state (&old_omp_state); - - resolve_types (ns); - component_assignment_level = 0; - resolve_codes (ns); - - gfc_current_ns = old_ns; - cs_base = old_cs_base; - ns->resolved = 1; - - gfc_run_passes (ns); - - if (!ns->construct_entities) - gfc_omp_restore_state (&old_omp_state); -} diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc new file mode 100644 index 0000000..43eeefe --- /dev/null +++ b/gcc/fortran/resolve.cc @@ -0,0 +1,17582 @@ +/* Perform type resolution on the various structures. + Copyright (C) 2001-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "bitmap.h" +#include "gfortran.h" +#include "arith.h" /* For gfc_compare_expr(). */ +#include "dependency.h" +#include "data.h" +#include "target-memory.h" /* for gfc_simplify_transfer */ +#include "constructor.h" + +/* Types used in equivalence statements. */ + +enum seq_type +{ + SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED +}; + +/* Stack to keep track of the nesting of blocks as we move through the + code. See resolve_branch() and gfc_resolve_code(). */ + +typedef struct code_stack +{ + struct gfc_code *head, *current; + struct code_stack *prev; + + /* This bitmap keeps track of the targets valid for a branch from + inside this block except for END {IF|SELECT}s of enclosing + blocks. */ + bitmap reachable_labels; +} +code_stack; + +static code_stack *cs_base = NULL; + + +/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ + +static int forall_flag; +int gfc_do_concurrent_flag; + +/* True when we are resolving an expression that is an actual argument to + a procedure. */ +static bool actual_arg = false; +/* True when we are resolving an expression that is the first actual argument + to a procedure. */ +static bool first_actual_arg = false; + + +/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ + +static int omp_workshare_flag; + +/* True if we are processing a formal arglist. The corresponding function + resets the flag each time that it is read. */ +static bool formal_arg_flag = false; + +/* True if we are resolving a specification expression. */ +static bool specification_expr = false; + +/* The id of the last entry seen. */ +static int current_entry_id; + +/* We use bitmaps to determine if a branch target is valid. */ +static bitmap_obstack labels_obstack; + +/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ +static bool inquiry_argument = false; + + +bool +gfc_is_formal_arg (void) +{ + return formal_arg_flag; +} + +/* Is the symbol host associated? */ +static bool +is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) +{ + for (ns = ns->parent; ns; ns = ns->parent) + { + if (sym->ns == ns) + return true; + } + + return false; +} + +/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is + an ABSTRACT derived-type. If where is not NULL, an error message with that + locus is printed, optionally using name. */ + +static bool +resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) +{ + if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract) + { + if (where) + { + if (name) + gfc_error ("%qs at %L is of the ABSTRACT type %qs", + name, where, ts->u.derived->name); + else + gfc_error ("ABSTRACT type %qs used at %L", + ts->u.derived->name, where); + } + + return false; + } + + return true; +} + + +static bool +check_proc_interface (gfc_symbol *ifc, locus *where) +{ + /* Several checks for F08:C1216. */ + if (ifc->attr.procedure) + { + gfc_error ("Interface %qs at %L is declared " + "in a later PROCEDURE statement", ifc->name, where); + return false; + } + if (ifc->generic) + { + /* For generic interfaces, check if there is + a specific procedure with the same name. */ + gfc_interface *gen = ifc->generic; + while (gen && strcmp (gen->sym->name, ifc->name) != 0) + gen = gen->next; + if (!gen) + { + gfc_error ("Interface %qs at %L may not be generic", + ifc->name, where); + return false; + } + } + if (ifc->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Interface %qs at %L may not be a statement function", + ifc->name, where); + return false; + } + if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) + || gfc_is_intrinsic (ifc, 1, ifc->declared_at)) + ifc->attr.intrinsic = 1; + if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0)) + { + gfc_error ("Intrinsic procedure %qs not allowed in " + "PROCEDURE statement at %L", ifc->name, where); + return false; + } + if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') + { + gfc_error ("Interface %qs at %L must be explicit", ifc->name, where); + return false; + } + return true; +} + + +static void resolve_symbol (gfc_symbol *sym); + + +/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ + +static bool +resolve_procedure_interface (gfc_symbol *sym) +{ + gfc_symbol *ifc = sym->ts.interface; + + if (!ifc) + return true; + + if (ifc == sym) + { + gfc_error ("PROCEDURE %qs at %L may not be used as its own interface", + sym->name, &sym->declared_at); + return false; + } + if (!check_proc_interface (ifc, &sym->declared_at)) + return false; + + if (ifc->attr.if_source || ifc->attr.intrinsic) + { + /* Resolve interface and copy attributes. */ + resolve_symbol (ifc); + if (ifc->attr.intrinsic) + gfc_resolve_intrinsic (ifc, &ifc->declared_at); + + if (ifc->result) + { + sym->ts = ifc->result->ts; + sym->attr.allocatable = ifc->result->attr.allocatable; + sym->attr.pointer = ifc->result->attr.pointer; + sym->attr.dimension = ifc->result->attr.dimension; + sym->attr.class_ok = ifc->result->attr.class_ok; + sym->as = gfc_copy_array_spec (ifc->result->as); + sym->result = sym; + } + else + { + sym->ts = ifc->ts; + sym->attr.allocatable = ifc->attr.allocatable; + sym->attr.pointer = ifc->attr.pointer; + sym->attr.dimension = ifc->attr.dimension; + sym->attr.class_ok = ifc->attr.class_ok; + sym->as = gfc_copy_array_spec (ifc->as); + } + sym->ts.interface = ifc; + sym->attr.function = ifc->attr.function; + sym->attr.subroutine = ifc->attr.subroutine; + + sym->attr.pure = ifc->attr.pure; + sym->attr.elemental = ifc->attr.elemental; + sym->attr.contiguous = ifc->attr.contiguous; + sym->attr.recursive = ifc->attr.recursive; + sym->attr.always_explicit = ifc->attr.always_explicit; + sym->attr.ext_attr |= ifc->attr.ext_attr; + sym->attr.is_bind_c = ifc->attr.is_bind_c; + /* Copy char length. */ + if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) + { + sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); + if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved + && !gfc_resolve_expr (sym->ts.u.cl->length)) + return false; + } + } + + return true; +} + + +/* Resolve types of formal argument lists. These have to be done early so that + the formal argument lists of module procedures can be copied to the + containing module before the individual procedures are resolved + individually. We also resolve argument lists of procedures in interface + blocks because they are self-contained scoping units. + + Since a dummy argument cannot be a non-dummy procedure, the only + resort left for untyped names are the IMPLICIT types. */ + +void +gfc_resolve_formal_arglist (gfc_symbol *proc) +{ + gfc_formal_arglist *f; + gfc_symbol *sym; + bool saved_specification_expr; + int i; + + if (proc->result != NULL) + sym = proc->result; + else + sym = proc; + + if (gfc_elemental (proc) + || sym->attr.pointer || sym->attr.allocatable + || (sym->as && sym->as->rank != 0)) + { + proc->attr.always_explicit = 1; + sym->attr.always_explicit = 1; + } + + formal_arg_flag = true; + + for (f = proc->formal; f; f = f->next) + { + gfc_array_spec *as; + + sym = f->sym; + + if (sym == NULL) + { + /* Alternate return placeholder. */ + if (gfc_elemental (proc)) + gfc_error ("Alternate return specifier in elemental subroutine " + "%qs at %L is not allowed", proc->name, + &proc->declared_at); + if (proc->attr.function) + gfc_error ("Alternate return specifier in function " + "%qs at %L is not allowed", proc->name, + &proc->declared_at); + continue; + } + else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL + && !resolve_procedure_interface (sym)) + return; + + if (strcmp (proc->name, sym->name) == 0) + { + gfc_error ("Self-referential argument " + "%qs at %L is not allowed", sym->name, + &proc->declared_at); + return; + } + + if (sym->attr.if_source != IFSRC_UNKNOWN) + gfc_resolve_formal_arglist (sym); + + if (sym->attr.subroutine || sym->attr.external) + { + if (sym->attr.flavor == FL_UNKNOWN) + gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at); + } + else + { + if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic + && (!sym->attr.function || sym->result == sym)) + gfc_set_default_type (sym, 1, sym->ns); + } + + as = sym->ts.type == BT_CLASS && sym->attr.class_ok + ? CLASS_DATA (sym)->as : sym->as; + + saved_specification_expr = specification_expr; + specification_expr = true; + gfc_resolve_array_spec (as, 0); + specification_expr = saved_specification_expr; + + /* We can't tell if an array with dimension (:) is assumed or deferred + shape until we know if it has the pointer or allocatable attributes. + */ + if (as && as->rank > 0 && as->type == AS_DEFERRED + && ((sym->ts.type != BT_CLASS + && !(sym->attr.pointer || sym->attr.allocatable)) + || (sym->ts.type == BT_CLASS + && !(CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.allocatable))) + && sym->attr.flavor != FL_PROCEDURE) + { + as->type = AS_ASSUMED_SHAPE; + for (i = 0; i < as->rank; i++) + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + } + + if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE) + || (as && as->type == AS_ASSUMED_RANK) + || sym->attr.pointer || sym->attr.allocatable || sym->attr.target + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && (CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.target)) + || sym->attr.optional) + { + proc->attr.always_explicit = 1; + if (proc->result) + proc->result->attr.always_explicit = 1; + } + + /* If the flavor is unknown at this point, it has to be a variable. + A procedure specification would have already set the type. */ + + if (sym->attr.flavor == FL_UNKNOWN) + gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); + + if (gfc_pure (proc)) + { + if (sym->attr.flavor == FL_PROCEDURE) + { + /* F08:C1279. */ + if (!gfc_pure (sym)) + { + gfc_error ("Dummy procedure %qs of PURE procedure at %L must " + "also be PURE", sym->name, &sym->declared_at); + continue; + } + } + else if (!sym->attr.pointer) + { + if (proc->attr.function && sym->attr.intent != INTENT_IN) + { + if (sym->attr.value) + gfc_notify_std (GFC_STD_F2008, "Argument %qs" + " of pure function %qs at %L with VALUE " + "attribute but without INTENT(IN)", + sym->name, proc->name, &sym->declared_at); + else + gfc_error ("Argument %qs of pure function %qs at %L must " + "be INTENT(IN) or VALUE", sym->name, proc->name, + &sym->declared_at); + } + + if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) + { + if (sym->attr.value) + gfc_notify_std (GFC_STD_F2008, "Argument %qs" + " of pure subroutine %qs at %L with VALUE " + "attribute but without INTENT", sym->name, + proc->name, &sym->declared_at); + else + gfc_error ("Argument %qs of pure subroutine %qs at %L " + "must have its INTENT specified or have the " + "VALUE attribute", sym->name, proc->name, + &sym->declared_at); + } + } + + /* F08:C1278a. */ + if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) + { + gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L" + " may not be polymorphic", sym->name, proc->name, + &sym->declared_at); + continue; + } + } + + if (proc->attr.implicit_pure) + { + if (sym->attr.flavor == FL_PROCEDURE) + { + if (!gfc_pure (sym)) + proc->attr.implicit_pure = 0; + } + else if (!sym->attr.pointer) + { + if (proc->attr.function && sym->attr.intent != INTENT_IN + && !sym->value) + proc->attr.implicit_pure = 0; + + if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN + && !sym->value) + proc->attr.implicit_pure = 0; + } + } + + if (gfc_elemental (proc)) + { + /* F08:C1289. */ + if (sym->attr.codimension + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.codimension)) + { + gfc_error ("Coarray dummy argument %qs at %L to elemental " + "procedure", sym->name, &sym->declared_at); + continue; + } + + if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->as)) + { + gfc_error ("Argument %qs of elemental procedure at %L must " + "be scalar", sym->name, &sym->declared_at); + continue; + } + + if (sym->attr.allocatable + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.allocatable)) + { + gfc_error ("Argument %qs of elemental procedure at %L cannot " + "have the ALLOCATABLE attribute", sym->name, + &sym->declared_at); + continue; + } + + if (sym->attr.pointer + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.class_pointer)) + { + gfc_error ("Argument %qs of elemental procedure at %L cannot " + "have the POINTER attribute", sym->name, + &sym->declared_at); + continue; + } + + if (sym->attr.flavor == FL_PROCEDURE) + { + gfc_error ("Dummy procedure %qs not allowed in elemental " + "procedure %qs at %L", sym->name, proc->name, + &sym->declared_at); + continue; + } + + /* Fortran 2008 Corrigendum 1, C1290a. */ + if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value) + { + gfc_error ("Argument %qs of elemental procedure %qs at %L must " + "have its INTENT specified or have the VALUE " + "attribute", sym->name, proc->name, + &sym->declared_at); + continue; + } + } + + /* Each dummy shall be specified to be scalar. */ + if (proc->attr.proc == PROC_ST_FUNCTION) + { + if (sym->as != NULL) + { + /* F03:C1263 (R1238) The function-name and each dummy-arg-name + shall be specified, explicitly or implicitly, to be scalar. */ + gfc_error ("Argument '%s' of statement function '%s' at %L " + "must be scalar", sym->name, proc->name, + &proc->declared_at); + continue; + } + + if (sym->ts.type == BT_CHARACTER) + { + gfc_charlen *cl = sym->ts.u.cl; + if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Character-valued argument %qs of statement " + "function at %L must have constant length", + sym->name, &sym->declared_at); + continue; + } + } + } + } + formal_arg_flag = false; +} + + +/* Work function called when searching for symbols that have argument lists + associated with them. */ + +static void +find_arglists (gfc_symbol *sym) +{ + if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns + || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic) + return; + + gfc_resolve_formal_arglist (sym); +} + + +/* Given a namespace, resolve all formal argument lists within the namespace. + */ + +static void +resolve_formal_arglists (gfc_namespace *ns) +{ + if (ns == NULL) + return; + + gfc_traverse_ns (ns, find_arglists); +} + + +static void +resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) +{ + bool t; + + if (sym && sym->attr.flavor == FL_PROCEDURE + && sym->ns->parent + && sym->ns->parent->proc_name + && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE + && !strcmp (sym->name, sym->ns->parent->proc_name->name)) + gfc_error ("Contained procedure %qs at %L has the same name as its " + "encompassing procedure", sym->name, &sym->declared_at); + + /* If this namespace is not a function or an entry master function, + ignore it. */ + if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE) + || sym->attr.entry_master) + return; + + if (!sym->result) + return; + + /* Try to find out of what the return type is. */ + if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL) + { + t = gfc_set_default_type (sym->result, 0, ns); + + if (!t && !sym->result->attr.untyped) + { + if (sym->result == sym) + gfc_error ("Contained function %qs at %L has no IMPLICIT type", + sym->name, &sym->declared_at); + else if (!sym->result->attr.proc_pointer) + gfc_error ("Result %qs of contained function %qs at %L has " + "no IMPLICIT type", sym->result->name, sym->name, + &sym->result->declared_at); + sym->result->attr.untyped = 1; + } + } + + /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value + type, lists the only ways a character length value of * can be used: + dummy arguments of procedures, named constants, function results and + in allocate statements if the allocate_object is an assumed length dummy + in external functions. Internal function results and results of module + procedures are not on this list, ergo, not permitted. */ + + if (sym->result->ts.type == BT_CHARACTER) + { + gfc_charlen *cl = sym->result->ts.u.cl; + if ((!cl || !cl->length) && !sym->result->ts.deferred) + { + /* See if this is a module-procedure and adapt error message + accordingly. */ + bool module_proc; + gcc_assert (ns->parent && ns->parent->proc_name); + module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE); + + gfc_error (module_proc + ? G_("Character-valued module procedure %qs at %L" + " must not be assumed length") + : G_("Character-valued internal function %qs at %L" + " must not be assumed length"), + sym->name, &sym->declared_at); + } + } +} + + +/* Add NEW_ARGS to the formal argument list of PROC, taking care not to + introduce duplicates. */ + +static void +merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) +{ + gfc_formal_arglist *f, *new_arglist; + gfc_symbol *new_sym; + + for (; new_args != NULL; new_args = new_args->next) + { + new_sym = new_args->sym; + /* See if this arg is already in the formal argument list. */ + for (f = proc->formal; f; f = f->next) + { + if (new_sym == f->sym) + break; + } + + if (f) + continue; + + /* Add a new argument. Argument order is not important. */ + new_arglist = gfc_get_formal_arglist (); + new_arglist->sym = new_sym; + new_arglist->next = proc->formal; + proc->formal = new_arglist; + } +} + + +/* Flag the arguments that are not present in all entries. */ + +static void +check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) +{ + gfc_formal_arglist *f, *head; + head = new_args; + + for (f = proc->formal; f; f = f->next) + { + if (f->sym == NULL) + continue; + + for (new_args = head; new_args; new_args = new_args->next) + { + if (new_args->sym == f->sym) + break; + } + + if (new_args) + continue; + + f->sym->attr.not_always_present = 1; + } +} + + +/* Resolve alternate entry points. If a symbol has multiple entry points we + create a new master symbol for the main routine, and turn the existing + symbol into an entry point. */ + +static void +resolve_entries (gfc_namespace *ns) +{ + gfc_namespace *old_ns; + gfc_code *c; + gfc_symbol *proc; + gfc_entry_list *el; + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int master_count = 0; + + if (ns->proc_name == NULL) + return; + + /* No need to do anything if this procedure doesn't have alternate entry + points. */ + if (!ns->entries) + return; + + /* We may already have resolved alternate entry points. */ + if (ns->proc_name->attr.entry_master) + return; + + /* If this isn't a procedure something has gone horribly wrong. */ + gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE); + + /* Remember the current namespace. */ + old_ns = gfc_current_ns; + + gfc_current_ns = ns; + + /* Add the main entry point to the list of entry points. */ + el = gfc_get_entry_list (); + el->sym = ns->proc_name; + el->id = 0; + el->next = ns->entries; + ns->entries = el; + ns->proc_name->attr.entry = 1; + + /* If it is a module function, it needs to be in the right namespace + so that gfc_get_fake_result_decl can gather up the results. The + need for this arose in get_proc_name, where these beasts were + left in their own namespace, to keep prior references linked to + the entry declaration.*/ + if (ns->proc_name->attr.function + && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) + el->sym->ns = ns; + + /* Do the same for entries where the master is not a module + procedure. These are retained in the module namespace because + of the module procedure declaration. */ + for (el = el->next; el; el = el->next) + if (el->sym->ns->proc_name->attr.flavor == FL_MODULE + && el->sym->attr.mod_proc) + el->sym->ns = ns; + el = ns->entries; + + /* Add an entry statement for it. */ + c = gfc_get_code (EXEC_ENTRY); + c->ext.entry = el; + c->next = ns->code; + ns->code = c; + + /* Create a new symbol for the master function. */ + /* Give the internal function a unique name (within this file). + Also include the function name so the user has some hope of figuring + out what is going on. */ + snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", + master_count++, ns->proc_name->name); + gfc_get_ha_symbol (name, &proc); + gcc_assert (proc != NULL); + + gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL); + if (ns->proc_name->attr.subroutine) + gfc_add_subroutine (&proc->attr, proc->name, NULL); + else + { + gfc_symbol *sym; + gfc_typespec *ts, *fts; + gfc_array_spec *as, *fas; + gfc_add_function (&proc->attr, proc->name, NULL); + proc->result = proc; + fas = ns->entries->sym->as; + fas = fas ? fas : ns->entries->sym->result->as; + fts = &ns->entries->sym->result->ts; + if (fts->type == BT_UNKNOWN) + fts = gfc_get_default_type (ns->entries->sym->result->name, NULL); + for (el = ns->entries->next; el; el = el->next) + { + ts = &el->sym->result->ts; + as = el->sym->as; + as = as ? as : el->sym->result->as; + if (ts->type == BT_UNKNOWN) + ts = gfc_get_default_type (el->sym->result->name, NULL); + + if (! gfc_compare_types (ts, fts) + || (el->sym->result->attr.dimension + != ns->entries->sym->result->attr.dimension) + || (el->sym->result->attr.pointer + != ns->entries->sym->result->attr.pointer)) + break; + else if (as && fas && ns->entries->sym->result != el->sym->result + && gfc_compare_array_spec (as, fas) == 0) + gfc_error ("Function %s at %L has entries with mismatched " + "array specifications", ns->entries->sym->name, + &ns->entries->sym->declared_at); + /* The characteristics need to match and thus both need to have + the same string length, i.e. both len=*, or both len=4. + Having both len= is also possible, but difficult to + check at compile time. */ + else if (ts->type == BT_CHARACTER + && (el->sym->result->attr.allocatable + != ns->entries->sym->result->attr.allocatable)) + { + gfc_error ("Function %s at %L has entry %s with mismatched " + "characteristics", ns->entries->sym->name, + &ns->entries->sym->declared_at, el->sym->name); + goto cleanup; + } + else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl + && (((ts->u.cl->length && !fts->u.cl->length) + ||(!ts->u.cl->length && fts->u.cl->length)) + || (ts->u.cl->length + && ts->u.cl->length->expr_type + != fts->u.cl->length->expr_type) + || (ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && mpz_cmp (ts->u.cl->length->value.integer, + fts->u.cl->length->value.integer) != 0))) + gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " + "entries returning variables of different " + "string lengths", ns->entries->sym->name, + &ns->entries->sym->declared_at); + } + + if (el == NULL) + { + sym = ns->entries->sym->result; + /* All result types the same. */ + proc->ts = *fts; + if (sym->attr.dimension) + gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); + if (sym->attr.pointer) + gfc_add_pointer (&proc->attr, NULL); + } + else + { + /* Otherwise the result will be passed through a union by + reference. */ + proc->attr.mixed_entry_master = 1; + for (el = ns->entries; el; el = el->next) + { + sym = el->sym->result; + if (sym->attr.dimension) + { + if (el == ns->entries) + gfc_error ("FUNCTION result %s cannot be an array in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + else + gfc_error ("ENTRY result %s cannot be an array in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + } + else if (sym->attr.pointer) + { + if (el == ns->entries) + gfc_error ("FUNCTION result %s cannot be a POINTER in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + else + gfc_error ("ENTRY result %s cannot be a POINTER in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + } + else + { + ts = &sym->ts; + if (ts->type == BT_UNKNOWN) + ts = gfc_get_default_type (sym->name, NULL); + switch (ts->type) + { + case BT_INTEGER: + if (ts->kind == gfc_default_integer_kind) + sym = NULL; + break; + case BT_REAL: + if (ts->kind == gfc_default_real_kind + || ts->kind == gfc_default_double_kind) + sym = NULL; + break; + case BT_COMPLEX: + if (ts->kind == gfc_default_complex_kind) + sym = NULL; + break; + case BT_LOGICAL: + if (ts->kind == gfc_default_logical_kind) + sym = NULL; + break; + case BT_UNKNOWN: + /* We will issue error elsewhere. */ + sym = NULL; + break; + default: + break; + } + if (sym) + { + if (el == ns->entries) + gfc_error ("FUNCTION result %s cannot be of type %s " + "in FUNCTION %s at %L", sym->name, + gfc_typename (ts), ns->entries->sym->name, + &sym->declared_at); + else + gfc_error ("ENTRY result %s cannot be of type %s " + "in FUNCTION %s at %L", sym->name, + gfc_typename (ts), ns->entries->sym->name, + &sym->declared_at); + } + } + } + } + } + +cleanup: + proc->attr.access = ACCESS_PRIVATE; + proc->attr.entry_master = 1; + + /* Merge all the entry point arguments. */ + for (el = ns->entries; el; el = el->next) + merge_argument_lists (proc, el->sym->formal); + + /* Check the master formal arguments for any that are not + present in all entry points. */ + for (el = ns->entries; el; el = el->next) + check_argument_lists (proc, el->sym->formal); + + /* Use the master function for the function body. */ + ns->proc_name = proc; + + /* Finalize the new symbols. */ + gfc_commit_symbols (); + + /* Restore the original namespace. */ + gfc_current_ns = old_ns; +} + + +/* Resolve common variables. */ +static void +resolve_common_vars (gfc_common_head *common_block, bool named_common) +{ + gfc_symbol *csym = common_block->head; + gfc_gsymbol *gsym; + + for (; csym; csym = csym->common_next) + { + gsym = gfc_find_gsymbol (gfc_gsym_root, csym->name); + if (gsym && (gsym->type == GSYM_MODULE || gsym->type == GSYM_PROGRAM)) + gfc_error_now ("Global entity %qs at %L cannot appear in a " + "COMMON block at %L", gsym->name, + &gsym->where, &csym->common_block->where); + + /* gfc_add_in_common may have been called before, but the reported errors + have been ignored to continue parsing. + We do the checks again here. */ + if (!csym->attr.use_assoc) + { + gfc_add_in_common (&csym->attr, csym->name, &common_block->where); + gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L", + &common_block->where); + } + + if (csym->value || csym->attr.data) + { + if (!csym->ns->is_block_data) + gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON " + "but only in BLOCK DATA initialization is " + "allowed", csym->name, &csym->declared_at); + else if (!named_common) + gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is " + "in a blank COMMON but initialization is only " + "allowed in named common blocks", csym->name, + &csym->declared_at); + } + + if (UNLIMITED_POLY (csym)) + gfc_error_now ("%qs at %L cannot appear in COMMON " + "[F2008:C5100]", csym->name, &csym->declared_at); + + if (csym->ts.type != BT_DERIVED) + continue; + + if (!(csym->ts.u.derived->attr.sequence + || csym->ts.u.derived->attr.is_bind_c)) + gfc_error_now ("Derived type variable %qs in COMMON at %L " + "has neither the SEQUENCE nor the BIND(C) " + "attribute", csym->name, &csym->declared_at); + if (csym->ts.u.derived->attr.alloc_comp) + gfc_error_now ("Derived type variable %qs in COMMON at %L " + "has an ultimate component that is " + "allocatable", csym->name, &csym->declared_at); + if (gfc_has_default_initializer (csym->ts.u.derived)) + gfc_error_now ("Derived type variable %qs in COMMON at %L " + "may not have default initializer", csym->name, + &csym->declared_at); + + if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer) + gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at); + } +} + +/* Resolve common blocks. */ +static void +resolve_common_blocks (gfc_symtree *common_root) +{ + gfc_symbol *sym; + gfc_gsymbol * gsym; + + if (common_root == NULL) + return; + + if (common_root->left) + resolve_common_blocks (common_root->left); + if (common_root->right) + resolve_common_blocks (common_root->right); + + resolve_common_vars (common_root->n.common, true); + + /* The common name is a global name - in Fortran 2003 also if it has a + C binding name, since Fortran 2008 only the C binding name is a global + identifier. */ + if (!common_root->n.common->binding_label + || gfc_notification_std (GFC_STD_F2008)) + { + gsym = gfc_find_gsymbol (gfc_gsym_root, + common_root->n.common->name); + + if (gsym && gfc_notification_std (GFC_STD_F2008) + && gsym->type == GSYM_COMMON + && ((common_root->n.common->binding_label + && (!gsym->binding_label + || strcmp (common_root->n.common->binding_label, + gsym->binding_label) != 0)) + || (!common_root->n.common->binding_label + && gsym->binding_label))) + { + gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global " + "identifier and must thus have the same binding name " + "as the same-named COMMON block at %L: %s vs %s", + common_root->n.common->name, &common_root->n.common->where, + &gsym->where, + common_root->n.common->binding_label + ? common_root->n.common->binding_label : "(blank)", + gsym->binding_label ? gsym->binding_label : "(blank)"); + return; + } + + if (gsym && gsym->type != GSYM_COMMON + && !common_root->n.common->binding_label) + { + gfc_error ("COMMON block %qs at %L uses the same global identifier " + "as entity at %L", + common_root->n.common->name, &common_root->n.common->where, + &gsym->where); + return; + } + if (gsym && gsym->type != GSYM_COMMON) + { + gfc_error ("Fortran 2008: COMMON block %qs with binding label at " + "%L sharing the identifier with global non-COMMON-block " + "entity at %L", common_root->n.common->name, + &common_root->n.common->where, &gsym->where); + return; + } + if (!gsym) + { + gsym = gfc_get_gsymbol (common_root->n.common->name, false); + gsym->type = GSYM_COMMON; + gsym->where = common_root->n.common->where; + gsym->defined = 1; + } + gsym->used = 1; + } + + if (common_root->n.common->binding_label) + { + gsym = gfc_find_gsymbol (gfc_gsym_root, + common_root->n.common->binding_label); + if (gsym && gsym->type != GSYM_COMMON) + { + gfc_error ("COMMON block at %L with binding label %qs uses the same " + "global identifier as entity at %L", + &common_root->n.common->where, + common_root->n.common->binding_label, &gsym->where); + return; + } + if (!gsym) + { + gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true); + gsym->type = GSYM_COMMON; + gsym->where = common_root->n.common->where; + gsym->defined = 1; + } + gsym->used = 1; + } + + gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); + if (sym == NULL) + return; + + if (sym->attr.flavor == FL_PARAMETER) + gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L", + sym->name, &common_root->n.common->where, &sym->declared_at); + + if (sym->attr.external) + gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute", + sym->name, &common_root->n.common->where); + + if (sym->attr.intrinsic) + gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", + sym->name, &common_root->n.common->where); + else if (sym->attr.result + || gfc_is_function_return_value (sym, gfc_current_ns)) + gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " + "that is also a function result", sym->name, + &common_root->n.common->where); + else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL + && sym->attr.proc != PROC_ST_FUNCTION) + gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " + "that is also a global procedure", sym->name, + &common_root->n.common->where); +} + + +/* Resolve contained function types. Because contained functions can call one + another, they have to be worked out before any of the contained procedures + can be resolved. + + The good news is that if a function doesn't already have a type, the only + way it can get one is through an IMPLICIT type or a RESULT variable, because + by definition contained functions are contained namespace they're contained + in, not in a sibling or parent namespace. */ + +static void +resolve_contained_functions (gfc_namespace *ns) +{ + gfc_namespace *child; + gfc_entry_list *el; + + resolve_formal_arglists (ns); + + for (child = ns->contained; child; child = child->sibling) + { + /* Resolve alternate entry points first. */ + resolve_entries (child); + + /* Then check function return types. */ + resolve_contained_fntype (child->proc_name, child); + for (el = child->entries; el; el = el->next) + resolve_contained_fntype (el->sym, child); + } +} + + + +/* A Parameterized Derived Type constructor must contain values for + the PDT KIND parameters or they must have a default initializer. + Go through the constructor picking out the KIND expressions, + storing them in 'param_list' and then call gfc_get_pdt_instance + to obtain the PDT instance. */ + +static gfc_actual_arglist *param_list, *param_tail, *param; + +static bool +get_pdt_spec_expr (gfc_component *c, gfc_expr *expr) +{ + param = gfc_get_actual_arglist (); + if (!param_list) + param_list = param_tail = param; + else + { + param_tail->next = param; + param_tail = param_tail->next; + } + + param_tail->name = c->name; + if (expr) + param_tail->expr = gfc_copy_expr (expr); + else if (c->initializer) + param_tail->expr = gfc_copy_expr (c->initializer); + else + { + param_tail->spec_type = SPEC_ASSUMED; + if (c->attr.pdt_kind) + { + gfc_error ("The KIND parameter %qs in the PDT constructor " + "at %C has no value", param->name); + return false; + } + } + + return true; +} + +static bool +get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr, + gfc_symbol *derived) +{ + gfc_constructor *cons = NULL; + gfc_component *comp; + bool t = true; + + if (expr && expr->expr_type == EXPR_STRUCTURE) + cons = gfc_constructor_first (expr->value.constructor); + else if (constr) + cons = *constr; + gcc_assert (cons); + + comp = derived->components; + + for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) + { + if (cons->expr + && cons->expr->expr_type == EXPR_STRUCTURE + && comp->ts.type == BT_DERIVED) + { + t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived); + if (!t) + return t; + } + else if (comp->ts.type == BT_DERIVED) + { + t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived); + if (!t) + return t; + } + else if ((comp->attr.pdt_kind || comp->attr.pdt_len) + && derived->attr.pdt_template) + { + t = get_pdt_spec_expr (comp, cons->expr); + if (!t) + return t; + } + } + return t; +} + + +static bool resolve_fl_derived0 (gfc_symbol *sym); +static bool resolve_fl_struct (gfc_symbol *sym); + + +/* Resolve all of the elements of a structure constructor and make sure that + the types are correct. The 'init' flag indicates that the given + constructor is an initializer. */ + +static bool +resolve_structure_cons (gfc_expr *expr, int init) +{ + gfc_constructor *cons; + gfc_component *comp; + bool t; + symbol_attribute a; + + t = true; + + if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION) + { + if (expr->ts.u.derived->attr.flavor == FL_DERIVED) + resolve_fl_derived0 (expr->ts.u.derived); + else + resolve_fl_struct (expr->ts.u.derived); + + /* If this is a Parameterized Derived Type template, find the + instance corresponding to the PDT kind parameters. */ + if (expr->ts.u.derived->attr.pdt_template) + { + param_list = NULL; + t = get_pdt_constructor (expr, NULL, expr->ts.u.derived); + if (!t) + return t; + gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL); + + expr->param_list = gfc_copy_actual_arglist (param_list); + + if (param_list) + gfc_free_actual_arglist (param_list); + + if (!expr->ts.u.derived->attr.pdt_type) + return false; + } + } + + cons = gfc_constructor_first (expr->value.constructor); + + /* A constructor may have references if it is the result of substituting a + parameter variable. In this case we just pull out the component we + want. */ + if (expr->ref) + comp = expr->ref->u.c.sym->components; + else + comp = expr->ts.u.derived->components; + + for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) + { + int rank; + + if (!cons->expr) + continue; + + /* Unions use an EXPR_NULL contrived expression to tell the translation + phase to generate an initializer of the appropriate length. + Ignore it here. */ + if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL) + continue; + + if (!gfc_resolve_expr (cons->expr)) + { + t = false; + continue; + } + + rank = comp->as ? comp->as->rank : 0; + if (comp->ts.type == BT_CLASS + && !comp->ts.u.derived->attr.unlimited_polymorphic + && CLASS_DATA (comp)->as) + rank = CLASS_DATA (comp)->as->rank; + + if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank + && (comp->attr.allocatable || cons->expr->rank)) + { + gfc_error ("The rank of the element in the structure " + "constructor at %L does not match that of the " + "component (%d/%d)", &cons->expr->where, + cons->expr->rank, rank); + t = false; + } + + /* If we don't have the right type, try to convert it. */ + + if (!comp->attr.proc_pointer && + !gfc_compare_types (&cons->expr->ts, &comp->ts)) + { + if (strcmp (comp->name, "_extends") == 0) + { + /* Can afford to be brutal with the _extends initializer. + The derived type can get lost because it is PRIVATE + but it is not usage constrained by the standard. */ + cons->expr->ts = comp->ts; + } + else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) + { + gfc_error ("The element in the structure constructor at %L, " + "for pointer component %qs, is %s but should be %s", + &cons->expr->where, comp->name, + gfc_basic_typename (cons->expr->ts.type), + gfc_basic_typename (comp->ts.type)); + t = false; + } + else + { + bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); + if (t) + t = t2; + } + } + + /* For strings, the length of the constructor should be the same as + the one of the structure, ensure this if the lengths are known at + compile time and when we are dealing with PARAMETER or structure + constructors. */ + if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl + && comp->ts.u.cl->length + && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT + && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length + && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT + && cons->expr->rank != 0 + && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, + comp->ts.u.cl->length->value.integer) != 0) + { + if (cons->expr->expr_type == EXPR_VARIABLE + && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER) + { + /* Wrap the parameter in an array constructor (EXPR_ARRAY) + to make use of the gfc_resolve_character_array_constructor + machinery. The expression is later simplified away to + an array of string literals. */ + gfc_expr *para = cons->expr; + cons->expr = gfc_get_expr (); + cons->expr->ts = para->ts; + cons->expr->where = para->where; + cons->expr->expr_type = EXPR_ARRAY; + cons->expr->rank = para->rank; + cons->expr->shape = gfc_copy_shape (para->shape, para->rank); + gfc_constructor_append_expr (&cons->expr->value.constructor, + para, &cons->expr->where); + } + + if (cons->expr->expr_type == EXPR_ARRAY) + { + /* Rely on the cleanup of the namespace to deal correctly with + the old charlen. (There was a block here that attempted to + remove the charlen but broke the chain in so doing.) */ + cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + cons->expr->ts.u.cl->length_from_typespec = true; + cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length); + gfc_resolve_character_array_constructor (cons->expr); + } + } + + if (cons->expr->expr_type == EXPR_NULL + && !(comp->attr.pointer || comp->attr.allocatable + || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID + || (comp->ts.type == BT_CLASS + && (CLASS_DATA (comp)->attr.class_pointer + || CLASS_DATA (comp)->attr.allocatable)))) + { + t = false; + gfc_error ("The NULL in the structure constructor at %L is " + "being applied to component %qs, which is neither " + "a POINTER nor ALLOCATABLE", &cons->expr->where, + comp->name); + } + + if (comp->attr.proc_pointer && comp->ts.interface) + { + /* Check procedure pointer interface. */ + gfc_symbol *s2 = NULL; + gfc_component *c2; + const char *name; + char err[200]; + + c2 = gfc_get_proc_ptr_comp (cons->expr); + if (c2) + { + s2 = c2->ts.interface; + name = c2->name; + } + else if (cons->expr->expr_type == EXPR_FUNCTION) + { + s2 = cons->expr->symtree->n.sym->result; + name = cons->expr->symtree->n.sym->result->name; + } + else if (cons->expr->expr_type != EXPR_NULL) + { + s2 = cons->expr->symtree->n.sym; + name = cons->expr->symtree->n.sym->name; + } + + if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, + err, sizeof (err), NULL, NULL)) + { + gfc_error_opt (0, "Interface mismatch for procedure-pointer " + "component %qs in structure constructor at %L:" + " %s", comp->name, &cons->expr->where, err); + return false; + } + } + + /* Validate shape, except for dynamic or PDT arrays. */ + if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank + && comp->as && !comp->attr.allocatable && !comp->attr.pointer + && !comp->attr.pdt_array) + { + mpz_t len; + mpz_init (len); + for (int n = 0; n < rank; n++) + { + if (comp->as->upper[n]->expr_type != EXPR_CONSTANT + || comp->as->lower[n]->expr_type != EXPR_CONSTANT) + { + gfc_error ("Bad array spec of component %qs referenced in " + "structure constructor at %L", + comp->name, &cons->expr->where); + t = false; + break; + }; + mpz_set_ui (len, 1); + mpz_add (len, len, comp->as->upper[n]->value.integer); + mpz_sub (len, len, comp->as->lower[n]->value.integer); + if (mpz_cmp (cons->expr->shape[n], len) != 0) + { + gfc_error ("The shape of component %qs in the structure " + "constructor at %L differs from the shape of the " + "declared component for dimension %d (%ld/%ld)", + comp->name, &cons->expr->where, n+1, + mpz_get_si (cons->expr->shape[n]), + mpz_get_si (len)); + t = false; + } + } + mpz_clear (len); + } + + if (!comp->attr.pointer || comp->attr.proc_pointer + || cons->expr->expr_type == EXPR_NULL) + continue; + + a = gfc_expr_attr (cons->expr); + + if (!a.pointer && !a.target) + { + t = false; + gfc_error ("The element in the structure constructor at %L, " + "for pointer component %qs should be a POINTER or " + "a TARGET", &cons->expr->where, comp->name); + } + + if (init) + { + /* F08:C461. Additional checks for pointer initialization. */ + if (a.allocatable) + { + t = false; + gfc_error ("Pointer initialization target at %L " + "must not be ALLOCATABLE", &cons->expr->where); + } + if (!a.save) + { + t = false; + gfc_error ("Pointer initialization target at %L " + "must have the SAVE attribute", &cons->expr->where); + } + } + + /* F2003, C1272 (3). */ + bool impure = cons->expr->expr_type == EXPR_VARIABLE + && (gfc_impure_variable (cons->expr->symtree->n.sym) + || gfc_is_coindexed (cons->expr)); + if (impure && gfc_pure (NULL)) + { + t = false; + gfc_error ("Invalid expression in the structure constructor for " + "pointer component %qs at %L in PURE procedure", + comp->name, &cons->expr->where); + } + + if (impure) + gfc_unset_implicit_pure (NULL); + } + + return t; +} + + +/****************** Expression name resolution ******************/ + +/* Returns 0 if a symbol was not declared with a type or + attribute declaration statement, nonzero otherwise. */ + +static int +was_declared (gfc_symbol *sym) +{ + symbol_attribute a; + + a = sym->attr; + + if (!a.implicit_type && sym->ts.type != BT_UNKNOWN) + return 1; + + if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic + || a.optional || a.pointer || a.save || a.target || a.volatile_ + || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN + || a.asynchronous || a.codimension) + return 1; + + return 0; +} + + +/* Determine if a symbol is generic or not. */ + +static int +generic_sym (gfc_symbol *sym) +{ + gfc_symbol *s; + + if (sym->attr.generic || + (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name))) + return 1; + + if (was_declared (sym) || sym->ns->parent == NULL) + return 0; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); + + if (s != NULL) + { + if (s == sym) + return 0; + else + return generic_sym (s); + } + + return 0; +} + + +/* Determine if a symbol is specific or not. */ + +static int +specific_sym (gfc_symbol *sym) +{ + gfc_symbol *s; + + if (sym->attr.if_source == IFSRC_IFBODY + || sym->attr.proc == PROC_MODULE + || sym->attr.proc == PROC_INTERNAL + || sym->attr.proc == PROC_ST_FUNCTION + || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name)) + || sym->attr.external) + return 1; + + if (was_declared (sym) || sym->ns->parent == NULL) + return 0; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); + + return (s == NULL) ? 0 : specific_sym (s); +} + + +/* Figure out if the procedure is specific, generic or unknown. */ + +enum proc_type +{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }; + +static proc_type +procedure_kind (gfc_symbol *sym) +{ + if (generic_sym (sym)) + return PTYPE_GENERIC; + + if (specific_sym (sym)) + return PTYPE_SPECIFIC; + + return PTYPE_UNKNOWN; +} + +/* Check references to assumed size arrays. The flag need_full_assumed_size + is nonzero when matching actual arguments. */ + +static int need_full_assumed_size = 0; + +static bool +check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e) +{ + if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) + return false; + + /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong. + What should it be? */ + if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL) + && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) + && (e->ref->u.ar.type == AR_FULL)) + { + gfc_error ("The upper bound in the last dimension must " + "appear in the reference to the assumed size " + "array %qs at %L", sym->name, &e->where); + return true; + } + return false; +} + + +/* Look for bad assumed size array references in argument expressions + of elemental and array valued intrinsic procedures. Since this is + called from procedure resolution functions, it only recurses at + operators. */ + +static bool +resolve_assumed_size_actual (gfc_expr *e) +{ + if (e == NULL) + return false; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e)) + return true; + break; + + case EXPR_OP: + if (resolve_assumed_size_actual (e->value.op.op1) + || resolve_assumed_size_actual (e->value.op.op2)) + return true; + break; + + default: + break; + } + return false; +} + + +/* Check a generic procedure, passed as an actual argument, to see if + there is a matching specific name. If none, it is an error, and if + more than one, the reference is ambiguous. */ +static int +count_specific_procs (gfc_expr *e) +{ + int n; + gfc_interface *p; + gfc_symbol *sym; + + n = 0; + sym = e->symtree->n.sym; + + for (p = sym->generic; p; p = p->next) + if (strcmp (sym->name, p->sym->name) == 0) + { + e->symtree = gfc_find_symtree (p->sym->ns->sym_root, + sym->name); + n++; + } + + if (n > 1) + gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, + &e->where); + + if (n == 0) + gfc_error ("GENERIC procedure %qs is not allowed as an actual " + "argument at %L", sym->name, &e->where); + + return n; +} + + +/* See if a call to sym could possibly be a not allowed RECURSION because of + a missing RECURSIVE declaration. This means that either sym is the current + context itself, or sym is the parent of a contained procedure calling its + non-RECURSIVE containing procedure. + This also works if sym is an ENTRY. */ + +static bool +is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) +{ + gfc_symbol* proc_sym; + gfc_symbol* context_proc; + gfc_namespace* real_context; + + if (sym->attr.flavor == FL_PROGRAM + || gfc_fl_struct (sym->attr.flavor)) + return false; + + /* If we've got an ENTRY, find real procedure. */ + if (sym->attr.entry && sym->ns->entries) + proc_sym = sym->ns->entries->sym; + else + proc_sym = sym; + + /* If sym is RECURSIVE, all is well of course. */ + if (proc_sym->attr.recursive || flag_recursive) + return false; + + /* Find the context procedure's "real" symbol if it has entries. + We look for a procedure symbol, so recurse on the parents if we don't + find one (like in case of a BLOCK construct). */ + for (real_context = context; ; real_context = real_context->parent) + { + /* We should find something, eventually! */ + gcc_assert (real_context); + + context_proc = (real_context->entries ? real_context->entries->sym + : real_context->proc_name); + + /* In some special cases, there may not be a proc_name, like for this + invalid code: + real(bad_kind()) function foo () ... + when checking the call to bad_kind (). + In these cases, we simply return here and assume that the + call is ok. */ + if (!context_proc) + return false; + + if (context_proc->attr.flavor != FL_LABEL) + break; + } + + /* A call from sym's body to itself is recursion, of course. */ + if (context_proc == proc_sym) + return true; + + /* The same is true if context is a contained procedure and sym the + containing one. */ + if (context_proc->attr.contained) + { + gfc_symbol* parent_proc; + + gcc_assert (context->parent); + parent_proc = (context->parent->entries ? context->parent->entries->sym + : context->parent->proc_name); + + if (parent_proc == proc_sym) + return true; + } + + return false; +} + + +/* Resolve an intrinsic procedure: Set its function/subroutine attribute, + its typespec and formal argument list. */ + +bool +gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) +{ + gfc_intrinsic_sym* isym = NULL; + const char* symstd; + + if (sym->resolve_symbol_called >= 2) + return true; + + sym->resolve_symbol_called = 2; + + /* Already resolved. */ + if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) + return true; + + /* We already know this one is an intrinsic, so we don't call + gfc_is_intrinsic for full checking but rather use gfc_find_function and + gfc_find_subroutine directly to check whether it is a function or + subroutine. */ + + if (sym->intmod_sym_id && sym->attr.subroutine) + { + gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); + isym = gfc_intrinsic_subroutine_by_id (id); + } + else if (sym->intmod_sym_id) + { + gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); + isym = gfc_intrinsic_function_by_id (id); + } + else if (!sym->attr.subroutine) + isym = gfc_find_function (sym->name); + + if (isym && !sym->attr.subroutine) + { + if (sym->ts.type != BT_UNKNOWN && warn_surprising + && !sym->attr.implicit_type) + gfc_warning (OPT_Wsurprising, + "Type specified for intrinsic function %qs at %L is" + " ignored", sym->name, &sym->declared_at); + + if (!sym->attr.function && + !gfc_add_function(&sym->attr, sym->name, loc)) + return false; + + sym->ts = isym->ts; + } + else if (isym || (isym = gfc_find_subroutine (sym->name))) + { + if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) + { + gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" + " specifier", sym->name, &sym->declared_at); + return false; + } + + if (!sym->attr.subroutine && + !gfc_add_subroutine(&sym->attr, sym->name, loc)) + return false; + } + else + { + gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, + &sym->declared_at); + return false; + } + + gfc_copy_formal_args_intr (sym, isym, NULL); + + sym->attr.pure = isym->pure; + sym->attr.elemental = isym->elemental; + + /* Check it is actually available in the standard settings. */ + if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) + { + gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not " + "available in the current standard settings but %s. Use " + "an appropriate %<-std=*%> option or enable " + "%<-fall-intrinsics%> in order to use it.", + sym->name, &sym->declared_at, symstd); + return false; + } + + return true; +} + + +/* Resolve a procedure expression, like passing it to a called procedure or as + RHS for a procedure pointer assignment. */ + +static bool +resolve_procedure_expression (gfc_expr* expr) +{ + gfc_symbol* sym; + + if (expr->expr_type != EXPR_VARIABLE) + return true; + gcc_assert (expr->symtree); + + sym = expr->symtree->n.sym; + + if (sym->attr.intrinsic) + gfc_resolve_intrinsic (sym, &expr->where); + + if (sym->attr.flavor != FL_PROCEDURE + || (sym->attr.function && sym->result == sym)) + return true; + + /* A non-RECURSIVE procedure that is used as procedure expression within its + own body is in danger of being called recursively. */ + if (is_illegal_recursion (sym, gfc_current_ns)) + gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" + " itself recursively. Declare it RECURSIVE or use" + " %<-frecursive%>", sym->name, &expr->where); + + return true; +} + + +/* Check that name is not a derived type. */ + +static bool +is_dt_name (const char *name) +{ + gfc_symbol *dt_list, *dt_first; + + dt_list = dt_first = gfc_derived_types; + for (; dt_list; dt_list = dt_list->dt_next) + { + if (strcmp(dt_list->name, name) == 0) + return true; + if (dt_first == dt_list->dt_next) + break; + } + return false; +} + + +/* Resolve an actual argument list. Most of the time, this is just + resolving the expressions in the list. + The exception is that we sometimes have to decide whether arguments + that look like procedure arguments are really simple variable + references. */ + +static bool +resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, + bool no_formal_args) +{ + gfc_symbol *sym; + gfc_symtree *parent_st; + gfc_expr *e; + gfc_component *comp; + int save_need_full_assumed_size; + bool return_value = false; + bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; + + actual_arg = true; + first_actual_arg = true; + + for (; arg; arg = arg->next) + { + e = arg->expr; + if (e == NULL) + { + /* Check the label is a valid branching target. */ + if (arg->label) + { + if (arg->label->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("Label %d referenced at %L is never defined", + arg->label->value, &arg->label->where); + goto cleanup; + } + } + first_actual_arg = false; + continue; + } + + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.generic + && no_formal_args + && count_specific_procs (e) != 1) + goto cleanup; + + if (e->ts.type != BT_PROCEDURE) + { + save_need_full_assumed_size = need_full_assumed_size; + if (e->expr_type != EXPR_VARIABLE) + need_full_assumed_size = 0; + if (!gfc_resolve_expr (e)) + goto cleanup; + need_full_assumed_size = save_need_full_assumed_size; + goto argument_list; + } + + /* See if the expression node should really be a variable reference. */ + + sym = e->symtree->n.sym; + + if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name)) + { + gfc_error ("Derived type %qs is used as an actual " + "argument at %L", sym->name, &e->where); + goto cleanup; + } + + if (sym->attr.flavor == FL_PROCEDURE + || sym->attr.intrinsic + || sym->attr.external) + { + int actual_ok; + + /* If a procedure is not already determined to be something else + check if it is intrinsic. */ + if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) + sym->attr.intrinsic = 1; + + if (sym->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Statement function %qs at %L is not allowed as an " + "actual argument", sym->name, &e->where); + } + + actual_ok = gfc_intrinsic_actual_ok (sym->name, + sym->attr.subroutine); + if (sym->attr.intrinsic && actual_ok == 0) + { + gfc_error ("Intrinsic %qs at %L is not allowed as an " + "actual argument", sym->name, &e->where); + } + + if (sym->attr.contained && !sym->attr.use_assoc + && sym->ns->proc_name->attr.flavor != FL_MODULE) + { + if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is" + " used as actual argument at %L", + sym->name, &e->where)) + goto cleanup; + } + + if (sym->attr.elemental && !sym->attr.intrinsic) + { + gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " + "allowed as an actual argument at %L", sym->name, + &e->where); + } + + /* Check if a generic interface has a specific procedure + with the same name before emitting an error. */ + if (sym->attr.generic && count_specific_procs (e) != 1) + goto cleanup; + + /* Just in case a specific was found for the expression. */ + sym = e->symtree->n.sym; + + /* If the symbol is the function that names the current (or + parent) scope, then we really have a variable reference. */ + + if (gfc_is_function_return_value (sym, sym->ns)) + goto got_variable; + + /* If all else fails, see if we have a specific intrinsic. */ + if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) + { + gfc_intrinsic_sym *isym; + + isym = gfc_find_function (sym->name); + if (isym == NULL || !isym->specific) + { + gfc_error ("Unable to find a specific INTRINSIC procedure " + "for the reference %qs at %L", sym->name, + &e->where); + goto cleanup; + } + sym->ts = isym->ts; + sym->attr.intrinsic = 1; + sym->attr.function = 1; + } + + if (!gfc_resolve_expr (e)) + goto cleanup; + goto argument_list; + } + + /* See if the name is a module procedure in a parent unit. */ + + if (was_declared (sym) || sym->ns->parent == NULL) + goto got_variable; + + if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) + { + gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); + goto cleanup; + } + + if (parent_st == NULL) + goto got_variable; + + sym = parent_st->n.sym; + e->symtree = parent_st; /* Point to the right thing. */ + + if (sym->attr.flavor == FL_PROCEDURE + || sym->attr.intrinsic + || sym->attr.external) + { + if (!gfc_resolve_expr (e)) + goto cleanup; + goto argument_list; + } + + got_variable: + e->expr_type = EXPR_VARIABLE; + e->ts = sym->ts; + if ((sym->as != NULL && sym->ts.type != BT_CLASS) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as)) + { + e->rank = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as->rank : sym->as->rank; + e->ref = gfc_get_ref (); + e->ref->type = REF_ARRAY; + e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.as = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as : sym->as; + } + + /* Expressions are assigned a default ts.type of BT_PROCEDURE in + primary.c (match_actual_arg). If above code determines that it + is a variable instead, it needs to be resolved as it was not + done at the beginning of this function. */ + save_need_full_assumed_size = need_full_assumed_size; + if (e->expr_type != EXPR_VARIABLE) + need_full_assumed_size = 0; + if (!gfc_resolve_expr (e)) + goto cleanup; + need_full_assumed_size = save_need_full_assumed_size; + + argument_list: + /* Check argument list functions %VAL, %LOC and %REF. There is + nothing to do for %REF. */ + if (arg->name && arg->name[0] == '%') + { + if (strcmp ("%VAL", arg->name) == 0) + { + if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED) + { + gfc_error ("By-value argument at %L is not of numeric " + "type", &e->where); + goto cleanup; + } + + if (e->rank) + { + gfc_error ("By-value argument at %L cannot be an array or " + "an array section", &e->where); + goto cleanup; + } + + /* Intrinsics are still PROC_UNKNOWN here. However, + since same file external procedures are not resolvable + in gfortran, it is a good deal easier to leave them to + intrinsic.c. */ + if (ptype != PROC_UNKNOWN + && ptype != PROC_DUMMY + && ptype != PROC_EXTERNAL + && ptype != PROC_MODULE) + { + gfc_error ("By-value argument at %L is not allowed " + "in this context", &e->where); + goto cleanup; + } + } + + /* Statement functions have already been excluded above. */ + else if (strcmp ("%LOC", arg->name) == 0 + && e->ts.type == BT_PROCEDURE) + { + if (e->symtree->n.sym->attr.proc == PROC_INTERNAL) + { + gfc_error ("Passing internal procedure at %L by location " + "not allowed", &e->where); + goto cleanup; + } + } + } + + comp = gfc_get_proc_ptr_comp(e); + if (e->expr_type == EXPR_VARIABLE + && comp && comp->attr.elemental) + { + gfc_error ("ELEMENTAL procedure pointer component %qs is not " + "allowed as an actual argument at %L", comp->name, + &e->where); + } + + /* Fortran 2008, C1237. */ + if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) + && gfc_has_ultimate_pointer (e)) + { + gfc_error ("Coindexed actual argument at %L with ultimate pointer " + "component", &e->where); + goto cleanup; + } + + first_actual_arg = false; + } + + return_value = true; + +cleanup: + actual_arg = actual_arg_sav; + first_actual_arg = first_actual_arg_sav; + + return return_value; +} + + +/* Do the checks of the actual argument list that are specific to elemental + procedures. If called with c == NULL, we have a function, otherwise if + expr == NULL, we have a subroutine. */ + +static bool +resolve_elemental_actual (gfc_expr *expr, gfc_code *c) +{ + gfc_actual_arglist *arg0; + gfc_actual_arglist *arg; + gfc_symbol *esym = NULL; + gfc_intrinsic_sym *isym = NULL; + gfc_expr *e = NULL; + gfc_intrinsic_arg *iformal = NULL; + gfc_formal_arglist *eformal = NULL; + bool formal_optional = false; + bool set_by_optional = false; + int i; + int rank = 0; + + /* Is this an elemental procedure? */ + if (expr && expr->value.function.actual != NULL) + { + if (expr->value.function.esym != NULL + && expr->value.function.esym->attr.elemental) + { + arg0 = expr->value.function.actual; + esym = expr->value.function.esym; + } + else if (expr->value.function.isym != NULL + && expr->value.function.isym->elemental) + { + arg0 = expr->value.function.actual; + isym = expr->value.function.isym; + } + else + return true; + } + else if (c && c->ext.actual != NULL) + { + arg0 = c->ext.actual; + + if (c->resolved_sym) + esym = c->resolved_sym; + else + esym = c->symtree->n.sym; + gcc_assert (esym); + + if (!esym->attr.elemental) + return true; + } + else + return true; + + /* The rank of an elemental is the rank of its array argument(s). */ + for (arg = arg0; arg; arg = arg->next) + { + if (arg->expr != NULL && arg->expr->rank != 0) + { + rank = arg->expr->rank; + if (arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->symtree->n.sym->attr.optional) + set_by_optional = true; + + /* Function specific; set the result rank and shape. */ + if (expr) + { + expr->rank = rank; + if (!expr->shape && arg->expr->shape) + { + expr->shape = gfc_get_shape (rank); + for (i = 0; i < rank; i++) + mpz_init_set (expr->shape[i], arg->expr->shape[i]); + } + } + break; + } + } + + /* If it is an array, it shall not be supplied as an actual argument + to an elemental procedure unless an array of the same rank is supplied + as an actual argument corresponding to a nonoptional dummy argument of + that elemental procedure(12.4.1.5). */ + formal_optional = false; + if (isym) + iformal = isym->formal; + else + eformal = esym->formal; + + for (arg = arg0; arg; arg = arg->next) + { + if (eformal) + { + if (eformal->sym && eformal->sym->attr.optional) + formal_optional = true; + eformal = eformal->next; + } + else if (isym && iformal) + { + if (iformal->optional) + formal_optional = true; + iformal = iformal->next; + } + else if (isym) + formal_optional = true; + + if (pedantic && arg->expr != NULL + && arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->symtree->n.sym->attr.optional + && formal_optional + && arg->expr->rank + && (set_by_optional || arg->expr->rank != rank) + && !(isym && isym->id == GFC_ISYM_CONVERSION)) + { + bool t = false; + gfc_actual_arglist *a; + + /* Scan the argument list for a non-optional argument with the + same rank as arg. */ + for (a = arg0; a; a = a->next) + if (a != arg + && a->expr->rank == arg->expr->rank + && !a->expr->symtree->n.sym->attr.optional) + { + t = true; + break; + } + + if (!t) + gfc_warning (OPT_Wpedantic, + "%qs at %L is an array and OPTIONAL; If it is not " + "present, then it cannot be the actual argument of " + "an ELEMENTAL procedure unless there is a non-optional" + " argument with the same rank " + "(Fortran 2018, 15.5.2.12)", + arg->expr->symtree->n.sym->name, &arg->expr->where); + } + } + + for (arg = arg0; arg; arg = arg->next) + { + if (arg->expr == NULL || arg->expr->rank == 0) + continue; + + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + if (resolve_assumed_size_actual (arg->expr)) + return false; + + /* Elemental procedure's array actual arguments must conform. */ + if (e != NULL) + { + if (!gfc_check_conformance (arg->expr, e, _("elemental procedure"))) + return false; + } + else + e = arg->expr; + } + + /* INTENT(OUT) is only allowed for subroutines; if any actual argument + is an array, the intent inout/out variable needs to be also an array. */ + if (rank > 0 && esym && expr == NULL) + for (eformal = esym->formal, arg = arg0; arg && eformal; + arg = arg->next, eformal = eformal->next) + if ((eformal->sym->attr.intent == INTENT_OUT + || eformal->sym->attr.intent == INTENT_INOUT) + && arg->expr && arg->expr->rank == 0) + { + gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " + "ELEMENTAL subroutine %qs is a scalar, but another " + "actual argument is an array", &arg->expr->where, + (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" + : "INOUT", eformal->sym->name, esym->name); + return false; + } + return true; +} + + +/* This function does the checking of references to global procedures + as defined in sections 18.1 and 14.1, respectively, of the Fortran + 77 and 95 standards. It checks for a gsymbol for the name, making + one if it does not already exist. If it already exists, then the + reference being resolved must correspond to the type of gsymbol. + Otherwise, the new symbol is equipped with the attributes of the + reference. The corresponding code that is called in creating + global entities is parse.c. + + In addition, for all but -std=legacy, the gsymbols are used to + check the interfaces of external procedures from the same file. + The namespace of the gsymbol is resolved and then, once this is + done the interface is checked. */ + + +static bool +not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns) +{ + if (!gsym_ns->proc_name->attr.recursive) + return true; + + if (sym->ns == gsym_ns) + return false; + + if (sym->ns->parent && sym->ns->parent == gsym_ns) + return false; + + return true; +} + +static bool +not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) +{ + if (gsym_ns->entries) + { + gfc_entry_list *entry = gsym_ns->entries; + + for (; entry; entry = entry->next) + { + if (strcmp (sym->name, entry->sym->name) == 0) + { + if (strcmp (gsym_ns->proc_name->name, + sym->ns->proc_name->name) == 0) + return false; + + if (sym->ns->parent + && strcmp (gsym_ns->proc_name->name, + sym->ns->parent->proc_name->name) == 0) + return false; + } + } + } + return true; +} + + +/* Check for the requirement of an explicit interface. F08:12.4.2.2. */ + +bool +gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) +{ + gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym); + + for ( ; arg; arg = arg->next) + { + if (!arg->sym) + continue; + + if (arg->sym->attr.allocatable) /* (2a) */ + { + strncpy (errmsg, _("allocatable argument"), err_len); + return true; + } + else if (arg->sym->attr.asynchronous) + { + strncpy (errmsg, _("asynchronous argument"), err_len); + return true; + } + else if (arg->sym->attr.optional) + { + strncpy (errmsg, _("optional argument"), err_len); + return true; + } + else if (arg->sym->attr.pointer) + { + strncpy (errmsg, _("pointer argument"), err_len); + return true; + } + else if (arg->sym->attr.target) + { + strncpy (errmsg, _("target argument"), err_len); + return true; + } + else if (arg->sym->attr.value) + { + strncpy (errmsg, _("value argument"), err_len); + return true; + } + else if (arg->sym->attr.volatile_) + { + strncpy (errmsg, _("volatile argument"), err_len); + return true; + } + else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */ + { + strncpy (errmsg, _("assumed-shape argument"), err_len); + return true; + } + else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */ + { + strncpy (errmsg, _("assumed-rank argument"), err_len); + return true; + } + else if (arg->sym->attr.codimension) /* (2c) */ + { + strncpy (errmsg, _("coarray argument"), err_len); + return true; + } + else if (false) /* (2d) TODO: parametrized derived type */ + { + strncpy (errmsg, _("parametrized derived type argument"), err_len); + return true; + } + else if (arg->sym->ts.type == BT_CLASS) /* (2e) */ + { + strncpy (errmsg, _("polymorphic argument"), err_len); + return true; + } + else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + { + strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len); + return true; + } + else if (arg->sym->ts.type == BT_ASSUMED) + { + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + strncpy (errmsg, _("assumed-type argument"), err_len); + return true; + } + } + + if (sym->attr.function) + { + gfc_symbol *res = sym->result ? sym->result : sym; + + if (res->attr.dimension) /* (3a) */ + { + strncpy (errmsg, _("array result"), err_len); + return true; + } + else if (res->attr.pointer || res->attr.allocatable) /* (3b) */ + { + strncpy (errmsg, _("pointer or allocatable result"), err_len); + return true; + } + else if (res->ts.type == BT_CHARACTER && res->ts.u.cl + && res->ts.u.cl->length + && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */ + { + strncpy (errmsg, _("result with non-constant character length"), err_len); + return true; + } + } + + if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */ + { + strncpy (errmsg, _("elemental procedure"), err_len); + return true; + } + else if (sym->attr.is_bind_c) /* (5) */ + { + strncpy (errmsg, _("bind(c) procedure"), err_len); + return true; + } + + return false; +} + + +static void +resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) +{ + gfc_gsymbol * gsym; + gfc_namespace *ns; + enum gfc_symbol_type type; + char reason[200]; + + type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + + gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name, + sym->binding_label != NULL); + + if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) + gfc_global_used (gsym, where); + + if ((sym->attr.if_source == IFSRC_UNKNOWN + || sym->attr.if_source == IFSRC_IFBODY) + && gsym->type != GSYM_UNKNOWN + && !gsym->binding_label + && gsym->ns + && gsym->ns->proc_name + && not_in_recursive (sym, gsym->ns) + && not_entry_self_reference (sym, gsym->ns)) + { + gfc_symbol *def_sym; + def_sym = gsym->ns->proc_name; + + if (gsym->ns->resolved != -1) + { + + /* Resolve the gsymbol namespace if needed. */ + if (!gsym->ns->resolved) + { + gfc_symbol *old_dt_list; + + /* Stash away derived types so that the backend_decls + do not get mixed up. */ + old_dt_list = gfc_derived_types; + gfc_derived_types = NULL; + + gfc_resolve (gsym->ns); + + /* Store the new derived types with the global namespace. */ + if (gfc_derived_types) + gsym->ns->derived_types = gfc_derived_types; + + /* Restore the derived types of this namespace. */ + gfc_derived_types = old_dt_list; + } + + /* Make sure that translation for the gsymbol occurs before + the procedure currently being resolved. */ + ns = gfc_global_ns_list; + for (; ns && ns != gsym->ns; ns = ns->sibling) + { + if (ns->sibling == gsym->ns) + { + ns->sibling = gsym->ns->sibling; + gsym->ns->sibling = gfc_global_ns_list; + gfc_global_ns_list = gsym->ns; + break; + } + } + + /* This can happen if a binding name has been specified. */ + if (gsym->binding_label && gsym->sym_name != def_sym->name) + gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym); + + if (def_sym->attr.entry_master || def_sym->attr.entry) + { + gfc_entry_list *entry; + for (entry = gsym->ns->entries; entry; entry = entry->next) + if (strcmp (entry->sym->name, sym->name) == 0) + { + def_sym = entry->sym; + break; + } + } + } + + if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) + { + gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", + sym->name, &sym->declared_at, gfc_typename (&sym->ts), + gfc_typename (&def_sym->ts)); + goto done; + } + + if (sym->attr.if_source == IFSRC_UNKNOWN + && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) + { + gfc_error ("Explicit interface required for %qs at %L: %s", + sym->name, &sym->declared_at, reason); + goto done; + } + + bool bad_result_characteristics; + if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, + reason, sizeof(reason), NULL, NULL, + &bad_result_characteristics)) + { + /* Turn erros into warnings with -std=gnu and -std=legacy, + unless a function returns a wrong type, which can lead + to all kinds of ICEs and wrong code. */ + + if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU) + && !bad_result_characteristics) + gfc_errors_to_warnings (true); + + gfc_error ("Interface mismatch in global procedure %qs at %L: %s", + sym->name, &sym->declared_at, reason); + sym->error = 1; + gfc_errors_to_warnings (false); + goto done; + } + } + +done: + + if (gsym->type == GSYM_UNKNOWN) + { + gsym->type = type; + gsym->where = *where; + } + + gsym->used = 1; +} + + +/************* Function resolution *************/ + +/* Resolve a function call known to be generic. + Section 14.1.2.4.1. */ + +static match +resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) +{ + gfc_symbol *s; + + if (sym->attr.generic) + { + s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual); + if (s != NULL) + { + expr->value.function.name = s->name; + expr->value.function.esym = s; + + if (s->ts.type != BT_UNKNOWN) + expr->ts = s->ts; + else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN) + expr->ts = s->result->ts; + + if (s->as != NULL) + expr->rank = s->as->rank; + else if (s->result != NULL && s->result->as != NULL) + expr->rank = s->result->as->rank; + + gfc_set_sym_referenced (expr->value.function.esym); + + return MATCH_YES; + } + + /* TODO: Need to search for elemental references in generic + interface. */ + } + + if (sym->attr.intrinsic) + return gfc_intrinsic_func_interface (expr, 0); + + return MATCH_NO; +} + + +static bool +resolve_generic_f (gfc_expr *expr) +{ + gfc_symbol *sym; + match m; + gfc_interface *intr = NULL; + + sym = expr->symtree->n.sym; + + for (;;) + { + m = resolve_generic_f0 (expr, sym); + if (m == MATCH_YES) + return true; + else if (m == MATCH_ERROR) + return false; + +generic: + if (!intr) + for (intr = sym->generic; intr; intr = intr->next) + if (gfc_fl_struct (intr->sym->attr.flavor)) + break; + + if (sym->ns->parent == NULL) + break; + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym == NULL) + break; + if (!generic_sym (sym)) + goto generic; + } + + /* Last ditch attempt. See if the reference is to an intrinsic + that possesses a matching interface. 14.1.2.4 */ + if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) + { + if (gfc_init_expr_flag) + gfc_error ("Function %qs in initialization expression at %L " + "must be an intrinsic function", + expr->symtree->n.sym->name, &expr->where); + else + gfc_error ("There is no specific function for the generic %qs " + "at %L", expr->symtree->n.sym->name, &expr->where); + return false; + } + + if (intr) + { + if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, + NULL, false)) + return false; + if (!gfc_use_derived (expr->ts.u.derived)) + return false; + return resolve_structure_cons (expr, 0); + } + + m = gfc_intrinsic_func_interface (expr, 0); + if (m == MATCH_YES) + return true; + + if (m == MATCH_NO) + gfc_error ("Generic function %qs at %L is not consistent with a " + "specific intrinsic interface", expr->symtree->n.sym->name, + &expr->where); + + return false; +} + + +/* Resolve a function call known to be specific. */ + +static match +resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) +{ + match m; + + if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) + { + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + goto found; + } + + sym->attr.proc = PROC_EXTERNAL; + goto found; + } + + if (sym->attr.proc == PROC_MODULE + || sym->attr.proc == PROC_ST_FUNCTION + || sym->attr.proc == PROC_INTERNAL) + goto found; + + if (sym->attr.intrinsic) + { + m = gfc_intrinsic_func_interface (expr, 1); + if (m == MATCH_YES) + return MATCH_YES; + if (m == MATCH_NO) + gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " + "with an intrinsic", sym->name, &expr->where); + + return MATCH_ERROR; + } + + return MATCH_NO; + +found: + gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); + + if (sym->result) + expr->ts = sym->result->ts; + else + expr->ts = sym->ts; + expr->value.function.name = sym->name; + expr->value.function.esym = sym; + /* Prevent crash when sym->ts.u.derived->components is not set due to previous + error(s). */ + if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)) + return MATCH_ERROR; + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) + expr->rank = CLASS_DATA (sym)->as->rank; + else if (sym->as != NULL) + expr->rank = sym->as->rank; + + return MATCH_YES; +} + + +static bool +resolve_specific_f (gfc_expr *expr) +{ + gfc_symbol *sym; + match m; + + sym = expr->symtree->n.sym; + + for (;;) + { + m = resolve_specific_f0 (sym, expr); + if (m == MATCH_YES) + return true; + if (m == MATCH_ERROR) + return false; + + if (sym->ns->parent == NULL) + break; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym == NULL) + break; + } + + gfc_error ("Unable to resolve the specific function %qs at %L", + expr->symtree->n.sym->name, &expr->where); + + return true; +} + +/* Recursively append candidate SYM to CANDIDATES. Store the number of + candidates in CANDIDATES_LEN. */ + +static void +lookup_function_fuzzy_find_candidates (gfc_symtree *sym, + char **&candidates, + size_t &candidates_len) +{ + gfc_symtree *p; + + if (sym == NULL) + return; + if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external) + && sym->n.sym->attr.flavor == FL_PROCEDURE) + vec_push (candidates, candidates_len, sym->name); + + p = sym->left; + if (p) + lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); + + p = sym->right; + if (p) + lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); +} + + +/* Lookup function FN fuzzily, taking names in SYMROOT into account. */ + +const char* +gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot) +{ + char **candidates = NULL; + size_t candidates_len = 0; + lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len); + return gfc_closest_fuzzy_match (fn, candidates); +} + + +/* Resolve a procedure call not known to be generic nor specific. */ + +static bool +resolve_unknown_f (gfc_expr *expr) +{ + gfc_symbol *sym; + gfc_typespec *ts; + + sym = expr->symtree->n.sym; + + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + expr->value.function.name = sym->name; + goto set_type; + } + + /* See if we have an intrinsic function reference. */ + + if (gfc_is_intrinsic (sym, 0, expr->where)) + { + if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) + return true; + return false; + } + + /* IMPLICIT NONE (external) procedures require an explicit EXTERNAL attr. */ + /* Intrinsics were handled above, only non-intrinsics left here. */ + if (sym->attr.flavor == FL_PROCEDURE + && sym->attr.implicit_type + && sym->ns + && sym->ns->has_implicit_none_export) + { + gfc_error ("Missing explicit declaration with EXTERNAL attribute " + "for symbol %qs at %L", sym->name, &sym->declared_at); + sym->error = 1; + return false; + } + + /* The reference is to an external name. */ + + sym->attr.proc = PROC_EXTERNAL; + expr->value.function.name = sym->name; + expr->value.function.esym = expr->symtree->n.sym; + + if (sym->as != NULL) + expr->rank = sym->as->rank; + + /* Type of the expression is either the type of the symbol or the + default type of the symbol. */ + +set_type: + gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); + + if (sym->ts.type != BT_UNKNOWN) + expr->ts = sym->ts; + else + { + ts = gfc_get_default_type (sym->name, sym->ns); + + if (ts->type == BT_UNKNOWN) + { + const char *guessed + = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); + if (guessed) + gfc_error ("Function %qs at %L has no IMPLICIT type" + "; did you mean %qs?", + sym->name, &expr->where, guessed); + else + gfc_error ("Function %qs at %L has no IMPLICIT type", + sym->name, &expr->where); + return false; + } + else + expr->ts = *ts; + } + + return true; +} + + +/* Return true, if the symbol is an external procedure. */ +static bool +is_external_proc (gfc_symbol *sym) +{ + if (!sym->attr.dummy && !sym->attr.contained + && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) + && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.proc_pointer + && !sym->attr.use_assoc + && sym->name) + return true; + + return false; +} + + +/* Figure out if a function reference is pure or not. Also set the name + of the function for a potential error message. Return nonzero if the + function is PURE, zero if not. */ +static int +pure_stmt_function (gfc_expr *, gfc_symbol *); + +int +gfc_pure_function (gfc_expr *e, const char **name) +{ + int pure; + gfc_component *comp; + + *name = NULL; + + if (e->symtree != NULL + && e->symtree->n.sym != NULL + && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) + return pure_stmt_function (e, e->symtree->n.sym); + + comp = gfc_get_proc_ptr_comp (e); + if (comp) + { + pure = gfc_pure (comp->ts.interface); + *name = comp->name; + } + else if (e->value.function.esym) + { + pure = gfc_pure (e->value.function.esym); + *name = e->value.function.esym->name; + } + else if (e->value.function.isym) + { + pure = e->value.function.isym->pure + || e->value.function.isym->elemental; + *name = e->value.function.isym->name; + } + else + { + /* Implicit functions are not pure. */ + pure = 0; + *name = e->value.function.name; + } + + return pure; +} + + +/* Check if the expression is a reference to an implicitly pure function. */ + +int +gfc_implicit_pure_function (gfc_expr *e) +{ + gfc_component *comp = gfc_get_proc_ptr_comp (e); + if (comp) + return gfc_implicit_pure (comp->ts.interface); + else if (e->value.function.esym) + return gfc_implicit_pure (e->value.function.esym); + else + return 0; +} + + +static bool +impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym, + int *f ATTRIBUTE_UNUSED) +{ + const char *name; + + /* Don't bother recursing into other statement functions + since they will be checked individually for purity. */ + if (e->expr_type != EXPR_FUNCTION + || !e->symtree + || e->symtree->n.sym == sym + || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) + return false; + + return gfc_pure_function (e, &name) ? false : true; +} + + +static int +pure_stmt_function (gfc_expr *e, gfc_symbol *sym) +{ + return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1; +} + + +/* Check if an impure function is allowed in the current context. */ + +static bool check_pure_function (gfc_expr *e) +{ + const char *name = NULL; + if (!gfc_pure_function (e, &name) && name) + { + if (forall_flag) + { + gfc_error ("Reference to impure function %qs at %L inside a " + "FORALL %s", name, &e->where, + forall_flag == 2 ? "mask" : "block"); + return false; + } + else if (gfc_do_concurrent_flag) + { + gfc_error ("Reference to impure function %qs at %L inside a " + "DO CONCURRENT %s", name, &e->where, + gfc_do_concurrent_flag == 2 ? "mask" : "block"); + return false; + } + else if (gfc_pure (NULL)) + { + gfc_error ("Reference to impure function %qs at %L " + "within a PURE procedure", name, &e->where); + return false; + } + if (!gfc_implicit_pure_function (e)) + gfc_unset_implicit_pure (NULL); + } + return true; +} + + +/* Update current procedure's array_outer_dependency flag, considering + a call to procedure SYM. */ + +static void +update_current_proc_array_outer_dependency (gfc_symbol *sym) +{ + /* Check to see if this is a sibling function that has not yet + been resolved. */ + gfc_namespace *sibling = gfc_current_ns->sibling; + for (; sibling; sibling = sibling->sibling) + { + if (sibling->proc_name == sym) + { + gfc_resolve (sibling); + break; + } + } + + /* If SYM has references to outer arrays, so has the procedure calling + SYM. If SYM is a procedure pointer, we can assume the worst. */ + if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer) + && gfc_current_ns->proc_name) + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; +} + + +/* Resolve a function call, which means resolving the arguments, then figuring + out which entity the name refers to. */ + +static bool +resolve_function (gfc_expr *expr) +{ + gfc_actual_arglist *arg; + gfc_symbol *sym; + bool t; + int temp; + procedure_type p = PROC_INTRINSIC; + bool no_formal_args; + + sym = NULL; + if (expr->symtree) + sym = expr->symtree->n.sym; + + /* If this is a procedure pointer component, it has already been resolved. */ + if (gfc_is_proc_ptr_comp (expr)) + return true; + + /* Avoid re-resolving the arguments of caf_get, which can lead to inserting + another caf_get. */ + if (sym && sym->attr.intrinsic + && (sym->intmod_sym_id == GFC_ISYM_CAF_GET + || sym->intmod_sym_id == GFC_ISYM_CAF_SEND)) + return true; + + if (expr->ref) + { + gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name, + &expr->where); + return false; + } + + if (sym && sym->attr.intrinsic + && !gfc_resolve_intrinsic (sym, &expr->where)) + return false; + + if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) + { + gfc_error ("%qs at %L is not a function", sym->name, &expr->where); + return false; + } + + /* If this is a deferred TBP with an abstract interface (which may + of course be referenced), expr->value.function.esym will be set. */ + if (sym && sym->attr.abstract && !expr->value.function.esym) + { + gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", + sym->name, &expr->where); + return false; + } + + /* If this is a deferred TBP with an abstract interface, its result + cannot be an assumed length character (F2003: C418). */ + if (sym && sym->attr.abstract && sym->attr.function + && sym->result->ts.u.cl + && sym->result->ts.u.cl->length == NULL + && !sym->result->ts.deferred) + { + gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed " + "character length result (F2008: C418)", sym->name, + &sym->declared_at); + return false; + } + + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size++; + + if (expr->symtree && expr->symtree->n.sym) + p = expr->symtree->n.sym->attr.proc; + + if (expr->value.function.isym && expr->value.function.isym->inquiry) + inquiry_argument = true; + no_formal_args = sym && is_external_proc (sym) + && gfc_sym_get_dummy_args (sym) == NULL; + + if (!resolve_actual_arglist (expr->value.function.actual, + p, no_formal_args)) + { + inquiry_argument = false; + return false; + } + + inquiry_argument = false; + + /* Resume assumed_size checking. */ + need_full_assumed_size--; + + /* If the procedure is external, check for usage. */ + if (sym && is_external_proc (sym)) + resolve_global_procedure (sym, &expr->where, 0); + + if (sym && sym->ts.type == BT_CHARACTER + && sym->ts.u.cl + && sym->ts.u.cl->length == NULL + && !sym->attr.dummy + && !sym->ts.deferred + && expr->value.function.esym == NULL + && !sym->attr.contained) + { + /* Internal procedures are taken care of in resolve_contained_fntype. */ + gfc_error ("Function %qs is declared CHARACTER(*) and cannot " + "be used at %L since it is not a dummy argument", + sym->name, &expr->where); + return false; + } + + /* See if function is already resolved. */ + + if (expr->value.function.name != NULL + || expr->value.function.isym != NULL) + { + if (expr->ts.type == BT_UNKNOWN) + expr->ts = sym->ts; + t = true; + } + else + { + /* Apply the rules of section 14.1.2. */ + + switch (procedure_kind (sym)) + { + case PTYPE_GENERIC: + t = resolve_generic_f (expr); + break; + + case PTYPE_SPECIFIC: + t = resolve_specific_f (expr); + break; + + case PTYPE_UNKNOWN: + t = resolve_unknown_f (expr); + break; + + default: + gfc_internal_error ("resolve_function(): bad function type"); + } + } + + /* If the expression is still a function (it might have simplified), + then we check to see if we are calling an elemental function. */ + + if (expr->expr_type != EXPR_FUNCTION) + return t; + + /* Walk the argument list looking for invalid BOZ. */ + for (arg = expr->value.function.actual; arg; arg = arg->next) + if (arg->expr && arg->expr->ts.type == BT_BOZ) + { + gfc_error ("A BOZ literal constant at %L cannot appear as an " + "actual argument in a function reference", + &arg->expr->where); + return false; + } + + temp = need_full_assumed_size; + need_full_assumed_size = 0; + + if (!resolve_elemental_actual (expr, NULL)) + return false; + + if (omp_workshare_flag + && expr->value.function.esym + && ! gfc_elemental (expr->value.function.esym)) + { + gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed " + "in WORKSHARE construct", expr->value.function.esym->name, + &expr->where); + t = false; + } + +#define GENERIC_ID expr->value.function.isym->id + else if (expr->value.function.actual != NULL + && expr->value.function.isym != NULL + && GENERIC_ID != GFC_ISYM_LBOUND + && GENERIC_ID != GFC_ISYM_LCOBOUND + && GENERIC_ID != GFC_ISYM_UCOBOUND + && GENERIC_ID != GFC_ISYM_LEN + && GENERIC_ID != GFC_ISYM_LOC + && GENERIC_ID != GFC_ISYM_C_LOC + && GENERIC_ID != GFC_ISYM_PRESENT) + { + /* Array intrinsics must also have the last upper bound of an + assumed size array argument. UBOUND and SIZE have to be + excluded from the check if the second argument is anything + than a constant. */ + + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE) + && arg == expr->value.function.actual + && arg->next != NULL && arg->next->expr) + { + if (arg->next->expr->expr_type != EXPR_CONSTANT) + break; + + if (arg->next->name && strcmp (arg->next->name, "kind") == 0) + break; + + if ((int)mpz_get_si (arg->next->expr->value.integer) + < arg->expr->rank) + break; + } + + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return false; + } + } +#undef GENERIC_ID + + need_full_assumed_size = temp; + + if (!check_pure_function(expr)) + t = false; + + /* Functions without the RECURSIVE attribution are not allowed to + * call themselves. */ + if (expr->value.function.esym && !expr->value.function.esym->attr.recursive) + { + gfc_symbol *esym; + esym = expr->value.function.esym; + + if (is_illegal_recursion (esym, gfc_current_ns)) + { + if (esym->attr.entry && esym->ns->entries) + gfc_error ("ENTRY %qs at %L cannot be called recursively, as" + " function %qs is not RECURSIVE", + esym->name, &expr->where, esym->ns->entries->sym->name); + else + gfc_error ("Function %qs at %L cannot be called recursively, as it" + " is not RECURSIVE", esym->name, &expr->where); + + t = false; + } + } + + /* Character lengths of use associated functions may contains references to + symbols not referenced from the current program unit otherwise. Make sure + those symbols are marked as referenced. */ + + if (expr->ts.type == BT_CHARACTER && expr->value.function.esym + && expr->value.function.esym->attr.use_assoc) + { + gfc_expr_set_symbols_referenced (expr->ts.u.cl->length); + } + + /* Make sure that the expression has a typespec that works. */ + if (expr->ts.type == BT_UNKNOWN) + { + if (expr->symtree->n.sym->result + && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN + && !expr->symtree->n.sym->result->attr.proc_pointer) + expr->ts = expr->symtree->n.sym->result->ts; + } + + if (!expr->ref && !expr->value.function.isym) + { + if (expr->value.function.esym) + update_current_proc_array_outer_dependency (expr->value.function.esym); + else + update_current_proc_array_outer_dependency (sym); + } + else if (expr->ref) + /* typebound procedure: Assume the worst. */ + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + + if (expr->value.function.esym + && expr->value.function.esym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED)) + gfc_warning (OPT_Wdeprecated_declarations, + "Using function %qs at %L is deprecated", + sym->name, &expr->where); + return t; +} + + +/************* Subroutine resolution *************/ + +static bool +pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) +{ + if (gfc_pure (sym)) + return true; + + if (forall_flag) + { + gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", + name, loc); + return false; + } + else if (gfc_do_concurrent_flag) + { + gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " + "PURE", name, loc); + return false; + } + else if (gfc_pure (NULL)) + { + gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc); + return false; + } + + gfc_unset_implicit_pure (NULL); + return true; +} + + +static match +resolve_generic_s0 (gfc_code *c, gfc_symbol *sym) +{ + gfc_symbol *s; + + if (sym->attr.generic) + { + s = gfc_search_interface (sym->generic, 1, &c->ext.actual); + if (s != NULL) + { + c->resolved_sym = s; + if (!pure_subroutine (s, s->name, &c->loc)) + return MATCH_ERROR; + return MATCH_YES; + } + + /* TODO: Need to search for elemental references in generic interface. */ + } + + if (sym->attr.intrinsic) + return gfc_intrinsic_sub_interface (c, 0); + + return MATCH_NO; +} + + +static bool +resolve_generic_s (gfc_code *c) +{ + gfc_symbol *sym; + match m; + + sym = c->symtree->n.sym; + + for (;;) + { + m = resolve_generic_s0 (c, sym); + if (m == MATCH_YES) + return true; + else if (m == MATCH_ERROR) + return false; + +generic: + if (sym->ns->parent == NULL) + break; + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym == NULL) + break; + if (!generic_sym (sym)) + goto generic; + } + + /* Last ditch attempt. See if the reference is to an intrinsic + that possesses a matching interface. 14.1.2.4 */ + sym = c->symtree->n.sym; + + if (!gfc_is_intrinsic (sym, 1, c->loc)) + { + gfc_error ("There is no specific subroutine for the generic %qs at %L", + sym->name, &c->loc); + return false; + } + + m = gfc_intrinsic_sub_interface (c, 0); + if (m == MATCH_YES) + return true; + if (m == MATCH_NO) + gfc_error ("Generic subroutine %qs at %L is not consistent with an " + "intrinsic subroutine interface", sym->name, &c->loc); + + return false; +} + + +/* Resolve a subroutine call known to be specific. */ + +static match +resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) +{ + match m; + + if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) + { + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + goto found; + } + + sym->attr.proc = PROC_EXTERNAL; + goto found; + } + + if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL) + goto found; + + if (sym->attr.intrinsic) + { + m = gfc_intrinsic_sub_interface (c, 1); + if (m == MATCH_YES) + return MATCH_YES; + if (m == MATCH_NO) + gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible " + "with an intrinsic", sym->name, &c->loc); + + return MATCH_ERROR; + } + + return MATCH_NO; + +found: + gfc_procedure_use (sym, &c->ext.actual, &c->loc); + + c->resolved_sym = sym; + if (!pure_subroutine (sym, sym->name, &c->loc)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +static bool +resolve_specific_s (gfc_code *c) +{ + gfc_symbol *sym; + match m; + + sym = c->symtree->n.sym; + + for (;;) + { + m = resolve_specific_s0 (c, sym); + if (m == MATCH_YES) + return true; + if (m == MATCH_ERROR) + return false; + + if (sym->ns->parent == NULL) + break; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym == NULL) + break; + } + + sym = c->symtree->n.sym; + gfc_error ("Unable to resolve the specific subroutine %qs at %L", + sym->name, &c->loc); + + return false; +} + + +/* Resolve a subroutine call not known to be generic nor specific. */ + +static bool +resolve_unknown_s (gfc_code *c) +{ + gfc_symbol *sym; + + sym = c->symtree->n.sym; + + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + goto found; + } + + /* See if we have an intrinsic function reference. */ + + if (gfc_is_intrinsic (sym, 1, c->loc)) + { + if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES) + return true; + return false; + } + + /* The reference is to an external name. */ + +found: + gfc_procedure_use (sym, &c->ext.actual, &c->loc); + + c->resolved_sym = sym; + + return pure_subroutine (sym, sym->name, &c->loc); +} + + +/* Resolve a subroutine call. Although it was tempting to use the same code + for functions, subroutines and functions are stored differently and this + makes things awkward. */ + +static bool +resolve_call (gfc_code *c) +{ + bool t; + procedure_type ptype = PROC_INTRINSIC; + gfc_symbol *csym, *sym; + bool no_formal_args; + + csym = c->symtree ? c->symtree->n.sym : NULL; + + if (csym && csym->ts.type != BT_UNKNOWN) + { + gfc_error ("%qs at %L has a type, which is not consistent with " + "the CALL at %L", csym->name, &csym->declared_at, &c->loc); + return false; + } + + if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) + { + gfc_symtree *st; + gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st); + sym = st ? st->n.sym : NULL; + if (sym && csym != sym + && sym->ns == gfc_current_ns + && sym->attr.flavor == FL_PROCEDURE + && sym->attr.contained) + { + sym->refs++; + if (csym->attr.generic) + c->symtree->n.sym = sym; + else + c->symtree = st; + csym = c->symtree->n.sym; + } + } + + /* If this ia a deferred TBP, c->expr1 will be set. */ + if (!c->expr1 && csym) + { + if (csym->attr.abstract) + { + gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", + csym->name, &c->loc); + return false; + } + + /* Subroutines without the RECURSIVE attribution are not allowed to + call themselves. */ + if (is_illegal_recursion (csym, gfc_current_ns)) + { + if (csym->attr.entry && csym->ns->entries) + gfc_error ("ENTRY %qs at %L cannot be called recursively, " + "as subroutine %qs is not RECURSIVE", + csym->name, &c->loc, csym->ns->entries->sym->name); + else + gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, " + "as it is not RECURSIVE", csym->name, &c->loc); + + t = false; + } + } + + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size++; + + if (csym) + ptype = csym->attr.proc; + + no_formal_args = csym && is_external_proc (csym) + && gfc_sym_get_dummy_args (csym) == NULL; + if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args)) + return false; + + /* Resume assumed_size checking. */ + need_full_assumed_size--; + + /* If external, check for usage. */ + if (csym && is_external_proc (csym)) + resolve_global_procedure (csym, &c->loc, 1); + + t = true; + if (c->resolved_sym == NULL) + { + c->resolved_isym = NULL; + switch (procedure_kind (csym)) + { + case PTYPE_GENERIC: + t = resolve_generic_s (c); + break; + + case PTYPE_SPECIFIC: + t = resolve_specific_s (c); + break; + + case PTYPE_UNKNOWN: + t = resolve_unknown_s (c); + break; + + default: + gfc_internal_error ("resolve_subroutine(): bad function type"); + } + } + + /* Some checks of elemental subroutine actual arguments. */ + if (!resolve_elemental_actual (NULL, c)) + return false; + + if (!c->expr1) + update_current_proc_array_outer_dependency (csym); + else + /* Typebound procedure: Assume the worst. */ + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + + if (c->resolved_sym + && c->resolved_sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED)) + gfc_warning (OPT_Wdeprecated_declarations, + "Using subroutine %qs at %L is deprecated", + c->resolved_sym->name, &c->loc); + + return t; +} + + +/* Compare the shapes of two arrays that have non-NULL shapes. If both + op1->shape and op2->shape are non-NULL return true if their shapes + match. If both op1->shape and op2->shape are non-NULL return false + if their shapes do not match. If either op1->shape or op2->shape is + NULL, return true. */ + +static bool +compare_shapes (gfc_expr *op1, gfc_expr *op2) +{ + bool t; + int i; + + t = true; + + if (op1->shape != NULL && op2->shape != NULL) + { + for (i = 0; i < op1->rank; i++) + { + if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) + { + gfc_error ("Shapes for operands at %L and %L are not conformable", + &op1->where, &op2->where); + t = false; + break; + } + } + } + + return t; +} + +/* Convert a logical operator to the corresponding bitwise intrinsic call. + For example A .AND. B becomes IAND(A, B). */ +static gfc_expr * +logical_to_bitwise (gfc_expr *e) +{ + gfc_expr *tmp, *op1, *op2; + gfc_isym_id isym; + gfc_actual_arglist *args = NULL; + + gcc_assert (e->expr_type == EXPR_OP); + + isym = GFC_ISYM_NONE; + op1 = e->value.op.op1; + op2 = e->value.op.op2; + + switch (e->value.op.op) + { + case INTRINSIC_NOT: + isym = GFC_ISYM_NOT; + break; + case INTRINSIC_AND: + isym = GFC_ISYM_IAND; + break; + case INTRINSIC_OR: + isym = GFC_ISYM_IOR; + break; + case INTRINSIC_NEQV: + isym = GFC_ISYM_IEOR; + break; + case INTRINSIC_EQV: + /* "Bitwise eqv" is just the complement of NEQV === IEOR. + Change the old expression to NEQV, which will get replaced by IEOR, + and wrap it in NOT. */ + tmp = gfc_copy_expr (e); + tmp->value.op.op = INTRINSIC_NEQV; + tmp = logical_to_bitwise (tmp); + isym = GFC_ISYM_NOT; + op1 = tmp; + op2 = NULL; + break; + default: + gfc_internal_error ("logical_to_bitwise(): Bad intrinsic"); + } + + /* Inherit the original operation's operands as arguments. */ + args = gfc_get_actual_arglist (); + args->expr = op1; + if (op2) + { + args->next = gfc_get_actual_arglist (); + args->next->expr = op2; + } + + /* Convert the expression to a function call. */ + e->expr_type = EXPR_FUNCTION; + e->value.function.actual = args; + e->value.function.isym = gfc_intrinsic_function_by_id (isym); + e->value.function.name = e->value.function.isym->name; + e->value.function.esym = NULL; + + /* Make up a pre-resolved function call symtree if we need to. */ + if (!e->symtree || !e->symtree->n.sym) + { + gfc_symbol *sym; + gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree); + sym = e->symtree->n.sym; + sym->result = sym; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.function = 1; + sym->attr.elemental = 1; + sym->attr.pure = 1; + sym->attr.referenced = 1; + gfc_intrinsic_symbol (sym); + gfc_commit_symbol (sym); + } + + args->name = e->value.function.isym->formal->name; + if (e->value.function.isym->formal->next) + args->next->name = e->value.function.isym->formal->next->name; + + return e; +} + +/* Recursively append candidate UOP to CANDIDATES. Store the number of + candidates in CANDIDATES_LEN. */ +static void +lookup_uop_fuzzy_find_candidates (gfc_symtree *uop, + char **&candidates, + size_t &candidates_len) +{ + gfc_symtree *p; + + if (uop == NULL) + return; + + /* Not sure how to properly filter here. Use all for a start. + n.uop.op is NULL for empty interface operators (is that legal?) disregard + these as i suppose they don't make terribly sense. */ + + if (uop->n.uop->op != NULL) + vec_push (candidates, candidates_len, uop->name); + + p = uop->left; + if (p) + lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); + + p = uop->right; + if (p) + lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); +} + +/* Lookup user-operator OP fuzzily, taking names in UOP into account. */ + +static const char* +lookup_uop_fuzzy (const char *op, gfc_symtree *uop) +{ + char **candidates = NULL; + size_t candidates_len = 0; + lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len); + return gfc_closest_fuzzy_match (op, candidates); +} + + +/* Callback finding an impure function as an operand to an .and. or + .or. expression. Remember the last function warned about to + avoid double warnings when recursing. */ + +static int +impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + gfc_expr *f = *e; + const char *name; + static gfc_expr *last = NULL; + bool *found = (bool *) data; + + if (f->expr_type == EXPR_FUNCTION) + { + *found = 1; + if (f != last && !gfc_pure_function (f, &name) + && !gfc_implicit_pure_function (f)) + { + if (name) + gfc_warning (OPT_Wfunction_elimination, + "Impure function %qs at %L might not be evaluated", + name, &f->where); + else + gfc_warning (OPT_Wfunction_elimination, + "Impure function at %L might not be evaluated", + &f->where); + } + last = f; + } + + return 0; +} + +/* Return true if TYPE is character based, false otherwise. */ + +static int +is_character_based (bt type) +{ + return type == BT_CHARACTER || type == BT_HOLLERITH; +} + + +/* If expression is a hollerith, convert it to character and issue a warning + for the conversion. */ + +static void +convert_hollerith_to_character (gfc_expr *e) +{ + if (e->ts.type == BT_HOLLERITH) + { + gfc_typespec t; + gfc_clear_ts (&t); + t.type = BT_CHARACTER; + t.kind = e->ts.kind; + gfc_convert_type_warn (e, &t, 2, 1); + } +} + +/* Convert to numeric and issue a warning for the conversion. */ + +static void +convert_to_numeric (gfc_expr *a, gfc_expr *b) +{ + gfc_typespec t; + gfc_clear_ts (&t); + t.type = b->ts.type; + t.kind = b->ts.kind; + gfc_convert_type_warn (a, &t, 2, 1); +} + +/* Resolve an operator expression node. This can involve replacing the + operation with a user defined function call. */ + +static bool +resolve_operator (gfc_expr *e) +{ + gfc_expr *op1, *op2; + /* One error uses 3 names; additional space for wording (also via gettext). */ + char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50]; + bool dual_locus_error; + bool t = true; + + /* Resolve all subnodes-- give them types. */ + + switch (e->value.op.op) + { + default: + if (!gfc_resolve_expr (e->value.op.op2)) + t = false; + + /* Fall through. */ + + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_PARENTHESES: + if (!gfc_resolve_expr (e->value.op.op1)) + return false; + if (e->value.op.op1 + && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2) + { + gfc_error ("BOZ literal constant at %L cannot be an operand of " + "unary operator %qs", &e->value.op.op1->where, + gfc_op2string (e->value.op.op)); + return false; + } + break; + } + + /* Typecheck the new node. */ + + op1 = e->value.op.op1; + op2 = e->value.op.op2; + if (op1 == NULL && op2 == NULL) + return false; + /* Error out if op2 did not resolve. We already diagnosed op1. */ + if (t == false) + return false; + + dual_locus_error = false; + + /* op1 and op2 cannot both be BOZ. */ + if (op1 && op1->ts.type == BT_BOZ + && op2 && op2->ts.type == BT_BOZ) + { + gfc_error ("Operands at %L and %L cannot appear as operands of " + "binary operator %qs", &op1->where, &op2->where, + gfc_op2string (e->value.op.op)); + return false; + } + + if ((op1 && op1->expr_type == EXPR_NULL) + || (op2 && op2->expr_type == EXPR_NULL)) + { + snprintf (msg, sizeof (msg), + _("Invalid context for NULL() pointer at %%L")); + goto bad_op; + } + + switch (e->value.op.op) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + if (op1->ts.type == BT_INTEGER + || op1->ts.type == BT_REAL + || op1->ts.type == BT_COMPLEX) + { + e->ts = op1->ts; + break; + } + + snprintf (msg, sizeof (msg), + _("Operand of unary numeric operator %%<%s%%> at %%L is %s"), + gfc_op2string (e->value.op.op), gfc_typename (e)); + goto bad_op; + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) + { + gfc_type_convert_binary (e, 1); + break; + } + + if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED) + snprintf (msg, sizeof (msg), + _("Unexpected derived-type entities in binary intrinsic " + "numeric operator %%<%s%%> at %%L"), + gfc_op2string (e->value.op.op)); + else + snprintf (msg, sizeof(msg), + _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"), + gfc_op2string (e->value.op.op), gfc_typename (op1), + gfc_typename (op2)); + goto bad_op; + + case INTRINSIC_CONCAT: + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && op1->ts.kind == op2->ts.kind) + { + e->ts.type = BT_CHARACTER; + e->ts.kind = op1->ts.kind; + break; + } + + snprintf (msg, sizeof (msg), + _("Operands of string concatenation operator at %%L are %s/%s"), + gfc_typename (op1), gfc_typename (op2)); + goto bad_op; + + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) + { + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_kind_max (op1, op2); + if (op1->ts.kind < e->ts.kind) + gfc_convert_type (op1, &e->ts, 2); + else if (op2->ts.kind < e->ts.kind) + gfc_convert_type (op2, &e->ts, 2); + + if (flag_frontend_optimize && + (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR)) + { + /* Warn about short-circuiting + with impure function as second operand. */ + bool op2_f = false; + gfc_expr_walker (&op2, impure_function_callback, &op2_f); + } + break; + } + + /* Logical ops on integers become bitwise ops with -fdec. */ + else if (flag_dec + && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER)) + { + e->ts.type = BT_INTEGER; + e->ts.kind = gfc_kind_max (op1, op2); + if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind) + gfc_convert_type (op1, &e->ts, 1); + if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind) + gfc_convert_type (op2, &e->ts, 1); + e = logical_to_bitwise (e); + goto simplify_op; + } + + snprintf (msg, sizeof (msg), + _("Operands of logical operator %%<%s%%> at %%L are %s/%s"), + gfc_op2string (e->value.op.op), gfc_typename (op1), + gfc_typename (op2)); + + goto bad_op; + + case INTRINSIC_NOT: + /* Logical ops on integers become bitwise ops with -fdec. */ + if (flag_dec && op1->ts.type == BT_INTEGER) + { + e->ts.type = BT_INTEGER; + e->ts.kind = op1->ts.kind; + e = logical_to_bitwise (e); + goto simplify_op; + } + + if (op1->ts.type == BT_LOGICAL) + { + e->ts.type = BT_LOGICAL; + e->ts.kind = op1->ts.kind; + break; + } + + snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"), + gfc_typename (op1)); + goto bad_op; + + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) + { + strcpy (msg, _("COMPLEX quantities cannot be compared at %L")); + goto bad_op; + } + + /* Fall through. */ + + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + + if (flag_dec + && is_character_based (op1->ts.type) + && is_character_based (op2->ts.type)) + { + convert_hollerith_to_character (op1); + convert_hollerith_to_character (op2); + } + + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && op1->ts.kind == op2->ts.kind) + { + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_default_logical_kind; + break; + } + + /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */ + if (op1->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear " + "as an operand of a relational operator"), + &op1->where)) + return false; + + if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind)) + return false; + + if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind)) + return false; + } + + /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */ + if (op2->ts.type == BT_BOZ) + { + if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear" + " as an operand of a relational operator"), + &op2->where)) + return false; + + if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind)) + return false; + + if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind)) + return false; + } + if (flag_dec + && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts)) + convert_to_numeric (op1, op2); + + if (flag_dec + && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH) + convert_to_numeric (op2, op1); + + if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) + { + gfc_type_convert_binary (e, 1); + + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_default_logical_kind; + + if (warn_compare_reals) + { + gfc_intrinsic_op op = e->value.op.op; + + /* Type conversion has made sure that the types of op1 and op2 + agree, so it is only necessary to check the first one. */ + if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX) + && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS + || op == INTRINSIC_NE || op == INTRINSIC_NE_OS)) + { + const char *msg; + + if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS) + msg = G_("Equality comparison for %s at %L"); + else + msg = G_("Inequality comparison for %s at %L"); + + gfc_warning (OPT_Wcompare_reals, msg, + gfc_typename (op1), &op1->where); + } + } + + break; + } + + if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) + snprintf (msg, sizeof (msg), + _("Logicals at %%L must be compared with %s instead of %s"), + (e->value.op.op == INTRINSIC_EQ + || e->value.op.op == INTRINSIC_EQ_OS) + ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); + else + snprintf (msg, sizeof (msg), + _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"), + gfc_op2string (e->value.op.op), gfc_typename (op1), + gfc_typename (op2)); + + goto bad_op; + + case INTRINSIC_USER: + if (e->value.op.uop->op == NULL) + { + const char *name = e->value.op.uop->name; + const char *guessed; + guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root); + if (guessed) + snprintf (msg, sizeof (msg), + _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"), + name, guessed); + else + snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"), + name); + } + else if (op2 == NULL) + snprintf (msg, sizeof (msg), + _("Operand of user operator %%<%s%%> at %%L is %s"), + e->value.op.uop->name, gfc_typename (op1)); + else + { + snprintf (msg, sizeof (msg), + _("Operands of user operator %%<%s%%> at %%L are %s/%s"), + e->value.op.uop->name, gfc_typename (op1), + gfc_typename (op2)); + e->value.op.uop->op->sym->attr.referenced = 1; + } + + goto bad_op; + + case INTRINSIC_PARENTHESES: + e->ts = op1->ts; + if (e->ts.type == BT_CHARACTER) + e->ts.u.cl = op1->ts.u.cl; + break; + + default: + gfc_internal_error ("resolve_operator(): Bad intrinsic"); + } + + /* Deal with arrayness of an operand through an operator. */ + + switch (e->value.op.op) + { + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + case INTRINSIC_CONCAT: + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + case INTRINSIC_EQ: + case INTRINSIC_EQ_OS: + case INTRINSIC_NE: + case INTRINSIC_NE_OS: + case INTRINSIC_GT: + case INTRINSIC_GT_OS: + case INTRINSIC_GE: + case INTRINSIC_GE_OS: + case INTRINSIC_LT: + case INTRINSIC_LT_OS: + case INTRINSIC_LE: + case INTRINSIC_LE_OS: + + if (op1->rank == 0 && op2->rank == 0) + e->rank = 0; + + if (op1->rank == 0 && op2->rank != 0) + { + e->rank = op2->rank; + + if (e->shape == NULL) + e->shape = gfc_copy_shape (op2->shape, op2->rank); + } + + if (op1->rank != 0 && op2->rank == 0) + { + e->rank = op1->rank; + + if (e->shape == NULL) + e->shape = gfc_copy_shape (op1->shape, op1->rank); + } + + if (op1->rank != 0 && op2->rank != 0) + { + if (op1->rank == op2->rank) + { + e->rank = op1->rank; + if (e->shape == NULL) + { + t = compare_shapes (op1, op2); + if (!t) + e->shape = NULL; + else + e->shape = gfc_copy_shape (op1->shape, op1->rank); + } + } + else + { + /* Allow higher level expressions to work. */ + e->rank = 0; + + /* Try user-defined operators, and otherwise throw an error. */ + dual_locus_error = true; + snprintf (msg, sizeof (msg), + _("Inconsistent ranks for operator at %%L and %%L")); + goto bad_op; + } + } + + break; + + case INTRINSIC_PARENTHESES: + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + /* Simply copy arrayness attribute */ + e->rank = op1->rank; + + if (e->shape == NULL) + e->shape = gfc_copy_shape (op1->shape, op1->rank); + + break; + + default: + break; + } + +simplify_op: + + /* Attempt to simplify the expression. */ + if (t) + { + t = gfc_simplify_expr (e, 0); + /* Some calls do not succeed in simplification and return false + even though there is no error; e.g. variable references to + PARAMETER arrays. */ + if (!gfc_is_constant_expr (e)) + t = true; + } + return t; + +bad_op: + + { + match m = gfc_extend_expr (e); + if (m == MATCH_YES) + return true; + if (m == MATCH_ERROR) + return false; + } + + if (dual_locus_error) + gfc_error (msg, &op1->where, &op2->where); + else + gfc_error (msg, &e->where); + + return false; +} + + +/************** Array resolution subroutines **************/ + +enum compare_result +{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }; + +/* Compare two integer expressions. */ + +static compare_result +compare_bound (gfc_expr *a, gfc_expr *b) +{ + int i; + + if (a == NULL || a->expr_type != EXPR_CONSTANT + || b == NULL || b->expr_type != EXPR_CONSTANT) + return CMP_UNKNOWN; + + /* If either of the types isn't INTEGER, we must have + raised an error earlier. */ + + if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER) + return CMP_UNKNOWN; + + i = mpz_cmp (a->value.integer, b->value.integer); + + if (i < 0) + return CMP_LT; + if (i > 0) + return CMP_GT; + return CMP_EQ; +} + + +/* Compare an integer expression with an integer. */ + +static compare_result +compare_bound_int (gfc_expr *a, int b) +{ + int i; + + if (a == NULL || a->expr_type != EXPR_CONSTANT) + return CMP_UNKNOWN; + + if (a->ts.type != BT_INTEGER) + gfc_internal_error ("compare_bound_int(): Bad expression"); + + i = mpz_cmp_si (a->value.integer, b); + + if (i < 0) + return CMP_LT; + if (i > 0) + return CMP_GT; + return CMP_EQ; +} + + +/* Compare an integer expression with a mpz_t. */ + +static compare_result +compare_bound_mpz_t (gfc_expr *a, mpz_t b) +{ + int i; + + if (a == NULL || a->expr_type != EXPR_CONSTANT) + return CMP_UNKNOWN; + + if (a->ts.type != BT_INTEGER) + gfc_internal_error ("compare_bound_int(): Bad expression"); + + i = mpz_cmp (a->value.integer, b); + + if (i < 0) + return CMP_LT; + if (i > 0) + return CMP_GT; + return CMP_EQ; +} + + +/* Compute the last value of a sequence given by a triplet. + Return 0 if it wasn't able to compute the last value, or if the + sequence if empty, and 1 otherwise. */ + +static int +compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end, + gfc_expr *stride, mpz_t last) +{ + mpz_t rem; + + if (start == NULL || start->expr_type != EXPR_CONSTANT + || end == NULL || end->expr_type != EXPR_CONSTANT + || (stride != NULL && stride->expr_type != EXPR_CONSTANT)) + return 0; + + if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER + || (stride != NULL && stride->ts.type != BT_INTEGER)) + return 0; + + if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ) + { + if (compare_bound (start, end) == CMP_GT) + return 0; + mpz_set (last, end->value.integer); + return 1; + } + + if (compare_bound_int (stride, 0) == CMP_GT) + { + /* Stride is positive */ + if (mpz_cmp (start->value.integer, end->value.integer) > 0) + return 0; + } + else + { + /* Stride is negative */ + if (mpz_cmp (start->value.integer, end->value.integer) < 0) + return 0; + } + + mpz_init (rem); + mpz_sub (rem, end->value.integer, start->value.integer); + mpz_tdiv_r (rem, rem, stride->value.integer); + mpz_sub (last, end->value.integer, rem); + mpz_clear (rem); + + return 1; +} + + +/* Compare a single dimension of an array reference to the array + specification. */ + +static bool +check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) +{ + mpz_t last_value; + + if (ar->dimen_type[i] == DIMEN_STAR) + { + gcc_assert (ar->stride[i] == NULL); + /* This implies [*] as [*:] and [*:3] are not possible. */ + if (ar->start[i] == NULL) + { + gcc_assert (ar->end[i] == NULL); + return true; + } + } + +/* Given start, end and stride values, calculate the minimum and + maximum referenced indexes. */ + + switch (ar->dimen_type[i]) + { + case DIMEN_VECTOR: + case DIMEN_THIS_IMAGE: + break; + + case DIMEN_STAR: + case DIMEN_ELEMENT: + if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) + { + if (i < as->rank) + gfc_warning (0, "Array reference at %L is out of bounds " + "(%ld < %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), i+1); + else + gfc_warning (0, "Array reference at %L is out of bounds " + "(%ld < %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), + i + 1 - as->rank); + return true; + } + if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) + { + if (i < as->rank) + gfc_warning (0, "Array reference at %L is out of bounds " + "(%ld > %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), i+1); + else + gfc_warning (0, "Array reference at %L is out of bounds " + "(%ld > %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), + i + 1 - as->rank); + return true; + } + + break; + + case DIMEN_RANGE: + { +#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i]) +#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i]) + + compare_result comp_start_end = compare_bound (AR_START, AR_END); + + /* Check for zero stride, which is not allowed. */ + if (compare_bound_int (ar->stride[i], 0) == CMP_EQ) + { + gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]); + return false; + } + + /* if start == len || (stride > 0 && start < len) + || (stride < 0 && start > len), + then the array section contains at least one element. In this + case, there is an out-of-bounds access if + (start < lower || start > upper). */ + if (compare_bound (AR_START, AR_END) == CMP_EQ + || ((compare_bound_int (ar->stride[i], 0) == CMP_GT + || ar->stride[i] == NULL) && comp_start_end == CMP_LT) + || (compare_bound_int (ar->stride[i], 0) == CMP_LT + && comp_start_end == CMP_GT)) + { + if (compare_bound (AR_START, as->lower[i]) == CMP_LT) + { + gfc_warning (0, "Lower array reference at %L is out of bounds " + "(%ld < %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (AR_START->value.integer), + mpz_get_si (as->lower[i]->value.integer), i+1); + return true; + } + if (compare_bound (AR_START, as->upper[i]) == CMP_GT) + { + gfc_warning (0, "Lower array reference at %L is out of bounds " + "(%ld > %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (AR_START->value.integer), + mpz_get_si (as->upper[i]->value.integer), i+1); + return true; + } + } + + /* If we can compute the highest index of the array section, + then it also has to be between lower and upper. */ + mpz_init (last_value); + if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i], + last_value)) + { + if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT) + { + gfc_warning (0, "Upper array reference at %L is out of bounds " + "(%ld < %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (last_value), + mpz_get_si (as->lower[i]->value.integer), i+1); + mpz_clear (last_value); + return true; + } + if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) + { + gfc_warning (0, "Upper array reference at %L is out of bounds " + "(%ld > %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (last_value), + mpz_get_si (as->upper[i]->value.integer), i+1); + mpz_clear (last_value); + return true; + } + } + mpz_clear (last_value); + +#undef AR_START +#undef AR_END + } + break; + + default: + gfc_internal_error ("check_dimension(): Bad array reference"); + } + + return true; +} + + +/* Compare an array reference with an array specification. */ + +static bool +compare_spec_to_ref (gfc_array_ref *ar) +{ + gfc_array_spec *as; + int i; + + as = ar->as; + i = as->rank - 1; + /* TODO: Full array sections are only allowed as actual parameters. */ + if (as->type == AS_ASSUMED_SIZE + && (/*ar->type == AR_FULL + ||*/ (ar->type == AR_SECTION + && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL))) + { + gfc_error ("Rightmost upper bound of assumed size array section " + "not specified at %L", &ar->where); + return false; + } + + if (ar->type == AR_FULL) + return true; + + if (as->rank != ar->dimen) + { + gfc_error ("Rank mismatch in array reference at %L (%d/%d)", + &ar->where, ar->dimen, as->rank); + return false; + } + + /* ar->codimen == 0 is a local array. */ + if (as->corank != ar->codimen && ar->codimen != 0) + { + gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", + &ar->where, ar->codimen, as->corank); + return false; + } + + for (i = 0; i < as->rank; i++) + if (!check_dimension (i, ar, as)) + return false; + + /* Local access has no coarray spec. */ + if (ar->codimen != 0) + for (i = as->rank; i < as->rank + as->corank; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate + && ar->dimen_type[i] != DIMEN_THIS_IMAGE) + { + gfc_error ("Coindex of codimension %d must be a scalar at %L", + i + 1 - as->rank, &ar->where); + return false; + } + if (!check_dimension (i, ar, as)) + return false; + } + + return true; +} + + +/* Resolve one part of an array index. */ + +static bool +gfc_resolve_index_1 (gfc_expr *index, int check_scalar, + int force_index_integer_kind) +{ + gfc_typespec ts; + + if (index == NULL) + return true; + + if (!gfc_resolve_expr (index)) + return false; + + if (check_scalar && index->rank != 0) + { + gfc_error ("Array index at %L must be scalar", &index->where); + return false; + } + + if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) + { + gfc_error ("Array index at %L must be of INTEGER type, found %s", + &index->where, gfc_basic_typename (index->ts.type)); + return false; + } + + if (index->ts.type == BT_REAL) + if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", + &index->where)) + return false; + + if ((index->ts.kind != gfc_index_integer_kind + && force_index_integer_kind) + || index->ts.type != BT_INTEGER) + { + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + + gfc_convert_type_warn (index, &ts, 2, 0); + } + + return true; +} + +/* Resolve one part of an array index. */ + +bool +gfc_resolve_index (gfc_expr *index, int check_scalar) +{ + return gfc_resolve_index_1 (index, check_scalar, 1); +} + +/* Resolve a dim argument to an intrinsic function. */ + +bool +gfc_resolve_dim_arg (gfc_expr *dim) +{ + if (dim == NULL) + return true; + + if (!gfc_resolve_expr (dim)) + return false; + + if (dim->rank != 0) + { + gfc_error ("Argument dim at %L must be scalar", &dim->where); + return false; + + } + + if (dim->ts.type != BT_INTEGER) + { + gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); + return false; + } + + if (dim->ts.kind != gfc_index_integer_kind) + { + gfc_typespec ts; + + gfc_clear_ts (&ts); + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + + gfc_convert_type_warn (dim, &ts, 2, 0); + } + + return true; +} + +/* Given an expression that contains array references, update those array + references to point to the right array specifications. While this is + filled in during matching, this information is difficult to save and load + in a module, so we take care of it here. + + The idea here is that the original array reference comes from the + base symbol. We traverse the list of reference structures, setting + the stored reference to references. Component references can + provide an additional array specification. */ +static void +resolve_assoc_var (gfc_symbol* sym, bool resolve_target); + +static void +find_array_spec (gfc_expr *e) +{ + gfc_array_spec *as; + gfc_component *c; + gfc_ref *ref; + bool class_as = false; + + if (e->symtree->n.sym->assoc) + { + if (e->symtree->n.sym->assoc->target) + gfc_resolve_expr (e->symtree->n.sym->assoc->target); + resolve_assoc_var (e->symtree->n.sym, false); + } + + if (e->symtree->n.sym->ts.type == BT_CLASS) + { + as = CLASS_DATA (e->symtree->n.sym)->as; + class_as = true; + } + else + as = e->symtree->n.sym->as; + + for (ref = e->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + if (as == NULL) + gfc_internal_error ("find_array_spec(): Missing spec"); + + ref->u.ar.as = as; + as = NULL; + break; + + case REF_COMPONENT: + c = ref->u.c.component; + if (c->attr.dimension) + { + if (as != NULL && !(class_as && as == c->as)) + gfc_internal_error ("find_array_spec(): unused as(1)"); + as = c->as; + } + + break; + + case REF_SUBSTRING: + case REF_INQUIRY: + break; + } + + if (as != NULL) + gfc_internal_error ("find_array_spec(): unused as(2)"); +} + + +/* Resolve an array reference. */ + +static bool +resolve_array_ref (gfc_array_ref *ar) +{ + int i, check_scalar; + gfc_expr *e; + + for (i = 0; i < ar->dimen + ar->codimen; i++) + { + check_scalar = ar->dimen_type[i] == DIMEN_RANGE; + + /* Do not force gfc_index_integer_kind for the start. We can + do fine with any integer kind. This avoids temporary arrays + created for indexing with a vector. */ + if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0)) + return false; + if (!gfc_resolve_index (ar->end[i], check_scalar)) + return false; + if (!gfc_resolve_index (ar->stride[i], check_scalar)) + return false; + + e = ar->start[i]; + + if (ar->dimen_type[i] == DIMEN_UNKNOWN) + switch (e->rank) + { + case 0: + ar->dimen_type[i] = DIMEN_ELEMENT; + break; + + case 1: + ar->dimen_type[i] = DIMEN_VECTOR; + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->ts.type == BT_DERIVED) + ar->start[i] = gfc_get_parentheses (e); + break; + + default: + gfc_error ("Array index at %L is an array of rank %d", + &ar->c_where[i], e->rank); + return false; + } + + /* Fill in the upper bound, which may be lower than the + specified one for something like a(2:10:5), which is + identical to a(2:7:5). Only relevant for strides not equal + to one. Don't try a division by zero. */ + if (ar->dimen_type[i] == DIMEN_RANGE + && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT + && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0 + && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0) + { + mpz_t size, end; + + if (gfc_ref_dimen_size (ar, i, &size, &end)) + { + if (ar->end[i] == NULL) + { + ar->end[i] = + gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &ar->where); + mpz_set (ar->end[i]->value.integer, end); + } + else if (ar->end[i]->ts.type == BT_INTEGER + && ar->end[i]->expr_type == EXPR_CONSTANT) + { + mpz_set (ar->end[i]->value.integer, end); + } + else + gcc_unreachable (); + + mpz_clear (size); + mpz_clear (end); + } + } + } + + if (ar->type == AR_FULL) + { + if (ar->as->rank == 0) + ar->type = AR_ELEMENT; + + /* Make sure array is the same as array(:,:), this way + we don't need to special case all the time. */ + ar->dimen = ar->as->rank; + for (i = 0; i < ar->dimen; i++) + { + ar->dimen_type[i] = DIMEN_RANGE; + + gcc_assert (ar->start[i] == NULL); + gcc_assert (ar->end[i] == NULL); + gcc_assert (ar->stride[i] == NULL); + } + } + + /* If the reference type is unknown, figure out what kind it is. */ + + if (ar->type == AR_UNKNOWN) + { + ar->type = AR_ELEMENT; + for (i = 0; i < ar->dimen; i++) + if (ar->dimen_type[i] == DIMEN_RANGE + || ar->dimen_type[i] == DIMEN_VECTOR) + { + ar->type = AR_SECTION; + break; + } + } + + if (!ar->as->cray_pointee && !compare_spec_to_ref (ar)) + return false; + + if (ar->as->corank && ar->codimen == 0) + { + int n; + ar->codimen = ar->as->corank; + for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) + ar->dimen_type[n] = DIMEN_THIS_IMAGE; + } + + return true; +} + + +bool +gfc_resolve_substring (gfc_ref *ref, bool *equal_length) +{ + int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); + + if (ref->u.ss.start != NULL) + { + if (!gfc_resolve_expr (ref->u.ss.start)) + return false; + + if (ref->u.ss.start->ts.type != BT_INTEGER) + { + gfc_error ("Substring start index at %L must be of type INTEGER", + &ref->u.ss.start->where); + return false; + } + + if (ref->u.ss.start->rank != 0) + { + gfc_error ("Substring start index at %L must be scalar", + &ref->u.ss.start->where); + return false; + } + + if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT + && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ + || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) + { + gfc_error ("Substring start index at %L is less than one", + &ref->u.ss.start->where); + return false; + } + } + + if (ref->u.ss.end != NULL) + { + if (!gfc_resolve_expr (ref->u.ss.end)) + return false; + + if (ref->u.ss.end->ts.type != BT_INTEGER) + { + gfc_error ("Substring end index at %L must be of type INTEGER", + &ref->u.ss.end->where); + return false; + } + + if (ref->u.ss.end->rank != 0) + { + gfc_error ("Substring end index at %L must be scalar", + &ref->u.ss.end->where); + return false; + } + + if (ref->u.ss.length != NULL + && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT + && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ + || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) + { + gfc_error ("Substring end index at %L exceeds the string length", + &ref->u.ss.start->where); + return false; + } + + if (compare_bound_mpz_t (ref->u.ss.end, + gfc_integer_kinds[k].huge) == CMP_GT + && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ + || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) + { + gfc_error ("Substring end index at %L is too large", + &ref->u.ss.end->where); + return false; + } + /* If the substring has the same length as the original + variable, the reference itself can be deleted. */ + + if (ref->u.ss.length != NULL + && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ + && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ) + *equal_length = true; + } + + return true; +} + + +/* This function supplies missing substring charlens. */ + +void +gfc_resolve_substring_charlen (gfc_expr *e) +{ + gfc_ref *char_ref; + gfc_expr *start, *end; + gfc_typespec *ts = NULL; + mpz_t diff; + + for (char_ref = e->ref; char_ref; char_ref = char_ref->next) + { + if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY) + break; + if (char_ref->type == REF_COMPONENT) + ts = &char_ref->u.c.component->ts; + } + + if (!char_ref || char_ref->type == REF_INQUIRY) + return; + + gcc_assert (char_ref->next == NULL); + + if (e->ts.u.cl) + { + if (e->ts.u.cl->length) + gfc_free_expr (e->ts.u.cl->length); + else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy) + return; + } + + if (!e->ts.u.cl) + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + if (char_ref->u.ss.start) + start = gfc_copy_expr (char_ref->u.ss.start); + else + start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); + + if (char_ref->u.ss.end) + end = gfc_copy_expr (char_ref->u.ss.end); + else if (e->expr_type == EXPR_VARIABLE) + { + if (!ts) + ts = &e->symtree->n.sym->ts; + end = gfc_copy_expr (ts->u.cl->length); + } + else + end = NULL; + + if (!start || !end) + { + gfc_free_expr (start); + gfc_free_expr (end); + return; + } + + /* Length = (end - start + 1). + Check first whether it has a constant length. */ + if (gfc_dep_difference (end, start, &diff)) + { + gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, + &e->where); + + mpz_add_ui (len->value.integer, diff, 1); + mpz_clear (diff); + e->ts.u.cl->length = len; + /* The check for length < 0 is handled below */ + } + else + { + e->ts.u.cl->length = gfc_subtract (end, start); + e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, + gfc_get_int_expr (gfc_charlen_int_kind, + NULL, 1)); + } + + /* F2008, 6.4.1: Both the starting point and the ending point shall + be within the range 1, 2, ..., n unless the starting point exceeds + the ending point, in which case the substring has length zero. */ + + if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0) + mpz_set_si (e->ts.u.cl->length->value.integer, 0); + + e->ts.u.cl->length->ts.type = BT_INTEGER; + e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; + + /* Make sure that the length is simplified. */ + gfc_simplify_expr (e->ts.u.cl->length, 1); + gfc_resolve_expr (e->ts.u.cl->length); +} + + +/* Resolve subtype references. */ + +bool +gfc_resolve_ref (gfc_expr *expr) +{ + int current_part_dimension, n_components, seen_part_dimension, dim; + gfc_ref *ref, **prev, *array_ref; + bool equal_length; + + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) + { + find_array_spec (expr); + break; + } + + for (prev = &expr->ref; *prev != NULL; + prev = *prev == NULL ? prev : &(*prev)->next) + switch ((*prev)->type) + { + case REF_ARRAY: + if (!resolve_array_ref (&(*prev)->u.ar)) + return false; + break; + + case REF_COMPONENT: + case REF_INQUIRY: + break; + + case REF_SUBSTRING: + equal_length = false; + if (!gfc_resolve_substring (*prev, &equal_length)) + return false; + + if (expr->expr_type != EXPR_SUBSTRING && equal_length) + { + /* Remove the reference and move the charlen, if any. */ + ref = *prev; + *prev = ref->next; + ref->next = NULL; + expr->ts.u.cl = ref->u.ss.length; + ref->u.ss.length = NULL; + gfc_free_ref_list (ref); + } + break; + } + + /* Check constraints on part references. */ + + current_part_dimension = 0; + seen_part_dimension = 0; + n_components = 0; + array_ref = NULL; + + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + array_ref = ref; + switch (ref->u.ar.type) + { + case AR_FULL: + /* Coarray scalar. */ + if (ref->u.ar.as->rank == 0) + { + current_part_dimension = 0; + break; + } + /* Fall through. */ + case AR_SECTION: + current_part_dimension = 1; + break; + + case AR_ELEMENT: + array_ref = NULL; + current_part_dimension = 0; + break; + + case AR_UNKNOWN: + gfc_internal_error ("resolve_ref(): Bad array reference"); + } + + break; + + case REF_COMPONENT: + if (current_part_dimension || seen_part_dimension) + { + /* F03:C614. */ + if (ref->u.c.component->attr.pointer + || ref->u.c.component->attr.proc_pointer + || (ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.pointer)) + { + gfc_error ("Component to the right of a part reference " + "with nonzero rank must not have the POINTER " + "attribute at %L", &expr->where); + return false; + } + else if (ref->u.c.component->attr.allocatable + || (ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.allocatable)) + + { + gfc_error ("Component to the right of a part reference " + "with nonzero rank must not have the ALLOCATABLE " + "attribute at %L", &expr->where); + return false; + } + } + + n_components++; + break; + + case REF_SUBSTRING: + break; + + case REF_INQUIRY: + /* Implement requirement in note 9.7 of F2018 that the result of the + LEN inquiry be a scalar. */ + if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred) + { + array_ref->u.ar.type = AR_ELEMENT; + expr->rank = 0; + /* INQUIRY_LEN is not evaluated from the rest of the expr + but directly from the string length. This means that setting + the array indices to one does not matter but might trigger + a runtime bounds error. Suppress the check. */ + expr->no_bounds_check = 1; + for (dim = 0; dim < array_ref->u.ar.dimen; dim++) + { + array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT; + if (array_ref->u.ar.start[dim]) + gfc_free_expr (array_ref->u.ar.start[dim]); + array_ref->u.ar.start[dim] + = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + if (array_ref->u.ar.end[dim]) + gfc_free_expr (array_ref->u.ar.end[dim]); + if (array_ref->u.ar.stride[dim]) + gfc_free_expr (array_ref->u.ar.stride[dim]); + } + } + break; + } + + if (((ref->type == REF_COMPONENT && n_components > 1) + || ref->next == NULL) + && current_part_dimension + && seen_part_dimension) + { + gfc_error ("Two or more part references with nonzero rank must " + "not be specified at %L", &expr->where); + return false; + } + + if (ref->type == REF_COMPONENT) + { + if (current_part_dimension) + seen_part_dimension = 1; + + /* reset to make sure */ + current_part_dimension = 0; + } + } + + return true; +} + + +/* Given an expression, determine its shape. This is easier than it sounds. + Leaves the shape array NULL if it is not possible to determine the shape. */ + +static void +expression_shape (gfc_expr *e) +{ + mpz_t array[GFC_MAX_DIMENSIONS]; + int i; + + if (e->rank <= 0 || e->shape != NULL) + return; + + for (i = 0; i < e->rank; i++) + if (!gfc_array_dimen_size (e, i, &array[i])) + goto fail; + + e->shape = gfc_get_shape (e->rank); + + memcpy (e->shape, array, e->rank * sizeof (mpz_t)); + + return; + +fail: + for (i--; i >= 0; i--) + mpz_clear (array[i]); +} + + +/* Given a variable expression node, compute the rank of the expression by + examining the base symbol and any reference structures it may have. */ + +void +gfc_expression_rank (gfc_expr *e) +{ + gfc_ref *ref; + int i, rank; + + /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that + could lead to serious confusion... */ + gcc_assert (e->expr_type != EXPR_COMPCALL); + + if (e->ref == NULL) + { + if (e->expr_type == EXPR_ARRAY) + goto done; + /* Constructors can have a rank different from one via RESHAPE(). */ + + e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL) + ? 0 : e->symtree->n.sym->as->rank); + goto done; + } + + rank = 0; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer + && ref->u.c.component->attr.function && !ref->next) + rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0; + + if (ref->type != REF_ARRAY) + continue; + + if (ref->u.ar.type == AR_FULL) + { + rank = ref->u.ar.as->rank; + break; + } + + if (ref->u.ar.type == AR_SECTION) + { + /* Figure out the rank of the section. */ + if (rank != 0) + gfc_internal_error ("gfc_expression_rank(): Two array specs"); + + for (i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_RANGE + || ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + rank++; + + break; + } + } + + e->rank = rank; + +done: + expression_shape (e); +} + + +static void +add_caf_get_intrinsic (gfc_expr *e) +{ + gfc_expr *wrapper, *tmp_expr; + gfc_ref *ref; + int n; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + if (ref == NULL) + return; + + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) + return; + + tmp_expr = XCNEW (gfc_expr); + *tmp_expr = *e; + wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET, + "caf_get", tmp_expr->where, 1, tmp_expr); + wrapper->ts = e->ts; + wrapper->rank = e->rank; + if (e->rank) + wrapper->shape = gfc_copy_shape (e->shape, e->rank); + *e = *wrapper; + free (wrapper); +} + + +static void +remove_caf_get_intrinsic (gfc_expr *e) +{ + gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CAF_GET); + gfc_expr *e2 = e->value.function.actual->expr; + e->value.function.actual->expr = NULL; + gfc_free_actual_arglist (e->value.function.actual); + gfc_free_shape (&e->shape, e->rank); + *e = *e2; + free (e2); +} + + +/* Resolve a variable expression. */ + +static bool +resolve_variable (gfc_expr *e) +{ + gfc_symbol *sym; + bool t; + + t = true; + + if (e->symtree == NULL) + return false; + sym = e->symtree->n.sym; + + /* Use same check as for TYPE(*) below; this check has to be before TYPE(*) + as ts.type is set to BT_ASSUMED in resolve_symbol. */ + if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + { + if (!actual_arg || inquiry_argument) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only " + "be used as actual argument", sym->name, &e->where); + return false; + } + } + /* TS 29113, 407b. */ + else if (e->ts.type == BT_ASSUMED) + { + if (!actual_arg) + { + gfc_error ("Assumed-type variable %s at %L may only be used " + "as actual argument", sym->name, &e->where); + return false; + } + else if (inquiry_argument && !first_actual_arg) + { + /* FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is + that the function-name resolution happens too late in that + function. */ + gfc_error ("Assumed-type variable %s at %L as actual argument to " + "an inquiry function shall be the first argument", + sym->name, &e->where); + return false; + } + } + /* TS 29113, C535b. */ + else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && !sym->attr.select_rank_temporary) + { + if (!actual_arg + && !(cs_base && cs_base->current + && cs_base->current->op == EXEC_SELECT_RANK)) + { + gfc_error ("Assumed-rank variable %s at %L may only be used as " + "actual argument", sym->name, &e->where); + return false; + } + else if (inquiry_argument && !first_actual_arg) + { + /* FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is + that the function-name resolution happens too late in that + function. */ + gfc_error ("Assumed-rank variable %s at %L as actual argument " + "to an inquiry function shall be the first argument", + sym->name, &e->where); + return false; + } + } + + if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have " + "a subobject reference", sym->name, &e->ref->u.ar.where); + return false; + } + /* TS 29113, 407b. */ + else if (e->ts.type == BT_ASSUMED && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Assumed-type variable %s at %L shall not have a subobject " + "reference", sym->name, &e->ref->u.ar.where); + return false; + } + + /* TS 29113, C535b. */ + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) + { + gfc_error ("Assumed-rank variable %s at %L shall not have a subobject " + "reference", sym->name, &e->ref->u.ar.where); + return false; + } + + /* For variables that are used in an associate (target => object) where + the object's basetype is array valued while the target is scalar, + the ts' type of the component refs is still array valued, which + can't be translated that way. */ + if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS + && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS + && sym->assoc->target->ts.u.derived + && CLASS_DATA (sym->assoc->target) + && CLASS_DATA (sym->assoc->target)->as) + { + gfc_ref *ref = e->ref; + while (ref) + { + switch (ref->type) + { + case REF_COMPONENT: + ref->u.c.sym = sym->ts.u.derived; + /* Stop the loop. */ + ref = NULL; + break; + default: + ref = ref->next; + break; + } + } + } + + /* If this is an associate-name, it may be parsed with an array reference + in error even though the target is scalar. Fail directly in this case. + TODO Understand why class scalar expressions must be excluded. */ + if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0)) + { + if (sym->ts.type == BT_CLASS) + gfc_fix_class_refs (e); + if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) + return false; + else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY)) + { + /* This can happen because the parser did not detect that the + associate name is an array and the expression had no array + part_ref. */ + gfc_ref *ref = gfc_get_ref (); + ref->type = REF_ARRAY; + ref->u.ar.type = AR_FULL; + if (sym->as) + { + ref->u.ar.as = sym->as; + ref->u.ar.dimen = sym->as->rank; + } + ref->next = e->ref; + e->ref = ref; + + } + } + + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) + sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); + + /* On the other hand, the parser may not have known this is an array; + in this case, we have to add a FULL reference. */ + if (sym->assoc && sym->attr.dimension && !e->ref) + { + e->ref = gfc_get_ref (); + e->ref->type = REF_ARRAY; + e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.dimen = 0; + } + + /* Like above, but for class types, where the checking whether an array + ref is present is more complicated. Furthermore make sure not to add + the full array ref to _vptr or _len refs. */ + if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived + && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.dimension + && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype)) + { + gfc_ref *ref, *newref; + + newref = gfc_get_ref (); + newref->type = REF_ARRAY; + newref->u.ar.type = AR_FULL; + newref->u.ar.dimen = 0; + /* Because this is an associate var and the first ref either is a ref to + the _data component or not, no traversal of the ref chain is + needed. The array ref needs to be inserted after the _data ref, + or when that is not present, which may happend for polymorphic + types, then at the first position. */ + ref = e->ref; + if (!ref) + e->ref = newref; + else if (ref->type == REF_COMPONENT + && strcmp ("_data", ref->u.c.component->name) == 0) + { + if (!ref->next || ref->next->type != REF_ARRAY) + { + newref->next = ref->next; + ref->next = newref; + } + else + /* Array ref present already. */ + gfc_free_ref_list (newref); + } + else if (ref->type == REF_ARRAY) + /* Array ref present already. */ + gfc_free_ref_list (newref); + else + { + newref->next = ref; + e->ref = newref; + } + } + + if (e->ref && !gfc_resolve_ref (e)) + return false; + + if (sym->attr.flavor == FL_PROCEDURE + && (!sym->attr.function + || (sym->attr.function && sym->result + && sym->result->attr.proc_pointer + && !sym->result->attr.function))) + { + e->ts.type = BT_PROCEDURE; + goto resolve_procedure; + } + + if (sym->ts.type != BT_UNKNOWN) + gfc_variable_attr (e, &e->ts); + else if (sym->attr.flavor == FL_PROCEDURE + && sym->attr.function && sym->result + && sym->result->ts.type != BT_UNKNOWN + && sym->result->attr.proc_pointer) + e->ts = sym->result->ts; + else + { + /* Must be a simple variable reference. */ + if (!gfc_set_default_type (sym, 1, sym->ns)) + return false; + e->ts = sym->ts; + } + + if (check_assumed_size_reference (sym, e)) + return false; + + /* Deal with forward references to entries during gfc_resolve_code, to + satisfy, at least partially, 12.5.2.5. */ + if (gfc_current_ns->entries + && current_entry_id == sym->entry_id + && cs_base + && cs_base->current + && cs_base->current->op != EXEC_ENTRY) + { + gfc_entry_list *entry; + gfc_formal_arglist *formal; + int n; + bool seen, saved_specification_expr; + + /* If the symbol is a dummy... */ + if (sym->attr.dummy && sym->ns == gfc_current_ns) + { + entry = gfc_current_ns->entries; + seen = false; + + /* ...test if the symbol is a parameter of previous entries. */ + for (; entry && entry->id <= current_entry_id; entry = entry->next) + for (formal = entry->sym->formal; formal; formal = formal->next) + { + if (formal->sym && sym->name == formal->sym->name) + { + seen = true; + break; + } + } + + /* If it has not been seen as a dummy, this is an error. */ + if (!seen) + { + if (specification_expr) + gfc_error ("Variable %qs, used in a specification expression" + ", is referenced at %L before the ENTRY statement " + "in which it is a parameter", + sym->name, &cs_base->current->loc); + else + gfc_error ("Variable %qs is used at %L before the ENTRY " + "statement in which it is a parameter", + sym->name, &cs_base->current->loc); + t = false; + } + } + + /* Now do the same check on the specification expressions. */ + saved_specification_expr = specification_expr; + specification_expr = true; + if (sym->ts.type == BT_CHARACTER + && !gfc_resolve_expr (sym->ts.u.cl->length)) + t = false; + + if (sym->as) + for (n = 0; n < sym->as->rank; n++) + { + if (!gfc_resolve_expr (sym->as->lower[n])) + t = false; + if (!gfc_resolve_expr (sym->as->upper[n])) + t = false; + } + specification_expr = saved_specification_expr; + + if (t) + /* Update the symbol's entry level. */ + sym->entry_id = current_entry_id + 1; + } + + /* If a symbol has been host_associated mark it. This is used latter, + to identify if aliasing is possible via host association. */ + if (sym->attr.flavor == FL_VARIABLE + && gfc_current_ns->parent + && (gfc_current_ns->parent == sym->ns + || (gfc_current_ns->parent->parent + && gfc_current_ns->parent->parent == sym->ns))) + sym->attr.host_assoc = 1; + + if (gfc_current_ns->proc_name + && sym->attr.dimension + && (sym->ns != gfc_current_ns + || sym->attr.use_assoc + || sym->attr.in_common)) + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + +resolve_procedure: + if (t && !resolve_procedure_expression (e)) + t = false; + + /* F2008, C617 and C1229. */ + if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) + && gfc_is_coindexed (e)) + { + gfc_ref *ref, *ref2 = NULL; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + ref2 = ref; + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + } + + for ( ; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + + /* Expression itself is not coindexed object. */ + if (ref && e->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic subobject of coindexed object at %L", + &e->where); + t = false; + } + + /* Expression itself is coindexed object. */ + if (ref == NULL) + { + gfc_component *c; + c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components; + for ( ; c; c = c->next) + if (c->attr.allocatable && c->ts.type == BT_CLASS) + { + gfc_error ("Coindexed object with polymorphic allocatable " + "subcomponent at %L", &e->where); + t = false; + break; + } + } + } + + if (t) + gfc_expression_rank (e); + + if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e)) + add_caf_get_intrinsic (e); + + if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result) + gfc_warning (OPT_Wdeprecated_declarations, + "Using variable %qs at %L is deprecated", + sym->name, &e->where); + /* Simplify cases where access to a parameter array results in a + single constant. Suppress errors since those will have been + issued before, as warnings. */ + if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER) + { + gfc_push_suppress_errors (); + gfc_simplify_expr (e, 1); + gfc_pop_suppress_errors (); + } + + return t; +} + + +/* Checks to see that the correct symbol has been host associated. + The only situation where this arises is that in which a twice + contained function is parsed after the host association is made. + Therefore, on detecting this, change the symbol in the expression + and convert the array reference into an actual arglist if the old + symbol is a variable. */ +static bool +check_host_association (gfc_expr *e) +{ + gfc_symbol *sym, *old_sym; + gfc_symtree *st; + int n; + gfc_ref *ref; + gfc_actual_arglist *arg, *tail = NULL; + bool retval = e->expr_type == EXPR_FUNCTION; + + /* If the expression is the result of substitution in + interface.c(gfc_extend_expr) because there is no way in + which the host association can be wrong. */ + if (e->symtree == NULL + || e->symtree->n.sym == NULL + || e->user_operator) + return retval; + + old_sym = e->symtree->n.sym; + + if (gfc_current_ns->parent + && old_sym->ns != gfc_current_ns) + { + /* Use the 'USE' name so that renamed module symbols are + correctly handled. */ + gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym); + + if (sym && old_sym != sym + && sym->ts.type == old_sym->ts.type + && sym->attr.flavor == FL_PROCEDURE + && sym->attr.contained) + { + /* Clear the shape, since it might not be valid. */ + gfc_free_shape (&e->shape, e->rank); + + /* Give the expression the right symtree! */ + gfc_find_sym_tree (e->symtree->name, NULL, 1, &st); + gcc_assert (st != NULL); + + if (old_sym->attr.flavor == FL_PROCEDURE + || e->expr_type == EXPR_FUNCTION) + { + /* Original was function so point to the new symbol, since + the actual argument list is already attached to the + expression. */ + e->value.function.esym = NULL; + e->symtree = st; + } + else + { + /* Original was variable so convert array references into + an actual arglist. This does not need any checking now + since resolve_function will take care of it. */ + e->value.function.actual = NULL; + e->expr_type = EXPR_FUNCTION; + e->symtree = st; + + /* Ambiguity will not arise if the array reference is not + the last reference. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->next == NULL) + break; + + if ((ref == NULL || ref->type != REF_ARRAY) + && sym->attr.proc == PROC_INTERNAL) + { + gfc_error ("%qs at %L is host associated at %L into " + "a contained procedure with an internal " + "procedure of the same name", sym->name, + &old_sym->declared_at, &e->where); + return false; + } + + gcc_assert (ref->type == REF_ARRAY); + + /* Grab the start expressions from the array ref and + copy them into actual arguments. */ + for (n = 0; n < ref->u.ar.dimen; n++) + { + arg = gfc_get_actual_arglist (); + arg->expr = gfc_copy_expr (ref->u.ar.start[n]); + if (e->value.function.actual == NULL) + tail = e->value.function.actual = arg; + else + { + tail->next = arg; + tail = arg; + } + } + + /* Dump the reference list and set the rank. */ + gfc_free_ref_list (e->ref); + e->ref = NULL; + e->rank = sym->as ? sym->as->rank : 0; + } + + gfc_resolve_expr (e); + sym->refs++; + } + } + /* This might have changed! */ + return e->expr_type == EXPR_FUNCTION; +} + + +static void +gfc_resolve_character_operator (gfc_expr *e) +{ + gfc_expr *op1 = e->value.op.op1; + gfc_expr *op2 = e->value.op.op2; + gfc_expr *e1 = NULL; + gfc_expr *e2 = NULL; + + gcc_assert (e->value.op.op == INTRINSIC_CONCAT); + + if (op1->ts.u.cl && op1->ts.u.cl->length) + e1 = gfc_copy_expr (op1->ts.u.cl->length); + else if (op1->expr_type == EXPR_CONSTANT) + e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, + op1->value.character.length); + + if (op2->ts.u.cl && op2->ts.u.cl->length) + e2 = gfc_copy_expr (op2->ts.u.cl->length); + else if (op2->expr_type == EXPR_CONSTANT) + e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, + op2->value.character.length); + + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + if (!e1 || !e2) + { + gfc_free_expr (e1); + gfc_free_expr (e2); + + return; + } + + e->ts.u.cl->length = gfc_add (e1, e2); + e->ts.u.cl->length->ts.type = BT_INTEGER; + e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; + gfc_simplify_expr (e->ts.u.cl->length, 0); + gfc_resolve_expr (e->ts.u.cl->length); + + return; +} + + +/* Ensure that an character expression has a charlen and, if possible, a + length expression. */ + +static void +fixup_charlen (gfc_expr *e) +{ + /* The cases fall through so that changes in expression type and the need + for multiple fixes are picked up. In all circumstances, a charlen should + be available for the middle end to hang a backend_decl on. */ + switch (e->expr_type) + { + case EXPR_OP: + gfc_resolve_character_operator (e); + /* FALLTHRU */ + + case EXPR_ARRAY: + if (e->expr_type == EXPR_ARRAY) + gfc_resolve_character_array_constructor (e); + /* FALLTHRU */ + + case EXPR_SUBSTRING: + if (!e->ts.u.cl && e->ref) + gfc_resolve_substring_charlen (e); + /* FALLTHRU */ + + default: + if (!e->ts.u.cl) + e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + break; + } +} + + +/* Update an actual argument to include the passed-object for type-bound + procedures at the right position. */ + +static gfc_actual_arglist* +update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos, + const char *name) +{ + gcc_assert (argpos > 0); + + if (argpos == 1) + { + gfc_actual_arglist* result; + + result = gfc_get_actual_arglist (); + result->expr = po; + result->next = lst; + if (name) + result->name = name; + + return result; + } + + if (lst) + lst->next = update_arglist_pass (lst->next, po, argpos - 1, name); + else + lst = update_arglist_pass (NULL, po, argpos - 1, name); + return lst; +} + + +/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */ + +static gfc_expr* +extract_compcall_passed_object (gfc_expr* e) +{ + gfc_expr* po; + + if (e->expr_type == EXPR_UNKNOWN) + { + gfc_error ("Error in typebound call at %L", + &e->where); + return NULL; + } + + gcc_assert (e->expr_type == EXPR_COMPCALL); + + if (e->value.compcall.base_object) + po = gfc_copy_expr (e->value.compcall.base_object); + else + { + po = gfc_get_expr (); + po->expr_type = EXPR_VARIABLE; + po->symtree = e->symtree; + po->ref = gfc_copy_ref (e->ref); + po->where = e->where; + } + + if (!gfc_resolve_expr (po)) + return NULL; + + return po; +} + + +/* Update the arglist of an EXPR_COMPCALL expression to include the + passed-object. */ + +static bool +update_compcall_arglist (gfc_expr* e) +{ + gfc_expr* po; + gfc_typebound_proc* tbp; + + tbp = e->value.compcall.tbp; + + if (tbp->error) + return false; + + po = extract_compcall_passed_object (e); + if (!po) + return false; + + if (tbp->nopass || e->value.compcall.ignore_pass) + { + gfc_free_expr (po); + return true; + } + + if (tbp->pass_arg_num <= 0) + return false; + + e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, + tbp->pass_arg_num, + tbp->pass_arg); + + return true; +} + + +/* Extract the passed object from a PPC call (a copy of it). */ + +static gfc_expr* +extract_ppc_passed_object (gfc_expr *e) +{ + gfc_expr *po; + gfc_ref **ref; + + po = gfc_get_expr (); + po->expr_type = EXPR_VARIABLE; + po->symtree = e->symtree; + po->ref = gfc_copy_ref (e->ref); + po->where = e->where; + + /* Remove PPC reference. */ + ref = &po->ref; + while ((*ref)->next) + ref = &(*ref)->next; + gfc_free_ref_list (*ref); + *ref = NULL; + + if (!gfc_resolve_expr (po)) + return NULL; + + return po; +} + + +/* Update the actual arglist of a procedure pointer component to include the + passed-object. */ + +static bool +update_ppc_arglist (gfc_expr* e) +{ + gfc_expr* po; + gfc_component *ppc; + gfc_typebound_proc* tb; + + ppc = gfc_get_proc_ptr_comp (e); + if (!ppc) + return false; + + tb = ppc->tb; + + if (tb->error) + return false; + else if (tb->nopass) + return true; + + po = extract_ppc_passed_object (e); + if (!po) + return false; + + /* F08:R739. */ + if (po->rank != 0) + { + gfc_error ("Passed-object at %L must be scalar", &e->where); + return false; + } + + /* F08:C611. */ + if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract) + { + gfc_error ("Base object for procedure-pointer component call at %L is of" + " ABSTRACT type %qs", &e->where, po->ts.u.derived->name); + return false; + } + + gcc_assert (tb->pass_arg_num > 0); + e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, + tb->pass_arg_num, + tb->pass_arg); + + return true; +} + + +/* Check that the object a TBP is called on is valid, i.e. it must not be + of ABSTRACT type (as in subobject%abstract_parent%tbp()). */ + +static bool +check_typebound_baseobject (gfc_expr* e) +{ + gfc_expr* base; + bool return_value = false; + + base = extract_compcall_passed_object (e); + if (!base) + return false; + + if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS) + { + gfc_error ("Error in typebound call at %L", &e->where); + goto cleanup; + } + + if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok) + return false; + + /* F08:C611. */ + if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) + { + gfc_error ("Base object for type-bound procedure call at %L is of" + " ABSTRACT type %qs", &e->where, base->ts.u.derived->name); + goto cleanup; + } + + /* F08:C1230. If the procedure called is NOPASS, + the base object must be scalar. */ + if (e->value.compcall.tbp->nopass && base->rank != 0) + { + gfc_error ("Base object for NOPASS type-bound procedure call at %L must" + " be scalar", &e->where); + goto cleanup; + } + + return_value = true; + +cleanup: + gfc_free_expr (base); + return return_value; +} + + +/* Resolve a call to a type-bound procedure, either function or subroutine, + statically from the data in an EXPR_COMPCALL expression. The adapted + arglist and the target-procedure symtree are returned. */ + +static bool +resolve_typebound_static (gfc_expr* e, gfc_symtree** target, + gfc_actual_arglist** actual) +{ + gcc_assert (e->expr_type == EXPR_COMPCALL); + gcc_assert (!e->value.compcall.tbp->is_generic); + + /* Update the actual arglist for PASS. */ + if (!update_compcall_arglist (e)) + return false; + + *actual = e->value.compcall.actual; + *target = e->value.compcall.tbp->u.specific; + + gfc_free_ref_list (e->ref); + e->ref = NULL; + e->value.compcall.actual = NULL; + + /* If we find a deferred typebound procedure, check for derived types + that an overriding typebound procedure has not been missed. */ + if (e->value.compcall.name + && !e->value.compcall.tbp->non_overridable + && e->value.compcall.base_object + && e->value.compcall.base_object->ts.type == BT_DERIVED) + { + gfc_symtree *st; + gfc_symbol *derived; + + /* Use the derived type of the base_object. */ + derived = e->value.compcall.base_object->ts.u.derived; + st = NULL; + + /* If necessary, go through the inheritance chain. */ + while (!st && derived) + { + /* Look for the typebound procedure 'name'. */ + if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) + st = gfc_find_symtree (derived->f2k_derived->tb_sym_root, + e->value.compcall.name); + if (!st) + derived = gfc_get_derived_super_type (derived); + } + + /* Now find the specific name in the derived type namespace. */ + if (st && st->n.tb && st->n.tb->u.specific) + gfc_find_sym_tree (st->n.tb->u.specific->name, + derived->ns, 1, &st); + if (st) + *target = st; + } + return true; +} + + +/* Get the ultimate declared type from an expression. In addition, + return the last class/derived type reference and the copy of the + reference list. If check_types is set true, derived types are + identified as well as class references. */ +static gfc_symbol* +get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, + gfc_expr *e, bool check_types) +{ + gfc_symbol *declared; + gfc_ref *ref; + + declared = NULL; + if (class_ref) + *class_ref = NULL; + if (new_ref) + *new_ref = gfc_copy_ref (e->ref); + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_COMPONENT) + continue; + + if ((ref->u.c.component->ts.type == BT_CLASS + || (check_types && gfc_bt_struct (ref->u.c.component->ts.type))) + && ref->u.c.component->attr.flavor != FL_PROCEDURE) + { + declared = ref->u.c.component->ts.u.derived; + if (class_ref) + *class_ref = ref; + } + } + + if (declared == NULL) + declared = e->symtree->n.sym->ts.u.derived; + + return declared; +} + + +/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out + which of the specific bindings (if any) matches the arglist and transform + the expression into a call of that binding. */ + +static bool +resolve_typebound_generic_call (gfc_expr* e, const char **name) +{ + gfc_typebound_proc* genproc; + const char* genname; + gfc_symtree *st; + gfc_symbol *derived; + + gcc_assert (e->expr_type == EXPR_COMPCALL); + genname = e->value.compcall.name; + genproc = e->value.compcall.tbp; + + if (!genproc->is_generic) + return true; + + /* Try the bindings on this type and in the inheritance hierarchy. */ + for (; genproc; genproc = genproc->overridden) + { + gfc_tbp_generic* g; + + gcc_assert (genproc->is_generic); + for (g = genproc->u.generic; g; g = g->next) + { + gfc_symbol* target; + gfc_actual_arglist* args; + bool matches; + + gcc_assert (g->specific); + + if (g->specific->error) + continue; + + target = g->specific->u.specific->n.sym; + + /* Get the right arglist by handling PASS/NOPASS. */ + args = gfc_copy_actual_arglist (e->value.compcall.actual); + if (!g->specific->nopass) + { + gfc_expr* po; + po = extract_compcall_passed_object (e); + if (!po) + { + gfc_free_actual_arglist (args); + return false; + } + + gcc_assert (g->specific->pass_arg_num > 0); + gcc_assert (!g->specific->error); + args = update_arglist_pass (args, po, g->specific->pass_arg_num, + g->specific->pass_arg); + } + resolve_actual_arglist (args, target->attr.proc, + is_external_proc (target) + && gfc_sym_get_dummy_args (target) == NULL); + + /* Check if this arglist matches the formal. */ + matches = gfc_arglist_matches_symbol (&args, target); + + /* Clean up and break out of the loop if we've found it. */ + gfc_free_actual_arglist (args); + if (matches) + { + e->value.compcall.tbp = g->specific; + genname = g->specific_st->name; + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = genname; + goto success; + } + } + } + + /* Nothing matching found! */ + gfc_error ("Found no matching specific binding for the call to the GENERIC" + " %qs at %L", genname, &e->where); + return false; + +success: + /* Make sure that we have the right specific instance for the name. */ + derived = get_declared_from_expr (NULL, NULL, e, true); + + st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); + if (st) + e->value.compcall.tbp = st->n.tb; + + return true; +} + + +/* Resolve a call to a type-bound subroutine. */ + +static bool +resolve_typebound_call (gfc_code* c, const char **name, bool *overridable) +{ + gfc_actual_arglist* newactual; + gfc_symtree* target; + + /* Check that's really a SUBROUTINE. */ + if (!c->expr1->value.compcall.tbp->subroutine) + { + if (!c->expr1->value.compcall.tbp->is_generic + && c->expr1->value.compcall.tbp->u.specific + && c->expr1->value.compcall.tbp->u.specific->n.sym + && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine) + c->expr1->value.compcall.tbp->subroutine = 1; + else + { + gfc_error ("%qs at %L should be a SUBROUTINE", + c->expr1->value.compcall.name, &c->loc); + return false; + } + } + + if (!check_typebound_baseobject (c->expr1)) + return false; + + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = c->expr1->value.compcall.name; + + if (!resolve_typebound_generic_call (c->expr1, name)) + return false; + + /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */ + if (overridable) + *overridable = !c->expr1->value.compcall.tbp->non_overridable; + + /* Transform into an ordinary EXEC_CALL for now. */ + + if (!resolve_typebound_static (c->expr1, &target, &newactual)) + return false; + + c->ext.actual = newactual; + c->symtree = target; + c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); + + gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); + + gfc_free_expr (c->expr1); + c->expr1 = gfc_get_expr (); + c->expr1->expr_type = EXPR_FUNCTION; + c->expr1->symtree = target; + c->expr1->where = c->loc; + + return resolve_call (c); +} + + +/* Resolve a component-call expression. */ +static bool +resolve_compcall (gfc_expr* e, const char **name) +{ + gfc_actual_arglist* newactual; + gfc_symtree* target; + + /* Check that's really a FUNCTION. */ + if (!e->value.compcall.tbp->function) + { + gfc_error ("%qs at %L should be a FUNCTION", + e->value.compcall.name, &e->where); + return false; + } + + + /* These must not be assign-calls! */ + gcc_assert (!e->value.compcall.assign); + + if (!check_typebound_baseobject (e)) + return false; + + /* Pass along the name for CLASS methods, where the vtab + procedure pointer component has to be referenced. */ + if (name) + *name = e->value.compcall.name; + + if (!resolve_typebound_generic_call (e, name)) + return false; + gcc_assert (!e->value.compcall.tbp->is_generic); + + /* Take the rank from the function's symbol. */ + if (e->value.compcall.tbp->u.specific->n.sym->as) + e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank; + + /* For now, we simply transform it into an EXPR_FUNCTION call with the same + arglist to the TBP's binding target. */ + + if (!resolve_typebound_static (e, &target, &newactual)) + return false; + + e->value.function.actual = newactual; + e->value.function.name = NULL; + e->value.function.esym = target->n.sym; + e->value.function.isym = NULL; + e->symtree = target; + e->ts = target->n.sym->ts; + e->expr_type = EXPR_FUNCTION; + + /* Resolution is not necessary if this is a class subroutine; this + function only has to identify the specific proc. Resolution of + the call will be done next in resolve_typebound_call. */ + return gfc_resolve_expr (e); +} + + +static bool resolve_fl_derived (gfc_symbol *sym); + + +/* Resolve a typebound function, or 'method'. First separate all + the non-CLASS references by calling resolve_compcall directly. */ + +static bool +resolve_typebound_function (gfc_expr* e) +{ + gfc_symbol *declared; + gfc_component *c; + gfc_ref *new_ref; + gfc_ref *class_ref; + gfc_symtree *st; + const char *name; + gfc_typespec ts; + gfc_expr *expr; + bool overridable; + + st = e->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = e->value.compcall.base_object; + overridable = !e->value.compcall.tbp->non_overridable; + if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) + { + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + ts = expr->ts; + declared = ts.u.derived; + c = gfc_find_component (declared, "_vptr", true, true, NULL); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (!resolve_compcall (e, &name)) + return false; + + /* Use the generic name if it is there. */ + name = name ? name : e->value.function.esym->name; + e->symtree = expr->symtree; + e->ref = gfc_copy_ref (expr->ref); + get_declared_from_expr (&class_ref, NULL, e, false); + + /* Trim away the extraneous references that emerge from nested + use of interface.c (extend_expr). */ + if (class_ref && class_ref->next) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = NULL; + } + else if (e->ref && !class_ref && expr->ts.type != BT_CLASS) + { + gfc_free_ref_list (e->ref); + e->ref = NULL; + } + + gfc_add_vptr_component (e); + gfc_add_component_ref (e, name); + e->value.function.esym = NULL; + if (expr->expr_type != EXPR_VARIABLE) + e->base_expr = expr; + return true; + } + + if (st == NULL) + return resolve_compcall (e, NULL); + + if (!gfc_resolve_ref (e)) + return false; + + /* Get the CLASS declared type. */ + declared = get_declared_from_expr (&class_ref, &new_ref, e, true); + + if (!resolve_fl_derived (declared)) + return false; + + /* Weed out cases of the ultimate component being a derived type. */ + if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) + { + gfc_free_ref_list (new_ref); + return resolve_compcall (e, NULL); + } + + c = gfc_find_component (declared, "_data", true, true, NULL); + + /* Treat the call as if it is a typebound procedure, in order to roll + out the correct name for the specific function. */ + if (!resolve_compcall (e, &name)) + { + gfc_free_ref_list (new_ref); + return false; + } + ts = e->ts; + + if (overridable) + { + /* Convert the expression to a procedure pointer component call. */ + e->value.function.esym = NULL; + e->symtree = st; + + if (new_ref) + e->ref = new_ref; + + /* '_vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_vptr_component (e); + gfc_add_component_ref (e, name); + + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + e->ts = ts; + } + else if (new_ref) + gfc_free_ref_list (new_ref); + + return true; +} + +/* Resolve a typebound subroutine, or 'method'. First separate all + the non-CLASS references by calling resolve_typebound_call + directly. */ + +static bool +resolve_typebound_subroutine (gfc_code *code) +{ + gfc_symbol *declared; + gfc_component *c; + gfc_ref *new_ref; + gfc_ref *class_ref; + gfc_symtree *st; + const char *name; + gfc_typespec ts; + gfc_expr *expr; + bool overridable; + + st = code->expr1->symtree; + + /* Deal with typebound operators for CLASS objects. */ + expr = code->expr1->value.compcall.base_object; + overridable = !code->expr1->value.compcall.tbp->non_overridable; + if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) + { + /* If the base_object is not a variable, the corresponding actual + argument expression must be stored in e->base_expression so + that the corresponding tree temporary can be used as the base + object in gfc_conv_procedure_call. */ + if (expr->expr_type != EXPR_VARIABLE) + { + gfc_actual_arglist *args; + + args= code->expr1->value.function.actual; + for (; args; args = args->next) + if (expr == args->expr) + expr = args->expr; + } + + /* Since the typebound operators are generic, we have to ensure + that any delays in resolution are corrected and that the vtab + is present. */ + declared = expr->ts.u.derived; + c = gfc_find_component (declared, "_vptr", true, true, NULL); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (declared); + + if (!resolve_typebound_call (code, &name, NULL)) + return false; + + /* Use the generic name if it is there. */ + name = name ? name : code->expr1->value.function.esym->name; + code->expr1->symtree = expr->symtree; + code->expr1->ref = gfc_copy_ref (expr->ref); + + /* Trim away the extraneous references that emerge from nested + use of interface.c (extend_expr). */ + get_declared_from_expr (&class_ref, NULL, code->expr1, false); + if (class_ref && class_ref->next) + { + gfc_free_ref_list (class_ref->next); + class_ref->next = NULL; + } + else if (code->expr1->ref && !class_ref) + { + gfc_free_ref_list (code->expr1->ref); + code->expr1->ref = NULL; + } + + /* Now use the procedure in the vtable. */ + gfc_add_vptr_component (code->expr1); + gfc_add_component_ref (code->expr1, name); + code->expr1->value.function.esym = NULL; + if (expr->expr_type != EXPR_VARIABLE) + code->expr1->base_expr = expr; + return true; + } + + if (st == NULL) + return resolve_typebound_call (code, NULL, NULL); + + if (!gfc_resolve_ref (code->expr1)) + return false; + + /* Get the CLASS declared type. */ + get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); + + /* Weed out cases of the ultimate component being a derived type. */ + if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) + || (!class_ref && st->n.sym->ts.type != BT_CLASS)) + { + gfc_free_ref_list (new_ref); + return resolve_typebound_call (code, NULL, NULL); + } + + if (!resolve_typebound_call (code, &name, &overridable)) + { + gfc_free_ref_list (new_ref); + return false; + } + ts = code->expr1->ts; + + if (overridable) + { + /* Convert the expression to a procedure pointer component call. */ + code->expr1->value.function.esym = NULL; + code->expr1->symtree = st; + + if (new_ref) + code->expr1->ref = new_ref; + + /* '_vptr' points to the vtab, which contains the procedure pointers. */ + gfc_add_vptr_component (code->expr1); + gfc_add_component_ref (code->expr1, name); + + /* Recover the typespec for the expression. This is really only + necessary for generic procedures, where the additional call + to gfc_add_component_ref seems to throw the collection of the + correct typespec. */ + code->expr1->ts = ts; + } + else if (new_ref) + gfc_free_ref_list (new_ref); + + return true; +} + + +/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */ + +static bool +resolve_ppc_call (gfc_code* c) +{ + gfc_component *comp; + + comp = gfc_get_proc_ptr_comp (c->expr1); + gcc_assert (comp != NULL); + + c->resolved_sym = c->expr1->symtree->n.sym; + c->expr1->expr_type = EXPR_VARIABLE; + + if (!comp->attr.subroutine) + gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); + + if (!gfc_resolve_ref (c->expr1)) + return false; + + if (!update_ppc_arglist (c->expr1)) + return false; + + c->ext.actual = c->expr1->value.compcall.actual; + + if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, + !(comp->ts.interface + && comp->ts.interface->formal))) + return false; + + if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where)) + return false; + + gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where); + + return true; +} + + +/* Resolve a Function Call to a Procedure Pointer Component (Function). */ + +static bool +resolve_expr_ppc (gfc_expr* e) +{ + gfc_component *comp; + + comp = gfc_get_proc_ptr_comp (e); + gcc_assert (comp != NULL); + + /* Convert to EXPR_FUNCTION. */ + e->expr_type = EXPR_FUNCTION; + e->value.function.isym = NULL; + e->value.function.actual = e->value.compcall.actual; + e->ts = comp->ts; + if (comp->as != NULL) + e->rank = comp->as->rank; + + if (!comp->attr.function) + gfc_add_function (&comp->attr, comp->name, &e->where); + + if (!gfc_resolve_ref (e)) + return false; + + if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, + !(comp->ts.interface + && comp->ts.interface->formal))) + return false; + + if (!update_ppc_arglist (e)) + return false; + + if (!check_pure_function(e)) + return false; + + gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); + + return true; +} + + +static bool +gfc_is_expandable_expr (gfc_expr *e) +{ + gfc_constructor *con; + + if (e->expr_type == EXPR_ARRAY) + { + /* Traverse the constructor looking for variables that are flavor + parameter. Parameters must be expanded since they are fully used at + compile time. */ + con = gfc_constructor_first (e->value.constructor); + for (; con; con = gfc_constructor_next (con)) + { + if (con->expr->expr_type == EXPR_VARIABLE + && con->expr->symtree + && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER + || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) + return true; + if (con->expr->expr_type == EXPR_ARRAY + && gfc_is_expandable_expr (con->expr)) + return true; + } + } + + return false; +} + + +/* Sometimes variables in specification expressions of the result + of module procedures in submodules wind up not being the 'real' + dummy. Find this, if possible, in the namespace of the first + formal argument. */ + +static void +fixup_unique_dummy (gfc_expr *e) +{ + gfc_symtree *st = NULL; + gfc_symbol *s = NULL; + + if (e->symtree->n.sym->ns->proc_name + && e->symtree->n.sym->ns->proc_name->formal) + s = e->symtree->n.sym->ns->proc_name->formal->sym; + + if (s != NULL) + st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name); + + if (st != NULL + && st->n.sym != NULL + && st->n.sym->attr.dummy) + e->symtree = st; +} + +/* Resolve an expression. That is, make sure that types of operands agree + with their operators, intrinsic operators are converted to function calls + for overloaded types and unresolved function references are resolved. */ + +bool +gfc_resolve_expr (gfc_expr *e) +{ + bool t; + bool inquiry_save, actual_arg_save, first_actual_arg_save; + + if (e == NULL || e->do_not_resolve_again) + return true; + + /* inquiry_argument only applies to variables. */ + inquiry_save = inquiry_argument; + actual_arg_save = actual_arg; + first_actual_arg_save = first_actual_arg; + + if (e->expr_type != EXPR_VARIABLE) + { + inquiry_argument = false; + actual_arg = false; + first_actual_arg = false; + } + else if (e->symtree != NULL + && *e->symtree->name == '@' + && e->symtree->n.sym->attr.dummy) + { + /* Deal with submodule specification expressions that are not + found to be referenced in module.c(read_cleanup). */ + fixup_unique_dummy (e); + } + + switch (e->expr_type) + { + case EXPR_OP: + t = resolve_operator (e); + break; + + case EXPR_FUNCTION: + case EXPR_VARIABLE: + + if (check_host_association (e)) + t = resolve_function (e); + else + t = resolve_variable (e); + + if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref + && e->ref->type != REF_SUBSTRING) + gfc_resolve_substring_charlen (e); + + break; + + case EXPR_COMPCALL: + t = resolve_typebound_function (e); + break; + + case EXPR_SUBSTRING: + t = gfc_resolve_ref (e); + break; + + case EXPR_CONSTANT: + case EXPR_NULL: + t = true; + break; + + case EXPR_PPC: + t = resolve_expr_ppc (e); + break; + + case EXPR_ARRAY: + t = false; + if (!gfc_resolve_ref (e)) + break; + + t = gfc_resolve_array_constructor (e); + /* Also try to expand a constructor. */ + if (t) + { + gfc_expression_rank (e); + if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) + gfc_expand_constructor (e, false); + } + + /* This provides the opportunity for the length of constructors with + character valued function elements to propagate the string length + to the expression. */ + if (t && e->ts.type == BT_CHARACTER) + { + /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER + here rather then add a duplicate test for it above. */ + gfc_expand_constructor (e, false); + t = gfc_resolve_character_array_constructor (e); + } + + break; + + case EXPR_STRUCTURE: + t = gfc_resolve_ref (e); + if (!t) + break; + + t = resolve_structure_cons (e, 0); + if (!t) + break; + + t = gfc_simplify_expr (e, 0); + break; + + default: + gfc_internal_error ("gfc_resolve_expr(): Bad expression type"); + } + + if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl) + fixup_charlen (e); + + inquiry_argument = inquiry_save; + actual_arg = actual_arg_save; + first_actual_arg = first_actual_arg_save; + + /* For some reason, resolving these expressions a second time mangles + the typespec of the expression itself. */ + if (t && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.select_rank_temporary + && UNLIMITED_POLY (e->symtree->n.sym)) + e->do_not_resolve_again = 1; + + return t; +} + + +/* Resolve an expression from an iterator. They must be scalar and have + INTEGER or (optionally) REAL type. */ + +static bool +gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, + const char *name_msgid) +{ + if (!gfc_resolve_expr (expr)) + return false; + + if (expr->rank != 0) + { + gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where); + return false; + } + + if (expr->ts.type != BT_INTEGER) + { + if (expr->ts.type == BT_REAL) + { + if (real_ok) + return gfc_notify_std (GFC_STD_F95_DEL, + "%s at %L must be integer", + _(name_msgid), &expr->where); + else + { + gfc_error ("%s at %L must be INTEGER", _(name_msgid), + &expr->where); + return false; + } + } + else + { + gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); + return false; + } + } + return true; +} + + +/* Resolve the expressions in an iterator structure. If REAL_OK is + false allow only INTEGER type iterators, otherwise allow REAL types. + Set own_scope to true for ac-implied-do and data-implied-do as those + have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */ + +bool +gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) +{ + if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")) + return false; + + if (!gfc_check_vardef_context (iter->var, false, false, own_scope, + _("iterator variable"))) + return false; + + if (!gfc_resolve_iterator_expr (iter->start, real_ok, + "Start expression in DO loop")) + return false; + + if (!gfc_resolve_iterator_expr (iter->end, real_ok, + "End expression in DO loop")) + return false; + + if (!gfc_resolve_iterator_expr (iter->step, real_ok, + "Step expression in DO loop")) + return false; + + /* Convert start, end, and step to the same type as var. */ + if (iter->start->ts.kind != iter->var->ts.kind + || iter->start->ts.type != iter->var->ts.type) + gfc_convert_type (iter->start, &iter->var->ts, 1); + + if (iter->end->ts.kind != iter->var->ts.kind + || iter->end->ts.type != iter->var->ts.type) + gfc_convert_type (iter->end, &iter->var->ts, 1); + + if (iter->step->ts.kind != iter->var->ts.kind + || iter->step->ts.type != iter->var->ts.type) + gfc_convert_type (iter->step, &iter->var->ts, 1); + + if (iter->step->expr_type == EXPR_CONSTANT) + { + if ((iter->step->ts.type == BT_INTEGER + && mpz_cmp_ui (iter->step->value.integer, 0) == 0) + || (iter->step->ts.type == BT_REAL + && mpfr_sgn (iter->step->value.real) == 0)) + { + gfc_error ("Step expression in DO loop at %L cannot be zero", + &iter->step->where); + return false; + } + } + + if (iter->start->expr_type == EXPR_CONSTANT + && iter->end->expr_type == EXPR_CONSTANT + && iter->step->expr_type == EXPR_CONSTANT) + { + int sgn, cmp; + if (iter->start->ts.type == BT_INTEGER) + { + sgn = mpz_cmp_ui (iter->step->value.integer, 0); + cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer); + } + else + { + sgn = mpfr_sgn (iter->step->value.real); + cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real); + } + if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))) + gfc_warning (OPT_Wzerotrip, + "DO loop at %L will be executed zero times", + &iter->step->where); + } + + if (iter->end->expr_type == EXPR_CONSTANT + && iter->end->ts.type == BT_INTEGER + && iter->step->expr_type == EXPR_CONSTANT + && iter->step->ts.type == BT_INTEGER + && (mpz_cmp_si (iter->step->value.integer, -1L) == 0 + || mpz_cmp_si (iter->step->value.integer, 1L) == 0)) + { + bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0; + int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false); + + if (is_step_positive + && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0) + gfc_warning (OPT_Wundefined_do_loop, + "DO loop at %L is undefined as it overflows", + &iter->step->where); + else if (!is_step_positive + && mpz_cmp (iter->end->value.integer, + gfc_integer_kinds[k].min_int) == 0) + gfc_warning (OPT_Wundefined_do_loop, + "DO loop at %L is undefined as it underflows", + &iter->step->where); + } + + return true; +} + + +/* Traversal function for find_forall_index. f == 2 signals that + that variable itself is not to be checked - only the references. */ + +static bool +forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) +{ + if (expr->expr_type != EXPR_VARIABLE) + return false; + + /* A scalar assignment */ + if (!expr->ref || *f == 1) + { + if (expr->symtree->n.sym == sym) + return true; + else + return false; + } + + if (*f == 2) + *f = 1; + return false; +} + + +/* Check whether the FORALL index appears in the expression or not. + Returns true if SYM is found in EXPR. */ + +bool +find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f) +{ + if (gfc_traverse_expr (expr, sym, forall_index, f)) + return true; + else + return false; +} + + +/* Resolve a list of FORALL iterators. The FORALL index-name is constrained + to be a scalar INTEGER variable. The subscripts and stride are scalar + INTEGERs, and if stride is a constant it must be nonzero. + Furthermore "A subscript or stride in a forall-triplet-spec shall + not contain a reference to any index-name in the + forall-triplet-spec-list in which it appears." (7.5.4.1) */ + +static void +resolve_forall_iterators (gfc_forall_iterator *it) +{ + gfc_forall_iterator *iter, *iter2; + + for (iter = it; iter; iter = iter->next) + { + if (gfc_resolve_expr (iter->var) + && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)) + gfc_error ("FORALL index-name at %L must be a scalar INTEGER", + &iter->var->where); + + if (gfc_resolve_expr (iter->start) + && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)) + gfc_error ("FORALL start expression at %L must be a scalar INTEGER", + &iter->start->where); + if (iter->var->ts.kind != iter->start->ts.kind) + gfc_convert_type (iter->start, &iter->var->ts, 1); + + if (gfc_resolve_expr (iter->end) + && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)) + gfc_error ("FORALL end expression at %L must be a scalar INTEGER", + &iter->end->where); + if (iter->var->ts.kind != iter->end->ts.kind) + gfc_convert_type (iter->end, &iter->var->ts, 1); + + if (gfc_resolve_expr (iter->stride)) + { + if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0) + gfc_error ("FORALL stride expression at %L must be a scalar %s", + &iter->stride->where, "INTEGER"); + + if (iter->stride->expr_type == EXPR_CONSTANT + && mpz_cmp_ui (iter->stride->value.integer, 0) == 0) + gfc_error ("FORALL stride expression at %L cannot be zero", + &iter->stride->where); + } + if (iter->var->ts.kind != iter->stride->ts.kind) + gfc_convert_type (iter->stride, &iter->var->ts, 1); + } + + for (iter = it; iter; iter = iter->next) + for (iter2 = iter; iter2; iter2 = iter2->next) + { + if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0) + || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0) + || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0)) + gfc_error ("FORALL index %qs may not appear in triplet " + "specification at %L", iter->var->symtree->name, + &iter2->start->where); + } +} + + +/* Given a pointer to a symbol that is a derived type, see if it's + inaccessible, i.e. if it's defined in another module and the components are + PRIVATE. The search is recursive if necessary. Returns zero if no + inaccessible components are found, nonzero otherwise. */ + +static int +derived_inaccessible (gfc_symbol *sym) +{ + gfc_component *c; + + if (sym->attr.use_assoc && sym->attr.private_comp) + return 1; + + for (c = sym->components; c; c = c->next) + { + /* Prevent an infinite loop through this function. */ + if (c->ts.type == BT_DERIVED && c->attr.pointer + && sym == c->ts.u.derived) + continue; + + if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived)) + return 1; + } + + return 0; +} + + +/* Resolve the argument of a deallocate expression. The expression must be + a pointer or a full array. */ + +static bool +resolve_deallocate_expr (gfc_expr *e) +{ + symbol_attribute attr; + int allocatable, pointer; + gfc_ref *ref; + gfc_symbol *sym; + gfc_component *c; + bool unlimited; + + if (!gfc_resolve_expr (e)) + return false; + + if (e->expr_type != EXPR_VARIABLE) + goto bad; + + sym = e->symtree->n.sym; + unlimited = UNLIMITED_POLY(sym); + + if (sym->ts.type == BT_CLASS) + { + allocatable = CLASS_DATA (sym)->attr.allocatable; + pointer = CLASS_DATA (sym)->attr.class_pointer; + } + else + { + allocatable = sym->attr.allocatable; + pointer = sym->attr.pointer; + } + for (ref = e->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + if (ref->u.ar.type != AR_FULL + && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0 + && ref->u.ar.codimen && gfc_ref_this_image (ref))) + allocatable = 0; + break; + + case REF_COMPONENT: + c = ref->u.c.component; + if (c->ts.type == BT_CLASS) + { + allocatable = CLASS_DATA (c)->attr.allocatable; + pointer = CLASS_DATA (c)->attr.class_pointer; + } + else + { + allocatable = c->attr.allocatable; + pointer = c->attr.pointer; + } + break; + + case REF_SUBSTRING: + case REF_INQUIRY: + allocatable = 0; + break; + } + } + + attr = gfc_expr_attr (e); + + if (allocatable == 0 && attr.pointer == 0 && !unlimited) + { + bad: + gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", + &e->where); + return false; + } + + /* F2008, C644. */ + if (gfc_is_coindexed (e)) + { + gfc_error ("Coindexed allocatable object at %L", &e->where); + return false; + } + + if (pointer + && !gfc_check_vardef_context (e, true, true, false, + _("DEALLOCATE object"))) + return false; + if (!gfc_check_vardef_context (e, false, true, false, + _("DEALLOCATE object"))) + return false; + + return true; +} + + +/* Returns true if the expression e contains a reference to the symbol sym. */ +static bool +sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) +{ + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym) + return true; + + return false; +} + +bool +gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) +{ + return gfc_traverse_expr (e, sym, sym_in_expr, 0); +} + + +/* Given the expression node e for an allocatable/pointer of derived type to be + allocated, get the expression node to be initialized afterwards (needed for + derived types with default initializers, and derived types with allocatable + components that need nullification.) */ + +gfc_expr * +gfc_expr_to_initialize (gfc_expr *e) +{ + gfc_expr *result; + gfc_ref *ref; + int i; + + result = gfc_copy_expr (e); + + /* Change the last array reference from AR_ELEMENT to AR_FULL. */ + for (ref = result->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->next == NULL) + { + if (ref->u.ar.dimen == 0 + && ref->u.ar.as && ref->u.ar.as->corank) + return result; + + ref->u.ar.type = AR_FULL; + + for (i = 0; i < ref->u.ar.dimen; i++) + ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL; + + break; + } + + gfc_free_shape (&result->shape, result->rank); + + /* Recalculate rank, shape, etc. */ + gfc_resolve_expr (result); + return result; +} + + +/* If the last ref of an expression is an array ref, return a copy of the + expression with that one removed. Otherwise, a copy of the original + expression. This is used for allocate-expressions and pointer assignment + LHS, where there may be an array specification that needs to be stripped + off when using gfc_check_vardef_context. */ + +static gfc_expr* +remove_last_array_ref (gfc_expr* e) +{ + gfc_expr* e2; + gfc_ref** r; + + e2 = gfc_copy_expr (e); + for (r = &e2->ref; *r; r = &(*r)->next) + if ((*r)->type == REF_ARRAY && !(*r)->next) + { + gfc_free_ref_list (*r); + *r = NULL; + break; + } + + return e2; +} + + +/* Used in resolve_allocate_expr to check that a allocation-object and + a source-expr are conformable. This does not catch all possible + cases; in particular a runtime checking is needed. */ + +static bool +conformable_arrays (gfc_expr *e1, gfc_expr *e2) +{ + gfc_ref *tail; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + + /* First compare rank. */ + if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) + || (!tail && e1->rank != e2->rank)) + { + gfc_error ("Source-expr at %L must be scalar or have the " + "same rank as the allocate-object at %L", + &e1->where, &e2->where); + return false; + } + + if (e1->shape) + { + int i; + mpz_t s; + + mpz_init (s); + + for (i = 0; i < e1->rank; i++) + { + if (tail->u.ar.start[i] == NULL) + break; + + if (tail->u.ar.end[i]) + { + mpz_set (s, tail->u.ar.end[i]->value.integer); + mpz_sub (s, s, tail->u.ar.start[i]->value.integer); + mpz_add_ui (s, s, 1); + } + else + { + mpz_set (s, tail->u.ar.start[i]->value.integer); + } + + if (mpz_cmp (e1->shape[i], s) != 0) + { + gfc_error ("Source-expr at %L and allocate-object at %L must " + "have the same shape", &e1->where, &e2->where); + mpz_clear (s); + return false; + } + } + + mpz_clear (s); + } + + return true; +} + + +/* Resolve the expression in an ALLOCATE statement, doing the additional + checks to see whether the expression is OK or not. The expression must + have a trailing array reference that gives the size of the array. */ + +static bool +resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) +{ + int i, pointer, allocatable, dimension, is_abstract; + int codimension; + bool coindexed; + bool unlimited; + symbol_attribute attr; + gfc_ref *ref, *ref2; + gfc_expr *e2; + gfc_array_ref *ar; + gfc_symbol *sym = NULL; + gfc_alloc *a; + gfc_component *c; + bool t; + + /* Mark the utmost array component as being in allocate to allow DIMEN_STAR + checking of coarrays. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + + if (ref && ref->type == REF_ARRAY) + ref->u.ar.in_allocate = true; + + if (!gfc_resolve_expr (e)) + goto failure; + + /* Make sure the expression is allocatable or a pointer. If it is + pointer, the next-to-last reference must be a pointer. */ + + ref2 = NULL; + if (e->symtree) + sym = e->symtree->n.sym; + + /* Check whether ultimate component is abstract and CLASS. */ + is_abstract = 0; + + /* Is the allocate-object unlimited polymorphic? */ + unlimited = UNLIMITED_POLY(e); + + if (e->expr_type != EXPR_VARIABLE) + { + allocatable = 0; + attr = gfc_expr_attr (e); + pointer = attr.pointer; + dimension = attr.dimension; + codimension = attr.codimension; + } + else + { + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + { + allocatable = CLASS_DATA (sym)->attr.allocatable; + pointer = CLASS_DATA (sym)->attr.class_pointer; + dimension = CLASS_DATA (sym)->attr.dimension; + codimension = CLASS_DATA (sym)->attr.codimension; + is_abstract = CLASS_DATA (sym)->attr.abstract; + } + else + { + allocatable = sym->attr.allocatable; + pointer = sym->attr.pointer; + dimension = sym->attr.dimension; + codimension = sym->attr.codimension; + } + + coindexed = false; + + for (ref = e->ref; ref; ref2 = ref, ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + if (ref->u.ar.codimen > 0) + { + int n; + for (n = ref->u.ar.dimen; + n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) + { + coindexed = true; + break; + } + } + + if (ref->next != NULL) + pointer = 0; + break; + + case REF_COMPONENT: + /* F2008, C644. */ + if (coindexed) + { + gfc_error ("Coindexed allocatable object at %L", + &e->where); + goto failure; + } + + c = ref->u.c.component; + if (c->ts.type == BT_CLASS) + { + allocatable = CLASS_DATA (c)->attr.allocatable; + pointer = CLASS_DATA (c)->attr.class_pointer; + dimension = CLASS_DATA (c)->attr.dimension; + codimension = CLASS_DATA (c)->attr.codimension; + is_abstract = CLASS_DATA (c)->attr.abstract; + } + else + { + allocatable = c->attr.allocatable; + pointer = c->attr.pointer; + dimension = c->attr.dimension; + codimension = c->attr.codimension; + is_abstract = c->attr.abstract; + } + break; + + case REF_SUBSTRING: + case REF_INQUIRY: + allocatable = 0; + pointer = 0; + break; + } + } + } + + /* Check for F08:C628 (F2018:C932). Each allocate-object shall be a data + pointer or an allocatable variable. */ + if (allocatable == 0 && pointer == 0) + { + gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", + &e->where); + goto failure; + } + + /* Some checks for the SOURCE tag. */ + if (code->expr3) + { + /* Check F03:C631. */ + if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) + { + gfc_error ("Type of entity at %L is type incompatible with " + "source-expr at %L", &e->where, &code->expr3->where); + goto failure; + } + + /* Check F03:C632 and restriction following Note 6.18. */ + if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e)) + goto failure; + + /* Check F03:C633. */ + if (code->expr3->ts.kind != e->ts.kind && !unlimited) + { + gfc_error ("The allocate-object at %L and the source-expr at %L " + "shall have the same kind type parameter", + &e->where, &code->expr3->where); + goto failure; + } + + /* Check F2008, C642. */ + if (code->expr3->ts.type == BT_DERIVED + && ((codimension && gfc_expr_attr (code->expr3).lock_comp) + || (code->expr3->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && code->expr3->ts.u.derived->intmod_sym_id + == ISOFORTRAN_LOCK_TYPE))) + { + gfc_error ("The source-expr at %L shall neither be of type " + "LOCK_TYPE nor have a LOCK_TYPE component if " + "allocate-object at %L is a coarray", + &code->expr3->where, &e->where); + goto failure; + } + + /* Check TS18508, C702/C703. */ + if (code->expr3->ts.type == BT_DERIVED + && ((codimension && gfc_expr_attr (code->expr3).event_comp) + || (code->expr3->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && code->expr3->ts.u.derived->intmod_sym_id + == ISOFORTRAN_EVENT_TYPE))) + { + gfc_error ("The source-expr at %L shall neither be of type " + "EVENT_TYPE nor have a EVENT_TYPE component if " + "allocate-object at %L is a coarray", + &code->expr3->where, &e->where); + goto failure; + } + } + + /* Check F08:C629. */ + if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN + && !code->expr3) + { + gcc_assert (e->ts.type == BT_CLASS); + gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " + "type-spec or source-expr", sym->name, &e->where); + goto failure; + } + + /* Check F08:C632. */ + if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred + && !UNLIMITED_POLY (e)) + { + int cmp; + + if (!e->ts.u.cl->length) + goto failure; + + cmp = gfc_dep_compare_expr (e->ts.u.cl->length, + code->ext.alloc.ts.u.cl->length); + if (cmp == 1 || cmp == -1 || cmp == -3) + { + gfc_error ("Allocating %s at %L with type-spec requires the same " + "character-length parameter as in the declaration", + sym->name, &e->where); + goto failure; + } + } + + /* In the variable definition context checks, gfc_expr_attr is used + on the expression. This is fooled by the array specification + present in e, thus we have to eliminate that one temporarily. */ + e2 = remove_last_array_ref (e); + t = true; + if (t && pointer) + t = gfc_check_vardef_context (e2, true, true, false, + _("ALLOCATE object")); + if (t) + t = gfc_check_vardef_context (e2, false, true, false, + _("ALLOCATE object")); + gfc_free_expr (e2); + if (!t) + goto failure; + + if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension + && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED) + { + /* For class arrays, the initialization with SOURCE is done + using _copy and trans_call. It is convenient to exploit that + when the allocated type is different from the declared type but + no SOURCE exists by setting expr3. */ + code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); + } + else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED + && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + { + /* We have to zero initialize the integer variable. */ + code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0); + } + + if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) + { + /* Make sure the vtab symbol is present when + the module variables are generated. */ + gfc_typespec ts = e->ts; + if (code->expr3) + ts = code->expr3->ts; + else if (code->ext.alloc.ts.type == BT_DERIVED) + ts = code->ext.alloc.ts; + + /* Finding the vtab also publishes the type's symbol. Therefore this + statement is necessary. */ + gfc_find_derived_vtab (ts.u.derived); + } + else if (unlimited && !UNLIMITED_POLY (code->expr3)) + { + /* Again, make sure the vtab symbol is present when + the module variables are generated. */ + gfc_typespec *ts = NULL; + if (code->expr3) + ts = &code->expr3->ts; + else + ts = &code->ext.alloc.ts; + + gcc_assert (ts); + + /* Finding the vtab also publishes the type's symbol. Therefore this + statement is necessary. */ + gfc_find_vtab (ts); + } + + if (dimension == 0 && codimension == 0) + goto success; + + /* Make sure the last reference node is an array specification. */ + + if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL + || (dimension && ref2->u.ar.dimen == 0)) + { + /* F08:C633. */ + if (code->expr3) + { + if (!gfc_notify_std (GFC_STD_F2008, "Array specification required " + "in ALLOCATE statement at %L", &e->where)) + goto failure; + if (code->expr3->rank != 0) + *array_alloc_wo_spec = true; + else + { + gfc_error ("Array specification or array-valued SOURCE= " + "expression required in ALLOCATE statement at %L", + &e->where); + goto failure; + } + } + else + { + gfc_error ("Array specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } + } + + /* Make sure that the array section reference makes sense in the + context of an ALLOCATE specification. */ + + ar = &ref2->u.ar; + + if (codimension) + for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) + { + switch (ar->dimen_type[i]) + { + case DIMEN_THIS_IMAGE: + gfc_error ("Coarray specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + + case DIMEN_RANGE: + if (ar->start[i] == 0 || ar->end[i] == 0) + { + /* If ar->stride[i] is NULL, we issued a previous error. */ + if (ar->stride[i] == NULL) + gfc_error ("Bad array specification in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } + else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1) + { + gfc_error ("Upper cobound is less than lower cobound at %L", + &ar->start[i]->where); + goto failure; + } + break; + + case DIMEN_ELEMENT: + if (ar->start[i]->expr_type == EXPR_CONSTANT) + { + gcc_assert (ar->start[i]->ts.type == BT_INTEGER); + if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0) + { + gfc_error ("Upper cobound is less than lower cobound " + "of 1 at %L", &ar->start[i]->where); + goto failure; + } + } + break; + + case DIMEN_STAR: + break; + + default: + gfc_error ("Bad array specification in ALLOCATE statement at %L", + &e->where); + goto failure; + + } + } + for (i = 0; i < ar->dimen; i++) + { + if (ar->type == AR_ELEMENT || ar->type == AR_FULL) + goto check_symbols; + + switch (ar->dimen_type[i]) + { + case DIMEN_ELEMENT: + break; + + case DIMEN_RANGE: + if (ar->start[i] != NULL + && ar->end[i] != NULL + && ar->stride[i] == NULL) + break; + + /* Fall through. */ + + case DIMEN_UNKNOWN: + case DIMEN_VECTOR: + case DIMEN_STAR: + case DIMEN_THIS_IMAGE: + gfc_error ("Bad array specification in ALLOCATE statement at %L", + &e->where); + goto failure; + } + +check_symbols: + for (a = code->ext.alloc.list; a; a = a->next) + { + sym = a->expr->symtree->n.sym; + + /* TODO - check derived type components. */ + if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS) + continue; + + if ((ar->start[i] != NULL + && gfc_find_sym_in_expr (sym, ar->start[i])) + || (ar->end[i] != NULL + && gfc_find_sym_in_expr (sym, ar->end[i]))) + { + gfc_error ("%qs must not appear in the array specification at " + "%L in the same ALLOCATE statement where it is " + "itself allocated", sym->name, &ar->where); + goto failure; + } + } + } + + for (i = ar->dimen; i < ar->codimen + ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_ELEMENT + || ar->dimen_type[i] == DIMEN_RANGE) + { + if (i == (ar->dimen + ar->codimen - 1)) + { + gfc_error ("Expected '*' in coindex specification in ALLOCATE " + "statement at %L", &e->where); + goto failure; + } + continue; + } + + if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1) + && ar->stride[i] == NULL) + break; + + gfc_error ("Bad coarray specification in ALLOCATE statement at %L", + &e->where); + goto failure; + } + +success: + return true; + +failure: + return false; +} + + +static void +resolve_allocate_deallocate (gfc_code *code, const char *fcn) +{ + gfc_expr *stat, *errmsg, *pe, *qe; + gfc_alloc *a, *p, *q; + + stat = code->expr1; + errmsg = code->expr2; + + /* Check the stat variable. */ + if (stat) + { + if (!gfc_check_vardef_context (stat, false, false, false, + _("STAT variable"))) + goto done_stat; + + if (stat->ts.type != BT_INTEGER + || stat->rank > 0) + gfc_error ("Stat-variable at %L must be a scalar INTEGER " + "variable", &stat->where); + + if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL) + goto done_stat; + + /* F2018:9.7.4: The stat-variable shall not be allocated or deallocated + * within the ALLOCATE or DEALLOCATE statement in which it appears ... + */ + for (p = code->ext.alloc.list; p; p = p->next) + if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Stat-variable at %L shall not be %sd within " + "the same %s statement", &stat->where, fcn, fcn); + break; + } + } + } + +done_stat: + + /* Check the errmsg variable. */ + if (errmsg) + { + if (!stat) + gfc_warning (0, "ERRMSG at %L is useless without a STAT tag", + &errmsg->where); + + if (!gfc_check_vardef_context (errmsg, false, false, false, + _("ERRMSG variable"))) + goto done_errmsg; + + /* F18:R928 alloc-opt is ERRMSG = errmsg-variable + F18:R930 errmsg-variable is scalar-default-char-variable + F18:R906 default-char-variable is variable + F18:C906 default-char-variable shall be default character. */ + if (errmsg->ts.type != BT_CHARACTER + || errmsg->rank > 0 + || errmsg->ts.kind != gfc_default_character_kind) + gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER " + "variable", &errmsg->where); + + if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL) + goto done_errmsg; + + /* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated + * within the ALLOCATE or DEALLOCATE statement in which it appears ... + */ + for (p = code->ext.alloc.list; p; p = p->next) + if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) + { + gfc_ref *ref1, *ref2; + bool found = true; + + for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; + ref1 = ref1->next, ref2 = ref2->next) + { + if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) + continue; + if (ref1->u.c.component->name != ref2->u.c.component->name) + { + found = false; + break; + } + } + + if (found) + { + gfc_error ("Errmsg-variable at %L shall not be %sd within " + "the same %s statement", &errmsg->where, fcn, fcn); + break; + } + } + } + +done_errmsg: + + /* Check that an allocate-object appears only once in the statement. */ + + for (p = code->ext.alloc.list; p; p = p->next) + { + pe = p->expr; + for (q = p->next; q; q = q->next) + { + qe = q->expr; + if (pe->symtree->n.sym->name == qe->symtree->n.sym->name) + { + /* This is a potential collision. */ + gfc_ref *pr = pe->ref; + gfc_ref *qr = qe->ref; + + /* Follow the references until + a) They start to differ, in which case there is no error; + you can deallocate a%b and a%c in a single statement + b) Both of them stop, which is an error + c) One of them stops, which is also an error. */ + while (1) + { + if (pr == NULL && qr == NULL) + { + gfc_error ("Allocate-object at %L also appears at %L", + &pe->where, &qe->where); + break; + } + else if (pr != NULL && qr == NULL) + { + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &pe->where, &qe->where); + break; + } + else if (pr == NULL && qr != NULL) + { + gfc_error ("Allocate-object at %L is subobject of" + " object at %L", &qe->where, &pe->where); + break; + } + /* Here, pr != NULL && qr != NULL */ + gcc_assert(pr->type == qr->type); + if (pr->type == REF_ARRAY) + { + /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)), + which are legal. */ + gcc_assert (qr->type == REF_ARRAY); + + if (pr->next && qr->next) + { + int i; + gfc_array_ref *par = &(pr->u.ar); + gfc_array_ref *qar = &(qr->u.ar); + + for (i=0; idimen; i++) + { + if ((par->start[i] != NULL + || qar->start[i] != NULL) + && gfc_dep_compare_expr (par->start[i], + qar->start[i]) != 0) + goto break_label; + } + } + } + else + { + if (pr->u.c.component->name != qr->u.c.component->name) + break; + } + + pr = pr->next; + qr = qr->next; + } + break_label: + ; + } + } + } + + if (strcmp (fcn, "ALLOCATE") == 0) + { + bool arr_alloc_wo_spec = false; + + /* Resolving the expr3 in the loop over all objects to allocate would + execute loop invariant code for each loop item. Therefore do it just + once here. */ + if (code->expr3 && code->expr3->mold + && code->expr3->ts.type == BT_DERIVED) + { + /* Default initialization via MOLD (non-polymorphic). */ + gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); + if (rhs != NULL) + { + gfc_resolve_expr (rhs); + gfc_free_expr (code->expr3); + code->expr3 = rhs; + } + } + for (a = code->ext.alloc.list; a; a = a->next) + resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec); + + if (arr_alloc_wo_spec && code->expr3) + { + /* Mark the allocate to have to take the array specification + from the expr3. */ + code->ext.alloc.arr_spec_from_expr3 = 1; + } + } + else + { + for (a = code->ext.alloc.list; a; a = a->next) + resolve_deallocate_expr (a->expr); + } +} + + +/************ SELECT CASE resolution subroutines ************/ + +/* Callback function for our mergesort variant. Determines interval + overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for + op1 > op2. Assumes we're not dealing with the default case. + We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:). + There are nine situations to check. */ + +static int +compare_cases (const gfc_case *op1, const gfc_case *op2) +{ + int retval; + + if (op1->low == NULL) /* op1 = (:L) */ + { + /* op2 = (:N), so overlap. */ + retval = 0; + /* op2 = (M:) or (M:N), L < M */ + if (op2->low != NULL + && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) + retval = -1; + } + else if (op1->high == NULL) /* op1 = (K:) */ + { + /* op2 = (M:), so overlap. */ + retval = 0; + /* op2 = (:N) or (M:N), K > N */ + if (op2->high != NULL + && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) + retval = 1; + } + else /* op1 = (K:L) */ + { + if (op2->low == NULL) /* op2 = (:N), K > N */ + retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) + ? 1 : 0; + else if (op2->high == NULL) /* op2 = (M:), L < M */ + retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) + ? -1 : 0; + else /* op2 = (M:N) */ + { + retval = 0; + /* L < M */ + if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) + retval = -1; + /* K > N */ + else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) + retval = 1; + } + } + + return retval; +} + + +/* Merge-sort a double linked case list, detecting overlap in the + process. LIST is the head of the double linked case list before it + is sorted. Returns the head of the sorted list if we don't see any + overlap, or NULL otherwise. */ + +static gfc_case * +check_case_overlap (gfc_case *list) +{ + gfc_case *p, *q, *e, *tail; + int insize, nmerges, psize, qsize, cmp, overlap_seen; + + /* If the passed list was empty, return immediately. */ + if (!list) + return NULL; + + overlap_seen = 0; + insize = 1; + + /* Loop unconditionally. The only exit from this loop is a return + statement, when we've finished sorting the case list. */ + for (;;) + { + p = list; + list = NULL; + tail = NULL; + + /* Count the number of merges we do in this pass. */ + nmerges = 0; + + /* Loop while there exists a merge to be done. */ + while (p) + { + int i; + + /* Count this merge. */ + nmerges++; + + /* Cut the list in two pieces by stepping INSIZE places + forward in the list, starting from P. */ + psize = 0; + q = p; + for (i = 0; i < insize; i++) + { + psize++; + q = q->right; + if (!q) + break; + } + qsize = insize; + + /* Now we have two lists. Merge them! */ + while (psize > 0 || (qsize > 0 && q != NULL)) + { + /* See from which the next case to merge comes from. */ + if (psize == 0) + { + /* P is empty so the next case must come from Q. */ + e = q; + q = q->right; + qsize--; + } + else if (qsize == 0 || q == NULL) + { + /* Q is empty. */ + e = p; + p = p->right; + psize--; + } + else + { + cmp = compare_cases (p, q); + if (cmp < 0) + { + /* The whole case range for P is less than the + one for Q. */ + e = p; + p = p->right; + psize--; + } + else if (cmp > 0) + { + /* The whole case range for Q is greater than + the case range for P. */ + e = q; + q = q->right; + qsize--; + } + else + { + /* The cases overlap, or they are the same + element in the list. Either way, we must + issue an error and get the next case from P. */ + /* FIXME: Sort P and Q by line number. */ + gfc_error ("CASE label at %L overlaps with CASE " + "label at %L", &p->where, &q->where); + overlap_seen = 1; + e = p; + p = p->right; + psize--; + } + } + + /* Add the next element to the merged list. */ + if (tail) + tail->right = e; + else + list = e; + e->left = tail; + tail = e; + } + + /* P has now stepped INSIZE places along, and so has Q. So + they're the same. */ + p = q; + } + tail->right = NULL; + + /* If we have done only one merge or none at all, we've + finished sorting the cases. */ + if (nmerges <= 1) + { + if (!overlap_seen) + return list; + else + return NULL; + } + + /* Otherwise repeat, merging lists twice the size. */ + insize *= 2; + } +} + + +/* Check to see if an expression is suitable for use in a CASE statement. + Makes sure that all case expressions are scalar constants of the same + type. Return false if anything is wrong. */ + +static bool +validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) +{ + if (e == NULL) return true; + + if (e->ts.type != case_expr->ts.type) + { + gfc_error ("Expression in CASE statement at %L must be of type %s", + &e->where, gfc_basic_typename (case_expr->ts.type)); + return false; + } + + /* C805 (R808) For a given case-construct, each case-value shall be of + the same type as case-expr. For character type, length differences + are allowed, but the kind type parameters shall be the same. */ + + if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind) + { + gfc_error ("Expression in CASE statement at %L must be of kind %d", + &e->where, case_expr->ts.kind); + return false; + } + + /* Convert the case value kind to that of case expression kind, + if needed */ + + if (e->ts.kind != case_expr->ts.kind) + gfc_convert_type_warn (e, &case_expr->ts, 2, 0); + + if (e->rank != 0) + { + gfc_error ("Expression in CASE statement at %L must be scalar", + &e->where); + return false; + } + + return true; +} + + +/* Given a completely parsed select statement, we: + + - Validate all expressions and code within the SELECT. + - Make sure that the selection expression is not of the wrong type. + - Make sure that no case ranges overlap. + - Eliminate unreachable cases and unreachable code resulting from + removing case labels. + + The standard does allow unreachable cases, e.g. CASE (5:3). But + they are a hassle for code generation, and to prevent that, we just + cut them out here. This is not necessary for overlapping cases + because they are illegal and we never even try to generate code. + + We have the additional caveat that a SELECT construct could have + been a computed GOTO in the source code. Fortunately we can fairly + easily work around that here: The case_expr for a "real" SELECT CASE + is in code->expr1, but for a computed GOTO it is in code->expr2. All + we have to do is make sure that the case_expr is a scalar integer + expression. */ + +static void +resolve_select (gfc_code *code, bool select_type) +{ + gfc_code *body; + gfc_expr *case_expr; + gfc_case *cp, *default_case, *tail, *head; + int seen_unreachable; + int seen_logical; + int ncases; + bt type; + bool t; + + if (code->expr1 == NULL) + { + /* This was actually a computed GOTO statement. */ + case_expr = code->expr2; + if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0) + gfc_error ("Selection expression in computed GOTO statement " + "at %L must be a scalar integer expression", + &case_expr->where); + + /* Further checking is not necessary because this SELECT was built + by the compiler, so it should always be OK. Just move the + case_expr from expr2 to expr so that we can handle computed + GOTOs as normal SELECTs from here on. */ + code->expr1 = code->expr2; + code->expr2 = NULL; + return; + } + + case_expr = code->expr1; + type = case_expr->ts.type; + + /* F08:C830. */ + if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER) + { + gfc_error ("Argument of SELECT statement at %L cannot be %s", + &case_expr->where, gfc_typename (case_expr)); + + /* Punt. Going on here just produce more garbage error messages. */ + return; + } + + /* F08:R842. */ + if (!select_type && case_expr->rank != 0) + { + gfc_error ("Argument of SELECT statement at %L must be a scalar " + "expression", &case_expr->where); + + /* Punt. */ + return; + } + + /* Raise a warning if an INTEGER case value exceeds the range of + the case-expr. Later, all expressions will be promoted to the + largest kind of all case-labels. */ + + if (type == BT_INTEGER) + for (body = code->block; body; body = body->block) + for (cp = body->ext.block.case_list; cp; cp = cp->next) + { + if (cp->low + && gfc_check_integer_range (cp->low->value.integer, + case_expr->ts.kind) != ARITH_OK) + gfc_warning (0, "Expression in CASE statement at %L is " + "not in the range of %s", &cp->low->where, + gfc_typename (case_expr)); + + if (cp->high + && cp->low != cp->high + && gfc_check_integer_range (cp->high->value.integer, + case_expr->ts.kind) != ARITH_OK) + gfc_warning (0, "Expression in CASE statement at %L is " + "not in the range of %s", &cp->high->where, + gfc_typename (case_expr)); + } + + /* PR 19168 has a long discussion concerning a mismatch of the kinds + of the SELECT CASE expression and its CASE values. Walk the lists + of case values, and if we find a mismatch, promote case_expr to + the appropriate kind. */ + + if (type == BT_LOGICAL || type == BT_INTEGER) + { + for (body = code->block; body; body = body->block) + { + /* Walk the case label list. */ + for (cp = body->ext.block.case_list; cp; cp = cp->next) + { + /* Intercept the DEFAULT case. It does not have a kind. */ + if (cp->low == NULL && cp->high == NULL) + continue; + + /* Unreachable case ranges are discarded, so ignore. */ + if (cp->low != NULL && cp->high != NULL + && cp->low != cp->high + && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) + continue; + + if (cp->low != NULL + && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low)) + gfc_convert_type_warn (case_expr, &cp->low->ts, 1, 0); + + if (cp->high != NULL + && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high)) + gfc_convert_type_warn (case_expr, &cp->high->ts, 1, 0); + } + } + } + + /* Assume there is no DEFAULT case. */ + default_case = NULL; + head = tail = NULL; + ncases = 0; + seen_logical = 0; + + for (body = code->block; body; body = body->block) + { + /* Assume the CASE list is OK, and all CASE labels can be matched. */ + t = true; + seen_unreachable = 0; + + /* Walk the case label list, making sure that all case labels + are legal. */ + for (cp = body->ext.block.case_list; cp; cp = cp->next) + { + /* Count the number of cases in the whole construct. */ + ncases++; + + /* Intercept the DEFAULT case. */ + if (cp->low == NULL && cp->high == NULL) + { + if (default_case != NULL) + { + gfc_error ("The DEFAULT CASE at %L cannot be followed " + "by a second DEFAULT CASE at %L", + &default_case->where, &cp->where); + t = false; + break; + } + else + { + default_case = cp; + continue; + } + } + + /* Deal with single value cases and case ranges. Errors are + issued from the validation function. */ + if (!validate_case_label_expr (cp->low, case_expr) + || !validate_case_label_expr (cp->high, case_expr)) + { + t = false; + break; + } + + if (type == BT_LOGICAL + && ((cp->low == NULL || cp->high == NULL) + || cp->low != cp->high)) + { + gfc_error ("Logical range in CASE statement at %L is not " + "allowed", + cp->low ? &cp->low->where : &cp->high->where); + t = false; + break; + } + + if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT) + { + int value; + value = cp->low->value.logical == 0 ? 2 : 1; + if (value & seen_logical) + { + gfc_error ("Constant logical value in CASE statement " + "is repeated at %L", + &cp->low->where); + t = false; + break; + } + seen_logical |= value; + } + + if (cp->low != NULL && cp->high != NULL + && cp->low != cp->high + && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) + { + if (warn_surprising) + gfc_warning (OPT_Wsurprising, + "Range specification at %L can never be matched", + &cp->where); + + cp->unreachable = 1; + seen_unreachable = 1; + } + else + { + /* If the case range can be matched, it can also overlap with + other cases. To make sure it does not, we put it in a + double linked list here. We sort that with a merge sort + later on to detect any overlapping cases. */ + if (!head) + { + head = tail = cp; + head->right = head->left = NULL; + } + else + { + tail->right = cp; + tail->right->left = tail; + tail = tail->right; + tail->right = NULL; + } + } + } + + /* It there was a failure in the previous case label, give up + for this case label list. Continue with the next block. */ + if (!t) + continue; + + /* See if any case labels that are unreachable have been seen. + If so, we eliminate them. This is a bit of a kludge because + the case lists for a single case statement (label) is a + single forward linked lists. */ + if (seen_unreachable) + { + /* Advance until the first case in the list is reachable. */ + while (body->ext.block.case_list != NULL + && body->ext.block.case_list->unreachable) + { + gfc_case *n = body->ext.block.case_list; + body->ext.block.case_list = body->ext.block.case_list->next; + n->next = NULL; + gfc_free_case_list (n); + } + + /* Strip all other unreachable cases. */ + if (body->ext.block.case_list) + { + for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next) + { + if (cp->next->unreachable) + { + gfc_case *n = cp->next; + cp->next = cp->next->next; + n->next = NULL; + gfc_free_case_list (n); + } + } + } + } + } + + /* See if there were overlapping cases. If the check returns NULL, + there was overlap. In that case we don't do anything. If head + is non-NULL, we prepend the DEFAULT case. The sorted list can + then used during code generation for SELECT CASE constructs with + a case expression of a CHARACTER type. */ + if (head) + { + head = check_case_overlap (head); + + /* Prepend the default_case if it is there. */ + if (head != NULL && default_case) + { + default_case->left = NULL; + default_case->right = head; + head->left = default_case; + } + } + + /* Eliminate dead blocks that may be the result if we've seen + unreachable case labels for a block. */ + for (body = code; body && body->block; body = body->block) + { + if (body->block->ext.block.case_list == NULL) + { + /* Cut the unreachable block from the code chain. */ + gfc_code *c = body->block; + body->block = c->block; + + /* Kill the dead block, but not the blocks below it. */ + c->block = NULL; + gfc_free_statements (c); + } + } + + /* More than two cases is legal but insane for logical selects. + Issue a warning for it. */ + if (warn_surprising && type == BT_LOGICAL && ncases > 2) + gfc_warning (OPT_Wsurprising, + "Logical SELECT CASE block at %L has more that two cases", + &code->loc); +} + + +/* Check if a derived type is extensible. */ + +bool +gfc_type_is_extensible (gfc_symbol *sym) +{ + return !(sym->attr.is_bind_c || sym->attr.sequence + || (sym->attr.is_class + && sym->components->ts.u.derived->attr.unlimited_polymorphic)); +} + + +static void +resolve_types (gfc_namespace *ns); + +/* Resolve an associate-name: Resolve target and ensure the type-spec is + correct as well as possibly the array-spec. */ + +static void +resolve_assoc_var (gfc_symbol* sym, bool resolve_target) +{ + gfc_expr* target; + + gcc_assert (sym->assoc); + gcc_assert (sym->attr.flavor == FL_VARIABLE); + + /* If this is for SELECT TYPE, the target may not yet be set. In that + case, return. Resolution will be called later manually again when + this is done. */ + target = sym->assoc->target; + if (!target) + return; + gcc_assert (!sym->assoc->dangling); + + if (resolve_target && !gfc_resolve_expr (target)) + return; + + /* For variable targets, we get some attributes from the target. */ + if (target->expr_type == EXPR_VARIABLE) + { + gfc_symbol *tsym, *dsym; + + gcc_assert (target->symtree); + tsym = target->symtree->n.sym; + + if (gfc_expr_attr (target).proc_pointer) + { + gfc_error ("Associating entity %qs at %L is a procedure pointer", + tsym->name, &target->where); + return; + } + + if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic + && (dsym = gfc_find_dt_in_generic (tsym)) != NULL + && dsym->attr.flavor == FL_DERIVED) + { + gfc_error ("Derived type %qs cannot be used as a variable at %L", + tsym->name, &target->where); + return; + } + + if (tsym->attr.flavor == FL_PROCEDURE) + { + bool is_error = true; + if (tsym->attr.function && tsym->result == tsym) + for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent) + if (tsym == ns->proc_name) + { + is_error = false; + break; + } + if (is_error) + { + gfc_error ("Associating entity %qs at %L is a procedure name", + tsym->name, &target->where); + return; + } + } + + sym->attr.asynchronous = tsym->attr.asynchronous; + sym->attr.volatile_ = tsym->attr.volatile_; + + sym->attr.target = tsym->attr.target + || gfc_expr_attr (target).pointer; + if (is_subref_array (target)) + sym->attr.subref_array_pointer = 1; + } + else if (target->ts.type == BT_PROCEDURE) + { + gfc_error ("Associating selector-expression at %L yields a procedure", + &target->where); + return; + } + + if (target->expr_type == EXPR_NULL) + { + gfc_error ("Selector at %L cannot be NULL()", &target->where); + return; + } + else if (target->ts.type == BT_UNKNOWN) + { + gfc_error ("Selector at %L has no type", &target->where); + return; + } + + /* Get type if this was not already set. Note that it can be + some other type than the target in case this is a SELECT TYPE + selector! So we must not update when the type is already there. */ + if (sym->ts.type == BT_UNKNOWN) + sym->ts = target->ts; + + gcc_assert (sym->ts.type != BT_UNKNOWN); + + /* See if this is a valid association-to-variable. */ + sym->assoc->variable = (target->expr_type == EXPR_VARIABLE + && !gfc_has_vector_subscript (target)); + + /* Finally resolve if this is an array or not. */ + if (sym->attr.dimension && target->rank == 0) + { + /* primary.c makes the assumption that a reference to an associate + name followed by a left parenthesis is an array reference. */ + if (sym->ts.type != BT_CHARACTER) + gfc_error ("Associate-name %qs at %L is used as array", + sym->name, &sym->declared_at); + sym->attr.dimension = 0; + return; + } + + + /* We cannot deal with class selectors that need temporaries. */ + if (target->ts.type == BT_CLASS + && gfc_ref_needs_temporary_p (target->ref)) + { + gfc_error ("CLASS selector at %L needs a temporary which is not " + "yet implemented", &target->where); + return; + } + + if (target->ts.type == BT_CLASS) + gfc_fix_class_refs (target); + + if (target->rank != 0 && !sym->attr.select_rank_temporary) + { + gfc_array_spec *as; + /* The rank may be incorrectly guessed at parsing, therefore make sure + it is corrected now. */ + if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed)) + { + if (!sym->as) + sym->as = gfc_get_array_spec (); + as = sym->as; + as->rank = target->rank; + as->type = AS_DEFERRED; + as->corank = gfc_get_corank (target); + sym->attr.dimension = 1; + if (as->corank != 0) + sym->attr.codimension = 1; + } + else if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym) + && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) + { + if (!CLASS_DATA (sym)->as) + CLASS_DATA (sym)->as = gfc_get_array_spec (); + as = CLASS_DATA (sym)->as; + as->rank = target->rank; + as->type = AS_DEFERRED; + as->corank = gfc_get_corank (target); + CLASS_DATA (sym)->attr.dimension = 1; + if (as->corank != 0) + CLASS_DATA (sym)->attr.codimension = 1; + } + } + else if (!sym->attr.select_rank_temporary) + { + /* target's rank is 0, but the type of the sym is still array valued, + which has to be corrected. */ + if (sym->ts.type == BT_CLASS && sym->ts.u.derived + && CLASS_DATA (sym) && CLASS_DATA (sym)->as) + { + gfc_array_spec *as; + symbol_attribute attr; + /* The associated variable's type is still the array type + correct this now. */ + gfc_typespec *ts = &target->ts; + gfc_ref *ref; + gfc_component *c; + for (ref = target->ref; ref != NULL; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + ts = &ref->u.c.component->ts; + break; + case REF_ARRAY: + if (ts->type == BT_CLASS) + ts = &ts->u.derived->components->ts; + break; + default: + break; + } + } + /* Create a scalar instance of the current class type. Because the + rank of a class array goes into its name, the type has to be + rebuild. The alternative of (re-)setting just the attributes + and as in the current type, destroys the type also in other + places. */ + as = NULL; + sym->ts = *ts; + sym->ts.type = BT_CLASS; + attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; + attr.class_ok = 0; + attr.associate_var = 1; + attr.dimension = attr.codimension = 0; + attr.class_pointer = 1; + if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) + gcc_unreachable (); + /* Make sure the _vptr is set. */ + c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); + CLASS_DATA (sym)->attr.pointer = 1; + CLASS_DATA (sym)->attr.class_pointer = 1; + gfc_set_sym_referenced (sym->ts.u.derived); + gfc_commit_symbol (sym->ts.u.derived); + /* _vptr now has the _vtab in it, change it to the _vtype. */ + if (c->ts.u.derived->attr.vtab) + c->ts.u.derived = c->ts.u.derived->ts.u.derived; + c->ts.u.derived->ns->types_resolved = 0; + resolve_types (c->ts.u.derived->ns); + } + } + + /* Mark this as an associate variable. */ + sym->attr.associate_var = 1; + + /* Fix up the type-spec for CHARACTER types. */ + if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary) + { + if (!sym->ts.u.cl) + sym->ts.u.cl = target->ts.u.cl; + + if (sym->ts.deferred && target->expr_type == EXPR_VARIABLE + && target->symtree->n.sym->attr.dummy + && sym->ts.u.cl == target->ts.u.cl) + { + sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); + sym->ts.deferred = 1; + } + + if (!sym->ts.u.cl->length + && !sym->ts.deferred + && target->expr_type == EXPR_CONSTANT) + { + sym->ts.u.cl->length = + gfc_get_int_expr (gfc_charlen_int_kind, NULL, + target->value.character.length); + } + else if ((!sym->ts.u.cl->length + || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) + && target->expr_type != EXPR_VARIABLE) + { + sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); + sym->ts.deferred = 1; + + /* This is reset in trans-stmt.c after the assignment + of the target expression to the associate name. */ + sym->attr.allocatable = 1; + } + } + + /* If the target is a good class object, so is the associate variable. */ + if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) + sym->attr.class_ok = 1; +} + + +/* Ensure that SELECT TYPE expressions have the correct rank and a full + array reference, where necessary. The symbols are artificial and so + the dimension attribute and arrayspec can also be set. In addition, + sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS. + This is corrected here as well.*/ + +static void +fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, + int rank, gfc_ref *ref) +{ + gfc_ref *nref = (*expr1)->ref; + gfc_symbol *sym1 = (*expr1)->symtree->n.sym; + gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL; + (*expr1)->rank = rank; + if (sym1->ts.type == BT_CLASS) + { + if ((*expr1)->ts.type != BT_CLASS) + (*expr1)->ts = sym1->ts; + + CLASS_DATA (sym1)->attr.dimension = 1; + if (CLASS_DATA (sym1)->as == NULL && sym2) + CLASS_DATA (sym1)->as + = gfc_copy_array_spec (CLASS_DATA (sym2)->as); + } + else + { + sym1->attr.dimension = 1; + if (sym1->as == NULL && sym2) + sym1->as = gfc_copy_array_spec (sym2->as); + } + + for (; nref; nref = nref->next) + if (nref->next == NULL) + break; + + if (ref && nref && nref->type != REF_ARRAY) + nref->next = gfc_copy_ref (ref); + else if (ref && !nref) + (*expr1)->ref = gfc_copy_ref (ref); +} + + +static gfc_expr * +build_loc_call (gfc_expr *sym_expr) +{ + gfc_expr *loc_call; + loc_call = gfc_get_expr (); + loc_call->expr_type = EXPR_FUNCTION; + gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false); + loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE; + loc_call->symtree->n.sym->attr.intrinsic = 1; + loc_call->symtree->n.sym->result = loc_call->symtree->n.sym; + gfc_commit_symbol (loc_call->symtree->n.sym); + loc_call->ts.type = BT_INTEGER; + loc_call->ts.kind = gfc_index_integer_kind; + loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC); + loc_call->value.function.actual = gfc_get_actual_arglist (); + loc_call->value.function.actual->expr = sym_expr; + loc_call->where = sym_expr->where; + return loc_call; +} + +/* Resolve a SELECT TYPE statement. */ + +static void +resolve_select_type (gfc_code *code, gfc_namespace *old_ns) +{ + gfc_symbol *selector_type; + gfc_code *body, *new_st, *if_st, *tail; + gfc_code *class_is = NULL, *default_case = NULL; + gfc_case *c; + gfc_symtree *st; + char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; + gfc_namespace *ns; + int error = 0; + int rank = 0; + gfc_ref* ref = NULL; + gfc_expr *selector_expr = NULL; + + ns = code->ext.block.ns; + gfc_resolve (ns); + + /* Check for F03:C813. */ + if (code->expr1->ts.type != BT_CLASS + && !(code->expr2 && code->expr2->ts.type == BT_CLASS)) + { + gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " + "at %L", &code->loc); + return; + } + + if (!code->expr1->symtree->n.sym->attr.class_ok) + return; + + if (code->expr2) + { + gfc_ref *ref2 = NULL; + for (ref = code->expr2->ref; ref != NULL; ref = ref->next) + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS) + ref2 = ref; + + if (ref2) + { + if (code->expr1->symtree->n.sym->attr.untyped) + code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts; + selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived; + } + else + { + if (code->expr1->symtree->n.sym->attr.untyped) + code->expr1->symtree->n.sym->ts = code->expr2->ts; + selector_type = CLASS_DATA (code->expr2) + ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived; + } + + if (code->expr2->rank + && code->expr1->ts.type == BT_CLASS + && CLASS_DATA (code->expr1)->as) + CLASS_DATA (code->expr1)->as->rank = code->expr2->rank; + + /* F2008: C803 The selector expression must not be coindexed. */ + if (gfc_is_coindexed (code->expr2)) + { + gfc_error ("Selector at %L must not be coindexed", + &code->expr2->where); + return; + } + + } + else + { + selector_type = CLASS_DATA (code->expr1)->ts.u.derived; + + if (gfc_is_coindexed (code->expr1)) + { + gfc_error ("Selector at %L must not be coindexed", + &code->expr1->where); + return; + } + } + + /* Loop over TYPE IS / CLASS IS cases. */ + for (body = code->block; body; body = body->block) + { + c = body->ext.block.case_list; + + if (!error) + { + /* Check for repeated cases. */ + for (tail = code->block; tail; tail = tail->block) + { + gfc_case *d = tail->ext.block.case_list; + if (tail == body) + break; + + if (c->ts.type == d->ts.type + && ((c->ts.type == BT_DERIVED + && c->ts.u.derived && d->ts.u.derived + && !strcmp (c->ts.u.derived->name, + d->ts.u.derived->name)) + || c->ts.type == BT_UNKNOWN + || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && c->ts.kind == d->ts.kind))) + { + gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L", + &c->where, &d->where); + return; + } + } + } + + /* Check F03:C815. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && selector_type + && !selector_type->attr.unlimited_polymorphic + && !gfc_type_is_extensible (c->ts.u.derived)) + { + gfc_error ("Derived type %qs at %L must be extensible", + c->ts.u.derived->name, &c->where); + error++; + continue; + } + + /* Check F03:C816. */ + if (c->ts.type != BT_UNKNOWN + && selector_type && !selector_type->attr.unlimited_polymorphic + && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) + || !gfc_type_is_extension_of (selector_type, c->ts.u.derived))) + { + if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + gfc_error ("Derived type %qs at %L must be an extension of %qs", + c->ts.u.derived->name, &c->where, selector_type->name); + else + gfc_error ("Unexpected intrinsic type %qs at %L", + gfc_basic_typename (c->ts.type), &c->where); + error++; + continue; + } + + /* Check F03:C814. */ + if (c->ts.type == BT_CHARACTER + && (c->ts.u.cl->length != NULL || c->ts.deferred)) + { + gfc_error ("The type-spec at %L shall specify that each length " + "type parameter is assumed", &c->where); + error++; + continue; + } + + /* Intercept the DEFAULT case. */ + if (c->ts.type == BT_UNKNOWN) + { + /* Check F03:C818. */ + if (default_case) + { + gfc_error ("The DEFAULT CASE at %L cannot be followed " + "by a second DEFAULT CASE at %L", + &default_case->ext.block.case_list->where, &c->where); + error++; + continue; + } + + default_case = body; + } + } + + if (error > 0) + return; + + /* Transform SELECT TYPE statement to BLOCK and associate selector to + target if present. If there are any EXIT statements referring to the + SELECT TYPE construct, this is no problem because the gfc_code + reference stays the same and EXIT is equally possible from the BLOCK + it is changed to. */ + code->op = EXEC_BLOCK; + if (code->expr2) + { + gfc_association_list* assoc; + + assoc = gfc_get_association_list (); + assoc->st = code->expr1->symtree; + assoc->target = gfc_copy_expr (code->expr2); + assoc->target->where = code->expr2->where; + /* assoc->variable will be set by resolve_assoc_var. */ + + code->ext.block.assoc = assoc; + code->expr1->symtree->n.sym->assoc = assoc; + + resolve_assoc_var (code->expr1->symtree->n.sym, false); + } + else + code->ext.block.assoc = NULL; + + /* Ensure that the selector rank and arrayspec are available to + correct expressions in which they might be missing. */ + if (code->expr2 && code->expr2->rank) + { + rank = code->expr2->rank; + for (ref = code->expr2->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + if (ref && ref->type == REF_ARRAY) + ref = gfc_copy_ref (ref); + + /* Fixup expr1 if necessary. */ + if (rank) + fixup_array_ref (&code->expr1, code->expr2, rank, ref); + } + else if (code->expr1->rank) + { + rank = code->expr1->rank; + for (ref = code->expr1->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + if (ref && ref->type == REF_ARRAY) + ref = gfc_copy_ref (ref); + } + + /* Add EXEC_SELECT to switch on type. */ + new_st = gfc_get_code (code->op); + new_st->expr1 = code->expr1; + new_st->expr2 = code->expr2; + new_st->block = code->block; + code->expr1 = code->expr2 = NULL; + code->block = NULL; + if (!ns->code) + ns->code = new_st; + else + ns->code->next = new_st; + code = new_st; + code->op = EXEC_SELECT_TYPE; + + /* Use the intrinsic LOC function to generate an integer expression + for the vtable of the selector. Note that the rank of the selector + expression has to be set to zero. */ + gfc_add_vptr_component (code->expr1); + code->expr1->rank = 0; + code->expr1 = build_loc_call (code->expr1); + selector_expr = code->expr1->value.function.actual->expr; + + /* Loop over TYPE IS / CLASS IS cases. */ + for (body = code->block; body; body = body->block) + { + gfc_symbol *vtab; + gfc_expr *e; + c = body->ext.block.case_list; + + /* Generate an index integer expression for address of the + TYPE/CLASS vtable and store it in c->low. The hash expression + is stored in c->high and is used to resolve intrinsic cases. */ + if (c->ts.type != BT_UNKNOWN) + { + if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + { + vtab = gfc_find_derived_vtab (c->ts.u.derived); + gcc_assert (vtab); + c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL, + c->ts.u.derived->hash_value); + } + else + { + vtab = gfc_find_vtab (&c->ts); + gcc_assert (vtab && CLASS_DATA (vtab)->initializer); + e = CLASS_DATA (vtab)->initializer; + c->high = gfc_copy_expr (e); + if (c->high->ts.kind != gfc_integer_4_kind) + { + gfc_typespec ts; + ts.kind = gfc_integer_4_kind; + ts.type = BT_INTEGER; + gfc_convert_type_warn (c->high, &ts, 2, 0); + } + } + + e = gfc_lval_expr_from_sym (vtab); + c->low = build_loc_call (e); + } + else + continue; + + /* Associate temporary to selector. This should only be done + when this case is actually true, so build a new ASSOCIATE + that does precisely this here (instead of using the + 'global' one). */ + + if (c->ts.type == BT_CLASS) + sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); + else if (c->ts.type == BT_DERIVED) + sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); + else if (c->ts.type == BT_CHARACTER) + { + HOST_WIDE_INT charlen = 0; + if (c->ts.u.cl && c->ts.u.cl->length + && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) + charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); + snprintf (name, sizeof (name), + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (c->ts.type), charlen, c->ts.kind); + } + else + sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), + c->ts.kind); + + st = gfc_find_symtree (ns->sym_root, name); + gcc_assert (st->n.sym->assoc); + st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); + st->n.sym->assoc->target->where = selector_expr->where; + if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) + { + gfc_add_data_component (st->n.sym->assoc->target); + /* Fixup the target expression if necessary. */ + if (rank) + fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref); + } + + new_st = gfc_get_code (EXEC_BLOCK); + new_st->ext.block.ns = gfc_build_block_ns (ns); + new_st->ext.block.ns->code = body->next; + body->next = new_st; + + /* Chain in the new list only if it is marked as dangling. Otherwise + there is a CASE label overlap and this is already used. Just ignore, + the error is diagnosed elsewhere. */ + if (st->n.sym->assoc->dangling) + { + new_st->ext.block.assoc = st->n.sym->assoc; + st->n.sym->assoc->dangling = 0; + } + + resolve_assoc_var (st->n.sym, false); + } + + /* Take out CLASS IS cases for separate treatment. */ + body = code; + while (body && body->block) + { + if (body->block->ext.block.case_list->ts.type == BT_CLASS) + { + /* Add to class_is list. */ + if (class_is == NULL) + { + class_is = body->block; + tail = class_is; + } + else + { + for (tail = class_is; tail->block; tail = tail->block) ; + tail->block = body->block; + tail = tail->block; + } + /* Remove from EXEC_SELECT list. */ + body->block = body->block->block; + tail->block = NULL; + } + else + body = body->block; + } + + if (class_is) + { + gfc_symbol *vtab; + + if (!default_case) + { + /* Add a default case to hold the CLASS IS cases. */ + for (tail = code; tail->block; tail = tail->block) ; + tail->block = gfc_get_code (EXEC_SELECT_TYPE); + tail = tail->block; + tail->ext.block.case_list = gfc_get_case (); + tail->ext.block.case_list->ts.type = BT_UNKNOWN; + tail->next = NULL; + default_case = tail; + } + + /* More than one CLASS IS block? */ + if (class_is->block) + { + gfc_code **c1,*c2; + bool swapped; + /* Sort CLASS IS blocks by extension level. */ + do + { + swapped = false; + for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) + { + c2 = (*c1)->block; + /* F03:C817 (check for doubles). */ + if ((*c1)->ext.block.case_list->ts.u.derived->hash_value + == c2->ext.block.case_list->ts.u.derived->hash_value) + { + gfc_error ("Double CLASS IS block in SELECT TYPE " + "statement at %L", + &c2->ext.block.case_list->where); + return; + } + if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension + < c2->ext.block.case_list->ts.u.derived->attr.extension) + { + /* Swap. */ + (*c1)->block = c2->block; + c2->block = *c1; + *c1 = c2; + swapped = true; + } + } + } + while (swapped); + } + + /* Generate IF chain. */ + if_st = gfc_get_code (EXEC_IF); + new_st = if_st; + for (body = class_is; body; body = body->block) + { + new_st->block = gfc_get_code (EXEC_IF); + new_st = new_st->block; + /* Set up IF condition: Call _gfortran_is_extension_of. */ + new_st->expr1 = gfc_get_expr (); + new_st->expr1->expr_type = EXPR_FUNCTION; + new_st->expr1->ts.type = BT_LOGICAL; + new_st->expr1->ts.kind = 4; + new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); + new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym); + new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF; + /* Set up arguments. */ + new_st->expr1->value.function.actual = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree); + new_st->expr1->value.function.actual->expr->where = code->loc; + new_st->expr1->where = code->loc; + gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); + vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); + st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); + new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); + new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); + new_st->expr1->value.function.actual->next->expr->where = code->loc; + /* Set up types in formal arg list. */ + new_st->expr1->value.function.isym->formal = XCNEW (gfc_intrinsic_arg); + new_st->expr1->value.function.isym->formal->ts = new_st->expr1->value.function.actual->expr->ts; + new_st->expr1->value.function.isym->formal->next = XCNEW (gfc_intrinsic_arg); + new_st->expr1->value.function.isym->formal->next->ts = new_st->expr1->value.function.actual->next->expr->ts; + + new_st->next = body->next; + } + if (default_case->next) + { + new_st->block = gfc_get_code (EXEC_IF); + new_st = new_st->block; + new_st->next = default_case->next; + } + + /* Replace CLASS DEFAULT code by the IF chain. */ + default_case->next = if_st; + } + + /* Resolve the internal code. This cannot be done earlier because + it requires that the sym->assoc of selectors is set already. */ + gfc_current_ns = ns; + gfc_resolve_blocks (code->block, gfc_current_ns); + gfc_current_ns = old_ns; + + if (ref) + free (ref); +} + + +/* Resolve a SELECT RANK statement. */ + +static void +resolve_select_rank (gfc_code *code, gfc_namespace *old_ns) +{ + gfc_namespace *ns; + gfc_code *body, *new_st, *tail; + gfc_case *c; + char tname[GFC_MAX_SYMBOL_LEN + 7]; + char name[2 * GFC_MAX_SYMBOL_LEN]; + gfc_symtree *st; + gfc_expr *selector_expr = NULL; + int case_value; + HOST_WIDE_INT charlen = 0; + + ns = code->ext.block.ns; + gfc_resolve (ns); + + code->op = EXEC_BLOCK; + if (code->expr2) + { + gfc_association_list* assoc; + + assoc = gfc_get_association_list (); + assoc->st = code->expr1->symtree; + assoc->target = gfc_copy_expr (code->expr2); + assoc->target->where = code->expr2->where; + /* assoc->variable will be set by resolve_assoc_var. */ + + code->ext.block.assoc = assoc; + code->expr1->symtree->n.sym->assoc = assoc; + + resolve_assoc_var (code->expr1->symtree->n.sym, false); + } + else + code->ext.block.assoc = NULL; + + /* Loop over RANK cases. Note that returning on the errors causes a + cascade of further errors because the case blocks do not compile + correctly. */ + for (body = code->block; body; body = body->block) + { + c = body->ext.block.case_list; + if (c->low) + case_value = (int) mpz_get_si (c->low->value.integer); + else + case_value = -2; + + /* Check for repeated cases. */ + for (tail = code->block; tail; tail = tail->block) + { + gfc_case *d = tail->ext.block.case_list; + int case_value2; + + if (tail == body) + break; + + /* Check F2018: C1153. */ + if (!c->low && !d->low) + gfc_error ("RANK DEFAULT at %L is repeated at %L", + &c->where, &d->where); + + if (!c->low || !d->low) + continue; + + /* Check F2018: C1153. */ + case_value2 = (int) mpz_get_si (d->low->value.integer); + if ((case_value == case_value2) && case_value == -1) + gfc_error ("RANK (*) at %L is repeated at %L", + &c->where, &d->where); + else if (case_value == case_value2) + gfc_error ("RANK (%i) at %L is repeated at %L", + case_value, &c->where, &d->where); + } + + if (!c->low) + continue; + + /* Check F2018: C1155. */ + if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable + || gfc_expr_attr (code->expr1).pointer)) + gfc_error ("RANK (*) at %L cannot be used with the pointer or " + "allocatable selector at %L", &c->where, &code->expr1->where); + + if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable + || gfc_expr_attr (code->expr1).pointer)) + gfc_error ("RANK (*) at %L cannot be used with the pointer or " + "allocatable selector at %L", &c->where, &code->expr1->where); + } + + /* Add EXEC_SELECT to switch on rank. */ + new_st = gfc_get_code (code->op); + new_st->expr1 = code->expr1; + new_st->expr2 = code->expr2; + new_st->block = code->block; + code->expr1 = code->expr2 = NULL; + code->block = NULL; + if (!ns->code) + ns->code = new_st; + else + ns->code->next = new_st; + code = new_st; + code->op = EXEC_SELECT_RANK; + + selector_expr = code->expr1; + + /* Loop over SELECT RANK cases. */ + for (body = code->block; body; body = body->block) + { + c = body->ext.block.case_list; + int case_value; + + /* Pass on the default case. */ + if (c->low == NULL) + continue; + + /* Associate temporary to selector. This should only be done + when this case is actually true, so build a new ASSOCIATE + that does precisely this here (instead of using the + 'global' one). */ + if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length + && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) + charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); + + if (c->ts.type == BT_CLASS) + sprintf (tname, "class_%s", c->ts.u.derived->name); + else if (c->ts.type == BT_DERIVED) + sprintf (tname, "type_%s", c->ts.u.derived->name); + else if (c->ts.type != BT_CHARACTER) + sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind); + else + sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (c->ts.type), charlen, c->ts.kind); + + case_value = (int) mpz_get_si (c->low->value.integer); + if (case_value >= 0) + sprintf (name, "__tmp_%s_rank_%d", tname, case_value); + else + sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value); + + st = gfc_find_symtree (ns->sym_root, name); + gcc_assert (st->n.sym->assoc); + + st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); + st->n.sym->assoc->target->where = selector_expr->where; + + new_st = gfc_get_code (EXEC_BLOCK); + new_st->ext.block.ns = gfc_build_block_ns (ns); + new_st->ext.block.ns->code = body->next; + body->next = new_st; + + /* Chain in the new list only if it is marked as dangling. Otherwise + there is a CASE label overlap and this is already used. Just ignore, + the error is diagnosed elsewhere. */ + if (st->n.sym->assoc->dangling) + { + new_st->ext.block.assoc = st->n.sym->assoc; + st->n.sym->assoc->dangling = 0; + } + + resolve_assoc_var (st->n.sym, false); + } + + gfc_current_ns = ns; + gfc_resolve_blocks (code->block, gfc_current_ns); + gfc_current_ns = old_ns; +} + + +/* Resolve a transfer statement. This is making sure that: + -- a derived type being transferred has only non-pointer components + -- a derived type being transferred doesn't have private components, unless + it's being transferred from the module where the type was defined + -- we're not trying to transfer a whole assumed size array. */ + +static void +resolve_transfer (gfc_code *code) +{ + gfc_symbol *sym, *derived; + gfc_ref *ref; + gfc_expr *exp; + bool write = false; + bool formatted = false; + gfc_dt *dt = code->ext.dt; + gfc_symbol *dtio_sub = NULL; + + exp = code->expr1; + + while (exp != NULL && exp->expr_type == EXPR_OP + && exp->value.op.op == INTRINSIC_PARENTHESES) + exp = exp->value.op.op1; + + if (exp && exp->expr_type == EXPR_NULL + && code->ext.dt) + { + gfc_error ("Invalid context for NULL () intrinsic at %L", + &exp->where); + return; + } + + if (exp == NULL || (exp->expr_type != EXPR_VARIABLE + && exp->expr_type != EXPR_FUNCTION + && exp->expr_type != EXPR_STRUCTURE)) + return; + + /* If we are reading, the variable will be changed. Note that + code->ext.dt may be NULL if the TRANSFER is related to + an INQUIRE statement -- but in this case, we are not reading, either. */ + if (dt && dt->dt_io_kind->value.iokind == M_READ + && !gfc_check_vardef_context (exp, false, false, false, + _("item in READ"))) + return; + + const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE + || exp->expr_type == EXPR_FUNCTION + ? &exp->ts : &exp->symtree->n.sym->ts; + + /* Go to actual component transferred. */ + for (ref = exp->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + ts = &ref->u.c.component->ts; + + if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE + && (ts->type == BT_DERIVED || ts->type == BT_CLASS)) + { + derived = ts->u.derived; + + /* Determine when to use the formatted DTIO procedure. */ + if (dt && (dt->format_expr || dt->format_label)) + formatted = true; + + write = dt->dt_io_kind->value.iokind == M_WRITE + || dt->dt_io_kind->value.iokind == M_PRINT; + dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted); + + if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE) + { + dt->udtio = exp; + sym = exp->symtree->n.sym->ns->proc_name; + /* Check to see if this is a nested DTIO call, with the + dummy as the io-list object. */ + if (sym && sym == dtio_sub && sym->formal + && sym->formal->sym == exp->symtree->n.sym + && exp->ref == NULL) + { + if (!sym->attr.recursive) + { + gfc_error ("DTIO %s procedure at %L must be recursive", + sym->name, &sym->declared_at); + return; + } + } + } + } + + if (ts->type == BT_CLASS && dtio_sub == NULL) + { + gfc_error ("Data transfer element at %L cannot be polymorphic unless " + "it is processed by a defined input/output procedure", + &code->loc); + return; + } + + if (ts->type == BT_DERIVED) + { + /* Check that transferred derived type doesn't contain POINTER + components unless it is processed by a defined input/output + procedure". */ + if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL) + { + gfc_error ("Data transfer element at %L cannot have POINTER " + "components unless it is processed by a defined " + "input/output procedure", &code->loc); + return; + } + + /* F08:C935. */ + if (ts->u.derived->attr.proc_pointer_comp) + { + gfc_error ("Data transfer element at %L cannot have " + "procedure pointer components", &code->loc); + return; + } + + if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL) + { + gfc_error ("Data transfer element at %L cannot have ALLOCATABLE " + "components unless it is processed by a defined " + "input/output procedure", &code->loc); + return; + } + + /* C_PTR and C_FUNPTR have private components which means they cannot + be printed. However, if -std=gnu and not -pedantic, allow + the component to be printed to help debugging. */ + if (ts->u.derived->ts.f90_type == BT_VOID) + { + if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L " + "cannot have PRIVATE components", &code->loc)) + return; + } + else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL) + { + gfc_error ("Data transfer element at %L cannot have " + "PRIVATE components unless it is processed by " + "a defined input/output procedure", &code->loc); + return; + } + } + + if (exp->expr_type == EXPR_STRUCTURE) + return; + + sym = exp->symtree->n.sym; + + if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref + && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL) + { + gfc_error ("Data transfer element at %L cannot be a full reference to " + "an assumed-size array", &code->loc); + return; + } +} + + +/*********** Toplevel code resolution subroutines ***********/ + +/* Find the set of labels that are reachable from this block. We also + record the last statement in each block. */ + +static void +find_reachable_labels (gfc_code *block) +{ + gfc_code *c; + + if (!block) + return; + + cs_base->reachable_labels = bitmap_alloc (&labels_obstack); + + /* Collect labels in this block. We don't keep those corresponding + to END {IF|SELECT}, these are checked in resolve_branch by going + up through the code_stack. */ + for (c = block; c; c = c->next) + { + if (c->here && c->op != EXEC_END_NESTED_BLOCK) + bitmap_set_bit (cs_base->reachable_labels, c->here->value); + } + + /* Merge with labels from parent block. */ + if (cs_base->prev) + { + gcc_assert (cs_base->prev->reachable_labels); + bitmap_ior_into (cs_base->reachable_labels, + cs_base->prev->reachable_labels); + } +} + + +static void +resolve_lock_unlock_event (gfc_code *code) +{ + if (code->expr1->expr_type == EXPR_FUNCTION + && code->expr1->value.function.isym + && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) + remove_caf_get_intrinsic (code->expr1); + + if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK) + && (code->expr1->ts.type != BT_DERIVED + || code->expr1->expr_type != EXPR_VARIABLE + || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE + || code->expr1->rank != 0 + || (!gfc_is_coarray (code->expr1) && + !gfc_is_coindexed (code->expr1)))) + gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", + &code->expr1->where); + else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT) + && (code->expr1->ts.type != BT_DERIVED + || code->expr1->expr_type != EXPR_VARIABLE + || code->expr1->ts.u.derived->from_intmod + != INTMOD_ISO_FORTRAN_ENV + || code->expr1->ts.u.derived->intmod_sym_id + != ISOFORTRAN_EVENT_TYPE + || code->expr1->rank != 0)) + gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE", + &code->expr1->where); + else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1) + && !gfc_is_coindexed (code->expr1)) + gfc_error ("Event variable argument at %L must be a coarray or coindexed", + &code->expr1->where); + else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1)) + gfc_error ("Event variable argument at %L must be a coarray but not " + "coindexed", &code->expr1->where); + + /* Check STAT. */ + if (code->expr2 + && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE)) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + + if (code->expr2 + && !gfc_check_vardef_context (code->expr2, false, false, false, + _("STAT variable"))) + return; + + /* Check ERRMSG. */ + if (code->expr3 + && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 + || code->expr3->expr_type != EXPR_VARIABLE)) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); + + if (code->expr3 + && !gfc_check_vardef_context (code->expr3, false, false, false, + _("ERRMSG variable"))) + return; + + /* Check for LOCK the ACQUIRED_LOCK. */ + if (code->op != EXEC_EVENT_WAIT && code->expr4 + && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0 + || code->expr4->expr_type != EXPR_VARIABLE)) + gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL " + "variable", &code->expr4->where); + + if (code->op != EXEC_EVENT_WAIT && code->expr4 + && !gfc_check_vardef_context (code->expr4, false, false, false, + _("ACQUIRED_LOCK variable"))) + return; + + /* Check for EVENT WAIT the UNTIL_COUNT. */ + if (code->op == EXEC_EVENT_WAIT && code->expr4) + { + if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER + || code->expr4->rank != 0) + gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER " + "expression", &code->expr4->where); + } +} + + +static void +resolve_critical (gfc_code *code) +{ + gfc_symtree *symtree; + gfc_symbol *lock_type; + char name[GFC_MAX_SYMBOL_LEN]; + static int serial = 0; + + if (flag_coarray != GFC_FCOARRAY_LIB) + return; + + symtree = gfc_find_symtree (gfc_current_ns->sym_root, + GFC_PREFIX ("lock_type")); + if (symtree) + lock_type = symtree->n.sym; + else + { + if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree, + false) != 0) + gcc_unreachable (); + lock_type = symtree->n.sym; + lock_type->attr.flavor = FL_DERIVED; + lock_type->attr.zero_comp = 1; + lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV; + lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE; + } + + sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++); + if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0) + gcc_unreachable (); + + code->resolved_sym = symtree->n.sym; + symtree->n.sym->attr.flavor = FL_VARIABLE; + symtree->n.sym->attr.referenced = 1; + symtree->n.sym->attr.artificial = 1; + symtree->n.sym->attr.codimension = 1; + symtree->n.sym->ts.type = BT_DERIVED; + symtree->n.sym->ts.u.derived = lock_type; + symtree->n.sym->as = gfc_get_array_spec (); + symtree->n.sym->as->corank = 1; + symtree->n.sym->as->type = AS_EXPLICIT; + symtree->n.sym->as->cotype = AS_EXPLICIT; + symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, 1); + gfc_commit_symbols(); +} + + +static void +resolve_sync (gfc_code *code) +{ + /* Check imageset. The * case matches expr1 == NULL. */ + if (code->expr1) + { + if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1) + gfc_error ("Imageset argument at %L must be a scalar or rank-1 " + "INTEGER expression", &code->expr1->where); + if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0 + && mpz_cmp_si (code->expr1->value.integer, 1) < 0) + gfc_error ("Imageset argument at %L must between 1 and num_images()", + &code->expr1->where); + else if (code->expr1->expr_type == EXPR_ARRAY + && gfc_simplify_expr (code->expr1, 0)) + { + gfc_constructor *cons; + cons = gfc_constructor_first (code->expr1->value.constructor); + for (; cons; cons = gfc_constructor_next (cons)) + if (cons->expr->expr_type == EXPR_CONSTANT + && mpz_cmp_si (cons->expr->value.integer, 1) < 0) + gfc_error ("Imageset argument at %L must between 1 and " + "num_images()", &cons->expr->where); + } + } + + /* Check STAT. */ + gfc_resolve_expr (code->expr2); + if (code->expr2) + { + if (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + else + gfc_check_vardef_context (code->expr2, false, false, false, + _("STAT variable")); + } + + /* Check ERRMSG. */ + gfc_resolve_expr (code->expr3); + if (code->expr3) + { + if (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); + else + gfc_check_vardef_context (code->expr3, false, false, false, + _("ERRMSG variable")); + } +} + + +/* Given a branch to a label, see if the branch is conforming. + The code node describes where the branch is located. */ + +static void +resolve_branch (gfc_st_label *label, gfc_code *code) +{ + code_stack *stack; + + if (label == NULL) + return; + + /* Step one: is this a valid branching target? */ + + if (label->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("Label %d referenced at %L is never defined", label->value, + &code->loc); + return; + } + + if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) + { + gfc_error ("Statement at %L is not a valid branch target statement " + "for the branch statement at %L", &label->where, &code->loc); + return; + } + + /* Step two: make sure this branch is not a branch to itself ;-) */ + + if (code->here == label) + { + gfc_warning (0, + "Branch at %L may result in an infinite loop", &code->loc); + return; + } + + /* Step three: See if the label is in the same block as the + branching statement. The hard work has been done by setting up + the bitmap reachable_labels. */ + + if (bitmap_bit_p (cs_base->reachable_labels, label->value)) + { + /* Check now whether there is a CRITICAL construct; if so, check + whether the label is still visible outside of the CRITICAL block, + which is invalid. */ + for (stack = cs_base; stack; stack = stack->prev) + { + if (stack->current->op == EXEC_CRITICAL + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CRITICAL construct for " + "label at %L", &code->loc, &label->where); + else if (stack->current->op == EXEC_DO_CONCURRENT + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " + "for label at %L", &code->loc, &label->where); + } + + return; + } + + /* Step four: If we haven't found the label in the bitmap, it may + still be the label of the END of the enclosing block, in which + case we find it by going up the code_stack. */ + + for (stack = cs_base; stack; stack = stack->prev) + { + if (stack->current->next && stack->current->next->here == label) + break; + if (stack->current->op == EXEC_CRITICAL) + { + /* Note: A label at END CRITICAL does not leave the CRITICAL + construct as END CRITICAL is still part of it. */ + gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" + " at %L", &code->loc, &label->where); + return; + } + else if (stack->current->op == EXEC_DO_CONCURRENT) + { + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " + "label at %L", &code->loc, &label->where); + return; + } + } + + if (stack) + { + gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK); + return; + } + + /* The label is not in an enclosing block, so illegal. This was + allowed in Fortran 66, so we allow it as extension. No + further checks are necessary in this case. */ + gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block " + "as the GOTO statement at %L", &label->where, + &code->loc); + return; +} + + +/* Check whether EXPR1 has the same shape as EXPR2. */ + +static bool +resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) +{ + mpz_t shape[GFC_MAX_DIMENSIONS]; + mpz_t shape2[GFC_MAX_DIMENSIONS]; + bool result = false; + int i; + + /* Compare the rank. */ + if (expr1->rank != expr2->rank) + return result; + + /* Compare the size of each dimension. */ + for (i=0; irank; i++) + { + if (!gfc_array_dimen_size (expr1, i, &shape[i])) + goto ignore; + + if (!gfc_array_dimen_size (expr2, i, &shape2[i])) + goto ignore; + + if (mpz_cmp (shape[i], shape2[i])) + goto over; + } + + /* When either of the two expression is an assumed size array, we + ignore the comparison of dimension sizes. */ +ignore: + result = true; + +over: + gfc_clear_shape (shape, i); + gfc_clear_shape (shape2, i); + return result; +} + + +/* Check whether a WHERE assignment target or a WHERE mask expression + has the same shape as the outmost WHERE mask expression. */ + +static void +resolve_where (gfc_code *code, gfc_expr *mask) +{ + gfc_code *cblock; + gfc_code *cnext; + gfc_expr *e = NULL; + + cblock = code->block; + + /* Store the first WHERE mask-expr of the WHERE statement or construct. + In case of nested WHERE, only the outmost one is stored. */ + if (mask == NULL) /* outmost WHERE */ + e = cblock->expr1; + else /* inner WHERE */ + e = mask; + + while (cblock) + { + if (cblock->expr1) + { + /* Check if the mask-expr has a consistent shape with the + outmost WHERE mask-expr. */ + if (!resolve_where_shape (cblock->expr1, e)) + gfc_error ("WHERE mask at %L has inconsistent shape", + &cblock->expr1->where); + } + + /* the assignment statement of a WHERE statement, or the first + statement in where-body-construct of a WHERE construct */ + cnext = cblock->next; + while (cnext) + { + switch (cnext->op) + { + /* WHERE assignment statement */ + case EXEC_ASSIGN: + + /* Check shape consistent for WHERE assignment target. */ + if (e && !resolve_where_shape (cnext->expr1, e)) + gfc_error ("WHERE assignment target at %L has " + "inconsistent shape", &cnext->expr1->where); + break; + + + case EXEC_ASSIGN_CALL: + resolve_call (cnext); + if (!cnext->resolved_sym->attr.elemental) + gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", + &cnext->ext.actual->expr->where); + break; + + /* WHERE or WHERE construct is part of a where-body-construct */ + case EXEC_WHERE: + resolve_where (cnext, e); + break; + + default: + gfc_error ("Unsupported statement inside WHERE at %L", + &cnext->loc); + } + /* the next statement within the same where-body-construct */ + cnext = cnext->next; + } + /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ + cblock = cblock->block; + } +} + + +/* Resolve assignment in FORALL construct. + NVAR is the number of FORALL index variables, and VAR_EXPR records the + FORALL index variables. */ + +static void +gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) +{ + int n; + + for (n = 0; n < nvar; n++) + { + gfc_symbol *forall_index; + + forall_index = var_expr[n]->symtree->n.sym; + + /* Check whether the assignment target is one of the FORALL index + variable. */ + if ((code->expr1->expr_type == EXPR_VARIABLE) + && (code->expr1->symtree->n.sym == forall_index)) + gfc_error ("Assignment to a FORALL index variable at %L", + &code->expr1->where); + else + { + /* If one of the FORALL index variables doesn't appear in the + assignment variable, then there could be a many-to-one + assignment. Emit a warning rather than an error because the + mask could be resolving this problem. */ + if (!find_forall_index (code->expr1, forall_index, 0)) + gfc_warning (0, "The FORALL with index %qs is not used on the " + "left side of the assignment at %L and so might " + "cause multiple assignment to this object", + var_expr[n]->symtree->name, &code->expr1->where); + } + } +} + + +/* Resolve WHERE statement in FORALL construct. */ + +static void +gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, + gfc_expr **var_expr) +{ + gfc_code *cblock; + gfc_code *cnext; + + cblock = code->block; + while (cblock) + { + /* the assignment statement of a WHERE statement, or the first + statement in where-body-construct of a WHERE construct */ + cnext = cblock->next; + while (cnext) + { + switch (cnext->op) + { + /* WHERE assignment statement */ + case EXEC_ASSIGN: + gfc_resolve_assign_in_forall (cnext, nvar, var_expr); + break; + + /* WHERE operator assignment statement */ + case EXEC_ASSIGN_CALL: + resolve_call (cnext); + if (!cnext->resolved_sym->attr.elemental) + gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", + &cnext->ext.actual->expr->where); + break; + + /* WHERE or WHERE construct is part of a where-body-construct */ + case EXEC_WHERE: + gfc_resolve_where_code_in_forall (cnext, nvar, var_expr); + break; + + default: + gfc_error ("Unsupported statement inside WHERE at %L", + &cnext->loc); + } + /* the next statement within the same where-body-construct */ + cnext = cnext->next; + } + /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ + cblock = cblock->block; + } +} + + +/* Traverse the FORALL body to check whether the following errors exist: + 1. For assignment, check if a many-to-one assignment happens. + 2. For WHERE statement, check the WHERE body to see if there is any + many-to-one assignment. */ + +static void +gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) +{ + gfc_code *c; + + c = code->block->next; + while (c) + { + switch (c->op) + { + case EXEC_ASSIGN: + case EXEC_POINTER_ASSIGN: + gfc_resolve_assign_in_forall (c, nvar, var_expr); + break; + + case EXEC_ASSIGN_CALL: + resolve_call (c); + break; + + /* Because the gfc_resolve_blocks() will handle the nested FORALL, + there is no need to handle it here. */ + case EXEC_FORALL: + break; + case EXEC_WHERE: + gfc_resolve_where_code_in_forall(c, nvar, var_expr); + break; + default: + break; + } + /* The next statement in the FORALL body. */ + c = c->next; + } +} + + +/* Counts the number of iterators needed inside a forall construct, including + nested forall constructs. This is used to allocate the needed memory + in gfc_resolve_forall. */ + +static int +gfc_count_forall_iterators (gfc_code *code) +{ + int max_iters, sub_iters, current_iters; + gfc_forall_iterator *fa; + + gcc_assert(code->op == EXEC_FORALL); + max_iters = 0; + current_iters = 0; + + for (fa = code->ext.forall_iterator; fa; fa = fa->next) + current_iters ++; + + code = code->block->next; + + while (code) + { + if (code->op == EXEC_FORALL) + { + sub_iters = gfc_count_forall_iterators (code); + if (sub_iters > max_iters) + max_iters = sub_iters; + } + code = code->next; + } + + return current_iters + max_iters; +} + + +/* Given a FORALL construct, first resolve the FORALL iterator, then call + gfc_resolve_forall_body to resolve the FORALL body. */ + +static void +gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) +{ + static gfc_expr **var_expr; + static int total_var = 0; + static int nvar = 0; + int i, old_nvar, tmp; + gfc_forall_iterator *fa; + + old_nvar = nvar; + + if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) + return; + + /* Start to resolve a FORALL construct */ + if (forall_save == 0) + { + /* Count the total number of FORALL indices in the nested FORALL + construct in order to allocate the VAR_EXPR with proper size. */ + total_var = gfc_count_forall_iterators (code); + + /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */ + var_expr = XCNEWVEC (gfc_expr *, total_var); + } + + /* The information about FORALL iterator, including FORALL indices start, end + and stride. An outer FORALL indice cannot appear in start, end or stride. */ + for (fa = code->ext.forall_iterator; fa; fa = fa->next) + { + /* Fortran 20008: C738 (R753). */ + if (fa->var->ref && fa->var->ref->type == REF_ARRAY) + { + gfc_error ("FORALL index-name at %L must be a scalar variable " + "of type integer", &fa->var->where); + continue; + } + + /* Check if any outer FORALL index name is the same as the current + one. */ + for (i = 0; i < nvar; i++) + { + if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) + gfc_error ("An outer FORALL construct already has an index " + "with this name %L", &fa->var->where); + } + + /* Record the current FORALL index. */ + var_expr[nvar] = gfc_copy_expr (fa->var); + + nvar++; + + /* No memory leak. */ + gcc_assert (nvar <= total_var); + } + + /* Resolve the FORALL body. */ + gfc_resolve_forall_body (code, nvar, var_expr); + + /* May call gfc_resolve_forall to resolve the inner FORALL loop. */ + gfc_resolve_blocks (code->block, ns); + + tmp = nvar; + nvar = old_nvar; + /* Free only the VAR_EXPRs allocated in this frame. */ + for (i = nvar; i < tmp; i++) + gfc_free_expr (var_expr[i]); + + if (nvar == 0) + { + /* We are in the outermost FORALL construct. */ + gcc_assert (forall_save == 0); + + /* VAR_EXPR is not needed any more. */ + free (var_expr); + total_var = 0; + } +} + + +/* Resolve a BLOCK construct statement. */ + +static void +resolve_block_construct (gfc_code* code) +{ + /* Resolve the BLOCK's namespace. */ + gfc_resolve (code->ext.block.ns); + + /* For an ASSOCIATE block, the associations (and their targets) are already + resolved during resolve_symbol. */ +} + + +/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and + DO code nodes. */ + +void +gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) +{ + bool t; + + for (; b; b = b->block) + { + t = gfc_resolve_expr (b->expr1); + if (!gfc_resolve_expr (b->expr2)) + t = false; + + switch (b->op) + { + case EXEC_IF: + if (t && b->expr1 != NULL + && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &b->expr1->where); + break; + + case EXEC_WHERE: + if (t + && b->expr1 != NULL + && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0)) + gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array", + &b->expr1->where); + break; + + case EXEC_GOTO: + resolve_branch (b->label1, b); + break; + + case EXEC_BLOCK: + resolve_block_construct (b); + break; + + case EXEC_SELECT: + case EXEC_SELECT_TYPE: + case EXEC_SELECT_RANK: + case EXEC_FORALL: + case EXEC_DO: + case EXEC_DO_WHILE: + case EXEC_DO_CONCURRENT: + case EXEC_CRITICAL: + case EXEC_READ: + case EXEC_WRITE: + case EXEC_IOLENGTH: + case EXEC_WAIT: + break; + + case EXEC_OMP_ATOMIC: + case EXEC_OACC_ATOMIC: + { + /* Verify this before calling gfc_resolve_code, which might + change it. */ + gcc_assert (b->op == EXEC_OMP_ATOMIC + || (b->next && b->next->op == EXEC_ASSIGN)); + } + break; + + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_LOOP: + case EXEC_OACC_UPDATE: + case EXEC_OACC_WAIT: + case EXEC_OACC_CACHE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ROUTINE: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SIMD: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKGROUP: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_WORKSHARE: + break; + + default: + gfc_internal_error ("gfc_resolve_blocks(): Bad block type"); + } + + gfc_resolve_code (b->next, ns); + } +} + + +/* Does everything to resolve an ordinary assignment. Returns true + if this is an interface assignment. */ +static bool +resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) +{ + bool rval = false; + gfc_expr *lhs; + gfc_expr *rhs; + int n; + gfc_ref *ref; + symbol_attribute attr; + + if (gfc_extend_assign (code, ns)) + { + gfc_expr** rhsptr; + + if (code->op == EXEC_ASSIGN_CALL) + { + lhs = code->ext.actual->expr; + rhsptr = &code->ext.actual->next->expr; + } + else + { + gfc_actual_arglist* args; + gfc_typebound_proc* tbp; + + gcc_assert (code->op == EXEC_COMPCALL); + + args = code->expr1->value.compcall.actual; + lhs = args->expr; + rhsptr = &args->next->expr; + + tbp = code->expr1->value.compcall.tbp; + gcc_assert (!tbp->is_generic); + } + + /* Make a temporary rhs when there is a default initializer + and rhs is the same symbol as the lhs. */ + if ((*rhsptr)->expr_type == EXPR_VARIABLE + && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED + && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) + && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) + *rhsptr = gfc_get_parentheses (*rhsptr); + + return true; + } + + lhs = code->expr1; + rhs = code->expr2; + + if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) + && rhs->ts.type == BT_CHARACTER + && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) + { + /* Use of -fdec-char-conversions allows assignment of character data + to non-character variables. This not permited for nonconstant + strings. */ + gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs), + gfc_typename (lhs), &rhs->where); + return false; + } + + /* Handle the case of a BOZ literal on the RHS. */ + if (rhs->ts.type == BT_BOZ) + { + if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA " + "statement value nor an actual argument of " + "INT/REAL/DBLE/CMPLX intrinsic subprogram", + &rhs->where)) + return false; + + switch (lhs->ts.type) + { + case BT_INTEGER: + if (!gfc_boz2int (rhs, lhs->ts.kind)) + return false; + break; + case BT_REAL: + if (!gfc_boz2real (rhs, lhs->ts.kind)) + return false; + break; + default: + gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where); + return false; + } + } + + if (lhs->ts.type == BT_CHARACTER && warn_character_truncation) + { + HOST_WIDE_INT llen = 0, rlen = 0; + if (lhs->ts.u.cl != NULL + && lhs->ts.u.cl->length != NULL + && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) + llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer); + + if (rhs->expr_type == EXPR_CONSTANT) + rlen = rhs->value.character.length; + + else if (rhs->ts.u.cl != NULL + && rhs->ts.u.cl->length != NULL + && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) + rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer); + + if (rlen && llen && rlen > llen) + gfc_warning_now (OPT_Wcharacter_truncation, + "CHARACTER expression will be truncated " + "in assignment (%ld/%ld) at %L", + (long) llen, (long) rlen, &code->loc); + } + + /* Ensure that a vector index expression for the lvalue is evaluated + to a temporary if the lvalue symbol is referenced in it. */ + if (lhs->rank) + { + for (ref = lhs->ref; ref; ref= ref->next) + if (ref->type == REF_ARRAY) + { + for (n = 0; n < ref->u.ar.dimen; n++) + if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR + && gfc_find_sym_in_expr (lhs->symtree->n.sym, + ref->u.ar.start[n])) + ref->u.ar.start[n] + = gfc_get_parentheses (ref->u.ar.start[n]); + } + } + + if (gfc_pure (NULL)) + { + if (lhs->ts.type == BT_DERIVED + && lhs->expr_type == EXPR_VARIABLE + && lhs->ts.u.derived->attr.pointer_comp + && rhs->expr_type == EXPR_VARIABLE + && (gfc_impure_variable (rhs->symtree->n.sym) + || gfc_is_coindexed (rhs))) + { + /* F2008, C1283. */ + if (gfc_is_coindexed (rhs)) + gfc_error ("Coindexed expression at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure", + &rhs->where); + else + /* F2008, C1283 (4). */ + gfc_error ("In a pure subprogram an INTENT(IN) dummy argument " + "shall not be used as the expr at %L of an intrinsic " + "assignment statement in which the variable is of a " + "derived type if the derived type has a pointer " + "component at any level of component selection.", + &rhs->where); + return rval; + } + + /* Fortran 2008, C1283. */ + if (gfc_is_coindexed (lhs)) + { + gfc_error ("Assignment to coindexed variable at %L in a PURE " + "procedure", &rhs->where); + return rval; + } + } + + if (gfc_implicit_pure (NULL)) + { + if (lhs->expr_type == EXPR_VARIABLE + && lhs->symtree->n.sym != gfc_current_ns->proc_name + && lhs->symtree->n.sym->ns != gfc_current_ns) + gfc_unset_implicit_pure (NULL); + + if (lhs->ts.type == BT_DERIVED + && lhs->expr_type == EXPR_VARIABLE + && lhs->ts.u.derived->attr.pointer_comp + && rhs->expr_type == EXPR_VARIABLE + && (gfc_impure_variable (rhs->symtree->n.sym) + || gfc_is_coindexed (rhs))) + gfc_unset_implicit_pure (NULL); + + /* Fortran 2008, C1283. */ + if (gfc_is_coindexed (lhs)) + gfc_unset_implicit_pure (NULL); + } + + /* F2008, 7.2.1.2. */ + attr = gfc_expr_attr (lhs); + if (lhs->ts.type == BT_CLASS && attr.allocatable) + { + if (attr.codimension) + { + gfc_error ("Assignment to polymorphic coarray at %L is not " + "permitted", &lhs->where); + return false; + } + if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable " + "polymorphic variable at %L", &lhs->where)) + return false; + if (!flag_realloc_lhs) + { + gfc_error ("Assignment to an allocatable polymorphic variable at %L " + "requires %<-frealloc-lhs%>", &lhs->where); + return false; + } + } + else if (lhs->ts.type == BT_CLASS) + { + gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic " + "assignment at %L - check that there is a matching specific " + "subroutine for '=' operator", &lhs->where); + return false; + } + + bool lhs_coindexed = gfc_is_coindexed (lhs); + + /* F2008, Section 7.2.1.2. */ + if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs)) + { + gfc_error ("Coindexed variable must not have an allocatable ultimate " + "component in assignment at %L", &lhs->where); + return false; + } + + /* Assign the 'data' of a class object to a derived type. */ + if (lhs->ts.type == BT_DERIVED + && rhs->ts.type == BT_CLASS + && rhs->expr_type != EXPR_ARRAY) + gfc_add_data_component (rhs); + + /* Make sure there is a vtable and, in particular, a _copy for the + rhs type. */ + if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS) + gfc_find_vtab (&rhs->ts); + + bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB + && (lhs_coindexed + || (code->expr2->expr_type == EXPR_FUNCTION + && code->expr2->value.function.isym + && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET + && (code->expr1->rank == 0 || code->expr2->rank != 0) + && !gfc_expr_attr (rhs).allocatable + && !gfc_has_vector_subscript (rhs))); + + gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send); + + /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable. + Additionally, insert this code when the RHS is a CAF as we then use the + GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if + the LHS is (re)allocatable or has a vector subscript. If the LHS is a + noncoindexed array and the RHS is a coindexed scalar, use the normal code + path. */ + if (caf_convert_to_send) + { + if (code->expr2->expr_type == EXPR_FUNCTION + && code->expr2->value.function.isym + && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET) + remove_caf_get_intrinsic (code->expr2); + code->op = EXEC_CALL; + gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true); + code->resolved_sym = code->symtree->n.sym; + code->resolved_sym->attr.flavor = FL_PROCEDURE; + code->resolved_sym->attr.intrinsic = 1; + code->resolved_sym->attr.subroutine = 1; + code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); + gfc_commit_symbol (code->resolved_sym); + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = lhs; + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = rhs; + code->expr1 = NULL; + code->expr2 = NULL; + } + + return false; +} + + +/* Add a component reference onto an expression. */ + +static void +add_comp_ref (gfc_expr *e, gfc_component *c) +{ + gfc_ref **ref; + ref = &(e->ref); + while (*ref) + ref = &((*ref)->next); + *ref = gfc_get_ref (); + (*ref)->type = REF_COMPONENT; + (*ref)->u.c.sym = e->ts.u.derived; + (*ref)->u.c.component = c; + e->ts = c->ts; + + /* Add a full array ref, as necessary. */ + if (c->as) + { + gfc_add_full_array_ref (e, c->as); + e->rank = c->as->rank; + } +} + + +/* Build an assignment. Keep the argument 'op' for future use, so that + pointer assignments can be made. */ + +static gfc_code * +build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, + gfc_component *comp1, gfc_component *comp2, locus loc) +{ + gfc_code *this_code; + + this_code = gfc_get_code (op); + this_code->next = NULL; + this_code->expr1 = gfc_copy_expr (expr1); + this_code->expr2 = gfc_copy_expr (expr2); + this_code->loc = loc; + if (comp1 && comp2) + { + add_comp_ref (this_code->expr1, comp1); + add_comp_ref (this_code->expr2, comp2); + } + + return this_code; +} + + +/* Makes a temporary variable expression based on the characteristics of + a given variable expression. */ + +static gfc_expr* +get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) +{ + static int serial = 0; + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + gfc_array_spec *as; + gfc_array_ref *aref; + gfc_ref *ref; + + sprintf (name, GFC_PREFIX("DA%d"), serial++); + gfc_get_sym_tree (name, ns, &tmp, false); + gfc_add_type (tmp->n.sym, &e->ts, NULL); + + if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER) + tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, + e->value.character.length); + + as = NULL; + ref = NULL; + aref = NULL; + + /* Obtain the arrayspec for the temporary. */ + if (e->rank && e->expr_type != EXPR_ARRAY + && e->expr_type != EXPR_FUNCTION + && e->expr_type != EXPR_OP) + { + aref = gfc_find_array_ref (e); + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->as == aref->as) + as = aref->as; + else + { + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && ref->u.c.component->as == aref->as) + { + as = aref->as; + break; + } + } + } + + /* Add the attributes and the arrayspec to the temporary. */ + tmp->n.sym->attr = gfc_expr_attr (e); + tmp->n.sym->attr.function = 0; + tmp->n.sym->attr.proc_pointer = 0; + tmp->n.sym->attr.result = 0; + tmp->n.sym->attr.flavor = FL_VARIABLE; + tmp->n.sym->attr.dummy = 0; + tmp->n.sym->attr.use_assoc = 0; + tmp->n.sym->attr.intent = INTENT_UNKNOWN; + + if (as) + { + tmp->n.sym->as = gfc_copy_array_spec (as); + if (!ref) + ref = e->ref; + if (as->type == AS_DEFERRED) + tmp->n.sym->attr.allocatable = 1; + } + else if (e->rank && (e->expr_type == EXPR_ARRAY + || e->expr_type == EXPR_FUNCTION + || e->expr_type == EXPR_OP)) + { + tmp->n.sym->as = gfc_get_array_spec (); + tmp->n.sym->as->type = AS_DEFERRED; + tmp->n.sym->as->rank = e->rank; + tmp->n.sym->attr.allocatable = 1; + tmp->n.sym->attr.dimension = 1; + } + else + tmp->n.sym->attr.dimension = 0; + + gfc_set_sym_referenced (tmp->n.sym); + gfc_commit_symbol (tmp->n.sym); + e = gfc_lval_expr_from_sym (tmp->n.sym); + + /* Should the lhs be a section, use its array ref for the + temporary expression. */ + if (aref && aref->type != AR_FULL) + { + gfc_free_ref_list (e->ref); + e->ref = gfc_copy_ref (ref); + } + return e; +} + + +/* Add one line of code to the code chain, making sure that 'head' and + 'tail' are appropriately updated. */ + +static void +add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail) +{ + gcc_assert (this_code); + if (*head == NULL) + *head = *tail = *this_code; + else + *tail = gfc_append_code (*tail, *this_code); + *this_code = NULL; +} + + +/* Counts the potential number of part array references that would + result from resolution of typebound defined assignments. */ + +static int +nonscalar_typebound_assign (gfc_symbol *derived, int depth) +{ + gfc_component *c; + int c_depth = 0, t_depth; + + for (c= derived->components; c; c = c->next) + { + if ((!gfc_bt_struct (c->ts.type) + || c->attr.pointer + || c->attr.allocatable + || c->attr.proc_pointer_comp + || c->attr.class_pointer + || c->attr.proc_pointer) + && !c->attr.defined_assign_comp) + continue; + + if (c->as && c_depth == 0) + c_depth = 1; + + if (c->ts.u.derived->attr.defined_assign_comp) + t_depth = nonscalar_typebound_assign (c->ts.u.derived, + c->as ? 1 : 0); + else + t_depth = 0; + + c_depth = t_depth > c_depth ? t_depth : c_depth; + } + return depth + c_depth; +} + + +/* Implement 7.2.1.3 of the F08 standard: + "An intrinsic assignment where the variable is of derived type is + performed as if each component of the variable were assigned from the + corresponding component of expr using pointer assignment (7.2.2) for + each pointer component, defined assignment for each nonpointer + nonallocatable component of a type that has a type-bound defined + assignment consistent with the component, intrinsic assignment for + each other nonpointer nonallocatable component, ..." + + The pointer assignments are taken care of by the intrinsic + assignment of the structure itself. This function recursively adds + defined assignments where required. The recursion is accomplished + by calling gfc_resolve_code. + + When the lhs in a defined assignment has intent INOUT, we need a + temporary for the lhs. In pseudo-code: + + ! Only call function lhs once. + if (lhs is not a constant or an variable) + temp_x = expr2 + expr2 => temp_x + ! Do the intrinsic assignment + expr1 = expr2 + ! Now do the defined assignments + do over components with typebound defined assignment [%cmp] + #if one component's assignment procedure is INOUT + t1 = expr1 + #if expr2 non-variable + temp_x = expr2 + expr2 => temp_x + # endif + expr1 = expr2 + # for each cmp + t1%cmp {defined=} expr2%cmp + expr1%cmp = t1%cmp + #else + expr1 = expr2 + + # for each cmp + expr1%cmp {defined=} expr2%cmp + #endif + */ + +/* The temporary assignments have to be put on top of the additional + code to avoid the result being changed by the intrinsic assignment. + */ +static int component_assignment_level = 0; +static gfc_code *tmp_head = NULL, *tmp_tail = NULL; + +static void +generate_component_assignments (gfc_code **code, gfc_namespace *ns) +{ + gfc_component *comp1, *comp2; + gfc_code *this_code = NULL, *head = NULL, *tail = NULL; + gfc_expr *t1; + int error_count, depth; + + gfc_get_errors (NULL, &error_count); + + /* Filter out continuing processing after an error. */ + if (error_count + || (*code)->expr1->ts.type != BT_DERIVED + || (*code)->expr2->ts.type != BT_DERIVED) + return; + + /* TODO: Handle more than one part array reference in assignments. */ + depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived, + (*code)->expr1->rank ? 1 : 0); + if (depth > 1) + { + gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not " + "done because multiple part array references would " + "occur in intermediate expressions.", &(*code)->loc); + return; + } + + component_assignment_level++; + + /* Create a temporary so that functions get called only once. */ + if ((*code)->expr2->expr_type != EXPR_VARIABLE + && (*code)->expr2->expr_type != EXPR_CONSTANT) + { + gfc_expr *tmp_expr; + + /* Assign the rhs to the temporary. */ + tmp_expr = get_temp_from_expr ((*code)->expr1, ns); + this_code = build_assignment (EXEC_ASSIGN, + tmp_expr, (*code)->expr2, + NULL, NULL, (*code)->loc); + /* Add the code and substitute the rhs expression. */ + add_code_to_chain (&this_code, &tmp_head, &tmp_tail); + gfc_free_expr ((*code)->expr2); + (*code)->expr2 = tmp_expr; + } + + /* Do the intrinsic assignment. This is not needed if the lhs is one + of the temporaries generated here, since the intrinsic assignment + to the final result already does this. */ + if ((*code)->expr1->symtree->n.sym->name[2] != '@') + { + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, (*code)->expr2, + NULL, NULL, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + } + + comp1 = (*code)->expr1->ts.u.derived->components; + comp2 = (*code)->expr2->ts.u.derived->components; + + t1 = NULL; + for (; comp1; comp1 = comp1->next, comp2 = comp2->next) + { + bool inout = false; + + /* The intrinsic assignment does the right thing for pointers + of all kinds and allocatable components. */ + if (!gfc_bt_struct (comp1->ts.type) + || comp1->attr.pointer + || comp1->attr.allocatable + || comp1->attr.proc_pointer_comp + || comp1->attr.class_pointer + || comp1->attr.proc_pointer) + continue; + + /* Make an assigment for this component. */ + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, (*code)->expr2, + comp1, comp2, (*code)->loc); + + /* Convert the assignment if there is a defined assignment for + this type. Otherwise, using the call from gfc_resolve_code, + recurse into its components. */ + gfc_resolve_code (this_code, ns); + + if (this_code->op == EXEC_ASSIGN_CALL) + { + gfc_formal_arglist *dummy_args; + gfc_symbol *rsym; + /* Check that there is a typebound defined assignment. If not, + then this must be a module defined assignment. We cannot + use the defined_assign_comp attribute here because it must + be this derived type that has the defined assignment and not + a parent type. */ + if (!(comp1->ts.u.derived->f2k_derived + && comp1->ts.u.derived->f2k_derived + ->tb_op[INTRINSIC_ASSIGN])) + { + gfc_free_statements (this_code); + this_code = NULL; + continue; + } + + /* If the first argument of the subroutine has intent INOUT + a temporary must be generated and used instead. */ + rsym = this_code->resolved_sym; + dummy_args = gfc_sym_get_dummy_args (rsym); + if (dummy_args + && dummy_args->sym->attr.intent == INTENT_INOUT) + { + gfc_code *temp_code; + inout = true; + + /* Build the temporary required for the assignment and put + it at the head of the generated code. */ + if (!t1) + { + t1 = get_temp_from_expr ((*code)->expr1, ns); + temp_code = build_assignment (EXEC_ASSIGN, + t1, (*code)->expr1, + NULL, NULL, (*code)->loc); + + /* For allocatable LHS, check whether it is allocated. Note + that allocatable components with defined assignment are + not yet support. See PR 57696. */ + if ((*code)->expr1->symtree->n.sym->attr.allocatable) + { + gfc_code *block; + gfc_expr *e = + gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); + block = gfc_get_code (EXEC_IF); + block->block = gfc_get_code (EXEC_IF); + block->block->expr1 + = gfc_build_intrinsic_call (ns, + GFC_ISYM_ALLOCATED, "allocated", + (*code)->loc, 1, e); + block->block->next = temp_code; + temp_code = block; + } + add_code_to_chain (&temp_code, &tmp_head, &tmp_tail); + } + + /* Replace the first actual arg with the component of the + temporary. */ + gfc_free_expr (this_code->ext.actual->expr); + this_code->ext.actual->expr = gfc_copy_expr (t1); + add_comp_ref (this_code->ext.actual->expr, comp1); + + /* If the LHS variable is allocatable and wasn't allocated and + the temporary is allocatable, pointer assign the address of + the freshly allocated LHS to the temporary. */ + if ((*code)->expr1->symtree->n.sym->attr.allocatable + && gfc_expr_attr ((*code)->expr1).allocatable) + { + gfc_code *block; + gfc_expr *cond; + + cond = gfc_get_expr (); + cond->ts.type = BT_LOGICAL; + cond->ts.kind = gfc_default_logical_kind; + cond->expr_type = EXPR_OP; + cond->where = (*code)->loc; + cond->value.op.op = INTRINSIC_NOT; + cond->value.op.op1 = gfc_build_intrinsic_call (ns, + GFC_ISYM_ALLOCATED, "allocated", + (*code)->loc, 1, gfc_copy_expr (t1)); + block = gfc_get_code (EXEC_IF); + block->block = gfc_get_code (EXEC_IF); + block->block->expr1 = cond; + block->block->next = build_assignment (EXEC_POINTER_ASSIGN, + t1, (*code)->expr1, + NULL, NULL, (*code)->loc); + add_code_to_chain (&block, &head, &tail); + } + } + } + else if (this_code->op == EXEC_ASSIGN && !this_code->next) + { + /* Don't add intrinsic assignments since they are already + effected by the intrinsic assignment of the structure. */ + gfc_free_statements (this_code); + this_code = NULL; + continue; + } + + add_code_to_chain (&this_code, &head, &tail); + + if (t1 && inout) + { + /* Transfer the value to the final result. */ + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, t1, + comp1, comp2, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + } + } + + /* Put the temporary assignments at the top of the generated code. */ + if (tmp_head && component_assignment_level == 1) + { + gfc_append_code (tmp_head, head); + head = tmp_head; + tmp_head = tmp_tail = NULL; + } + + // If we did a pointer assignment - thus, we need to ensure that the LHS is + // not accidentally deallocated. Hence, nullify t1. + if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable + && gfc_expr_attr ((*code)->expr1).allocatable) + { + gfc_code *block; + gfc_expr *cond; + gfc_expr *e; + + e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); + cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated", + (*code)->loc, 2, gfc_copy_expr (t1), e); + block = gfc_get_code (EXEC_IF); + block->block = gfc_get_code (EXEC_IF); + block->block->expr1 = cond; + block->block->next = build_assignment (EXEC_POINTER_ASSIGN, + t1, gfc_get_null_expr (&(*code)->loc), + NULL, NULL, (*code)->loc); + gfc_append_code (tail, block); + tail = block; + } + + /* Now attach the remaining code chain to the input code. Step on + to the end of the new code since resolution is complete. */ + gcc_assert ((*code)->op == EXEC_ASSIGN); + tail->next = (*code)->next; + /* Overwrite 'code' because this would place the intrinsic assignment + before the temporary for the lhs is created. */ + gfc_free_expr ((*code)->expr1); + gfc_free_expr ((*code)->expr2); + **code = *head; + if (head != tail) + free (head); + *code = tail; + + component_assignment_level--; +} + + +/* F2008: Pointer function assignments are of the form: + ptr_fcn (args) = expr + This function breaks these assignments into two statements: + temporary_pointer => ptr_fcn(args) + temporary_pointer = expr */ + +static bool +resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns) +{ + gfc_expr *tmp_ptr_expr; + gfc_code *this_code; + gfc_component *comp; + gfc_symbol *s; + + if ((*code)->expr1->expr_type != EXPR_FUNCTION) + return false; + + /* Even if standard does not support this feature, continue to build + the two statements to avoid upsetting frontend_passes.c. */ + gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at " + "%L", &(*code)->loc); + + comp = gfc_get_proc_ptr_comp ((*code)->expr1); + + if (comp) + s = comp->ts.interface; + else + s = (*code)->expr1->symtree->n.sym; + + if (s == NULL || !s->result->attr.pointer) + { + gfc_error ("The function result on the lhs of the assignment at " + "%L must have the pointer attribute.", + &(*code)->expr1->where); + (*code)->op = EXEC_NOP; + return false; + } + + tmp_ptr_expr = get_temp_from_expr ((*code)->expr1, ns); + + /* get_temp_from_expression is set up for ordinary assignments. To that + end, where array bounds are not known, arrays are made allocatable. + Change the temporary to a pointer here. */ + tmp_ptr_expr->symtree->n.sym->attr.pointer = 1; + tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0; + tmp_ptr_expr->where = (*code)->loc; + + this_code = build_assignment (EXEC_ASSIGN, + tmp_ptr_expr, (*code)->expr2, + NULL, NULL, (*code)->loc); + this_code->next = (*code)->next; + (*code)->next = this_code; + (*code)->op = EXEC_POINTER_ASSIGN; + (*code)->expr2 = (*code)->expr1; + (*code)->expr1 = tmp_ptr_expr; + + return true; +} + + +/* Deferred character length assignments from an operator expression + require a temporary because the character length of the lhs can + change in the course of the assignment. */ + +static bool +deferred_op_assign (gfc_code **code, gfc_namespace *ns) +{ + gfc_expr *tmp_expr; + gfc_code *this_code; + + if (!((*code)->expr1->ts.type == BT_CHARACTER + && (*code)->expr1->ts.deferred && (*code)->expr1->rank + && (*code)->expr2->expr_type == EXPR_OP)) + return false; + + if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1)) + return false; + + if (gfc_expr_attr ((*code)->expr1).pointer) + return false; + + tmp_expr = get_temp_from_expr ((*code)->expr1, ns); + tmp_expr->where = (*code)->loc; + + /* A new charlen is required to ensure that the variable string + length is different to that of the original lhs. */ + tmp_expr->ts.u.cl = gfc_get_charlen(); + tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl; + tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next; + (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl; + + tmp_expr->symtree->n.sym->ts.deferred = 1; + + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, + gfc_copy_expr (tmp_expr), + NULL, NULL, (*code)->loc); + + (*code)->expr1 = tmp_expr; + + this_code->next = (*code)->next; + (*code)->next = this_code; + + return true; +} + + +/* Given a block of code, recursively resolve everything pointed to by this + code block. */ + +void +gfc_resolve_code (gfc_code *code, gfc_namespace *ns) +{ + int omp_workshare_save; + int forall_save, do_concurrent_save; + code_stack frame; + bool t; + + frame.prev = cs_base; + frame.head = code; + cs_base = &frame; + + find_reachable_labels (code); + + for (; code; code = code->next) + { + frame.current = code; + forall_save = forall_flag; + do_concurrent_save = gfc_do_concurrent_flag; + + if (code->op == EXEC_FORALL) + { + forall_flag = 1; + gfc_resolve_forall (code, ns, forall_save); + forall_flag = 2; + } + else if (code->block) + { + omp_workshare_save = -1; + switch (code->op) + { + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_LOOP: + gfc_resolve_oacc_blocks (code, ns); + break; + case EXEC_OMP_PARALLEL_WORKSHARE: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 1; + gfc_resolve_omp_parallel_blocks (code, ns); + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 0; + gfc_resolve_omp_parallel_blocks (code, ns); + break; + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_SIMD: + case EXEC_OMP_TARGET_SIMD: + gfc_resolve_omp_do_blocks (code, ns); + break; + case EXEC_SELECT_TYPE: + case EXEC_SELECT_RANK: + /* Blocks are handled in resolve_select_type/rank because we + have to transform the SELECT TYPE into ASSOCIATE first. */ + break; + case EXEC_DO_CONCURRENT: + gfc_do_concurrent_flag = 1; + gfc_resolve_blocks (code->block, ns); + gfc_do_concurrent_flag = 2; + break; + case EXEC_OMP_WORKSHARE: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 1; + /* FALL THROUGH */ + default: + gfc_resolve_blocks (code->block, ns); + break; + } + + if (omp_workshare_save != -1) + omp_workshare_flag = omp_workshare_save; + } +start: + t = true; + if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) + t = gfc_resolve_expr (code->expr1); + forall_flag = forall_save; + gfc_do_concurrent_flag = do_concurrent_save; + + if (!gfc_resolve_expr (code->expr2)) + t = false; + + if (code->op == EXEC_ALLOCATE + && !gfc_resolve_expr (code->expr3)) + t = false; + + switch (code->op) + { + case EXEC_NOP: + case EXEC_END_BLOCK: + case EXEC_END_NESTED_BLOCK: + case EXEC_CYCLE: + case EXEC_PAUSE: + case EXEC_STOP: + case EXEC_ERROR_STOP: + case EXEC_EXIT: + case EXEC_CONTINUE: + case EXEC_DT_END: + case EXEC_ASSIGN_CALL: + break; + + case EXEC_CRITICAL: + resolve_critical (code); + break; + + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: + resolve_sync (code); + break; + + case EXEC_LOCK: + case EXEC_UNLOCK: + case EXEC_EVENT_POST: + case EXEC_EVENT_WAIT: + resolve_lock_unlock_event (code); + break; + + case EXEC_FAIL_IMAGE: + case EXEC_FORM_TEAM: + case EXEC_CHANGE_TEAM: + case EXEC_END_TEAM: + case EXEC_SYNC_TEAM: + break; + + case EXEC_ENTRY: + /* Keep track of which entry we are up to. */ + current_entry_id = code->ext.entry->id; + break; + + case EXEC_WHERE: + resolve_where (code, NULL); + break; + + case EXEC_GOTO: + if (code->expr1 != NULL) + { + if (code->expr1->expr_type != EXPR_VARIABLE + || code->expr1->ts.type != BT_INTEGER + || (code->expr1->ref + && code->expr1->ref->type == REF_ARRAY) + || code->expr1->symtree == NULL + || (code->expr1->symtree->n.sym + && (code->expr1->symtree->n.sym->attr.flavor + == FL_PARAMETER))) + gfc_error ("ASSIGNED GOTO statement at %L requires a " + "scalar INTEGER variable", &code->expr1->where); + else if (code->expr1->symtree->n.sym + && code->expr1->symtree->n.sym->attr.assign != 1) + gfc_error ("Variable %qs has not been assigned a target " + "label at %L", code->expr1->symtree->n.sym->name, + &code->expr1->where); + } + else + resolve_branch (code->label1, code); + break; + + case EXEC_RETURN: + if (code->expr1 != NULL + && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) + gfc_error ("Alternate RETURN statement at %L requires a SCALAR-" + "INTEGER return specifier", &code->expr1->where); + break; + + case EXEC_INIT_ASSIGN: + case EXEC_END_PROCEDURE: + break; + + case EXEC_ASSIGN: + if (!t) + break; + + if (code->expr1->ts.type == BT_CLASS) + gfc_find_vtab (&code->expr2->ts); + + /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on + the LHS. */ + if (code->expr1->expr_type == EXPR_FUNCTION + && code->expr1->value.function.isym + && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) + remove_caf_get_intrinsic (code->expr1); + + /* If this is a pointer function in an lvalue variable context, + the new code will have to be resolved afresh. This is also the + case with an error, where the code is transformed into NOP to + prevent ICEs downstream. */ + if (resolve_ptr_fcn_assign (&code, ns) + || code->op == EXEC_NOP) + goto start; + + if (!gfc_check_vardef_context (code->expr1, false, false, false, + _("assignment"))) + break; + + if (resolve_ordinary_assign (code, ns)) + { + if (omp_workshare_flag) + { + gfc_error ("Expected intrinsic assignment in OMP WORKSHARE " + "at %L", &code->loc); + break; + } + if (code->op == EXEC_COMPCALL) + goto compcall; + else + goto call; + } + + /* Check for dependencies in deferred character length array + assignments and generate a temporary, if necessary. */ + if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns)) + break; + + /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ + if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED + && code->expr1->ts.u.derived + && code->expr1->ts.u.derived->attr.defined_assign_comp) + generate_component_assignments (&code, ns); + + break; + + case EXEC_LABEL_ASSIGN: + if (code->label1->defined == ST_LABEL_UNKNOWN) + gfc_error ("Label %d referenced at %L is never defined", + code->label1->value, &code->label1->where); + if (t + && (code->expr1->expr_type != EXPR_VARIABLE + || code->expr1->symtree->n.sym->ts.type != BT_INTEGER + || code->expr1->symtree->n.sym->ts.kind + != gfc_default_integer_kind + || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER + || code->expr1->symtree->n.sym->as != NULL)) + gfc_error ("ASSIGN statement at %L requires a scalar " + "default INTEGER variable", &code->expr1->where); + break; + + case EXEC_POINTER_ASSIGN: + { + gfc_expr* e; + + if (!t) + break; + + /* This is both a variable definition and pointer assignment + context, so check both of them. For rank remapping, a final + array ref may be present on the LHS and fool gfc_expr_attr + used in gfc_check_vardef_context. Remove it. */ + e = remove_last_array_ref (code->expr1); + t = gfc_check_vardef_context (e, true, false, false, + _("pointer assignment")); + if (t) + t = gfc_check_vardef_context (e, false, false, false, + _("pointer assignment")); + gfc_free_expr (e); + + t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t; + + if (!t) + break; + + /* Assigning a class object always is a regular assign. */ + if (code->expr2->ts.type == BT_CLASS + && code->expr1->ts.type == BT_CLASS + && CLASS_DATA (code->expr2) + && !CLASS_DATA (code->expr2)->attr.dimension + && !(gfc_expr_attr (code->expr1).proc_pointer + && code->expr2->expr_type == EXPR_VARIABLE + && code->expr2->symtree->n.sym->attr.flavor + == FL_PROCEDURE)) + code->op = EXEC_ASSIGN; + break; + } + + case EXEC_ARITHMETIC_IF: + { + gfc_expr *e = code->expr1; + + gfc_resolve_expr (e); + if (e->expr_type == EXPR_NULL) + gfc_error ("Invalid NULL at %L", &e->where); + + if (t && (e->rank > 0 + || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER))) + gfc_error ("Arithmetic IF statement at %L requires a scalar " + "REAL or INTEGER expression", &e->where); + + resolve_branch (code->label1, code); + resolve_branch (code->label2, code); + resolve_branch (code->label3, code); + } + break; + + case EXEC_IF: + if (t && code->expr1 != NULL + && (code->expr1->ts.type != BT_LOGICAL + || code->expr1->rank != 0)) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &code->expr1->where); + break; + + case EXEC_CALL: + call: + resolve_call (code); + break; + + case EXEC_COMPCALL: + compcall: + resolve_typebound_subroutine (code); + break; + + case EXEC_CALL_PPC: + resolve_ppc_call (code); + break; + + case EXEC_SELECT: + /* Select is complicated. Also, a SELECT construct could be + a transformed computed GOTO. */ + resolve_select (code, false); + break; + + case EXEC_SELECT_TYPE: + resolve_select_type (code, ns); + break; + + case EXEC_SELECT_RANK: + resolve_select_rank (code, ns); + break; + + case EXEC_BLOCK: + resolve_block_construct (code); + break; + + case EXEC_DO: + if (code->ext.iterator != NULL) + { + gfc_iterator *iter = code->ext.iterator; + if (gfc_resolve_iterator (iter, true, false)) + gfc_resolve_do_iterator (code, iter->var->symtree->n.sym, + true); + } + break; + + case EXEC_DO_WHILE: + if (code->expr1 == NULL) + gfc_internal_error ("gfc_resolve_code(): No expression on " + "DO WHILE"); + if (t + && (code->expr1->rank != 0 + || code->expr1->ts.type != BT_LOGICAL)) + gfc_error ("Exit condition of DO WHILE loop at %L must be " + "a scalar LOGICAL expression", &code->expr1->where); + break; + + case EXEC_ALLOCATE: + if (t) + resolve_allocate_deallocate (code, "ALLOCATE"); + + break; + + case EXEC_DEALLOCATE: + if (t) + resolve_allocate_deallocate (code, "DEALLOCATE"); + + break; + + case EXEC_OPEN: + if (!gfc_resolve_open (code->ext.open, &code->loc)) + break; + + resolve_branch (code->ext.open->err, code); + break; + + case EXEC_CLOSE: + if (!gfc_resolve_close (code->ext.close, &code->loc)) + break; + + resolve_branch (code->ext.close->err, code); + break; + + case EXEC_BACKSPACE: + case EXEC_ENDFILE: + case EXEC_REWIND: + case EXEC_FLUSH: + if (!gfc_resolve_filepos (code->ext.filepos, &code->loc)) + break; + + resolve_branch (code->ext.filepos->err, code); + break; + + case EXEC_INQUIRE: + if (!gfc_resolve_inquire (code->ext.inquire)) + break; + + resolve_branch (code->ext.inquire->err, code); + break; + + case EXEC_IOLENGTH: + gcc_assert (code->ext.inquire != NULL); + if (!gfc_resolve_inquire (code->ext.inquire)) + break; + + resolve_branch (code->ext.inquire->err, code); + break; + + case EXEC_WAIT: + if (!gfc_resolve_wait (code->ext.wait)) + break; + + resolve_branch (code->ext.wait->err, code); + resolve_branch (code->ext.wait->end, code); + resolve_branch (code->ext.wait->eor, code); + break; + + case EXEC_READ: + case EXEC_WRITE: + if (!gfc_resolve_dt (code, code->ext.dt, &code->loc)) + break; + + resolve_branch (code->ext.dt->err, code); + resolve_branch (code->ext.dt->end, code); + resolve_branch (code->ext.dt->eor, code); + break; + + case EXEC_TRANSFER: + resolve_transfer (code); + break; + + case EXEC_DO_CONCURRENT: + case EXEC_FORALL: + resolve_forall_iterators (code->ext.forall_iterator); + + if (code->expr1 != NULL + && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank)) + gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL " + "expression", &code->expr1->where); + break; + + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_LOOP: + case EXEC_OACC_UPDATE: + case EXEC_OACC_WAIT: + case EXEC_OACC_CACHE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ATOMIC: + case EXEC_OACC_DECLARE: + gfc_resolve_oacc_directive (code, ns); + break; + + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_CANCEL: + case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_FLUSH: + case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: + case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_ORDERED: + case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SIMD: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKGROUP: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_WORKSHARE: + gfc_resolve_omp_directive (code, ns); + break; + + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + omp_workshare_save = omp_workshare_flag; + omp_workshare_flag = 0; + gfc_resolve_omp_directive (code, ns); + omp_workshare_flag = omp_workshare_save; + break; + + default: + gfc_internal_error ("gfc_resolve_code(): Bad statement code"); + } + } + + cs_base = frame.prev; +} + + +/* Resolve initial values and make sure they are compatible with + the variable. */ + +static void +resolve_values (gfc_symbol *sym) +{ + bool t; + + if (sym->value == NULL) + return; + + if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym->attr.referenced) + gfc_warning (OPT_Wdeprecated_declarations, + "Using parameter %qs declared at %L is deprecated", + sym->name, &sym->declared_at); + + if (sym->value->expr_type == EXPR_STRUCTURE) + t= resolve_structure_cons (sym->value, 1); + else + t = gfc_resolve_expr (sym->value); + + if (!t) + return; + + gfc_check_assign_symbol (sym, NULL, sym->value); +} + + +/* Verify any BIND(C) derived types in the namespace so we can report errors + for them once, rather than for each variable declared of that type. */ + +static void +resolve_bind_c_derived_types (gfc_symbol *derived_sym) +{ + if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED + && derived_sym->attr.is_bind_c == 1) + verify_bind_c_derived_type (derived_sym); + + return; +} + + +/* Check the interfaces of DTIO procedures associated with derived + type 'sym'. These procedures can either have typebound bindings or + can appear in DTIO generic interfaces. */ + +static void +gfc_verify_DTIO_procedures (gfc_symbol *sym) +{ + if (!sym || sym->attr.flavor != FL_DERIVED) + return; + + gfc_check_dtio_interfaces (sym); + + return; +} + +/* Verify that any binding labels used in a given namespace do not collide + with the names or binding labels of any global symbols. Multiple INTERFACE + for the same procedure are permitted. */ + +static void +gfc_verify_binding_labels (gfc_symbol *sym) +{ + gfc_gsymbol *gsym; + const char *module; + + if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c + || sym->attr.flavor == FL_DERIVED || !sym->binding_label) + return; + + gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label); + + if (sym->module) + module = sym->module; + else if (sym->ns && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE) + module = sym->ns->proc_name->name; + else if (sym->ns && sym->ns->parent + && sym->ns && sym->ns->parent->proc_name + && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) + module = sym->ns->parent->proc_name->name; + else + module = NULL; + + if (!gsym + || (!gsym->defined + && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE))) + { + if (!gsym) + gsym = gfc_get_gsymbol (sym->binding_label, true); + gsym->where = sym->declared_at; + gsym->sym_name = sym->name; + gsym->binding_label = sym->binding_label; + gsym->ns = sym->ns; + gsym->mod_name = module; + if (sym->attr.function) + gsym->type = GSYM_FUNCTION; + else if (sym->attr.subroutine) + gsym->type = GSYM_SUBROUTINE; + /* Mark as variable/procedure as defined, unless its an INTERFACE. */ + gsym->defined = sym->attr.if_source != IFSRC_IFBODY; + return; + } + + if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) + { + gfc_error ("Variable %qs with binding label %qs at %L uses the same global " + "identifier as entity at %L", sym->name, + sym->binding_label, &sym->declared_at, &gsym->where); + /* Clear the binding label to prevent checking multiple times. */ + sym->binding_label = NULL; + return; + } + + if (sym->attr.flavor == FL_VARIABLE && module + && (strcmp (module, gsym->mod_name) != 0 + || strcmp (sym->name, gsym->sym_name) != 0)) + { + /* This can only happen if the variable is defined in a module - if it + isn't the same module, reject it. */ + gfc_error ("Variable %qs from module %qs with binding label %qs at %L " + "uses the same global identifier as entity at %L from module %qs", + sym->name, module, sym->binding_label, + &sym->declared_at, &gsym->where, gsym->mod_name); + sym->binding_label = NULL; + return; + } + + if ((sym->attr.function || sym->attr.subroutine) + && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION) + || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY)) + && (sym != gsym->ns->proc_name && sym->attr.entry == 0) + && (module != gsym->mod_name + || strcmp (gsym->sym_name, sym->name) != 0 + || (module && strcmp (module, gsym->mod_name) != 0))) + { + /* Print an error if the procedure is defined multiple times; we have to + exclude references to the same procedure via module association or + multiple checks for the same procedure. */ + gfc_error ("Procedure %qs with binding label %qs at %L uses the same " + "global identifier as entity at %L", sym->name, + sym->binding_label, &sym->declared_at, &gsym->where); + sym->binding_label = NULL; + } +} + + +/* Resolve an index expression. */ + +static bool +resolve_index_expr (gfc_expr *e) +{ + if (!gfc_resolve_expr (e)) + return false; + + if (!gfc_simplify_expr (e, 0)) + return false; + + if (!gfc_specification_expr (e)) + return false; + + return true; +} + + +/* Resolve a charlen structure. */ + +static bool +resolve_charlen (gfc_charlen *cl) +{ + int k; + bool saved_specification_expr; + + if (cl->resolved) + return true; + + cl->resolved = 1; + saved_specification_expr = specification_expr; + specification_expr = true; + + if (cl->length_from_typespec) + { + if (!gfc_resolve_expr (cl->length)) + { + specification_expr = saved_specification_expr; + return false; + } + + if (!gfc_simplify_expr (cl->length, 0)) + { + specification_expr = saved_specification_expr; + return false; + } + + /* cl->length has been resolved. It should have an integer type. */ + if (cl->length + && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0)) + { + gfc_error ("Scalar INTEGER expression expected at %L", + &cl->length->where); + return false; + } + } + else + { + if (!resolve_index_expr (cl->length)) + { + specification_expr = saved_specification_expr; + return false; + } + } + + /* F2008, 4.4.3.2: If the character length parameter value evaluates to + a negative value, the length of character entities declared is zero. */ + if (cl->length && cl->length->expr_type == EXPR_CONSTANT + && mpz_sgn (cl->length->value.integer) < 0) + gfc_replace_expr (cl->length, + gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0)); + + /* Check that the character length is not too large. */ + k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); + if (cl->length && cl->length->expr_type == EXPR_CONSTANT + && cl->length->ts.type == BT_INTEGER + && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0) + { + gfc_error ("String length at %L is too large", &cl->length->where); + specification_expr = saved_specification_expr; + return false; + } + + specification_expr = saved_specification_expr; + return true; +} + + +/* Test for non-constant shape arrays. */ + +static bool +is_non_constant_shape_array (gfc_symbol *sym) +{ + gfc_expr *e; + int i; + bool not_constant; + + not_constant = false; + if (sym->as != NULL) + { + /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that + has not been simplified; parameter array references. Do the + simplification now. */ + for (i = 0; i < sym->as->rank + sym->as->corank; i++) + { + if (i == GFC_MAX_DIMENSIONS) + break; + + e = sym->as->lower[i]; + if (e && (!resolve_index_expr(e) + || !gfc_is_constant_expr (e))) + not_constant = true; + e = sym->as->upper[i]; + if (e && (!resolve_index_expr(e) + || !gfc_is_constant_expr (e))) + not_constant = true; + } + } + return not_constant; +} + +/* Given a symbol and an initialization expression, add code to initialize + the symbol to the function entry. */ +static void +build_init_assign (gfc_symbol *sym, gfc_expr *init) +{ + gfc_expr *lval; + gfc_code *init_st; + gfc_namespace *ns = sym->ns; + + /* Search for the function namespace if this is a contained + function without an explicit result. */ + if (sym->attr.function && sym == sym->result + && sym->name != sym->ns->proc_name->name) + { + ns = ns->contained; + for (;ns; ns = ns->sibling) + if (strcmp (ns->proc_name->name, sym->name) == 0) + break; + } + + if (ns == NULL) + { + gfc_free_expr (init); + return; + } + + /* Build an l-value expression for the result. */ + lval = gfc_lval_expr_from_sym (sym); + + /* Add the code at scope entry. */ + init_st = gfc_get_code (EXEC_INIT_ASSIGN); + init_st->next = ns->code; + ns->code = init_st; + + /* Assign the default initializer to the l-value. */ + init_st->loc = sym->declared_at; + init_st->expr1 = lval; + init_st->expr2 = init; +} + + +/* Whether or not we can generate a default initializer for a symbol. */ + +static bool +can_generate_init (gfc_symbol *sym) +{ + symbol_attribute *a; + if (!sym) + return false; + a = &sym->attr; + + /* These symbols should never have a default initialization. */ + return !( + a->allocatable + || a->external + || a->pointer + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && (CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.proc_pointer)) + || a->in_equivalence + || a->in_common + || a->data + || sym->module + || a->cray_pointee + || a->cray_pointer + || sym->assoc + || (!a->referenced && !a->result) + || (a->dummy && (a->intent != INTENT_OUT + || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)) + || (a->function && sym != sym->result) + ); +} + + +/* Assign the default initializer to a derived type variable or result. */ + +static void +apply_default_init (gfc_symbol *sym) +{ + gfc_expr *init = NULL; + + if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function) + return; + + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) + init = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); + + if (init == NULL && sym->ts.type != BT_CLASS) + return; + + build_init_assign (sym, init); + sym->attr.referenced = 1; +} + + +/* Build an initializer for a local. Returns null if the symbol should not have + a default initialization. */ + +static gfc_expr * +build_default_init_expr (gfc_symbol *sym) +{ + /* These symbols should never have a default initialization. */ + if (sym->attr.allocatable + || sym->attr.external + || sym->attr.dummy + || sym->attr.pointer + || sym->attr.in_equivalence + || sym->attr.in_common + || sym->attr.data + || sym->module + || sym->attr.cray_pointee + || sym->attr.cray_pointer + || sym->assoc) + return NULL; + + /* Get the appropriate init expression. */ + return gfc_build_default_init_expr (&sym->ts, &sym->declared_at); +} + +/* Add an initialization expression to a local variable. */ +static void +apply_default_init_local (gfc_symbol *sym) +{ + gfc_expr *init = NULL; + + /* The symbol should be a variable or a function return value. */ + if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function) + || (sym->attr.function && sym->result != sym)) + return; + + /* Try to build the initializer expression. If we can't initialize + this symbol, then init will be NULL. */ + init = build_default_init_expr (sym); + if (init == NULL) + return; + + /* For saved variables, we don't want to add an initializer at function + entry, so we just add a static initializer. Note that automatic variables + are stack allocated even with -fno-automatic; we have also to exclude + result variable, which are also nonstatic. */ + if (!sym->attr.automatic + && (sym->attr.save || sym->ns->save_all + || (flag_max_stack_var_size == 0 && !sym->attr.result + && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive) + && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))) + { + /* Don't clobber an existing initializer! */ + gcc_assert (sym->value == NULL); + sym->value = init; + return; + } + + build_init_assign (sym, init); +} + + +/* Resolution of common features of flavors variable and procedure. */ + +static bool +resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) +{ + gfc_array_spec *as; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym)) + as = CLASS_DATA (sym)->as; + else + as = sym->as; + + /* Constraints on deferred shape variable. */ + if (as == NULL || as->type != AS_DEFERRED) + { + bool pointer, allocatable, dimension; + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym)) + { + pointer = CLASS_DATA (sym)->attr.class_pointer; + allocatable = CLASS_DATA (sym)->attr.allocatable; + dimension = CLASS_DATA (sym)->attr.dimension; + } + else + { + pointer = sym->attr.pointer && !sym->attr.select_type_temporary; + allocatable = sym->attr.allocatable; + dimension = sym->attr.dimension; + } + + if (allocatable) + { + if (dimension && as->type != AS_ASSUMED_RANK) + { + gfc_error ("Allocatable array %qs at %L must have a deferred " + "shape or assumed rank", sym->name, &sym->declared_at); + return false; + } + else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object " + "%qs at %L may not be ALLOCATABLE", + sym->name, &sym->declared_at)) + return false; + } + + if (pointer && dimension && as->type != AS_ASSUMED_RANK) + { + gfc_error ("Array pointer %qs at %L must have a deferred shape or " + "assumed rank", sym->name, &sym->declared_at); + sym->error = 1; + return false; + } + } + else + { + if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer + && sym->ts.type != BT_CLASS && !sym->assoc) + { + gfc_error ("Array %qs at %L cannot have a deferred shape", + sym->name, &sym->declared_at); + return false; + } + } + + /* Constraints on polymorphic variables. */ + if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) + { + /* F03:C502. */ + if (sym->attr.class_ok + && sym->ts.u.derived + && !sym->attr.select_type_temporary + && !UNLIMITED_POLY (sym) + && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) + { + gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible", + CLASS_DATA (sym)->ts.u.derived->name, sym->name, + &sym->declared_at); + return false; + } + + /* F03:C509. */ + /* Assume that use associated symbols were checked in the module ns. + Class-variables that are associate-names are also something special + and excepted from the test. */ + if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc) + { + gfc_error ("CLASS variable %qs at %L must be dummy, allocatable " + "or pointer", sym->name, &sym->declared_at); + return false; + } + } + + return true; +} + + +/* Additional checks for symbols with flavor variable and derived + type. To be called from resolve_fl_variable. */ + +static bool +resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) +{ + gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); + + /* Check to see if a derived type is blocked from being host + associated by the presence of another class I symbol in the same + namespace. 14.6.1.3 of the standard and the discussion on + comp.lang.fortran. */ + if (sym->ts.u.derived + && sym->ns != sym->ts.u.derived->ns + && !sym->ts.u.derived->attr.use_assoc + && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY) + { + gfc_symbol *s; + gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); + if (s && s->attr.generic) + s = gfc_find_dt_in_generic (s); + if (s && !gfc_fl_struct (s->attr.flavor)) + { + gfc_error ("The type %qs cannot be host associated at %L " + "because it is blocked by an incompatible object " + "of the same name declared at %L", + sym->ts.u.derived->name, &sym->declared_at, + &s->declared_at); + return false; + } + } + + /* 4th constraint in section 11.3: "If an object of a type for which + component-initialization is specified (R429) appears in the + specification-part of a module and does not have the ALLOCATABLE + or POINTER attribute, the object shall have the SAVE attribute." + + The check for initializers is performed with + gfc_has_default_initializer because gfc_default_initializer generates + a hidden default for allocatable components. */ + if (!(sym->value || no_init_flag) && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE + && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save + && !sym->attr.pointer && !sym->attr.allocatable + && gfc_has_default_initializer (sym->ts.u.derived) + && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable " + "%qs at %L, needed due to the default " + "initialization", sym->name, &sym->declared_at)) + return false; + + /* Assign default initializer. */ + if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) + && (!no_init_flag + || (sym->attr.intent == INTENT_OUT + && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY))) + sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); + + return true; +} + + +/* F2008, C402 (R401): A colon shall not be used as a type-param-value + except in the declaration of an entity or component that has the POINTER + or ALLOCATABLE attribute. */ + +static bool +deferred_requirements (gfc_symbol *sym) +{ + if (sym->ts.deferred + && !(sym->attr.pointer + || sym->attr.allocatable + || sym->attr.associate_var + || sym->attr.omp_udr_artificial_var)) + { + /* If a function has a result variable, only check the variable. */ + if (sym->result && sym->name != sym->result->name) + return true; + + gfc_error ("Entity %qs at %L has a deferred type parameter and " + "requires either the POINTER or ALLOCATABLE attribute", + sym->name, &sym->declared_at); + return false; + } + return true; +} + + +/* Resolve symbols with flavor variable. */ + +static bool +resolve_fl_variable (gfc_symbol *sym, int mp_flag) +{ + const char *auto_save_msg = "Automatic object %qs at %L cannot have the " + "SAVE attribute"; + + if (!resolve_fl_var_and_proc (sym, mp_flag)) + return false; + + /* Set this flag to check that variables are parameters of all entries. + This check is effected by the call to gfc_resolve_expr through + is_non_constant_shape_array. */ + bool saved_specification_expr = specification_expr; + specification_expr = true; + + if (sym->ns->proc_name + && (sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program) + && !sym->attr.use_assoc + && !sym->attr.allocatable + && !sym->attr.pointer + && is_non_constant_shape_array (sym)) + { + /* F08:C541. The shape of an array defined in a main program or module + * needs to be constant. */ + gfc_error ("The module or main program array %qs at %L must " + "have constant shape", sym->name, &sym->declared_at); + specification_expr = saved_specification_expr; + return false; + } + + /* Constraints on deferred type parameter. */ + if (!deferred_requirements (sym)) + return false; + + if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var) + { + /* Make sure that character string variables with assumed length are + dummy arguments. */ + gfc_expr *e = NULL; + + if (sym->ts.u.cl) + e = sym->ts.u.cl->length; + else + return false; + + if (e == NULL && !sym->attr.dummy && !sym->attr.result + && !sym->ts.deferred && !sym->attr.select_type_temporary + && !sym->attr.omp_udr_artificial_var) + { + gfc_error ("Entity with assumed character length at %L must be a " + "dummy argument or a PARAMETER", &sym->declared_at); + specification_expr = saved_specification_expr; + return false; + } + + if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) + { + gfc_error (auto_save_msg, sym->name, &sym->declared_at); + specification_expr = saved_specification_expr; + return false; + } + + if (!gfc_is_constant_expr (e) + && !(e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor == FL_PARAMETER)) + { + if (!sym->attr.use_assoc && sym->ns->proc_name + && (sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program)) + { + gfc_error ("%qs at %L must have constant character length " + "in this context", sym->name, &sym->declared_at); + specification_expr = saved_specification_expr; + return false; + } + if (sym->attr.in_common) + { + gfc_error ("COMMON variable %qs at %L must have constant " + "character length", sym->name, &sym->declared_at); + specification_expr = saved_specification_expr; + return false; + } + } + } + + if (sym->value == NULL && sym->attr.referenced) + apply_default_init_local (sym); /* Try to apply a default initialization. */ + + /* Determine if the symbol may not have an initializer. */ + int no_init_flag = 0, automatic_flag = 0; + if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy + || sym->attr.intrinsic || sym->attr.result) + no_init_flag = 1; + else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer + && is_non_constant_shape_array (sym)) + { + no_init_flag = automatic_flag = 1; + + /* Also, they must not have the SAVE attribute. + SAVE_IMPLICIT is checked below. */ + if (sym->as && sym->attr.codimension) + { + int corank = sym->as->corank; + sym->as->corank = 0; + no_init_flag = automatic_flag = is_non_constant_shape_array (sym); + sym->as->corank = corank; + } + if (automatic_flag && sym->attr.save == SAVE_EXPLICIT) + { + gfc_error (auto_save_msg, sym->name, &sym->declared_at); + specification_expr = saved_specification_expr; + return false; + } + } + + /* Ensure that any initializer is simplified. */ + if (sym->value) + gfc_simplify_expr (sym->value, 1); + + /* Reject illegal initializers. */ + if (!sym->mark && sym->value) + { + if (sym->attr.allocatable || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.allocatable)) + gfc_error ("Allocatable %qs at %L cannot have an initializer", + sym->name, &sym->declared_at); + else if (sym->attr.external) + gfc_error ("External %qs at %L cannot have an initializer", + sym->name, &sym->declared_at); + else if (sym->attr.dummy) + gfc_error ("Dummy %qs at %L cannot have an initializer", + sym->name, &sym->declared_at); + else if (sym->attr.intrinsic) + gfc_error ("Intrinsic %qs at %L cannot have an initializer", + sym->name, &sym->declared_at); + else if (sym->attr.result) + gfc_error ("Function result %qs at %L cannot have an initializer", + sym->name, &sym->declared_at); + else if (automatic_flag) + gfc_error ("Automatic array %qs at %L cannot have an initializer", + sym->name, &sym->declared_at); + else + goto no_init_error; + specification_expr = saved_specification_expr; + return false; + } + +no_init_error: + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + { + bool res = resolve_fl_variable_derived (sym, no_init_flag); + specification_expr = saved_specification_expr; + return res; + } + + specification_expr = saved_specification_expr; + return true; +} + + +/* Compare the dummy characteristics of a module procedure interface + declaration with the corresponding declaration in a submodule. */ +static gfc_formal_arglist *new_formal; +static char errmsg[200]; + +static void +compare_fsyms (gfc_symbol *sym) +{ + gfc_symbol *fsym; + + if (sym == NULL || new_formal == NULL) + return; + + fsym = new_formal->sym; + + if (sym == fsym) + return; + + if (strcmp (sym->name, fsym->name) == 0) + { + if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200)) + gfc_error ("%s at %L", errmsg, &fsym->declared_at); + } +} + + +/* Resolve a procedure. */ + +static bool +resolve_fl_procedure (gfc_symbol *sym, int mp_flag) +{ + gfc_formal_arglist *arg; + bool allocatable_or_pointer = false; + + if (sym->attr.function + && !resolve_fl_var_and_proc (sym, mp_flag)) + return false; + + /* Constraints on deferred type parameter. */ + if (!deferred_requirements (sym)) + return false; + + if (sym->ts.type == BT_CHARACTER) + { + gfc_charlen *cl = sym->ts.u.cl; + + if (cl && cl->length && gfc_is_constant_expr (cl->length) + && !resolve_charlen (cl)) + return false; + + if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + && sym->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Character-valued statement function %qs at %L must " + "have constant length", sym->name, &sym->declared_at); + return false; + } + } + + /* Ensure that derived type for are not of a private type. Internal + module procedures are excluded by 2.2.3.3 - i.e., they are not + externally accessible and can access all the objects accessible in + the host. */ + if (!(sym->ns->parent && sym->ns->parent->proc_name + && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) + && gfc_check_symbol_access (sym)) + { + gfc_interface *iface; + + for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next) + { + if (arg->sym + && arg->sym->ts.type == BT_DERIVED + && arg->sym->ts.u.derived + && !arg->sym->ts.u.derived->attr.use_assoc + && !gfc_check_symbol_access (arg->sym->ts.u.derived) + && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type " + "and cannot be a dummy argument" + " of %qs, which is PUBLIC at %L", + arg->sym->name, sym->name, + &sym->declared_at)) + { + /* Stop this message from recurring. */ + arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; + return false; + } + } + + /* PUBLIC interfaces may expose PRIVATE procedures that take types + PRIVATE to the containing module. */ + for (iface = sym->generic; iface; iface = iface->next) + { + for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next) + { + if (arg->sym + && arg->sym->ts.type == BT_DERIVED + && !arg->sym->ts.u.derived->attr.use_assoc + && !gfc_check_symbol_access (arg->sym->ts.u.derived) + && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in " + "PUBLIC interface %qs at %L " + "takes dummy arguments of %qs which " + "is PRIVATE", iface->sym->name, + sym->name, &iface->sym->declared_at, + gfc_typename(&arg->sym->ts))) + { + /* Stop this message from recurring. */ + arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; + return false; + } + } + } + } + + if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.proc_pointer) + { + gfc_error ("Function %qs at %L cannot have an initializer", + sym->name, &sym->declared_at); + + /* Make sure no second error is issued for this. */ + sym->value->error = 1; + return false; + } + + /* An external symbol may not have an initializer because it is taken to be + a procedure. Exception: Procedure Pointers. */ + if (sym->attr.external && sym->value && !sym->attr.proc_pointer) + { + gfc_error ("External object %qs at %L may not have an initializer", + sym->name, &sym->declared_at); + return false; + } + + /* An elemental function is required to return a scalar 12.7.1 */ + if (sym->attr.elemental && sym->attr.function + && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as))) + { + gfc_error ("ELEMENTAL function %qs at %L must have a scalar " + "result", sym->name, &sym->declared_at); + /* Reset so that the error only occurs once. */ + sym->attr.elemental = 0; + return false; + } + + if (sym->attr.proc == PROC_ST_FUNCTION + && (sym->attr.allocatable || sym->attr.pointer)) + { + gfc_error ("Statement function %qs at %L may not have pointer or " + "allocatable attribute", sym->name, &sym->declared_at); + return false; + } + + /* 5.1.1.5 of the Standard: A function name declared with an asterisk + char-len-param shall not be array-valued, pointer-valued, recursive + or pure. ....snip... A character value of * may only be used in the + following ways: (i) Dummy arg of procedure - dummy associates with + actual length; (ii) To declare a named constant; or (iii) External + function - but length must be declared in calling scoping unit. */ + if (sym->attr.function + && sym->ts.type == BT_CHARACTER && !sym->ts.deferred + && sym->ts.u.cl && sym->ts.u.cl->length == NULL) + { + if ((sym->as && sym->as->rank) || (sym->attr.pointer) + || (sym->attr.recursive) || (sym->attr.pure)) + { + if (sym->as && sym->as->rank) + gfc_error ("CHARACTER(*) function %qs at %L cannot be " + "array-valued", sym->name, &sym->declared_at); + + if (sym->attr.pointer) + gfc_error ("CHARACTER(*) function %qs at %L cannot be " + "pointer-valued", sym->name, &sym->declared_at); + + if (sym->attr.pure) + gfc_error ("CHARACTER(*) function %qs at %L cannot be " + "pure", sym->name, &sym->declared_at); + + if (sym->attr.recursive) + gfc_error ("CHARACTER(*) function %qs at %L cannot be " + "recursive", sym->name, &sym->declared_at); + + return false; + } + + /* Appendix B.2 of the standard. Contained functions give an + error anyway. Deferred character length is an F2003 feature. + Don't warn on intrinsic conversion functions, which start + with two underscores. */ + if (!sym->attr.contained && !sym->ts.deferred + && (sym->name[0] != '_' || sym->name[1] != '_')) + gfc_notify_std (GFC_STD_F95_OBS, + "CHARACTER(*) function %qs at %L", + sym->name, &sym->declared_at); + } + + /* F2008, C1218. */ + if (sym->attr.elemental) + { + if (sym->attr.proc_pointer) + { + const char* name = (sym->attr.result ? sym->ns->proc_name->name + : sym->name); + gfc_error ("Procedure pointer %qs at %L shall not be elemental", + name, &sym->declared_at); + return false; + } + if (sym->attr.dummy) + { + gfc_error ("Dummy procedure %qs at %L shall not be elemental", + sym->name, &sym->declared_at); + return false; + } + } + + /* F2018, C15100: "The result of an elemental function shall be scalar, + and shall not have the POINTER or ALLOCATABLE attribute." The scalar + pointer is tested and caught elsewhere. */ + if (sym->result) + allocatable_or_pointer = sym->result->ts.type == BT_CLASS + && CLASS_DATA (sym->result) ? + (CLASS_DATA (sym->result)->attr.allocatable + || CLASS_DATA (sym->result)->attr.pointer) : + (sym->result->attr.allocatable + || sym->result->attr.pointer); + + if (sym->attr.elemental && sym->result + && allocatable_or_pointer) + { + gfc_error ("Function result variable %qs at %L of elemental " + "function %qs shall not have an ALLOCATABLE or POINTER " + "attribute", sym->result->name, + &sym->result->declared_at, sym->name); + return false; + } + + if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) + { + gfc_formal_arglist *curr_arg; + int has_non_interop_arg = 0; + + if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, + sym->common_block)) + { + /* Clear these to prevent looking at them again if there was an + error. */ + sym->attr.is_bind_c = 0; + sym->attr.is_c_interop = 0; + sym->ts.is_c_interop = 0; + } + else + { + /* So far, no errors have been found. */ + sym->attr.is_c_interop = 1; + sym->ts.is_c_interop = 1; + } + + curr_arg = gfc_sym_get_dummy_args (sym); + while (curr_arg != NULL) + { + /* Skip implicitly typed dummy args here. */ + if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0) + if (!gfc_verify_c_interop_param (curr_arg->sym)) + /* If something is found to fail, record the fact so we + can mark the symbol for the procedure as not being + BIND(C) to try and prevent multiple errors being + reported. */ + has_non_interop_arg = 1; + + curr_arg = curr_arg->next; + } + + /* See if any of the arguments were not interoperable and if so, clear + the procedure symbol to prevent duplicate error messages. */ + if (has_non_interop_arg != 0) + { + sym->attr.is_c_interop = 0; + sym->ts.is_c_interop = 0; + sym->attr.is_bind_c = 0; + } + } + + if (!sym->attr.proc_pointer) + { + if (sym->attr.save == SAVE_EXPLICIT) + { + gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " + "in %qs at %L", sym->name, &sym->declared_at); + return false; + } + if (sym->attr.intent) + { + gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " + "in %qs at %L", sym->name, &sym->declared_at); + return false; + } + if (sym->attr.subroutine && sym->attr.result) + { + gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " + "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at); + return false; + } + if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure + && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) + || sym->attr.contained)) + { + gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " + "in %qs at %L", sym->name, &sym->declared_at); + return false; + } + if (strcmp ("ppr@", sym->name) == 0) + { + gfc_error ("Procedure pointer result %qs at %L " + "is missing the pointer attribute", + sym->ns->proc_name->name, &sym->declared_at); + return false; + } + } + + /* Assume that a procedure whose body is not known has references + to external arrays. */ + if (sym->attr.if_source != IFSRC_DECL) + sym->attr.array_outer_dependency = 1; + + /* Compare the characteristics of a module procedure with the + interface declaration. Ideally this would be done with + gfc_compare_interfaces but, at present, the formal interface + cannot be copied to the ts.interface. */ + if (sym->attr.module_procedure + && sym->attr.if_source == IFSRC_DECL) + { + gfc_symbol *iface; + char name[2*GFC_MAX_SYMBOL_LEN + 1]; + char *module_name; + char *submodule_name; + strcpy (name, sym->ns->proc_name->name); + module_name = strtok (name, "."); + submodule_name = strtok (NULL, "."); + + iface = sym->tlink; + sym->tlink = NULL; + + /* Make sure that the result uses the correct charlen for deferred + length results. */ + if (iface && sym->result + && iface->ts.type == BT_CHARACTER + && iface->ts.deferred) + sym->result->ts.u.cl = iface->ts.u.cl; + + if (iface == NULL) + goto check_formal; + + /* Check the procedure characteristics. */ + if (sym->attr.elemental != iface->attr.elemental) + { + gfc_error ("Mismatch in ELEMENTAL attribute between MODULE " + "PROCEDURE at %L and its interface in %s", + &sym->declared_at, module_name); + return false; + } + + if (sym->attr.pure != iface->attr.pure) + { + gfc_error ("Mismatch in PURE attribute between MODULE " + "PROCEDURE at %L and its interface in %s", + &sym->declared_at, module_name); + return false; + } + + if (sym->attr.recursive != iface->attr.recursive) + { + gfc_error ("Mismatch in RECURSIVE attribute between MODULE " + "PROCEDURE at %L and its interface in %s", + &sym->declared_at, module_name); + return false; + } + + /* Check the result characteristics. */ + if (!gfc_check_result_characteristics (sym, iface, errmsg, 200)) + { + gfc_error ("%s between the MODULE PROCEDURE declaration " + "in MODULE %qs and the declaration at %L in " + "(SUB)MODULE %qs", + errmsg, module_name, &sym->declared_at, + submodule_name ? submodule_name : module_name); + return false; + } + +check_formal: + /* Check the characteristics of the formal arguments. */ + if (sym->formal && sym->formal_ns) + { + for (arg = sym->formal; arg && arg->sym; arg = arg->next) + { + new_formal = arg; + gfc_traverse_ns (sym->formal_ns, compare_fsyms); + } + } + } + return true; +} + + +/* Resolve a list of finalizer procedures. That is, after they have hopefully + been defined and we now know their defined arguments, check that they fulfill + the requirements of the standard for procedures used as finalizers. */ + +static bool +gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) +{ + gfc_finalizer* list; + gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ + bool result = true; + bool seen_scalar = false; + gfc_symbol *vtab; + gfc_component *c; + gfc_symbol *parent = gfc_get_derived_super_type (derived); + + if (parent) + gfc_resolve_finalizers (parent, finalizable); + + /* Ensure that derived-type components have a their finalizers resolved. */ + bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers; + for (c = derived->components; c; c = c->next) + if (c->ts.type == BT_DERIVED + && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable) + { + bool has_final2 = false; + if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2)) + return false; /* Error. */ + has_final = has_final || has_final2; + } + /* Return early if not finalizable. */ + if (!has_final) + { + if (finalizable) + *finalizable = false; + return true; + } + + /* Walk over the list of finalizer-procedures, check them, and if any one + does not fit in with the standard's definition, print an error and remove + it from the list. */ + prev_link = &derived->f2k_derived->finalizers; + for (list = derived->f2k_derived->finalizers; list; list = *prev_link) + { + gfc_formal_arglist *dummy_args; + gfc_symbol* arg; + gfc_finalizer* i; + int my_rank; + + /* Skip this finalizer if we already resolved it. */ + if (list->proc_tree) + { + if (list->proc_tree->n.sym->formal->sym->as == NULL + || list->proc_tree->n.sym->formal->sym->as->rank == 0) + seen_scalar = true; + prev_link = &(list->next); + continue; + } + + /* Check this exists and is a SUBROUTINE. */ + if (!list->proc_sym->attr.subroutine) + { + gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE", + list->proc_sym->name, &list->where); + goto error; + } + + /* We should have exactly one argument. */ + dummy_args = gfc_sym_get_dummy_args (list->proc_sym); + if (!dummy_args || dummy_args->next) + { + gfc_error ("FINAL procedure at %L must have exactly one argument", + &list->where); + goto error; + } + arg = dummy_args->sym; + + /* This argument must be of our type. */ + if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) + { + gfc_error ("Argument of FINAL procedure at %L must be of type %qs", + &arg->declared_at, derived->name); + goto error; + } + + /* It must neither be a pointer nor allocatable nor optional. */ + if (arg->attr.pointer) + { + gfc_error ("Argument of FINAL procedure at %L must not be a POINTER", + &arg->declared_at); + goto error; + } + if (arg->attr.allocatable) + { + gfc_error ("Argument of FINAL procedure at %L must not be" + " ALLOCATABLE", &arg->declared_at); + goto error; + } + if (arg->attr.optional) + { + gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL", + &arg->declared_at); + goto error; + } + + /* It must not be INTENT(OUT). */ + if (arg->attr.intent == INTENT_OUT) + { + gfc_error ("Argument of FINAL procedure at %L must not be" + " INTENT(OUT)", &arg->declared_at); + goto error; + } + + /* Warn if the procedure is non-scalar and not assumed shape. */ + if (warn_surprising && arg->as && arg->as->rank != 0 + && arg->as->type != AS_ASSUMED_SHAPE) + gfc_warning (OPT_Wsurprising, + "Non-scalar FINAL procedure at %L should have assumed" + " shape argument", &arg->declared_at); + + /* Check that it does not match in kind and rank with a FINAL procedure + defined earlier. To really loop over the *earlier* declarations, + we need to walk the tail of the list as new ones were pushed at the + front. */ + /* TODO: Handle kind parameters once they are implemented. */ + my_rank = (arg->as ? arg->as->rank : 0); + for (i = list->next; i; i = i->next) + { + gfc_formal_arglist *dummy_args; + + /* Argument list might be empty; that is an error signalled earlier, + but we nevertheless continued resolving. */ + dummy_args = gfc_sym_get_dummy_args (i->proc_sym); + if (dummy_args) + { + gfc_symbol* i_arg = dummy_args->sym; + const int i_rank = (i_arg->as ? i_arg->as->rank : 0); + if (i_rank == my_rank) + { + gfc_error ("FINAL procedure %qs declared at %L has the same" + " rank (%d) as %qs", + list->proc_sym->name, &list->where, my_rank, + i->proc_sym->name); + goto error; + } + } + } + + /* Is this the/a scalar finalizer procedure? */ + if (my_rank == 0) + seen_scalar = true; + + /* Find the symtree for this procedure. */ + gcc_assert (!list->proc_tree); + list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); + + prev_link = &list->next; + continue; + + /* Remove wrong nodes immediately from the list so we don't risk any + troubles in the future when they might fail later expectations. */ +error: + i = list; + *prev_link = list->next; + gfc_free_finalizer (i); + result = false; + } + + if (result == false) + return false; + + /* Warn if we haven't seen a scalar finalizer procedure (but we know there + were nodes in the list, must have been for arrays. It is surely a good + idea to have a scalar version there if there's something to finalize. */ + if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar) + gfc_warning (OPT_Wsurprising, + "Only array FINAL procedures declared for derived type %qs" + " defined at %L, suggest also scalar one", + derived->name, &derived->declared_at); + + vtab = gfc_find_derived_vtab (derived); + c = vtab->ts.u.derived->components->next->next->next->next->next; + gfc_set_sym_referenced (c->initializer->symtree->n.sym); + + if (finalizable) + *finalizable = true; + + return true; +} + + +/* Check if two GENERIC targets are ambiguous and emit an error is they are. */ + +static bool +check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, + const char* generic_name, locus where) +{ + gfc_symbol *sym1, *sym2; + const char *pass1, *pass2; + gfc_formal_arglist *dummy_args; + + gcc_assert (t1->specific && t2->specific); + gcc_assert (!t1->specific->is_generic); + gcc_assert (!t2->specific->is_generic); + gcc_assert (t1->is_operator == t2->is_operator); + + sym1 = t1->specific->u.specific->n.sym; + sym2 = t2->specific->u.specific->n.sym; + + if (sym1 == sym2) + return true; + + /* Both must be SUBROUTINEs or both must be FUNCTIONs. */ + if (sym1->attr.subroutine != sym2->attr.subroutine + || sym1->attr.function != sym2->attr.function) + { + gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for" + " GENERIC %qs at %L", + sym1->name, sym2->name, generic_name, &where); + return false; + } + + /* Determine PASS arguments. */ + if (t1->specific->nopass) + pass1 = NULL; + else if (t1->specific->pass_arg) + pass1 = t1->specific->pass_arg; + else + { + dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym); + if (dummy_args) + pass1 = dummy_args->sym->name; + else + pass1 = NULL; + } + if (t2->specific->nopass) + pass2 = NULL; + else if (t2->specific->pass_arg) + pass2 = t2->specific->pass_arg; + else + { + dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym); + if (dummy_args) + pass2 = dummy_args->sym->name; + else + pass2 = NULL; + } + + /* Compare the interfaces. */ + if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, + NULL, 0, pass1, pass2)) + { + gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous", + sym1->name, sym2->name, generic_name, &where); + return false; + } + + return true; +} + + +/* Worker function for resolving a generic procedure binding; this is used to + resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures. + + The difference between those cases is finding possible inherited bindings + that are overridden, as one has to look for them in tb_sym_root, + tb_uop_root or tb_op, respectively. Thus the caller must already find + the super-type and set p->overridden correctly. */ + +static bool +resolve_tb_generic_targets (gfc_symbol* super_type, + gfc_typebound_proc* p, const char* name) +{ + gfc_tbp_generic* target; + gfc_symtree* first_target; + gfc_symtree* inherited; + + gcc_assert (p && p->is_generic); + + /* Try to find the specific bindings for the symtrees in our target-list. */ + gcc_assert (p->u.generic); + for (target = p->u.generic; target; target = target->next) + if (!target->specific) + { + gfc_typebound_proc* overridden_tbp; + gfc_tbp_generic* g; + const char* target_name; + + target_name = target->specific_st->name; + + /* Defined for this type directly. */ + if (target->specific_st->n.tb && !target->specific_st->n.tb->error) + { + target->specific = target->specific_st->n.tb; + goto specific_found; + } + + /* Look for an inherited specific binding. */ + if (super_type) + { + inherited = gfc_find_typebound_proc (super_type, NULL, target_name, + true, NULL); + + if (inherited) + { + gcc_assert (inherited->n.tb); + target->specific = inherited->n.tb; + goto specific_found; + } + } + + gfc_error ("Undefined specific binding %qs as target of GENERIC %qs" + " at %L", target_name, name, &p->where); + return false; + + /* Once we've found the specific binding, check it is not ambiguous with + other specifics already found or inherited for the same GENERIC. */ +specific_found: + gcc_assert (target->specific); + + /* This must really be a specific binding! */ + if (target->specific->is_generic) + { + gfc_error ("GENERIC %qs at %L must target a specific binding," + " %qs is GENERIC, too", name, &p->where, target_name); + return false; + } + + /* Check those already resolved on this type directly. */ + for (g = p->u.generic; g; g = g->next) + if (g != target && g->specific + && !check_generic_tbp_ambiguity (target, g, name, p->where)) + return false; + + /* Check for ambiguity with inherited specific targets. */ + for (overridden_tbp = p->overridden; overridden_tbp; + overridden_tbp = overridden_tbp->overridden) + if (overridden_tbp->is_generic) + { + for (g = overridden_tbp->u.generic; g; g = g->next) + { + gcc_assert (g->specific); + if (!check_generic_tbp_ambiguity (target, g, name, p->where)) + return false; + } + } + } + + /* If we attempt to "overwrite" a specific binding, this is an error. */ + if (p->overridden && !p->overridden->is_generic) + { + gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with" + " the same name", name, &p->where); + return false; + } + + /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as + all must have the same attributes here. */ + first_target = p->u.generic->specific->u.specific; + gcc_assert (first_target); + p->subroutine = first_target->n.sym->attr.subroutine; + p->function = first_target->n.sym->attr.function; + + return true; +} + + +/* Resolve a GENERIC procedure binding for a derived type. */ + +static bool +resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) +{ + gfc_symbol* super_type; + + /* Find the overridden binding if any. */ + st->n.tb->overridden = NULL; + super_type = gfc_get_derived_super_type (derived); + if (super_type) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_proc (super_type, NULL, st->name, + true, NULL); + + if (overridden && overridden->n.tb) + st->n.tb->overridden = overridden->n.tb; + } + + /* Resolve using worker function. */ + return resolve_tb_generic_targets (super_type, st->n.tb, st->name); +} + + +/* Retrieve the target-procedure of an operator binding and do some checks in + common for intrinsic and user-defined type-bound operators. */ + +static gfc_symbol* +get_checked_tb_operator_target (gfc_tbp_generic* target, locus where) +{ + gfc_symbol* target_proc; + + gcc_assert (target->specific && !target->specific->is_generic); + target_proc = target->specific->u.specific->n.sym; + gcc_assert (target_proc); + + /* F08:C468. All operator bindings must have a passed-object dummy argument. */ + if (target->specific->nopass) + { + gfc_error ("Type-bound operator at %L cannot be NOPASS", &where); + return NULL; + } + + return target_proc; +} + + +/* Resolve a type-bound intrinsic operator. */ + +static bool +resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, + gfc_typebound_proc* p) +{ + gfc_symbol* super_type; + gfc_tbp_generic* target; + + /* If there's already an error here, do nothing (but don't fail again). */ + if (p->error) + return true; + + /* Operators should always be GENERIC bindings. */ + gcc_assert (p->is_generic); + + /* Look for an overridden binding. */ + super_type = gfc_get_derived_super_type (derived); + if (super_type && super_type->f2k_derived) + p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL, + op, true, NULL); + else + p->overridden = NULL; + + /* Resolve general GENERIC properties using worker function. */ + if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op))) + goto error; + + /* Check the targets to be procedures of correct interface. */ + for (target = p->u.generic; target; target = target->next) + { + gfc_symbol* target_proc; + + target_proc = get_checked_tb_operator_target (target, p->where); + if (!target_proc) + goto error; + + if (!gfc_check_operator_interface (target_proc, op, p->where)) + goto error; + + /* Add target to non-typebound operator list. */ + if (!target->specific->deferred && !derived->attr.use_assoc + && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns) + { + gfc_interface *head, *intr; + + /* Preempt 'gfc_check_new_interface' for submodules, where the + mechanism for handling module procedures winds up resolving + operator interfaces twice and would otherwise cause an error. */ + for (intr = derived->ns->op[op]; intr; intr = intr->next) + if (intr->sym == target_proc + && target_proc->attr.used_in_submodule) + return true; + + if (!gfc_check_new_interface (derived->ns->op[op], + target_proc, p->where)) + return false; + head = derived->ns->op[op]; + intr = gfc_get_interface (); + intr->sym = target_proc; + intr->where = p->where; + intr->next = head; + derived->ns->op[op] = intr; + } + } + + return true; + +error: + p->error = 1; + return false; +} + + +/* Resolve a type-bound user operator (tree-walker callback). */ + +static gfc_symbol* resolve_bindings_derived; +static bool resolve_bindings_result; + +static bool check_uop_procedure (gfc_symbol* sym, locus where); + +static void +resolve_typebound_user_op (gfc_symtree* stree) +{ + gfc_symbol* super_type; + gfc_tbp_generic* target; + + gcc_assert (stree && stree->n.tb); + + if (stree->n.tb->error) + return; + + /* Operators should always be GENERIC bindings. */ + gcc_assert (stree->n.tb->is_generic); + + /* Find overridden procedure, if any. */ + super_type = gfc_get_derived_super_type (resolve_bindings_derived); + if (super_type && super_type->f2k_derived) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_user_op (super_type, NULL, + stree->name, true, NULL); + + if (overridden && overridden->n.tb) + stree->n.tb->overridden = overridden->n.tb; + } + else + stree->n.tb->overridden = NULL; + + /* Resolve basically using worker function. */ + if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)) + goto error; + + /* Check the targets to be functions of correct interface. */ + for (target = stree->n.tb->u.generic; target; target = target->next) + { + gfc_symbol* target_proc; + + target_proc = get_checked_tb_operator_target (target, stree->n.tb->where); + if (!target_proc) + goto error; + + if (!check_uop_procedure (target_proc, stree->n.tb->where)) + goto error; + } + + return; + +error: + resolve_bindings_result = false; + stree->n.tb->error = 1; +} + + +/* Resolve the type-bound procedures for a derived type. */ + +static void +resolve_typebound_procedure (gfc_symtree* stree) +{ + gfc_symbol* proc; + locus where; + gfc_symbol* me_arg; + gfc_symbol* super_type; + gfc_component* comp; + + gcc_assert (stree); + + /* Undefined specific symbol from GENERIC target definition. */ + if (!stree->n.tb) + return; + + if (stree->n.tb->error) + return; + + /* If this is a GENERIC binding, use that routine. */ + if (stree->n.tb->is_generic) + { + if (!resolve_typebound_generic (resolve_bindings_derived, stree)) + goto error; + return; + } + + /* Get the target-procedure to check it. */ + gcc_assert (!stree->n.tb->is_generic); + gcc_assert (stree->n.tb->u.specific); + proc = stree->n.tb->u.specific->n.sym; + where = stree->n.tb->where; + + /* Default access should already be resolved from the parser. */ + gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN); + + if (stree->n.tb->deferred) + { + if (!check_proc_interface (proc, &where)) + goto error; + } + else + { + /* If proc has not been resolved at this point, proc->name may + actually be a USE associated entity. See PR fortran/89647. */ + if (!proc->resolve_symbol_called + && proc->attr.function == 0 && proc->attr.subroutine == 0) + { + gfc_symbol *tmp; + gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp); + if (tmp && tmp->attr.use_assoc) + { + proc->module = tmp->module; + proc->attr.proc = tmp->attr.proc; + proc->attr.function = tmp->attr.function; + proc->attr.subroutine = tmp->attr.subroutine; + proc->attr.use_assoc = tmp->attr.use_assoc; + proc->ts = tmp->ts; + proc->result = tmp->result; + } + } + + /* Check for F08:C465. */ + if ((!proc->attr.subroutine && !proc->attr.function) + || (proc->attr.proc != PROC_MODULE + && proc->attr.if_source != IFSRC_IFBODY + && !proc->attr.module_procedure) + || proc->attr.abstract) + { + gfc_error ("%qs must be a module procedure or an external " + "procedure with an explicit interface at %L", + proc->name, &where); + goto error; + } + } + + stree->n.tb->subroutine = proc->attr.subroutine; + stree->n.tb->function = proc->attr.function; + + /* Find the super-type of the current derived type. We could do this once and + store in a global if speed is needed, but as long as not I believe this is + more readable and clearer. */ + super_type = gfc_get_derived_super_type (resolve_bindings_derived); + + /* If PASS, resolve and check arguments if not already resolved / loaded + from a .mod file. */ + if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0) + { + gfc_formal_arglist *dummy_args; + + dummy_args = gfc_sym_get_dummy_args (proc); + if (stree->n.tb->pass_arg) + { + gfc_formal_arglist *i; + + /* If an explicit passing argument name is given, walk the arg-list + and look for it. */ + + me_arg = NULL; + stree->n.tb->pass_arg_num = 1; + for (i = dummy_args; i; i = i->next) + { + if (!strcmp (i->sym->name, stree->n.tb->pass_arg)) + { + me_arg = i->sym; + break; + } + ++stree->n.tb->pass_arg_num; + } + + if (!me_arg) + { + gfc_error ("Procedure %qs with PASS(%s) at %L has no" + " argument %qs", + proc->name, stree->n.tb->pass_arg, &where, + stree->n.tb->pass_arg); + goto error; + } + } + else + { + /* Otherwise, take the first one; there should in fact be at least + one. */ + stree->n.tb->pass_arg_num = 1; + if (!dummy_args) + { + gfc_error ("Procedure %qs with PASS at %L must have at" + " least one argument", proc->name, &where); + goto error; + } + me_arg = dummy_args->sym; + } + + /* Now check that the argument-type matches and the passed-object + dummy argument is generally fine. */ + + gcc_assert (me_arg); + + if (me_arg->ts.type != BT_CLASS) + { + gfc_error ("Non-polymorphic passed-object dummy argument of %qs" + " at %L", proc->name, &where); + goto error; + } + + if (CLASS_DATA (me_arg)->ts.u.derived + != resolve_bindings_derived) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the derived-type %qs", me_arg->name, proc->name, + me_arg->name, &where, resolve_bindings_derived->name); + goto error; + } + + gcc_assert (me_arg->ts.type == BT_CLASS); + if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) + { + gfc_error ("Passed-object dummy argument of %qs at %L must be" + " scalar", proc->name, &where); + goto error; + } + if (CLASS_DATA (me_arg)->attr.allocatable) + { + gfc_error ("Passed-object dummy argument of %qs at %L must not" + " be ALLOCATABLE", proc->name, &where); + goto error; + } + if (CLASS_DATA (me_arg)->attr.class_pointer) + { + gfc_error ("Passed-object dummy argument of %qs at %L must not" + " be POINTER", proc->name, &where); + goto error; + } + } + + /* If we are extending some type, check that we don't override a procedure + flagged NON_OVERRIDABLE. */ + stree->n.tb->overridden = NULL; + if (super_type) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_proc (super_type, NULL, + stree->name, true, NULL); + + if (overridden) + { + if (overridden->n.tb) + stree->n.tb->overridden = overridden->n.tb; + + if (!gfc_check_typebound_override (stree, overridden)) + goto error; + } + } + + /* See if there's a name collision with a component directly in this type. */ + for (comp = resolve_bindings_derived->components; comp; comp = comp->next) + if (!strcmp (comp->name, stree->name)) + { + gfc_error ("Procedure %qs at %L has the same name as a component of" + " %qs", + stree->name, &where, resolve_bindings_derived->name); + goto error; + } + + /* Try to find a name collision with an inherited component. */ + if (super_type && gfc_find_component (super_type, stree->name, true, true, + NULL)) + { + gfc_error ("Procedure %qs at %L has the same name as an inherited" + " component of %qs", + stree->name, &where, resolve_bindings_derived->name); + goto error; + } + + stree->n.tb->error = 0; + return; + +error: + resolve_bindings_result = false; + stree->n.tb->error = 1; +} + + +static bool +resolve_typebound_procedures (gfc_symbol* derived) +{ + int op; + gfc_symbol* super_type; + + if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) + return true; + + super_type = gfc_get_derived_super_type (derived); + if (super_type) + resolve_symbol (super_type); + + resolve_bindings_derived = derived; + resolve_bindings_result = true; + + if (derived->f2k_derived->tb_sym_root) + gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, + &resolve_typebound_procedure); + + if (derived->f2k_derived->tb_uop_root) + gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, + &resolve_typebound_user_op); + + for (op = 0; op != GFC_INTRINSIC_OPS; ++op) + { + gfc_typebound_proc* p = derived->f2k_derived->tb_op[op]; + if (p && !resolve_typebound_intrinsic_op (derived, + (gfc_intrinsic_op)op, p)) + resolve_bindings_result = false; + } + + return resolve_bindings_result; +} + + +/* Add a derived type to the dt_list. The dt_list is used in trans-types.c + to give all identical derived types the same backend_decl. */ +static void +add_dt_to_dt_list (gfc_symbol *derived) +{ + if (!derived->dt_next) + { + if (gfc_derived_types) + { + derived->dt_next = gfc_derived_types->dt_next; + gfc_derived_types->dt_next = derived; + } + else + { + derived->dt_next = derived; + } + gfc_derived_types = derived; + } +} + + +/* Ensure that a derived-type is really not abstract, meaning that every + inherited DEFERRED binding is overridden by a non-DEFERRED one. */ + +static bool +ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) +{ + if (!st) + return true; + + if (!ensure_not_abstract_walker (sub, st->left)) + return false; + if (!ensure_not_abstract_walker (sub, st->right)) + return false; + + if (st->n.tb && st->n.tb->deferred) + { + gfc_symtree* overriding; + overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); + if (!overriding) + return false; + gcc_assert (overriding->n.tb); + if (overriding->n.tb->deferred) + { + gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because" + " %qs is DEFERRED and not overridden", + sub->name, &sub->declared_at, st->name); + return false; + } + } + + return true; +} + +static bool +ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) +{ + /* The algorithm used here is to recursively travel up the ancestry of sub + and for each ancestor-type, check all bindings. If any of them is + DEFERRED, look it up starting from sub and see if the found (overriding) + binding is not DEFERRED. + This is not the most efficient way to do this, but it should be ok and is + clearer than something sophisticated. */ + + gcc_assert (ancestor && !sub->attr.abstract); + + if (!ancestor->attr.abstract) + return true; + + /* Walk bindings of this ancestor. */ + if (ancestor->f2k_derived) + { + bool t; + t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root); + if (!t) + return false; + } + + /* Find next ancestor type and recurse on it. */ + ancestor = gfc_get_derived_super_type (ancestor); + if (ancestor) + return ensure_not_abstract (sub, ancestor); + + return true; +} + + +/* This check for typebound defined assignments is done recursively + since the order in which derived types are resolved is not always in + order of the declarations. */ + +static void +check_defined_assignments (gfc_symbol *derived) +{ + gfc_component *c; + + for (c = derived->components; c; c = c->next) + { + if (!gfc_bt_struct (c->ts.type) + || c->attr.pointer + || c->attr.allocatable + || c->attr.proc_pointer_comp + || c->attr.class_pointer + || c->attr.proc_pointer) + continue; + + if (c->ts.u.derived->attr.defined_assign_comp + || (c->ts.u.derived->f2k_derived + && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN])) + { + derived->attr.defined_assign_comp = 1; + return; + } + + check_defined_assignments (c->ts.u.derived); + if (c->ts.u.derived->attr.defined_assign_comp) + { + derived->attr.defined_assign_comp = 1; + return; + } + } +} + + +/* Resolve a single component of a derived type or structure. */ + +static bool +resolve_component (gfc_component *c, gfc_symbol *sym) +{ + gfc_symbol *super_type; + symbol_attribute *attr; + + if (c->attr.artificial) + return true; + + /* Do not allow vtype components to be resolved in nameless namespaces + such as block data because the procedure pointers will cause ICEs + and vtables are not needed in these contexts. */ + if (sym->attr.vtype && sym->attr.use_assoc + && sym->ns->proc_name == NULL) + return true; + + /* F2008, C442. */ + if ((!sym->attr.is_class || c != sym->components) + && c->attr.codimension + && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) + { + gfc_error ("Coarray component %qs at %L must be allocatable with " + "deferred shape", c->name, &c->loc); + return false; + } + + /* F2008, C443. */ + if (c->attr.codimension && c->ts.type == BT_DERIVED + && c->ts.u.derived->ts.is_iso_c) + { + gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", c->name, &c->loc); + return false; + } + + /* F2008, C444. */ + if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp + && (c->attr.codimension || c->attr.pointer || c->attr.dimension + || c->attr.allocatable)) + { + gfc_error ("Component %qs at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + c->name, &c->loc); + return false; + } + + /* F2008, C448. */ + if (c->ts.type == BT_CLASS) + { + if (c->attr.class_ok && CLASS_DATA (c)) + { + attr = &(CLASS_DATA (c)->attr); + + /* Fix up contiguous attribute. */ + if (c->attr.contiguous) + attr->contiguous = 1; + } + else + attr = NULL; + } + else + attr = &c->attr; + + if (attr && attr->contiguous && (!attr->dimension || !attr->pointer)) + { + gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); + return false; + } + + /* F2003, 15.2.1 - length has to be one. */ + if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER + && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL + || !gfc_is_constant_expr (c->ts.u.cl->length) + || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0)) + { + gfc_error ("Component %qs of BIND(C) type at %L must have length one", + c->name, &c->loc); + return false; + } + + if (c->attr.proc_pointer && c->ts.interface) + { + gfc_symbol *ifc = c->ts.interface; + + if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc)) + { + c->tb->error = 1; + return false; + } + + if (ifc->attr.if_source || ifc->attr.intrinsic) + { + /* Resolve interface and copy attributes. */ + if (ifc->formal && !ifc->formal_ns) + resolve_symbol (ifc); + if (ifc->attr.intrinsic) + gfc_resolve_intrinsic (ifc, &ifc->declared_at); + + if (ifc->result) + { + c->ts = ifc->result->ts; + c->attr.allocatable = ifc->result->attr.allocatable; + c->attr.pointer = ifc->result->attr.pointer; + c->attr.dimension = ifc->result->attr.dimension; + c->as = gfc_copy_array_spec (ifc->result->as); + c->attr.class_ok = ifc->result->attr.class_ok; + } + else + { + c->ts = ifc->ts; + c->attr.allocatable = ifc->attr.allocatable; + c->attr.pointer = ifc->attr.pointer; + c->attr.dimension = ifc->attr.dimension; + c->as = gfc_copy_array_spec (ifc->as); + c->attr.class_ok = ifc->attr.class_ok; + } + c->ts.interface = ifc; + c->attr.function = ifc->attr.function; + c->attr.subroutine = ifc->attr.subroutine; + + c->attr.pure = ifc->attr.pure; + c->attr.elemental = ifc->attr.elemental; + c->attr.recursive = ifc->attr.recursive; + c->attr.always_explicit = ifc->attr.always_explicit; + c->attr.ext_attr |= ifc->attr.ext_attr; + /* Copy char length. */ + if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) + { + gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); + if (cl->length && !cl->resolved + && !gfc_resolve_expr (cl->length)) + { + c->tb->error = 1; + return false; + } + c->ts.u.cl = cl; + } + } + } + else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) + { + /* Since PPCs are not implicitly typed, a PPC without an explicit + interface must be a subroutine. */ + gfc_add_subroutine (&c->attr, c->name, &c->loc); + } + + /* Procedure pointer components: Check PASS arg. */ + if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 + && !sym->attr.vtype) + { + gfc_symbol* me_arg; + + if (c->tb->pass_arg) + { + gfc_formal_arglist* i; + + /* If an explicit passing argument name is given, walk the arg-list + and look for it. */ + + me_arg = NULL; + c->tb->pass_arg_num = 1; + for (i = c->ts.interface->formal; i; i = i->next) + { + if (!strcmp (i->sym->name, c->tb->pass_arg)) + { + me_arg = i->sym; + break; + } + c->tb->pass_arg_num++; + } + + if (!me_arg) + { + gfc_error ("Procedure pointer component %qs with PASS(%s) " + "at %L has no argument %qs", c->name, + c->tb->pass_arg, &c->loc, c->tb->pass_arg); + c->tb->error = 1; + return false; + } + } + else + { + /* Otherwise, take the first one; there should in fact be at least + one. */ + c->tb->pass_arg_num = 1; + if (!c->ts.interface->formal) + { + gfc_error ("Procedure pointer component %qs with PASS at %L " + "must have at least one argument", + c->name, &c->loc); + c->tb->error = 1; + return false; + } + me_arg = c->ts.interface->formal->sym; + } + + /* Now check that the argument-type matches. */ + gcc_assert (me_arg); + if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) + || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) + || (me_arg->ts.type == BT_CLASS + && CLASS_DATA (me_arg)->ts.u.derived != sym)) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" + " the derived type %qs", me_arg->name, c->name, + me_arg->name, &c->loc, sym->name); + c->tb->error = 1; + return false; + } + + /* Check for F03:C453. */ + if (CLASS_DATA (me_arg)->attr.dimension) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "must be scalar", me_arg->name, c->name, me_arg->name, + &c->loc); + c->tb->error = 1; + return false; + } + + if (CLASS_DATA (me_arg)->attr.class_pointer) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "may not have the POINTER attribute", me_arg->name, + c->name, me_arg->name, &c->loc); + c->tb->error = 1; + return false; + } + + if (CLASS_DATA (me_arg)->attr.allocatable) + { + gfc_error ("Argument %qs of %qs with PASS(%s) at %L " + "may not be ALLOCATABLE", me_arg->name, c->name, + me_arg->name, &c->loc); + c->tb->error = 1; + return false; + } + + if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) + { + gfc_error ("Non-polymorphic passed-object dummy argument of %qs" + " at %L", c->name, &c->loc); + return false; + } + + } + + /* Check type-spec if this is not the parent-type component. */ + if (((sym->attr.is_class + && (!sym->components->ts.u.derived->attr.extension + || c != sym->components->ts.u.derived->components)) + || (!sym->attr.is_class + && (!sym->attr.extension || c != sym->components))) + && !sym->attr.vtype + && !resolve_typespec_used (&c->ts, &c->loc, c->name)) + return false; + + super_type = gfc_get_derived_super_type (sym); + + /* If this type is an extension, set the accessibility of the parent + component. */ + if (super_type + && ((sym->attr.is_class + && c == sym->components->ts.u.derived->components) + || (!sym->attr.is_class && c == sym->components)) + && strcmp (super_type->name, c->name) == 0) + c->attr.access = super_type->attr.access; + + /* If this type is an extension, see if this component has the same name + as an inherited type-bound procedure. */ + if (super_type && !sym->attr.is_class + && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) + { + gfc_error ("Component %qs of %qs at %L has the same name as an" + " inherited type-bound procedure", + c->name, sym->name, &c->loc); + return false; + } + + if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer + && !c->ts.deferred) + { + if (c->ts.u.cl->length == NULL + || (!resolve_charlen(c->ts.u.cl)) + || !gfc_is_constant_expr (c->ts.u.cl->length)) + { + gfc_error ("Character length of component %qs needs to " + "be a constant specification expression at %L", + c->name, + c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); + return false; + } + } + + if (c->ts.type == BT_CHARACTER && c->ts.deferred + && !c->attr.pointer && !c->attr.allocatable) + { + gfc_error ("Character component %qs of %qs at %L with deferred " + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); + return false; + } + + /* Add the hidden deferred length field. */ + if (c->ts.type == BT_CHARACTER + && (c->ts.deferred || c->attr.pdt_string) + && !c->attr.function + && !sym->attr.is_class) + { + char name[GFC_MAX_SYMBOL_LEN+9]; + gfc_component *strlen; + sprintf (name, "_%s_length", c->name); + strlen = gfc_find_component (sym, name, true, true, NULL); + if (strlen == NULL) + { + if (!gfc_add_component (sym, name, &strlen)) + return false; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.artificial = 1; + } + } + + if (c->ts.type == BT_DERIVED + && sym->component_access != ACCESS_PRIVATE + && gfc_check_symbol_access (sym) + && !is_sym_host_assoc (c->ts.u.derived, sym->ns) + && !c->ts.u.derived->attr.use_assoc + && !gfc_check_symbol_access (c->ts.u.derived) + && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " + "PRIVATE type and cannot be a component of " + "%qs, which is PUBLIC at %L", c->name, + sym->name, &sym->declared_at)) + return false; + + if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " + "type %s", c->name, &c->loc, sym->name); + return false; + } + + if (sym->attr.sequence) + { + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) + { + gfc_error ("Component %s of SEQUENCE type declared at %L does " + "not have the SEQUENCE attribute", + c->ts.u.derived->name, &sym->declared_at); + return false; + } + } + + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) + c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); + else if (c->ts.type == BT_CLASS && c->attr.class_ok + && CLASS_DATA (c)->ts.u.derived->attr.generic) + CLASS_DATA (c)->ts.u.derived + = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); + + /* If an allocatable component derived type is of the same type as + the enclosing derived type, we need a vtable generating so that + the __deallocate procedure is created. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && c->ts.u.derived == sym && c->attr.allocatable == 1) + gfc_find_vtab (&c->ts); + + /* Ensure that all the derived type components are put on the + derived type list; even in formal namespaces, where derived type + pointer components might not have been declared. */ + if (c->ts.type == BT_DERIVED + && c->ts.u.derived + && c->ts.u.derived->components + && c->attr.pointer + && sym != c->ts.u.derived) + add_dt_to_dt_list (c->ts.u.derived); + + if (c->as && c->as->type != AS_DEFERRED + && (c->attr.pointer || c->attr.allocatable)) + return false; + + if (!gfc_resolve_array_spec (c->as, + !(c->attr.pointer || c->attr.proc_pointer + || c->attr.allocatable))) + return false; + + if (c->initializer && !sym->attr.vtype + && !c->attr.pdt_kind && !c->attr.pdt_len + && !gfc_check_assign_symbol (sym, c, c->initializer)) + return false; + + return true; +} + + +/* Be nice about the locus for a structure expression - show the locus of the + first non-null sub-expression if we can. */ + +static locus * +cons_where (gfc_expr *struct_expr) +{ + gfc_constructor *cons; + + gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE); + + cons = gfc_constructor_first (struct_expr->value.constructor); + for (; cons; cons = gfc_constructor_next (cons)) + { + if (cons->expr && cons->expr->expr_type != EXPR_NULL) + return &cons->expr->where; + } + + return &struct_expr->where; +} + +/* Resolve the components of a structure type. Much less work than derived + types. */ + +static bool +resolve_fl_struct (gfc_symbol *sym) +{ + gfc_component *c; + gfc_expr *init = NULL; + bool success; + + /* Make sure UNIONs do not have overlapping initializers. */ + if (sym->attr.flavor == FL_UNION) + { + for (c = sym->components; c; c = c->next) + { + if (init && c->initializer) + { + gfc_error ("Conflicting initializers in union at %L and %L", + cons_where (init), cons_where (c->initializer)); + gfc_free_expr (c->initializer); + c->initializer = NULL; + } + if (init == NULL) + init = c->initializer; + } + } + + success = true; + for (c = sym->components; c; c = c->next) + if (!resolve_component (c, sym)) + success = false; + + if (!success) + return false; + + if (sym->components) + add_dt_to_dt_list (sym); + + return true; +} + + +/* Resolve the components of a derived type. This does not have to wait until + resolution stage, but can be done as soon as the dt declaration has been + parsed. */ + +static bool +resolve_fl_derived0 (gfc_symbol *sym) +{ + gfc_symbol* super_type; + gfc_component *c; + gfc_formal_arglist *f; + bool success; + + if (sym->attr.unlimited_polymorphic) + return true; + + super_type = gfc_get_derived_super_type (sym); + + /* F2008, C432. */ + if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + { + gfc_error ("As extending type %qs at %L has a coarray component, " + "parent type %qs shall also have one", sym->name, + &sym->declared_at, super_type->name); + return false; + } + + /* Ensure the extended type gets resolved before we do. */ + if (super_type && !resolve_fl_derived0 (super_type)) + return false; + + /* An ABSTRACT type must be extensible. */ + if (sym->attr.abstract && !gfc_type_is_extensible (sym)) + { + gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", + sym->name, &sym->declared_at); + return false; + } + + c = (sym->attr.is_class) ? sym->components->ts.u.derived->components + : sym->components; + + success = true; + for ( ; c != NULL; c = c->next) + if (!resolve_component (c, sym)) + success = false; + + if (!success) + return false; + + /* Now add the caf token field, where needed. */ + if (flag_coarray != GFC_FCOARRAY_NONE + && !sym->attr.is_class && !sym->attr.vtype) + { + for (c = sym->components; c; c = c->next) + if (!c->attr.dimension && !c->attr.codimension + && (c->attr.allocatable || c->attr.pointer)) + { + char name[GFC_MAX_SYMBOL_LEN+9]; + gfc_component *token; + sprintf (name, "_caf_%s", c->name); + token = gfc_find_component (sym, name, true, true, NULL); + if (token == NULL) + { + if (!gfc_add_component (sym, name, &token)) + return false; + token->ts.type = BT_VOID; + token->ts.kind = gfc_default_integer_kind; + token->attr.access = ACCESS_PRIVATE; + token->attr.artificial = 1; + token->attr.caf_token = 1; + } + } + } + + check_defined_assignments (sym); + + if (!sym->attr.defined_assign_comp && super_type) + sym->attr.defined_assign_comp + = super_type->attr.defined_assign_comp; + + /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that + all DEFERRED bindings are overridden. */ + if (super_type && super_type->attr.abstract && !sym->attr.abstract + && !sym->attr.is_class + && !ensure_not_abstract (sym, super_type)) + return false; + + /* Check that there is a component for every PDT parameter. */ + if (sym->attr.pdt_template) + { + for (f = sym->formal; f; f = f->next) + { + if (!f->sym) + continue; + c = gfc_find_component (sym, f->sym->name, true, true, NULL); + if (c == NULL) + { + gfc_error ("Parameterized type %qs does not have a component " + "corresponding to parameter %qs at %L", sym->name, + f->sym->name, &sym->declared_at); + break; + } + } + } + + /* Add derived type to the derived type list. */ + add_dt_to_dt_list (sym); + + return true; +} + + +/* The following procedure does the full resolution of a derived type, + including resolution of all type-bound procedures (if present). In contrast + to 'resolve_fl_derived0' this can only be done after the module has been + parsed completely. */ + +static bool +resolve_fl_derived (gfc_symbol *sym) +{ + gfc_symbol *gen_dt = NULL; + + if (sym->attr.unlimited_polymorphic) + return true; + + if (!sym->attr.is_class) + gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); + if (gen_dt && gen_dt->generic && gen_dt->generic->next + && (!gen_dt->generic->sym->attr.use_assoc + || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) + && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function " + "%qs at %L being the same name as derived " + "type at %L", sym->name, + gen_dt->generic->sym == sym + ? gen_dt->generic->next->sym->name + : gen_dt->generic->sym->name, + gen_dt->generic->sym == sym + ? &gen_dt->generic->next->sym->declared_at + : &gen_dt->generic->sym->declared_at, + &sym->declared_at)) + return false; + + if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc) + { + gfc_error ("Derived type %qs at %L has not been declared", + sym->name, &sym->declared_at); + return false; + } + + /* Resolve the finalizer procedures. */ + if (!gfc_resolve_finalizers (sym, NULL)) + return false; + + if (sym->attr.is_class && sym->ts.u.derived == NULL) + { + /* Fix up incomplete CLASS symbols. */ + gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL); + gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL); + + /* Nothing more to do for unlimited polymorphic entities. */ + if (data->ts.u.derived->attr.unlimited_polymorphic) + return true; + else if (vptr->ts.u.derived == NULL) + { + gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); + gcc_assert (vtab); + vptr->ts.u.derived = vtab->ts.u.derived; + if (!resolve_fl_derived0 (vptr->ts.u.derived)) + return false; + } + } + + if (!resolve_fl_derived0 (sym)) + return false; + + /* Resolve the type-bound procedures. */ + if (!resolve_typebound_procedures (sym)) + return false; + + /* Generate module vtables subject to their accessibility and their not + being vtables or pdt templates. If this is not done class declarations + in external procedures wind up with their own version and so SELECT TYPE + fails because the vptrs do not have the same address. */ + if (gfc_option.allow_std & GFC_STD_F2003 + && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE + && sym->attr.access != ACCESS_PRIVATE + && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template)) + { + gfc_symbol *vtab = gfc_find_derived_vtab (sym); + gfc_set_sym_referenced (vtab); + } + + return true; +} + + +static bool +resolve_fl_namelist (gfc_symbol *sym) +{ + gfc_namelist *nl; + gfc_symbol *nlsym; + + for (nl = sym->namelist; nl; nl = nl->next) + { + /* Check again, the check in match only works if NAMELIST comes + after the decl. */ + if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Assumed size array %qs in namelist %qs at %L is not " + "allowed", nl->sym->name, sym->name, &sym->declared_at); + return false; + } + + if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE + && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " + "with assumed shape in namelist %qs at %L", + nl->sym->name, sym->name, &sym->declared_at)) + return false; + + if (is_non_constant_shape_array (nl->sym) + && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " + "with nonconstant shape in namelist %qs at %L", + nl->sym->name, sym->name, &sym->declared_at)) + return false; + + if (nl->sym->ts.type == BT_CHARACTER + && (nl->sym->ts.u.cl->length == NULL + || !gfc_is_constant_expr (nl->sym->ts.u.cl->length)) + && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with " + "nonconstant character length in " + "namelist %qs at %L", nl->sym->name, + sym->name, &sym->declared_at)) + return false; + + } + + /* Reject PRIVATE objects in a PUBLIC namelist. */ + if (gfc_check_symbol_access (sym)) + { + for (nl = sym->namelist; nl; nl = nl->next) + { + if (!nl->sym->attr.use_assoc + && !is_sym_host_assoc (nl->sym, sym->ns) + && !gfc_check_symbol_access (nl->sym)) + { + gfc_error ("NAMELIST object %qs was declared PRIVATE and " + "cannot be member of PUBLIC namelist %qs at %L", + nl->sym->name, sym->name, &sym->declared_at); + return false; + } + + if (nl->sym->ts.type == BT_DERIVED + && (nl->sym->ts.u.derived->attr.alloc_comp + || nl->sym->ts.u.derived->attr.pointer_comp)) + { + if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " + "namelist %qs at %L with ALLOCATABLE " + "or POINTER components", nl->sym->name, + sym->name, &sym->declared_at)) + return false; + return true; + } + + /* Types with private components that came here by USE-association. */ + if (nl->sym->ts.type == BT_DERIVED + && derived_inaccessible (nl->sym->ts.u.derived)) + { + gfc_error ("NAMELIST object %qs has use-associated PRIVATE " + "components and cannot be member of namelist %qs at %L", + nl->sym->name, sym->name, &sym->declared_at); + return false; + } + + /* Types with private components that are defined in the same module. */ + if (nl->sym->ts.type == BT_DERIVED + && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns) + && nl->sym->ts.u.derived->attr.private_comp) + { + gfc_error ("NAMELIST object %qs has PRIVATE components and " + "cannot be a member of PUBLIC namelist %qs at %L", + nl->sym->name, sym->name, &sym->declared_at); + return false; + } + } + } + + + /* 14.1.2 A module or internal procedure represent local entities + of the same type as a namelist member and so are not allowed. */ + for (nl = sym->namelist; nl; nl = nl->next) + { + if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE) + continue; + + if (nl->sym->attr.function && nl->sym == nl->sym->result) + if ((nl->sym == sym->ns->proc_name) + || + (sym->ns->parent && nl->sym == sym->ns->parent->proc_name)) + continue; + + nlsym = NULL; + if (nl->sym->name) + gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym); + if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) + { + gfc_error ("PROCEDURE attribute conflicts with NAMELIST " + "attribute in %qs at %L", nlsym->name, + &sym->declared_at); + return false; + } + } + + return true; +} + + +static bool +resolve_fl_parameter (gfc_symbol *sym) +{ + /* A parameter array's shape needs to be constant. */ + if (sym->as != NULL + && (sym->as->type == AS_DEFERRED + || is_non_constant_shape_array (sym))) + { + gfc_error ("Parameter array %qs at %L cannot be automatic " + "or of deferred shape", sym->name, &sym->declared_at); + return false; + } + + /* Constraints on deferred type parameter. */ + if (!deferred_requirements (sym)) + return false; + + /* Make sure a parameter that has been implicitly typed still + matches the implicit type, since PARAMETER statements can precede + IMPLICIT statements. */ + if (sym->attr.implicit_type + && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name, + sym->ns))) + { + gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a " + "later IMPLICIT type", sym->name, &sym->declared_at); + return false; + } + + /* Make sure the types of derived parameters are consistent. This + type checking is deferred until resolution because the type may + refer to a derived type from the host. */ + if (sym->ts.type == BT_DERIVED + && !gfc_compare_types (&sym->ts, &sym->value->ts)) + { + gfc_error ("Incompatible derived type in PARAMETER at %L", + &sym->value->where); + return false; + } + + /* F03:C509,C514. */ + if (sym->ts.type == BT_CLASS) + { + gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute", + sym->name, &sym->declared_at); + return false; + } + + return true; +} + + +/* Called by resolve_symbol to check PDTs. */ + +static void +resolve_pdt (gfc_symbol* sym) +{ + gfc_symbol *derived = NULL; + gfc_actual_arglist *param; + gfc_component *c; + bool const_len_exprs = true; + bool assumed_len_exprs = false; + symbol_attribute *attr; + + if (sym->ts.type == BT_DERIVED) + { + derived = sym->ts.u.derived; + attr = &(sym->attr); + } + else if (sym->ts.type == BT_CLASS) + { + derived = CLASS_DATA (sym)->ts.u.derived; + attr = &(CLASS_DATA (sym)->attr); + } + else + gcc_unreachable (); + + gcc_assert (derived->attr.pdt_type); + + for (param = sym->param_list; param; param = param->next) + { + c = gfc_find_component (derived, param->name, false, true, NULL); + gcc_assert (c); + if (c->attr.pdt_kind) + continue; + + if (param->expr && !gfc_is_constant_expr (param->expr) + && c->attr.pdt_len) + const_len_exprs = false; + else if (param->spec_type == SPEC_ASSUMED) + assumed_len_exprs = true; + + if (param->spec_type == SPEC_DEFERRED + && !attr->allocatable && !attr->pointer) + gfc_error ("The object %qs at %L has a deferred LEN " + "parameter %qs and is neither allocatable " + "nor a pointer", sym->name, &sym->declared_at, + param->name); + + } + + if (!const_len_exprs + && (sym->ns->proc_name->attr.is_main_program + || sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->attr.save != SAVE_NONE)) + gfc_error ("The AUTOMATIC object %qs at %L must not have the " + "SAVE attribute or be a variable declared in the " + "main program, a module or a submodule(F08/C513)", + sym->name, &sym->declared_at); + + if (assumed_len_exprs && !(sym->attr.dummy + || sym->attr.select_type_temporary || sym->attr.associate_var)) + gfc_error ("The object %qs at %L with ASSUMED type parameters " + "must be a dummy or a SELECT TYPE selector(F08/4.2)", + sym->name, &sym->declared_at); +} + + +/* Do anything necessary to resolve a symbol. Right now, we just + assume that an otherwise unknown symbol is a variable. This sort + of thing commonly happens for symbols in module. */ + +static void +resolve_symbol (gfc_symbol *sym) +{ + int check_constant, mp_flag; + gfc_symtree *symtree; + gfc_symtree *this_symtree; + gfc_namespace *ns; + gfc_component *c; + symbol_attribute class_attr; + gfc_array_spec *as; + bool saved_specification_expr; + + if (sym->resolve_symbol_called >= 1) + return; + sym->resolve_symbol_called = 1; + + /* No symbol will ever have union type; only components can be unions. + Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION + (just like derived type declaration symbols have flavor FL_DERIVED). */ + gcc_assert (sym->ts.type != BT_UNION); + + /* Coarrayed polymorphic objects with allocatable or pointer components are + yet unsupported for -fcoarray=lib. */ + if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS + && sym->ts.u.derived && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.codimension + && CLASS_DATA (sym)->ts.u.derived + && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp + || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp)) + { + gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) " + "type coarrays at %L are unsupported", &sym->declared_at); + return; + } + + if (sym->attr.artificial) + return; + + if (sym->attr.unlimited_polymorphic) + return; + + if (sym->attr.flavor == FL_UNKNOWN + || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic + && !sym->attr.generic && !sym->attr.external + && sym->attr.if_source == IFSRC_UNKNOWN + && sym->ts.type == BT_UNKNOWN)) + { + + /* If we find that a flavorless symbol is an interface in one of the + parent namespaces, find its symtree in this namespace, free the + symbol and set the symtree to point to the interface symbol. */ + for (ns = gfc_current_ns->parent; ns; ns = ns->parent) + { + symtree = gfc_find_symtree (ns->sym_root, sym->name); + if (symtree && (symtree->n.sym->generic || + (symtree->n.sym->attr.flavor == FL_PROCEDURE + && sym->ns->construct_entities))) + { + this_symtree = gfc_find_symtree (gfc_current_ns->sym_root, + sym->name); + if (this_symtree->n.sym == sym) + { + symtree->n.sym->refs++; + gfc_release_symbol (sym); + this_symtree->n.sym = symtree->n.sym; + return; + } + } + } + + /* Otherwise give it a flavor according to such attributes as + it has. */ + if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0 + && sym->attr.intrinsic == 0) + sym->attr.flavor = FL_VARIABLE; + else if (sym->attr.flavor == FL_UNKNOWN) + { + sym->attr.flavor = FL_PROCEDURE; + if (sym->attr.dimension) + sym->attr.function = 1; + } + } + + if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function) + gfc_add_function (&sym->attr, sym->name, &sym->declared_at); + + if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL + && !resolve_procedure_interface (sym)) + return; + + if (sym->attr.is_protected && !sym->attr.proc_pointer + && (sym->attr.procedure || sym->attr.external)) + { + if (sym->attr.external) + gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute " + "at %L", &sym->declared_at); + else + gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute " + "at %L", &sym->declared_at); + + return; + } + + if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym)) + return; + + else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION) + && !resolve_fl_struct (sym)) + return; + + /* Symbols that are module procedures with results (functions) have + the types and array specification copied for type checking in + procedures that call them, as well as for saving to a module + file. These symbols can't stand the scrutiny that their results + can. */ + mp_flag = (sym->result != NULL && sym->result != sym); + + /* Make sure that the intrinsic is consistent with its internal + representation. This needs to be done before assigning a default + type to avoid spurious warnings. */ + if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic + && !gfc_resolve_intrinsic (sym, &sym->declared_at)) + return; + + /* Resolve associate names. */ + if (sym->assoc) + resolve_assoc_var (sym, true); + + /* Assign default type to symbols that need one and don't have one. */ + if (sym->ts.type == BT_UNKNOWN) + { + if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER) + { + gfc_set_default_type (sym, 1, NULL); + } + + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external + && !sym->attr.function && !sym->attr.subroutine + && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN) + gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at); + + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function) + { + /* The specific case of an external procedure should emit an error + in the case that there is no implicit type. */ + if (!mp_flag) + { + if (!sym->attr.mixed_entry_master) + gfc_set_default_type (sym, sym->attr.external, NULL); + } + else + { + /* Result may be in another namespace. */ + resolve_symbol (sym->result); + + if (!sym->result->attr.proc_pointer) + { + sym->ts = sym->result->ts; + sym->as = gfc_copy_array_spec (sym->result->as); + sym->attr.dimension = sym->result->attr.dimension; + sym->attr.pointer = sym->result->attr.pointer; + sym->attr.allocatable = sym->result->attr.allocatable; + sym->attr.contiguous = sym->result->attr.contiguous; + } + } + } + } + else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function) + { + bool saved_specification_expr = specification_expr; + bool saved_formal_arg_flag = formal_arg_flag; + + specification_expr = true; + formal_arg_flag = true; + gfc_resolve_array_spec (sym->result->as, false); + formal_arg_flag = saved_formal_arg_flag; + specification_expr = saved_specification_expr; + } + + if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) + { + as = CLASS_DATA (sym)->as; + class_attr = CLASS_DATA (sym)->attr; + class_attr.pointer = class_attr.class_pointer; + } + else + { + class_attr = sym->attr; + as = sym->as; + } + + /* F2008, C530. */ + if (sym->attr.contiguous + && (!class_attr.dimension + || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK + && !class_attr.pointer))) + { + gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an " + "array pointer or an assumed-shape or assumed-rank array", + sym->name, &sym->declared_at); + return; + } + + /* Assumed size arrays and assumed shape arrays must be dummy + arguments. Array-spec's of implied-shape should have been resolved to + AS_EXPLICIT already. */ + + if (as) + { + /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad + specification expression. */ + if (as->type == AS_IMPLIED_SHAPE) + { + int i; + for (i=0; irank; i++) + { + if (as->lower[i] != NULL && as->upper[i] == NULL) + { + gfc_error ("Bad specification for assumed size array at %L", + &as->lower[i]->where); + return; + } + } + gcc_unreachable(); + } + + if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed) + || as->type == AS_ASSUMED_SHAPE) + && !sym->attr.dummy && !sym->attr.select_type_temporary) + { + if (as->type == AS_ASSUMED_SIZE) + gfc_error ("Assumed size array at %L must be a dummy argument", + &sym->declared_at); + else + gfc_error ("Assumed shape array at %L must be a dummy argument", + &sym->declared_at); + return; + } + /* TS 29113, C535a. */ + if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy + && !sym->attr.select_type_temporary + && !(cs_base && cs_base->current + && cs_base->current->op == EXEC_SELECT_RANK)) + { + gfc_error ("Assumed-rank array at %L must be a dummy argument", + &sym->declared_at); + return; + } + if (as->type == AS_ASSUMED_RANK + && (sym->attr.codimension || sym->attr.value)) + { + gfc_error ("Assumed-rank array at %L may not have the VALUE or " + "CODIMENSION attribute", &sym->declared_at); + return; + } + } + + /* Make sure symbols with known intent or optional are really dummy + variable. Because of ENTRY statement, this has to be deferred + until resolution time. */ + + if (!sym->attr.dummy + && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN)) + { + gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at); + return; + } + + if (sym->attr.value && !sym->attr.dummy) + { + gfc_error ("%qs at %L cannot have the VALUE attribute because " + "it is not a dummy argument", sym->name, &sym->declared_at); + return; + } + + if (sym->attr.value && sym->ts.type == BT_CHARACTER) + { + gfc_charlen *cl = sym->ts.u.cl; + if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Character dummy variable %qs at %L with VALUE " + "attribute must have constant length", + sym->name, &sym->declared_at); + return; + } + + if (sym->ts.is_c_interop + && mpz_cmp_si (cl->length->value.integer, 1) != 0) + { + gfc_error ("C interoperable character dummy variable %qs at %L " + "with VALUE attribute must have length one", + sym->name, &sym->declared_at); + return; + } + } + + if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c + && sym->ts.u.derived->attr.generic) + { + sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); + if (!sym->ts.u.derived) + { + gfc_error ("The derived type %qs at %L is of type %qs, " + "which has not been defined", sym->name, + &sym->declared_at, sym->ts.u.derived->name); + sym->ts.type = BT_UNKNOWN; + return; + } + } + + /* Use the same constraints as TYPE(*), except for the type check + and that only scalars and assumed-size arrays are permitted. */ + if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) + { + if (!sym->attr.dummy) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " + "a dummy argument", sym->name, &sym->declared_at); + return; + } + + if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER + && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL + && sym->ts.type != BT_COMPLEX) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " + "of type TYPE(*) or of an numeric intrinsic type", + sym->name, &sym->declared_at); + return; + } + + if (sym->attr.allocatable || sym->attr.codimension + || sym->attr.pointer || sym->attr.value) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " + "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE " + "attribute", sym->name, &sym->declared_at); + return; + } + + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " + "have the INTENT(OUT) attribute", + sym->name, &sym->declared_at); + return; + } + if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE) + { + gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall " + "either be a scalar or an assumed-size array", + sym->name, &sym->declared_at); + return; + } + + /* Set the type to TYPE(*) and add a dimension(*) to ensure + NO_ARG_CHECK is correctly handled in trans*.c, e.g. with + packing. */ + sym->ts.type = BT_ASSUMED; + sym->as = gfc_get_array_spec (); + sym->as->type = AS_ASSUMED_SIZE; + sym->as->rank = 1; + sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + } + else if (sym->ts.type == BT_ASSUMED) + { + /* TS 29113, C407a. */ + if (!sym->attr.dummy) + { + gfc_error ("Assumed type of variable %s at %L is only permitted " + "for dummy variables", sym->name, &sym->declared_at); + return; + } + if (sym->attr.allocatable || sym->attr.codimension + || sym->attr.pointer || sym->attr.value) + { + gfc_error ("Assumed-type variable %s at %L may not have the " + "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute", + sym->name, &sym->declared_at); + return; + } + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Assumed-type variable %s at %L may not have the " + "INTENT(OUT) attribute", + sym->name, &sym->declared_at); + return; + } + if (sym->attr.dimension && sym->as->type == AS_EXPLICIT) + { + gfc_error ("Assumed-type variable %s at %L shall not be an " + "explicit-shape array", sym->name, &sym->declared_at); + return; + } + } + + /* If the symbol is marked as bind(c), that it is declared at module level + scope and verify its type and kind. Do not do the latter for symbols + that are implicitly typed because that is handled in + gfc_set_default_type. Handle dummy arguments and procedure definitions + separately. Also, anything that is use associated is not handled here + but instead is handled in the module it is declared in. Finally, derived + type definitions are allowed to be BIND(C) since that only implies that + they're interoperable, and they are checked fully for interoperability + when a variable is declared of that type. */ + if (sym->attr.is_bind_c && sym->attr.use_assoc == 0 + && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE + && sym->attr.flavor != FL_DERIVED) + { + bool t = true; + + /* First, make sure the variable is declared at the + module-level scope (J3/04-007, Section 15.3). */ + if (sym->ns->proc_name->attr.flavor != FL_MODULE && + sym->attr.in_common == 0) + { + gfc_error ("Variable %qs at %L cannot be BIND(C) because it " + "is neither a COMMON block nor declared at the " + "module level scope", sym->name, &(sym->declared_at)); + t = false; + } + else if (sym->ts.type == BT_CHARACTER + && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL + || !gfc_is_constant_expr (sym->ts.u.cl->length) + || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0)) + { + gfc_error ("BIND(C) Variable %qs at %L must have length one", + sym->name, &sym->declared_at); + t = false; + } + else if (sym->common_head != NULL && sym->attr.implicit_type == 0) + { + t = verify_com_block_vars_c_interop (sym->common_head); + } + else if (sym->attr.implicit_type == 0) + { + /* If type() declaration, we need to verify that the components + of the given type are all C interoperable, etc. */ + if (sym->ts.type == BT_DERIVED && + sym->ts.u.derived->attr.is_c_interop != 1) + { + /* Make sure the user marked the derived type as BIND(C). If + not, call the verify routine. This could print an error + for the derived type more than once if multiple variables + of that type are declared. */ + if (sym->ts.u.derived->attr.is_bind_c != 1) + verify_bind_c_derived_type (sym->ts.u.derived); + t = false; + } + + /* Verify the variable itself as C interoperable if it + is BIND(C). It is not possible for this to succeed if + the verify_bind_c_derived_type failed, so don't have to handle + any error returned by verify_bind_c_derived_type. */ + t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, + sym->common_block); + } + + if (!t) + { + /* clear the is_bind_c flag to prevent reporting errors more than + once if something failed. */ + sym->attr.is_bind_c = 0; + return; + } + } + + /* If a derived type symbol has reached this point, without its + type being declared, we have an error. Notice that most + conditions that produce undefined derived types have already + been dealt with. However, the likes of: + implicit type(t) (t) ..... call foo (t) will get us here if + the type is not declared in the scope of the implicit + statement. Change the type to BT_UNKNOWN, both because it is so + and to prevent an ICE. */ + if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c + && sym->ts.u.derived->components == NULL + && !sym->ts.u.derived->attr.zero_comp) + { + gfc_error ("The derived type %qs at %L is of type %qs, " + "which has not been defined", sym->name, + &sym->declared_at, sym->ts.u.derived->name); + sym->ts.type = BT_UNKNOWN; + return; + } + + /* Make sure that the derived type has been resolved and that the + derived type is visible in the symbol's namespace, if it is a + module function and is not PRIVATE. */ + if (sym->ts.type == BT_DERIVED + && sym->ts.u.derived->attr.use_assoc + && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE + && !resolve_fl_derived (sym->ts.u.derived)) + return; + + /* Unless the derived-type declaration is use associated, Fortran 95 + does not allow public entries of private derived types. + See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation + 161 in 95-006r3. */ + if (sym->ts.type == BT_DERIVED + && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE + && !sym->ts.u.derived->attr.use_assoc + && gfc_check_symbol_access (sym) + && !gfc_check_symbol_access (sym->ts.u.derived) + && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE " + "derived type %qs", + (sym->attr.flavor == FL_PARAMETER) + ? "parameter" : "variable", + sym->name, &sym->declared_at, + sym->ts.u.derived->name)) + return; + + /* F2008, C1302. */ + if (sym->ts.type == BT_DERIVED + && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + || sym->ts.u.derived->attr.lock_comp) + && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) + { + gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of " + "type LOCK_TYPE must be a coarray", sym->name, + &sym->declared_at); + return; + } + + /* TS18508, C702/C703. */ + if (sym->ts.type == BT_DERIVED + && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + || sym->ts.u.derived->attr.event_comp) + && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) + { + gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of " + "type EVENT_TYPE must be a coarray", sym->name, + &sym->declared_at); + return; + } + + /* An assumed-size array with INTENT(OUT) shall not be of a type for which + default initialization is defined (5.1.2.4.4). */ + if (sym->ts.type == BT_DERIVED + && sym->attr.dummy + && sym->attr.intent == INTENT_OUT + && sym->as + && sym->as->type == AS_ASSUMED_SIZE) + { + for (c = sym->ts.u.derived->components; c; c = c->next) + { + if (c->initializer) + { + gfc_error ("The INTENT(OUT) dummy argument %qs at %L is " + "ASSUMED SIZE and so cannot have a default initializer", + sym->name, &sym->declared_at); + return; + } + } + } + + /* F2008, C542. */ + if (sym->ts.type == BT_DERIVED && sym->attr.dummy + && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp) + { + gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be " + "INTENT(OUT)", sym->name, &sym->declared_at); + return; + } + + /* TS18508. */ + if (sym->ts.type == BT_DERIVED && sym->attr.dummy + && sym->attr.intent == INTENT_OUT && sym->attr.event_comp) + { + gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be " + "INTENT(OUT)", sym->name, &sym->declared_at); + return; + } + + /* F2008, C525. */ + if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.coarray_comp)) + || class_attr.codimension) + && (sym->attr.result || sym->result == sym)) + { + gfc_error ("Function result %qs at %L shall not be a coarray or have " + "a coarray component", sym->name, &sym->declared_at); + return; + } + + /* F2008, C524. */ + if (sym->attr.codimension && sym->ts.type == BT_DERIVED + && sym->ts.u.derived->ts.is_iso_c) + { + gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", sym->name, &sym->declared_at); + return; + } + + /* F2008, C525. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.coarray_comp)) + && (class_attr.codimension || class_attr.pointer || class_attr.dimension + || class_attr.allocatable)) + { + gfc_error ("Variable %qs at %L with coarray component shall be a " + "nonpointer, nonallocatable scalar, which is not a coarray", + sym->name, &sym->declared_at); + return; + } + + /* F2008, C526. The function-result case was handled above. */ + if (class_attr.codimension + && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save + || sym->attr.select_type_temporary + || sym->attr.associate_var + || (sym->ns->save_all && !sym->attr.automatic) + || sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program + || sym->attr.function || sym->attr.result || sym->attr.use_assoc)) + { + gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE " + "nor a dummy argument", sym->name, &sym->declared_at); + return; + } + /* F2008, C528. */ + else if (class_attr.codimension && !sym->attr.select_type_temporary + && !class_attr.allocatable && as && as->cotype == AS_DEFERRED) + { + gfc_error ("Coarray variable %qs at %L shall not have codimensions with " + "deferred shape", sym->name, &sym->declared_at); + return; + } + else if (class_attr.codimension && class_attr.allocatable && as + && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED)) + { + gfc_error ("Allocatable coarray variable %qs at %L must have " + "deferred shape", sym->name, &sym->declared_at); + return; + } + + /* F2008, C541. */ + if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.coarray_comp)) + || (class_attr.codimension && class_attr.allocatable)) + && sym->attr.dummy && sym->attr.intent == INTENT_OUT) + { + gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an " + "allocatable coarray or have coarray components", + sym->name, &sym->declared_at); + return; + } + + if (class_attr.codimension && sym->attr.dummy + && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) + { + gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) " + "procedure %qs", sym->name, &sym->declared_at, + sym->ns->proc_name->name); + return; + } + + if (sym->ts.type == BT_LOGICAL + && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym) + || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name + && sym->ns->proc_name->attr.is_bind_c))) + { + int i; + for (i = 0; gfc_logical_kinds[i].kind; i++) + if (gfc_logical_kinds[i].kind == sym->ts.kind) + break; + if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy + && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at " + "%L with non-C_Bool kind in BIND(C) procedure " + "%qs", sym->name, &sym->declared_at, + sym->ns->proc_name->name)) + return; + else if (!gfc_logical_kinds[i].c_bool + && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable " + "%qs at %L with non-C_Bool kind in " + "BIND(C) procedure %qs", sym->name, + &sym->declared_at, + sym->attr.function ? sym->name + : sym->ns->proc_name->name)) + return; + } + + switch (sym->attr.flavor) + { + case FL_VARIABLE: + if (!resolve_fl_variable (sym, mp_flag)) + return; + break; + + case FL_PROCEDURE: + if (sym->formal && !sym->formal_ns) + { + /* Check that none of the arguments are a namelist. */ + gfc_formal_arglist *formal = sym->formal; + + for (; formal; formal = formal->next) + if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST) + { + gfc_error ("Namelist %qs cannot be an argument to " + "subroutine or function at %L", + formal->sym->name, &sym->declared_at); + return; + } + } + + if (!resolve_fl_procedure (sym, mp_flag)) + return; + break; + + case FL_NAMELIST: + if (!resolve_fl_namelist (sym)) + return; + break; + + case FL_PARAMETER: + if (!resolve_fl_parameter (sym)) + return; + break; + + default: + break; + } + + /* Resolve array specifier. Check as well some constraints + on COMMON blocks. */ + + check_constant = sym->attr.in_common && !sym->attr.pointer; + + /* Set the formal_arg_flag so that check_conflict will not throw + an error for host associated variables in the specification + expression for an array_valued function. */ + if ((sym->attr.function || sym->attr.result) && sym->as) + formal_arg_flag = true; + + saved_specification_expr = specification_expr; + specification_expr = true; + gfc_resolve_array_spec (sym->as, check_constant); + specification_expr = saved_specification_expr; + + formal_arg_flag = false; + + /* Resolve formal namespaces. */ + if (sym->formal_ns && sym->formal_ns != gfc_current_ns + && !sym->attr.contained && !sym->attr.intrinsic) + gfc_resolve (sym->formal_ns); + + /* Make sure the formal namespace is present. */ + if (sym->formal && !sym->formal_ns) + { + gfc_formal_arglist *formal = sym->formal; + while (formal && !formal->sym) + formal = formal->next; + + if (formal) + { + sym->formal_ns = formal->sym->ns; + if (sym->formal_ns && sym->ns != formal->sym->ns) + sym->formal_ns->refs++; + } + } + + /* Check threadprivate restrictions. */ + if (sym->attr.threadprivate + && !(sym->attr.save || sym->attr.data || sym->attr.in_common) + && !(sym->ns->save_all && !sym->attr.automatic) + && sym->module == NULL + && (sym->ns->proc_name == NULL + || (sym->ns->proc_name->attr.flavor != FL_MODULE + && !sym->ns->proc_name->attr.is_main_program))) + gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + + /* Check omp declare target restrictions. */ + if (sym->attr.omp_declare_target + && sym->attr.flavor == FL_VARIABLE + && !sym->attr.save + && !(sym->ns->save_all && !sym->attr.automatic) + && (!sym->attr.in_common + && sym->module == NULL + && (sym->ns->proc_name == NULL + || (sym->ns->proc_name->attr.flavor != FL_MODULE + && !sym->ns->proc_name->attr.is_main_program)))) + gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd", + sym->name, &sym->declared_at); + + /* If we have come this far we can apply default-initializers, as + described in 14.7.5, to those variables that have not already + been assigned one. */ + if (sym->ts.type == BT_DERIVED + && !sym->value + && !sym->attr.allocatable + && !sym->attr.alloc_comp) + { + symbol_attribute *a = &sym->attr; + + if ((!a->save && !a->dummy && !a->pointer + && !a->in_common && !a->use_assoc + && a->referenced + && !((a->function || a->result) + && (!a->dimension + || sym->ts.u.derived->attr.alloc_comp + || sym->ts.u.derived->attr.pointer_comp)) + && !(a->function && sym != sym->result)) + || (a->dummy && !a->pointer && a->intent == INTENT_OUT + && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)) + apply_default_init (sym); + else if (a->function && sym->result && a->access != ACCESS_PRIVATE + && (sym->ts.u.derived->attr.alloc_comp + || sym->ts.u.derived->attr.pointer_comp)) + /* Mark the result symbol to be referenced, when it has allocatable + components. */ + sym->result->attr.referenced = 1; + } + + if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns + && sym->attr.dummy && sym->attr.intent == INTENT_OUT + && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY + && !CLASS_DATA (sym)->attr.class_pointer + && !CLASS_DATA (sym)->attr.allocatable) + apply_default_init (sym); + + /* If this symbol has a type-spec, check it. */ + if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER + || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) + if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)) + return; + + if (sym->param_list) + resolve_pdt (sym); +} + + +/************* Resolve DATA statements *************/ + +static struct +{ + gfc_data_value *vnode; + mpz_t left; +} +values; + + +/* Advance the values structure to point to the next value in the data list. */ + +static bool +next_data_value (void) +{ + while (mpz_cmp_ui (values.left, 0) == 0) + { + + if (values.vnode->next == NULL) + return false; + + values.vnode = values.vnode->next; + mpz_set (values.left, values.vnode->repeat); + } + + return true; +} + + +static bool +check_data_variable (gfc_data_variable *var, locus *where) +{ + gfc_expr *e; + mpz_t size; + mpz_t offset; + bool t; + ar_type mark = AR_UNKNOWN; + int i; + mpz_t section_index[GFC_MAX_DIMENSIONS]; + gfc_ref *ref; + gfc_array_ref *ar; + gfc_symbol *sym; + int has_pointer; + + if (!gfc_resolve_expr (var->expr)) + return false; + + ar = NULL; + mpz_init_set_si (offset, 0); + e = var->expr; + + if (e->expr_type == EXPR_FUNCTION && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CAF_GET) + e = e->value.function.actual->expr; + + if (e->expr_type != EXPR_VARIABLE) + { + gfc_error ("Expecting definable entity near %L", where); + return false; + } + + sym = e->symtree->n.sym; + + if (sym->ns->is_block_data && !sym->attr.in_common) + { + gfc_error ("BLOCK DATA element %qs at %L must be in COMMON", + sym->name, &sym->declared_at); + return false; + } + + if (e->ref == NULL && sym->as) + { + gfc_error ("DATA array %qs at %L must be specified in a previous" + " declaration", sym->name, where); + return false; + } + + if (gfc_is_coindexed (e)) + { + gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name, + where); + return false; + } + + has_pointer = sym->attr.pointer; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) + has_pointer = 1; + + if (has_pointer) + { + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL) + { + gfc_error ("DATA element %qs at %L is a pointer and so must " + "be a full array", sym->name, where); + return false; + } + + if (values.vnode->expr->expr_type == EXPR_CONSTANT) + { + gfc_error ("DATA object near %L has the pointer attribute " + "and the corresponding DATA value is not a valid " + "initial-data-target", where); + return false; + } + } + + if (ref->type == REF_COMPONENT && ref->u.c.component->attr.allocatable) + { + gfc_error ("DATA element %qs at %L cannot have the ALLOCATABLE " + "attribute", ref->u.c.component->name, &e->where); + return false; + } + } + + if (e->rank == 0 || has_pointer) + { + mpz_init_set_ui (size, 1); + ref = NULL; + } + else + { + ref = e->ref; + + /* Find the array section reference. */ + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_ARRAY) + continue; + if (ref->u.ar.type == AR_ELEMENT) + continue; + break; + } + gcc_assert (ref); + + /* Set marks according to the reference pattern. */ + switch (ref->u.ar.type) + { + case AR_FULL: + mark = AR_FULL; + break; + + case AR_SECTION: + ar = &ref->u.ar; + /* Get the start position of array section. */ + gfc_get_section_index (ar, section_index, &offset); + mark = AR_SECTION; + break; + + default: + gcc_unreachable (); + } + + if (!gfc_array_size (e, &size)) + { + gfc_error ("Nonconstant array section at %L in DATA statement", + where); + mpz_clear (offset); + return false; + } + } + + t = true; + + while (mpz_cmp_ui (size, 0) > 0) + { + if (!next_data_value ()) + { + gfc_error ("DATA statement at %L has more variables than values", + where); + t = false; + break; + } + + t = gfc_check_assign (var->expr, values.vnode->expr, 0); + if (!t) + break; + + /* If we have more than one element left in the repeat count, + and we have more than one element left in the target variable, + then create a range assignment. */ + /* FIXME: Only done for full arrays for now, since array sections + seem tricky. */ + if (mark == AR_FULL && ref && ref->next == NULL + && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0) + { + mpz_t range; + + if (mpz_cmp (size, values.left) >= 0) + { + mpz_init_set (range, values.left); + mpz_sub (size, size, values.left); + mpz_set_ui (values.left, 0); + } + else + { + mpz_init_set (range, size); + mpz_sub (values.left, values.left, size); + mpz_set_ui (size, 0); + } + + t = gfc_assign_data_value (var->expr, values.vnode->expr, + offset, &range); + + mpz_add (offset, offset, range); + mpz_clear (range); + + if (!t) + break; + } + + /* Assign initial value to symbol. */ + else + { + mpz_sub_ui (values.left, values.left, 1); + mpz_sub_ui (size, size, 1); + + t = gfc_assign_data_value (var->expr, values.vnode->expr, + offset, NULL); + if (!t) + break; + + if (mark == AR_FULL) + mpz_add_ui (offset, offset, 1); + + /* Modify the array section indexes and recalculate the offset + for next element. */ + else if (mark == AR_SECTION) + gfc_advance_section (section_index, ar, &offset); + } + } + + if (mark == AR_SECTION) + { + for (i = 0; i < ar->dimen; i++) + mpz_clear (section_index[i]); + } + + mpz_clear (size); + mpz_clear (offset); + + return t; +} + + +static bool traverse_data_var (gfc_data_variable *, locus *); + +/* Iterate over a list of elements in a DATA statement. */ + +static bool +traverse_data_list (gfc_data_variable *var, locus *where) +{ + mpz_t trip; + iterator_stack frame; + gfc_expr *e, *start, *end, *step; + bool retval = true; + + mpz_init (frame.value); + mpz_init (trip); + + start = gfc_copy_expr (var->iter.start); + end = gfc_copy_expr (var->iter.end); + step = gfc_copy_expr (var->iter.step); + + if (!gfc_simplify_expr (start, 1) + || start->expr_type != EXPR_CONSTANT) + { + gfc_error ("start of implied-do loop at %L could not be " + "simplified to a constant value", &start->where); + retval = false; + goto cleanup; + } + if (!gfc_simplify_expr (end, 1) + || end->expr_type != EXPR_CONSTANT) + { + gfc_error ("end of implied-do loop at %L could not be " + "simplified to a constant value", &end->where); + retval = false; + goto cleanup; + } + if (!gfc_simplify_expr (step, 1) + || step->expr_type != EXPR_CONSTANT) + { + gfc_error ("step of implied-do loop at %L could not be " + "simplified to a constant value", &step->where); + retval = false; + goto cleanup; + } + if (mpz_cmp_si (step->value.integer, 0) == 0) + { + gfc_error ("step of implied-do loop at %L shall not be zero", + &step->where); + retval = false; + goto cleanup; + } + + mpz_set (trip, end->value.integer); + mpz_sub (trip, trip, start->value.integer); + mpz_add (trip, trip, step->value.integer); + + mpz_div (trip, trip, step->value.integer); + + mpz_set (frame.value, start->value.integer); + + frame.prev = iter_stack; + frame.variable = var->iter.var->symtree; + iter_stack = &frame; + + while (mpz_cmp_ui (trip, 0) > 0) + { + if (!traverse_data_var (var->list, where)) + { + retval = false; + goto cleanup; + } + + e = gfc_copy_expr (var->expr); + if (!gfc_simplify_expr (e, 1)) + { + gfc_free_expr (e); + retval = false; + goto cleanup; + } + + mpz_add (frame.value, frame.value, step->value.integer); + + mpz_sub_ui (trip, trip, 1); + } + +cleanup: + mpz_clear (frame.value); + mpz_clear (trip); + + gfc_free_expr (start); + gfc_free_expr (end); + gfc_free_expr (step); + + iter_stack = frame.prev; + return retval; +} + + +/* Type resolve variables in the variable list of a DATA statement. */ + +static bool +traverse_data_var (gfc_data_variable *var, locus *where) +{ + bool t; + + for (; var; var = var->next) + { + if (var->expr == NULL) + t = traverse_data_list (var, where); + else + t = check_data_variable (var, where); + + if (!t) + return false; + } + + return true; +} + + +/* Resolve the expressions and iterators associated with a data statement. + This is separate from the assignment checking because data lists should + only be resolved once. */ + +static bool +resolve_data_variables (gfc_data_variable *d) +{ + for (; d; d = d->next) + { + if (d->list == NULL) + { + if (!gfc_resolve_expr (d->expr)) + return false; + } + else + { + if (!gfc_resolve_iterator (&d->iter, false, true)) + return false; + + if (!resolve_data_variables (d->list)) + return false; + } + } + + return true; +} + + +/* Resolve a single DATA statement. We implement this by storing a pointer to + the value list into static variables, and then recursively traversing the + variables list, expanding iterators and such. */ + +static void +resolve_data (gfc_data *d) +{ + + if (!resolve_data_variables (d->var)) + return; + + values.vnode = d->value; + if (d->value == NULL) + mpz_set_ui (values.left, 0); + else + mpz_set (values.left, d->value->repeat); + + if (!traverse_data_var (d->var, &d->where)) + return; + + /* At this point, we better not have any values left. */ + + if (next_data_value ()) + gfc_error ("DATA statement at %L has more values than variables", + &d->where); +} + + +/* 12.6 Constraint: In a pure subprogram any variable which is in common or + accessed by host or use association, is a dummy argument to a pure function, + is a dummy argument with INTENT (IN) to a pure subroutine, or an object that + is storage associated with any such variable, shall not be used in the + following contexts: (clients of this function). */ + +/* Determines if a variable is not 'pure', i.e., not assignable within a pure + procedure. Returns zero if assignment is OK, nonzero if there is a + problem. */ +int +gfc_impure_variable (gfc_symbol *sym) +{ + gfc_symbol *proc; + gfc_namespace *ns; + + if (sym->attr.use_assoc || sym->attr.in_common) + return 1; + + /* Check if the symbol's ns is inside the pure procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + if (ns == sym->ns) + break; + if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function) + return 1; + } + + proc = sym->ns->proc_name; + if (sym->attr.dummy + && !sym->attr.value + && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN) + || proc->attr.function)) + return 1; + + /* TODO: Sort out what can be storage associated, if anything, and include + it here. In principle equivalences should be scanned but it does not + seem to be possible to storage associate an impure variable this way. */ + return 0; +} + + +/* Test whether a symbol is pure or not. For a NULL pointer, checks if the + current namespace is inside a pure procedure. */ + +int +gfc_pure (gfc_symbol *sym) +{ + symbol_attribute attr; + gfc_namespace *ns; + + if (sym == NULL) + { + /* Check if the current namespace or one of its parents + belongs to a pure procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + return 0; + attr = sym->attr; + if (attr.flavor == FL_PROCEDURE && attr.pure) + return 1; + } + return 0; + } + + attr = sym->attr; + + return attr.flavor == FL_PROCEDURE && attr.pure; +} + + +/* Test whether a symbol is implicitly pure or not. For a NULL pointer, + checks if the current namespace is implicitly pure. Note that this + function returns false for a PURE procedure. */ + +int +gfc_implicit_pure (gfc_symbol *sym) +{ + gfc_namespace *ns; + + if (sym == NULL) + { + /* Check if the current procedure is implicit_pure. Walk up + the procedure list until we find a procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + return 0; + + if (sym->attr.flavor == FL_PROCEDURE) + break; + } + } + + return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure + && !sym->attr.pure; +} + + +void +gfc_unset_implicit_pure (gfc_symbol *sym) +{ + gfc_namespace *ns; + + if (sym == NULL) + { + /* Check if the current procedure is implicit_pure. Walk up + the procedure list until we find a procedure. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = ns->proc_name; + if (sym == NULL) + return; + + if (sym->attr.flavor == FL_PROCEDURE) + break; + } + } + + if (sym->attr.flavor == FL_PROCEDURE) + sym->attr.implicit_pure = 0; + else + sym->attr.pure = 0; +} + + +/* Test whether the current procedure is elemental or not. */ + +int +gfc_elemental (gfc_symbol *sym) +{ + symbol_attribute attr; + + if (sym == NULL) + sym = gfc_current_ns->proc_name; + if (sym == NULL) + return 0; + attr = sym->attr; + + return attr.flavor == FL_PROCEDURE && attr.elemental; +} + + +/* Warn about unused labels. */ + +static void +warn_unused_fortran_label (gfc_st_label *label) +{ + if (label == NULL) + return; + + warn_unused_fortran_label (label->left); + + if (label->defined == ST_LABEL_UNKNOWN) + return; + + switch (label->referenced) + { + case ST_LABEL_UNKNOWN: + gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used", + label->value, &label->where); + break; + + case ST_LABEL_BAD_TARGET: + gfc_warning (OPT_Wunused_label, + "Label %d at %L defined but cannot be used", + label->value, &label->where); + break; + + default: + break; + } + + warn_unused_fortran_label (label->right); +} + + +/* Returns the sequence type of a symbol or sequence. */ + +static seq_type +sequence_type (gfc_typespec ts) +{ + seq_type result; + gfc_component *c; + + switch (ts.type) + { + case BT_DERIVED: + + if (ts.u.derived->components == NULL) + return SEQ_NONDEFAULT; + + result = sequence_type (ts.u.derived->components->ts); + for (c = ts.u.derived->components->next; c; c = c->next) + if (sequence_type (c->ts) != result) + return SEQ_MIXED; + + return result; + + case BT_CHARACTER: + if (ts.kind != gfc_default_character_kind) + return SEQ_NONDEFAULT; + + return SEQ_CHARACTER; + + case BT_INTEGER: + if (ts.kind != gfc_default_integer_kind) + return SEQ_NONDEFAULT; + + return SEQ_NUMERIC; + + case BT_REAL: + if (!(ts.kind == gfc_default_real_kind + || ts.kind == gfc_default_double_kind)) + return SEQ_NONDEFAULT; + + return SEQ_NUMERIC; + + case BT_COMPLEX: + if (ts.kind != gfc_default_complex_kind) + return SEQ_NONDEFAULT; + + return SEQ_NUMERIC; + + case BT_LOGICAL: + if (ts.kind != gfc_default_logical_kind) + return SEQ_NONDEFAULT; + + return SEQ_NUMERIC; + + default: + return SEQ_NONDEFAULT; + } +} + + +/* Resolve derived type EQUIVALENCE object. */ + +static bool +resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) +{ + gfc_component *c = derived->components; + + if (!derived) + return true; + + /* Shall not be an object of nonsequence derived type. */ + if (!derived->attr.sequence) + { + gfc_error ("Derived type variable %qs at %L must have SEQUENCE " + "attribute to be an EQUIVALENCE object", sym->name, + &e->where); + return false; + } + + /* Shall not have allocatable components. */ + if (derived->attr.alloc_comp) + { + gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE " + "components to be an EQUIVALENCE object",sym->name, + &e->where); + return false; + } + + if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived)) + { + gfc_error ("Derived type variable %qs at %L with default " + "initialization cannot be in EQUIVALENCE with a variable " + "in COMMON", sym->name, &e->where); + return false; + } + + for (; c ; c = c->next) + { + if (gfc_bt_struct (c->ts.type) + && (!resolve_equivalence_derived(c->ts.u.derived, sym, e))) + return false; + + /* Shall not be an object of sequence derived type containing a pointer + in the structure. */ + if (c->attr.pointer) + { + gfc_error ("Derived type variable %qs at %L with pointer " + "component(s) cannot be an EQUIVALENCE object", + sym->name, &e->where); + return false; + } + } + return true; +} + + +/* Resolve equivalence object. + An EQUIVALENCE object shall not be a dummy argument, a pointer, a target, + an allocatable array, an object of nonsequence derived type, an object of + sequence derived type containing a pointer at any level of component + selection, an automatic object, a function name, an entry name, a result + name, a named constant, a structure component, or a subobject of any of + the preceding objects. A substring shall not have length zero. A + derived type shall not have components with default initialization nor + shall two objects of an equivalence group be initialized. + Either all or none of the objects shall have an protected attribute. + The simple constraints are done in symbol.c(check_conflict) and the rest + are implemented here. */ + +static void +resolve_equivalence (gfc_equiv *eq) +{ + gfc_symbol *sym; + gfc_symbol *first_sym; + gfc_expr *e; + gfc_ref *r; + locus *last_where = NULL; + seq_type eq_type, last_eq_type; + gfc_typespec *last_ts; + int object, cnt_protected; + const char *msg; + + last_ts = &eq->expr->symtree->n.sym->ts; + + first_sym = eq->expr->symtree->n.sym; + + cnt_protected = 0; + + for (object = 1; eq; eq = eq->eq, object++) + { + e = eq->expr; + + e->ts = e->symtree->n.sym->ts; + /* match_varspec might not know yet if it is seeing + array reference or substring reference, as it doesn't + know the types. */ + if (e->ref && e->ref->type == REF_ARRAY) + { + gfc_ref *ref = e->ref; + sym = e->symtree->n.sym; + + if (sym->attr.dimension) + { + ref->u.ar.as = sym->as; + ref = ref->next; + } + + /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */ + if (e->ts.type == BT_CHARACTER + && ref + && ref->type == REF_ARRAY + && ref->u.ar.dimen == 1 + && ref->u.ar.dimen_type[0] == DIMEN_RANGE + && ref->u.ar.stride[0] == NULL) + { + gfc_expr *start = ref->u.ar.start[0]; + gfc_expr *end = ref->u.ar.end[0]; + void *mem = NULL; + + /* Optimize away the (:) reference. */ + if (start == NULL && end == NULL) + { + if (e->ref == ref) + e->ref = ref->next; + else + e->ref->next = ref->next; + mem = ref; + } + else + { + ref->type = REF_SUBSTRING; + if (start == NULL) + start = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, 1); + ref->u.ss.start = start; + if (end == NULL && e->ts.u.cl) + end = gfc_copy_expr (e->ts.u.cl->length); + ref->u.ss.end = end; + ref->u.ss.length = e->ts.u.cl; + e->ts.u.cl = NULL; + } + ref = ref->next; + free (mem); + } + + /* Any further ref is an error. */ + if (ref) + { + gcc_assert (ref->type == REF_ARRAY); + gfc_error ("Syntax error in EQUIVALENCE statement at %L", + &ref->u.ar.where); + continue; + } + } + + if (!gfc_resolve_expr (e)) + continue; + + sym = e->symtree->n.sym; + + if (sym->attr.is_protected) + cnt_protected++; + if (cnt_protected > 0 && cnt_protected != object) + { + gfc_error ("Either all or none of the objects in the " + "EQUIVALENCE set at %L shall have the " + "PROTECTED attribute", + &e->where); + break; + } + + /* Shall not equivalence common block variables in a PURE procedure. */ + if (sym->ns->proc_name + && sym->ns->proc_name->attr.pure + && sym->attr.in_common) + { + /* Need to check for symbols that may have entered the pure + procedure via a USE statement. */ + bool saw_sym = false; + if (sym->ns->use_stmts) + { + gfc_use_rename *r; + for (r = sym->ns->use_stmts->rename; r; r = r->next) + if (strcmp(r->use_name, sym->name) == 0) saw_sym = true; + } + else + saw_sym = true; + + if (saw_sym) + gfc_error ("COMMON block member %qs at %L cannot be an " + "EQUIVALENCE object in the pure procedure %qs", + sym->name, &e->where, sym->ns->proc_name->name); + break; + } + + /* Shall not be a named constant. */ + if (e->expr_type == EXPR_CONSTANT) + { + gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE " + "object", sym->name, &e->where); + continue; + } + + if (e->ts.type == BT_DERIVED + && !resolve_equivalence_derived (e->ts.u.derived, sym, e)) + continue; + + /* Check that the types correspond correctly: + Note 5.28: + A numeric sequence structure may be equivalenced to another sequence + structure, an object of default integer type, default real type, double + precision real type, default logical type such that components of the + structure ultimately only become associated to objects of the same + kind. A character sequence structure may be equivalenced to an object + of default character kind or another character sequence structure. + Other objects may be equivalenced only to objects of the same type and + kind parameters. */ + + /* Identical types are unconditionally OK. */ + if (object == 1 || gfc_compare_types (last_ts, &sym->ts)) + goto identical_types; + + last_eq_type = sequence_type (*last_ts); + eq_type = sequence_type (sym->ts); + + /* Since the pair of objects is not of the same type, mixed or + non-default sequences can be rejected. */ + + msg = "Sequence %s with mixed components in EQUIVALENCE " + "statement at %L with different type objects"; + if ((object ==2 + && last_eq_type == SEQ_MIXED + && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) + || (eq_type == SEQ_MIXED + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) + continue; + + msg = "Non-default type object or sequence %s in EQUIVALENCE " + "statement at %L with objects of different type"; + if ((object ==2 + && last_eq_type == SEQ_NONDEFAULT + && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) + || (eq_type == SEQ_NONDEFAULT + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) + continue; + + msg ="Non-CHARACTER object %qs in default CHARACTER " + "EQUIVALENCE statement at %L"; + if (last_eq_type == SEQ_CHARACTER + && eq_type != SEQ_CHARACTER + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) + continue; + + msg ="Non-NUMERIC object %qs in default NUMERIC " + "EQUIVALENCE statement at %L"; + if (last_eq_type == SEQ_NUMERIC + && eq_type != SEQ_NUMERIC + && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) + continue; + +identical_types: + + last_ts =&sym->ts; + last_where = &e->where; + + if (!e->ref) + continue; + + /* Shall not be an automatic array. */ + if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym)) + { + gfc_error ("Array %qs at %L with non-constant bounds cannot be " + "an EQUIVALENCE object", sym->name, &e->where); + continue; + } + + r = e->ref; + while (r) + { + /* Shall not be a structure component. */ + if (r->type == REF_COMPONENT) + { + gfc_error ("Structure component %qs at %L cannot be an " + "EQUIVALENCE object", + r->u.c.component->name, &e->where); + break; + } + + /* A substring shall not have length zero. */ + if (r->type == REF_SUBSTRING) + { + if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT) + { + gfc_error ("Substring at %L has length zero", + &r->u.ss.start->where); + break; + } + } + r = r->next; + } + } +} + + +/* Function called by resolve_fntype to flag other symbols used in the + length type parameter specification of function results. */ + +static bool +flag_fn_result_spec (gfc_expr *expr, + gfc_symbol *sym, + int *f ATTRIBUTE_UNUSED) +{ + gfc_namespace *ns; + gfc_symbol *s; + + if (expr->expr_type == EXPR_VARIABLE) + { + s = expr->symtree->n.sym; + for (ns = s->ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (sym == s) + { + gfc_error ("Self reference in character length expression " + "for %qs at %L", sym->name, &expr->where); + return true; + } + + if (!s->fn_result_spec + && s->attr.flavor == FL_PARAMETER) + { + /* Function contained in a module.... */ + if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE) + { + gfc_symtree *st; + s->fn_result_spec = 1; + /* Make sure that this symbol is translated as a module + variable. */ + st = gfc_get_unique_symtree (ns); + st->n.sym = s; + s->refs++; + } + /* ... which is use associated and called. */ + else if (s->attr.use_assoc || s->attr.used_in_submodule + || + /* External function matched with an interface. */ + (s->ns->proc_name + && ((s->ns == ns + && s->ns->proc_name->attr.if_source == IFSRC_DECL) + || s->ns->proc_name->attr.if_source == IFSRC_IFBODY) + && s->ns->proc_name->attr.function)) + s->fn_result_spec = 1; + } + } + return false; +} + + +/* Resolve function and ENTRY types, issue diagnostics if needed. */ + +static void +resolve_fntype (gfc_namespace *ns) +{ + gfc_entry_list *el; + gfc_symbol *sym; + + if (ns->proc_name == NULL || !ns->proc_name->attr.function) + return; + + /* If there are any entries, ns->proc_name is the entry master + synthetic symbol and ns->entries->sym actual FUNCTION symbol. */ + if (ns->entries) + sym = ns->entries->sym; + else + sym = ns->proc_name; + if (sym->result == sym + && sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (sym, 0, NULL) + && !sym->attr.untyped) + { + gfc_error ("Function %qs at %L has no IMPLICIT type", + sym->name, &sym->declared_at); + sym->attr.untyped = 1; + } + + if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc + && !sym->attr.contained + && !gfc_check_symbol_access (sym->ts.u.derived) + && gfc_check_symbol_access (sym)) + { + gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at " + "%L of PRIVATE type %qs", sym->name, + &sym->declared_at, sym->ts.u.derived->name); + } + + if (ns->entries) + for (el = ns->entries->next; el; el = el->next) + { + if (el->sym->result == el->sym + && el->sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (el->sym, 0, NULL) + && !el->sym->attr.untyped) + { + gfc_error ("ENTRY %qs at %L has no IMPLICIT type", + el->sym->name, &el->sym->declared_at); + el->sym->attr.untyped = 1; + } + } + + if (sym->ts.type == BT_CHARACTER) + gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0); +} + + +/* 12.3.2.1.1 Defined operators. */ + +static bool +check_uop_procedure (gfc_symbol *sym, locus where) +{ + gfc_formal_arglist *formal; + + if (!sym->attr.function) + { + gfc_error ("User operator procedure %qs at %L must be a FUNCTION", + sym->name, &where); + return false; + } + + if (sym->ts.type == BT_CHARACTER + && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred) + && !(sym->result && ((sym->result->ts.u.cl + && sym->result->ts.u.cl->length) || sym->result->ts.deferred))) + { + gfc_error ("User operator procedure %qs at %L cannot be assumed " + "character length", sym->name, &where); + return false; + } + + formal = gfc_sym_get_dummy_args (sym); + if (!formal || !formal->sym) + { + gfc_error ("User operator procedure %qs at %L must have at least " + "one argument", sym->name, &where); + return false; + } + + if (formal->sym->attr.intent != INTENT_IN) + { + gfc_error ("First argument of operator interface at %L must be " + "INTENT(IN)", &where); + return false; + } + + if (formal->sym->attr.optional) + { + gfc_error ("First argument of operator interface at %L cannot be " + "optional", &where); + return false; + } + + formal = formal->next; + if (!formal || !formal->sym) + return true; + + if (formal->sym->attr.intent != INTENT_IN) + { + gfc_error ("Second argument of operator interface at %L must be " + "INTENT(IN)", &where); + return false; + } + + if (formal->sym->attr.optional) + { + gfc_error ("Second argument of operator interface at %L cannot be " + "optional", &where); + return false; + } + + if (formal->next) + { + gfc_error ("Operator interface at %L must have, at most, two " + "arguments", &where); + return false; + } + + return true; +} + +static void +gfc_resolve_uops (gfc_symtree *symtree) +{ + gfc_interface *itr; + + if (symtree == NULL) + return; + + gfc_resolve_uops (symtree->left); + gfc_resolve_uops (symtree->right); + + for (itr = symtree->n.uop->op; itr; itr = itr->next) + check_uop_procedure (itr->sym, itr->sym->declared_at); +} + + +/* Examine all of the expressions associated with a program unit, + assign types to all intermediate expressions, make sure that all + assignments are to compatible types and figure out which names + refer to which functions or subroutines. It doesn't check code + block, which is handled by gfc_resolve_code. */ + +static void +resolve_types (gfc_namespace *ns) +{ + gfc_namespace *n; + gfc_charlen *cl; + gfc_data *d; + gfc_equiv *eq; + gfc_namespace* old_ns = gfc_current_ns; + bool recursive = ns->proc_name && ns->proc_name->attr.recursive; + + if (ns->types_resolved) + return; + + /* Check that all IMPLICIT types are ok. */ + if (!ns->seen_implicit_none) + { + unsigned letter; + for (letter = 0; letter != GFC_LETTERS; ++letter) + if (ns->set_flag[letter] + && !resolve_typespec_used (&ns->default_type[letter], + &ns->implicit_loc[letter], NULL)) + return; + } + + gfc_current_ns = ns; + + resolve_entries (ns); + + resolve_common_vars (&ns->blank_common, false); + resolve_common_blocks (ns->common_root); + + resolve_contained_functions (ns); + + if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE + && ns->proc_name->attr.if_source == IFSRC_IFBODY) + gfc_resolve_formal_arglist (ns->proc_name); + + gfc_traverse_ns (ns, resolve_bind_c_derived_types); + + for (cl = ns->cl_list; cl; cl = cl->next) + resolve_charlen (cl); + + gfc_traverse_ns (ns, resolve_symbol); + + resolve_fntype (ns); + + for (n = ns->contained; n; n = n->sibling) + { + if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name)) + gfc_error ("Contained procedure %qs at %L of a PURE procedure must " + "also be PURE", n->proc_name->name, + &n->proc_name->declared_at); + + resolve_types (n); + } + + forall_flag = 0; + gfc_do_concurrent_flag = 0; + gfc_check_interfaces (ns); + + gfc_traverse_ns (ns, resolve_values); + + if (ns->save_all || (!flag_automatic && !recursive)) + gfc_save_all (ns); + + iter_stack = NULL; + for (d = ns->data; d; d = d->next) + resolve_data (d); + + iter_stack = NULL; + gfc_traverse_ns (ns, gfc_formalize_init_value); + + gfc_traverse_ns (ns, gfc_verify_binding_labels); + + for (eq = ns->equiv; eq; eq = eq->next) + resolve_equivalence (eq); + + /* Warn about unused labels. */ + if (warn_unused_label) + warn_unused_fortran_label (ns->st_labels); + + gfc_resolve_uops (ns->uop_root); + + gfc_traverse_ns (ns, gfc_verify_DTIO_procedures); + + gfc_resolve_omp_declare_simd (ns); + + gfc_resolve_omp_udrs (ns->omp_udr_root); + + ns->types_resolved = 1; + + gfc_current_ns = old_ns; +} + + +/* Call gfc_resolve_code recursively. */ + +static void +resolve_codes (gfc_namespace *ns) +{ + gfc_namespace *n; + bitmap_obstack old_obstack; + + if (ns->resolved == 1) + return; + + for (n = ns->contained; n; n = n->sibling) + resolve_codes (n); + + gfc_current_ns = ns; + + /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */ + if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)) + cs_base = NULL; + + /* Set to an out of range value. */ + current_entry_id = -1; + + old_obstack = labels_obstack; + bitmap_obstack_initialize (&labels_obstack); + + gfc_resolve_oacc_declare (ns); + gfc_resolve_oacc_routines (ns); + gfc_resolve_omp_local_vars (ns); + gfc_resolve_code (ns->code, ns); + + bitmap_obstack_release (&labels_obstack); + labels_obstack = old_obstack; +} + + +/* This function is called after a complete program unit has been compiled. + Its purpose is to examine all of the expressions associated with a program + unit, assign types to all intermediate expressions, make sure that all + assignments are to compatible types and figure out which names refer to + which functions or subroutines. */ + +void +gfc_resolve (gfc_namespace *ns) +{ + gfc_namespace *old_ns; + code_stack *old_cs_base; + struct gfc_omp_saved_state old_omp_state; + + if (ns->resolved) + return; + + ns->resolved = -1; + old_ns = gfc_current_ns; + old_cs_base = cs_base; + + /* As gfc_resolve can be called during resolution of an OpenMP construct + body, we should clear any state associated to it, so that say NS's + DO loops are not interpreted as OpenMP loops. */ + if (!ns->construct_entities) + gfc_omp_save_and_clear_state (&old_omp_state); + + resolve_types (ns); + component_assignment_level = 0; + resolve_codes (ns); + + gfc_current_ns = old_ns; + cs_base = old_cs_base; + ns->resolved = 1; + + gfc_run_passes (ns); + + if (!ns->construct_entities) + gfc_omp_restore_state (&old_omp_state); +} diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c deleted file mode 100644 index 4df6576..0000000 --- a/gcc/fortran/scanner.c +++ /dev/null @@ -1,2903 +0,0 @@ -/* Character scanner. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -/* Set of subroutines to (ultimately) return the next character to the - various matching subroutines. This file's job is to read files and - build up lines that are parsed by the parser. This means that we - handle continuation lines and "include" lines. - - The first thing the scanner does is to load an entire file into - memory. We load the entire file into memory for a couple reasons. - The first is that we want to be able to deal with nonseekable input - (pipes, stdin) and there is a lot of backing up involved during - parsing. - - The second is that we want to be able to print the locus of errors, - and an error on line 999999 could conflict with something on line - one. Given nonseekable input, we've got to store the whole thing. - - One thing that helps are the column truncation limits that give us - an upper bound on the size of individual lines. We don't store the - truncated stuff. - - From the scanner's viewpoint, the higher level subroutines ask for - new characters and do a lot of jumping backwards. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" -#include "toplev.h" /* For set_src_pwd. */ -#include "debug.h" -#include "options.h" -#include "diagnostic-core.h" /* For fatal_error. */ -#include "cpp.h" -#include "scanner.h" - -/* List of include file search directories. */ -gfc_directorylist *include_dirs, *intrinsic_modules_dirs; - -static gfc_file *file_head, *current_file; - -static int continue_flag, end_flag, gcc_attribute_flag; -/* If !$omp/!$acc occurred in current comment line. */ -static int openmp_flag, openacc_flag; -static int continue_count, continue_line; -static locus openmp_locus; -static locus openacc_locus; -static locus gcc_attribute_locus; - -gfc_source_form gfc_current_form; -static gfc_linebuf *line_head, *line_tail; - -locus gfc_current_locus; -const char *gfc_source_file; -static FILE *gfc_src_file; -static gfc_char_t *gfc_src_preprocessor_lines[2]; - -static struct gfc_file_change -{ - const char *filename; - gfc_linebuf *lb; - int line; -} *file_changes; -static size_t file_changes_cur, file_changes_count; -static size_t file_changes_allocated; - -static gfc_char_t *last_error_char; - -/* Functions dealing with our wide characters (gfc_char_t) and - sequences of such characters. */ - -int -gfc_wide_fits_in_byte (gfc_char_t c) -{ - return (c <= UCHAR_MAX); -} - -static inline int -wide_is_ascii (gfc_char_t c) -{ - return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0); -} - -int -gfc_wide_is_printable (gfc_char_t c) -{ - return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c)); -} - -gfc_char_t -gfc_wide_tolower (gfc_char_t c) -{ - return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c); -} - -gfc_char_t -gfc_wide_toupper (gfc_char_t c) -{ - return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c); -} - -int -gfc_wide_is_digit (gfc_char_t c) -{ - return (c >= '0' && c <= '9'); -} - -static inline int -wide_atoi (gfc_char_t *c) -{ -#define MAX_DIGITS 20 - char buf[MAX_DIGITS+1]; - int i = 0; - - while (gfc_wide_is_digit(*c) && i < MAX_DIGITS) - buf[i++] = *c++; - buf[i] = '\0'; - return atoi (buf); -} - -size_t -gfc_wide_strlen (const gfc_char_t *str) -{ - size_t i; - - for (i = 0; str[i]; i++) - ; - - return i; -} - -gfc_char_t * -gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len) -{ - size_t i; - - for (i = 0; i < len; i++) - b[i] = c; - - return b; -} - -static gfc_char_t * -wide_strcpy (gfc_char_t *dest, const gfc_char_t *src) -{ - gfc_char_t *d; - - for (d = dest; (*d = *src) != '\0'; ++src, ++d) - ; - - return dest; -} - -static gfc_char_t * -wide_strchr (const gfc_char_t *s, gfc_char_t c) -{ - do { - if (*s == c) - { - return CONST_CAST(gfc_char_t *, s); - } - } while (*s++); - return 0; -} - -char * -gfc_widechar_to_char (const gfc_char_t *s, int length) -{ - size_t len, i; - char *res; - - if (s == NULL) - return NULL; - - /* Passing a negative length is used to indicate that length should be - calculated using gfc_wide_strlen(). */ - len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s)); - res = XNEWVEC (char, len + 1); - - for (i = 0; i < len; i++) - { - gcc_assert (gfc_wide_fits_in_byte (s[i])); - res[i] = (unsigned char) s[i]; - } - - res[len] = '\0'; - return res; -} - -gfc_char_t * -gfc_char_to_widechar (const char *s) -{ - size_t len, i; - gfc_char_t *res; - - if (s == NULL) - return NULL; - - len = strlen (s); - res = gfc_get_wide_string (len + 1); - - for (i = 0; i < len; i++) - res[i] = (unsigned char) s[i]; - - res[len] = '\0'; - return res; -} - -static int -wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n) -{ - gfc_char_t c1, c2; - - while (n-- > 0) - { - c1 = *s1++; - c2 = *s2++; - if (c1 != c2) - return (c1 > c2 ? 1 : -1); - if (c1 == '\0') - return 0; - } - return 0; -} - -int -gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n) -{ - gfc_char_t c1, c2; - - while (n-- > 0) - { - c1 = gfc_wide_tolower (*s1++); - c2 = TOLOWER (*s2++); - if (c1 != c2) - return (c1 > c2 ? 1 : -1); - if (c1 == '\0') - return 0; - } - return 0; -} - - -/* Main scanner initialization. */ - -void -gfc_scanner_init_1 (void) -{ - file_head = NULL; - line_head = NULL; - line_tail = NULL; - - continue_count = 0; - continue_line = 0; - - end_flag = 0; - last_error_char = NULL; -} - - -/* Main scanner destructor. */ - -void -gfc_scanner_done_1 (void) -{ - gfc_linebuf *lb; - gfc_file *f; - - while(line_head != NULL) - { - lb = line_head->next; - free (line_head); - line_head = lb; - } - - while(file_head != NULL) - { - f = file_head->next; - free (file_head->filename); - free (file_head); - file_head = f; - } -} - -static bool -gfc_do_check_include_dir (const char *path, bool warn) -{ - struct stat st; - if (stat (path, &st)) - { - if (errno != ENOENT) - gfc_warning_now (0, "Include directory %qs: %s", - path, xstrerror(errno)); - else if (warn) - gfc_warning_now (OPT_Wmissing_include_dirs, - "Nonexistent include directory %qs", path); - return false; - } - else if (!S_ISDIR (st.st_mode)) - { - gfc_fatal_error ("%qs is not a directory", path); - return false; - } - return true; -} - -/* In order that -W(no-)missing-include-dirs works, the diagnostic can only be - run after processing the commandline. */ -static void -gfc_do_check_include_dirs (gfc_directorylist **list, bool do_warn) -{ - gfc_directorylist *prev, *q, *n; - prev = NULL; - n = *list; - while (n) - { - q = n; n = n->next; - if (gfc_do_check_include_dir (q->path, q->warn && do_warn)) - { - prev = q; - continue; - } - if (prev == NULL) - *list = n; - else - prev->next = n; - free (q->path); - free (q); - } -} - -void -gfc_check_include_dirs (bool verbose_missing_dir_warn) -{ - /* This is a bit convoluted: If gfc_cpp_enabled () and - verbose_missing_dir_warn, the warning is shown by libcpp. Otherwise, - it is shown here, still conditional on OPT_Wmissing_include_dirs. */ - bool warn = !gfc_cpp_enabled () || !verbose_missing_dir_warn; - gfc_do_check_include_dirs (&include_dirs, warn); - gfc_do_check_include_dirs (&intrinsic_modules_dirs, verbose_missing_dir_warn); - if (gfc_option.module_dir && gfc_cpp_enabled ()) - gfc_do_check_include_dirs (&include_dirs, true); -} - -/* Adds path to the list pointed to by list. */ - -static void -add_path_to_list (gfc_directorylist **list, const char *path, - bool use_for_modules, bool head, bool warn, bool defer_warn) -{ - gfc_directorylist *dir; - const char *p; - char *q; - size_t len; - int i; - - p = path; - while (*p == ' ' || *p == '\t') /* someone might do "-I include" */ - if (*p++ == '\0') - return; - - /* Strip trailing directory separators from the path, as this - will confuse Windows systems. */ - len = strlen (p); - q = (char *) alloca (len + 1); - memcpy (q, p, len + 1); - i = len - 1; - while (i >=0 && IS_DIR_SEPARATOR (q[i])) - q[i--] = '\0'; - - if (!defer_warn && !gfc_do_check_include_dir (q, warn)) - return; - - if (head || *list == NULL) - { - dir = XCNEW (gfc_directorylist); - if (!head) - *list = dir; - } - else - { - dir = *list; - while (dir->next) - dir = dir->next; - - dir->next = XCNEW (gfc_directorylist); - dir = dir->next; - } - - dir->next = head ? *list : NULL; - if (head) - *list = dir; - dir->use_for_modules = use_for_modules; - dir->warn = warn; - dir->path = XCNEWVEC (char, strlen (p) + 2); - strcpy (dir->path, p); - strcat (dir->path, "/"); /* make '/' last character */ -} - -/* defer_warn is set to true while parsing the commandline. */ - -void -gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir, - bool warn, bool defer_warn) -{ - add_path_to_list (&include_dirs, path, use_for_modules, file_dir, warn, - defer_warn); - - /* For '#include "..."' these directories are automatically searched. */ - if (!file_dir) - gfc_cpp_add_include_path (xstrdup(path), true); -} - - -void -gfc_add_intrinsic_modules_path (const char *path) -{ - add_path_to_list (&intrinsic_modules_dirs, path, true, false, false, false); -} - - -/* Release resources allocated for options. */ - -void -gfc_release_include_path (void) -{ - gfc_directorylist *p; - - while (include_dirs != NULL) - { - p = include_dirs; - include_dirs = include_dirs->next; - free (p->path); - free (p); - } - - while (intrinsic_modules_dirs != NULL) - { - p = intrinsic_modules_dirs; - intrinsic_modules_dirs = intrinsic_modules_dirs->next; - free (p->path); - free (p); - } - - free (gfc_option.module_dir); -} - - -static FILE * -open_included_file (const char *name, gfc_directorylist *list, - bool module, bool system) -{ - char *fullname; - gfc_directorylist *p; - FILE *f; - - for (p = list; p; p = p->next) - { - if (module && !p->use_for_modules) - continue; - - fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); - strcpy (fullname, p->path); - strcat (fullname, name); - - f = gfc_open_file (fullname); - if (f != NULL) - { - if (gfc_cpp_makedep ()) - gfc_cpp_add_dep (fullname, system); - - return f; - } - } - - return NULL; -} - - -/* Opens file for reading, searching through the include directories - given if necessary. If the include_cwd argument is true, we try - to open the file in the current directory first. */ - -FILE * -gfc_open_included_file (const char *name, bool include_cwd, bool module) -{ - FILE *f = NULL; - - if (IS_ABSOLUTE_PATH (name) || include_cwd) - { - f = gfc_open_file (name); - if (f && gfc_cpp_makedep ()) - gfc_cpp_add_dep (name, false); - } - - if (!f) - f = open_included_file (name, include_dirs, module, false); - - return f; -} - - -/* Test to see if we're at the end of the main source file. */ - -int -gfc_at_end (void) -{ - return end_flag; -} - - -/* Test to see if we're at the end of the current file. */ - -int -gfc_at_eof (void) -{ - if (gfc_at_end ()) - return 1; - - if (line_head == NULL) - return 1; /* Null file */ - - if (gfc_current_locus.lb == NULL) - return 1; - - return 0; -} - - -/* Test to see if we're at the beginning of a new line. */ - -int -gfc_at_bol (void) -{ - if (gfc_at_eof ()) - return 1; - - return (gfc_current_locus.nextc == gfc_current_locus.lb->line); -} - - -/* Test to see if we're at the end of a line. */ - -int -gfc_at_eol (void) -{ - if (gfc_at_eof ()) - return 1; - - return (*gfc_current_locus.nextc == '\0'); -} - -static void -add_file_change (const char *filename, int line) -{ - if (file_changes_count == file_changes_allocated) - { - if (file_changes_allocated) - file_changes_allocated *= 2; - else - file_changes_allocated = 16; - file_changes = XRESIZEVEC (struct gfc_file_change, file_changes, - file_changes_allocated); - } - file_changes[file_changes_count].filename = filename; - file_changes[file_changes_count].lb = NULL; - file_changes[file_changes_count++].line = line; -} - -static void -report_file_change (gfc_linebuf *lb) -{ - size_t c = file_changes_cur; - while (c < file_changes_count - && file_changes[c].lb == lb) - { - if (file_changes[c].filename) - (*debug_hooks->start_source_file) (file_changes[c].line, - file_changes[c].filename); - else - (*debug_hooks->end_source_file) (file_changes[c].line); - ++c; - } - file_changes_cur = c; -} - -void -gfc_start_source_files (void) -{ - /* If the debugger wants the name of the main source file, - we give it. */ - if (debug_hooks->start_end_main_source_file) - (*debug_hooks->start_source_file) (0, gfc_source_file); - - file_changes_cur = 0; - report_file_change (gfc_current_locus.lb); -} - -void -gfc_end_source_files (void) -{ - report_file_change (NULL); - - if (debug_hooks->start_end_main_source_file) - (*debug_hooks->end_source_file) (0); -} - -/* Advance the current line pointer to the next line. */ - -void -gfc_advance_line (void) -{ - if (gfc_at_end ()) - return; - - if (gfc_current_locus.lb == NULL) - { - end_flag = 1; - return; - } - - if (gfc_current_locus.lb->next - && !gfc_current_locus.lb->next->dbg_emitted) - { - report_file_change (gfc_current_locus.lb->next); - gfc_current_locus.lb->next->dbg_emitted = true; - } - - gfc_current_locus.lb = gfc_current_locus.lb->next; - - if (gfc_current_locus.lb != NULL) - gfc_current_locus.nextc = gfc_current_locus.lb->line; - else - { - gfc_current_locus.nextc = NULL; - end_flag = 1; - } -} - - -/* Get the next character from the input, advancing gfc_current_file's - locus. When we hit the end of the line or the end of the file, we - start returning a '\n' in order to complete the current statement. - No Fortran line conventions are implemented here. - - Requiring explicit advances to the next line prevents the parse - pointer from being on the wrong line if the current statement ends - prematurely. */ - -static gfc_char_t -next_char (void) -{ - gfc_char_t c; - - if (gfc_current_locus.nextc == NULL) - return '\n'; - - c = *gfc_current_locus.nextc++; - if (c == '\0') - { - gfc_current_locus.nextc--; /* Remain on this line. */ - c = '\n'; - } - - return c; -} - - -/* Skip a comment. When we come here the parse pointer is positioned - immediately after the comment character. If we ever implement - compiler directives within comments, here is where we parse the - directive. */ - -static void -skip_comment_line (void) -{ - gfc_char_t c; - - do - { - c = next_char (); - } - while (c != '\n'); - - gfc_advance_line (); -} - - -int -gfc_define_undef_line (void) -{ - char *tmp; - - /* All lines beginning with '#' are either #define or #undef. */ - if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#') - return 0; - - if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0) - { - tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1); - (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb), - tmp); - free (tmp); - } - - if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0) - { - tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1); - (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb), - tmp); - free (tmp); - } - - /* Skip the rest of the line. */ - skip_comment_line (); - - return 1; -} - - -/* Return true if GCC$ was matched. */ -static bool -skip_gcc_attribute (locus start) -{ - bool r = false; - char c; - locus old_loc = gfc_current_locus; - - if ((c = next_char ()) == 'g' || c == 'G') - if ((c = next_char ()) == 'c' || c == 'C') - if ((c = next_char ()) == 'c' || c == 'C') - if ((c = next_char ()) == '$') - r = true; - - if (r == false) - gfc_current_locus = old_loc; - else - { - gcc_attribute_flag = 1; - gcc_attribute_locus = old_loc; - gfc_current_locus = start; - } - - return r; -} - -/* Return true if CC was matched. */ -static bool -skip_free_oacc_sentinel (locus start, locus old_loc) -{ - bool r = false; - char c; - - if ((c = next_char ()) == 'c' || c == 'C') - if ((c = next_char ()) == 'c' || c == 'C') - r = true; - - if (r) - { - if ((c = next_char ()) == ' ' || c == '\t' - || continue_flag) - { - while (gfc_is_whitespace (c)) - c = next_char (); - if (c != '\n' && c != '!') - { - openacc_flag = 1; - openacc_locus = old_loc; - gfc_current_locus = start; - } - else - r = false; - } - else - { - gfc_warning_now (0, "!$ACC at %C starts a commented " - "line as it neither is followed " - "by a space nor is a " - "continuation line"); - r = false; - } - } - - return r; -} - -/* Return true if MP was matched. */ -static bool -skip_free_omp_sentinel (locus start, locus old_loc) -{ - bool r = false; - char c; - - if ((c = next_char ()) == 'm' || c == 'M') - if ((c = next_char ()) == 'p' || c == 'P') - r = true; - - if (r) - { - if ((c = next_char ()) == ' ' || c == '\t' - || continue_flag) - { - while (gfc_is_whitespace (c)) - c = next_char (); - if (c != '\n' && c != '!') - { - openmp_flag = 1; - openmp_locus = old_loc; - gfc_current_locus = start; - } - else - r = false; - } - else - { - gfc_warning_now (0, "!$OMP at %C starts a commented " - "line as it neither is followed " - "by a space nor is a " - "continuation line"); - r = false; - } - } - - return r; -} - -/* Comment lines are null lines, lines containing only blanks or lines - on which the first nonblank line is a '!'. - Return true if !$ openmp or openacc conditional compilation sentinel was - seen. */ - -static bool -skip_free_comments (void) -{ - locus start; - gfc_char_t c; - int at_bol; - - for (;;) - { - at_bol = gfc_at_bol (); - start = gfc_current_locus; - if (gfc_at_eof ()) - break; - - do - c = next_char (); - while (gfc_is_whitespace (c)); - - if (c == '\n') - { - gfc_advance_line (); - continue; - } - - if (c == '!') - { - /* Keep the !GCC$ line. */ - if (at_bol && skip_gcc_attribute (start)) - return false; - - /* If -fopenmp/-fopenacc, we need to handle here 2 things: - 1) don't treat !$omp/!$acc as comments, but directives - 2) handle OpenMP/OpenACC conditional compilation, where - !$ should be treated as 2 spaces (for initial lines - only if followed by space). */ - if (at_bol) - { - if ((flag_openmp || flag_openmp_simd) - && flag_openacc) - { - locus old_loc = gfc_current_locus; - if (next_char () == '$') - { - c = next_char (); - if (c == 'o' || c == 'O') - { - if (skip_free_omp_sentinel (start, old_loc)) - return false; - gfc_current_locus = old_loc; - next_char (); - c = next_char (); - } - else if (c == 'a' || c == 'A') - { - if (skip_free_oacc_sentinel (start, old_loc)) - return false; - gfc_current_locus = old_loc; - next_char (); - c = next_char (); - } - if (continue_flag || c == ' ' || c == '\t') - { - gfc_current_locus = old_loc; - next_char (); - openmp_flag = openacc_flag = 0; - return true; - } - } - gfc_current_locus = old_loc; - } - else if ((flag_openmp || flag_openmp_simd) - && !flag_openacc) - { - locus old_loc = gfc_current_locus; - if (next_char () == '$') - { - c = next_char (); - if (c == 'o' || c == 'O') - { - if (skip_free_omp_sentinel (start, old_loc)) - return false; - gfc_current_locus = old_loc; - next_char (); - c = next_char (); - } - if (continue_flag || c == ' ' || c == '\t') - { - gfc_current_locus = old_loc; - next_char (); - openmp_flag = 0; - return true; - } - } - gfc_current_locus = old_loc; - } - else if (flag_openacc - && !(flag_openmp || flag_openmp_simd)) - { - locus old_loc = gfc_current_locus; - if (next_char () == '$') - { - c = next_char (); - if (c == 'a' || c == 'A') - { - if (skip_free_oacc_sentinel (start, old_loc)) - return false; - gfc_current_locus = old_loc; - next_char(); - c = next_char(); - } - } - gfc_current_locus = old_loc; - } - } - skip_comment_line (); - continue; - } - - break; - } - - if (openmp_flag && at_bol) - openmp_flag = 0; - - if (openacc_flag && at_bol) - openacc_flag = 0; - - gcc_attribute_flag = 0; - gfc_current_locus = start; - return false; -} - -/* Return true if MP was matched in fixed form. */ -static bool -skip_fixed_omp_sentinel (locus *start) -{ - gfc_char_t c; - if (((c = next_char ()) == 'm' || c == 'M') - && ((c = next_char ()) == 'p' || c == 'P')) - { - c = next_char (); - if (c != '\n' - && (continue_flag - || c == ' ' || c == '\t' || c == '0')) - { - if (c == ' ' || c == '\t' || c == '0') - openacc_flag = 0; - do - c = next_char (); - while (gfc_is_whitespace (c)); - if (c != '\n' && c != '!') - { - /* Canonicalize to *$omp. */ - *start->nextc = '*'; - openmp_flag = 1; - gfc_current_locus = *start; - return true; - } - } - } - return false; -} - -/* Return true if CC was matched in fixed form. */ -static bool -skip_fixed_oacc_sentinel (locus *start) -{ - gfc_char_t c; - if (((c = next_char ()) == 'c' || c == 'C') - && ((c = next_char ()) == 'c' || c == 'C')) - { - c = next_char (); - if (c != '\n' - && (continue_flag - || c == ' ' || c == '\t' || c == '0')) - { - if (c == ' ' || c == '\t' || c == '0') - openmp_flag = 0; - do - c = next_char (); - while (gfc_is_whitespace (c)); - if (c != '\n' && c != '!') - { - /* Canonicalize to *$acc. */ - *start->nextc = '*'; - openacc_flag = 1; - gfc_current_locus = *start; - return true; - } - } - } - return false; -} - -/* Skip comment lines in fixed source mode. We have the same rules as - in skip_free_comment(), except that we can have a 'c', 'C' or '*' - in column 1, and a '!' cannot be in column 6. Also, we deal with - lines with 'd' or 'D' in column 1, if the user requested this. */ - -static void -skip_fixed_comments (void) -{ - locus start; - int col; - gfc_char_t c; - - if (! gfc_at_bol ()) - { - start = gfc_current_locus; - if (! gfc_at_eof ()) - { - do - c = next_char (); - while (gfc_is_whitespace (c)); - - if (c == '\n') - gfc_advance_line (); - else if (c == '!') - skip_comment_line (); - } - - if (! gfc_at_bol ()) - { - gfc_current_locus = start; - return; - } - } - - for (;;) - { - start = gfc_current_locus; - if (gfc_at_eof ()) - break; - - c = next_char (); - if (c == '\n') - { - gfc_advance_line (); - continue; - } - - if (c == '!' || c == 'c' || c == 'C' || c == '*') - { - if (skip_gcc_attribute (start)) - { - /* Canonicalize to *$omp. */ - *start.nextc = '*'; - return; - } - - if (gfc_current_locus.lb != NULL - && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) - continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); - - /* If -fopenmp/-fopenacc, we need to handle here 2 things: - 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments, - but directives - 2) handle OpenMP/OpenACC conditional compilation, where - !$|c$|*$ should be treated as 2 spaces if the characters - in columns 3 to 6 are valid fixed form label columns - characters. */ - if ((flag_openmp || flag_openmp_simd) && !flag_openacc) - { - if (next_char () == '$') - { - c = next_char (); - if (c == 'o' || c == 'O') - { - if (skip_fixed_omp_sentinel (&start)) - return; - } - else - goto check_for_digits; - } - gfc_current_locus = start; - } - else if (flag_openacc && !(flag_openmp || flag_openmp_simd)) - { - if (next_char () == '$') - { - c = next_char (); - if (c == 'a' || c == 'A') - { - if (skip_fixed_oacc_sentinel (&start)) - return; - } - } - gfc_current_locus = start; - } - else if (flag_openacc || flag_openmp || flag_openmp_simd) - { - if (next_char () == '$') - { - c = next_char (); - if (c == 'a' || c == 'A') - { - if (skip_fixed_oacc_sentinel (&start)) - return; - } - else if (c == 'o' || c == 'O') - { - if (skip_fixed_omp_sentinel (&start)) - return; - } - else - goto check_for_digits; - } - gfc_current_locus = start; - } - - skip_comment_line (); - continue; - -check_for_digits: - { - /* Required for OpenMP's conditional compilation sentinel. */ - int digit_seen = 0; - - for (col = 3; col < 6; col++, c = next_char ()) - if (c == ' ') - continue; - else if (c == '\t') - { - col = 6; - break; - } - else if (c < '0' || c > '9') - break; - else - digit_seen = 1; - - if (col == 6 && c != '\n' - && ((continue_flag && !digit_seen) - || c == ' ' || c == '\t' || c == '0')) - { - gfc_current_locus = start; - start.nextc[0] = ' '; - start.nextc[1] = ' '; - continue; - } - } - skip_comment_line (); - continue; - } - - if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D')) - { - if (gfc_option.flag_d_lines == 0) - { - skip_comment_line (); - continue; - } - else - *start.nextc = c = ' '; - } - - col = 1; - - while (gfc_is_whitespace (c)) - { - c = next_char (); - col++; - } - - if (c == '\n') - { - gfc_advance_line (); - continue; - } - - if (col != 6 && c == '!') - { - if (gfc_current_locus.lb != NULL - && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) - continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); - skip_comment_line (); - continue; - } - - break; - } - - openmp_flag = 0; - openacc_flag = 0; - gcc_attribute_flag = 0; - gfc_current_locus = start; -} - - -/* Skips the current line if it is a comment. */ - -void -gfc_skip_comments (void) -{ - if (gfc_current_form == FORM_FREE) - skip_free_comments (); - else - skip_fixed_comments (); -} - - -/* Get the next character from the input, taking continuation lines - and end-of-line comments into account. This implies that comment - lines between continued lines must be eaten here. For higher-level - subroutines, this flattens continued lines into a single logical - line. The in_string flag denotes whether we're inside a character - context or not. */ - -gfc_char_t -gfc_next_char_literal (gfc_instring in_string) -{ - static locus omp_acc_err_loc = {}; - locus old_loc; - int i, prev_openmp_flag, prev_openacc_flag; - gfc_char_t c; - - continue_flag = 0; - prev_openacc_flag = prev_openmp_flag = 0; - -restart: - c = next_char (); - if (gfc_at_end ()) - { - continue_count = 0; - return c; - } - - if (gfc_current_form == FORM_FREE) - { - bool openmp_cond_flag; - - if (!in_string && c == '!') - { - if (gcc_attribute_flag - && memcmp (&gfc_current_locus, &gcc_attribute_locus, - sizeof (gfc_current_locus)) == 0) - goto done; - - if (openmp_flag - && memcmp (&gfc_current_locus, &openmp_locus, - sizeof (gfc_current_locus)) == 0) - goto done; - - if (openacc_flag - && memcmp (&gfc_current_locus, &openacc_locus, - sizeof (gfc_current_locus)) == 0) - goto done; - - /* This line can't be continued */ - do - { - c = next_char (); - } - while (c != '\n'); - - /* Avoid truncation warnings for comment ending lines. */ - gfc_current_locus.lb->truncated = 0; - - goto done; - } - - /* Check to see if the continuation line was truncated. */ - if (warn_line_truncation && gfc_current_locus.lb != NULL - && gfc_current_locus.lb->truncated) - { - int maxlen = flag_free_line_length; - gfc_char_t *current_nextc = gfc_current_locus.nextc; - - gfc_current_locus.lb->truncated = 0; - gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen; - gfc_warning_now (OPT_Wline_truncation, - "Line truncated at %L", &gfc_current_locus); - gfc_current_locus.nextc = current_nextc; - } - - if (c != '&') - goto done; - - /* If the next nonblank character is a ! or \n, we've got a - continuation line. */ - old_loc = gfc_current_locus; - - c = next_char (); - while (gfc_is_whitespace (c)) - c = next_char (); - - /* Character constants to be continued cannot have commentary - after the '&'. However, there are cases where we may think we - are still in a string and we are looking for a possible - doubled quote and we end up here. See PR64506. */ - - if (in_string && c != '\n') - { - gfc_current_locus = old_loc; - c = '&'; - goto done; - } - - if (c != '!' && c != '\n') - { - gfc_current_locus = old_loc; - c = '&'; - goto done; - } - - if (flag_openmp) - prev_openmp_flag = openmp_flag; - if (flag_openacc) - prev_openacc_flag = openacc_flag; - - /* This can happen if the input file changed or via cpp's #line - without getting reset (e.g. via input_stmt). It also happens - when pre-including files via -fpre-include=. */ - if (continue_count == 0 - && gfc_current_locus.lb - && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1) - continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1; - - continue_flag = 1; - if (c == '!') - skip_comment_line (); - else - gfc_advance_line (); - - if (gfc_at_eof ()) - goto not_continuation; - - /* We've got a continuation line. If we are on the very next line after - the last continuation, increment the continuation line count and - check whether the limit has been exceeded. */ - if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1) - { - if (++continue_count == gfc_option.max_continue_free) - { - if (gfc_notification_std (GFC_STD_GNU) || pedantic) - gfc_warning (0, "Limit of %d continuations exceeded in " - "statement at %C", gfc_option.max_continue_free); - } - } - - /* Now find where it continues. First eat any comment lines. */ - openmp_cond_flag = skip_free_comments (); - - if (gfc_current_locus.lb != NULL - && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) - continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); - - if (flag_openmp) - if (prev_openmp_flag != openmp_flag && !openacc_flag) - { - gfc_current_locus = old_loc; - openmp_flag = prev_openmp_flag; - c = '&'; - goto done; - } - - if (flag_openacc) - if (prev_openacc_flag != openacc_flag && !openmp_flag) - { - gfc_current_locus = old_loc; - openacc_flag = prev_openacc_flag; - c = '&'; - goto done; - } - - /* Now that we have a non-comment line, probe ahead for the - first non-whitespace character. If it is another '&', then - reading starts at the next character, otherwise we must back - up to where the whitespace started and resume from there. */ - - old_loc = gfc_current_locus; - - c = next_char (); - while (gfc_is_whitespace (c)) - c = next_char (); - - if (openmp_flag && !openacc_flag) - { - for (i = 0; i < 5; i++, c = next_char ()) - { - gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]); - if (i == 4) - old_loc = gfc_current_locus; - } - while (gfc_is_whitespace (c)) - c = next_char (); - } - if (openacc_flag && !openmp_flag) - { - for (i = 0; i < 5; i++, c = next_char ()) - { - gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$acc"[i]); - if (i == 4) - old_loc = gfc_current_locus; - } - while (gfc_is_whitespace (c)) - c = next_char (); - } - - /* In case we have an OpenMP directive continued by OpenACC - sentinel, or vice versa, we get both openmp_flag and - openacc_flag on. */ - - if (openacc_flag && openmp_flag) - { - int is_openmp = 0; - for (i = 0; i < 5; i++, c = next_char ()) - { - if (gfc_wide_tolower (c) != (unsigned char) "!$acc"[i]) - is_openmp = 1; - } - if (omp_acc_err_loc.nextc != gfc_current_locus.nextc - || omp_acc_err_loc.lb != gfc_current_locus.lb) - gfc_error_now (is_openmp - ? G_("Wrong OpenACC continuation at %C: " - "expected !$ACC, got !$OMP") - : G_("Wrong OpenMP continuation at %C: " - "expected !$OMP, got !$ACC")); - omp_acc_err_loc = gfc_current_locus; - goto not_continuation; - } - - if (c != '&') - { - if (in_string && gfc_current_locus.nextc) - { - gfc_current_locus.nextc--; - if (warn_ampersand && in_string == INSTRING_WARN) - gfc_warning (OPT_Wampersand, - "Missing %<&%> in continued character " - "constant at %C"); - } - else if (!in_string && (c == '\'' || c == '"')) - goto done; - /* Both !$omp and !$ -fopenmp continuation lines have & on the - continuation line only optionally. */ - else if (openmp_flag || openacc_flag || openmp_cond_flag) - { - if (gfc_current_locus.nextc) - gfc_current_locus.nextc--; - } - else - { - c = ' '; - gfc_current_locus = old_loc; - goto done; - } - } - } - else /* Fixed form. */ - { - /* Fixed form continuation. */ - if (in_string != INSTRING_WARN && c == '!') - { - /* Skip comment at end of line. */ - do - { - c = next_char (); - } - while (c != '\n'); - - /* Avoid truncation warnings for comment ending lines. */ - gfc_current_locus.lb->truncated = 0; - } - - if (c != '\n') - goto done; - - /* Check to see if the continuation line was truncated. */ - if (warn_line_truncation && gfc_current_locus.lb != NULL - && gfc_current_locus.lb->truncated) - { - gfc_current_locus.lb->truncated = 0; - gfc_warning_now (OPT_Wline_truncation, - "Line truncated at %L", &gfc_current_locus); - } - - if (flag_openmp) - prev_openmp_flag = openmp_flag; - if (flag_openacc) - prev_openacc_flag = openacc_flag; - - /* This can happen if the input file changed or via cpp's #line - without getting reset (e.g. via input_stmt). It also happens - when pre-including files via -fpre-include=. */ - if (continue_count == 0 - && gfc_current_locus.lb - && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1) - continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1; - - continue_flag = 1; - old_loc = gfc_current_locus; - - gfc_advance_line (); - skip_fixed_comments (); - - /* See if this line is a continuation line. */ - if (flag_openmp && openmp_flag != prev_openmp_flag && !openacc_flag) - { - openmp_flag = prev_openmp_flag; - goto not_continuation; - } - if (flag_openacc && openacc_flag != prev_openacc_flag && !openmp_flag) - { - openacc_flag = prev_openacc_flag; - goto not_continuation; - } - - /* In case we have an OpenMP directive continued by OpenACC - sentinel, or vice versa, we get both openmp_flag and - openacc_flag on. */ - if (openacc_flag && openmp_flag) - { - int is_openmp = 0; - for (i = 0; i < 5; i++) - { - c = next_char (); - if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i]) - is_openmp = 1; - } - if (omp_acc_err_loc.nextc != gfc_current_locus.nextc - || omp_acc_err_loc.lb != gfc_current_locus.lb) - gfc_error_now (is_openmp - ? G_("Wrong OpenACC continuation at %C: " - "expected !$ACC, got !$OMP") - : G_("Wrong OpenMP continuation at %C: " - "expected !$OMP, got !$ACC")); - omp_acc_err_loc = gfc_current_locus; - goto not_continuation; - } - else if (!openmp_flag && !openacc_flag) - for (i = 0; i < 5; i++) - { - c = next_char (); - if (c != ' ') - goto not_continuation; - } - else if (openmp_flag) - for (i = 0; i < 5; i++) - { - c = next_char (); - if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i]) - goto not_continuation; - } - else if (openacc_flag) - for (i = 0; i < 5; i++) - { - c = next_char (); - if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i]) - goto not_continuation; - } - - c = next_char (); - if (c == '0' || c == ' ' || c == '\n') - goto not_continuation; - - /* We've got a continuation line. If we are on the very next line after - the last continuation, increment the continuation line count and - check whether the limit has been exceeded. */ - if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1) - { - if (++continue_count == gfc_option.max_continue_fixed) - { - if (gfc_notification_std (GFC_STD_GNU) || pedantic) - gfc_warning (0, "Limit of %d continuations exceeded in " - "statement at %C", - gfc_option.max_continue_fixed); - } - } - - if (gfc_current_locus.lb != NULL - && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) - continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); - } - - /* Ready to read first character of continuation line, which might - be another continuation line! */ - goto restart; - -not_continuation: - c = '\n'; - gfc_current_locus = old_loc; - end_flag = 0; - -done: - if (c == '\n') - continue_count = 0; - continue_flag = 0; - return c; -} - - -/* Get the next character of input, folded to lowercase. In fixed - form mode, we also ignore spaces. When matcher subroutines are - parsing character literals, they have to call - gfc_next_char_literal(). */ - -gfc_char_t -gfc_next_char (void) -{ - gfc_char_t c; - - do - { - c = gfc_next_char_literal (NONSTRING); - } - while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c)); - - return gfc_wide_tolower (c); -} - -char -gfc_next_ascii_char (void) -{ - gfc_char_t c = gfc_next_char (); - - return (gfc_wide_fits_in_byte (c) ? (unsigned char) c - : (unsigned char) UCHAR_MAX); -} - - -gfc_char_t -gfc_peek_char (void) -{ - locus old_loc; - gfc_char_t c; - - old_loc = gfc_current_locus; - c = gfc_next_char (); - gfc_current_locus = old_loc; - - return c; -} - - -char -gfc_peek_ascii_char (void) -{ - gfc_char_t c = gfc_peek_char (); - - return (gfc_wide_fits_in_byte (c) ? (unsigned char) c - : (unsigned char) UCHAR_MAX); -} - - -/* Recover from an error. We try to get past the current statement - and get lined up for the next. The next statement follows a '\n' - or a ';'. We also assume that we are not within a character - constant, and deal with finding a '\'' or '"'. */ - -void -gfc_error_recovery (void) -{ - gfc_char_t c, delim; - - if (gfc_at_eof ()) - return; - - for (;;) - { - c = gfc_next_char (); - if (c == '\n' || c == ';') - break; - - if (c != '\'' && c != '"') - { - if (gfc_at_eof ()) - break; - continue; - } - delim = c; - - for (;;) - { - c = next_char (); - - if (c == delim) - break; - if (c == '\n') - return; - if (c == '\\') - { - c = next_char (); - if (c == '\n') - return; - } - } - if (gfc_at_eof ()) - break; - } -} - - -/* Read ahead until the next character to be read is not whitespace. */ - -void -gfc_gobble_whitespace (void) -{ - static int linenum = 0; - locus old_loc; - gfc_char_t c; - - do - { - old_loc = gfc_current_locus; - c = gfc_next_char_literal (NONSTRING); - /* Issue a warning for nonconforming tabs. We keep track of the line - number because the Fortran matchers will often back up and the same - line will be scanned multiple times. */ - if (warn_tabs && c == '\t') - { - int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location); - if (cur_linenum != linenum) - { - linenum = cur_linenum; - gfc_warning_now (OPT_Wtabs, "Nonconforming tab character at %C"); - } - } - } - while (gfc_is_whitespace (c)); - - if (!ISPRINT(c) && c != '\n' && last_error_char != gfc_current_locus.nextc) - { - char buf[20]; - last_error_char = gfc_current_locus.nextc; - snprintf (buf, 20, "%2.2X", c); - gfc_error_now ("Invalid character 0x%s at %C", buf); - } - - gfc_current_locus = old_loc; -} - - -/* Load a single line into pbuf. - - If pbuf points to a NULL pointer, it is allocated. - We truncate lines that are too long, unless we're dealing with - preprocessor lines or if the option -ffixed-line-length-none is set, - in which case we reallocate the buffer to fit the entire line, if - need be. - In fixed mode, we expand a tab that occurs within the statement - label region to expand to spaces that leave the next character in - the source region. - - If first_char is not NULL, it's a pointer to a single char value holding - the first character of the line, which has already been read by the - caller. This avoids the use of ungetc(). - - load_line returns whether the line was truncated. - - NOTE: The error machinery isn't available at this point, so we can't - easily report line and column numbers consistent with other - parts of gfortran. */ - -static int -load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) -{ - int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; - int quoted = ' ', comment_ix = -1; - bool seen_comment = false; - bool first_comment = true; - bool trunc_flag = false; - bool seen_printable = false; - bool seen_ampersand = false; - bool found_tab = false; - bool warned_tabs = false; - gfc_char_t *buffer; - - /* Determine the maximum allowed line length. */ - if (gfc_current_form == FORM_FREE) - maxlen = flag_free_line_length; - else if (gfc_current_form == FORM_FIXED) - maxlen = flag_fixed_line_length; - else - maxlen = 72; - - if (*pbuf == NULL) - { - /* Allocate the line buffer, storing its length into buflen. - Note that if maxlen==0, indicating that arbitrary-length lines - are allowed, the buffer will be reallocated if this length is - insufficient; since 132 characters is the length of a standard - free-form line, we use that as a starting guess. */ - if (maxlen > 0) - buflen = maxlen; - else - buflen = 132; - - *pbuf = gfc_get_wide_string (buflen + 1); - } - - i = 0; - buffer = *pbuf; - - if (first_char) - c = *first_char; - else - c = getc (input); - - /* In order to not truncate preprocessor lines, we have to - remember that this is one. */ - preprocessor_flag = (c == '#'); - - for (;;) - { - if (c == EOF) - break; - - if (c == '\n') - { - /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */ - if (gfc_current_form == FORM_FREE - && !seen_printable && seen_ampersand) - { - if (pedantic) - gfc_error_now ("%<&%> not allowed by itself in line %d", - current_file->line); - else - gfc_warning_now (0, "%<&%> not allowed by itself in line %d", - current_file->line); - } - break; - } - - if (c == '\r' || c == '\0') - goto next_char; /* Gobble characters. */ - - if (c == '&') - { - if (seen_ampersand) - { - seen_ampersand = false; - seen_printable = true; - } - else - seen_ampersand = true; - } - - if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand)) - seen_printable = true; - - /* Is this a fixed-form comment? */ - if (gfc_current_form == FORM_FIXED && i == 0 - && (c == '*' || c == 'c' || c == 'C' - || (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D')))) - { - seen_comment = true; - comment_ix = i; - } - - if (quoted == ' ') - { - if (c == '\'' || c == '"') - quoted = c; - } - else if (c == quoted) - quoted = ' '; - - /* Is this a free-form comment? */ - if (c == '!' && quoted == ' ') - { - if (seen_comment) - first_comment = false; - seen_comment = true; - comment_ix = i; - } - - /* For truncation and tab warnings, set seen_comment to false if one has - either an OpenMP or OpenACC directive - or a !GCC$ attribute. If - OpenMP is enabled, use '!$' as as conditional compilation sentinel - and OpenMP directive ('!$omp'). */ - if (seen_comment && first_comment && flag_openmp && comment_ix + 1 == i - && c == '$') - first_comment = seen_comment = false; - if (seen_comment && first_comment && comment_ix + 4 == i) - { - if (((*pbuf)[comment_ix+1] == 'g' || (*pbuf)[comment_ix+1] == 'G') - && ((*pbuf)[comment_ix+2] == 'c' || (*pbuf)[comment_ix+2] == 'C') - && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C') - && c == '$') - first_comment = seen_comment = false; - if (flag_openacc - && (*pbuf)[comment_ix+1] == '$' - && ((*pbuf)[comment_ix+2] == 'a' || (*pbuf)[comment_ix+2] == 'A') - && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C') - && (c == 'c' || c == 'C')) - first_comment = seen_comment = false; - } - - /* Vendor extension: "1" marks a continuation line. */ - if (found_tab) - { - found_tab = false; - if (c >= '1' && c <= '9') - { - *(buffer-1) = c; - goto next_char; - } - } - - if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6) - { - found_tab = true; - - if (warn_tabs && seen_comment == 0 && !warned_tabs) - { - warned_tabs = true; - gfc_warning_now (OPT_Wtabs, - "Nonconforming tab character in column %d " - "of line %d", i + 1, current_file->line); - } - - while (i < 6) - { - *buffer++ = ' '; - i++; - } - - goto next_char; - } - - *buffer++ = c; - i++; - - if (maxlen == 0 || preprocessor_flag) - { - if (i >= buflen) - { - /* Reallocate line buffer to double size to hold the - overlong line. */ - buflen = buflen * 2; - *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1)); - buffer = (*pbuf) + i; - } - } - else if (i >= maxlen) - { - bool trunc_warn = true; - - /* Enhancement, if the very next non-space character is an ampersand - or comment that we would otherwise warn about, don't mark as - truncated. */ - - /* Truncate the rest of the line. */ - for (;;) - { - c = getc (input); - if (c == '\r' || c == ' ') - continue; - - if (c == '\n' || c == EOF) - break; - - if (!trunc_warn && c != '!') - trunc_warn = true; - - if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&') - || c == '!')) - trunc_warn = false; - - if (c == '!') - seen_comment = 1; - - if (trunc_warn && !seen_comment) - trunc_flag = 1; - } - - c = '\n'; - continue; - } - -next_char: - c = getc (input); - } - - /* Pad lines to the selected line length in fixed form. */ - if (gfc_current_form == FORM_FIXED - && flag_fixed_line_length != 0 - && flag_pad_source - && !preprocessor_flag - && c != EOF) - { - while (i++ < maxlen) - *buffer++ = ' '; - } - - *buffer = '\0'; - *pbuflen = buflen; - - return trunc_flag; -} - - -/* Get a gfc_file structure, initialize it and add it to - the file stack. */ - -static gfc_file * -get_file (const char *name, enum lc_reason reason) -{ - gfc_file *f; - - f = XCNEW (gfc_file); - - f->filename = xstrdup (name); - - f->next = file_head; - file_head = f; - - f->up = current_file; - if (current_file != NULL) - f->inclusion_line = current_file->line; - - linemap_add (line_table, reason, false, f->filename, 1); - - return f; -} - - -/* Deal with a line from the C preprocessor. The - initial octothorp has already been seen. */ - -static void -preprocessor_line (gfc_char_t *c) -{ - bool flag[5]; - int i, line; - gfc_char_t *wide_filename; - gfc_file *f; - int escaped, unescape; - char *filename; - - c++; - while (*c == ' ' || *c == '\t') - c++; - - if (*c < '0' || *c > '9') - goto bad_cpp_line; - - line = wide_atoi (c); - - c = wide_strchr (c, ' '); - if (c == NULL) - { - /* No file name given. Set new line number. */ - current_file->line = line; - return; - } - - /* Skip spaces. */ - while (*c == ' ' || *c == '\t') - c++; - - /* Skip quote. */ - if (*c != '"') - goto bad_cpp_line; - ++c; - - wide_filename = c; - - /* Make filename end at quote. */ - unescape = 0; - escaped = false; - while (*c && ! (!escaped && *c == '"')) - { - if (escaped) - escaped = false; - else if (*c == '\\') - { - escaped = true; - unescape++; - } - ++c; - } - - if (! *c) - /* Preprocessor line has no closing quote. */ - goto bad_cpp_line; - - *c++ = '\0'; - - /* Undo effects of cpp_quote_string. */ - if (unescape) - { - gfc_char_t *s = wide_filename; - gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape); - - wide_filename = d; - while (*s) - { - if (*s == '\\') - *d++ = *++s; - else - *d++ = *s; - s++; - } - *d = '\0'; - } - - /* Get flags. */ - - flag[1] = flag[2] = flag[3] = flag[4] = false; - - for (;;) - { - c = wide_strchr (c, ' '); - if (c == NULL) - break; - - c++; - i = wide_atoi (c); - - if (i >= 1 && i <= 4) - flag[i] = true; - } - - /* Convert the filename in wide characters into a filename in narrow - characters. */ - filename = gfc_widechar_to_char (wide_filename, -1); - - /* Interpret flags. */ - - if (flag[1]) /* Starting new file. */ - { - f = get_file (filename, LC_RENAME); - add_file_change (f->filename, f->inclusion_line); - current_file = f; - } - - if (flag[2]) /* Ending current file. */ - { - if (!current_file->up - || filename_cmp (current_file->up->filename, filename) != 0) - { - linemap_line_start (line_table, current_file->line, 80); - /* ??? One could compute the exact column where the filename - starts and compute the exact location here. */ - gfc_warning_now_at (linemap_position_for_column (line_table, 1), - 0, "file %qs left but not entered", - filename); - current_file->line++; - if (unescape) - free (wide_filename); - free (filename); - return; - } - - add_file_change (NULL, line); - current_file = current_file->up; - linemap_add (line_table, LC_RENAME, false, current_file->filename, - current_file->line); - } - - /* The name of the file can be a temporary file produced by - cpp. Replace the name if it is different. */ - - if (filename_cmp (current_file->filename, filename) != 0) - { - /* FIXME: we leak the old filename because a pointer to it may be stored - in the linemap. Alternative could be using GC or updating linemap to - point to the new name, but there is no API for that currently. */ - current_file->filename = xstrdup (filename); - - /* We need to tell the linemap API that the filename changed. Just - changing current_file is insufficient. */ - linemap_add (line_table, LC_RENAME, false, current_file->filename, line); - } - - /* Set new line number. */ - current_file->line = line; - if (unescape) - free (wide_filename); - free (filename); - return; - - bad_cpp_line: - linemap_line_start (line_table, current_file->line, 80); - /* ??? One could compute the exact column where the directive - starts and compute the exact location here. */ - gfc_warning_now_at (linemap_position_for_column (line_table, 2), 0, - "Illegal preprocessor directive"); - current_file->line++; -} - - -static void load_file (const char *, const char *, bool); - -/* include_line()-- Checks a line buffer to see if it is an include - line. If so, we call load_file() recursively to load the included - file. We never return a syntax error because a statement like - "include = 5" is perfectly legal. We return 0 if no include was - processed, 1 if we matched an include or -1 if include was - partially processed, but will need continuation lines. */ - -static int -include_line (gfc_char_t *line) -{ - gfc_char_t quote, *c, *begin, *stop; - char *filename; - const char *include = "include"; - bool allow_continuation = flag_dec_include; - int i; - - c = line; - - if (flag_openmp || flag_openmp_simd) - { - if (gfc_current_form == FORM_FREE) - { - while (*c == ' ' || *c == '\t') - c++; - if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t')) - c += 3; - } - else - { - if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*') - && c[1] == '$' && c[2] == ' ') - c += 3; - } - } - - if (gfc_current_form == FORM_FREE) - { - while (*c == ' ' || *c == '\t') - c++; - if (gfc_wide_strncasecmp (c, "include", 7)) - { - if (!allow_continuation) - return 0; - for (i = 0; i < 7; ++i) - { - gfc_char_t c1 = gfc_wide_tolower (*c); - if (c1 != (unsigned char) include[i]) - break; - c++; - } - if (i == 0 || *c != '&') - return 0; - c++; - while (*c == ' ' || *c == '\t') - c++; - if (*c == '\0' || *c == '!') - return -1; - return 0; - } - - c += 7; - } - else - { - while (*c == ' ' || *c == '\t') - c++; - if (flag_dec_include && *c == '0' && c - line == 5) - { - c++; - while (*c == ' ' || *c == '\t') - c++; - } - if (c - line < 6) - allow_continuation = false; - for (i = 0; i < 7; ++i) - { - gfc_char_t c1 = gfc_wide_tolower (*c); - if (c1 != (unsigned char) include[i]) - break; - c++; - while (*c == ' ' || *c == '\t') - c++; - } - if (!allow_continuation) - { - if (i != 7) - return 0; - } - else if (i != 7) - { - if (i == 0) - return 0; - - /* At the end of line or comment this might be continued. */ - if (*c == '\0' || *c == '!') - return -1; - - return 0; - } - } - - while (*c == ' ' || *c == '\t') - c++; - - /* Find filename between quotes. */ - - quote = *c++; - if (quote != '"' && quote != '\'') - { - if (allow_continuation) - { - if (gfc_current_form == FORM_FREE) - { - if (quote == '&') - { - while (*c == ' ' || *c == '\t') - c++; - if (*c == '\0' || *c == '!') - return -1; - } - } - else if (quote == '\0' || quote == '!') - return -1; - } - return 0; - } - - begin = c; - - bool cont = false; - while (*c != quote && *c != '\0') - { - if (allow_continuation && gfc_current_form == FORM_FREE) - { - if (*c == '&') - cont = true; - else if (*c != ' ' && *c != '\t') - cont = false; - } - c++; - } - - if (*c == '\0') - { - if (allow_continuation - && (cont || gfc_current_form != FORM_FREE)) - return -1; - return 0; - } - - stop = c++; - - while (*c == ' ' || *c == '\t') - c++; - - if (*c != '\0' && *c != '!') - return 0; - - /* We have an include line at this point. */ - - *stop = '\0'; /* It's ok to trash the buffer, as this line won't be - read by anything else. */ - - filename = gfc_widechar_to_char (begin, -1); - load_file (filename, NULL, false); - free (filename); - return 1; -} - -/* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc. - APIs. Return 1 if recognized as valid INCLUDE statement and load_file has - been called, 0 if it is not a valid INCLUDE statement and -1 if eof has - been encountered while parsing it. */ -static int -include_stmt (gfc_linebuf *b) -{ - int ret = 0, i, length; - const char *include = "include"; - gfc_char_t c, quote = 0; - locus str_locus; - char *filename; - - continue_flag = 0; - end_flag = 0; - gcc_attribute_flag = 0; - openmp_flag = 0; - openacc_flag = 0; - continue_count = 0; - continue_line = 0; - gfc_current_locus.lb = b; - gfc_current_locus.nextc = b->line; - - gfc_skip_comments (); - gfc_gobble_whitespace (); - - for (i = 0; i < 7; i++) - { - c = gfc_next_char (); - if (c != (unsigned char) include[i]) - { - if (gfc_current_form == FORM_FIXED - && i == 0 - && c == '0' - && gfc_current_locus.nextc == b->line + 6) - { - gfc_gobble_whitespace (); - i--; - continue; - } - gcc_assert (i != 0); - if (c == '\n') - { - gfc_advance_line (); - gfc_skip_comments (); - if (gfc_at_eof ()) - ret = -1; - } - goto do_ret; - } - } - gfc_gobble_whitespace (); - - c = gfc_next_char (); - if (c == '\'' || c == '"') - quote = c; - else - { - if (c == '\n') - { - gfc_advance_line (); - gfc_skip_comments (); - if (gfc_at_eof ()) - ret = -1; - } - goto do_ret; - } - - str_locus = gfc_current_locus; - length = 0; - do - { - c = gfc_next_char_literal (INSTRING_NOWARN); - if (c == quote) - break; - if (c == '\n') - { - gfc_advance_line (); - gfc_skip_comments (); - if (gfc_at_eof ()) - ret = -1; - goto do_ret; - } - length++; - } - while (1); - - gfc_gobble_whitespace (); - c = gfc_next_char (); - if (c != '\n') - goto do_ret; - - gfc_current_locus = str_locus; - ret = 1; - filename = XNEWVEC (char, length + 1); - for (i = 0; i < length; i++) - { - c = gfc_next_char_literal (INSTRING_WARN); - gcc_assert (gfc_wide_fits_in_byte (c)); - filename[i] = (unsigned char) c; - } - filename[length] = '\0'; - load_file (filename, NULL, false); - free (filename); - -do_ret: - continue_flag = 0; - end_flag = 0; - gcc_attribute_flag = 0; - openmp_flag = 0; - openacc_flag = 0; - continue_count = 0; - continue_line = 0; - memset (&gfc_current_locus, '\0', sizeof (locus)); - memset (&openmp_locus, '\0', sizeof (locus)); - memset (&openacc_locus, '\0', sizeof (locus)); - memset (&gcc_attribute_locus, '\0', sizeof (locus)); - return ret; -} - - - -/* Load a file into memory by calling load_line until the file ends. */ - -static void -load_file (const char *realfilename, const char *displayedname, bool initial) -{ - gfc_char_t *line; - gfc_linebuf *b, *include_b = NULL; - gfc_file *f; - FILE *input; - int len, line_len; - bool first_line; - struct stat st; - int stat_result; - const char *filename; - /* If realfilename and displayedname are different and non-null then - surely realfilename is the preprocessed form of - displayedname. */ - bool preprocessed_p = (realfilename && displayedname - && strcmp (realfilename, displayedname)); - - filename = displayedname ? displayedname : realfilename; - - for (f = current_file; f; f = f->up) - if (filename_cmp (filename, f->filename) == 0) - fatal_error (linemap_line_start (line_table, current_file->line, 0), - "File %qs is being included recursively", filename); - if (initial) - { - if (gfc_src_file) - { - input = gfc_src_file; - gfc_src_file = NULL; - } - else - input = gfc_open_file (realfilename); - - if (input == NULL) - gfc_fatal_error ("Cannot open file %qs", filename); - } - else - { - input = gfc_open_included_file (realfilename, false, false); - if (input == NULL) - { - /* For -fpre-include file, current_file is NULL. */ - if (current_file) - fatal_error (linemap_line_start (line_table, current_file->line, 0), - "Cannot open included file %qs", filename); - else - gfc_fatal_error ("Cannot open pre-included file %qs", filename); - } - stat_result = stat (realfilename, &st); - if (stat_result == 0 && !S_ISREG (st.st_mode)) - { - fclose (input); - if (current_file) - fatal_error (linemap_line_start (line_table, current_file->line, 0), - "Included file %qs is not a regular file", filename); - else - gfc_fatal_error ("Included file %qs is not a regular file", filename); - } - } - - /* Load the file. - - A "non-initial" file means a file that is being included. In - that case we are creating an LC_ENTER map. - - An "initial" file means a main file; one that is not included. - That file has already got at least one (surely more) line map(s) - created by gfc_init. So the subsequent map created in that case - must have LC_RENAME reason. - - This latter case is not true for a preprocessed file. In that - case, although the file is "initial", the line maps created by - gfc_init was used during the preprocessing of the file. Now that - the preprocessing is over and we are being fed the result of that - preprocessing, we need to create a brand new line map for the - preprocessed file, so the reason is going to be LC_ENTER. */ - - f = get_file (filename, (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER); - if (!initial) - add_file_change (f->filename, f->inclusion_line); - current_file = f; - current_file->line = 1; - line = NULL; - line_len = 0; - first_line = true; - - if (initial && gfc_src_preprocessor_lines[0]) - { - preprocessor_line (gfc_src_preprocessor_lines[0]); - free (gfc_src_preprocessor_lines[0]); - gfc_src_preprocessor_lines[0] = NULL; - if (gfc_src_preprocessor_lines[1]) - { - preprocessor_line (gfc_src_preprocessor_lines[1]); - free (gfc_src_preprocessor_lines[1]); - gfc_src_preprocessor_lines[1] = NULL; - } - } - - for (;;) - { - int trunc = load_line (input, &line, &line_len, NULL); - int inc_line; - - len = gfc_wide_strlen (line); - if (feof (input) && len == 0) - break; - - /* If this is the first line of the file, it can contain a byte - order mark (BOM), which we will ignore: - FF FE is UTF-16 little endian, - FE FF is UTF-16 big endian, - EF BB BF is UTF-8. */ - if (first_line - && ((line_len >= 2 && line[0] == (unsigned char) '\xFF' - && line[1] == (unsigned char) '\xFE') - || (line_len >= 2 && line[0] == (unsigned char) '\xFE' - && line[1] == (unsigned char) '\xFF') - || (line_len >= 3 && line[0] == (unsigned char) '\xEF' - && line[1] == (unsigned char) '\xBB' - && line[2] == (unsigned char) '\xBF'))) - { - int n = line[1] == (unsigned char) '\xBB' ? 3 : 2; - gfc_char_t *new_char = gfc_get_wide_string (line_len); - - wide_strcpy (new_char, &line[n]); - free (line); - line = new_char; - len -= n; - } - - /* There are three things this line can be: a line of Fortran - source, an include line or a C preprocessor directive. */ - - if (line[0] == '#') - { - /* When -g3 is specified, it's possible that we emit #define - and #undef lines, which we need to pass to the middle-end - so that it can emit correct debug info. */ - if (debug_info_level == DINFO_LEVEL_VERBOSE - && (wide_strncmp (line, "#define ", 8) == 0 - || wide_strncmp (line, "#undef ", 7) == 0)) - ; - else - { - preprocessor_line (line); - continue; - } - } - - /* Preprocessed files have preprocessor lines added before the byte - order mark, so first_line is not about the first line of the file - but the first line that's not a preprocessor line. */ - first_line = false; - - inc_line = include_line (line); - if (inc_line > 0) - { - current_file->line++; - continue; - } - - /* Add line. */ - - b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size - + (len + 1) * sizeof (gfc_char_t)); - - - b->location - = linemap_line_start (line_table, current_file->line++, len); - /* ??? We add the location for the maximum column possible here, - because otherwise if the next call creates a new line-map, it - will not reserve space for any offset. */ - if (len > 0) - linemap_position_for_column (line_table, len); - - b->file = current_file; - b->truncated = trunc; - wide_strcpy (b->line, line); - - if (line_head == NULL) - line_head = b; - else - line_tail->next = b; - - line_tail = b; - - while (file_changes_cur < file_changes_count) - file_changes[file_changes_cur++].lb = b; - - if (flag_dec_include) - { - if (include_b && b != include_b) - { - int inc_line2 = include_stmt (include_b); - if (inc_line2 == 0) - include_b = NULL; - else if (inc_line2 > 0) - { - do - { - if (gfc_current_form == FORM_FIXED) - { - for (gfc_char_t *p = include_b->line; *p; p++) - *p = ' '; - } - else - include_b->line[0] = '\0'; - if (include_b == b) - break; - include_b = include_b->next; - } - while (1); - include_b = NULL; - } - } - if (inc_line == -1 && !include_b) - include_b = b; - } - } - - /* Release the line buffer allocated in load_line. */ - free (line); - - fclose (input); - - if (!initial) - add_file_change (NULL, current_file->inclusion_line + 1); - current_file = current_file->up; - linemap_add (line_table, LC_LEAVE, 0, NULL, 0); -} - - -/* Open a new file and start scanning from that file. Returns true - if everything went OK, false otherwise. If form == FORM_UNKNOWN - it tries to determine the source form from the filename, defaulting - to free form. */ - -void -gfc_new_file (void) -{ - if (flag_pre_include != NULL) - load_file (flag_pre_include, NULL, false); - - if (gfc_cpp_enabled ()) - { - gfc_cpp_preprocess (gfc_source_file); - if (!gfc_cpp_preprocess_only ()) - load_file (gfc_cpp_temporary_file (), gfc_source_file, true); - } - else - load_file (gfc_source_file, NULL, true); - - gfc_current_locus.lb = line_head; - gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line; - -#if 0 /* Debugging aid. */ - for (; line_head; line_head = line_head->next) - printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location), - LOCATION_LINE (line_head->location), line_head->line); - - exit (SUCCESS_EXIT_CODE); -#endif -} - -static char * -unescape_filename (const char *ptr) -{ - const char *p = ptr, *s; - char *d, *ret; - int escaped, unescape = 0; - - /* Make filename end at quote. */ - escaped = false; - while (*p && ! (! escaped && *p == '"')) - { - if (escaped) - escaped = false; - else if (*p == '\\') - { - escaped = true; - unescape++; - } - ++p; - } - - if (!*p || p[1]) - return NULL; - - /* Undo effects of cpp_quote_string. */ - s = ptr; - d = XCNEWVEC (char, p + 1 - ptr - unescape); - ret = d; - - while (s != p) - { - if (*s == '\\') - *d++ = *++s; - else - *d++ = *s; - s++; - } - *d = '\0'; - return ret; -} - -/* For preprocessed files, if the first tokens are of the form # NUM. - handle the directives so we know the original file name. */ - -const char * -gfc_read_orig_filename (const char *filename, const char **canon_source_file) -{ - int c, len; - char *dirname, *tmp; - - gfc_src_file = gfc_open_file (filename); - if (gfc_src_file == NULL) - return NULL; - - c = getc (gfc_src_file); - - if (c != '#') - return NULL; - - len = 0; - load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c); - - if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0) - return NULL; - - tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1); - filename = unescape_filename (tmp); - free (tmp); - if (filename == NULL) - return NULL; - - c = getc (gfc_src_file); - - if (c != '#') - return filename; - - len = 0; - load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c); - - if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0) - return filename; - - tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1); - dirname = unescape_filename (tmp); - free (tmp); - if (dirname == NULL) - return filename; - - len = strlen (dirname); - if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/') - { - free (dirname); - return filename; - } - dirname[len - 2] = '\0'; - set_src_pwd (dirname); - - if (! IS_ABSOLUTE_PATH (filename)) - { - char *p = XCNEWVEC (char, len + strlen (filename)); - - memcpy (p, dirname, len - 2); - p[len - 2] = '/'; - strcpy (p + len - 1, filename); - *canon_source_file = p; - } - - free (dirname); - return filename; -} diff --git a/gcc/fortran/scanner.cc b/gcc/fortran/scanner.cc new file mode 100644 index 0000000..4df6576 --- /dev/null +++ b/gcc/fortran/scanner.cc @@ -0,0 +1,2903 @@ +/* Character scanner. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +/* Set of subroutines to (ultimately) return the next character to the + various matching subroutines. This file's job is to read files and + build up lines that are parsed by the parser. This means that we + handle continuation lines and "include" lines. + + The first thing the scanner does is to load an entire file into + memory. We load the entire file into memory for a couple reasons. + The first is that we want to be able to deal with nonseekable input + (pipes, stdin) and there is a lot of backing up involved during + parsing. + + The second is that we want to be able to print the locus of errors, + and an error on line 999999 could conflict with something on line + one. Given nonseekable input, we've got to store the whole thing. + + One thing that helps are the column truncation limits that give us + an upper bound on the size of individual lines. We don't store the + truncated stuff. + + From the scanner's viewpoint, the higher level subroutines ask for + new characters and do a lot of jumping backwards. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" +#include "toplev.h" /* For set_src_pwd. */ +#include "debug.h" +#include "options.h" +#include "diagnostic-core.h" /* For fatal_error. */ +#include "cpp.h" +#include "scanner.h" + +/* List of include file search directories. */ +gfc_directorylist *include_dirs, *intrinsic_modules_dirs; + +static gfc_file *file_head, *current_file; + +static int continue_flag, end_flag, gcc_attribute_flag; +/* If !$omp/!$acc occurred in current comment line. */ +static int openmp_flag, openacc_flag; +static int continue_count, continue_line; +static locus openmp_locus; +static locus openacc_locus; +static locus gcc_attribute_locus; + +gfc_source_form gfc_current_form; +static gfc_linebuf *line_head, *line_tail; + +locus gfc_current_locus; +const char *gfc_source_file; +static FILE *gfc_src_file; +static gfc_char_t *gfc_src_preprocessor_lines[2]; + +static struct gfc_file_change +{ + const char *filename; + gfc_linebuf *lb; + int line; +} *file_changes; +static size_t file_changes_cur, file_changes_count; +static size_t file_changes_allocated; + +static gfc_char_t *last_error_char; + +/* Functions dealing with our wide characters (gfc_char_t) and + sequences of such characters. */ + +int +gfc_wide_fits_in_byte (gfc_char_t c) +{ + return (c <= UCHAR_MAX); +} + +static inline int +wide_is_ascii (gfc_char_t c) +{ + return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0); +} + +int +gfc_wide_is_printable (gfc_char_t c) +{ + return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c)); +} + +gfc_char_t +gfc_wide_tolower (gfc_char_t c) +{ + return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c); +} + +gfc_char_t +gfc_wide_toupper (gfc_char_t c) +{ + return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c); +} + +int +gfc_wide_is_digit (gfc_char_t c) +{ + return (c >= '0' && c <= '9'); +} + +static inline int +wide_atoi (gfc_char_t *c) +{ +#define MAX_DIGITS 20 + char buf[MAX_DIGITS+1]; + int i = 0; + + while (gfc_wide_is_digit(*c) && i < MAX_DIGITS) + buf[i++] = *c++; + buf[i] = '\0'; + return atoi (buf); +} + +size_t +gfc_wide_strlen (const gfc_char_t *str) +{ + size_t i; + + for (i = 0; str[i]; i++) + ; + + return i; +} + +gfc_char_t * +gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len) +{ + size_t i; + + for (i = 0; i < len; i++) + b[i] = c; + + return b; +} + +static gfc_char_t * +wide_strcpy (gfc_char_t *dest, const gfc_char_t *src) +{ + gfc_char_t *d; + + for (d = dest; (*d = *src) != '\0'; ++src, ++d) + ; + + return dest; +} + +static gfc_char_t * +wide_strchr (const gfc_char_t *s, gfc_char_t c) +{ + do { + if (*s == c) + { + return CONST_CAST(gfc_char_t *, s); + } + } while (*s++); + return 0; +} + +char * +gfc_widechar_to_char (const gfc_char_t *s, int length) +{ + size_t len, i; + char *res; + + if (s == NULL) + return NULL; + + /* Passing a negative length is used to indicate that length should be + calculated using gfc_wide_strlen(). */ + len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s)); + res = XNEWVEC (char, len + 1); + + for (i = 0; i < len; i++) + { + gcc_assert (gfc_wide_fits_in_byte (s[i])); + res[i] = (unsigned char) s[i]; + } + + res[len] = '\0'; + return res; +} + +gfc_char_t * +gfc_char_to_widechar (const char *s) +{ + size_t len, i; + gfc_char_t *res; + + if (s == NULL) + return NULL; + + len = strlen (s); + res = gfc_get_wide_string (len + 1); + + for (i = 0; i < len; i++) + res[i] = (unsigned char) s[i]; + + res[len] = '\0'; + return res; +} + +static int +wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n) +{ + gfc_char_t c1, c2; + + while (n-- > 0) + { + c1 = *s1++; + c2 = *s2++; + if (c1 != c2) + return (c1 > c2 ? 1 : -1); + if (c1 == '\0') + return 0; + } + return 0; +} + +int +gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n) +{ + gfc_char_t c1, c2; + + while (n-- > 0) + { + c1 = gfc_wide_tolower (*s1++); + c2 = TOLOWER (*s2++); + if (c1 != c2) + return (c1 > c2 ? 1 : -1); + if (c1 == '\0') + return 0; + } + return 0; +} + + +/* Main scanner initialization. */ + +void +gfc_scanner_init_1 (void) +{ + file_head = NULL; + line_head = NULL; + line_tail = NULL; + + continue_count = 0; + continue_line = 0; + + end_flag = 0; + last_error_char = NULL; +} + + +/* Main scanner destructor. */ + +void +gfc_scanner_done_1 (void) +{ + gfc_linebuf *lb; + gfc_file *f; + + while(line_head != NULL) + { + lb = line_head->next; + free (line_head); + line_head = lb; + } + + while(file_head != NULL) + { + f = file_head->next; + free (file_head->filename); + free (file_head); + file_head = f; + } +} + +static bool +gfc_do_check_include_dir (const char *path, bool warn) +{ + struct stat st; + if (stat (path, &st)) + { + if (errno != ENOENT) + gfc_warning_now (0, "Include directory %qs: %s", + path, xstrerror(errno)); + else if (warn) + gfc_warning_now (OPT_Wmissing_include_dirs, + "Nonexistent include directory %qs", path); + return false; + } + else if (!S_ISDIR (st.st_mode)) + { + gfc_fatal_error ("%qs is not a directory", path); + return false; + } + return true; +} + +/* In order that -W(no-)missing-include-dirs works, the diagnostic can only be + run after processing the commandline. */ +static void +gfc_do_check_include_dirs (gfc_directorylist **list, bool do_warn) +{ + gfc_directorylist *prev, *q, *n; + prev = NULL; + n = *list; + while (n) + { + q = n; n = n->next; + if (gfc_do_check_include_dir (q->path, q->warn && do_warn)) + { + prev = q; + continue; + } + if (prev == NULL) + *list = n; + else + prev->next = n; + free (q->path); + free (q); + } +} + +void +gfc_check_include_dirs (bool verbose_missing_dir_warn) +{ + /* This is a bit convoluted: If gfc_cpp_enabled () and + verbose_missing_dir_warn, the warning is shown by libcpp. Otherwise, + it is shown here, still conditional on OPT_Wmissing_include_dirs. */ + bool warn = !gfc_cpp_enabled () || !verbose_missing_dir_warn; + gfc_do_check_include_dirs (&include_dirs, warn); + gfc_do_check_include_dirs (&intrinsic_modules_dirs, verbose_missing_dir_warn); + if (gfc_option.module_dir && gfc_cpp_enabled ()) + gfc_do_check_include_dirs (&include_dirs, true); +} + +/* Adds path to the list pointed to by list. */ + +static void +add_path_to_list (gfc_directorylist **list, const char *path, + bool use_for_modules, bool head, bool warn, bool defer_warn) +{ + gfc_directorylist *dir; + const char *p; + char *q; + size_t len; + int i; + + p = path; + while (*p == ' ' || *p == '\t') /* someone might do "-I include" */ + if (*p++ == '\0') + return; + + /* Strip trailing directory separators from the path, as this + will confuse Windows systems. */ + len = strlen (p); + q = (char *) alloca (len + 1); + memcpy (q, p, len + 1); + i = len - 1; + while (i >=0 && IS_DIR_SEPARATOR (q[i])) + q[i--] = '\0'; + + if (!defer_warn && !gfc_do_check_include_dir (q, warn)) + return; + + if (head || *list == NULL) + { + dir = XCNEW (gfc_directorylist); + if (!head) + *list = dir; + } + else + { + dir = *list; + while (dir->next) + dir = dir->next; + + dir->next = XCNEW (gfc_directorylist); + dir = dir->next; + } + + dir->next = head ? *list : NULL; + if (head) + *list = dir; + dir->use_for_modules = use_for_modules; + dir->warn = warn; + dir->path = XCNEWVEC (char, strlen (p) + 2); + strcpy (dir->path, p); + strcat (dir->path, "/"); /* make '/' last character */ +} + +/* defer_warn is set to true while parsing the commandline. */ + +void +gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir, + bool warn, bool defer_warn) +{ + add_path_to_list (&include_dirs, path, use_for_modules, file_dir, warn, + defer_warn); + + /* For '#include "..."' these directories are automatically searched. */ + if (!file_dir) + gfc_cpp_add_include_path (xstrdup(path), true); +} + + +void +gfc_add_intrinsic_modules_path (const char *path) +{ + add_path_to_list (&intrinsic_modules_dirs, path, true, false, false, false); +} + + +/* Release resources allocated for options. */ + +void +gfc_release_include_path (void) +{ + gfc_directorylist *p; + + while (include_dirs != NULL) + { + p = include_dirs; + include_dirs = include_dirs->next; + free (p->path); + free (p); + } + + while (intrinsic_modules_dirs != NULL) + { + p = intrinsic_modules_dirs; + intrinsic_modules_dirs = intrinsic_modules_dirs->next; + free (p->path); + free (p); + } + + free (gfc_option.module_dir); +} + + +static FILE * +open_included_file (const char *name, gfc_directorylist *list, + bool module, bool system) +{ + char *fullname; + gfc_directorylist *p; + FILE *f; + + for (p = list; p; p = p->next) + { + if (module && !p->use_for_modules) + continue; + + fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); + strcpy (fullname, p->path); + strcat (fullname, name); + + f = gfc_open_file (fullname); + if (f != NULL) + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (fullname, system); + + return f; + } + } + + return NULL; +} + + +/* Opens file for reading, searching through the include directories + given if necessary. If the include_cwd argument is true, we try + to open the file in the current directory first. */ + +FILE * +gfc_open_included_file (const char *name, bool include_cwd, bool module) +{ + FILE *f = NULL; + + if (IS_ABSOLUTE_PATH (name) || include_cwd) + { + f = gfc_open_file (name); + if (f && gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, false); + } + + if (!f) + f = open_included_file (name, include_dirs, module, false); + + return f; +} + + +/* Test to see if we're at the end of the main source file. */ + +int +gfc_at_end (void) +{ + return end_flag; +} + + +/* Test to see if we're at the end of the current file. */ + +int +gfc_at_eof (void) +{ + if (gfc_at_end ()) + return 1; + + if (line_head == NULL) + return 1; /* Null file */ + + if (gfc_current_locus.lb == NULL) + return 1; + + return 0; +} + + +/* Test to see if we're at the beginning of a new line. */ + +int +gfc_at_bol (void) +{ + if (gfc_at_eof ()) + return 1; + + return (gfc_current_locus.nextc == gfc_current_locus.lb->line); +} + + +/* Test to see if we're at the end of a line. */ + +int +gfc_at_eol (void) +{ + if (gfc_at_eof ()) + return 1; + + return (*gfc_current_locus.nextc == '\0'); +} + +static void +add_file_change (const char *filename, int line) +{ + if (file_changes_count == file_changes_allocated) + { + if (file_changes_allocated) + file_changes_allocated *= 2; + else + file_changes_allocated = 16; + file_changes = XRESIZEVEC (struct gfc_file_change, file_changes, + file_changes_allocated); + } + file_changes[file_changes_count].filename = filename; + file_changes[file_changes_count].lb = NULL; + file_changes[file_changes_count++].line = line; +} + +static void +report_file_change (gfc_linebuf *lb) +{ + size_t c = file_changes_cur; + while (c < file_changes_count + && file_changes[c].lb == lb) + { + if (file_changes[c].filename) + (*debug_hooks->start_source_file) (file_changes[c].line, + file_changes[c].filename); + else + (*debug_hooks->end_source_file) (file_changes[c].line); + ++c; + } + file_changes_cur = c; +} + +void +gfc_start_source_files (void) +{ + /* If the debugger wants the name of the main source file, + we give it. */ + if (debug_hooks->start_end_main_source_file) + (*debug_hooks->start_source_file) (0, gfc_source_file); + + file_changes_cur = 0; + report_file_change (gfc_current_locus.lb); +} + +void +gfc_end_source_files (void) +{ + report_file_change (NULL); + + if (debug_hooks->start_end_main_source_file) + (*debug_hooks->end_source_file) (0); +} + +/* Advance the current line pointer to the next line. */ + +void +gfc_advance_line (void) +{ + if (gfc_at_end ()) + return; + + if (gfc_current_locus.lb == NULL) + { + end_flag = 1; + return; + } + + if (gfc_current_locus.lb->next + && !gfc_current_locus.lb->next->dbg_emitted) + { + report_file_change (gfc_current_locus.lb->next); + gfc_current_locus.lb->next->dbg_emitted = true; + } + + gfc_current_locus.lb = gfc_current_locus.lb->next; + + if (gfc_current_locus.lb != NULL) + gfc_current_locus.nextc = gfc_current_locus.lb->line; + else + { + gfc_current_locus.nextc = NULL; + end_flag = 1; + } +} + + +/* Get the next character from the input, advancing gfc_current_file's + locus. When we hit the end of the line or the end of the file, we + start returning a '\n' in order to complete the current statement. + No Fortran line conventions are implemented here. + + Requiring explicit advances to the next line prevents the parse + pointer from being on the wrong line if the current statement ends + prematurely. */ + +static gfc_char_t +next_char (void) +{ + gfc_char_t c; + + if (gfc_current_locus.nextc == NULL) + return '\n'; + + c = *gfc_current_locus.nextc++; + if (c == '\0') + { + gfc_current_locus.nextc--; /* Remain on this line. */ + c = '\n'; + } + + return c; +} + + +/* Skip a comment. When we come here the parse pointer is positioned + immediately after the comment character. If we ever implement + compiler directives within comments, here is where we parse the + directive. */ + +static void +skip_comment_line (void) +{ + gfc_char_t c; + + do + { + c = next_char (); + } + while (c != '\n'); + + gfc_advance_line (); +} + + +int +gfc_define_undef_line (void) +{ + char *tmp; + + /* All lines beginning with '#' are either #define or #undef. */ + if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#') + return 0; + + if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0) + { + tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1); + (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb), + tmp); + free (tmp); + } + + if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0) + { + tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1); + (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb), + tmp); + free (tmp); + } + + /* Skip the rest of the line. */ + skip_comment_line (); + + return 1; +} + + +/* Return true if GCC$ was matched. */ +static bool +skip_gcc_attribute (locus start) +{ + bool r = false; + char c; + locus old_loc = gfc_current_locus; + + if ((c = next_char ()) == 'g' || c == 'G') + if ((c = next_char ()) == 'c' || c == 'C') + if ((c = next_char ()) == 'c' || c == 'C') + if ((c = next_char ()) == '$') + r = true; + + if (r == false) + gfc_current_locus = old_loc; + else + { + gcc_attribute_flag = 1; + gcc_attribute_locus = old_loc; + gfc_current_locus = start; + } + + return r; +} + +/* Return true if CC was matched. */ +static bool +skip_free_oacc_sentinel (locus start, locus old_loc) +{ + bool r = false; + char c; + + if ((c = next_char ()) == 'c' || c == 'C') + if ((c = next_char ()) == 'c' || c == 'C') + r = true; + + if (r) + { + if ((c = next_char ()) == ' ' || c == '\t' + || continue_flag) + { + while (gfc_is_whitespace (c)) + c = next_char (); + if (c != '\n' && c != '!') + { + openacc_flag = 1; + openacc_locus = old_loc; + gfc_current_locus = start; + } + else + r = false; + } + else + { + gfc_warning_now (0, "!$ACC at %C starts a commented " + "line as it neither is followed " + "by a space nor is a " + "continuation line"); + r = false; + } + } + + return r; +} + +/* Return true if MP was matched. */ +static bool +skip_free_omp_sentinel (locus start, locus old_loc) +{ + bool r = false; + char c; + + if ((c = next_char ()) == 'm' || c == 'M') + if ((c = next_char ()) == 'p' || c == 'P') + r = true; + + if (r) + { + if ((c = next_char ()) == ' ' || c == '\t' + || continue_flag) + { + while (gfc_is_whitespace (c)) + c = next_char (); + if (c != '\n' && c != '!') + { + openmp_flag = 1; + openmp_locus = old_loc; + gfc_current_locus = start; + } + else + r = false; + } + else + { + gfc_warning_now (0, "!$OMP at %C starts a commented " + "line as it neither is followed " + "by a space nor is a " + "continuation line"); + r = false; + } + } + + return r; +} + +/* Comment lines are null lines, lines containing only blanks or lines + on which the first nonblank line is a '!'. + Return true if !$ openmp or openacc conditional compilation sentinel was + seen. */ + +static bool +skip_free_comments (void) +{ + locus start; + gfc_char_t c; + int at_bol; + + for (;;) + { + at_bol = gfc_at_bol (); + start = gfc_current_locus; + if (gfc_at_eof ()) + break; + + do + c = next_char (); + while (gfc_is_whitespace (c)); + + if (c == '\n') + { + gfc_advance_line (); + continue; + } + + if (c == '!') + { + /* Keep the !GCC$ line. */ + if (at_bol && skip_gcc_attribute (start)) + return false; + + /* If -fopenmp/-fopenacc, we need to handle here 2 things: + 1) don't treat !$omp/!$acc as comments, but directives + 2) handle OpenMP/OpenACC conditional compilation, where + !$ should be treated as 2 spaces (for initial lines + only if followed by space). */ + if (at_bol) + { + if ((flag_openmp || flag_openmp_simd) + && flag_openacc) + { + locus old_loc = gfc_current_locus; + if (next_char () == '$') + { + c = next_char (); + if (c == 'o' || c == 'O') + { + if (skip_free_omp_sentinel (start, old_loc)) + return false; + gfc_current_locus = old_loc; + next_char (); + c = next_char (); + } + else if (c == 'a' || c == 'A') + { + if (skip_free_oacc_sentinel (start, old_loc)) + return false; + gfc_current_locus = old_loc; + next_char (); + c = next_char (); + } + if (continue_flag || c == ' ' || c == '\t') + { + gfc_current_locus = old_loc; + next_char (); + openmp_flag = openacc_flag = 0; + return true; + } + } + gfc_current_locus = old_loc; + } + else if ((flag_openmp || flag_openmp_simd) + && !flag_openacc) + { + locus old_loc = gfc_current_locus; + if (next_char () == '$') + { + c = next_char (); + if (c == 'o' || c == 'O') + { + if (skip_free_omp_sentinel (start, old_loc)) + return false; + gfc_current_locus = old_loc; + next_char (); + c = next_char (); + } + if (continue_flag || c == ' ' || c == '\t') + { + gfc_current_locus = old_loc; + next_char (); + openmp_flag = 0; + return true; + } + } + gfc_current_locus = old_loc; + } + else if (flag_openacc + && !(flag_openmp || flag_openmp_simd)) + { + locus old_loc = gfc_current_locus; + if (next_char () == '$') + { + c = next_char (); + if (c == 'a' || c == 'A') + { + if (skip_free_oacc_sentinel (start, old_loc)) + return false; + gfc_current_locus = old_loc; + next_char(); + c = next_char(); + } + } + gfc_current_locus = old_loc; + } + } + skip_comment_line (); + continue; + } + + break; + } + + if (openmp_flag && at_bol) + openmp_flag = 0; + + if (openacc_flag && at_bol) + openacc_flag = 0; + + gcc_attribute_flag = 0; + gfc_current_locus = start; + return false; +} + +/* Return true if MP was matched in fixed form. */ +static bool +skip_fixed_omp_sentinel (locus *start) +{ + gfc_char_t c; + if (((c = next_char ()) == 'm' || c == 'M') + && ((c = next_char ()) == 'p' || c == 'P')) + { + c = next_char (); + if (c != '\n' + && (continue_flag + || c == ' ' || c == '\t' || c == '0')) + { + if (c == ' ' || c == '\t' || c == '0') + openacc_flag = 0; + do + c = next_char (); + while (gfc_is_whitespace (c)); + if (c != '\n' && c != '!') + { + /* Canonicalize to *$omp. */ + *start->nextc = '*'; + openmp_flag = 1; + gfc_current_locus = *start; + return true; + } + } + } + return false; +} + +/* Return true if CC was matched in fixed form. */ +static bool +skip_fixed_oacc_sentinel (locus *start) +{ + gfc_char_t c; + if (((c = next_char ()) == 'c' || c == 'C') + && ((c = next_char ()) == 'c' || c == 'C')) + { + c = next_char (); + if (c != '\n' + && (continue_flag + || c == ' ' || c == '\t' || c == '0')) + { + if (c == ' ' || c == '\t' || c == '0') + openmp_flag = 0; + do + c = next_char (); + while (gfc_is_whitespace (c)); + if (c != '\n' && c != '!') + { + /* Canonicalize to *$acc. */ + *start->nextc = '*'; + openacc_flag = 1; + gfc_current_locus = *start; + return true; + } + } + } + return false; +} + +/* Skip comment lines in fixed source mode. We have the same rules as + in skip_free_comment(), except that we can have a 'c', 'C' or '*' + in column 1, and a '!' cannot be in column 6. Also, we deal with + lines with 'd' or 'D' in column 1, if the user requested this. */ + +static void +skip_fixed_comments (void) +{ + locus start; + int col; + gfc_char_t c; + + if (! gfc_at_bol ()) + { + start = gfc_current_locus; + if (! gfc_at_eof ()) + { + do + c = next_char (); + while (gfc_is_whitespace (c)); + + if (c == '\n') + gfc_advance_line (); + else if (c == '!') + skip_comment_line (); + } + + if (! gfc_at_bol ()) + { + gfc_current_locus = start; + return; + } + } + + for (;;) + { + start = gfc_current_locus; + if (gfc_at_eof ()) + break; + + c = next_char (); + if (c == '\n') + { + gfc_advance_line (); + continue; + } + + if (c == '!' || c == 'c' || c == 'C' || c == '*') + { + if (skip_gcc_attribute (start)) + { + /* Canonicalize to *$omp. */ + *start.nextc = '*'; + return; + } + + if (gfc_current_locus.lb != NULL + && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) + continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); + + /* If -fopenmp/-fopenacc, we need to handle here 2 things: + 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments, + but directives + 2) handle OpenMP/OpenACC conditional compilation, where + !$|c$|*$ should be treated as 2 spaces if the characters + in columns 3 to 6 are valid fixed form label columns + characters. */ + if ((flag_openmp || flag_openmp_simd) && !flag_openacc) + { + if (next_char () == '$') + { + c = next_char (); + if (c == 'o' || c == 'O') + { + if (skip_fixed_omp_sentinel (&start)) + return; + } + else + goto check_for_digits; + } + gfc_current_locus = start; + } + else if (flag_openacc && !(flag_openmp || flag_openmp_simd)) + { + if (next_char () == '$') + { + c = next_char (); + if (c == 'a' || c == 'A') + { + if (skip_fixed_oacc_sentinel (&start)) + return; + } + } + gfc_current_locus = start; + } + else if (flag_openacc || flag_openmp || flag_openmp_simd) + { + if (next_char () == '$') + { + c = next_char (); + if (c == 'a' || c == 'A') + { + if (skip_fixed_oacc_sentinel (&start)) + return; + } + else if (c == 'o' || c == 'O') + { + if (skip_fixed_omp_sentinel (&start)) + return; + } + else + goto check_for_digits; + } + gfc_current_locus = start; + } + + skip_comment_line (); + continue; + +check_for_digits: + { + /* Required for OpenMP's conditional compilation sentinel. */ + int digit_seen = 0; + + for (col = 3; col < 6; col++, c = next_char ()) + if (c == ' ') + continue; + else if (c == '\t') + { + col = 6; + break; + } + else if (c < '0' || c > '9') + break; + else + digit_seen = 1; + + if (col == 6 && c != '\n' + && ((continue_flag && !digit_seen) + || c == ' ' || c == '\t' || c == '0')) + { + gfc_current_locus = start; + start.nextc[0] = ' '; + start.nextc[1] = ' '; + continue; + } + } + skip_comment_line (); + continue; + } + + if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D')) + { + if (gfc_option.flag_d_lines == 0) + { + skip_comment_line (); + continue; + } + else + *start.nextc = c = ' '; + } + + col = 1; + + while (gfc_is_whitespace (c)) + { + c = next_char (); + col++; + } + + if (c == '\n') + { + gfc_advance_line (); + continue; + } + + if (col != 6 && c == '!') + { + if (gfc_current_locus.lb != NULL + && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) + continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); + skip_comment_line (); + continue; + } + + break; + } + + openmp_flag = 0; + openacc_flag = 0; + gcc_attribute_flag = 0; + gfc_current_locus = start; +} + + +/* Skips the current line if it is a comment. */ + +void +gfc_skip_comments (void) +{ + if (gfc_current_form == FORM_FREE) + skip_free_comments (); + else + skip_fixed_comments (); +} + + +/* Get the next character from the input, taking continuation lines + and end-of-line comments into account. This implies that comment + lines between continued lines must be eaten here. For higher-level + subroutines, this flattens continued lines into a single logical + line. The in_string flag denotes whether we're inside a character + context or not. */ + +gfc_char_t +gfc_next_char_literal (gfc_instring in_string) +{ + static locus omp_acc_err_loc = {}; + locus old_loc; + int i, prev_openmp_flag, prev_openacc_flag; + gfc_char_t c; + + continue_flag = 0; + prev_openacc_flag = prev_openmp_flag = 0; + +restart: + c = next_char (); + if (gfc_at_end ()) + { + continue_count = 0; + return c; + } + + if (gfc_current_form == FORM_FREE) + { + bool openmp_cond_flag; + + if (!in_string && c == '!') + { + if (gcc_attribute_flag + && memcmp (&gfc_current_locus, &gcc_attribute_locus, + sizeof (gfc_current_locus)) == 0) + goto done; + + if (openmp_flag + && memcmp (&gfc_current_locus, &openmp_locus, + sizeof (gfc_current_locus)) == 0) + goto done; + + if (openacc_flag + && memcmp (&gfc_current_locus, &openacc_locus, + sizeof (gfc_current_locus)) == 0) + goto done; + + /* This line can't be continued */ + do + { + c = next_char (); + } + while (c != '\n'); + + /* Avoid truncation warnings for comment ending lines. */ + gfc_current_locus.lb->truncated = 0; + + goto done; + } + + /* Check to see if the continuation line was truncated. */ + if (warn_line_truncation && gfc_current_locus.lb != NULL + && gfc_current_locus.lb->truncated) + { + int maxlen = flag_free_line_length; + gfc_char_t *current_nextc = gfc_current_locus.nextc; + + gfc_current_locus.lb->truncated = 0; + gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen; + gfc_warning_now (OPT_Wline_truncation, + "Line truncated at %L", &gfc_current_locus); + gfc_current_locus.nextc = current_nextc; + } + + if (c != '&') + goto done; + + /* If the next nonblank character is a ! or \n, we've got a + continuation line. */ + old_loc = gfc_current_locus; + + c = next_char (); + while (gfc_is_whitespace (c)) + c = next_char (); + + /* Character constants to be continued cannot have commentary + after the '&'. However, there are cases where we may think we + are still in a string and we are looking for a possible + doubled quote and we end up here. See PR64506. */ + + if (in_string && c != '\n') + { + gfc_current_locus = old_loc; + c = '&'; + goto done; + } + + if (c != '!' && c != '\n') + { + gfc_current_locus = old_loc; + c = '&'; + goto done; + } + + if (flag_openmp) + prev_openmp_flag = openmp_flag; + if (flag_openacc) + prev_openacc_flag = openacc_flag; + + /* This can happen if the input file changed or via cpp's #line + without getting reset (e.g. via input_stmt). It also happens + when pre-including files via -fpre-include=. */ + if (continue_count == 0 + && gfc_current_locus.lb + && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1) + continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1; + + continue_flag = 1; + if (c == '!') + skip_comment_line (); + else + gfc_advance_line (); + + if (gfc_at_eof ()) + goto not_continuation; + + /* We've got a continuation line. If we are on the very next line after + the last continuation, increment the continuation line count and + check whether the limit has been exceeded. */ + if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1) + { + if (++continue_count == gfc_option.max_continue_free) + { + if (gfc_notification_std (GFC_STD_GNU) || pedantic) + gfc_warning (0, "Limit of %d continuations exceeded in " + "statement at %C", gfc_option.max_continue_free); + } + } + + /* Now find where it continues. First eat any comment lines. */ + openmp_cond_flag = skip_free_comments (); + + if (gfc_current_locus.lb != NULL + && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) + continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); + + if (flag_openmp) + if (prev_openmp_flag != openmp_flag && !openacc_flag) + { + gfc_current_locus = old_loc; + openmp_flag = prev_openmp_flag; + c = '&'; + goto done; + } + + if (flag_openacc) + if (prev_openacc_flag != openacc_flag && !openmp_flag) + { + gfc_current_locus = old_loc; + openacc_flag = prev_openacc_flag; + c = '&'; + goto done; + } + + /* Now that we have a non-comment line, probe ahead for the + first non-whitespace character. If it is another '&', then + reading starts at the next character, otherwise we must back + up to where the whitespace started and resume from there. */ + + old_loc = gfc_current_locus; + + c = next_char (); + while (gfc_is_whitespace (c)) + c = next_char (); + + if (openmp_flag && !openacc_flag) + { + for (i = 0; i < 5; i++, c = next_char ()) + { + gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]); + if (i == 4) + old_loc = gfc_current_locus; + } + while (gfc_is_whitespace (c)) + c = next_char (); + } + if (openacc_flag && !openmp_flag) + { + for (i = 0; i < 5; i++, c = next_char ()) + { + gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$acc"[i]); + if (i == 4) + old_loc = gfc_current_locus; + } + while (gfc_is_whitespace (c)) + c = next_char (); + } + + /* In case we have an OpenMP directive continued by OpenACC + sentinel, or vice versa, we get both openmp_flag and + openacc_flag on. */ + + if (openacc_flag && openmp_flag) + { + int is_openmp = 0; + for (i = 0; i < 5; i++, c = next_char ()) + { + if (gfc_wide_tolower (c) != (unsigned char) "!$acc"[i]) + is_openmp = 1; + } + if (omp_acc_err_loc.nextc != gfc_current_locus.nextc + || omp_acc_err_loc.lb != gfc_current_locus.lb) + gfc_error_now (is_openmp + ? G_("Wrong OpenACC continuation at %C: " + "expected !$ACC, got !$OMP") + : G_("Wrong OpenMP continuation at %C: " + "expected !$OMP, got !$ACC")); + omp_acc_err_loc = gfc_current_locus; + goto not_continuation; + } + + if (c != '&') + { + if (in_string && gfc_current_locus.nextc) + { + gfc_current_locus.nextc--; + if (warn_ampersand && in_string == INSTRING_WARN) + gfc_warning (OPT_Wampersand, + "Missing %<&%> in continued character " + "constant at %C"); + } + else if (!in_string && (c == '\'' || c == '"')) + goto done; + /* Both !$omp and !$ -fopenmp continuation lines have & on the + continuation line only optionally. */ + else if (openmp_flag || openacc_flag || openmp_cond_flag) + { + if (gfc_current_locus.nextc) + gfc_current_locus.nextc--; + } + else + { + c = ' '; + gfc_current_locus = old_loc; + goto done; + } + } + } + else /* Fixed form. */ + { + /* Fixed form continuation. */ + if (in_string != INSTRING_WARN && c == '!') + { + /* Skip comment at end of line. */ + do + { + c = next_char (); + } + while (c != '\n'); + + /* Avoid truncation warnings for comment ending lines. */ + gfc_current_locus.lb->truncated = 0; + } + + if (c != '\n') + goto done; + + /* Check to see if the continuation line was truncated. */ + if (warn_line_truncation && gfc_current_locus.lb != NULL + && gfc_current_locus.lb->truncated) + { + gfc_current_locus.lb->truncated = 0; + gfc_warning_now (OPT_Wline_truncation, + "Line truncated at %L", &gfc_current_locus); + } + + if (flag_openmp) + prev_openmp_flag = openmp_flag; + if (flag_openacc) + prev_openacc_flag = openacc_flag; + + /* This can happen if the input file changed or via cpp's #line + without getting reset (e.g. via input_stmt). It also happens + when pre-including files via -fpre-include=. */ + if (continue_count == 0 + && gfc_current_locus.lb + && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1) + continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1; + + continue_flag = 1; + old_loc = gfc_current_locus; + + gfc_advance_line (); + skip_fixed_comments (); + + /* See if this line is a continuation line. */ + if (flag_openmp && openmp_flag != prev_openmp_flag && !openacc_flag) + { + openmp_flag = prev_openmp_flag; + goto not_continuation; + } + if (flag_openacc && openacc_flag != prev_openacc_flag && !openmp_flag) + { + openacc_flag = prev_openacc_flag; + goto not_continuation; + } + + /* In case we have an OpenMP directive continued by OpenACC + sentinel, or vice versa, we get both openmp_flag and + openacc_flag on. */ + if (openacc_flag && openmp_flag) + { + int is_openmp = 0; + for (i = 0; i < 5; i++) + { + c = next_char (); + if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i]) + is_openmp = 1; + } + if (omp_acc_err_loc.nextc != gfc_current_locus.nextc + || omp_acc_err_loc.lb != gfc_current_locus.lb) + gfc_error_now (is_openmp + ? G_("Wrong OpenACC continuation at %C: " + "expected !$ACC, got !$OMP") + : G_("Wrong OpenMP continuation at %C: " + "expected !$OMP, got !$ACC")); + omp_acc_err_loc = gfc_current_locus; + goto not_continuation; + } + else if (!openmp_flag && !openacc_flag) + for (i = 0; i < 5; i++) + { + c = next_char (); + if (c != ' ') + goto not_continuation; + } + else if (openmp_flag) + for (i = 0; i < 5; i++) + { + c = next_char (); + if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i]) + goto not_continuation; + } + else if (openacc_flag) + for (i = 0; i < 5; i++) + { + c = next_char (); + if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i]) + goto not_continuation; + } + + c = next_char (); + if (c == '0' || c == ' ' || c == '\n') + goto not_continuation; + + /* We've got a continuation line. If we are on the very next line after + the last continuation, increment the continuation line count and + check whether the limit has been exceeded. */ + if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1) + { + if (++continue_count == gfc_option.max_continue_fixed) + { + if (gfc_notification_std (GFC_STD_GNU) || pedantic) + gfc_warning (0, "Limit of %d continuations exceeded in " + "statement at %C", + gfc_option.max_continue_fixed); + } + } + + if (gfc_current_locus.lb != NULL + && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) + continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); + } + + /* Ready to read first character of continuation line, which might + be another continuation line! */ + goto restart; + +not_continuation: + c = '\n'; + gfc_current_locus = old_loc; + end_flag = 0; + +done: + if (c == '\n') + continue_count = 0; + continue_flag = 0; + return c; +} + + +/* Get the next character of input, folded to lowercase. In fixed + form mode, we also ignore spaces. When matcher subroutines are + parsing character literals, they have to call + gfc_next_char_literal(). */ + +gfc_char_t +gfc_next_char (void) +{ + gfc_char_t c; + + do + { + c = gfc_next_char_literal (NONSTRING); + } + while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c)); + + return gfc_wide_tolower (c); +} + +char +gfc_next_ascii_char (void) +{ + gfc_char_t c = gfc_next_char (); + + return (gfc_wide_fits_in_byte (c) ? (unsigned char) c + : (unsigned char) UCHAR_MAX); +} + + +gfc_char_t +gfc_peek_char (void) +{ + locus old_loc; + gfc_char_t c; + + old_loc = gfc_current_locus; + c = gfc_next_char (); + gfc_current_locus = old_loc; + + return c; +} + + +char +gfc_peek_ascii_char (void) +{ + gfc_char_t c = gfc_peek_char (); + + return (gfc_wide_fits_in_byte (c) ? (unsigned char) c + : (unsigned char) UCHAR_MAX); +} + + +/* Recover from an error. We try to get past the current statement + and get lined up for the next. The next statement follows a '\n' + or a ';'. We also assume that we are not within a character + constant, and deal with finding a '\'' or '"'. */ + +void +gfc_error_recovery (void) +{ + gfc_char_t c, delim; + + if (gfc_at_eof ()) + return; + + for (;;) + { + c = gfc_next_char (); + if (c == '\n' || c == ';') + break; + + if (c != '\'' && c != '"') + { + if (gfc_at_eof ()) + break; + continue; + } + delim = c; + + for (;;) + { + c = next_char (); + + if (c == delim) + break; + if (c == '\n') + return; + if (c == '\\') + { + c = next_char (); + if (c == '\n') + return; + } + } + if (gfc_at_eof ()) + break; + } +} + + +/* Read ahead until the next character to be read is not whitespace. */ + +void +gfc_gobble_whitespace (void) +{ + static int linenum = 0; + locus old_loc; + gfc_char_t c; + + do + { + old_loc = gfc_current_locus; + c = gfc_next_char_literal (NONSTRING); + /* Issue a warning for nonconforming tabs. We keep track of the line + number because the Fortran matchers will often back up and the same + line will be scanned multiple times. */ + if (warn_tabs && c == '\t') + { + int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location); + if (cur_linenum != linenum) + { + linenum = cur_linenum; + gfc_warning_now (OPT_Wtabs, "Nonconforming tab character at %C"); + } + } + } + while (gfc_is_whitespace (c)); + + if (!ISPRINT(c) && c != '\n' && last_error_char != gfc_current_locus.nextc) + { + char buf[20]; + last_error_char = gfc_current_locus.nextc; + snprintf (buf, 20, "%2.2X", c); + gfc_error_now ("Invalid character 0x%s at %C", buf); + } + + gfc_current_locus = old_loc; +} + + +/* Load a single line into pbuf. + + If pbuf points to a NULL pointer, it is allocated. + We truncate lines that are too long, unless we're dealing with + preprocessor lines or if the option -ffixed-line-length-none is set, + in which case we reallocate the buffer to fit the entire line, if + need be. + In fixed mode, we expand a tab that occurs within the statement + label region to expand to spaces that leave the next character in + the source region. + + If first_char is not NULL, it's a pointer to a single char value holding + the first character of the line, which has already been read by the + caller. This avoids the use of ungetc(). + + load_line returns whether the line was truncated. + + NOTE: The error machinery isn't available at this point, so we can't + easily report line and column numbers consistent with other + parts of gfortran. */ + +static int +load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) +{ + int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; + int quoted = ' ', comment_ix = -1; + bool seen_comment = false; + bool first_comment = true; + bool trunc_flag = false; + bool seen_printable = false; + bool seen_ampersand = false; + bool found_tab = false; + bool warned_tabs = false; + gfc_char_t *buffer; + + /* Determine the maximum allowed line length. */ + if (gfc_current_form == FORM_FREE) + maxlen = flag_free_line_length; + else if (gfc_current_form == FORM_FIXED) + maxlen = flag_fixed_line_length; + else + maxlen = 72; + + if (*pbuf == NULL) + { + /* Allocate the line buffer, storing its length into buflen. + Note that if maxlen==0, indicating that arbitrary-length lines + are allowed, the buffer will be reallocated if this length is + insufficient; since 132 characters is the length of a standard + free-form line, we use that as a starting guess. */ + if (maxlen > 0) + buflen = maxlen; + else + buflen = 132; + + *pbuf = gfc_get_wide_string (buflen + 1); + } + + i = 0; + buffer = *pbuf; + + if (first_char) + c = *first_char; + else + c = getc (input); + + /* In order to not truncate preprocessor lines, we have to + remember that this is one. */ + preprocessor_flag = (c == '#'); + + for (;;) + { + if (c == EOF) + break; + + if (c == '\n') + { + /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */ + if (gfc_current_form == FORM_FREE + && !seen_printable && seen_ampersand) + { + if (pedantic) + gfc_error_now ("%<&%> not allowed by itself in line %d", + current_file->line); + else + gfc_warning_now (0, "%<&%> not allowed by itself in line %d", + current_file->line); + } + break; + } + + if (c == '\r' || c == '\0') + goto next_char; /* Gobble characters. */ + + if (c == '&') + { + if (seen_ampersand) + { + seen_ampersand = false; + seen_printable = true; + } + else + seen_ampersand = true; + } + + if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand)) + seen_printable = true; + + /* Is this a fixed-form comment? */ + if (gfc_current_form == FORM_FIXED && i == 0 + && (c == '*' || c == 'c' || c == 'C' + || (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D')))) + { + seen_comment = true; + comment_ix = i; + } + + if (quoted == ' ') + { + if (c == '\'' || c == '"') + quoted = c; + } + else if (c == quoted) + quoted = ' '; + + /* Is this a free-form comment? */ + if (c == '!' && quoted == ' ') + { + if (seen_comment) + first_comment = false; + seen_comment = true; + comment_ix = i; + } + + /* For truncation and tab warnings, set seen_comment to false if one has + either an OpenMP or OpenACC directive - or a !GCC$ attribute. If + OpenMP is enabled, use '!$' as as conditional compilation sentinel + and OpenMP directive ('!$omp'). */ + if (seen_comment && first_comment && flag_openmp && comment_ix + 1 == i + && c == '$') + first_comment = seen_comment = false; + if (seen_comment && first_comment && comment_ix + 4 == i) + { + if (((*pbuf)[comment_ix+1] == 'g' || (*pbuf)[comment_ix+1] == 'G') + && ((*pbuf)[comment_ix+2] == 'c' || (*pbuf)[comment_ix+2] == 'C') + && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C') + && c == '$') + first_comment = seen_comment = false; + if (flag_openacc + && (*pbuf)[comment_ix+1] == '$' + && ((*pbuf)[comment_ix+2] == 'a' || (*pbuf)[comment_ix+2] == 'A') + && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C') + && (c == 'c' || c == 'C')) + first_comment = seen_comment = false; + } + + /* Vendor extension: "1" marks a continuation line. */ + if (found_tab) + { + found_tab = false; + if (c >= '1' && c <= '9') + { + *(buffer-1) = c; + goto next_char; + } + } + + if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6) + { + found_tab = true; + + if (warn_tabs && seen_comment == 0 && !warned_tabs) + { + warned_tabs = true; + gfc_warning_now (OPT_Wtabs, + "Nonconforming tab character in column %d " + "of line %d", i + 1, current_file->line); + } + + while (i < 6) + { + *buffer++ = ' '; + i++; + } + + goto next_char; + } + + *buffer++ = c; + i++; + + if (maxlen == 0 || preprocessor_flag) + { + if (i >= buflen) + { + /* Reallocate line buffer to double size to hold the + overlong line. */ + buflen = buflen * 2; + *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1)); + buffer = (*pbuf) + i; + } + } + else if (i >= maxlen) + { + bool trunc_warn = true; + + /* Enhancement, if the very next non-space character is an ampersand + or comment that we would otherwise warn about, don't mark as + truncated. */ + + /* Truncate the rest of the line. */ + for (;;) + { + c = getc (input); + if (c == '\r' || c == ' ') + continue; + + if (c == '\n' || c == EOF) + break; + + if (!trunc_warn && c != '!') + trunc_warn = true; + + if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&') + || c == '!')) + trunc_warn = false; + + if (c == '!') + seen_comment = 1; + + if (trunc_warn && !seen_comment) + trunc_flag = 1; + } + + c = '\n'; + continue; + } + +next_char: + c = getc (input); + } + + /* Pad lines to the selected line length in fixed form. */ + if (gfc_current_form == FORM_FIXED + && flag_fixed_line_length != 0 + && flag_pad_source + && !preprocessor_flag + && c != EOF) + { + while (i++ < maxlen) + *buffer++ = ' '; + } + + *buffer = '\0'; + *pbuflen = buflen; + + return trunc_flag; +} + + +/* Get a gfc_file structure, initialize it and add it to + the file stack. */ + +static gfc_file * +get_file (const char *name, enum lc_reason reason) +{ + gfc_file *f; + + f = XCNEW (gfc_file); + + f->filename = xstrdup (name); + + f->next = file_head; + file_head = f; + + f->up = current_file; + if (current_file != NULL) + f->inclusion_line = current_file->line; + + linemap_add (line_table, reason, false, f->filename, 1); + + return f; +} + + +/* Deal with a line from the C preprocessor. The + initial octothorp has already been seen. */ + +static void +preprocessor_line (gfc_char_t *c) +{ + bool flag[5]; + int i, line; + gfc_char_t *wide_filename; + gfc_file *f; + int escaped, unescape; + char *filename; + + c++; + while (*c == ' ' || *c == '\t') + c++; + + if (*c < '0' || *c > '9') + goto bad_cpp_line; + + line = wide_atoi (c); + + c = wide_strchr (c, ' '); + if (c == NULL) + { + /* No file name given. Set new line number. */ + current_file->line = line; + return; + } + + /* Skip spaces. */ + while (*c == ' ' || *c == '\t') + c++; + + /* Skip quote. */ + if (*c != '"') + goto bad_cpp_line; + ++c; + + wide_filename = c; + + /* Make filename end at quote. */ + unescape = 0; + escaped = false; + while (*c && ! (!escaped && *c == '"')) + { + if (escaped) + escaped = false; + else if (*c == '\\') + { + escaped = true; + unescape++; + } + ++c; + } + + if (! *c) + /* Preprocessor line has no closing quote. */ + goto bad_cpp_line; + + *c++ = '\0'; + + /* Undo effects of cpp_quote_string. */ + if (unescape) + { + gfc_char_t *s = wide_filename; + gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape); + + wide_filename = d; + while (*s) + { + if (*s == '\\') + *d++ = *++s; + else + *d++ = *s; + s++; + } + *d = '\0'; + } + + /* Get flags. */ + + flag[1] = flag[2] = flag[3] = flag[4] = false; + + for (;;) + { + c = wide_strchr (c, ' '); + if (c == NULL) + break; + + c++; + i = wide_atoi (c); + + if (i >= 1 && i <= 4) + flag[i] = true; + } + + /* Convert the filename in wide characters into a filename in narrow + characters. */ + filename = gfc_widechar_to_char (wide_filename, -1); + + /* Interpret flags. */ + + if (flag[1]) /* Starting new file. */ + { + f = get_file (filename, LC_RENAME); + add_file_change (f->filename, f->inclusion_line); + current_file = f; + } + + if (flag[2]) /* Ending current file. */ + { + if (!current_file->up + || filename_cmp (current_file->up->filename, filename) != 0) + { + linemap_line_start (line_table, current_file->line, 80); + /* ??? One could compute the exact column where the filename + starts and compute the exact location here. */ + gfc_warning_now_at (linemap_position_for_column (line_table, 1), + 0, "file %qs left but not entered", + filename); + current_file->line++; + if (unescape) + free (wide_filename); + free (filename); + return; + } + + add_file_change (NULL, line); + current_file = current_file->up; + linemap_add (line_table, LC_RENAME, false, current_file->filename, + current_file->line); + } + + /* The name of the file can be a temporary file produced by + cpp. Replace the name if it is different. */ + + if (filename_cmp (current_file->filename, filename) != 0) + { + /* FIXME: we leak the old filename because a pointer to it may be stored + in the linemap. Alternative could be using GC or updating linemap to + point to the new name, but there is no API for that currently. */ + current_file->filename = xstrdup (filename); + + /* We need to tell the linemap API that the filename changed. Just + changing current_file is insufficient. */ + linemap_add (line_table, LC_RENAME, false, current_file->filename, line); + } + + /* Set new line number. */ + current_file->line = line; + if (unescape) + free (wide_filename); + free (filename); + return; + + bad_cpp_line: + linemap_line_start (line_table, current_file->line, 80); + /* ??? One could compute the exact column where the directive + starts and compute the exact location here. */ + gfc_warning_now_at (linemap_position_for_column (line_table, 2), 0, + "Illegal preprocessor directive"); + current_file->line++; +} + + +static void load_file (const char *, const char *, bool); + +/* include_line()-- Checks a line buffer to see if it is an include + line. If so, we call load_file() recursively to load the included + file. We never return a syntax error because a statement like + "include = 5" is perfectly legal. We return 0 if no include was + processed, 1 if we matched an include or -1 if include was + partially processed, but will need continuation lines. */ + +static int +include_line (gfc_char_t *line) +{ + gfc_char_t quote, *c, *begin, *stop; + char *filename; + const char *include = "include"; + bool allow_continuation = flag_dec_include; + int i; + + c = line; + + if (flag_openmp || flag_openmp_simd) + { + if (gfc_current_form == FORM_FREE) + { + while (*c == ' ' || *c == '\t') + c++; + if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t')) + c += 3; + } + else + { + if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*') + && c[1] == '$' && c[2] == ' ') + c += 3; + } + } + + if (gfc_current_form == FORM_FREE) + { + while (*c == ' ' || *c == '\t') + c++; + if (gfc_wide_strncasecmp (c, "include", 7)) + { + if (!allow_continuation) + return 0; + for (i = 0; i < 7; ++i) + { + gfc_char_t c1 = gfc_wide_tolower (*c); + if (c1 != (unsigned char) include[i]) + break; + c++; + } + if (i == 0 || *c != '&') + return 0; + c++; + while (*c == ' ' || *c == '\t') + c++; + if (*c == '\0' || *c == '!') + return -1; + return 0; + } + + c += 7; + } + else + { + while (*c == ' ' || *c == '\t') + c++; + if (flag_dec_include && *c == '0' && c - line == 5) + { + c++; + while (*c == ' ' || *c == '\t') + c++; + } + if (c - line < 6) + allow_continuation = false; + for (i = 0; i < 7; ++i) + { + gfc_char_t c1 = gfc_wide_tolower (*c); + if (c1 != (unsigned char) include[i]) + break; + c++; + while (*c == ' ' || *c == '\t') + c++; + } + if (!allow_continuation) + { + if (i != 7) + return 0; + } + else if (i != 7) + { + if (i == 0) + return 0; + + /* At the end of line or comment this might be continued. */ + if (*c == '\0' || *c == '!') + return -1; + + return 0; + } + } + + while (*c == ' ' || *c == '\t') + c++; + + /* Find filename between quotes. */ + + quote = *c++; + if (quote != '"' && quote != '\'') + { + if (allow_continuation) + { + if (gfc_current_form == FORM_FREE) + { + if (quote == '&') + { + while (*c == ' ' || *c == '\t') + c++; + if (*c == '\0' || *c == '!') + return -1; + } + } + else if (quote == '\0' || quote == '!') + return -1; + } + return 0; + } + + begin = c; + + bool cont = false; + while (*c != quote && *c != '\0') + { + if (allow_continuation && gfc_current_form == FORM_FREE) + { + if (*c == '&') + cont = true; + else if (*c != ' ' && *c != '\t') + cont = false; + } + c++; + } + + if (*c == '\0') + { + if (allow_continuation + && (cont || gfc_current_form != FORM_FREE)) + return -1; + return 0; + } + + stop = c++; + + while (*c == ' ' || *c == '\t') + c++; + + if (*c != '\0' && *c != '!') + return 0; + + /* We have an include line at this point. */ + + *stop = '\0'; /* It's ok to trash the buffer, as this line won't be + read by anything else. */ + + filename = gfc_widechar_to_char (begin, -1); + load_file (filename, NULL, false); + free (filename); + return 1; +} + +/* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc. + APIs. Return 1 if recognized as valid INCLUDE statement and load_file has + been called, 0 if it is not a valid INCLUDE statement and -1 if eof has + been encountered while parsing it. */ +static int +include_stmt (gfc_linebuf *b) +{ + int ret = 0, i, length; + const char *include = "include"; + gfc_char_t c, quote = 0; + locus str_locus; + char *filename; + + continue_flag = 0; + end_flag = 0; + gcc_attribute_flag = 0; + openmp_flag = 0; + openacc_flag = 0; + continue_count = 0; + continue_line = 0; + gfc_current_locus.lb = b; + gfc_current_locus.nextc = b->line; + + gfc_skip_comments (); + gfc_gobble_whitespace (); + + for (i = 0; i < 7; i++) + { + c = gfc_next_char (); + if (c != (unsigned char) include[i]) + { + if (gfc_current_form == FORM_FIXED + && i == 0 + && c == '0' + && gfc_current_locus.nextc == b->line + 6) + { + gfc_gobble_whitespace (); + i--; + continue; + } + gcc_assert (i != 0); + if (c == '\n') + { + gfc_advance_line (); + gfc_skip_comments (); + if (gfc_at_eof ()) + ret = -1; + } + goto do_ret; + } + } + gfc_gobble_whitespace (); + + c = gfc_next_char (); + if (c == '\'' || c == '"') + quote = c; + else + { + if (c == '\n') + { + gfc_advance_line (); + gfc_skip_comments (); + if (gfc_at_eof ()) + ret = -1; + } + goto do_ret; + } + + str_locus = gfc_current_locus; + length = 0; + do + { + c = gfc_next_char_literal (INSTRING_NOWARN); + if (c == quote) + break; + if (c == '\n') + { + gfc_advance_line (); + gfc_skip_comments (); + if (gfc_at_eof ()) + ret = -1; + goto do_ret; + } + length++; + } + while (1); + + gfc_gobble_whitespace (); + c = gfc_next_char (); + if (c != '\n') + goto do_ret; + + gfc_current_locus = str_locus; + ret = 1; + filename = XNEWVEC (char, length + 1); + for (i = 0; i < length; i++) + { + c = gfc_next_char_literal (INSTRING_WARN); + gcc_assert (gfc_wide_fits_in_byte (c)); + filename[i] = (unsigned char) c; + } + filename[length] = '\0'; + load_file (filename, NULL, false); + free (filename); + +do_ret: + continue_flag = 0; + end_flag = 0; + gcc_attribute_flag = 0; + openmp_flag = 0; + openacc_flag = 0; + continue_count = 0; + continue_line = 0; + memset (&gfc_current_locus, '\0', sizeof (locus)); + memset (&openmp_locus, '\0', sizeof (locus)); + memset (&openacc_locus, '\0', sizeof (locus)); + memset (&gcc_attribute_locus, '\0', sizeof (locus)); + return ret; +} + + + +/* Load a file into memory by calling load_line until the file ends. */ + +static void +load_file (const char *realfilename, const char *displayedname, bool initial) +{ + gfc_char_t *line; + gfc_linebuf *b, *include_b = NULL; + gfc_file *f; + FILE *input; + int len, line_len; + bool first_line; + struct stat st; + int stat_result; + const char *filename; + /* If realfilename and displayedname are different and non-null then + surely realfilename is the preprocessed form of + displayedname. */ + bool preprocessed_p = (realfilename && displayedname + && strcmp (realfilename, displayedname)); + + filename = displayedname ? displayedname : realfilename; + + for (f = current_file; f; f = f->up) + if (filename_cmp (filename, f->filename) == 0) + fatal_error (linemap_line_start (line_table, current_file->line, 0), + "File %qs is being included recursively", filename); + if (initial) + { + if (gfc_src_file) + { + input = gfc_src_file; + gfc_src_file = NULL; + } + else + input = gfc_open_file (realfilename); + + if (input == NULL) + gfc_fatal_error ("Cannot open file %qs", filename); + } + else + { + input = gfc_open_included_file (realfilename, false, false); + if (input == NULL) + { + /* For -fpre-include file, current_file is NULL. */ + if (current_file) + fatal_error (linemap_line_start (line_table, current_file->line, 0), + "Cannot open included file %qs", filename); + else + gfc_fatal_error ("Cannot open pre-included file %qs", filename); + } + stat_result = stat (realfilename, &st); + if (stat_result == 0 && !S_ISREG (st.st_mode)) + { + fclose (input); + if (current_file) + fatal_error (linemap_line_start (line_table, current_file->line, 0), + "Included file %qs is not a regular file", filename); + else + gfc_fatal_error ("Included file %qs is not a regular file", filename); + } + } + + /* Load the file. + + A "non-initial" file means a file that is being included. In + that case we are creating an LC_ENTER map. + + An "initial" file means a main file; one that is not included. + That file has already got at least one (surely more) line map(s) + created by gfc_init. So the subsequent map created in that case + must have LC_RENAME reason. + + This latter case is not true for a preprocessed file. In that + case, although the file is "initial", the line maps created by + gfc_init was used during the preprocessing of the file. Now that + the preprocessing is over and we are being fed the result of that + preprocessing, we need to create a brand new line map for the + preprocessed file, so the reason is going to be LC_ENTER. */ + + f = get_file (filename, (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER); + if (!initial) + add_file_change (f->filename, f->inclusion_line); + current_file = f; + current_file->line = 1; + line = NULL; + line_len = 0; + first_line = true; + + if (initial && gfc_src_preprocessor_lines[0]) + { + preprocessor_line (gfc_src_preprocessor_lines[0]); + free (gfc_src_preprocessor_lines[0]); + gfc_src_preprocessor_lines[0] = NULL; + if (gfc_src_preprocessor_lines[1]) + { + preprocessor_line (gfc_src_preprocessor_lines[1]); + free (gfc_src_preprocessor_lines[1]); + gfc_src_preprocessor_lines[1] = NULL; + } + } + + for (;;) + { + int trunc = load_line (input, &line, &line_len, NULL); + int inc_line; + + len = gfc_wide_strlen (line); + if (feof (input) && len == 0) + break; + + /* If this is the first line of the file, it can contain a byte + order mark (BOM), which we will ignore: + FF FE is UTF-16 little endian, + FE FF is UTF-16 big endian, + EF BB BF is UTF-8. */ + if (first_line + && ((line_len >= 2 && line[0] == (unsigned char) '\xFF' + && line[1] == (unsigned char) '\xFE') + || (line_len >= 2 && line[0] == (unsigned char) '\xFE' + && line[1] == (unsigned char) '\xFF') + || (line_len >= 3 && line[0] == (unsigned char) '\xEF' + && line[1] == (unsigned char) '\xBB' + && line[2] == (unsigned char) '\xBF'))) + { + int n = line[1] == (unsigned char) '\xBB' ? 3 : 2; + gfc_char_t *new_char = gfc_get_wide_string (line_len); + + wide_strcpy (new_char, &line[n]); + free (line); + line = new_char; + len -= n; + } + + /* There are three things this line can be: a line of Fortran + source, an include line or a C preprocessor directive. */ + + if (line[0] == '#') + { + /* When -g3 is specified, it's possible that we emit #define + and #undef lines, which we need to pass to the middle-end + so that it can emit correct debug info. */ + if (debug_info_level == DINFO_LEVEL_VERBOSE + && (wide_strncmp (line, "#define ", 8) == 0 + || wide_strncmp (line, "#undef ", 7) == 0)) + ; + else + { + preprocessor_line (line); + continue; + } + } + + /* Preprocessed files have preprocessor lines added before the byte + order mark, so first_line is not about the first line of the file + but the first line that's not a preprocessor line. */ + first_line = false; + + inc_line = include_line (line); + if (inc_line > 0) + { + current_file->line++; + continue; + } + + /* Add line. */ + + b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size + + (len + 1) * sizeof (gfc_char_t)); + + + b->location + = linemap_line_start (line_table, current_file->line++, len); + /* ??? We add the location for the maximum column possible here, + because otherwise if the next call creates a new line-map, it + will not reserve space for any offset. */ + if (len > 0) + linemap_position_for_column (line_table, len); + + b->file = current_file; + b->truncated = trunc; + wide_strcpy (b->line, line); + + if (line_head == NULL) + line_head = b; + else + line_tail->next = b; + + line_tail = b; + + while (file_changes_cur < file_changes_count) + file_changes[file_changes_cur++].lb = b; + + if (flag_dec_include) + { + if (include_b && b != include_b) + { + int inc_line2 = include_stmt (include_b); + if (inc_line2 == 0) + include_b = NULL; + else if (inc_line2 > 0) + { + do + { + if (gfc_current_form == FORM_FIXED) + { + for (gfc_char_t *p = include_b->line; *p; p++) + *p = ' '; + } + else + include_b->line[0] = '\0'; + if (include_b == b) + break; + include_b = include_b->next; + } + while (1); + include_b = NULL; + } + } + if (inc_line == -1 && !include_b) + include_b = b; + } + } + + /* Release the line buffer allocated in load_line. */ + free (line); + + fclose (input); + + if (!initial) + add_file_change (NULL, current_file->inclusion_line + 1); + current_file = current_file->up; + linemap_add (line_table, LC_LEAVE, 0, NULL, 0); +} + + +/* Open a new file and start scanning from that file. Returns true + if everything went OK, false otherwise. If form == FORM_UNKNOWN + it tries to determine the source form from the filename, defaulting + to free form. */ + +void +gfc_new_file (void) +{ + if (flag_pre_include != NULL) + load_file (flag_pre_include, NULL, false); + + if (gfc_cpp_enabled ()) + { + gfc_cpp_preprocess (gfc_source_file); + if (!gfc_cpp_preprocess_only ()) + load_file (gfc_cpp_temporary_file (), gfc_source_file, true); + } + else + load_file (gfc_source_file, NULL, true); + + gfc_current_locus.lb = line_head; + gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line; + +#if 0 /* Debugging aid. */ + for (; line_head; line_head = line_head->next) + printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location), + LOCATION_LINE (line_head->location), line_head->line); + + exit (SUCCESS_EXIT_CODE); +#endif +} + +static char * +unescape_filename (const char *ptr) +{ + const char *p = ptr, *s; + char *d, *ret; + int escaped, unescape = 0; + + /* Make filename end at quote. */ + escaped = false; + while (*p && ! (! escaped && *p == '"')) + { + if (escaped) + escaped = false; + else if (*p == '\\') + { + escaped = true; + unescape++; + } + ++p; + } + + if (!*p || p[1]) + return NULL; + + /* Undo effects of cpp_quote_string. */ + s = ptr; + d = XCNEWVEC (char, p + 1 - ptr - unescape); + ret = d; + + while (s != p) + { + if (*s == '\\') + *d++ = *++s; + else + *d++ = *s; + s++; + } + *d = '\0'; + return ret; +} + +/* For preprocessed files, if the first tokens are of the form # NUM. + handle the directives so we know the original file name. */ + +const char * +gfc_read_orig_filename (const char *filename, const char **canon_source_file) +{ + int c, len; + char *dirname, *tmp; + + gfc_src_file = gfc_open_file (filename); + if (gfc_src_file == NULL) + return NULL; + + c = getc (gfc_src_file); + + if (c != '#') + return NULL; + + len = 0; + load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c); + + if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0) + return NULL; + + tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1); + filename = unescape_filename (tmp); + free (tmp); + if (filename == NULL) + return NULL; + + c = getc (gfc_src_file); + + if (c != '#') + return filename; + + len = 0; + load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c); + + if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0) + return filename; + + tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1); + dirname = unescape_filename (tmp); + free (tmp); + if (dirname == NULL) + return filename; + + len = strlen (dirname); + if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/') + { + free (dirname); + return filename; + } + dirname[len - 2] = '\0'; + set_src_pwd (dirname); + + if (! IS_ABSOLUTE_PATH (filename)) + { + char *p = XCNEWVEC (char, len + strlen (filename)); + + memcpy (p, dirname, len - 2); + p[len - 2] = '/'; + strcpy (p + len - 1, filename); + *canon_source_file = p; + } + + free (dirname); + return filename; +} diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c deleted file mode 100644 index cc7d33a..0000000 --- a/gcc/fortran/simplify.c +++ /dev/null @@ -1,8966 +0,0 @@ -/* Simplify intrinsic functions at compile-time. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught & Katherine Holcomb - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tm.h" /* For BITS_PER_UNIT. */ -#include "gfortran.h" -#include "arith.h" -#include "intrinsic.h" -#include "match.h" -#include "target-memory.h" -#include "constructor.h" -#include "version.h" /* For version_string. */ - -/* Prototypes. */ - -static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false); - -gfc_expr gfc_bad_expr; - -static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int); - - -/* Note that 'simplification' is not just transforming expressions. - For functions that are not simplified at compile time, range - checking is done if possible. - - The return convention is that each simplification function returns: - - A new expression node corresponding to the simplified arguments. - The original arguments are destroyed by the caller, and must not - be a part of the new expression. - - NULL pointer indicating that no simplification was possible and - the original expression should remain intact. - - An expression pointer to gfc_bad_expr (a static placeholder) - indicating that some error has prevented simplification. The - error is generated within the function and should be propagated - upwards - - By the time a simplification function gets control, it has been - decided that the function call is really supposed to be the - intrinsic. No type checking is strictly necessary, since only - valid types will be passed on. On the other hand, a simplification - subroutine may have to look at the type of an argument as part of - its processing. - - Array arguments are only passed to these subroutines that implement - the simplification of transformational intrinsics. - - The functions in this file don't have much comment with them, but - everything is reasonably straight-forward. The Standard, chapter 13 - is the best comment you'll find for this file anyway. */ - -/* Range checks an expression node. If all goes well, returns the - node, otherwise returns &gfc_bad_expr and frees the node. */ - -static gfc_expr * -range_check (gfc_expr *result, const char *name) -{ - if (result == NULL) - return &gfc_bad_expr; - - if (result->expr_type != EXPR_CONSTANT) - return result; - - switch (gfc_range_check (result)) - { - case ARITH_OK: - return result; - - case ARITH_OVERFLOW: - gfc_error ("Result of %s overflows its kind at %L", name, - &result->where); - break; - - case ARITH_UNDERFLOW: - gfc_error ("Result of %s underflows its kind at %L", name, - &result->where); - break; - - case ARITH_NAN: - gfc_error ("Result of %s is NaN at %L", name, &result->where); - break; - - default: - gfc_error ("Result of %s gives range error for its kind at %L", name, - &result->where); - break; - } - - gfc_free_expr (result); - return &gfc_bad_expr; -} - - -/* A helper function that gets an optional and possibly missing - kind parameter. Returns the kind, -1 if something went wrong. */ - -static int -get_kind (bt type, gfc_expr *k, const char *name, int default_kind) -{ - int kind; - - if (k == NULL) - return default_kind; - - if (k->expr_type != EXPR_CONSTANT) - { - gfc_error ("KIND parameter of %s at %L must be an initialization " - "expression", name, &k->where); - return -1; - } - - if (gfc_extract_int (k, &kind) - || gfc_validate_kind (type, kind, true) < 0) - { - gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); - return -1; - } - - return kind; -} - - -/* Converts an mpz_t signed variable into an unsigned one, assuming - two's complement representations and a binary width of bitsize. - The conversion is a no-op unless x is negative; otherwise, it can - be accomplished by masking out the high bits. */ - -static void -convert_mpz_to_unsigned (mpz_t x, int bitsize) -{ - mpz_t mask; - - if (mpz_sgn (x) < 0) - { - /* Confirm that no bits above the signed range are unset if we - are doing range checking. */ - if (flag_range_check != 0) - gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX); - - mpz_init_set_ui (mask, 1); - mpz_mul_2exp (mask, mask, bitsize); - mpz_sub_ui (mask, mask, 1); - - mpz_and (x, x, mask); - - mpz_clear (mask); - } - else - { - /* Confirm that no bits above the signed range are set if we - are doing range checking. */ - if (flag_range_check != 0) - gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX); - } -} - - -/* Converts an mpz_t unsigned variable into a signed one, assuming - two's complement representations and a binary width of bitsize. - If the bitsize-1 bit is set, this is taken as a sign bit and - the number is converted to the corresponding negative number. */ - -void -gfc_convert_mpz_to_signed (mpz_t x, int bitsize) -{ - mpz_t mask; - - /* Confirm that no bits above the unsigned range are set if we are - doing range checking. */ - if (flag_range_check != 0) - gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX); - - if (mpz_tstbit (x, bitsize - 1) == 1) - { - mpz_init_set_ui (mask, 1); - mpz_mul_2exp (mask, mask, bitsize); - mpz_sub_ui (mask, mask, 1); - - /* We negate the number by hand, zeroing the high bits, that is - make it the corresponding positive number, and then have it - negated by GMP, giving the correct representation of the - negative number. */ - mpz_com (x, x); - mpz_add_ui (x, x, 1); - mpz_and (x, x, mask); - - mpz_neg (x, x); - - mpz_clear (mask); - } -} - - -/* Test that the expression is a constant array, simplifying if - we are dealing with a parameter array. */ - -static bool -is_constant_array_expr (gfc_expr *e) -{ - gfc_constructor *c; - bool array_OK = true; - mpz_t size; - - if (e == NULL) - return true; - - if (e->expr_type == EXPR_VARIABLE && e->rank > 0 - && e->symtree->n.sym->attr.flavor == FL_PARAMETER) - gfc_simplify_expr (e, 1); - - if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) - return false; - - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - if (c->expr->expr_type != EXPR_CONSTANT - && c->expr->expr_type != EXPR_STRUCTURE) - { - array_OK = false; - break; - } - - /* Check and expand the constructor. */ - if (!array_OK && gfc_init_expr_flag && e->rank == 1) - { - array_OK = gfc_reduce_init_expr (e); - /* gfc_reduce_init_expr resets the flag. */ - gfc_init_expr_flag = true; - } - else - return array_OK; - - /* Recheck to make sure that any EXPR_ARRAYs have gone. */ - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - if (c->expr->expr_type != EXPR_CONSTANT - && c->expr->expr_type != EXPR_STRUCTURE) - return false; - - /* Make sure that the array has a valid shape. */ - if (e->shape == NULL && e->rank == 1) - { - if (!gfc_array_size(e, &size)) - return false; - e->shape = gfc_get_shape (1); - mpz_init_set (e->shape[0], size); - mpz_clear (size); - } - - return array_OK; -} - -/* Test for a size zero array. */ -bool -gfc_is_size_zero_array (gfc_expr *array) -{ - - if (array->rank == 0) - return false; - - if (array->expr_type == EXPR_VARIABLE && array->rank > 0 - && array->symtree->n.sym->attr.flavor == FL_PARAMETER - && array->shape != NULL) - { - for (int i = 0; i < array->rank; i++) - if (mpz_cmp_si (array->shape[i], 0) <= 0) - return true; - - return false; - } - - if (array->expr_type == EXPR_ARRAY) - return array->value.constructor == NULL; - - return false; -} - - -/* Initialize a transformational result expression with a given value. */ - -static void -init_result_expr (gfc_expr *e, int init, gfc_expr *array) -{ - if (e && e->expr_type == EXPR_ARRAY) - { - gfc_constructor *ctor = gfc_constructor_first (e->value.constructor); - while (ctor) - { - init_result_expr (ctor->expr, init, array); - ctor = gfc_constructor_next (ctor); - } - } - else if (e && e->expr_type == EXPR_CONSTANT) - { - int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - HOST_WIDE_INT length; - gfc_char_t *string; - - switch (e->ts.type) - { - case BT_LOGICAL: - e->value.logical = (init ? 1 : 0); - break; - - case BT_INTEGER: - if (init == INT_MIN) - mpz_set (e->value.integer, gfc_integer_kinds[i].min_int); - else if (init == INT_MAX) - mpz_set (e->value.integer, gfc_integer_kinds[i].huge); - else - mpz_set_si (e->value.integer, init); - break; - - case BT_REAL: - if (init == INT_MIN) - { - mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); - mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); - } - else if (init == INT_MAX) - mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); - else - mpfr_set_si (e->value.real, init, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); - break; - - case BT_CHARACTER: - if (init == INT_MIN) - { - gfc_expr *len = gfc_simplify_len (array, NULL); - gfc_extract_hwi (len, &length); - string = gfc_get_wide_string (length + 1); - gfc_wide_memset (string, 0, length); - } - else if (init == INT_MAX) - { - gfc_expr *len = gfc_simplify_len (array, NULL); - gfc_extract_hwi (len, &length); - string = gfc_get_wide_string (length + 1); - gfc_wide_memset (string, 255, length); - } - else - { - length = 0; - string = gfc_get_wide_string (1); - } - - string[length] = '\0'; - e->value.character.length = length; - e->value.character.string = string; - break; - - default: - gcc_unreachable(); - } - } - else - gcc_unreachable(); -} - - -/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul; - if conj_a is true, the matrix_a is complex conjugated. */ - -static gfc_expr * -compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a, - gfc_expr *matrix_b, int stride_b, int offset_b, - bool conj_a) -{ - gfc_expr *result, *a, *b, *c; - - /* Set result to an INTEGER(1) 0 for numeric types and .false. for - LOGICAL. Mixed-mode math in the loop will promote result to the - correct type and kind. */ - if (matrix_a->ts.type == BT_LOGICAL) - result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); - else - result = gfc_get_int_expr (1, NULL, 0); - result->where = matrix_a->where; - - a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); - b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); - while (a && b) - { - /* Copying of expressions is required as operands are free'd - by the gfc_arith routines. */ - switch (result->ts.type) - { - case BT_LOGICAL: - result = gfc_or (result, - gfc_and (gfc_copy_expr (a), - gfc_copy_expr (b))); - break; - - case BT_INTEGER: - case BT_REAL: - case BT_COMPLEX: - if (conj_a && a->ts.type == BT_COMPLEX) - c = gfc_simplify_conjg (a); - else - c = gfc_copy_expr (a); - result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b))); - break; - - default: - gcc_unreachable(); - } - - offset_a += stride_a; - a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); - - offset_b += stride_b; - b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); - } - - return result; -} - - -/* Build a result expression for transformational intrinsics, - depending on DIM. */ - -static gfc_expr * -transformational_result (gfc_expr *array, gfc_expr *dim, bt type, - int kind, locus* where) -{ - gfc_expr *result; - int i, nelem; - - if (!dim || array->rank == 1) - return gfc_get_constant_expr (type, kind, where); - - result = gfc_get_array_expr (type, kind, where); - result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); - result->rank = array->rank - 1; - - /* gfc_array_size() would count the number of elements in the constructor, - we have not built those yet. */ - nelem = 1; - for (i = 0; i < result->rank; ++i) - nelem *= mpz_get_ui (result->shape[i]); - - for (i = 0; i < nelem; ++i) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_get_constant_expr (type, kind, where), - NULL); - } - - return result; -} - - -typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); - -/* Wrapper function, implements 'op1 += 1'. Only called if MASK - of COUNT intrinsic is .TRUE.. - - Interface and implementation mimics arith functions as - gfc_add, gfc_multiply, etc. */ - -static gfc_expr * -gfc_count (gfc_expr *op1, gfc_expr *op2) -{ - gfc_expr *result; - - gcc_assert (op1->ts.type == BT_INTEGER); - gcc_assert (op2->ts.type == BT_LOGICAL); - gcc_assert (op2->value.logical); - - result = gfc_copy_expr (op1); - mpz_add_ui (result->value.integer, result->value.integer, 1); - - gfc_free_expr (op1); - gfc_free_expr (op2); - return result; -} - - -/* Transforms an ARRAY with operation OP, according to MASK, to a - scalar RESULT. E.g. called if - - REAL, PARAMETER :: array(n, m) = ... - REAL, PARAMETER :: s = SUM(array) - - where OP == gfc_add(). */ - -static gfc_expr * -simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, - transformational_op op) -{ - gfc_expr *a, *m; - gfc_constructor *array_ctor, *mask_ctor; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - return result; - - array_ctor = gfc_constructor_first (array->value.constructor); - mask_ctor = NULL; - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - - while (array_ctor) - { - a = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - - /* A constant MASK equals .TRUE. here and can be ignored. */ - if (mask_ctor) - { - m = mask_ctor->expr; - mask_ctor = gfc_constructor_next (mask_ctor); - if (!m->value.logical) - continue; - } - - result = op (result, gfc_copy_expr (a)); - if (!result) - return result; - } - - return result; -} - -/* Transforms an ARRAY with operation OP, according to MASK, to an - array RESULT. E.g. called if - - REAL, PARAMETER :: array(n, m) = ... - REAL, PARAMETER :: s(n) = PROD(array, DIM=1) - - where OP == gfc_multiply(). - The result might be post processed using post_op. */ - -static gfc_expr * -simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask, transformational_op op, - transformational_op post_op) -{ - mpz_t size; - int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; - gfc_expr **arrayvec, **resultvec, **base, **src, **dest; - gfc_constructor *array_ctor, *mask_ctor, *result_ctor; - - int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], - tmpstride[GFC_MAX_DIMENSIONS]; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - return result; - - /* Build an indexed table for array element expressions to minimize - linked-list traversal. Masked elements are set to NULL. */ - gfc_array_size (array, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - arrayvec = XCNEWVEC (gfc_expr*, arraysize); - - array_ctor = gfc_constructor_first (array->value.constructor); - mask_ctor = NULL; - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - - for (i = 0; i < arraysize; ++i) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - - if (mask_ctor) - { - if (!mask_ctor->expr->value.logical) - arrayvec[i] = NULL; - - mask_ctor = gfc_constructor_next (mask_ctor); - } - } - - /* Same for the result expression. */ - gfc_array_size (result, &size); - resultsize = mpz_get_ui (size); - mpz_clear (size); - - resultvec = XCNEWVEC (gfc_expr*, resultsize); - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - resultvec[i] = result_ctor->expr; - result_ctor = gfc_constructor_next (result_ctor); - } - - gfc_extract_int (dim, &dim_index); - dim_index -= 1; /* zero-base index */ - dim_extent = 0; - dim_stride = 0; - - for (i = 0, n = 0; i < array->rank; ++i) - { - count[i] = 0; - tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); - if (i == dim_index) - { - dim_extent = mpz_get_si (array->shape[i]); - dim_stride = tmpstride[i]; - continue; - } - - extent[n] = mpz_get_si (array->shape[i]); - sstride[n] = tmpstride[i]; - dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; - n += 1; - } - - done = resultsize <= 0; - base = arrayvec; - dest = resultvec; - while (!done) - { - for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) - if (*src) - *dest = op (*dest, gfc_copy_expr (*src)); - - if (post_op) - *dest = post_op (*dest, *dest); - - count[0]++; - base += sstride[0]; - dest += dstride[0]; - - n = 0; - while (!done && count[n] == extent[n]) - { - count[n] = 0; - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - - n++; - if (n < result->rank) - { - /* If the nested loop is unrolled GFC_MAX_DIMENSIONS - times, we'd warn for the last iteration, because the - array index will have already been incremented to the - array sizes, and we can't tell that this must make - the test against result->rank false, because ranks - must not exceed GFC_MAX_DIMENSIONS. */ - GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) - count[n]++; - base += sstride[n]; - dest += dstride[n]; - GCC_DIAGNOSTIC_POP - } - else - done = true; - } - } - - /* Place updated expression in result constructor. */ - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - result_ctor->expr = resultvec[i]; - result_ctor = gfc_constructor_next (result_ctor); - } - - free (arrayvec); - free (resultvec); - return result; -} - - -static gfc_expr * -simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, - int init_val, transformational_op op) -{ - gfc_expr *result; - bool size_zero; - - size_zero = gfc_is_size_zero_array (array); - - if (!(is_constant_array_expr (array) || size_zero) - || !gfc_is_constant_expr (dim)) - return NULL; - - if (mask - && !is_constant_array_expr (mask) - && mask->expr_type != EXPR_CONSTANT) - return NULL; - - result = transformational_result (array, dim, array->ts.type, - array->ts.kind, &array->where); - init_result_expr (result, init_val, array); - - if (size_zero) - return result; - - return !dim || array->rank == 1 ? - simplify_transformation_to_scalar (result, array, mask, op) : - simplify_transformation_to_array (result, array, dim, mask, op, NULL); -} - - -/********************** Simplification functions *****************************/ - -gfc_expr * -gfc_simplify_abs (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - switch (e->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); - mpz_abs (result->value.integer, e->value.integer); - return range_check (result, "IABS"); - - case BT_REAL: - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); - return range_check (result, "ABS"); - - case BT_COMPLEX: - gfc_set_model_kind (e->ts.kind); - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); - return range_check (result, "CABS"); - - default: - gfc_internal_error ("gfc_simplify_abs(): Bad type"); - } -} - - -static gfc_expr * -simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) -{ - gfc_expr *result; - int kind; - bool too_large = false; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); - if (kind == -1) - return &gfc_bad_expr; - - if (mpz_cmp_si (e->value.integer, 0) < 0) - { - gfc_error ("Argument of %s function at %L is negative", name, - &e->where); - return &gfc_bad_expr; - } - - if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0) - gfc_warning (OPT_Wsurprising, - "Argument of %s function at %L outside of range [0,127]", - name, &e->where); - - if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0) - too_large = true; - else if (kind == 4) - { - mpz_t t; - mpz_init_set_ui (t, 2); - mpz_pow_ui (t, t, 32); - mpz_sub_ui (t, t, 1); - if (mpz_cmp (e->value.integer, t) > 0) - too_large = true; - mpz_clear (t); - } - - if (too_large) - { - gfc_error ("Argument of %s function at %L is too large for the " - "collating sequence of kind %d", name, &e->where, kind); - return &gfc_bad_expr; - } - - result = gfc_get_character_expr (kind, &e->where, NULL, 1); - result->value.character.string[0] = mpz_get_ui (e->value.integer); - - return result; -} - - - -/* We use the processor's collating sequence, because all - systems that gfortran currently works on are ASCII. */ - -gfc_expr * -gfc_simplify_achar (gfc_expr *e, gfc_expr *k) -{ - return simplify_achar_char (e, k, "ACHAR", true); -} - - -gfc_expr * -gfc_simplify_acos (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ACOS at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_acos(): Bad type"); - } - - return range_check (result, "ACOS"); -} - -gfc_expr * -gfc_simplify_acosh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) < 0) - { - gfc_error ("Argument of ACOSH at %L must not be less than 1", - &x->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); - } - - return range_check (result, "ACOSH"); -} - -gfc_expr * -gfc_simplify_adjustl (gfc_expr *e) -{ - gfc_expr *result; - int count, i, len; - gfc_char_t ch; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - - for (count = 0, i = 0; i < len; ++i) - { - ch = e->value.character.string[i]; - if (ch != ' ') - break; - ++count; - } - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); - for (i = 0; i < len - count; ++i) - result->value.character.string[i] = e->value.character.string[count + i]; - - return result; -} - - -gfc_expr * -gfc_simplify_adjustr (gfc_expr *e) -{ - gfc_expr *result; - int count, i, len; - gfc_char_t ch; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - - for (count = 0, i = len - 1; i >= 0; --i) - { - ch = e->value.character.string[i]; - if (ch != ' ') - break; - ++count; - } - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); - for (i = 0; i < count; ++i) - result->value.character.string[i] = ' '; - - for (i = count; i < len; ++i) - result->value.character.string[i] = e->value.character.string[i - count]; - - return result; -} - - -gfc_expr * -gfc_simplify_aimag (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); - - return range_check (result, "AIMAG"); -} - - -gfc_expr * -gfc_simplify_aint (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *rtrunc, *result; - int kind; - - kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_real2real (rtrunc, kind); - - gfc_free_expr (rtrunc); - - return range_check (result, "AINT"); -} - - -gfc_expr * -gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) -{ - return simplify_transformation (mask, dim, NULL, true, gfc_and); -} - - -gfc_expr * -gfc_simplify_dint (gfc_expr *e) -{ - gfc_expr *rtrunc, *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_real2real (rtrunc, gfc_default_double_kind); - - gfc_free_expr (rtrunc); - - return range_check (result, "DINT"); -} - - -gfc_expr * -gfc_simplify_dreal (gfc_expr *e) -{ - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); - - return range_check (result, "DREAL"); -} - - -gfc_expr * -gfc_simplify_anint (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *result; - int kind; - - kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (e->ts.type, kind, &e->where); - mpfr_round (result->value.real, e->value.real); - - return range_check (result, "ANINT"); -} - - -gfc_expr * -gfc_simplify_and (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - - switch (x->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); - mpz_and (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "AND"); - - case BT_LOGICAL: - return gfc_get_logical_expr (kind, &x->where, - x->value.logical && y->value.logical); - - default: - gcc_unreachable (); - } -} - - -gfc_expr * -gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) -{ - return simplify_transformation (mask, dim, NULL, false, gfc_or); -} - - -gfc_expr * -gfc_simplify_dnint (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); - mpfr_round (result->value.real, e->value.real); - - return range_check (result, "DNINT"); -} - - -gfc_expr * -gfc_simplify_asin (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ASIN at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_asin(): Bad type"); - } - - return range_check (result, "ASIN"); -} - - -/* Convert radians to degrees, i.e., x * 180 / pi. */ - -static void -rad2deg (mpfr_t x) -{ - mpfr_t tmp; - - mpfr_init (tmp); - mpfr_const_pi (tmp, GFC_RND_MODE); - mpfr_mul_ui (x, x, 180, GFC_RND_MODE); - mpfr_div (x, x, tmp, GFC_RND_MODE); - mpfr_clear (tmp); -} - - -/* Simplify ACOSD(X) where the returned value has units of degree. */ - -gfc_expr * -gfc_simplify_acosd (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ACOSD at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); - rad2deg (result->value.real); - - return range_check (result, "ACOSD"); -} - - -/* Simplify asind (x) where the returned value has units of degree. */ - -gfc_expr * -gfc_simplify_asind (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_cmp_si (x->value.real, 1) > 0 - || mpfr_cmp_si (x->value.real, -1) < 0) - { - gfc_error ("Argument of ASIND at %L must be between -1 and 1", - &x->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); - rad2deg (result->value.real); - - return range_check (result, "ASIND"); -} - - -/* Simplify atand (x) where the returned value has units of degree. */ - -gfc_expr * -gfc_simplify_atand (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); - rad2deg (result->value.real); - - return range_check (result, "ATAND"); -} - - -gfc_expr * -gfc_simplify_asinh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); - } - - return range_check (result, "ASINH"); -} - - -gfc_expr * -gfc_simplify_atan (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_atan(): Bad type"); - } - - return range_check (result, "ATAN"); -} - - -gfc_expr * -gfc_simplify_atanh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (x->value.real, 1) >= 0 - || mpfr_cmp_si (x->value.real, -1) <= 0) - { - gfc_error ("Argument of ATANH at %L must be inside the range -1 " - "to 1", &x->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); - } - - return range_check (result, "ATANH"); -} - - -gfc_expr * -gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) - { - gfc_error ("If first argument of ATAN2 at %L is zero, then the " - "second argument must not be zero", &y->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "ATAN2"); -} - - -gfc_expr * -gfc_simplify_bessel_j0 (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "BESSEL_J0"); -} - - -gfc_expr * -gfc_simplify_bessel_j1 (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "BESSEL_J1"); -} - - -gfc_expr * -gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) -{ - gfc_expr *result; - long n; - - if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) - return NULL; - - n = mpz_get_si (order->value.integer); - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE); - - return range_check (result, "BESSEL_JN"); -} - - -/* Simplify transformational form of JN and YN. */ - -static gfc_expr * -gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, - bool jn) -{ - gfc_expr *result; - gfc_expr *e; - long n1, n2; - int i; - mpfr_t x2rev, last1, last2; - - if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT - || order2->expr_type != EXPR_CONSTANT) - return NULL; - - n1 = mpz_get_si (order1->value.integer); - n2 = mpz_get_si (order2->value.integer); - result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); - result->rank = 1; - result->shape = gfc_get_shape (1); - mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); - - if (n2 < n1) - return result; - - /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and - YN(N, 0.0) = -Inf. */ - - if (mpfr_cmp_ui (x->value.real, 0.0) == 0) - { - if (!jn && flag_range_check) - { - gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - if (jn && n1 == 0) - { - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); - gfc_constructor_append_expr (&result->value.constructor, e, - &x->where); - n1++; - } - - for (i = n1; i <= n2; i++) - { - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - if (jn) - mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); - else - mpfr_set_inf (e->value.real, -1); - gfc_constructor_append_expr (&result->value.constructor, e, - &x->where); - } - - return result; - } - - /* Use the faster but more verbose recurrence algorithm. Bessel functions - are stable for downward recursion and Neumann functions are stable - for upward recursion. It is - x2rev = 2.0/x, - J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), - Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). - Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ - - gfc_set_model_kind (x->ts.kind); - - /* Get first recursion anchor. */ - - mpfr_init (last1); - if (jn) - mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); - else - mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); - - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (e->value.real, last1, GFC_RND_MODE); - if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) - { - mpfr_clear (last1); - gfc_free_expr (e); - gfc_free_expr (result); - return &gfc_bad_expr; - } - gfc_constructor_append_expr (&result->value.constructor, e, &x->where); - - if (n1 == n2) - { - mpfr_clear (last1); - return result; - } - - /* Get second recursion anchor. */ - - mpfr_init (last2); - if (jn) - mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); - else - mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); - - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (e->value.real, last2, GFC_RND_MODE); - if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) - { - mpfr_clear (last1); - mpfr_clear (last2); - gfc_free_expr (e); - gfc_free_expr (result); - return &gfc_bad_expr; - } - if (jn) - gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); - else - gfc_constructor_append_expr (&result->value.constructor, e, &x->where); - - if (n1 + 1 == n2) - { - mpfr_clear (last1); - mpfr_clear (last2); - return result; - } - - /* Start actual recursion. */ - - mpfr_init (x2rev); - mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); - - for (i = 2; i <= n2-n1; i++) - { - e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - /* Special case: For YN, if the previous N gave -INF, set - also N+1 to -INF. */ - if (!jn && !flag_range_check && mpfr_inf_p (last2)) - { - mpfr_set_inf (e->value.real, -1); - gfc_constructor_append_expr (&result->value.constructor, e, - &x->where); - continue; - } - - mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), - GFC_RND_MODE); - mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); - mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); - - if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) - { - /* Range_check frees "e" in that case. */ - e = NULL; - goto error; - } - - if (jn) - gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, - -i-1); - else - gfc_constructor_append_expr (&result->value.constructor, e, &x->where); - - mpfr_set (last1, last2, GFC_RND_MODE); - mpfr_set (last2, e->value.real, GFC_RND_MODE); - } - - mpfr_clear (last1); - mpfr_clear (last2); - mpfr_clear (x2rev); - return result; - -error: - mpfr_clear (last1); - mpfr_clear (last2); - mpfr_clear (x2rev); - gfc_free_expr (e); - gfc_free_expr (result); - return &gfc_bad_expr; -} - - -gfc_expr * -gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) -{ - return gfc_simplify_bessel_n2 (order1, order2, x, true); -} - - -gfc_expr * -gfc_simplify_bessel_y0 (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "BESSEL_Y0"); -} - - -gfc_expr * -gfc_simplify_bessel_y1 (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "BESSEL_Y1"); -} - - -gfc_expr * -gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) -{ - gfc_expr *result; - long n; - - if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) - return NULL; - - n = mpz_get_si (order->value.integer); - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); - - return range_check (result, "BESSEL_YN"); -} - - -gfc_expr * -gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) -{ - return gfc_simplify_bessel_n2 (order1, order2, x, false); -} - - -gfc_expr * -gfc_simplify_bit_size (gfc_expr *e) -{ - int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - return gfc_get_int_expr (e->ts.kind, &e->where, - gfc_integer_kinds[i].bit_size); -} - - -gfc_expr * -gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) -{ - int b; - - if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) - return NULL; - - if (gfc_extract_int (bit, &b) || b < 0) - return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); - - return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, - mpz_tstbit (e->value.integer, b)); -} - - -static int -compare_bitwise (gfc_expr *i, gfc_expr *j) -{ - mpz_t x, y; - int k, res; - - gcc_assert (i->ts.type == BT_INTEGER); - gcc_assert (j->ts.type == BT_INTEGER); - - mpz_init_set (x, i->value.integer); - k = gfc_validate_kind (i->ts.type, i->ts.kind, false); - convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); - - mpz_init_set (y, j->value.integer); - k = gfc_validate_kind (j->ts.type, j->ts.kind, false); - convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); - - res = mpz_cmp (x, y); - mpz_clear (x); - mpz_clear (y); - return res; -} - - -gfc_expr * -gfc_simplify_bge (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) >= 0); -} - - -gfc_expr * -gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) > 0); -} - - -gfc_expr * -gfc_simplify_ble (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) <= 0); -} - - -gfc_expr * -gfc_simplify_blt (gfc_expr *i, gfc_expr *j) -{ - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, - compare_bitwise (i, j) < 0); -} - - -gfc_expr * -gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *ceil, *result; - int kind; - - kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - ceil = gfc_copy_expr (e); - mpfr_ceil (ceil->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); - gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); - - gfc_free_expr (ceil); - - return range_check (result, "CEILING"); -} - - -gfc_expr * -gfc_simplify_char (gfc_expr *e, gfc_expr *k) -{ - return simplify_achar_char (e, k, "CHAR", false); -} - - -/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ - -static gfc_expr * -simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT - || (y != NULL && y->expr_type != EXPR_CONSTANT)) - return NULL; - - result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); - - switch (x->ts.type) - { - case BT_INTEGER: - mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); - break; - - case BT_REAL: - mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); - } - - if (!y) - return range_check (result, name); - - switch (y->ts.type) - { - case BT_INTEGER: - mpfr_set_z (mpc_imagref (result->value.complex), - y->value.integer, GFC_RND_MODE); - break; - - case BT_REAL: - mpfr_set (mpc_imagref (result->value.complex), - y->value.real, GFC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); - } - - return range_check (result, name); -} - - -gfc_expr * -gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) -{ - int kind; - - kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); - if (kind == -1) - return &gfc_bad_expr; - - return simplify_cmplx ("CMPLX", x, y, kind); -} - - -gfc_expr * -gfc_simplify_complex (gfc_expr *x, gfc_expr *y) -{ - int kind; - - if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) - kind = gfc_default_complex_kind; - else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) - kind = x->ts.kind; - else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) - kind = y->ts.kind; - else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) - kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; - else - gcc_unreachable (); - - return simplify_cmplx ("COMPLEX", x, y, kind); -} - - -gfc_expr * -gfc_simplify_conjg (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_copy_expr (e); - mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); - - return range_check (result, "CONJG"); -} - - -/* Simplify atan2d (x) where the unit is degree. */ - -gfc_expr * -gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) - { - gfc_error ("If first argument of ATAN2D at %L is zero, then the " - "second argument must not be zero", &y->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); - rad2deg (result->value.real); - - return range_check (result, "ATAN2D"); -} - - -gfc_expr * -gfc_simplify_cos (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); - mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_cos(): Bad type"); - } - - return range_check (result, "COS"); -} - - -static void -deg2rad (mpfr_t x) -{ - mpfr_t d2r; - - mpfr_init (d2r); - mpfr_const_pi (d2r, GFC_RND_MODE); - mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE); - mpfr_mul (x, x, d2r, GFC_RND_MODE); - mpfr_clear (d2r); -} - - -/* Simplification routines for SIND, COSD, TAND. */ -#include "trigd_fe.inc" - - -/* Simplify COSD(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_cosd (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - simplify_cosd (result->value.real); - - return range_check (result, "COSD"); -} - - -/* Simplify SIND(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_sind (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - simplify_sind (result->value.real); - - return range_check (result, "SIND"); -} - - -/* Simplify TAND(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_tand (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - simplify_tand (result->value.real); - - return range_check (result, "TAND"); -} - - -/* Simplify COTAND(X) where X has the unit of degree. */ - -gfc_expr * -gfc_simplify_cotand (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - /* Implement COTAND = -TAND(x+90). - TAND offers correct exact values for multiples of 30 degrees. - This implementation is also compatible with the behavior of some legacy - compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */ - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE); - simplify_tand (result->value.real); - mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); - - return range_check (result, "COTAND"); -} - - -gfc_expr * -gfc_simplify_cosh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "COSH"); -} - - -gfc_expr * -gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) -{ - gfc_expr *result; - bool size_zero; - - size_zero = gfc_is_size_zero_array (mask); - - if (!(is_constant_array_expr (mask) || size_zero) - || !gfc_is_constant_expr (dim) - || !gfc_is_constant_expr (kind)) - return NULL; - - result = transformational_result (mask, dim, - BT_INTEGER, - get_kind (BT_INTEGER, kind, "COUNT", - gfc_default_integer_kind), - &mask->where); - - init_result_expr (result, 0, NULL); - - if (size_zero) - return result; - - /* Passing MASK twice, once as data array, once as mask. - Whenever gfc_count is called, '1' is added to the result. */ - return !dim || mask->rank == 1 ? - simplify_transformation_to_scalar (result, mask, mask, gfc_count) : - simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); -} - -/* Simplification routine for cshift. This works by copying the array - expressions into a one-dimensional array, shuffling the values into another - one-dimensional array and creating the new array expression from this. The - shuffling part is basically taken from the library routine. */ - -gfc_expr * -gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) -{ - gfc_expr *result; - int which; - gfc_expr **arrayvec, **resultvec; - gfc_expr **rptr, **sptr; - mpz_t size; - size_t arraysize, shiftsize, i; - gfc_constructor *array_ctor, *shift_ctor; - ssize_t *shiftvec, *hptr; - ssize_t shift_val, len; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - hs_ex[GFC_MAX_DIMENSIONS + 1], - hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS], - a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS], - h_extent[GFC_MAX_DIMENSIONS], - ss_ex[GFC_MAX_DIMENSIONS + 1]; - ssize_t rsoffset; - int d, n; - bool continue_loop; - gfc_expr **src, **dest; - - if (!is_constant_array_expr (array)) - return NULL; - - if (shift->rank > 0) - gfc_simplify_expr (shift, 1); - - if (!gfc_is_constant_expr (shift)) - return NULL; - - /* Make dim zero-based. */ - if (dim) - { - if (!gfc_is_constant_expr (dim)) - return NULL; - which = mpz_get_si (dim->value.integer) - 1; - } - else - which = 0; - - if (array->shape == NULL) - return NULL; - - gfc_array_size (array, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); - result->shape = gfc_copy_shape (array->shape, array->rank); - result->rank = array->rank; - result->ts.u.derived = array->ts.u.derived; - - if (arraysize == 0) - return result; - - arrayvec = XCNEWVEC (gfc_expr *, arraysize); - array_ctor = gfc_constructor_first (array->value.constructor); - for (i = 0; i < arraysize; i++) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - } - - resultvec = XCNEWVEC (gfc_expr *, arraysize); - - extent[0] = 1; - count[0] = 0; - - for (d=0; d < array->rank; d++) - { - a_extent[d] = mpz_get_si (array->shape[d]); - a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; - } - - if (shift->rank > 0) - { - gfc_array_size (shift, &size); - shiftsize = mpz_get_ui (size); - mpz_clear (size); - shiftvec = XCNEWVEC (ssize_t, shiftsize); - shift_ctor = gfc_constructor_first (shift->value.constructor); - for (d = 0; d < shift->rank; d++) - { - h_extent[d] = mpz_get_si (shift->shape[d]); - hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1]; - } - } - else - shiftvec = NULL; - - /* Shut up compiler */ - len = 1; - rsoffset = 1; - - n = 0; - for (d=0; d < array->rank; d++) - { - if (d == which) - { - rsoffset = a_stride[d]; - len = a_extent[d]; - } - else - { - count[n] = 0; - extent[n] = a_extent[d]; - sstride[n] = a_stride[d]; - ss_ex[n] = sstride[n] * extent[n]; - if (shiftvec) - hs_ex[n] = hstride[n] * extent[n]; - n++; - } - } - ss_ex[n] = 0; - hs_ex[n] = 0; - - if (shiftvec) - { - for (i = 0; i < shiftsize; i++) - { - ssize_t val; - val = mpz_get_si (shift_ctor->expr->value.integer); - val = val % len; - if (val < 0) - val += len; - shiftvec[i] = val; - shift_ctor = gfc_constructor_next (shift_ctor); - } - shift_val = 0; - } - else - { - shift_val = mpz_get_si (shift->value.integer); - shift_val = shift_val % len; - if (shift_val < 0) - shift_val += len; - } - - continue_loop = true; - d = array->rank; - rptr = resultvec; - sptr = arrayvec; - hptr = shiftvec; - - while (continue_loop) - { - ssize_t sh; - if (shiftvec) - sh = *hptr; - else - sh = shift_val; - - src = &sptr[sh * rsoffset]; - dest = rptr; - for (n = 0; n < len - sh; n++) - { - *dest = *src; - dest += rsoffset; - src += rsoffset; - } - src = sptr; - for ( n = 0; n < sh; n++) - { - *dest = *src; - dest += rsoffset; - src += rsoffset; - } - rptr += sstride[0]; - sptr += sstride[0]; - if (shiftvec) - hptr += hstride[0]; - count[0]++; - n = 0; - while (count[n] == extent[n]) - { - count[n] = 0; - rptr -= ss_ex[n]; - sptr -= ss_ex[n]; - if (shiftvec) - hptr -= hs_ex[n]; - n++; - if (n >= d - 1) - { - continue_loop = false; - break; - } - else - { - count[n]++; - rptr += sstride[n]; - sptr += sstride[n]; - if (shiftvec) - hptr += hstride[n]; - } - } - } - - for (i = 0; i < arraysize; i++) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (resultvec[i]), - NULL); - } - return result; -} - - -gfc_expr * -gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) -{ - return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); -} - - -gfc_expr * -gfc_simplify_dble (gfc_expr *e) -{ - gfc_expr *result = NULL; - int tmp1, tmp2; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - if (result == &gfc_bad_expr) - return &gfc_bad_expr; - - return range_check (result, "DBLE"); -} - - -gfc_expr * -gfc_simplify_digits (gfc_expr *x) -{ - int i, digits; - - i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - switch (x->ts.type) - { - case BT_INTEGER: - digits = gfc_integer_kinds[i].digits; - break; - - case BT_REAL: - case BT_COMPLEX: - digits = gfc_real_kinds[i].digits; - break; - - default: - gcc_unreachable (); - } - - return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); -} - - -gfc_expr * -gfc_simplify_dim (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - result = gfc_get_constant_expr (x->ts.type, kind, &x->where); - - switch (x->ts.type) - { - case BT_INTEGER: - if (mpz_cmp (x->value.integer, y->value.integer) > 0) - mpz_sub (result->value.integer, x->value.integer, y->value.integer); - else - mpz_set_ui (result->value.integer, 0); - - break; - - case BT_REAL: - if (mpfr_cmp (x->value.real, y->value.real) > 0) - mpfr_sub (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); - else - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - - break; - - default: - gfc_internal_error ("gfc_simplify_dim(): Bad type"); - } - - return range_check (result, "DIM"); -} - - -gfc_expr* -gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) -{ - /* If vector_a is a zero-sized array, the result is 0 for INTEGER, - REAL, and COMPLEX types and .false. for LOGICAL. */ - if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0) - { - if (vector_a->ts.type == BT_LOGICAL) - return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); - else - return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - } - - if (!is_constant_array_expr (vector_a) - || !is_constant_array_expr (vector_b)) - return NULL; - - return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true); -} - - -gfc_expr * -gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *a1, *a2, *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - a1 = gfc_real2real (x, gfc_default_double_kind); - a2 = gfc_real2real (y, gfc_default_double_kind); - - result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); - mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE); - - gfc_free_expr (a2); - gfc_free_expr (a1); - - return range_check (result, "DPROD"); -} - - -static gfc_expr * -simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, - bool right) -{ - gfc_expr *result; - int i, k, size, shift; - - if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT - || shiftarg->expr_type != EXPR_CONSTANT) - return NULL; - - k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); - size = gfc_integer_kinds[k].bit_size; - - gfc_extract_int (shiftarg, &shift); - - /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ - if (right) - shift = size - shift; - - result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); - mpz_set_ui (result->value.integer, 0); - - for (i = 0; i < shift; i++) - if (mpz_tstbit (arg2->value.integer, size - shift + i)) - mpz_setbit (result->value.integer, i); - - for (i = 0; i < size - shift; i++) - if (mpz_tstbit (arg1->value.integer, i)) - mpz_setbit (result->value.integer, shift + i); - - /* Convert to a signed value. */ - gfc_convert_mpz_to_signed (result->value.integer, size); - - return result; -} - - -gfc_expr * -gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) -{ - return simplify_dshift (arg1, arg2, shiftarg, true); -} - - -gfc_expr * -gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) -{ - return simplify_dshift (arg1, arg2, shiftarg, false); -} - - -gfc_expr * -gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, - gfc_expr *dim) -{ - bool temp_boundary; - gfc_expr *bnd; - gfc_expr *result; - int which; - gfc_expr **arrayvec, **resultvec; - gfc_expr **rptr, **sptr; - mpz_t size; - size_t arraysize, i; - gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor; - ssize_t shift_val, len; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS], - a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1]; - ssize_t rsoffset; - int d, n; - bool continue_loop; - gfc_expr **src, **dest; - size_t s_len; - - if (!is_constant_array_expr (array)) - return NULL; - - if (shift->rank > 0) - gfc_simplify_expr (shift, 1); - - if (!gfc_is_constant_expr (shift)) - return NULL; - - if (boundary) - { - if (boundary->rank > 0) - gfc_simplify_expr (boundary, 1); - - if (!gfc_is_constant_expr (boundary)) - return NULL; - } - - if (dim) - { - if (!gfc_is_constant_expr (dim)) - return NULL; - which = mpz_get_si (dim->value.integer) - 1; - } - else - which = 0; - - s_len = 0; - if (boundary == NULL) - { - temp_boundary = true; - switch (array->ts.type) - { - - case BT_INTEGER: - bnd = gfc_get_int_expr (array->ts.kind, NULL, 0); - break; - - case BT_LOGICAL: - bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0); - break; - - case BT_REAL: - bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); - mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE); - break; - - case BT_COMPLEX: - bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); - mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE); - break; - - case BT_CHARACTER: - s_len = mpz_get_ui (array->ts.u.cl->length->value.integer); - bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len); - break; - - default: - gcc_unreachable(); - - } - } - else - { - temp_boundary = false; - bnd = boundary; - } - - gfc_array_size (array, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); - result->shape = gfc_copy_shape (array->shape, array->rank); - result->rank = array->rank; - result->ts = array->ts; - - if (arraysize == 0) - goto final; - - arrayvec = XCNEWVEC (gfc_expr *, arraysize); - array_ctor = gfc_constructor_first (array->value.constructor); - for (i = 0; i < arraysize; i++) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - } - - resultvec = XCNEWVEC (gfc_expr *, arraysize); - - extent[0] = 1; - count[0] = 0; - - for (d=0; d < array->rank; d++) - { - a_extent[d] = mpz_get_si (array->shape[d]); - a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; - } - - if (shift->rank > 0) - { - shift_ctor = gfc_constructor_first (shift->value.constructor); - shift_val = 0; - } - else - { - shift_ctor = NULL; - shift_val = mpz_get_si (shift->value.integer); - } - - if (bnd->rank > 0) - bnd_ctor = gfc_constructor_first (bnd->value.constructor); - else - bnd_ctor = NULL; - - /* Shut up compiler */ - len = 1; - rsoffset = 1; - - n = 0; - for (d=0; d < array->rank; d++) - { - if (d == which) - { - rsoffset = a_stride[d]; - len = a_extent[d]; - } - else - { - count[n] = 0; - extent[n] = a_extent[d]; - sstride[n] = a_stride[d]; - ss_ex[n] = sstride[n] * extent[n]; - n++; - } - } - ss_ex[n] = 0; - - continue_loop = true; - d = array->rank; - rptr = resultvec; - sptr = arrayvec; - - while (continue_loop) - { - ssize_t sh, delta; - - if (shift_ctor) - sh = mpz_get_si (shift_ctor->expr->value.integer); - else - sh = shift_val; - - if (( sh >= 0 ? sh : -sh ) > len) - { - delta = len; - sh = len; - } - else - delta = (sh >= 0) ? sh: -sh; - - if (sh > 0) - { - src = &sptr[delta * rsoffset]; - dest = rptr; - } - else - { - src = sptr; - dest = &rptr[delta * rsoffset]; - } - - for (n = 0; n < len - delta; n++) - { - *dest = *src; - dest += rsoffset; - src += rsoffset; - } - - if (sh < 0) - dest = rptr; - - n = delta; - - if (bnd_ctor) - { - while (n--) - { - *dest = gfc_copy_expr (bnd_ctor->expr); - dest += rsoffset; - } - } - else - { - while (n--) - { - *dest = gfc_copy_expr (bnd); - dest += rsoffset; - } - } - rptr += sstride[0]; - sptr += sstride[0]; - if (shift_ctor) - shift_ctor = gfc_constructor_next (shift_ctor); - - if (bnd_ctor) - bnd_ctor = gfc_constructor_next (bnd_ctor); - - count[0]++; - n = 0; - while (count[n] == extent[n]) - { - count[n] = 0; - rptr -= ss_ex[n]; - sptr -= ss_ex[n]; - n++; - if (n >= d - 1) - { - continue_loop = false; - break; - } - else - { - count[n]++; - rptr += sstride[n]; - sptr += sstride[n]; - } - } - } - - for (i = 0; i < arraysize; i++) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (resultvec[i]), - NULL); - } - - final: - if (temp_boundary) - gfc_free_expr (bnd); - - return result; -} - -gfc_expr * -gfc_simplify_erf (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "ERF"); -} - - -gfc_expr * -gfc_simplify_erfc (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "ERFC"); -} - - -/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */ - -#define MAX_ITER 200 -#define ARG_LIMIT 12 - -/* Calculate ERFC_SCALED directly by its definition: - - ERFC_SCALED(x) = ERFC(x) * EXP(X**2) - - using a large precision for intermediate results. This is used for all - but large values of the argument. */ -static void -fullprec_erfc_scaled (mpfr_t res, mpfr_t arg) -{ - mpfr_prec_t prec; - mpfr_t a, b; - - prec = mpfr_get_default_prec (); - mpfr_set_default_prec (10 * prec); - - mpfr_init (a); - mpfr_init (b); - - mpfr_set (a, arg, GFC_RND_MODE); - mpfr_sqr (b, a, GFC_RND_MODE); - mpfr_exp (b, b, GFC_RND_MODE); - mpfr_erfc (a, a, GFC_RND_MODE); - mpfr_mul (a, a, b, GFC_RND_MODE); - - mpfr_set (res, a, GFC_RND_MODE); - mpfr_set_default_prec (prec); - - mpfr_clear (a); - mpfr_clear (b); -} - -/* Calculate ERFC_SCALED using a power series expansion in 1/arg: - - ERFC_SCALED(x) = 1 / (x * sqrt(pi)) - * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1)) - / (2 * x**2)**n) - - This is used for large values of the argument. Intermediate calculations - are performed with twice the precision. We don't do a fixed number of - iterations of the sum, but stop when it has converged to the required - precision. */ -static void -asympt_erfc_scaled (mpfr_t res, mpfr_t arg) -{ - mpfr_t sum, x, u, v, w, oldsum, sumtrunc; - mpz_t num; - mpfr_prec_t prec; - unsigned i; - - prec = mpfr_get_default_prec (); - mpfr_set_default_prec (2 * prec); - - mpfr_init (sum); - mpfr_init (x); - mpfr_init (u); - mpfr_init (v); - mpfr_init (w); - mpz_init (num); - - mpfr_init (oldsum); - mpfr_init (sumtrunc); - mpfr_set_prec (oldsum, prec); - mpfr_set_prec (sumtrunc, prec); - - mpfr_set (x, arg, GFC_RND_MODE); - mpfr_set_ui (sum, 1, GFC_RND_MODE); - mpz_set_ui (num, 1); - - mpfr_set (u, x, GFC_RND_MODE); - mpfr_sqr (u, u, GFC_RND_MODE); - mpfr_mul_ui (u, u, 2, GFC_RND_MODE); - mpfr_pow_si (u, u, -1, GFC_RND_MODE); - - for (i = 1; i < MAX_ITER; i++) - { - mpfr_set (oldsum, sum, GFC_RND_MODE); - - mpz_mul_ui (num, num, 2 * i - 1); - mpz_neg (num, num); - - mpfr_set (w, u, GFC_RND_MODE); - mpfr_pow_ui (w, w, i, GFC_RND_MODE); - - mpfr_set_z (v, num, GFC_RND_MODE); - mpfr_mul (v, v, w, GFC_RND_MODE); - - mpfr_add (sum, sum, v, GFC_RND_MODE); - - mpfr_set (sumtrunc, sum, GFC_RND_MODE); - if (mpfr_cmp (sumtrunc, oldsum) == 0) - break; - } - - /* We should have converged by now; otherwise, ARG_LIMIT is probably - set too low. */ - gcc_assert (i < MAX_ITER); - - /* Divide by x * sqrt(Pi). */ - mpfr_const_pi (u, GFC_RND_MODE); - mpfr_sqrt (u, u, GFC_RND_MODE); - mpfr_mul (u, u, x, GFC_RND_MODE); - mpfr_div (sum, sum, u, GFC_RND_MODE); - - mpfr_set (res, sum, GFC_RND_MODE); - mpfr_set_default_prec (prec); - - mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL); - mpz_clear (num); -} - - -gfc_expr * -gfc_simplify_erfc_scaled (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) - asympt_erfc_scaled (result->value.real, x->value.real); - else - fullprec_erfc_scaled (result->value.real, x->value.real); - - return range_check (result, "ERFC_SCALED"); -} - -#undef MAX_ITER -#undef ARG_LIMIT - - -gfc_expr * -gfc_simplify_epsilon (gfc_expr *e) -{ - gfc_expr *result; - int i; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); - - return range_check (result, "EPSILON"); -} - - -gfc_expr * -gfc_simplify_exp (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (x->ts.kind); - mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_exp(): Bad type"); - } - - return range_check (result, "EXP"); -} - - -gfc_expr * -gfc_simplify_exponent (gfc_expr *x) -{ - long int val; - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &x->where); - - /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */ - if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real)) - { - int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); - mpz_set (result->value.integer, gfc_integer_kinds[i].huge); - return result; - } - - /* EXPONENT(+/- 0.0) = 0 */ - if (mpfr_zero_p (x->value.real)) - { - mpz_set_ui (result->value.integer, 0); - return result; - } - - gfc_set_model (x->value.real); - - val = (long int) mpfr_get_exp (x->value.real); - mpz_set_si (result->value.integer, val); - - return range_check (result, "EXPONENT"); -} - - -gfc_expr * -gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED, - gfc_expr *kind) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_current_locus = *gfc_current_intrinsic_where; - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - if (flag_coarray == GFC_FCOARRAY_SINGLE) - { - gfc_expr *result; - int actual_kind; - if (kind) - gfc_extract_int (kind, &actual_kind); - else - actual_kind = gfc_default_integer_kind; - - result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus); - result->rank = 1; - return result; - } - - /* For fcoarray = lib no simplification is possible, because it is not known - what images failed or are stopped at compile time. */ - return NULL; -} - - -gfc_expr * -gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_current_locus = *gfc_current_intrinsic_where; - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - if (flag_coarray == GFC_FCOARRAY_SINGLE) - { - gfc_expr *result; - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - result->rank = 0; - return result; - } - - /* For fcoarray = lib no simplification is possible, because it is not known - what images failed or are stopped at compile time. */ - return NULL; -} - - -gfc_expr * -gfc_simplify_float (gfc_expr *a) -{ - gfc_expr *result; - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_int2real (a, gfc_default_real_kind); - - return range_check (result, "FLOAT"); -} - - -static bool -is_last_ref_vtab (gfc_expr *e) -{ - gfc_ref *ref; - gfc_component *comp = NULL; - - if (e->expr_type != EXPR_VARIABLE) - return false; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - comp = ref->u.c.component; - - if (!e->ref || !comp) - return e->symtree->n.sym->attr.vtab; - - if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) - return true; - - return false; -} - - -gfc_expr * -gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) -{ - /* Avoid simplification of resolved symbols. */ - if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) - return NULL; - - if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_type_is_extension_of (mold->ts.u.derived, - a->ts.u.derived)); - - if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold)) - return NULL; - - /* Return .false. if the dynamic type can never be an extension. */ - if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS - && !gfc_type_is_extension_of - (mold->ts.u.derived->components->ts.u.derived, - a->ts.u.derived->components->ts.u.derived) - && !gfc_type_is_extension_of - (a->ts.u.derived->components->ts.u.derived, - mold->ts.u.derived->components->ts.u.derived)) - || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS - && !gfc_type_is_extension_of - (mold->ts.u.derived->components->ts.u.derived, - a->ts.u.derived)) - || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED - && !gfc_type_is_extension_of - (mold->ts.u.derived, - a->ts.u.derived->components->ts.u.derived) - && !gfc_type_is_extension_of - (a->ts.u.derived->components->ts.u.derived, - mold->ts.u.derived))) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); - - /* Return .true. if the dynamic type is guaranteed to be an extension. */ - if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED - && gfc_type_is_extension_of (mold->ts.u.derived, - a->ts.u.derived->components->ts.u.derived)) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); - - return NULL; -} - - -gfc_expr * -gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) -{ - /* Avoid simplification of resolved symbols. */ - if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) - return NULL; - - /* Return .false. if the dynamic type can never be the - same. */ - if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok) - || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok)) - && !gfc_type_compatible (&a->ts, &b->ts) - && !gfc_type_compatible (&b->ts, &a->ts)) - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); - - if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_derived_types (a->ts.u.derived, - b->ts.u.derived)); -} - - -gfc_expr * -gfc_simplify_floor (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *result; - mpfr_t floor; - int kind; - - kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); - if (kind == -1) - gfc_internal_error ("gfc_simplify_floor(): Bad kind"); - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - mpfr_init2 (floor, mpfr_get_prec (e->value.real)); - mpfr_floor (floor, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); - gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); - - mpfr_clear (floor); - - return range_check (result, "FLOOR"); -} - - -gfc_expr * -gfc_simplify_fraction (gfc_expr *x) -{ - gfc_expr *result; - mpfr_exp_t e; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - /* FRACTION(inf) = NaN. */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - return result; - } - - /* mpfr_frexp() correctly handles zeros and NaNs. */ - mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "FRACTION"); -} - - -gfc_expr * -gfc_simplify_gamma (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "GAMMA"); -} - - -gfc_expr * -gfc_simplify_huge (gfc_expr *e) -{ - gfc_expr *result; - int i; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - - switch (e->ts.type) - { - case BT_INTEGER: - mpz_set (result->value.integer, gfc_integer_kinds[i].huge); - break; - - case BT_REAL: - mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return result; -} - - -gfc_expr * -gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); - return range_check (result, "HYPOT"); -} - - -/* We use the processor's collating sequence, because all - systems that gfortran currently works on are ASCII. */ - -gfc_expr * -gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - gfc_char_t index; - int k; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (e->value.character.length != 1) - { - gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); - return &gfc_bad_expr; - } - - index = e->value.character.string[0]; - - if (warn_surprising && index > 127) - gfc_warning (OPT_Wsurprising, - "Argument of IACHAR function at %L outside of range 0..127", - &e->where); - - k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_int_expr (k, &e->where, index); - - return range_check (result, "IACHAR"); -} - - -static gfc_expr * -do_bit_and (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_INTEGER - && result->expr_type == EXPR_CONSTANT); - - mpz_and (result->value.integer, result->value.integer, e->value.integer); - return result; -} - - -gfc_expr * -gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, -1, do_bit_and); -} - - -static gfc_expr * -do_bit_ior (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_INTEGER - && result->expr_type == EXPR_CONSTANT); - - mpz_ior (result->value.integer, result->value.integer, e->value.integer); - return result; -} - - -gfc_expr * -gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 0, do_bit_ior); -} - - -gfc_expr * -gfc_simplify_iand (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); - mpz_and (result->value.integer, x->value.integer, y->value.integer); - - return range_check (result, "IAND"); -} - - -gfc_expr * -gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int k, pos; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (y, &pos); - - k = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - result = gfc_copy_expr (x); - - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); - - mpz_clrbit (result->value.integer, pos); - - gfc_convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) -{ - gfc_expr *result; - int pos, len; - int i, k, bitsize; - int *bits; - - if (x->expr_type != EXPR_CONSTANT - || y->expr_type != EXPR_CONSTANT - || z->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (y, &pos); - gfc_extract_int (z, &len); - - k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); - - bitsize = gfc_integer_kinds[k].bit_size; - - if (pos + len > bitsize) - { - gfc_error ("Sum of second and third arguments of IBITS exceeds " - "bit size at %L", &y->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); - - bits = XCNEWVEC (int, bitsize); - - for (i = 0; i < bitsize; i++) - bits[i] = 0; - - for (i = 0; i < len; i++) - bits[i] = mpz_tstbit (x->value.integer, i + pos); - - for (i = 0; i < bitsize; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i); - else if (bits[i] == 1) - mpz_setbit (result->value.integer, i); - else - gfc_internal_error ("IBITS: Bad bit"); - } - - free (bits); - - gfc_convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int k, pos; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (y, &pos); - - k = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - result = gfc_copy_expr (x); - - convert_mpz_to_unsigned (result->value.integer, - gfc_integer_kinds[k].bit_size); - - mpz_setbit (result->value.integer, pos); - - gfc_convert_mpz_to_signed (result->value.integer, - gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - gfc_char_t index; - int k; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (e->value.character.length != 1) - { - gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); - return &gfc_bad_expr; - } - - index = e->value.character.string[0]; - - k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_int_expr (k, &e->where, index); - - return range_check (result, "ICHAR"); -} - - -gfc_expr * -gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); - mpz_xor (result->value.integer, x->value.integer, y->value.integer); - - return range_check (result, "IEOR"); -} - - -gfc_expr * -gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) -{ - gfc_expr *result; - int back, len, lensub; - int i, j, k, count, index = 0, start; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT - || ( b != NULL && b->expr_type != EXPR_CONSTANT)) - return NULL; - - if (b != NULL && b->value.logical != 0) - back = 1; - else - back = 0; - - k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); - - len = x->value.character.length; - lensub = y->value.character.length; - - if (len < lensub) - { - mpz_set_si (result->value.integer, 0); - return result; - } - - if (back == 0) - { - if (lensub == 0) - { - mpz_set_si (result->value.integer, 1); - return result; - } - else if (lensub == 1) - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[i]) - { - index = i + 1; - goto done; - } - } - } - } - else - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[i]) - { - start = i; - count = 0; - - for (k = 0; k < lensub; k++) - { - if (y->value.character.string[k] - == x->value.character.string[k + start]) - count++; - } - - if (count == lensub) - { - index = start + 1; - goto done; - } - } - } - } - } - - } - else - { - if (lensub == 0) - { - mpz_set_si (result->value.integer, len + 1); - return result; - } - else if (lensub == 1) - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[len - i]) - { - index = len - i + 1; - goto done; - } - } - } - } - else - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[len - i]) - { - start = len - i; - if (start <= len - lensub) - { - count = 0; - for (k = 0; k < lensub; k++) - if (y->value.character.string[k] - == x->value.character.string[k + start]) - count++; - - if (count == lensub) - { - index = start + 1; - goto done; - } - } - else - { - continue; - } - } - } - } - } - } - -done: - mpz_set_si (result->value.integer, index); - return range_check (result, "INDEX"); -} - - -static gfc_expr * -simplify_intconv (gfc_expr *e, int kind, const char *name) -{ - gfc_expr *result = NULL; - int tmp1, tmp2; - - /* Convert BOZ to integer, and return without range checking. */ - if (e->ts.type == BT_BOZ) - { - if (!gfc_boz2int (e, kind)) - return NULL; - result = gfc_copy_expr (e); - return result; - } - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_convert_constant (e, BT_INTEGER, kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - if (result == &gfc_bad_expr) - return &gfc_bad_expr; - - return range_check (result, name); -} - - -gfc_expr * -gfc_simplify_int (gfc_expr *e, gfc_expr *k) -{ - int kind; - - kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - - return simplify_intconv (e, kind, "INT"); -} - -gfc_expr * -gfc_simplify_int2 (gfc_expr *e) -{ - return simplify_intconv (e, 2, "INT2"); -} - - -gfc_expr * -gfc_simplify_int8 (gfc_expr *e) -{ - return simplify_intconv (e, 8, "INT8"); -} - - -gfc_expr * -gfc_simplify_long (gfc_expr *e) -{ - return simplify_intconv (e, 4, "LONG"); -} - - -gfc_expr * -gfc_simplify_ifix (gfc_expr *e) -{ - gfc_expr *rtrunc, *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &e->where); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); - - gfc_free_expr (rtrunc); - - return range_check (result, "IFIX"); -} - - -gfc_expr * -gfc_simplify_idint (gfc_expr *e) -{ - gfc_expr *rtrunc, *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - rtrunc = gfc_copy_expr (e); - mpfr_trunc (rtrunc->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &e->where); - gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); - - gfc_free_expr (rtrunc); - - return range_check (result, "IDINT"); -} - - -gfc_expr * -gfc_simplify_ior (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); - mpz_ior (result->value.integer, x->value.integer, y->value.integer); - - return range_check (result, "IOR"); -} - - -static gfc_expr * -do_bit_xor (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_INTEGER - && result->expr_type == EXPR_CONSTANT); - - mpz_xor (result->value.integer, result->value.integer, e->value.integer); - return result; -} - - -gfc_expr * -gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 0, do_bit_xor); -} - - -gfc_expr * -gfc_simplify_is_iostat_end (gfc_expr *x) -{ - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, - mpz_cmp_si (x->value.integer, - LIBERROR_END) == 0); -} - - -gfc_expr * -gfc_simplify_is_iostat_eor (gfc_expr *x) -{ - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, - mpz_cmp_si (x->value.integer, - LIBERROR_EOR) == 0); -} - - -gfc_expr * -gfc_simplify_isnan (gfc_expr *x) -{ - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, - mpfr_nan_p (x->value.real)); -} - - -/* Performs a shift on its first argument. Depending on the last - argument, the shift can be arithmetic, i.e. with filling from the - left like in the SHIFTA intrinsic. */ -static gfc_expr * -simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, - bool arithmetic, int direction) -{ - gfc_expr *result; - int ashift, *bits, i, k, bitsize, shift; - - if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (s, &shift); - - k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); - bitsize = gfc_integer_kinds[k].bit_size; - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - - if (shift == 0) - { - mpz_set (result->value.integer, e->value.integer); - return result; - } - - if (direction > 0 && shift < 0) - { - /* Left shift, as in SHIFTL. */ - gfc_error ("Second argument of %s is negative at %L", name, &e->where); - return &gfc_bad_expr; - } - else if (direction < 0) - { - /* Right shift, as in SHIFTR or SHIFTA. */ - if (shift < 0) - { - gfc_error ("Second argument of %s is negative at %L", - name, &e->where); - return &gfc_bad_expr; - } - - shift = -shift; - } - - ashift = (shift >= 0 ? shift : -shift); - - if (ashift > bitsize) - { - gfc_error ("Magnitude of second argument of %s exceeds bit size " - "at %L", name, &e->where); - return &gfc_bad_expr; - } - - bits = XCNEWVEC (int, bitsize); - - for (i = 0; i < bitsize; i++) - bits[i] = mpz_tstbit (e->value.integer, i); - - if (shift > 0) - { - /* Left shift. */ - for (i = 0; i < shift; i++) - mpz_clrbit (result->value.integer, i); - - for (i = 0; i < bitsize - shift; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + shift); - else - mpz_setbit (result->value.integer, i + shift); - } - } - else - { - /* Right shift. */ - if (arithmetic && bits[bitsize - 1]) - for (i = bitsize - 1; i >= bitsize - ashift; i--) - mpz_setbit (result->value.integer, i); - else - for (i = bitsize - 1; i >= bitsize - ashift; i--) - mpz_clrbit (result->value.integer, i); - - for (i = bitsize - 1; i >= ashift; i--) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i - ashift); - else - mpz_setbit (result->value.integer, i - ashift); - } - } - - gfc_convert_mpz_to_signed (result->value.integer, bitsize); - free (bits); - - return result; -} - - -gfc_expr * -gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "ISHFT", false, 0); -} - - -gfc_expr * -gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "LSHIFT", false, 1); -} - - -gfc_expr * -gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "RSHIFT", true, -1); -} - - -gfc_expr * -gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "SHIFTA", true, -1); -} - - -gfc_expr * -gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "SHIFTL", false, 1); -} - - -gfc_expr * -gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) -{ - return simplify_shift (e, s, "SHIFTR", false, -1); -} - - -gfc_expr * -gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) -{ - gfc_expr *result; - int shift, ashift, isize, ssize, delta, k; - int i, *bits; - - if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (s, &shift); - - k = gfc_validate_kind (e->ts.type, e->ts.kind, false); - isize = gfc_integer_kinds[k].bit_size; - - if (sz != NULL) - { - if (sz->expr_type != EXPR_CONSTANT) - return NULL; - - gfc_extract_int (sz, &ssize); - } - else - ssize = isize; - - if (shift >= 0) - ashift = shift; - else - ashift = -shift; - - if (ashift > ssize) - { - if (sz == NULL) - gfc_error ("Magnitude of second argument of ISHFTC exceeds " - "BIT_SIZE of first argument at %C"); - else - gfc_error ("Absolute value of SHIFT shall be less than or equal " - "to SIZE at %C"); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - - mpz_set (result->value.integer, e->value.integer); - - if (shift == 0) - return result; - - convert_mpz_to_unsigned (result->value.integer, isize); - - bits = XCNEWVEC (int, ssize); - - for (i = 0; i < ssize; i++) - bits[i] = mpz_tstbit (e->value.integer, i); - - delta = ssize - ashift; - - if (shift > 0) - { - for (i = 0; i < delta; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + shift); - else - mpz_setbit (result->value.integer, i + shift); - } - - for (i = delta; i < ssize; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i - delta); - else - mpz_setbit (result->value.integer, i - delta); - } - } - else - { - for (i = 0; i < ashift; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + delta); - else - mpz_setbit (result->value.integer, i + delta); - } - - for (i = ashift; i < ssize; i++) - { - if (bits[i] == 0) - mpz_clrbit (result->value.integer, i + shift); - else - mpz_setbit (result->value.integer, i + shift); - } - } - - gfc_convert_mpz_to_signed (result->value.integer, isize); - - free (bits); - return result; -} - - -gfc_expr * -gfc_simplify_kind (gfc_expr *e) -{ - return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind); -} - - -static gfc_expr * -simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, - gfc_array_spec *as, gfc_ref *ref, bool coarray) -{ - gfc_expr *l, *u, *result; - int k; - - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - - /* For non-variables, LBOUND(expr, DIM=n) = 1 and - UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ - if (!coarray && array->expr_type != EXPR_VARIABLE) - { - if (upper) - { - gfc_expr* dim = result; - mpz_set_si (dim->value.integer, d); - - result = simplify_size (array, dim, k); - gfc_free_expr (dim); - if (!result) - goto returnNull; - } - else - mpz_set_si (result->value.integer, 1); - - goto done; - } - - /* Otherwise, we have a variable expression. */ - gcc_assert (array->expr_type == EXPR_VARIABLE); - gcc_assert (as); - - if (!gfc_resolve_array_spec (as, 0)) - return NULL; - - /* The last dimension of an assumed-size array is special. */ - if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) - || (coarray && d == as->rank + as->corank - && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE))) - { - if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT) - { - gfc_free_expr (result); - return gfc_copy_expr (as->lower[d-1]); - } - - goto returnNull; - } - - result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - - /* Then, we need to know the extent of the given dimension. */ - if (coarray || (ref->u.ar.type == AR_FULL && !ref->next)) - { - gfc_expr *declared_bound; - int empty_bound; - bool constant_lbound, constant_ubound; - - l = as->lower[d-1]; - u = as->upper[d-1]; - - gcc_assert (l != NULL); - - constant_lbound = l->expr_type == EXPR_CONSTANT; - constant_ubound = u && u->expr_type == EXPR_CONSTANT; - - empty_bound = upper ? 0 : 1; - declared_bound = upper ? u : l; - - if ((!upper && !constant_lbound) - || (upper && !constant_ubound)) - goto returnNull; - - if (!coarray) - { - /* For {L,U}BOUND, the value depends on whether the array - is empty. We can nevertheless simplify if the declared bound - has the same value as that of an empty array, in which case - the result isn't dependent on the array emptyness. */ - if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0) - mpz_set_si (result->value.integer, empty_bound); - else if (!constant_lbound || !constant_ubound) - /* Array emptyness can't be determined, we can't simplify. */ - goto returnNull; - else if (mpz_cmp (l->value.integer, u->value.integer) > 0) - mpz_set_si (result->value.integer, empty_bound); - else - mpz_set (result->value.integer, declared_bound->value.integer); - } - else - mpz_set (result->value.integer, declared_bound->value.integer); - } - else - { - if (upper) - { - int d2 = 0, cnt = 0; - for (int idx = 0; idx < ref->u.ar.dimen; ++idx) - { - if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT) - d2++; - else if (cnt < d - 1) - cnt++; - else - break; - } - if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL)) - goto returnNull; - } - else - mpz_set_si (result->value.integer, (long int) 1); - } - -done: - return range_check (result, upper ? "UBOUND" : "LBOUND"); - -returnNull: - gfc_free_expr (result); - return NULL; -} - - -static gfc_expr * -simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) -{ - gfc_ref *ref; - gfc_array_spec *as; - ar_type type = AR_UNKNOWN; - int d; - - if (array->ts.type == BT_CLASS) - return NULL; - - if (array->expr_type != EXPR_VARIABLE) - { - as = NULL; - ref = NULL; - goto done; - } - - /* Do not attempt to resolve if error has already been issued. */ - if (array->symtree->n.sym->error) - return NULL; - - /* Follow any component references. */ - as = array->symtree->n.sym->as; - for (ref = array->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - type = ref->u.ar.type; - switch (ref->u.ar.type) - { - case AR_ELEMENT: - as = NULL; - continue; - - case AR_FULL: - /* We're done because 'as' has already been set in the - previous iteration. */ - goto done; - - case AR_UNKNOWN: - return NULL; - - case AR_SECTION: - as = ref->u.ar.as; - goto done; - } - - gcc_unreachable (); - - case REF_COMPONENT: - as = ref->u.c.component->as; - continue; - - case REF_SUBSTRING: - case REF_INQUIRY: - continue; - } - } - - gcc_unreachable (); - - done: - - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK - || (as->type == AS_ASSUMED_SHAPE && upper))) - return NULL; - - /* 'array' shall not be an unallocated allocatable variable or a pointer that - is not associated. */ - if (array->expr_type == EXPR_VARIABLE - && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer)) - return NULL; - - gcc_assert (!as - || (as->type != AS_DEFERRED - && array->expr_type == EXPR_VARIABLE - && !gfc_expr_attr (array).allocatable - && !gfc_expr_attr (array).pointer)); - - if (dim == NULL) - { - /* Multi-dimensional bounds. */ - gfc_expr *bounds[GFC_MAX_DIMENSIONS]; - gfc_expr *e; - int k; - - /* UBOUND(ARRAY) is not valid for an assumed-size array. */ - if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE) - { - /* An error message will be emitted in - check_assumed_size_reference (resolve.c). */ - return &gfc_bad_expr; - } - - /* Simplify the bounds for each dimension. */ - for (d = 0; d < array->rank; d++) - { - bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, - false); - if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) - { - int j; - - for (j = 0; j < d; j++) - gfc_free_expr (bounds[j]); - - if (gfc_seen_div0) - return &gfc_bad_expr; - else - return bounds[d]; - } - } - - /* Allocate the result expression. */ - k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", - gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - e = gfc_get_array_expr (BT_INTEGER, k, &array->where); - - /* The result is a rank 1 array; its size is the rank of the first - argument to {L,U}BOUND. */ - e->rank = 1; - e->shape = gfc_get_shape (1); - mpz_init_set_ui (e->shape[0], array->rank); - - /* Create the constructor for this array. */ - for (d = 0; d < array->rank; d++) - gfc_constructor_append_expr (&e->value.constructor, - bounds[d], &e->where); - - return e; - } - else - { - /* A DIM argument is specified. */ - if (dim->expr_type != EXPR_CONSTANT) - return NULL; - - d = mpz_get_si (dim->value.integer); - - if ((d < 1 || d > array->rank) - || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) - { - gfc_error ("DIM argument at %L is out of bounds", &dim->where); - return &gfc_bad_expr; - } - - if (as && as->type == AS_ASSUMED_RANK) - return NULL; - - return simplify_bound_dim (array, kind, d, upper, as, ref, false); - } -} - - -static gfc_expr * -simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) -{ - gfc_ref *ref; - gfc_array_spec *as; - int d; - - if (array->expr_type != EXPR_VARIABLE) - return NULL; - - /* Follow any component references. */ - as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) - ? array->ts.u.derived->components->as - : array->symtree->n.sym->as; - for (ref = array->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - switch (ref->u.ar.type) - { - case AR_ELEMENT: - if (ref->u.ar.as->corank > 0) - { - gcc_assert (as == ref->u.ar.as); - goto done; - } - as = NULL; - continue; - - case AR_FULL: - /* We're done because 'as' has already been set in the - previous iteration. */ - goto done; - - case AR_UNKNOWN: - return NULL; - - case AR_SECTION: - as = ref->u.ar.as; - goto done; - } - - gcc_unreachable (); - - case REF_COMPONENT: - as = ref->u.c.component->as; - continue; - - case REF_SUBSTRING: - case REF_INQUIRY: - continue; - } - } - - if (!as) - gcc_unreachable (); - - done: - - if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) - return NULL; - - if (dim == NULL) - { - /* Multi-dimensional cobounds. */ - gfc_expr *bounds[GFC_MAX_DIMENSIONS]; - gfc_expr *e; - int k; - - /* Simplify the cobounds for each dimension. */ - for (d = 0; d < as->corank; d++) - { - bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, - upper, as, ref, true); - if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) - { - int j; - - for (j = 0; j < d; j++) - gfc_free_expr (bounds[j]); - return bounds[d]; - } - } - - /* Allocate the result expression. */ - e = gfc_get_expr (); - e->where = array->where; - e->expr_type = EXPR_ARRAY; - e->ts.type = BT_INTEGER; - k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", - gfc_default_integer_kind); - if (k == -1) - { - gfc_free_expr (e); - return &gfc_bad_expr; - } - e->ts.kind = k; - - /* The result is a rank 1 array; its size is the rank of the first - argument to {L,U}COBOUND. */ - e->rank = 1; - e->shape = gfc_get_shape (1); - mpz_init_set_ui (e->shape[0], as->corank); - - /* Create the constructor for this array. */ - for (d = 0; d < as->corank; d++) - gfc_constructor_append_expr (&e->value.constructor, - bounds[d], &e->where); - return e; - } - else - { - /* A DIM argument is specified. */ - if (dim->expr_type != EXPR_CONSTANT) - return NULL; - - d = mpz_get_si (dim->value.integer); - - if (d < 1 || d > as->corank) - { - gfc_error ("DIM argument at %L is out of bounds", &dim->where); - return &gfc_bad_expr; - } - - return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); - } -} - - -gfc_expr * -gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_bound (array, dim, kind, 0); -} - - -gfc_expr * -gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_cobound (array, dim, kind, 0); -} - -gfc_expr * -gfc_simplify_leadz (gfc_expr *e) -{ - unsigned long lz, bs; - int i; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - bs = gfc_integer_kinds[i].bit_size; - if (mpz_cmp_si (e->value.integer, 0) == 0) - lz = bs; - else if (mpz_cmp_si (e->value.integer, 0) < 0) - lz = 0; - else - lz = bs - mpz_sizeinbase (e->value.integer, 2); - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); -} - - -/* Check for constant length of a substring. */ - -static bool -substring_has_constant_len (gfc_expr *e) -{ - gfc_ref *ref; - HOST_WIDE_INT istart, iend, length; - bool equal_length = false; - - if (e->ts.type != BT_CHARACTER) - return false; - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY) - break; - - if (!ref - || ref->type != REF_SUBSTRING - || !ref->u.ss.start - || ref->u.ss.start->expr_type != EXPR_CONSTANT - || !ref->u.ss.end - || ref->u.ss.end->expr_type != EXPR_CONSTANT) - return false; - - /* Basic checks on substring starting and ending indices. */ - if (!gfc_resolve_substring (ref, &equal_length)) - return false; - - istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer); - iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer); - - if (istart <= iend) - length = iend - istart + 1; - else - length = 0; - - /* Fix substring length. */ - e->value.character.length = length; - - return true; -} - - -gfc_expr * -gfc_simplify_len (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (e->expr_type == EXPR_CONSTANT - || substring_has_constant_len (e)) - { - result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); - mpz_set_si (result->value.integer, e->value.character.length); - return range_check (result, "LEN"); - } - else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT - && e->ts.u.cl->length->ts.type == BT_INTEGER) - { - result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); - mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); - return range_check (result, "LEN"); - } - else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER - && e->symtree->n.sym - && e->symtree->n.sym->ts.type != BT_DERIVED - && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target - && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED - && e->symtree->n.sym->assoc->target->symtree->n.sym - && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym)) - - /* The expression in assoc->target points to a ref to the _data component - of the unlimited polymorphic entity. To get the _len component the last - _data ref needs to be stripped and a ref to the _len component added. */ - return gfc_get_len_component (e->symtree->n.sym->assoc->target, k); - else - return NULL; -} - - -gfc_expr * -gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) -{ - gfc_expr *result; - size_t count, len, i; - int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - for (count = 0, i = 1; i <= len; i++) - if (e->value.character.string[len - i] == ' ') - count++; - else - break; - - result = gfc_get_int_expr (k, &e->where, len - count); - return range_check (result, "LEN_TRIM"); -} - -gfc_expr * -gfc_simplify_lgamma (gfc_expr *x) -{ - gfc_expr *result; - int sg; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); - - return range_check (result, "LGAMMA"); -} - - -gfc_expr * -gfc_simplify_lge (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) >= 0); -} - - -gfc_expr * -gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) > 0); -} - - -gfc_expr * -gfc_simplify_lle (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) <= 0); -} - - -gfc_expr * -gfc_simplify_llt (gfc_expr *a, gfc_expr *b) -{ - if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, - gfc_compare_string (a, b) < 0); -} - - -gfc_expr * -gfc_simplify_log (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - if (mpfr_sgn (x->value.real) <= 0) - { - gfc_error ("Argument of LOG at %L cannot be less than or equal " - "to zero", &x->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - mpfr_log (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - if (mpfr_zero_p (mpc_realref (x->value.complex)) - && mpfr_zero_p (mpc_imagref (x->value.complex))) - { - gfc_error ("Complex argument of LOG at %L cannot be zero", - &x->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - gfc_set_model_kind (x->ts.kind); - mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("gfc_simplify_log: bad type"); - } - - return range_check (result, "LOG"); -} - - -gfc_expr * -gfc_simplify_log10 (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - if (mpfr_sgn (x->value.real) <= 0) - { - gfc_error ("Argument of LOG10 at %L cannot be less than or equal " - "to zero", &x->where); - return &gfc_bad_expr; - } - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); - - return range_check (result, "LOG10"); -} - - -gfc_expr * -gfc_simplify_logical (gfc_expr *e, gfc_expr *k) -{ - int kind; - - kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); - if (kind < 0) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - return gfc_get_logical_expr (kind, &e->where, e->value.logical); -} - - -gfc_expr* -gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) -{ - gfc_expr *result; - int row, result_rows, col, result_columns; - int stride_a, offset_a, stride_b, offset_b; - - if (!is_constant_array_expr (matrix_a) - || !is_constant_array_expr (matrix_b)) - return NULL; - - /* MATMUL should do mixed-mode arithmetic. Set the result type. */ - if (matrix_a->ts.type != matrix_b->ts.type) - { - gfc_expr e; - e.expr_type = EXPR_OP; - gfc_clear_ts (&e.ts); - e.value.op.op = INTRINSIC_NONE; - e.value.op.op1 = matrix_a; - e.value.op.op2 = matrix_b; - gfc_type_convert_binary (&e, 1); - result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where); - } - else - { - result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind, - &matrix_a->where); - } - - if (matrix_a->rank == 1 && matrix_b->rank == 2) - { - result_rows = 1; - result_columns = mpz_get_si (matrix_b->shape[1]); - stride_a = 1; - stride_b = mpz_get_si (matrix_b->shape[0]); - - result->rank = 1; - result->shape = gfc_get_shape (result->rank); - mpz_init_set_si (result->shape[0], result_columns); - } - else if (matrix_a->rank == 2 && matrix_b->rank == 1) - { - result_rows = mpz_get_si (matrix_a->shape[0]); - result_columns = 1; - stride_a = mpz_get_si (matrix_a->shape[0]); - stride_b = 1; - - result->rank = 1; - result->shape = gfc_get_shape (result->rank); - mpz_init_set_si (result->shape[0], result_rows); - } - else if (matrix_a->rank == 2 && matrix_b->rank == 2) - { - result_rows = mpz_get_si (matrix_a->shape[0]); - result_columns = mpz_get_si (matrix_b->shape[1]); - stride_a = mpz_get_si (matrix_a->shape[0]); - stride_b = mpz_get_si (matrix_b->shape[0]); - - result->rank = 2; - result->shape = gfc_get_shape (result->rank); - mpz_init_set_si (result->shape[0], result_rows); - mpz_init_set_si (result->shape[1], result_columns); - } - else - gcc_unreachable(); - - offset_b = 0; - for (col = 0; col < result_columns; ++col) - { - offset_a = 0; - - for (row = 0; row < result_rows; ++row) - { - gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, - matrix_b, 1, offset_b, false); - gfc_constructor_append_expr (&result->value.constructor, - e, NULL); - - offset_a += 1; - } - - offset_b += stride_b; - } - - return result; -} - - -gfc_expr * -gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) -{ - gfc_expr *result; - int kind, arg, k; - - if (i->expr_type != EXPR_CONSTANT) - return NULL; - - kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - k = gfc_validate_kind (BT_INTEGER, kind, false); - - bool fail = gfc_extract_int (i, &arg); - gcc_assert (!fail); - - if (!gfc_check_mask (i, kind_arg)) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); - - /* MASKR(n) = 2^n - 1 */ - mpz_set_ui (result->value.integer, 1); - mpz_mul_2exp (result->value.integer, result->value.integer, arg); - mpz_sub_ui (result->value.integer, result->value.integer, 1); - - gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) -{ - gfc_expr *result; - int kind, arg, k; - mpz_t z; - - if (i->expr_type != EXPR_CONSTANT) - return NULL; - - kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - k = gfc_validate_kind (BT_INTEGER, kind, false); - - bool fail = gfc_extract_int (i, &arg); - gcc_assert (!fail); - - if (!gfc_check_mask (i, kind_arg)) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); - - /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ - mpz_init_set_ui (z, 1); - mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); - mpz_set_ui (result->value.integer, 1); - mpz_mul_2exp (result->value.integer, result->value.integer, - gfc_integer_kinds[k].bit_size - arg); - mpz_sub (result->value.integer, z, result->value.integer); - mpz_clear (z); - - gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); - - return result; -} - - -gfc_expr * -gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) -{ - gfc_expr * result; - gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; - - if (mask->expr_type == EXPR_CONSTANT) - { - result = gfc_copy_expr (mask->value.logical ? tsource : fsource); - /* Parenthesis is needed to get lower bounds of 1. */ - result = gfc_get_parentheses (result); - gfc_simplify_expr (result, 1); - return result; - } - - if (!mask->rank || !is_constant_array_expr (mask) - || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) - return NULL; - - result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, - &tsource->where); - if (tsource->ts.type == BT_DERIVED) - result->ts.u.derived = tsource->ts.u.derived; - else if (tsource->ts.type == BT_CHARACTER) - result->ts.u.cl = tsource->ts.u.cl; - - tsource_ctor = gfc_constructor_first (tsource->value.constructor); - fsource_ctor = gfc_constructor_first (fsource->value.constructor); - mask_ctor = gfc_constructor_first (mask->value.constructor); - - while (mask_ctor) - { - if (mask_ctor->expr->value.logical) - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (tsource_ctor->expr), - NULL); - else - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (fsource_ctor->expr), - NULL); - tsource_ctor = gfc_constructor_next (tsource_ctor); - fsource_ctor = gfc_constructor_next (fsource_ctor); - mask_ctor = gfc_constructor_next (mask_ctor); - } - - result->shape = gfc_get_shape (1); - gfc_array_size (result, &result->shape[0]); - - return result; -} - - -gfc_expr * -gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) -{ - mpz_t arg1, arg2, mask; - gfc_expr *result; - - if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT - || mask_expr->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); - - /* Convert all argument to unsigned. */ - mpz_init_set (arg1, i->value.integer); - mpz_init_set (arg2, j->value.integer); - mpz_init_set (mask, mask_expr->value.integer); - - /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ - mpz_and (arg1, arg1, mask); - mpz_com (mask, mask); - mpz_and (arg2, arg2, mask); - mpz_ior (result->value.integer, arg1, arg2); - - mpz_clear (arg1); - mpz_clear (arg2); - mpz_clear (mask); - - return result; -} - - -/* Selects between current value and extremum for simplify_min_max - and simplify_minval_maxval. */ -static int -min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) -{ - int ret; - - switch (arg->ts.type) - { - case BT_INTEGER: - if (extremum->ts.kind < arg->ts.kind) - extremum->ts.kind = arg->ts.kind; - ret = mpz_cmp (arg->value.integer, - extremum->value.integer) * sign; - if (ret > 0) - mpz_set (extremum->value.integer, arg->value.integer); - break; - - case BT_REAL: - if (extremum->ts.kind < arg->ts.kind) - extremum->ts.kind = arg->ts.kind; - if (mpfr_nan_p (extremum->value.real)) - { - ret = 1; - mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); - } - else if (mpfr_nan_p (arg->value.real)) - ret = -1; - else - { - ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign; - if (ret > 0) - mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); - } - break; - - case BT_CHARACTER: -#define LENGTH(x) ((x)->value.character.length) -#define STRING(x) ((x)->value.character.string) - if (LENGTH (extremum) < LENGTH(arg)) - { - gfc_char_t *tmp = STRING(extremum); - - STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); - memcpy (STRING(extremum), tmp, - LENGTH(extremum) * sizeof (gfc_char_t)); - gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', - LENGTH(arg) - LENGTH(extremum)); - STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ - LENGTH(extremum) = LENGTH(arg); - free (tmp); - } - ret = gfc_compare_string (arg, extremum) * sign; - if (ret > 0) - { - free (STRING(extremum)); - STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); - memcpy (STRING(extremum), STRING(arg), - LENGTH(arg) * sizeof (gfc_char_t)); - gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', - LENGTH(extremum) - LENGTH(arg)); - STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ - } -#undef LENGTH -#undef STRING - break; - - default: - gfc_internal_error ("simplify_min_max(): Bad type in arglist"); - } - if (back_val && ret == 0) - ret = 1; - - return ret; -} - - -/* This function is special since MAX() can take any number of - arguments. The simplified expression is a rewritten version of the - argument list containing at most one constant element. Other - constant elements are deleted. Because the argument list has - already been checked, this function always succeeds. sign is 1 for - MAX(), -1 for MIN(). */ - -static gfc_expr * -simplify_min_max (gfc_expr *expr, int sign) -{ - int tmp1, tmp2; - gfc_actual_arglist *arg, *last, *extremum; - gfc_expr *tmp, *ret; - const char *fname; - - last = NULL; - extremum = NULL; - - arg = expr->value.function.actual; - - for (; arg; last = arg, arg = arg->next) - { - if (arg->expr->expr_type != EXPR_CONSTANT) - continue; - - if (extremum == NULL) - { - extremum = arg; - continue; - } - - min_max_choose (arg->expr, extremum->expr, sign); - - /* Delete the extra constant argument. */ - last->next = arg->next; - - arg->next = NULL; - gfc_free_actual_arglist (arg); - arg = last; - } - - /* If there is one value left, replace the function call with the - expression. */ - if (expr->value.function.actual->next != NULL) - return NULL; - - /* Handle special cases of specific functions (min|max)1 and - a(min|max)0. */ - - tmp = expr->value.function.actual->expr; - fname = expr->value.function.isym->name; - - if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind) - && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0)) - { - /* Explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - } - else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind) - && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0)) - { - ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind); - } - else - ret = gfc_copy_expr (tmp); - - return ret; - -} - - -gfc_expr * -gfc_simplify_min (gfc_expr *e) -{ - return simplify_min_max (e, -1); -} - - -gfc_expr * -gfc_simplify_max (gfc_expr *e) -{ - return simplify_min_max (e, 1); -} - -/* Helper function for gfc_simplify_minval. */ - -static gfc_expr * -gfc_min (gfc_expr *op1, gfc_expr *op2) -{ - min_max_choose (op1, op2, -1); - gfc_free_expr (op1); - return op2; -} - -/* Simplify minval for constant arrays. */ - -gfc_expr * -gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, INT_MAX, gfc_min); -} - -/* Helper function for gfc_simplify_maxval. */ - -static gfc_expr * -gfc_max (gfc_expr *op1, gfc_expr *op2) -{ - min_max_choose (op1, op2, 1); - gfc_free_expr (op1); - return op2; -} - - -/* Simplify maxval for constant arrays. */ - -gfc_expr * -gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, INT_MIN, gfc_max); -} - - -/* Transform minloc or maxloc of an array, according to MASK, - to the scalar result. This code is mostly identical to - simplify_transformation_to_scalar. */ - -static gfc_expr * -simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, - gfc_expr *extremum, int sign, bool back_val) -{ - gfc_expr *a, *m; - gfc_constructor *array_ctor, *mask_ctor; - mpz_t count; - - mpz_set_si (result->value.integer, 0); - - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - return result; - - array_ctor = gfc_constructor_first (array->value.constructor); - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - mpz_init_set_si (count, 0); - while (array_ctor) - { - mpz_add_ui (count, count, 1); - a = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - /* A constant MASK equals .TRUE. here and can be ignored. */ - if (mask_ctor) - { - m = mask_ctor->expr; - mask_ctor = gfc_constructor_next (mask_ctor); - if (!m->value.logical) - continue; - } - if (min_max_choose (a, extremum, sign, back_val) > 0) - mpz_set (result->value.integer, count); - } - mpz_clear (count); - gfc_free_expr (extremum); - return result; -} - -/* Simplify minloc / maxloc in the absence of a dim argument. */ - -static gfc_expr * -simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum, - gfc_expr *array, gfc_expr *mask, int sign, - bool back_val) -{ - ssize_t res[GFC_MAX_DIMENSIONS]; - int i, n; - gfc_constructor *result_ctor, *array_ctor, *mask_ctor; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS]; - gfc_expr *a, *m; - bool continue_loop; - bool ma; - - for (i = 0; irank; i++) - res[i] = -1; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - goto finish; - - if (array->shape == NULL) - goto finish; - - for (i = 0; i < array->rank; i++) - { - count[i] = 0; - sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); - extent[i] = mpz_get_si (array->shape[i]); - if (extent[i] <= 0) - goto finish; - } - - continue_loop = true; - array_ctor = gfc_constructor_first (array->value.constructor); - if (mask && mask->rank > 0) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - /* Loop over the array elements (and mask), keeping track of - the indices to return. */ - while (continue_loop) - { - do - { - a = array_ctor->expr; - if (mask_ctor) - { - m = mask_ctor->expr; - ma = m->value.logical; - mask_ctor = gfc_constructor_next (mask_ctor); - } - else - ma = true; - - if (ma && min_max_choose (a, extremum, sign, back_val) > 0) - { - for (i = 0; irank; i++) - res[i] = count[i]; - } - array_ctor = gfc_constructor_next (array_ctor); - count[0] ++; - } while (count[0] != extent[0]); - n = 0; - do - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - n++; - if (n >= array->rank) - { - continue_loop = false; - break; - } - else - count[n] ++; - } while (count[n] == extent[n]); - } - - finish: - gfc_free_expr (extremum); - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; irank; i++) - { - gfc_expr *r_expr; - r_expr = result_ctor->expr; - mpz_set_si (r_expr->value.integer, res[i] + 1); - result_ctor = gfc_constructor_next (result_ctor); - } - return result; -} - -/* Helper function for gfc_simplify_minmaxloc - build an array - expression with n elements. */ - -static gfc_expr * -new_array (bt type, int kind, int n, locus *where) -{ - gfc_expr *result; - int i; - - result = gfc_get_array_expr (type, kind, where); - result->rank = 1; - result->shape = gfc_get_shape(1); - mpz_init_set_si (result->shape[0], n); - for (i = 0; i < n; i++) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_get_constant_expr (type, kind, where), - NULL); - } - - return result; -} - -/* Simplify minloc and maxloc. This code is mostly identical to - simplify_transformation_to_array. */ - -static gfc_expr * -simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, - gfc_expr *dim, gfc_expr *mask, - gfc_expr *extremum, int sign, bool back_val) -{ - mpz_t size; - int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; - gfc_expr **arrayvec, **resultvec, **base, **src, **dest; - gfc_constructor *array_ctor, *mask_ctor, *result_ctor; - - int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], - tmpstride[GFC_MAX_DIMENSIONS]; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - return result; - - /* Build an indexed table for array element expressions to minimize - linked-list traversal. Masked elements are set to NULL. */ - gfc_array_size (array, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - arrayvec = XCNEWVEC (gfc_expr*, arraysize); - - array_ctor = gfc_constructor_first (array->value.constructor); - mask_ctor = NULL; - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - - for (i = 0; i < arraysize; ++i) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - - if (mask_ctor) - { - if (!mask_ctor->expr->value.logical) - arrayvec[i] = NULL; - - mask_ctor = gfc_constructor_next (mask_ctor); - } - } - - /* Same for the result expression. */ - gfc_array_size (result, &size); - resultsize = mpz_get_ui (size); - mpz_clear (size); - - resultvec = XCNEWVEC (gfc_expr*, resultsize); - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - resultvec[i] = result_ctor->expr; - result_ctor = gfc_constructor_next (result_ctor); - } - - gfc_extract_int (dim, &dim_index); - dim_index -= 1; /* zero-base index */ - dim_extent = 0; - dim_stride = 0; - - for (i = 0, n = 0; i < array->rank; ++i) - { - count[i] = 0; - tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); - if (i == dim_index) - { - dim_extent = mpz_get_si (array->shape[i]); - dim_stride = tmpstride[i]; - continue; - } - - extent[n] = mpz_get_si (array->shape[i]); - sstride[n] = tmpstride[i]; - dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; - n += 1; - } - - done = resultsize <= 0; - base = arrayvec; - dest = resultvec; - while (!done) - { - gfc_expr *ex; - ex = gfc_copy_expr (extremum); - for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) - { - if (*src && min_max_choose (*src, ex, sign, back_val) > 0) - mpz_set_si ((*dest)->value.integer, n + 1); - } - - count[0]++; - base += sstride[0]; - dest += dstride[0]; - gfc_free_expr (ex); - - n = 0; - while (!done && count[n] == extent[n]) - { - count[n] = 0; - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - - n++; - if (n < result->rank) - { - /* If the nested loop is unrolled GFC_MAX_DIMENSIONS - times, we'd warn for the last iteration, because the - array index will have already been incremented to the - array sizes, and we can't tell that this must make - the test against result->rank false, because ranks - must not exceed GFC_MAX_DIMENSIONS. */ - GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) - count[n]++; - base += sstride[n]; - dest += dstride[n]; - GCC_DIAGNOSTIC_POP - } - else - done = true; - } - } - - /* Place updated expression in result constructor. */ - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - result_ctor->expr = resultvec[i]; - result_ctor = gfc_constructor_next (result_ctor); - } - - free (arrayvec); - free (resultvec); - free (extremum); - return result; -} - -/* Simplify minloc and maxloc for constant arrays. */ - -static gfc_expr * -gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, - gfc_expr *kind, gfc_expr *back, int sign) -{ - gfc_expr *result; - gfc_expr *extremum; - int ikind; - int init_val; - bool back_val = false; - - if (!is_constant_array_expr (array) - || !gfc_is_constant_expr (dim)) - return NULL; - - if (mask - && !is_constant_array_expr (mask) - && mask->expr_type != EXPR_CONSTANT) - return NULL; - - if (kind) - { - if (gfc_extract_int (kind, &ikind, -1)) - return NULL; - } - else - ikind = gfc_default_integer_kind; - - if (back) - { - if (back->expr_type != EXPR_CONSTANT) - return NULL; - - back_val = back->value.logical; - } - - if (sign < 0) - init_val = INT_MAX; - else if (sign > 0) - init_val = INT_MIN; - else - gcc_unreachable(); - - extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); - init_result_expr (extremum, init_val, array); - - if (dim) - { - result = transformational_result (array, dim, BT_INTEGER, - ikind, &array->where); - init_result_expr (result, 0, array); - - if (array->rank == 1) - return simplify_minmaxloc_to_scalar (result, array, mask, extremum, - sign, back_val); - else - return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, - sign, back_val); - } - else - { - result = new_array (BT_INTEGER, ikind, array->rank, &array->where); - return simplify_minmaxloc_nodim (result, extremum, array, mask, - sign, back_val); - } -} - -gfc_expr * -gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, - gfc_expr *back) -{ - return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); -} - -gfc_expr * -gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, - gfc_expr *back) -{ - return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1); -} - -/* Simplify findloc to scalar. Similar to - simplify_minmaxloc_to_scalar. */ - -static gfc_expr * -simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value, - gfc_expr *mask, int back_val) -{ - gfc_expr *a, *m; - gfc_constructor *array_ctor, *mask_ctor; - mpz_t count; - - mpz_set_si (result->value.integer, 0); - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - return result; - - array_ctor = gfc_constructor_first (array->value.constructor); - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - mpz_init_set_si (count, 0); - while (array_ctor) - { - mpz_add_ui (count, count, 1); - a = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - /* A constant MASK equals .TRUE. here and can be ignored. */ - if (mask_ctor) - { - m = mask_ctor->expr; - mask_ctor = gfc_constructor_next (mask_ctor); - if (!m->value.logical) - continue; - } - if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) - { - /* We have a match. If BACK is true, continue so we find - the last one. */ - mpz_set (result->value.integer, count); - if (!back_val) - break; - } - } - mpz_clear (count); - return result; -} - -/* Simplify findloc in the absence of a dim argument. Similar to - simplify_minmaxloc_nodim. */ - -static gfc_expr * -simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array, - gfc_expr *mask, bool back_val) -{ - ssize_t res[GFC_MAX_DIMENSIONS]; - int i, n; - gfc_constructor *result_ctor, *array_ctor, *mask_ctor; - ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS]; - gfc_expr *a, *m; - bool continue_loop; - bool ma; - - for (i = 0; i < array->rank; i++) - res[i] = -1; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - goto finish; - - for (i = 0; i < array->rank; i++) - { - count[i] = 0; - sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); - extent[i] = mpz_get_si (array->shape[i]); - if (extent[i] <= 0) - goto finish; - } - - continue_loop = true; - array_ctor = gfc_constructor_first (array->value.constructor); - if (mask && mask->rank > 0) - mask_ctor = gfc_constructor_first (mask->value.constructor); - else - mask_ctor = NULL; - - /* Loop over the array elements (and mask), keeping track of - the indices to return. */ - while (continue_loop) - { - do - { - a = array_ctor->expr; - if (mask_ctor) - { - m = mask_ctor->expr; - ma = m->value.logical; - mask_ctor = gfc_constructor_next (mask_ctor); - } - else - ma = true; - - if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) - { - for (i = 0; i < array->rank; i++) - res[i] = count[i]; - if (!back_val) - goto finish; - } - array_ctor = gfc_constructor_next (array_ctor); - count[0] ++; - } while (count[0] != extent[0]); - n = 0; - do - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - n++; - if (n >= array->rank) - { - continue_loop = false; - break; - } - else - count[n] ++; - } while (count[n] == extent[n]); - } - -finish: - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < array->rank; i++) - { - gfc_expr *r_expr; - r_expr = result_ctor->expr; - mpz_set_si (r_expr->value.integer, res[i] + 1); - result_ctor = gfc_constructor_next (result_ctor); - } - return result; -} - - -/* Simplify findloc to an array. Similar to - simplify_minmaxloc_to_array. */ - -static gfc_expr * -simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value, - gfc_expr *dim, gfc_expr *mask, bool back_val) -{ - mpz_t size; - int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; - gfc_expr **arrayvec, **resultvec, **base, **src, **dest; - gfc_constructor *array_ctor, *mask_ctor, *result_ctor; - - int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], - sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], - tmpstride[GFC_MAX_DIMENSIONS]; - - /* Shortcut for constant .FALSE. MASK. */ - if (mask - && mask->expr_type == EXPR_CONSTANT - && !mask->value.logical) - return result; - - /* Build an indexed table for array element expressions to minimize - linked-list traversal. Masked elements are set to NULL. */ - gfc_array_size (array, &size); - arraysize = mpz_get_ui (size); - mpz_clear (size); - - arrayvec = XCNEWVEC (gfc_expr*, arraysize); - - array_ctor = gfc_constructor_first (array->value.constructor); - mask_ctor = NULL; - if (mask && mask->expr_type == EXPR_ARRAY) - mask_ctor = gfc_constructor_first (mask->value.constructor); - - for (i = 0; i < arraysize; ++i) - { - arrayvec[i] = array_ctor->expr; - array_ctor = gfc_constructor_next (array_ctor); - - if (mask_ctor) - { - if (!mask_ctor->expr->value.logical) - arrayvec[i] = NULL; - - mask_ctor = gfc_constructor_next (mask_ctor); - } - } - - /* Same for the result expression. */ - gfc_array_size (result, &size); - resultsize = mpz_get_ui (size); - mpz_clear (size); - - resultvec = XCNEWVEC (gfc_expr*, resultsize); - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - resultvec[i] = result_ctor->expr; - result_ctor = gfc_constructor_next (result_ctor); - } - - gfc_extract_int (dim, &dim_index); - - dim_index -= 1; /* Zero-base index. */ - dim_extent = 0; - dim_stride = 0; - - for (i = 0, n = 0; i < array->rank; ++i) - { - count[i] = 0; - tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); - if (i == dim_index) - { - dim_extent = mpz_get_si (array->shape[i]); - dim_stride = tmpstride[i]; - continue; - } - - extent[n] = mpz_get_si (array->shape[i]); - sstride[n] = tmpstride[i]; - dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; - n += 1; - } - - done = resultsize <= 0; - base = arrayvec; - dest = resultvec; - while (!done) - { - for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) - { - if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0) - { - mpz_set_si ((*dest)->value.integer, n + 1); - if (!back_val) - break; - } - } - - count[0]++; - base += sstride[0]; - dest += dstride[0]; - - n = 0; - while (!done && count[n] == extent[n]) - { - count[n] = 0; - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - - n++; - if (n < result->rank) - { - /* If the nested loop is unrolled GFC_MAX_DIMENSIONS - times, we'd warn for the last iteration, because the - array index will have already been incremented to the - array sizes, and we can't tell that this must make - the test against result->rank false, because ranks - must not exceed GFC_MAX_DIMENSIONS. */ - GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) - count[n]++; - base += sstride[n]; - dest += dstride[n]; - GCC_DIAGNOSTIC_POP - } - else - done = true; - } - } - - /* Place updated expression in result constructor. */ - result_ctor = gfc_constructor_first (result->value.constructor); - for (i = 0; i < resultsize; ++i) - { - result_ctor->expr = resultvec[i]; - result_ctor = gfc_constructor_next (result_ctor); - } - - free (arrayvec); - free (resultvec); - return result; -} - -/* Simplify findloc. */ - -gfc_expr * -gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim, - gfc_expr *mask, gfc_expr *kind, gfc_expr *back) -{ - gfc_expr *result; - int ikind; - bool back_val = false; - - if (!is_constant_array_expr (array) - || !gfc_is_constant_expr (dim)) - return NULL; - - if (! gfc_is_constant_expr (value)) - return 0; - - if (mask - && !is_constant_array_expr (mask) - && mask->expr_type != EXPR_CONSTANT) - return NULL; - - if (kind) - { - if (gfc_extract_int (kind, &ikind, -1)) - return NULL; - } - else - ikind = gfc_default_integer_kind; - - if (back) - { - if (back->expr_type != EXPR_CONSTANT) - return NULL; - - back_val = back->value.logical; - } - - if (dim) - { - result = transformational_result (array, dim, BT_INTEGER, - ikind, &array->where); - init_result_expr (result, 0, array); - - if (array->rank == 1) - return simplify_findloc_to_scalar (result, array, value, mask, - back_val); - else - return simplify_findloc_to_array (result, array, value, dim, mask, - back_val); - } - else - { - result = new_array (BT_INTEGER, ikind, array->rank, &array->where); - return simplify_findloc_nodim (result, value, array, mask, back_val); - } - return NULL; -} - -gfc_expr * -gfc_simplify_maxexponent (gfc_expr *x) -{ - int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - return gfc_get_int_expr (gfc_default_integer_kind, &x->where, - gfc_real_kinds[i].max_exponent); -} - - -gfc_expr * -gfc_simplify_minexponent (gfc_expr *x) -{ - int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); - return gfc_get_int_expr (gfc_default_integer_kind, &x->where, - gfc_real_kinds[i].min_exponent); -} - - -gfc_expr * -gfc_simplify_mod (gfc_expr *a, gfc_expr *p) -{ - gfc_expr *result; - int kind; - - /* First check p. */ - if (p->expr_type != EXPR_CONSTANT) - return NULL; - - /* p shall not be 0. */ - switch (p->ts.type) - { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - gfc_error ("Argument %qs of MOD at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - gfc_error ("Argument %qs of MOD at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - default: - gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); - } - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - - if (a->ts.type == BT_INTEGER) - mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); - else - { - gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); - } - - return range_check (result, "MOD"); -} - - -gfc_expr * -gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) -{ - gfc_expr *result; - int kind; - - /* First check p. */ - if (p->expr_type != EXPR_CONSTANT) - return NULL; - - /* p shall not be 0. */ - switch (p->ts.type) - { - case BT_INTEGER: - if (mpz_cmp_ui (p->value.integer, 0) == 0) - { - gfc_error ("Argument %qs of MODULO at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - case BT_REAL: - if (mpfr_cmp_ui (p->value.real, 0) == 0) - { - gfc_error ("Argument %qs of MODULO at %L shall not be zero", - "P", &p->where); - return &gfc_bad_expr; - } - break; - default: - gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); - } - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; - result = gfc_get_constant_expr (a->ts.type, kind, &a->where); - - if (a->ts.type == BT_INTEGER) - mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); - else - { - gfc_set_model_kind (kind); - mpfr_fmod (result->value.real, a->value.real, p->value.real, - GFC_RND_MODE); - if (mpfr_cmp_ui (result->value.real, 0) != 0) - { - if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) - mpfr_add (result->value.real, result->value.real, p->value.real, - GFC_RND_MODE); - } - else - mpfr_copysign (result->value.real, result->value.real, - p->value.real, GFC_RND_MODE); - } - - return range_check (result, "MODULO"); -} - - -gfc_expr * -gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) -{ - gfc_expr *result; - mpfr_exp_t emin, emax; - int kind; - - if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_copy_expr (x); - - /* Save current values of emin and emax. */ - emin = mpfr_get_emin (); - emax = mpfr_get_emax (); - - /* Set emin and emax for the current model number. */ - kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); - mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent - - mpfr_get_prec(result->value.real) + 1); - mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1); - mpfr_check_range (result->value.real, 0, MPFR_RNDU); - - if (mpfr_sgn (s->value.real) > 0) - { - mpfr_nextabove (result->value.real); - mpfr_subnormalize (result->value.real, 0, MPFR_RNDU); - } - else - { - mpfr_nextbelow (result->value.real); - mpfr_subnormalize (result->value.real, 0, MPFR_RNDD); - } - - mpfr_set_emin (emin); - mpfr_set_emax (emax); - - /* Only NaN can occur. Do not use range check as it gives an - error for denormal numbers. */ - if (mpfr_nan_p (result->value.real) && flag_range_check) - { - gfc_error ("Result of NEAREST is NaN at %L", &result->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - return result; -} - - -static gfc_expr * -simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) -{ - gfc_expr *itrunc, *result; - int kind; - - kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - itrunc = gfc_copy_expr (e); - mpfr_round (itrunc->value.real, e->value.real); - - result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); - gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); - - gfc_free_expr (itrunc); - - return range_check (result, name); -} - - -gfc_expr * -gfc_simplify_new_line (gfc_expr *e) -{ - gfc_expr *result; - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); - result->value.character.string[0] = '\n'; - - return result; -} - - -gfc_expr * -gfc_simplify_nint (gfc_expr *e, gfc_expr *k) -{ - return simplify_nint ("NINT", e, k); -} - - -gfc_expr * -gfc_simplify_idnint (gfc_expr *e) -{ - return simplify_nint ("IDNINT", e, NULL); -} - -static int norm2_scale; - -static gfc_expr * -norm2_add_squared (gfc_expr *result, gfc_expr *e) -{ - mpfr_t tmp; - - gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_REAL - && result->expr_type == EXPR_CONSTANT); - - gfc_set_model_kind (result->ts.kind); - int index = gfc_validate_kind (BT_REAL, result->ts.kind, false); - mpfr_exp_t exp; - if (mpfr_regular_p (result->value.real)) - { - exp = mpfr_get_exp (result->value.real); - /* If result is getting close to overflowing, scale down. */ - if (exp >= gfc_real_kinds[index].max_exponent - 4 - && norm2_scale <= gfc_real_kinds[index].max_exponent - 2) - { - norm2_scale += 2; - mpfr_div_ui (result->value.real, result->value.real, 16, - GFC_RND_MODE); - } - } - - mpfr_init (tmp); - if (mpfr_regular_p (e->value.real)) - { - exp = mpfr_get_exp (e->value.real); - /* If e**2 would overflow or close to overflowing, scale down. */ - if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2) - { - int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4; - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, new_scale - norm2_scale); - mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); - mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); - norm2_scale = new_scale; - } - } - if (norm2_scale) - { - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, norm2_scale); - mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE); - } - else - mpfr_set (tmp, e->value.real, GFC_RND_MODE); - mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE); - mpfr_add (result->value.real, result->value.real, tmp, - GFC_RND_MODE); - mpfr_clear (tmp); - - return result; -} - - -static gfc_expr * -norm2_do_sqrt (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_REAL - && result->expr_type == EXPR_CONSTANT); - - if (result != e) - mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); - mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); - if (norm2_scale && mpfr_regular_p (result->value.real)) - { - mpfr_t tmp; - mpfr_init (tmp); - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, norm2_scale); - mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); - } - norm2_scale = 0; - - return result; -} - - -gfc_expr * -gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) -{ - gfc_expr *result; - bool size_zero; - - size_zero = gfc_is_size_zero_array (e); - - if (!(is_constant_array_expr (e) || size_zero) - || (dim != NULL && !gfc_is_constant_expr (dim))) - return NULL; - - result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); - init_result_expr (result, 0, NULL); - - if (size_zero) - return result; - - norm2_scale = 0; - if (!dim || e->rank == 1) - { - result = simplify_transformation_to_scalar (result, e, NULL, - norm2_add_squared); - mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); - if (norm2_scale && mpfr_regular_p (result->value.real)) - { - mpfr_t tmp; - mpfr_init (tmp); - mpfr_set_ui (tmp, 1, GFC_RND_MODE); - mpfr_set_exp (tmp, norm2_scale); - mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); - mpfr_clear (tmp); - } - norm2_scale = 0; - } - else - result = simplify_transformation_to_array (result, e, dim, NULL, - norm2_add_squared, - norm2_do_sqrt); - - return result; -} - - -gfc_expr * -gfc_simplify_not (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - mpz_com (result->value.integer, e->value.integer); - - return range_check (result, "NOT"); -} - - -gfc_expr * -gfc_simplify_null (gfc_expr *mold) -{ - gfc_expr *result; - - if (mold) - { - result = gfc_copy_expr (mold); - result->expr_type = EXPR_NULL; - } - else - result = gfc_get_null_expr (NULL); - - return result; -} - - -gfc_expr * -gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) -{ - gfc_expr *result; - - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - if (flag_coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - if (failed && failed->expr_type != EXPR_CONSTANT) - return NULL; - - /* FIXME: gfc_current_locus is wrong. */ - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &gfc_current_locus); - - if (failed && failed->value.logical != 0) - mpz_set_si (result->value.integer, 0); - else - mpz_set_si (result->value.integer, 1); - - return result; -} - - -gfc_expr * -gfc_simplify_or (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - - switch (x->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); - mpz_ior (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "OR"); - - case BT_LOGICAL: - return gfc_get_logical_expr (kind, &x->where, - x->value.logical || y->value.logical); - default: - gcc_unreachable(); - } -} - - -gfc_expr * -gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) -{ - gfc_expr *result; - gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; - - if (!is_constant_array_expr (array) - || !is_constant_array_expr (vector) - || (!gfc_is_constant_expr (mask) - && !is_constant_array_expr (mask))) - return NULL; - - result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); - if (array->ts.type == BT_DERIVED) - result->ts.u.derived = array->ts.u.derived; - - array_ctor = gfc_constructor_first (array->value.constructor); - vector_ctor = vector - ? gfc_constructor_first (vector->value.constructor) - : NULL; - - if (mask->expr_type == EXPR_CONSTANT - && mask->value.logical) - { - /* Copy all elements of ARRAY to RESULT. */ - while (array_ctor) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (array_ctor->expr), - NULL); - - array_ctor = gfc_constructor_next (array_ctor); - vector_ctor = gfc_constructor_next (vector_ctor); - } - } - else if (mask->expr_type == EXPR_ARRAY) - { - /* Copy only those elements of ARRAY to RESULT whose - MASK equals .TRUE.. */ - mask_ctor = gfc_constructor_first (mask->value.constructor); - while (mask_ctor) - { - if (mask_ctor->expr->value.logical) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (array_ctor->expr), - NULL); - vector_ctor = gfc_constructor_next (vector_ctor); - } - - array_ctor = gfc_constructor_next (array_ctor); - mask_ctor = gfc_constructor_next (mask_ctor); - } - } - - /* Append any left-over elements from VECTOR to RESULT. */ - while (vector_ctor) - { - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (vector_ctor->expr), - NULL); - vector_ctor = gfc_constructor_next (vector_ctor); - } - - result->shape = gfc_get_shape (1); - gfc_array_size (result, &result->shape[0]); - - if (array->ts.type == BT_CHARACTER) - result->ts.u.cl = array->ts.u.cl; - - return result; -} - - -static gfc_expr * -do_xor (gfc_expr *result, gfc_expr *e) -{ - gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); - gcc_assert (result->ts.type == BT_LOGICAL - && result->expr_type == EXPR_CONSTANT); - - result->value.logical = result->value.logical != e->value.logical; - return result; -} - - -gfc_expr * -gfc_simplify_is_contiguous (gfc_expr *array) -{ - if (gfc_is_simply_contiguous (array, false, true)) - return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1); - - if (gfc_is_not_contiguous (array)) - return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0); - - return NULL; -} - - -gfc_expr * -gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) -{ - return simplify_transformation (e, dim, NULL, 0, do_xor); -} - - -gfc_expr * -gfc_simplify_popcnt (gfc_expr *e) -{ - int res, k; - mpz_t x; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - k = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - /* Convert argument to unsigned, then count the '1' bits. */ - mpz_init_set (x, e->value.integer); - convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); - res = mpz_popcount (x); - mpz_clear (x); - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); -} - - -gfc_expr * -gfc_simplify_poppar (gfc_expr *e) -{ - gfc_expr *popcnt; - int i; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - popcnt = gfc_simplify_popcnt (e); - gcc_assert (popcnt); - - bool fail = gfc_extract_int (popcnt, &i); - gcc_assert (!fail); - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); -} - - -gfc_expr * -gfc_simplify_precision (gfc_expr *e) -{ - int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, - gfc_real_kinds[i].precision); -} - - -gfc_expr * -gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 1, gfc_multiply); -} - - -gfc_expr * -gfc_simplify_radix (gfc_expr *e) -{ - int i; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - switch (e->ts.type) - { - case BT_INTEGER: - i = gfc_integer_kinds[i].radix; - break; - - case BT_REAL: - i = gfc_real_kinds[i].radix; - break; - - default: - gcc_unreachable (); - } - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); -} - - -gfc_expr * -gfc_simplify_range (gfc_expr *e) -{ - int i; - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - - switch (e->ts.type) - { - case BT_INTEGER: - i = gfc_integer_kinds[i].range; - break; - - case BT_REAL: - case BT_COMPLEX: - i = gfc_real_kinds[i].range; - break; - - default: - gcc_unreachable (); - } - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); -} - - -gfc_expr * -gfc_simplify_rank (gfc_expr *e) -{ - /* Assumed rank. */ - if (e->rank == -1) - return NULL; - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); -} - - -gfc_expr * -gfc_simplify_real (gfc_expr *e, gfc_expr *k) -{ - gfc_expr *result = NULL; - int kind, tmp1, tmp2; - - /* Convert BOZ to real, and return without range checking. */ - if (e->ts.type == BT_BOZ) - { - /* Determine kind for conversion of the BOZ. */ - if (k) - gfc_extract_int (k, &kind); - else - kind = gfc_default_real_kind; - - if (!gfc_boz2real (e, kind)) - return NULL; - result = gfc_copy_expr (e); - return result; - } - - if (e->ts.type == BT_COMPLEX) - kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); - else - kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind); - - if (kind == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_convert_constant (e, BT_REAL, kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - if (result == &gfc_bad_expr) - return &gfc_bad_expr; - - return range_check (result, "REAL"); -} - - -gfc_expr * -gfc_simplify_realpart (gfc_expr *e) -{ - gfc_expr *result; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); - - return range_check (result, "REALPART"); -} - -gfc_expr * -gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) -{ - gfc_expr *result; - gfc_charlen_t len; - mpz_t ncopies; - bool have_length = false; - - /* If NCOPIES isn't a constant, there's nothing we can do. */ - if (n->expr_type != EXPR_CONSTANT) - return NULL; - - /* If NCOPIES is negative, it's an error. */ - if (mpz_sgn (n->value.integer) < 0) - { - gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", - &n->where); - return &gfc_bad_expr; - } - - /* If we don't know the character length, we can do no more. */ - if (e->ts.u.cl && e->ts.u.cl->length - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer); - have_length = true; - } - else if (e->expr_type == EXPR_CONSTANT - && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) - { - len = e->value.character.length; - } - else - return NULL; - - /* If the source length is 0, any value of NCOPIES is valid - and everything behaves as if NCOPIES == 0. */ - mpz_init (ncopies); - if (len == 0) - mpz_set_ui (ncopies, 0); - else - mpz_set (ncopies, n->value.integer); - - /* Check that NCOPIES isn't too large. */ - if (len) - { - mpz_t max, mlen; - int i; - - /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ - mpz_init (max); - i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); - - if (have_length) - { - mpz_tdiv_q (max, gfc_integer_kinds[i].huge, - e->ts.u.cl->length->value.integer); - } - else - { - mpz_init (mlen); - gfc_mpz_set_hwi (mlen, len); - mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); - mpz_clear (mlen); - } - - /* The check itself. */ - if (mpz_cmp (ncopies, max) > 0) - { - mpz_clear (max); - mpz_clear (ncopies); - gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", - &n->where); - return &gfc_bad_expr; - } - - mpz_clear (max); - } - mpz_clear (ncopies); - - /* For further simplification, we need the character string to be - constant. */ - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - HOST_WIDE_INT ncop; - if (len || - (e->ts.u.cl->length && - mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) - { - bool fail = gfc_extract_hwi (n, &ncop); - gcc_assert (!fail); - } - else - ncop = 0; - - if (ncop == 0) - return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); - - len = e->value.character.length; - gfc_charlen_t nlen = ncop * len; - - /* Here's a semi-arbitrary limit. If the string is longer than 1 GB - (2**28 elements * 4 bytes (wide chars) per element) defer to - runtime instead of consuming (unbounded) memory and CPU at - compile time. */ - if (nlen > 268435456) - { - gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L" - " deferred to runtime, expect bugs", &e->where); - return NULL; - } - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); - for (size_t i = 0; i < (size_t) ncop; i++) - for (size_t j = 0; j < (size_t) len; j++) - result->value.character.string[j+i*len]= e->value.character.string[j]; - - result->value.character.string[nlen] = '\0'; /* For debugger */ - return result; -} - - -/* This one is a bear, but mainly has to do with shuffling elements. */ - -gfc_expr * -gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, - gfc_expr *pad, gfc_expr *order_exp) -{ - int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; - int i, rank, npad, x[GFC_MAX_DIMENSIONS]; - mpz_t index, size; - unsigned long j; - size_t nsource; - gfc_expr *e, *result; - bool zerosize = false; - - /* Check that argument expression types are OK. */ - if (!is_constant_array_expr (source) - || !is_constant_array_expr (shape_exp) - || !is_constant_array_expr (pad) - || !is_constant_array_expr (order_exp)) - return NULL; - - if (source->shape == NULL) - return NULL; - - /* Proceed with simplification, unpacking the array. */ - - mpz_init (index); - rank = 0; - - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) - x[i] = 0; - - for (;;) - { - e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); - if (e == NULL) - break; - - gfc_extract_int (e, &shape[rank]); - - gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); - if (shape[rank] < 0) - { - gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a " - "negative value %d for dimension %d", - &shape_exp->where, shape[rank], rank+1); - return &gfc_bad_expr; - } - - rank++; - } - - gcc_assert (rank > 0); - - /* Now unpack the order array if present. */ - if (order_exp == NULL) - { - for (i = 0; i < rank; i++) - order[i] = i; - } - else - { - mpz_t size; - int order_size, shape_size; - - if (order_exp->rank != shape_exp->rank) - { - gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different", - &order_exp->where, &shape_exp->where); - return &gfc_bad_expr; - } - - gfc_array_size (shape_exp, &size); - shape_size = mpz_get_ui (size); - mpz_clear (size); - gfc_array_size (order_exp, &size); - order_size = mpz_get_ui (size); - mpz_clear (size); - if (order_size != shape_size) - { - gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different", - &order_exp->where, &shape_exp->where); - return &gfc_bad_expr; - } - - for (i = 0; i < rank; i++) - { - e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); - gcc_assert (e); - - gfc_extract_int (e, &order[i]); - - if (order[i] < 1 || order[i] > rank) - { - gfc_error ("Element with a value of %d in ORDER at %L must be " - "in the range [1, ..., %d] for the RESHAPE intrinsic " - "near %L", order[i], &order_exp->where, rank, - &shape_exp->where); - return &gfc_bad_expr; - } - - order[i]--; - if (x[order[i]] != 0) - { - gfc_error ("ORDER at %L is not a permutation of the size of " - "SHAPE at %L", &order_exp->where, &shape_exp->where); - return &gfc_bad_expr; - } - x[order[i]] = 1; - } - } - - /* Count the elements in the source and padding arrays. */ - - npad = 0; - if (pad != NULL) - { - gfc_array_size (pad, &size); - npad = mpz_get_ui (size); - mpz_clear (size); - } - - gfc_array_size (source, &size); - nsource = mpz_get_ui (size); - mpz_clear (size); - - /* If it weren't for that pesky permutation we could just loop - through the source and round out any shortage with pad elements. - But no, someone just had to have the compiler do something the - user should be doing. */ - - for (i = 0; i < rank; i++) - x[i] = 0; - - result = gfc_get_array_expr (source->ts.type, source->ts.kind, - &source->where); - if (source->ts.type == BT_DERIVED) - result->ts.u.derived = source->ts.u.derived; - if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL) - result->ts = source->ts; - result->rank = rank; - result->shape = gfc_get_shape (rank); - for (i = 0; i < rank; i++) - { - mpz_init_set_ui (result->shape[i], shape[i]); - if (shape[i] == 0) - zerosize = true; - } - - if (zerosize) - goto sizezero; - - while (nsource > 0 || npad > 0) - { - /* Figure out which element to extract. */ - mpz_set_ui (index, 0); - - for (i = rank - 1; i >= 0; i--) - { - mpz_add_ui (index, index, x[order[i]]); - if (i != 0) - mpz_mul_ui (index, index, shape[order[i - 1]]); - } - - if (mpz_cmp_ui (index, INT_MAX) > 0) - gfc_internal_error ("Reshaped array too large at %C"); - - j = mpz_get_ui (index); - - if (j < nsource) - e = gfc_constructor_lookup_expr (source->value.constructor, j); - else - { - if (npad <= 0) - { - mpz_clear (index); - return NULL; - } - j = j - nsource; - j = j % npad; - e = gfc_constructor_lookup_expr (pad->value.constructor, j); - } - gcc_assert (e); - - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (e), &e->where); - - /* Calculate the next element. */ - i = 0; - -inc: - if (++x[i] < shape[i]) - continue; - x[i++] = 0; - if (i < rank) - goto inc; - - break; - } - -sizezero: - - mpz_clear (index); - - return result; -} - - -gfc_expr * -gfc_simplify_rrspacing (gfc_expr *x) -{ - gfc_expr *result; - int i; - long int e, p; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - /* RRSPACING(+/- 0.0) = 0.0 */ - if (mpfr_zero_p (x->value.real)) - { - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - return result; - } - - /* RRSPACING(inf) = NaN */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - return result; - } - - /* RRSPACING(NaN) = same NaN */ - if (mpfr_nan_p (x->value.real)) - { - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - return result; - } - - /* | x * 2**(-e) | * 2**p. */ - mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); - e = - (long int) mpfr_get_exp (x->value.real); - mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); - - p = (long int) gfc_real_kinds[i].digits; - mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE); - - return range_check (result, "RRSPACING"); -} - - -gfc_expr * -gfc_simplify_scale (gfc_expr *x, gfc_expr *i) -{ - int k, neg_flag, power, exp_range; - mpfr_t scale, radix; - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - if (mpfr_zero_p (x->value.real)) - { - mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); - return result; - } - - k = gfc_validate_kind (BT_REAL, x->ts.kind, false); - - exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; - - /* This check filters out values of i that would overflow an int. */ - if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 - || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) - { - gfc_error ("Result of SCALE overflows its kind at %L", &result->where); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - /* Compute scale = radix ** power. */ - power = mpz_get_si (i->value.integer); - - if (power >= 0) - neg_flag = 0; - else - { - neg_flag = 1; - power = -power; - } - - gfc_set_model_kind (x->ts.kind); - mpfr_init (scale); - mpfr_init (radix); - mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE); - mpfr_pow_ui (scale, radix, power, GFC_RND_MODE); - - if (neg_flag) - mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE); - else - mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); - - mpfr_clears (scale, radix, NULL); - - return range_check (result, "SCALE"); -} - - -/* Variants of strspn and strcspn that operate on wide characters. */ - -static size_t -wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) -{ - size_t i = 0; - const gfc_char_t *c; - - while (s1[i]) - { - for (c = s2; *c; c++) - { - if (s1[i] == *c) - break; - } - if (*c == '\0') - break; - i++; - } - - return i; -} - -static size_t -wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) -{ - size_t i = 0; - const gfc_char_t *c; - - while (s1[i]) - { - for (c = s2; *c; c++) - { - if (s1[i] == *c) - break; - } - if (*c) - break; - i++; - } - - return i; -} - - -gfc_expr * -gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) -{ - gfc_expr *result; - int back; - size_t i; - size_t indx, len, lenc; - int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT - || ( b != NULL && b->expr_type != EXPR_CONSTANT)) - return NULL; - - if (b != NULL && b->value.logical != 0) - back = 1; - else - back = 0; - - len = e->value.character.length; - lenc = c->value.character.length; - - if (len == 0 || lenc == 0) - { - indx = 0; - } - else - { - if (back == 0) - { - indx = wide_strcspn (e->value.character.string, - c->value.character.string) + 1; - if (indx > len) - indx = 0; - } - else - for (indx = len; indx > 0; indx--) - { - for (i = 0; i < lenc; i++) - { - if (c->value.character.string[i] - == e->value.character.string[indx - 1]) - break; - } - if (i < lenc) - break; - } - } - - result = gfc_get_int_expr (k, &e->where, indx); - return range_check (result, "SCAN"); -} - - -gfc_expr * -gfc_simplify_selected_char_kind (gfc_expr *e) -{ - int kind; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - if (gfc_compare_with_Cstring (e, "ascii", false) == 0 - || gfc_compare_with_Cstring (e, "default", false) == 0) - kind = 1; - else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0) - kind = 4; - else - kind = -1; - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); -} - - -gfc_expr * -gfc_simplify_selected_int_kind (gfc_expr *e) -{ - int i, kind, range; - - if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range)) - return NULL; - - kind = INT_MAX; - - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].range >= range - && gfc_integer_kinds[i].kind < kind) - kind = gfc_integer_kinds[i].kind; - - if (kind == INT_MAX) - kind = -1; - - return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); -} - - -gfc_expr * -gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) -{ - int range, precision, radix, i, kind, found_precision, found_range, - found_radix; - locus *loc = &gfc_current_locus; - - if (p == NULL) - precision = 0; - else - { - if (p->expr_type != EXPR_CONSTANT - || gfc_extract_int (p, &precision)) - return NULL; - loc = &p->where; - } - - if (q == NULL) - range = 0; - else - { - if (q->expr_type != EXPR_CONSTANT - || gfc_extract_int (q, &range)) - return NULL; - - if (!loc) - loc = &q->where; - } - - if (rdx == NULL) - radix = 0; - else - { - if (rdx->expr_type != EXPR_CONSTANT - || gfc_extract_int (rdx, &radix)) - return NULL; - - if (!loc) - loc = &rdx->where; - } - - kind = INT_MAX; - found_precision = 0; - found_range = 0; - found_radix = 0; - - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - { - if (gfc_real_kinds[i].precision >= precision) - found_precision = 1; - - if (gfc_real_kinds[i].range >= range) - found_range = 1; - - if (radix == 0 || gfc_real_kinds[i].radix == radix) - found_radix = 1; - - if (gfc_real_kinds[i].precision >= precision - && gfc_real_kinds[i].range >= range - && (radix == 0 || gfc_real_kinds[i].radix == radix) - && gfc_real_kinds[i].kind < kind) - kind = gfc_real_kinds[i].kind; - } - - if (kind == INT_MAX) - { - if (found_radix && found_range && !found_precision) - kind = -1; - else if (found_radix && found_precision && !found_range) - kind = -2; - else if (found_radix && !found_precision && !found_range) - kind = -3; - else if (found_radix) - kind = -4; - else - kind = -5; - } - - return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); -} - - -gfc_expr * -gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) -{ - gfc_expr *result; - mpfr_t exp, absv, log2, pow2, frac; - unsigned long exp2; - - if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - /* SET_EXPONENT (+/-0.0, I) = +/- 0.0 - SET_EXPONENT (NaN) = same NaN */ - if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real)) - { - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - return result; - } - - /* SET_EXPONENT (inf) = NaN */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - return result; - } - - gfc_set_model_kind (x->ts.kind); - mpfr_init (absv); - mpfr_init (log2); - mpfr_init (exp); - mpfr_init (pow2); - mpfr_init (frac); - - mpfr_abs (absv, x->value.real, GFC_RND_MODE); - mpfr_log2 (log2, absv, GFC_RND_MODE); - - mpfr_trunc (log2, log2); - mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); - - /* Old exponent value, and fraction. */ - mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); - - mpfr_div (frac, absv, pow2, GFC_RND_MODE); - - /* New exponent. */ - exp2 = (unsigned long) mpz_get_d (i->value.integer); - mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE); - - mpfr_clears (absv, log2, pow2, frac, NULL); - - return range_check (result, "SET_EXPONENT"); -} - - -gfc_expr * -gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) -{ - mpz_t shape[GFC_MAX_DIMENSIONS]; - gfc_expr *result, *e, *f; - gfc_array_ref *ar; - int n; - bool t; - int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); - - if (source->rank == -1) - return NULL; - - result = gfc_get_array_expr (BT_INTEGER, k, &source->where); - result->shape = gfc_get_shape (1); - mpz_init (result->shape[0]); - - if (source->rank == 0) - return result; - - if (source->expr_type == EXPR_VARIABLE) - { - ar = gfc_find_array_ref (source); - t = gfc_array_ref_shape (ar, shape); - } - else if (source->shape) - { - t = true; - for (n = 0; n < source->rank; n++) - { - mpz_init (shape[n]); - mpz_set (shape[n], source->shape[n]); - } - } - else - t = false; - - for (n = 0; n < source->rank; n++) - { - e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); - - if (t) - mpz_set (e->value.integer, shape[n]); - else - { - mpz_set_ui (e->value.integer, n + 1); - - f = simplify_size (source, e, k); - gfc_free_expr (e); - if (f == NULL) - { - gfc_free_expr (result); - return NULL; - } - else - e = f; - } - - if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr) - { - gfc_free_expr (result); - if (t) - gfc_clear_shape (shape, source->rank); - return &gfc_bad_expr; - } - - gfc_constructor_append_expr (&result->value.constructor, e, NULL); - } - - if (t) - gfc_clear_shape (shape, source->rank); - - mpz_set_si (result->shape[0], source->rank); - - return result; -} - - -static gfc_expr * -simplify_size (gfc_expr *array, gfc_expr *dim, int k) -{ - mpz_t size; - gfc_expr *return_value; - int d; - gfc_ref *ref; - - /* For unary operations, the size of the result is given by the size - of the operand. For binary ones, it's the size of the first operand - unless it is scalar, then it is the size of the second. */ - if (array->expr_type == EXPR_OP && !array->value.op.uop) - { - gfc_expr* replacement; - gfc_expr* simplified; - - switch (array->value.op.op) - { - /* Unary operations. */ - case INTRINSIC_NOT: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - case INTRINSIC_PARENTHESES: - replacement = array->value.op.op1; - break; - - /* Binary operations. If any one of the operands is scalar, take - the other one's size. If both of them are arrays, it does not - matter -- try to find one with known shape, if possible. */ - default: - if (array->value.op.op1->rank == 0) - replacement = array->value.op.op2; - else if (array->value.op.op2->rank == 0) - replacement = array->value.op.op1; - else - { - simplified = simplify_size (array->value.op.op1, dim, k); - if (simplified) - return simplified; - - replacement = array->value.op.op2; - } - break; - } - - /* Try to reduce it directly if possible. */ - simplified = simplify_size (replacement, dim, k); - - /* Otherwise, we build a new SIZE call. This is hopefully at least - simpler than the original one. */ - if (!simplified) - { - gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k); - simplified = gfc_build_intrinsic_call (gfc_current_ns, - GFC_ISYM_SIZE, "size", - array->where, 3, - gfc_copy_expr (replacement), - gfc_copy_expr (dim), - kind); - } - return simplified; - } - - for (ref = array->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.as) - gfc_resolve_array_spec (ref->u.ar.as, 0); - - if (dim == NULL) - { - if (!gfc_array_size (array, &size)) - return NULL; - } - else - { - if (dim->expr_type != EXPR_CONSTANT) - return NULL; - - d = mpz_get_ui (dim->value.integer) - 1; - if (!gfc_array_dimen_size (array, d, &size)) - return NULL; - } - - return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where); - mpz_set (return_value->value.integer, size); - mpz_clear (size); - - return return_value; -} - - -gfc_expr * -gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - gfc_expr *result; - int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - result = simplify_size (array, dim, k); - if (result == NULL || result == &gfc_bad_expr) - return result; - - return range_check (result, "SIZE"); -} - - -/* SIZEOF and C_SIZEOF return the size in bytes of an array element - multiplied by the array size. */ - -gfc_expr * -gfc_simplify_sizeof (gfc_expr *x) -{ - gfc_expr *result = NULL; - mpz_t array_size; - size_t res_size; - - if (x->ts.type == BT_CLASS || x->ts.deferred) - return NULL; - - if (x->ts.type == BT_CHARACTER - && (!x->ts.u.cl || !x->ts.u.cl->length - || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) - return NULL; - - if (x->rank && x->expr_type != EXPR_ARRAY - && !gfc_array_size (x, &array_size)) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, - &x->where); - gfc_target_expr_size (x, &res_size); - mpz_set_si (result->value.integer, res_size); - - return result; -} - - -/* STORAGE_SIZE returns the size in bits of a single array element. */ - -gfc_expr * -gfc_simplify_storage_size (gfc_expr *x, - gfc_expr *kind) -{ - gfc_expr *result = NULL; - int k; - size_t siz; - - if (x->ts.type == BT_CLASS || x->ts.deferred) - return NULL; - - if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT - && (!x->ts.u.cl || !x->ts.u.cl->length - || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) - return NULL; - - k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind); - if (k == -1) - return &gfc_bad_expr; - - result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); - - gfc_element_size (x, &siz); - mpz_set_si (result->value.integer, siz); - mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); - - return range_check (result, "STORAGE_SIZE"); -} - - -gfc_expr * -gfc_simplify_sign (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_INTEGER: - mpz_abs (result->value.integer, x->value.integer); - if (mpz_sgn (y->value.integer) < 0) - mpz_neg (result->value.integer, result->value.integer); - break; - - case BT_REAL: - if (flag_sign_zero) - mpfr_copysign (result->value.real, x->value.real, y->value.real, - GFC_RND_MODE); - else - mpfr_setsign (result->value.real, x->value.real, - mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); - break; - - default: - gfc_internal_error ("Bad type in gfc_simplify_sign"); - } - - return result; -} - - -gfc_expr * -gfc_simplify_sin (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model (x->value.real); - mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("in gfc_simplify_sin(): Bad type"); - } - - return range_check (result, "SIN"); -} - - -gfc_expr * -gfc_simplify_sinh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "SINH"); -} - - -/* The argument is always a double precision real that is converted to - single precision. TODO: Rounding! */ - -gfc_expr * -gfc_simplify_sngl (gfc_expr *a) -{ - gfc_expr *result; - int tmp1, tmp2; - - if (a->expr_type != EXPR_CONSTANT) - return NULL; - - /* For explicit conversion, turn off -Wconversion and -Wconversion-extra - warnings. */ - tmp1 = warn_conversion; - tmp2 = warn_conversion_extra; - warn_conversion = warn_conversion_extra = 0; - - result = gfc_real2real (a, gfc_default_real_kind); - - warn_conversion = tmp1; - warn_conversion_extra = tmp2; - - return range_check (result, "SNGL"); -} - - -gfc_expr * -gfc_simplify_spacing (gfc_expr *x) -{ - gfc_expr *result; - int i; - long int en, ep; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - i = gfc_validate_kind (x->ts.type, x->ts.kind, false); - result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); - - /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */ - if (mpfr_zero_p (x->value.real)) - { - mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); - return result; - } - - /* SPACING(inf) = NaN */ - if (mpfr_inf_p (x->value.real)) - { - mpfr_set_nan (result->value.real); - return result; - } - - /* SPACING(NaN) = same NaN */ - if (mpfr_nan_p (x->value.real)) - { - mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); - return result; - } - - /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p - are the radix, exponent of x, and precision. This excludes the - possibility of subnormal numbers. Fortran 2003 states the result is - b**max(e - p, emin - 1). */ - - ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits; - en = (long int) gfc_real_kinds[i].min_exponent - 1; - en = en > ep ? en : ep; - - mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); - mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE); - - return range_check (result, "SPACING"); -} - - -gfc_expr * -gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr) -{ - gfc_expr *result = NULL; - int nelem, i, j, dim, ncopies; - mpz_t size; - - if ((!gfc_is_constant_expr (source) - && !is_constant_array_expr (source)) - || !gfc_is_constant_expr (dim_expr) - || !gfc_is_constant_expr (ncopies_expr)) - return NULL; - - gcc_assert (dim_expr->ts.type == BT_INTEGER); - gfc_extract_int (dim_expr, &dim); - dim -= 1; /* zero-base DIM */ - - gcc_assert (ncopies_expr->ts.type == BT_INTEGER); - gfc_extract_int (ncopies_expr, &ncopies); - ncopies = MAX (ncopies, 0); - - /* Do not allow the array size to exceed the limit for an array - constructor. */ - if (source->expr_type == EXPR_ARRAY) - { - if (!gfc_array_size (source, &size)) - gfc_internal_error ("Failure getting length of a constant array."); - } - else - mpz_init_set_ui (size, 1); - - nelem = mpz_get_si (size) * ncopies; - if (nelem > flag_max_array_constructor) - { - if (gfc_init_expr_flag) - { - gfc_error ("The number of elements (%d) in the array constructor " - "at %L requires an increase of the allowed %d upper " - "limit. See %<-fmax-array-constructor%> option.", - nelem, &source->where, flag_max_array_constructor); - return &gfc_bad_expr; - } - else - return NULL; - } - - if (source->expr_type == EXPR_CONSTANT - || source->expr_type == EXPR_STRUCTURE) - { - gcc_assert (dim == 0); - - result = gfc_get_array_expr (source->ts.type, source->ts.kind, - &source->where); - if (source->ts.type == BT_DERIVED) - result->ts.u.derived = source->ts.u.derived; - result->rank = 1; - result->shape = gfc_get_shape (result->rank); - mpz_init_set_si (result->shape[0], ncopies); - - for (i = 0; i < ncopies; ++i) - gfc_constructor_append_expr (&result->value.constructor, - gfc_copy_expr (source), NULL); - } - else if (source->expr_type == EXPR_ARRAY) - { - int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; - gfc_constructor *source_ctor; - - gcc_assert (source->rank < GFC_MAX_DIMENSIONS); - gcc_assert (dim >= 0 && dim <= source->rank); - - result = gfc_get_array_expr (source->ts.type, source->ts.kind, - &source->where); - if (source->ts.type == BT_DERIVED) - result->ts.u.derived = source->ts.u.derived; - result->rank = source->rank + 1; - result->shape = gfc_get_shape (result->rank); - - for (i = 0, j = 0; i < result->rank; ++i) - { - if (i != dim) - mpz_init_set (result->shape[i], source->shape[j++]); - else - mpz_init_set_si (result->shape[i], ncopies); - - extent[i] = mpz_get_si (result->shape[i]); - rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; - } - - offset = 0; - for (source_ctor = gfc_constructor_first (source->value.constructor); - source_ctor; source_ctor = gfc_constructor_next (source_ctor)) - { - for (i = 0; i < ncopies; ++i) - gfc_constructor_insert_expr (&result->value.constructor, - gfc_copy_expr (source_ctor->expr), - NULL, offset + i * rstride[dim]); - - offset += (dim == 0 ? ncopies : 1); - } - } - else - { - gfc_error ("Simplification of SPREAD at %C not yet implemented"); - return &gfc_bad_expr; - } - - if (source->ts.type == BT_CHARACTER) - result->ts.u.cl = source->ts.u.cl; - - return result; -} - - -gfc_expr * -gfc_simplify_sqrt (gfc_expr *e) -{ - gfc_expr *result = NULL; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - switch (e->ts.type) - { - case BT_REAL: - if (mpfr_cmp_si (e->value.real, 0) < 0) - { - gfc_error ("Argument of SQRT at %L has a negative value", - &e->where); - return &gfc_bad_expr; - } - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model (e->value.real); - - result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); - mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gfc_internal_error ("invalid argument of SQRT at %L", &e->where); - } - - return range_check (result, "SQRT"); -} - - -gfc_expr * -gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) -{ - return simplify_transformation (array, dim, mask, 0, gfc_add); -} - - -/* Simplify COTAN(X) where X has the unit of radian. */ - -gfc_expr * -gfc_simplify_cotan (gfc_expr *x) -{ - gfc_expr *result; - mpc_t swp, *val; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - /* There is no builtin mpc_cot, so compute cot = cos / sin. */ - val = &result->value.complex; - mpc_init2 (swp, mpfr_get_default_prec ()); - mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE, - GFC_MPC_RND_MODE); - mpc_div (*val, swp, *val, GFC_MPC_RND_MODE); - mpc_clear (swp); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "COTAN"); -} - - -gfc_expr * -gfc_simplify_tan (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "TAN"); -} - - -gfc_expr * -gfc_simplify_tanh (gfc_expr *x) -{ - gfc_expr *result; - - if (x->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - - switch (x->ts.type) - { - case BT_REAL: - mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); - break; - - default: - gcc_unreachable (); - } - - return range_check (result, "TANH"); -} - - -gfc_expr * -gfc_simplify_tiny (gfc_expr *e) -{ - gfc_expr *result; - int i; - - i = gfc_validate_kind (BT_REAL, e->ts.kind, false); - - result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); - mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); - - return result; -} - - -gfc_expr * -gfc_simplify_trailz (gfc_expr *e) -{ - unsigned long tz, bs; - int i; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - i = gfc_validate_kind (e->ts.type, e->ts.kind, false); - bs = gfc_integer_kinds[i].bit_size; - tz = mpz_scan1 (e->value.integer, 0); - - return gfc_get_int_expr (gfc_default_integer_kind, - &e->where, MIN (tz, bs)); -} - - -gfc_expr * -gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) -{ - gfc_expr *result; - gfc_expr *mold_element; - size_t source_size; - size_t result_size; - size_t buffer_size; - mpz_t tmp; - unsigned char *buffer; - size_t result_length; - - if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size)) - return NULL; - - if (!gfc_resolve_expr (mold)) - return NULL; - if (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) - return NULL; - - if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, - &result_size, &result_length)) - return NULL; - - /* Calculate the size of the source. */ - if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp)) - gfc_internal_error ("Failure getting length of a constant array."); - - /* Create an empty new expression with the appropriate characteristics. */ - result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, - &source->where); - result->ts = mold->ts; - - mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor) - ? gfc_constructor_first (mold->value.constructor)->expr - : mold; - - /* Set result character length, if needed. Note that this needs to be - set even for array expressions, in order to pass this information into - gfc_target_interpret_expr. */ - if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) - result->value.character.length = mold_element->value.character.length; - - /* Set the number of elements in the result, and determine its size. */ - - if (mold->expr_type == EXPR_ARRAY || mold->rank || size) - { - result->expr_type = EXPR_ARRAY; - result->rank = 1; - result->shape = gfc_get_shape (1); - mpz_init_set_ui (result->shape[0], result_length); - } - else - result->rank = 0; - - /* Allocate the buffer to store the binary version of the source. */ - buffer_size = MAX (source_size, result_size); - buffer = (unsigned char*)alloca (buffer_size); - memset (buffer, 0, buffer_size); - - /* Now write source to the buffer. */ - gfc_target_encode_expr (source, buffer, buffer_size); - - /* And read the buffer back into the new expression. */ - gfc_target_interpret_expr (buffer, buffer_size, result, false); - - return result; -} - - -gfc_expr * -gfc_simplify_transpose (gfc_expr *matrix) -{ - int row, matrix_rows, col, matrix_cols; - gfc_expr *result; - - if (!is_constant_array_expr (matrix)) - return NULL; - - gcc_assert (matrix->rank == 2); - - if (matrix->shape == NULL) - return NULL; - - result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, - &matrix->where); - result->rank = 2; - result->shape = gfc_get_shape (result->rank); - mpz_init_set (result->shape[0], matrix->shape[1]); - mpz_init_set (result->shape[1], matrix->shape[0]); - - if (matrix->ts.type == BT_CHARACTER) - result->ts.u.cl = matrix->ts.u.cl; - else if (matrix->ts.type == BT_DERIVED) - result->ts.u.derived = matrix->ts.u.derived; - - matrix_rows = mpz_get_si (matrix->shape[0]); - matrix_cols = mpz_get_si (matrix->shape[1]); - for (row = 0; row < matrix_rows; ++row) - for (col = 0; col < matrix_cols; ++col) - { - gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, - col * matrix_rows + row); - gfc_constructor_insert_expr (&result->value.constructor, - gfc_copy_expr (e), &matrix->where, - row * matrix_cols + col); - } - - return result; -} - - -gfc_expr * -gfc_simplify_trim (gfc_expr *e) -{ - gfc_expr *result; - int count, i, len, lentrim; - - if (e->expr_type != EXPR_CONSTANT) - return NULL; - - len = e->value.character.length; - for (count = 0, i = 1; i <= len; ++i) - { - if (e->value.character.string[len - i] == ' ') - count++; - else - break; - } - - lentrim = len - count; - - result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); - for (i = 0; i < lentrim; i++) - result->value.character.string[i] = e->value.character.string[i]; - - return result; -} - - -gfc_expr * -gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) -{ - gfc_expr *result; - gfc_ref *ref; - gfc_array_spec *as; - gfc_constructor *sub_cons; - bool first_image; - int d; - - if (!is_constant_array_expr (sub)) - return NULL; - - /* Follow any component references. */ - as = coarray->symtree->n.sym->as; - for (ref = coarray->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - as = ref->u.ar.as; - - if (as->type == AS_DEFERRED) - return NULL; - - /* "valid sequence of cosubscripts" are required; thus, return 0 unless - the cosubscript addresses the first image. */ - - sub_cons = gfc_constructor_first (sub->value.constructor); - first_image = true; - - for (d = 1; d <= as->corank; d++) - { - gfc_expr *ca_bound; - int cmp; - - gcc_assert (sub_cons != NULL); - - ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, - NULL, true); - if (ca_bound == NULL) - return NULL; - - if (ca_bound == &gfc_bad_expr) - return ca_bound; - - cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); - - if (cmp == 0) - { - gfc_free_expr (ca_bound); - sub_cons = gfc_constructor_next (sub_cons); - continue; - } - - first_image = false; - - if (cmp > 0) - { - gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " - "SUB has %ld and COARRAY lower bound is %ld)", - &coarray->where, d, - mpz_get_si (sub_cons->expr->value.integer), - mpz_get_si (ca_bound->value.integer)); - gfc_free_expr (ca_bound); - return &gfc_bad_expr; - } - - gfc_free_expr (ca_bound); - - /* Check whether upperbound is valid for the multi-images case. */ - if (d < as->corank) - { - ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, - NULL, true); - if (ca_bound == &gfc_bad_expr) - return ca_bound; - - if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT - && mpz_cmp (ca_bound->value.integer, - sub_cons->expr->value.integer) < 0) - { - gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " - "SUB has %ld and COARRAY upper bound is %ld)", - &coarray->where, d, - mpz_get_si (sub_cons->expr->value.integer), - mpz_get_si (ca_bound->value.integer)); - gfc_free_expr (ca_bound); - return &gfc_bad_expr; - } - - if (ca_bound) - gfc_free_expr (ca_bound); - } - - sub_cons = gfc_constructor_next (sub_cons); - } - - gcc_assert (sub_cons == NULL); - - if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image) - return NULL; - - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &gfc_current_locus); - if (first_image) - mpz_set_si (result->value.integer, 1); - else - mpz_set_si (result->value.integer, 0); - - return result; -} - -gfc_expr * -gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) -{ - if (flag_coarray == GFC_FCOARRAY_NONE) - { - gfc_current_locus = *gfc_current_intrinsic_where; - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); - return &gfc_bad_expr; - } - - /* Simplification is possible for fcoarray = single only. For all other modes - the result depends on runtime conditions. */ - if (flag_coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - if (gfc_is_constant_expr (image)) - { - gfc_expr *result; - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &image->where); - if (mpz_get_si (image->value.integer) == 1) - mpz_set_si (result->value.integer, 0); - else - mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE); - return result; - } - else - return NULL; -} - - -gfc_expr * -gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) -{ - if (flag_coarray != GFC_FCOARRAY_SINGLE) - return NULL; - - /* If no coarray argument has been passed or when the first argument - is actually a distance argment. */ - if (coarray == NULL || !gfc_is_coarray (coarray)) - { - gfc_expr *result; - /* FIXME: gfc_current_locus is wrong. */ - result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, - &gfc_current_locus); - mpz_set_si (result->value.integer, 1); - return result; - } - - /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ - return simplify_cobound (coarray, dim, NULL, 0); -} - - -gfc_expr * -gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_bound (array, dim, kind, 1); -} - -gfc_expr * -gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) -{ - return simplify_cobound (array, dim, kind, 1); -} - - -gfc_expr * -gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) -{ - gfc_expr *result, *e; - gfc_constructor *vector_ctor, *mask_ctor, *field_ctor; - - if (!is_constant_array_expr (vector) - || !is_constant_array_expr (mask) - || (!gfc_is_constant_expr (field) - && !is_constant_array_expr (field))) - return NULL; - - result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, - &vector->where); - if (vector->ts.type == BT_DERIVED) - result->ts.u.derived = vector->ts.u.derived; - result->rank = mask->rank; - result->shape = gfc_copy_shape (mask->shape, mask->rank); - - if (vector->ts.type == BT_CHARACTER) - result->ts.u.cl = vector->ts.u.cl; - - vector_ctor = gfc_constructor_first (vector->value.constructor); - mask_ctor = gfc_constructor_first (mask->value.constructor); - field_ctor - = field->expr_type == EXPR_ARRAY - ? gfc_constructor_first (field->value.constructor) - : NULL; - - while (mask_ctor) - { - if (mask_ctor->expr->value.logical) - { - gcc_assert (vector_ctor); - e = gfc_copy_expr (vector_ctor->expr); - vector_ctor = gfc_constructor_next (vector_ctor); - } - else if (field->expr_type == EXPR_ARRAY) - e = gfc_copy_expr (field_ctor->expr); - else - e = gfc_copy_expr (field); - - gfc_constructor_append_expr (&result->value.constructor, e, NULL); - - mask_ctor = gfc_constructor_next (mask_ctor); - field_ctor = gfc_constructor_next (field_ctor); - } - - return result; -} - - -gfc_expr * -gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) -{ - gfc_expr *result; - int back; - size_t index, len, lenset; - size_t i; - int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind); - - if (k == -1) - return &gfc_bad_expr; - - if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT - || ( b != NULL && b->expr_type != EXPR_CONSTANT)) - return NULL; - - if (b != NULL && b->value.logical != 0) - back = 1; - else - back = 0; - - result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); - - len = s->value.character.length; - lenset = set->value.character.length; - - if (len == 0) - { - mpz_set_ui (result->value.integer, 0); - return result; - } - - if (back == 0) - { - if (lenset == 0) - { - mpz_set_ui (result->value.integer, 1); - return result; - } - - index = wide_strspn (s->value.character.string, - set->value.character.string) + 1; - if (index > len) - index = 0; - - } - else - { - if (lenset == 0) - { - mpz_set_ui (result->value.integer, len); - return result; - } - for (index = len; index > 0; index --) - { - for (i = 0; i < lenset; i++) - { - if (s->value.character.string[index - 1] - == set->value.character.string[i]) - break; - } - if (i == lenset) - break; - } - } - - mpz_set_ui (result->value.integer, index); - return result; -} - - -gfc_expr * -gfc_simplify_xor (gfc_expr *x, gfc_expr *y) -{ - gfc_expr *result; - int kind; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; - - switch (x->ts.type) - { - case BT_INTEGER: - result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); - mpz_xor (result->value.integer, x->value.integer, y->value.integer); - return range_check (result, "XOR"); - - case BT_LOGICAL: - return gfc_get_logical_expr (kind, &x->where, - (x->value.logical && !y->value.logical) - || (!x->value.logical && y->value.logical)); - - default: - gcc_unreachable (); - } -} - - -/****************** Constant simplification *****************/ - -/* Master function to convert one constant to another. While this is - used as a simplification function, it requires the destination type - and kind information which is supplied by a special case in - do_simplify(). */ - -gfc_expr * -gfc_convert_constant (gfc_expr *e, bt type, int kind) -{ - gfc_expr *result, *(*f) (gfc_expr *, int); - gfc_constructor *c, *t; - - switch (e->ts.type) - { - case BT_INTEGER: - switch (type) - { - case BT_INTEGER: - f = gfc_int2int; - break; - case BT_REAL: - f = gfc_int2real; - break; - case BT_COMPLEX: - f = gfc_int2complex; - break; - case BT_LOGICAL: - f = gfc_int2log; - break; - default: - goto oops; - } - break; - - case BT_REAL: - switch (type) - { - case BT_INTEGER: - f = gfc_real2int; - break; - case BT_REAL: - f = gfc_real2real; - break; - case BT_COMPLEX: - f = gfc_real2complex; - break; - default: - goto oops; - } - break; - - case BT_COMPLEX: - switch (type) - { - case BT_INTEGER: - f = gfc_complex2int; - break; - case BT_REAL: - f = gfc_complex2real; - break; - case BT_COMPLEX: - f = gfc_complex2complex; - break; - - default: - goto oops; - } - break; - - case BT_LOGICAL: - switch (type) - { - case BT_INTEGER: - f = gfc_log2int; - break; - case BT_LOGICAL: - f = gfc_log2log; - break; - default: - goto oops; - } - break; - - case BT_HOLLERITH: - switch (type) - { - case BT_INTEGER: - f = gfc_hollerith2int; - break; - - case BT_REAL: - f = gfc_hollerith2real; - break; - - case BT_COMPLEX: - f = gfc_hollerith2complex; - break; - - case BT_CHARACTER: - f = gfc_hollerith2character; - break; - - case BT_LOGICAL: - f = gfc_hollerith2logical; - break; - - default: - goto oops; - } - break; - - case BT_CHARACTER: - switch (type) - { - case BT_INTEGER: - f = gfc_character2int; - break; - - case BT_REAL: - f = gfc_character2real; - break; - - case BT_COMPLEX: - f = gfc_character2complex; - break; - - case BT_CHARACTER: - f = gfc_character2character; - break; - - case BT_LOGICAL: - f = gfc_character2logical; - break; - - default: - goto oops; - } - break; - - default: - oops: - return &gfc_bad_expr; - } - - result = NULL; - - switch (e->expr_type) - { - case EXPR_CONSTANT: - result = f (e, kind); - if (result == NULL) - return &gfc_bad_expr; - break; - - case EXPR_ARRAY: - if (!gfc_is_constant_expr (e)) - break; - - result = gfc_get_array_expr (type, kind, &e->where); - result->shape = gfc_copy_shape (e->shape, e->rank); - result->rank = e->rank; - - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - { - gfc_expr *tmp; - if (c->iterator == NULL) - { - if (c->expr->expr_type == EXPR_ARRAY) - tmp = gfc_convert_constant (c->expr, type, kind); - else if (c->expr->expr_type == EXPR_OP) - { - if (!gfc_simplify_expr (c->expr, 1)) - return &gfc_bad_expr; - tmp = f (c->expr, kind); - } - else - tmp = f (c->expr, kind); - } - else - tmp = gfc_convert_constant (c->expr, type, kind); - - if (tmp == NULL || tmp == &gfc_bad_expr) - { - gfc_free_expr (result); - return NULL; - } - - t = gfc_constructor_append_expr (&result->value.constructor, - tmp, &c->where); - if (c->iterator) - t->iterator = gfc_copy_iterator (c->iterator); - } - - break; - - default: - break; - } - - return result; -} - - -/* Function for converting character constants. */ -gfc_expr * -gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) -{ - gfc_expr *result; - int i; - - if (!gfc_is_constant_expr (e)) - return NULL; - - if (e->expr_type == EXPR_CONSTANT) - { - /* Simple case of a scalar. */ - result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); - if (result == NULL) - return &gfc_bad_expr; - - result->value.character.length = e->value.character.length; - result->value.character.string - = gfc_get_wide_string (e->value.character.length + 1); - memcpy (result->value.character.string, e->value.character.string, - (e->value.character.length + 1) * sizeof (gfc_char_t)); - - /* Check we only have values representable in the destination kind. */ - for (i = 0; i < result->value.character.length; i++) - if (!gfc_check_character_range (result->value.character.string[i], - kind)) - { - gfc_error ("Character %qs in string at %L cannot be converted " - "into character kind %d", - gfc_print_wide_char (result->value.character.string[i]), - &e->where, kind); - gfc_free_expr (result); - return &gfc_bad_expr; - } - - return result; - } - else if (e->expr_type == EXPR_ARRAY) - { - /* For an array constructor, we convert each constructor element. */ - gfc_constructor *c; - - result = gfc_get_array_expr (type, kind, &e->where); - result->shape = gfc_copy_shape (e->shape, e->rank); - result->rank = e->rank; - result->ts.u.cl = e->ts.u.cl; - - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - { - gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); - if (tmp == &gfc_bad_expr) - { - gfc_free_expr (result); - return &gfc_bad_expr; - } - - if (tmp == NULL) - { - gfc_free_expr (result); - return NULL; - } - - gfc_constructor_append_expr (&result->value.constructor, - tmp, &c->where); - } - - return result; - } - else - return NULL; -} - - -gfc_expr * -gfc_simplify_compiler_options (void) -{ - char *str; - gfc_expr *result; - - str = gfc_get_option_string (); - result = gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, str, strlen (str)); - free (str); - return result; -} - - -gfc_expr * -gfc_simplify_compiler_version (void) -{ - char *buffer; - size_t len; - - len = strlen ("GCC version ") + strlen (version_string); - buffer = XALLOCAVEC (char, len + 1); - snprintf (buffer, len + 1, "GCC version %s", version_string); - return gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, buffer, len); -} - -/* Simplification routines for intrinsics of IEEE modules. */ - -gfc_expr * -simplify_ieee_selected_real_kind (gfc_expr *expr) -{ - gfc_actual_arglist *arg; - gfc_expr *p = NULL, *q = NULL, *rdx = NULL; - - arg = expr->value.function.actual; - p = arg->expr; - if (arg->next) - { - q = arg->next->expr; - if (arg->next->next) - rdx = arg->next->next->expr; - } - - /* Currently, if IEEE is supported and this module is built, it means - all our floating-point types conform to IEEE. Hence, we simply handle - IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */ - return gfc_simplify_selected_real_kind (p, q, rdx); -} - -gfc_expr * -simplify_ieee_support (gfc_expr *expr) -{ - /* We consider that if the IEEE modules are loaded, we have full support - for flags, halting and rounding, which are the three functions - (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant - expressions. One day, we will need libgfortran to detect support and - communicate it back to us, allowing for partial support. */ - - return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where, - true); -} - -bool -matches_ieee_function_name (gfc_symbol *sym, const char *name) -{ - int n = strlen(name); - - if (!strncmp(sym->name, name, n)) - return true; - - /* If a generic was used and renamed, we need more work to find out. - Compare the specific name. */ - if (sym->generic && !strncmp(sym->generic->sym->name, name, n)) - return true; - - return false; -} - -gfc_expr * -gfc_simplify_ieee_functions (gfc_expr *expr) -{ - gfc_symbol* sym = expr->symtree->n.sym; - - if (matches_ieee_function_name(sym, "ieee_selected_real_kind")) - return simplify_ieee_selected_real_kind (expr); - else if (matches_ieee_function_name(sym, "ieee_support_flag") - || matches_ieee_function_name(sym, "ieee_support_halting") - || matches_ieee_function_name(sym, "ieee_support_rounding")) - return simplify_ieee_support (expr); - else - return NULL; -} diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc new file mode 100644 index 0000000..cc7d33a --- /dev/null +++ b/gcc/fortran/simplify.cc @@ -0,0 +1,8966 @@ +/* Simplify intrinsic functions at compile-time. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" /* For BITS_PER_UNIT. */ +#include "gfortran.h" +#include "arith.h" +#include "intrinsic.h" +#include "match.h" +#include "target-memory.h" +#include "constructor.h" +#include "version.h" /* For version_string. */ + +/* Prototypes. */ + +static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false); + +gfc_expr gfc_bad_expr; + +static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int); + + +/* Note that 'simplification' is not just transforming expressions. + For functions that are not simplified at compile time, range + checking is done if possible. + + The return convention is that each simplification function returns: + + A new expression node corresponding to the simplified arguments. + The original arguments are destroyed by the caller, and must not + be a part of the new expression. + + NULL pointer indicating that no simplification was possible and + the original expression should remain intact. + + An expression pointer to gfc_bad_expr (a static placeholder) + indicating that some error has prevented simplification. The + error is generated within the function and should be propagated + upwards + + By the time a simplification function gets control, it has been + decided that the function call is really supposed to be the + intrinsic. No type checking is strictly necessary, since only + valid types will be passed on. On the other hand, a simplification + subroutine may have to look at the type of an argument as part of + its processing. + + Array arguments are only passed to these subroutines that implement + the simplification of transformational intrinsics. + + The functions in this file don't have much comment with them, but + everything is reasonably straight-forward. The Standard, chapter 13 + is the best comment you'll find for this file anyway. */ + +/* Range checks an expression node. If all goes well, returns the + node, otherwise returns &gfc_bad_expr and frees the node. */ + +static gfc_expr * +range_check (gfc_expr *result, const char *name) +{ + if (result == NULL) + return &gfc_bad_expr; + + if (result->expr_type != EXPR_CONSTANT) + return result; + + switch (gfc_range_check (result)) + { + case ARITH_OK: + return result; + + case ARITH_OVERFLOW: + gfc_error ("Result of %s overflows its kind at %L", name, + &result->where); + break; + + case ARITH_UNDERFLOW: + gfc_error ("Result of %s underflows its kind at %L", name, + &result->where); + break; + + case ARITH_NAN: + gfc_error ("Result of %s is NaN at %L", name, &result->where); + break; + + default: + gfc_error ("Result of %s gives range error for its kind at %L", name, + &result->where); + break; + } + + gfc_free_expr (result); + return &gfc_bad_expr; +} + + +/* A helper function that gets an optional and possibly missing + kind parameter. Returns the kind, -1 if something went wrong. */ + +static int +get_kind (bt type, gfc_expr *k, const char *name, int default_kind) +{ + int kind; + + if (k == NULL) + return default_kind; + + if (k->expr_type != EXPR_CONSTANT) + { + gfc_error ("KIND parameter of %s at %L must be an initialization " + "expression", name, &k->where); + return -1; + } + + if (gfc_extract_int (k, &kind) + || gfc_validate_kind (type, kind, true) < 0) + { + gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); + return -1; + } + + return kind; +} + + +/* Converts an mpz_t signed variable into an unsigned one, assuming + two's complement representations and a binary width of bitsize. + The conversion is a no-op unless x is negative; otherwise, it can + be accomplished by masking out the high bits. */ + +static void +convert_mpz_to_unsigned (mpz_t x, int bitsize) +{ + mpz_t mask; + + if (mpz_sgn (x) < 0) + { + /* Confirm that no bits above the signed range are unset if we + are doing range checking. */ + if (flag_range_check != 0) + gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX); + + mpz_init_set_ui (mask, 1); + mpz_mul_2exp (mask, mask, bitsize); + mpz_sub_ui (mask, mask, 1); + + mpz_and (x, x, mask); + + mpz_clear (mask); + } + else + { + /* Confirm that no bits above the signed range are set if we + are doing range checking. */ + if (flag_range_check != 0) + gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX); + } +} + + +/* Converts an mpz_t unsigned variable into a signed one, assuming + two's complement representations and a binary width of bitsize. + If the bitsize-1 bit is set, this is taken as a sign bit and + the number is converted to the corresponding negative number. */ + +void +gfc_convert_mpz_to_signed (mpz_t x, int bitsize) +{ + mpz_t mask; + + /* Confirm that no bits above the unsigned range are set if we are + doing range checking. */ + if (flag_range_check != 0) + gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX); + + if (mpz_tstbit (x, bitsize - 1) == 1) + { + mpz_init_set_ui (mask, 1); + mpz_mul_2exp (mask, mask, bitsize); + mpz_sub_ui (mask, mask, 1); + + /* We negate the number by hand, zeroing the high bits, that is + make it the corresponding positive number, and then have it + negated by GMP, giving the correct representation of the + negative number. */ + mpz_com (x, x); + mpz_add_ui (x, x, 1); + mpz_and (x, x, mask); + + mpz_neg (x, x); + + mpz_clear (mask); + } +} + + +/* Test that the expression is a constant array, simplifying if + we are dealing with a parameter array. */ + +static bool +is_constant_array_expr (gfc_expr *e) +{ + gfc_constructor *c; + bool array_OK = true; + mpz_t size; + + if (e == NULL) + return true; + + if (e->expr_type == EXPR_VARIABLE && e->rank > 0 + && e->symtree->n.sym->attr.flavor == FL_PARAMETER) + gfc_simplify_expr (e, 1); + + if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) + return false; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->expr->expr_type != EXPR_CONSTANT + && c->expr->expr_type != EXPR_STRUCTURE) + { + array_OK = false; + break; + } + + /* Check and expand the constructor. */ + if (!array_OK && gfc_init_expr_flag && e->rank == 1) + { + array_OK = gfc_reduce_init_expr (e); + /* gfc_reduce_init_expr resets the flag. */ + gfc_init_expr_flag = true; + } + else + return array_OK; + + /* Recheck to make sure that any EXPR_ARRAYs have gone. */ + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->expr->expr_type != EXPR_CONSTANT + && c->expr->expr_type != EXPR_STRUCTURE) + return false; + + /* Make sure that the array has a valid shape. */ + if (e->shape == NULL && e->rank == 1) + { + if (!gfc_array_size(e, &size)) + return false; + e->shape = gfc_get_shape (1); + mpz_init_set (e->shape[0], size); + mpz_clear (size); + } + + return array_OK; +} + +/* Test for a size zero array. */ +bool +gfc_is_size_zero_array (gfc_expr *array) +{ + + if (array->rank == 0) + return false; + + if (array->expr_type == EXPR_VARIABLE && array->rank > 0 + && array->symtree->n.sym->attr.flavor == FL_PARAMETER + && array->shape != NULL) + { + for (int i = 0; i < array->rank; i++) + if (mpz_cmp_si (array->shape[i], 0) <= 0) + return true; + + return false; + } + + if (array->expr_type == EXPR_ARRAY) + return array->value.constructor == NULL; + + return false; +} + + +/* Initialize a transformational result expression with a given value. */ + +static void +init_result_expr (gfc_expr *e, int init, gfc_expr *array) +{ + if (e && e->expr_type == EXPR_ARRAY) + { + gfc_constructor *ctor = gfc_constructor_first (e->value.constructor); + while (ctor) + { + init_result_expr (ctor->expr, init, array); + ctor = gfc_constructor_next (ctor); + } + } + else if (e && e->expr_type == EXPR_CONSTANT) + { + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + HOST_WIDE_INT length; + gfc_char_t *string; + + switch (e->ts.type) + { + case BT_LOGICAL: + e->value.logical = (init ? 1 : 0); + break; + + case BT_INTEGER: + if (init == INT_MIN) + mpz_set (e->value.integer, gfc_integer_kinds[i].min_int); + else if (init == INT_MAX) + mpz_set (e->value.integer, gfc_integer_kinds[i].huge); + else + mpz_set_si (e->value.integer, init); + break; + + case BT_REAL: + if (init == INT_MIN) + { + mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE); + } + else if (init == INT_MAX) + mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + else + mpfr_set_si (e->value.real, init, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE); + break; + + case BT_CHARACTER: + if (init == INT_MIN) + { + gfc_expr *len = gfc_simplify_len (array, NULL); + gfc_extract_hwi (len, &length); + string = gfc_get_wide_string (length + 1); + gfc_wide_memset (string, 0, length); + } + else if (init == INT_MAX) + { + gfc_expr *len = gfc_simplify_len (array, NULL); + gfc_extract_hwi (len, &length); + string = gfc_get_wide_string (length + 1); + gfc_wide_memset (string, 255, length); + } + else + { + length = 0; + string = gfc_get_wide_string (1); + } + + string[length] = '\0'; + e->value.character.length = length; + e->value.character.string = string; + break; + + default: + gcc_unreachable(); + } + } + else + gcc_unreachable(); +} + + +/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul; + if conj_a is true, the matrix_a is complex conjugated. */ + +static gfc_expr * +compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a, + gfc_expr *matrix_b, int stride_b, int offset_b, + bool conj_a) +{ + gfc_expr *result, *a, *b, *c; + + /* Set result to an INTEGER(1) 0 for numeric types and .false. for + LOGICAL. Mixed-mode math in the loop will promote result to the + correct type and kind. */ + if (matrix_a->ts.type == BT_LOGICAL) + result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); + else + result = gfc_get_int_expr (1, NULL, 0); + result->where = matrix_a->where; + + a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); + b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); + while (a && b) + { + /* Copying of expressions is required as operands are free'd + by the gfc_arith routines. */ + switch (result->ts.type) + { + case BT_LOGICAL: + result = gfc_or (result, + gfc_and (gfc_copy_expr (a), + gfc_copy_expr (b))); + break; + + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + if (conj_a && a->ts.type == BT_COMPLEX) + c = gfc_simplify_conjg (a); + else + c = gfc_copy_expr (a); + result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b))); + break; + + default: + gcc_unreachable(); + } + + offset_a += stride_a; + a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a); + + offset_b += stride_b; + b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b); + } + + return result; +} + + +/* Build a result expression for transformational intrinsics, + depending on DIM. */ + +static gfc_expr * +transformational_result (gfc_expr *array, gfc_expr *dim, bt type, + int kind, locus* where) +{ + gfc_expr *result; + int i, nelem; + + if (!dim || array->rank == 1) + return gfc_get_constant_expr (type, kind, where); + + result = gfc_get_array_expr (type, kind, where); + result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim); + result->rank = array->rank - 1; + + /* gfc_array_size() would count the number of elements in the constructor, + we have not built those yet. */ + nelem = 1; + for (i = 0; i < result->rank; ++i) + nelem *= mpz_get_ui (result->shape[i]); + + for (i = 0; i < nelem; ++i) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_get_constant_expr (type, kind, where), + NULL); + } + + return result; +} + + +typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); + +/* Wrapper function, implements 'op1 += 1'. Only called if MASK + of COUNT intrinsic is .TRUE.. + + Interface and implementation mimics arith functions as + gfc_add, gfc_multiply, etc. */ + +static gfc_expr * +gfc_count (gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *result; + + gcc_assert (op1->ts.type == BT_INTEGER); + gcc_assert (op2->ts.type == BT_LOGICAL); + gcc_assert (op2->value.logical); + + result = gfc_copy_expr (op1); + mpz_add_ui (result->value.integer, result->value.integer, 1); + + gfc_free_expr (op1); + gfc_free_expr (op2); + return result; +} + + +/* Transforms an ARRAY with operation OP, according to MASK, to a + scalar RESULT. E.g. called if + + REAL, PARAMETER :: array(n, m) = ... + REAL, PARAMETER :: s = SUM(array) + + where OP == gfc_add(). */ + +static gfc_expr * +simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, + transformational_op op) +{ + gfc_expr *a, *m; + gfc_constructor *array_ctor, *mask_ctor; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + array_ctor = gfc_constructor_first (array->value.constructor); + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + + while (array_ctor) + { + a = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + + /* A constant MASK equals .TRUE. here and can be ignored. */ + if (mask_ctor) + { + m = mask_ctor->expr; + mask_ctor = gfc_constructor_next (mask_ctor); + if (!m->value.logical) + continue; + } + + result = op (result, gfc_copy_expr (a)); + if (!result) + return result; + } + + return result; +} + +/* Transforms an ARRAY with operation OP, according to MASK, to an + array RESULT. E.g. called if + + REAL, PARAMETER :: array(n, m) = ... + REAL, PARAMETER :: s(n) = PROD(array, DIM=1) + + where OP == gfc_multiply(). + The result might be post processed using post_op. */ + +static gfc_expr * +simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim, + gfc_expr *mask, transformational_op op, + transformational_op post_op) +{ + mpz_t size; + int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; + gfc_expr **arrayvec, **resultvec, **base, **src, **dest; + gfc_constructor *array_ctor, *mask_ctor, *result_ctor; + + int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], + tmpstride[GFC_MAX_DIMENSIONS]; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + /* Build an indexed table for array element expressions to minimize + linked-list traversal. Masked elements are set to NULL. */ + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + arrayvec = XCNEWVEC (gfc_expr*, arraysize); + + array_ctor = gfc_constructor_first (array->value.constructor); + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + + for (i = 0; i < arraysize; ++i) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + + if (mask_ctor) + { + if (!mask_ctor->expr->value.logical) + arrayvec[i] = NULL; + + mask_ctor = gfc_constructor_next (mask_ctor); + } + } + + /* Same for the result expression. */ + gfc_array_size (result, &size); + resultsize = mpz_get_ui (size); + mpz_clear (size); + + resultvec = XCNEWVEC (gfc_expr*, resultsize); + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + resultvec[i] = result_ctor->expr; + result_ctor = gfc_constructor_next (result_ctor); + } + + gfc_extract_int (dim, &dim_index); + dim_index -= 1; /* zero-base index */ + dim_extent = 0; + dim_stride = 0; + + for (i = 0, n = 0; i < array->rank; ++i) + { + count[i] = 0; + tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); + if (i == dim_index) + { + dim_extent = mpz_get_si (array->shape[i]); + dim_stride = tmpstride[i]; + continue; + } + + extent[n] = mpz_get_si (array->shape[i]); + sstride[n] = tmpstride[i]; + dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; + n += 1; + } + + done = resultsize <= 0; + base = arrayvec; + dest = resultvec; + while (!done) + { + for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) + if (*src) + *dest = op (*dest, gfc_copy_expr (*src)); + + if (post_op) + *dest = post_op (*dest, *dest); + + count[0]++; + base += sstride[0]; + dest += dstride[0]; + + n = 0; + while (!done && count[n] == extent[n]) + { + count[n] = 0; + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + + n++; + if (n < result->rank) + { + /* If the nested loop is unrolled GFC_MAX_DIMENSIONS + times, we'd warn for the last iteration, because the + array index will have already been incremented to the + array sizes, and we can't tell that this must make + the test against result->rank false, because ranks + must not exceed GFC_MAX_DIMENSIONS. */ + GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) + count[n]++; + base += sstride[n]; + dest += dstride[n]; + GCC_DIAGNOSTIC_POP + } + else + done = true; + } + } + + /* Place updated expression in result constructor. */ + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); + } + + free (arrayvec); + free (resultvec); + return result; +} + + +static gfc_expr * +simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, + int init_val, transformational_op op) +{ + gfc_expr *result; + bool size_zero; + + size_zero = gfc_is_size_zero_array (array); + + if (!(is_constant_array_expr (array) || size_zero) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + result = transformational_result (array, dim, array->ts.type, + array->ts.kind, &array->where); + init_result_expr (result, init_val, array); + + if (size_zero) + return result; + + return !dim || array->rank == 1 ? + simplify_transformation_to_scalar (result, array, mask, op) : + simplify_transformation_to_array (result, array, dim, mask, op, NULL); +} + + +/********************** Simplification functions *****************************/ + +gfc_expr * +gfc_simplify_abs (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + switch (e->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where); + mpz_abs (result->value.integer, e->value.integer); + return range_check (result, "IABS"); + + case BT_REAL: + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE); + return range_check (result, "ABS"); + + case BT_COMPLEX: + gfc_set_model_kind (e->ts.kind); + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE); + return range_check (result, "CABS"); + + default: + gfc_internal_error ("gfc_simplify_abs(): Bad type"); + } +} + + +static gfc_expr * +simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii) +{ + gfc_expr *result; + int kind; + bool too_large = false; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind); + if (kind == -1) + return &gfc_bad_expr; + + if (mpz_cmp_si (e->value.integer, 0) < 0) + { + gfc_error ("Argument of %s function at %L is negative", name, + &e->where); + return &gfc_bad_expr; + } + + if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0) + gfc_warning (OPT_Wsurprising, + "Argument of %s function at %L outside of range [0,127]", + name, &e->where); + + if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0) + too_large = true; + else if (kind == 4) + { + mpz_t t; + mpz_init_set_ui (t, 2); + mpz_pow_ui (t, t, 32); + mpz_sub_ui (t, t, 1); + if (mpz_cmp (e->value.integer, t) > 0) + too_large = true; + mpz_clear (t); + } + + if (too_large) + { + gfc_error ("Argument of %s function at %L is too large for the " + "collating sequence of kind %d", name, &e->where, kind); + return &gfc_bad_expr; + } + + result = gfc_get_character_expr (kind, &e->where, NULL, 1); + result->value.character.string[0] = mpz_get_ui (e->value.integer); + + return result; +} + + + +/* We use the processor's collating sequence, because all + systems that gfortran currently works on are ASCII. */ + +gfc_expr * +gfc_simplify_achar (gfc_expr *e, gfc_expr *k) +{ + return simplify_achar_char (e, k, "ACHAR", true); +} + + +gfc_expr * +gfc_simplify_acos (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) > 0 + || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ACOS at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_acos(): Bad type"); + } + + return range_check (result, "ACOS"); +} + +gfc_expr * +gfc_simplify_acosh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) < 0) + { + gfc_error ("Argument of ACOSH at %L must not be less than 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_acosh(): Bad type"); + } + + return range_check (result, "ACOSH"); +} + +gfc_expr * +gfc_simplify_adjustl (gfc_expr *e) +{ + gfc_expr *result; + int count, i, len; + gfc_char_t ch; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + + for (count = 0, i = 0; i < len; ++i) + { + ch = e->value.character.string[i]; + if (ch != ' ') + break; + ++count; + } + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); + for (i = 0; i < len - count; ++i) + result->value.character.string[i] = e->value.character.string[count + i]; + + return result; +} + + +gfc_expr * +gfc_simplify_adjustr (gfc_expr *e) +{ + gfc_expr *result; + int count, i, len; + gfc_char_t ch; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + + for (count = 0, i = len - 1; i >= 0; --i) + { + ch = e->value.character.string[i]; + if (ch != ' ') + break; + ++count; + } + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len); + for (i = 0; i < count; ++i) + result->value.character.string[i] = ' '; + + for (i = count; i < len; ++i) + result->value.character.string[i] = e->value.character.string[i - count]; + + return result; +} + + +gfc_expr * +gfc_simplify_aimag (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); + + return range_check (result, "AIMAG"); +} + + +gfc_expr * +gfc_simplify_aint (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *rtrunc, *result; + int kind; + + kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_real2real (rtrunc, kind); + + gfc_free_expr (rtrunc); + + return range_check (result, "AINT"); +} + + +gfc_expr * +gfc_simplify_all (gfc_expr *mask, gfc_expr *dim) +{ + return simplify_transformation (mask, dim, NULL, true, gfc_and); +} + + +gfc_expr * +gfc_simplify_dint (gfc_expr *e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_real2real (rtrunc, gfc_default_double_kind); + + gfc_free_expr (rtrunc); + + return range_check (result, "DINT"); +} + + +gfc_expr * +gfc_simplify_dreal (gfc_expr *e) +{ + gfc_expr *result = NULL; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); + + return range_check (result, "DREAL"); +} + + +gfc_expr * +gfc_simplify_anint (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *result; + int kind; + + kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (e->ts.type, kind, &e->where); + mpfr_round (result->value.real, e->value.real); + + return range_check (result, "ANINT"); +} + + +gfc_expr * +gfc_simplify_and (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + + switch (x->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_and (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "AND"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + x->value.logical && y->value.logical); + + default: + gcc_unreachable (); + } +} + + +gfc_expr * +gfc_simplify_any (gfc_expr *mask, gfc_expr *dim) +{ + return simplify_transformation (mask, dim, NULL, false, gfc_or); +} + + +gfc_expr * +gfc_simplify_dnint (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where); + mpfr_round (result->value.real, e->value.real); + + return range_check (result, "DNINT"); +} + + +gfc_expr * +gfc_simplify_asin (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) > 0 + || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ASIN at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_asin(): Bad type"); + } + + return range_check (result, "ASIN"); +} + + +/* Convert radians to degrees, i.e., x * 180 / pi. */ + +static void +rad2deg (mpfr_t x) +{ + mpfr_t tmp; + + mpfr_init (tmp); + mpfr_const_pi (tmp, GFC_RND_MODE); + mpfr_mul_ui (x, x, 180, GFC_RND_MODE); + mpfr_div (x, x, tmp, GFC_RND_MODE); + mpfr_clear (tmp); +} + + +/* Simplify ACOSD(X) where the returned value has units of degree. */ + +gfc_expr * +gfc_simplify_acosd (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 + || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ACOSD at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); + rad2deg (result->value.real); + + return range_check (result, "ACOSD"); +} + + +/* Simplify asind (x) where the returned value has units of degree. */ + +gfc_expr * +gfc_simplify_asind (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 + || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ASIND at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); + rad2deg (result->value.real); + + return range_check (result, "ASIND"); +} + + +/* Simplify atand (x) where the returned value has units of degree. */ + +gfc_expr * +gfc_simplify_atand (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); + rad2deg (result->value.real); + + return range_check (result, "ATAND"); +} + + +gfc_expr * +gfc_simplify_asinh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_asinh(): Bad type"); + } + + return range_check (result, "ASINH"); +} + + +gfc_expr * +gfc_simplify_atan (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_atan(): Bad type"); + } + + return range_check (result, "ATAN"); +} + + +gfc_expr * +gfc_simplify_atanh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (x->value.real, 1) >= 0 + || mpfr_cmp_si (x->value.real, -1) <= 0) + { + gfc_error ("Argument of ATANH at %L must be inside the range -1 " + "to 1", &x->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_atanh(): Bad type"); + } + + return range_check (result, "ATANH"); +} + + +gfc_expr * +gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) + { + gfc_error ("If first argument of ATAN2 at %L is zero, then the " + "second argument must not be zero", &y->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ATAN2"); +} + + +gfc_expr * +gfc_simplify_bessel_j0 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J0"); +} + + +gfc_expr * +gfc_simplify_bessel_j1 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_J1"); +} + + +gfc_expr * +gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x) +{ + gfc_expr *result; + long n; + + if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) + return NULL; + + n = mpz_get_si (order->value.integer); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_JN"); +} + + +/* Simplify transformational form of JN and YN. */ + +static gfc_expr * +gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x, + bool jn) +{ + gfc_expr *result; + gfc_expr *e; + long n1, n2; + int i; + mpfr_t x2rev, last1, last2; + + if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT + || order2->expr_type != EXPR_CONSTANT) + return NULL; + + n1 = mpz_get_si (order1->value.integer); + n2 = mpz_get_si (order2->value.integer); + result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where); + result->rank = 1; + result->shape = gfc_get_shape (1); + mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)); + + if (n2 < n1) + return result; + + /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and + YN(N, 0.0) = -Inf. */ + + if (mpfr_cmp_ui (x->value.real, 0.0) == 0) + { + if (!jn && flag_range_check) + { + gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + if (jn && n1 == 0) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set_ui (e->value.real, 1, GFC_RND_MODE); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + n1++; + } + + for (i = n1; i <= n2; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + if (jn) + mpfr_set_ui (e->value.real, 0, GFC_RND_MODE); + else + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + } + + return result; + } + + /* Use the faster but more verbose recurrence algorithm. Bessel functions + are stable for downward recursion and Neumann functions are stable + for upward recursion. It is + x2rev = 2.0/x, + J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x), + Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x). + Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */ + + gfc_set_model_kind (x->ts.kind); + + /* Get first recursion anchor. */ + + mpfr_init (last1); + if (jn) + mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE); + + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last1, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + if (n1 == n2) + { + mpfr_clear (last1); + return result; + } + + /* Get second recursion anchor. */ + + mpfr_init (last2); + if (jn) + mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE); + else + mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE); + + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (e->value.real, last2, GFC_RND_MODE); + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + mpfr_clear (last1); + mpfr_clear (last2); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; + } + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + if (n1 + 1 == n2) + { + mpfr_clear (last1); + mpfr_clear (last2); + return result; + } + + /* Start actual recursion. */ + + mpfr_init (x2rev); + mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE); + + for (i = 2; i <= n2-n1; i++) + { + e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + /* Special case: For YN, if the previous N gave -INF, set + also N+1 to -INF. */ + if (!jn && !flag_range_check && mpfr_inf_p (last2)) + { + mpfr_set_inf (e->value.real, -1); + gfc_constructor_append_expr (&result->value.constructor, e, + &x->where); + continue; + } + + mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1), + GFC_RND_MODE); + mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE); + mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE); + + if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr) + { + /* Range_check frees "e" in that case. */ + e = NULL; + goto error; + } + + if (jn) + gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, + -i-1); + else + gfc_constructor_append_expr (&result->value.constructor, e, &x->where); + + mpfr_set (last1, last2, GFC_RND_MODE); + mpfr_set (last2, e->value.real, GFC_RND_MODE); + } + + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + return result; + +error: + mpfr_clear (last1); + mpfr_clear (last2); + mpfr_clear (x2rev); + gfc_free_expr (e); + gfc_free_expr (result); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) +{ + return gfc_simplify_bessel_n2 (order1, order2, x, true); +} + + +gfc_expr * +gfc_simplify_bessel_y0 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y0"); +} + + +gfc_expr * +gfc_simplify_bessel_y1 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_Y1"); +} + + +gfc_expr * +gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x) +{ + gfc_expr *result; + long n; + + if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT) + return NULL; + + n = mpz_get_si (order->value.integer); + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE); + + return range_check (result, "BESSEL_YN"); +} + + +gfc_expr * +gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x) +{ + return gfc_simplify_bessel_n2 (order1, order2, x, false); +} + + +gfc_expr * +gfc_simplify_bit_size (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (e->ts.kind, &e->where, + gfc_integer_kinds[i].bit_size); +} + + +gfc_expr * +gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) +{ + int b; + + if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (bit, &b) || b < 0) + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); + + return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, + mpz_tstbit (e->value.integer, b)); +} + + +static int +compare_bitwise (gfc_expr *i, gfc_expr *j) +{ + mpz_t x, y; + int k, res; + + gcc_assert (i->ts.type == BT_INTEGER); + gcc_assert (j->ts.type == BT_INTEGER); + + mpz_init_set (x, i->value.integer); + k = gfc_validate_kind (i->ts.type, i->ts.kind, false); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + + mpz_init_set (y, j->value.integer); + k = gfc_validate_kind (j->ts.type, j->ts.kind, false); + convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size); + + res = mpz_cmp (x, y); + mpz_clear (x); + mpz_clear (y); + return res; +} + + +gfc_expr * +gfc_simplify_bge (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) >= 0); +} + + +gfc_expr * +gfc_simplify_bgt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) > 0); +} + + +gfc_expr * +gfc_simplify_ble (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) <= 0); +} + + +gfc_expr * +gfc_simplify_blt (gfc_expr *i, gfc_expr *j) +{ + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &i->where, + compare_bitwise (i, j) < 0); +} + + +gfc_expr * +gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *ceil, *result; + int kind; + + kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + ceil = gfc_copy_expr (e); + mpfr_ceil (ceil->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); + gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where); + + gfc_free_expr (ceil); + + return range_check (result, "CEILING"); +} + + +gfc_expr * +gfc_simplify_char (gfc_expr *e, gfc_expr *k) +{ + return simplify_achar_char (e, k, "CHAR", false); +} + + +/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */ + +static gfc_expr * +simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return NULL; + + result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE); + break; + + case BT_REAL: + mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); + } + + if (!y) + return range_check (result, name); + + switch (y->ts.type) + { + case BT_INTEGER: + mpfr_set_z (mpc_imagref (result->value.complex), + y->value.integer, GFC_RND_MODE); + break; + + case BT_REAL: + mpfr_set (mpc_imagref (result->value.complex), + y->value.real, GFC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); + } + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k) +{ + int kind; + + kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind); + if (kind == -1) + return &gfc_bad_expr; + + return simplify_cmplx ("CMPLX", x, y, kind); +} + + +gfc_expr * +gfc_simplify_complex (gfc_expr *x, gfc_expr *y) +{ + int kind; + + if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER) + kind = gfc_default_complex_kind; + else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER) + kind = x->ts.kind; + else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL) + kind = y->ts.kind; + else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL) + kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind; + else + gcc_unreachable (); + + return simplify_cmplx ("COMPLEX", x, y, kind); +} + + +gfc_expr * +gfc_simplify_conjg (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_copy_expr (e); + mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE); + + return range_check (result, "CONJG"); +} + + +/* Simplify atan2d (x) where the unit is degree. */ + +gfc_expr * +gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) + { + gfc_error ("If first argument of ATAN2D at %L is zero, then the " + "second argument must not be zero", &y->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); + rad2deg (result->value.real); + + return range_check (result, "ATAN2D"); +} + + +gfc_expr * +gfc_simplify_cos (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (x->ts.kind); + mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_cos(): Bad type"); + } + + return range_check (result, "COS"); +} + + +static void +deg2rad (mpfr_t x) +{ + mpfr_t d2r; + + mpfr_init (d2r); + mpfr_const_pi (d2r, GFC_RND_MODE); + mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE); + mpfr_mul (x, x, d2r, GFC_RND_MODE); + mpfr_clear (d2r); +} + + +/* Simplification routines for SIND, COSD, TAND. */ +#include "trigd_fe.inc" + + +/* Simplify COSD(X) where X has the unit of degree. */ + +gfc_expr * +gfc_simplify_cosd (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + simplify_cosd (result->value.real); + + return range_check (result, "COSD"); +} + + +/* Simplify SIND(X) where X has the unit of degree. */ + +gfc_expr * +gfc_simplify_sind (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + simplify_sind (result->value.real); + + return range_check (result, "SIND"); +} + + +/* Simplify TAND(X) where X has the unit of degree. */ + +gfc_expr * +gfc_simplify_tand (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + simplify_tand (result->value.real); + + return range_check (result, "TAND"); +} + + +/* Simplify COTAND(X) where X has the unit of degree. */ + +gfc_expr * +gfc_simplify_cotand (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + /* Implement COTAND = -TAND(x+90). + TAND offers correct exact values for multiples of 30 degrees. + This implementation is also compatible with the behavior of some legacy + compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */ + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE); + simplify_tand (result->value.real); + mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); + + return range_check (result, "COTAND"); +} + + +gfc_expr * +gfc_simplify_cosh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "COSH"); +} + + +gfc_expr * +gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *result; + bool size_zero; + + size_zero = gfc_is_size_zero_array (mask); + + if (!(is_constant_array_expr (mask) || size_zero) + || !gfc_is_constant_expr (dim) + || !gfc_is_constant_expr (kind)) + return NULL; + + result = transformational_result (mask, dim, + BT_INTEGER, + get_kind (BT_INTEGER, kind, "COUNT", + gfc_default_integer_kind), + &mask->where); + + init_result_expr (result, 0, NULL); + + if (size_zero) + return result; + + /* Passing MASK twice, once as data array, once as mask. + Whenever gfc_count is called, '1' is added to the result. */ + return !dim || mask->rank == 1 ? + simplify_transformation_to_scalar (result, mask, mask, gfc_count) : + simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); +} + +/* Simplification routine for cshift. This works by copying the array + expressions into a one-dimensional array, shuffling the values into another + one-dimensional array and creating the new array expression from this. The + shuffling part is basically taken from the library routine. */ + +gfc_expr * +gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) +{ + gfc_expr *result; + int which; + gfc_expr **arrayvec, **resultvec; + gfc_expr **rptr, **sptr; + mpz_t size; + size_t arraysize, shiftsize, i; + gfc_constructor *array_ctor, *shift_ctor; + ssize_t *shiftvec, *hptr; + ssize_t shift_val, len; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + hs_ex[GFC_MAX_DIMENSIONS + 1], + hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS], + a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS], + h_extent[GFC_MAX_DIMENSIONS], + ss_ex[GFC_MAX_DIMENSIONS + 1]; + ssize_t rsoffset; + int d, n; + bool continue_loop; + gfc_expr **src, **dest; + + if (!is_constant_array_expr (array)) + return NULL; + + if (shift->rank > 0) + gfc_simplify_expr (shift, 1); + + if (!gfc_is_constant_expr (shift)) + return NULL; + + /* Make dim zero-based. */ + if (dim) + { + if (!gfc_is_constant_expr (dim)) + return NULL; + which = mpz_get_si (dim->value.integer) - 1; + } + else + which = 0; + + if (array->shape == NULL) + return NULL; + + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + result->shape = gfc_copy_shape (array->shape, array->rank); + result->rank = array->rank; + result->ts.u.derived = array->ts.u.derived; + + if (arraysize == 0) + return result; + + arrayvec = XCNEWVEC (gfc_expr *, arraysize); + array_ctor = gfc_constructor_first (array->value.constructor); + for (i = 0; i < arraysize; i++) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + } + + resultvec = XCNEWVEC (gfc_expr *, arraysize); + + extent[0] = 1; + count[0] = 0; + + for (d=0; d < array->rank; d++) + { + a_extent[d] = mpz_get_si (array->shape[d]); + a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; + } + + if (shift->rank > 0) + { + gfc_array_size (shift, &size); + shiftsize = mpz_get_ui (size); + mpz_clear (size); + shiftvec = XCNEWVEC (ssize_t, shiftsize); + shift_ctor = gfc_constructor_first (shift->value.constructor); + for (d = 0; d < shift->rank; d++) + { + h_extent[d] = mpz_get_si (shift->shape[d]); + hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1]; + } + } + else + shiftvec = NULL; + + /* Shut up compiler */ + len = 1; + rsoffset = 1; + + n = 0; + for (d=0; d < array->rank; d++) + { + if (d == which) + { + rsoffset = a_stride[d]; + len = a_extent[d]; + } + else + { + count[n] = 0; + extent[n] = a_extent[d]; + sstride[n] = a_stride[d]; + ss_ex[n] = sstride[n] * extent[n]; + if (shiftvec) + hs_ex[n] = hstride[n] * extent[n]; + n++; + } + } + ss_ex[n] = 0; + hs_ex[n] = 0; + + if (shiftvec) + { + for (i = 0; i < shiftsize; i++) + { + ssize_t val; + val = mpz_get_si (shift_ctor->expr->value.integer); + val = val % len; + if (val < 0) + val += len; + shiftvec[i] = val; + shift_ctor = gfc_constructor_next (shift_ctor); + } + shift_val = 0; + } + else + { + shift_val = mpz_get_si (shift->value.integer); + shift_val = shift_val % len; + if (shift_val < 0) + shift_val += len; + } + + continue_loop = true; + d = array->rank; + rptr = resultvec; + sptr = arrayvec; + hptr = shiftvec; + + while (continue_loop) + { + ssize_t sh; + if (shiftvec) + sh = *hptr; + else + sh = shift_val; + + src = &sptr[sh * rsoffset]; + dest = rptr; + for (n = 0; n < len - sh; n++) + { + *dest = *src; + dest += rsoffset; + src += rsoffset; + } + src = sptr; + for ( n = 0; n < sh; n++) + { + *dest = *src; + dest += rsoffset; + src += rsoffset; + } + rptr += sstride[0]; + sptr += sstride[0]; + if (shiftvec) + hptr += hstride[0]; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + count[n] = 0; + rptr -= ss_ex[n]; + sptr -= ss_ex[n]; + if (shiftvec) + hptr -= hs_ex[n]; + n++; + if (n >= d - 1) + { + continue_loop = false; + break; + } + else + { + count[n]++; + rptr += sstride[n]; + sptr += sstride[n]; + if (shiftvec) + hptr += hstride[n]; + } + } + } + + for (i = 0; i < arraysize; i++) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (resultvec[i]), + NULL); + } + return result; +} + + +gfc_expr * +gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) +{ + return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); +} + + +gfc_expr * +gfc_simplify_dble (gfc_expr *e) +{ + gfc_expr *result = NULL; + int tmp1, tmp2; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + /* For explicit conversion, turn off -Wconversion and -Wconversion-extra + warnings. */ + tmp1 = warn_conversion; + tmp2 = warn_conversion_extra; + warn_conversion = warn_conversion_extra = 0; + + result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind); + + warn_conversion = tmp1; + warn_conversion_extra = tmp2; + + if (result == &gfc_bad_expr) + return &gfc_bad_expr; + + return range_check (result, "DBLE"); +} + + +gfc_expr * +gfc_simplify_digits (gfc_expr *x) +{ + int i, digits; + + i = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + switch (x->ts.type) + { + case BT_INTEGER: + digits = gfc_integer_kinds[i].digits; + break; + + case BT_REAL: + case BT_COMPLEX: + digits = gfc_real_kinds[i].digits; + break; + + default: + gcc_unreachable (); + } + + return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits); +} + + +gfc_expr * +gfc_simplify_dim (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + result = gfc_get_constant_expr (x->ts.type, kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (x->value.integer, y->value.integer) > 0) + mpz_sub (result->value.integer, x->value.integer, y->value.integer); + else + mpz_set_ui (result->value.integer, 0); + + break; + + case BT_REAL: + if (mpfr_cmp (x->value.real, y->value.real) > 0) + mpfr_sub (result->value.real, x->value.real, y->value.real, + GFC_RND_MODE); + else + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + + break; + + default: + gfc_internal_error ("gfc_simplify_dim(): Bad type"); + } + + return range_check (result, "DIM"); +} + + +gfc_expr* +gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) +{ + /* If vector_a is a zero-sized array, the result is 0 for INTEGER, + REAL, and COMPLEX types and .false. for LOGICAL. */ + if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0) + { + if (vector_a->ts.type == BT_LOGICAL) + return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false); + else + return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + } + + if (!is_constant_array_expr (vector_a) + || !is_constant_array_expr (vector_b)) + return NULL; + + return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true); +} + + +gfc_expr * +gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *a1, *a2, *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + a1 = gfc_real2real (x, gfc_default_double_kind); + a2 = gfc_real2real (y, gfc_default_double_kind); + + result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where); + mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE); + + gfc_free_expr (a2); + gfc_free_expr (a1); + + return range_check (result, "DPROD"); +} + + +static gfc_expr * +simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg, + bool right) +{ + gfc_expr *result; + int i, k, size, shift; + + if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT + || shiftarg->expr_type != EXPR_CONSTANT) + return NULL; + + k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false); + size = gfc_integer_kinds[k].bit_size; + + gfc_extract_int (shiftarg, &shift); + + /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */ + if (right) + shift = size - shift; + + result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where); + mpz_set_ui (result->value.integer, 0); + + for (i = 0; i < shift; i++) + if (mpz_tstbit (arg2->value.integer, size - shift + i)) + mpz_setbit (result->value.integer, i); + + for (i = 0; i < size - shift; i++) + if (mpz_tstbit (arg1->value.integer, i)) + mpz_setbit (result->value.integer, shift + i); + + /* Convert to a signed value. */ + gfc_convert_mpz_to_signed (result->value.integer, size); + + return result; +} + + +gfc_expr * +gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, true); +} + + +gfc_expr * +gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg) +{ + return simplify_dshift (arg1, arg2, shiftarg, false); +} + + +gfc_expr * +gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, + gfc_expr *dim) +{ + bool temp_boundary; + gfc_expr *bnd; + gfc_expr *result; + int which; + gfc_expr **arrayvec, **resultvec; + gfc_expr **rptr, **sptr; + mpz_t size; + size_t arraysize, i; + gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor; + ssize_t shift_val, len; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS], + a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1]; + ssize_t rsoffset; + int d, n; + bool continue_loop; + gfc_expr **src, **dest; + size_t s_len; + + if (!is_constant_array_expr (array)) + return NULL; + + if (shift->rank > 0) + gfc_simplify_expr (shift, 1); + + if (!gfc_is_constant_expr (shift)) + return NULL; + + if (boundary) + { + if (boundary->rank > 0) + gfc_simplify_expr (boundary, 1); + + if (!gfc_is_constant_expr (boundary)) + return NULL; + } + + if (dim) + { + if (!gfc_is_constant_expr (dim)) + return NULL; + which = mpz_get_si (dim->value.integer) - 1; + } + else + which = 0; + + s_len = 0; + if (boundary == NULL) + { + temp_boundary = true; + switch (array->ts.type) + { + + case BT_INTEGER: + bnd = gfc_get_int_expr (array->ts.kind, NULL, 0); + break; + + case BT_LOGICAL: + bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0); + break; + + case BT_REAL: + bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); + mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE); + break; + + case BT_COMPLEX: + bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); + mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE); + break; + + case BT_CHARACTER: + s_len = mpz_get_ui (array->ts.u.cl->length->value.integer); + bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len); + break; + + default: + gcc_unreachable(); + + } + } + else + { + temp_boundary = false; + bnd = boundary; + } + + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + result->shape = gfc_copy_shape (array->shape, array->rank); + result->rank = array->rank; + result->ts = array->ts; + + if (arraysize == 0) + goto final; + + arrayvec = XCNEWVEC (gfc_expr *, arraysize); + array_ctor = gfc_constructor_first (array->value.constructor); + for (i = 0; i < arraysize; i++) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + } + + resultvec = XCNEWVEC (gfc_expr *, arraysize); + + extent[0] = 1; + count[0] = 0; + + for (d=0; d < array->rank; d++) + { + a_extent[d] = mpz_get_si (array->shape[d]); + a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; + } + + if (shift->rank > 0) + { + shift_ctor = gfc_constructor_first (shift->value.constructor); + shift_val = 0; + } + else + { + shift_ctor = NULL; + shift_val = mpz_get_si (shift->value.integer); + } + + if (bnd->rank > 0) + bnd_ctor = gfc_constructor_first (bnd->value.constructor); + else + bnd_ctor = NULL; + + /* Shut up compiler */ + len = 1; + rsoffset = 1; + + n = 0; + for (d=0; d < array->rank; d++) + { + if (d == which) + { + rsoffset = a_stride[d]; + len = a_extent[d]; + } + else + { + count[n] = 0; + extent[n] = a_extent[d]; + sstride[n] = a_stride[d]; + ss_ex[n] = sstride[n] * extent[n]; + n++; + } + } + ss_ex[n] = 0; + + continue_loop = true; + d = array->rank; + rptr = resultvec; + sptr = arrayvec; + + while (continue_loop) + { + ssize_t sh, delta; + + if (shift_ctor) + sh = mpz_get_si (shift_ctor->expr->value.integer); + else + sh = shift_val; + + if (( sh >= 0 ? sh : -sh ) > len) + { + delta = len; + sh = len; + } + else + delta = (sh >= 0) ? sh: -sh; + + if (sh > 0) + { + src = &sptr[delta * rsoffset]; + dest = rptr; + } + else + { + src = sptr; + dest = &rptr[delta * rsoffset]; + } + + for (n = 0; n < len - delta; n++) + { + *dest = *src; + dest += rsoffset; + src += rsoffset; + } + + if (sh < 0) + dest = rptr; + + n = delta; + + if (bnd_ctor) + { + while (n--) + { + *dest = gfc_copy_expr (bnd_ctor->expr); + dest += rsoffset; + } + } + else + { + while (n--) + { + *dest = gfc_copy_expr (bnd); + dest += rsoffset; + } + } + rptr += sstride[0]; + sptr += sstride[0]; + if (shift_ctor) + shift_ctor = gfc_constructor_next (shift_ctor); + + if (bnd_ctor) + bnd_ctor = gfc_constructor_next (bnd_ctor); + + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + count[n] = 0; + rptr -= ss_ex[n]; + sptr -= ss_ex[n]; + n++; + if (n >= d - 1) + { + continue_loop = false; + break; + } + else + { + count[n]++; + rptr += sstride[n]; + sptr += sstride[n]; + } + } + } + + for (i = 0; i < arraysize; i++) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (resultvec[i]), + NULL); + } + + final: + if (temp_boundary) + gfc_free_expr (bnd); + + return result; +} + +gfc_expr * +gfc_simplify_erf (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ERF"); +} + + +gfc_expr * +gfc_simplify_erfc (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "ERFC"); +} + + +/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */ + +#define MAX_ITER 200 +#define ARG_LIMIT 12 + +/* Calculate ERFC_SCALED directly by its definition: + + ERFC_SCALED(x) = ERFC(x) * EXP(X**2) + + using a large precision for intermediate results. This is used for all + but large values of the argument. */ +static void +fullprec_erfc_scaled (mpfr_t res, mpfr_t arg) +{ + mpfr_prec_t prec; + mpfr_t a, b; + + prec = mpfr_get_default_prec (); + mpfr_set_default_prec (10 * prec); + + mpfr_init (a); + mpfr_init (b); + + mpfr_set (a, arg, GFC_RND_MODE); + mpfr_sqr (b, a, GFC_RND_MODE); + mpfr_exp (b, b, GFC_RND_MODE); + mpfr_erfc (a, a, GFC_RND_MODE); + mpfr_mul (a, a, b, GFC_RND_MODE); + + mpfr_set (res, a, GFC_RND_MODE); + mpfr_set_default_prec (prec); + + mpfr_clear (a); + mpfr_clear (b); +} + +/* Calculate ERFC_SCALED using a power series expansion in 1/arg: + + ERFC_SCALED(x) = 1 / (x * sqrt(pi)) + * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1)) + / (2 * x**2)**n) + + This is used for large values of the argument. Intermediate calculations + are performed with twice the precision. We don't do a fixed number of + iterations of the sum, but stop when it has converged to the required + precision. */ +static void +asympt_erfc_scaled (mpfr_t res, mpfr_t arg) +{ + mpfr_t sum, x, u, v, w, oldsum, sumtrunc; + mpz_t num; + mpfr_prec_t prec; + unsigned i; + + prec = mpfr_get_default_prec (); + mpfr_set_default_prec (2 * prec); + + mpfr_init (sum); + mpfr_init (x); + mpfr_init (u); + mpfr_init (v); + mpfr_init (w); + mpz_init (num); + + mpfr_init (oldsum); + mpfr_init (sumtrunc); + mpfr_set_prec (oldsum, prec); + mpfr_set_prec (sumtrunc, prec); + + mpfr_set (x, arg, GFC_RND_MODE); + mpfr_set_ui (sum, 1, GFC_RND_MODE); + mpz_set_ui (num, 1); + + mpfr_set (u, x, GFC_RND_MODE); + mpfr_sqr (u, u, GFC_RND_MODE); + mpfr_mul_ui (u, u, 2, GFC_RND_MODE); + mpfr_pow_si (u, u, -1, GFC_RND_MODE); + + for (i = 1; i < MAX_ITER; i++) + { + mpfr_set (oldsum, sum, GFC_RND_MODE); + + mpz_mul_ui (num, num, 2 * i - 1); + mpz_neg (num, num); + + mpfr_set (w, u, GFC_RND_MODE); + mpfr_pow_ui (w, w, i, GFC_RND_MODE); + + mpfr_set_z (v, num, GFC_RND_MODE); + mpfr_mul (v, v, w, GFC_RND_MODE); + + mpfr_add (sum, sum, v, GFC_RND_MODE); + + mpfr_set (sumtrunc, sum, GFC_RND_MODE); + if (mpfr_cmp (sumtrunc, oldsum) == 0) + break; + } + + /* We should have converged by now; otherwise, ARG_LIMIT is probably + set too low. */ + gcc_assert (i < MAX_ITER); + + /* Divide by x * sqrt(Pi). */ + mpfr_const_pi (u, GFC_RND_MODE); + mpfr_sqrt (u, u, GFC_RND_MODE); + mpfr_mul (u, u, x, GFC_RND_MODE); + mpfr_div (sum, sum, u, GFC_RND_MODE); + + mpfr_set (res, sum, GFC_RND_MODE); + mpfr_set_default_prec (prec); + + mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL); + mpz_clear (num); +} + + +gfc_expr * +gfc_simplify_erfc_scaled (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0) + asympt_erfc_scaled (result->value.real, x->value.real); + else + fullprec_erfc_scaled (result->value.real, x->value.real); + + return range_check (result, "ERFC_SCALED"); +} + +#undef MAX_ITER +#undef ARG_LIMIT + + +gfc_expr * +gfc_simplify_epsilon (gfc_expr *e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE); + + return range_check (result, "EPSILON"); +} + + +gfc_expr * +gfc_simplify_exp (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (x->ts.kind); + mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_exp(): Bad type"); + } + + return range_check (result, "EXP"); +} + + +gfc_expr * +gfc_simplify_exponent (gfc_expr *x) +{ + long int val; + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &x->where); + + /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */ + if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real)) + { + int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false); + mpz_set (result->value.integer, gfc_integer_kinds[i].huge); + return result; + } + + /* EXPONENT(+/- 0.0) = 0 */ + if (mpfr_zero_p (x->value.real)) + { + mpz_set_ui (result->value.integer, 0); + return result; + } + + gfc_set_model (x->value.real); + + val = (long int) mpfr_get_exp (x->value.real); + mpz_set_si (result->value.integer, val); + + return range_check (result, "EXPONENT"); +} + + +gfc_expr * +gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED, + gfc_expr *kind) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_current_locus = *gfc_current_intrinsic_where; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return &gfc_bad_expr; + } + + if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + gfc_expr *result; + int actual_kind; + if (kind) + gfc_extract_int (kind, &actual_kind); + else + actual_kind = gfc_default_integer_kind; + + result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus); + result->rank = 1; + return result; + } + + /* For fcoarray = lib no simplification is possible, because it is not known + what images failed or are stopped at compile time. */ + return NULL; +} + + +gfc_expr * +gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_current_locus = *gfc_current_intrinsic_where; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return &gfc_bad_expr; + } + + if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + gfc_expr *result; + result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); + result->rank = 0; + return result; + } + + /* For fcoarray = lib no simplification is possible, because it is not known + what images failed or are stopped at compile time. */ + return NULL; +} + + +gfc_expr * +gfc_simplify_float (gfc_expr *a) +{ + gfc_expr *result; + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_int2real (a, gfc_default_real_kind); + + return range_check (result, "FLOAT"); +} + + +static bool +is_last_ref_vtab (gfc_expr *e) +{ + gfc_ref *ref; + gfc_component *comp = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + comp = ref->u.c.component; + + if (!e->ref || !comp) + return e->symtree->n.sym->attr.vtab; + + if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0) + return true; + + return false; +} + + +gfc_expr * +gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) +{ + /* Avoid simplification of resolved symbols. */ + if (is_last_ref_vtab (a) || is_last_ref_vtab (mold)) + return NULL; + + if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_type_is_extension_of (mold->ts.u.derived, + a->ts.u.derived)); + + if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold)) + return NULL; + + /* Return .false. if the dynamic type can never be an extension. */ + if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS + && !gfc_type_is_extension_of + (mold->ts.u.derived->components->ts.u.derived, + a->ts.u.derived->components->ts.u.derived) + && !gfc_type_is_extension_of + (a->ts.u.derived->components->ts.u.derived, + mold->ts.u.derived->components->ts.u.derived)) + || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS + && !gfc_type_is_extension_of + (mold->ts.u.derived->components->ts.u.derived, + a->ts.u.derived)) + || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED + && !gfc_type_is_extension_of + (mold->ts.u.derived, + a->ts.u.derived->components->ts.u.derived) + && !gfc_type_is_extension_of + (a->ts.u.derived->components->ts.u.derived, + mold->ts.u.derived))) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); + + /* Return .true. if the dynamic type is guaranteed to be an extension. */ + if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED + && gfc_type_is_extension_of (mold->ts.u.derived, + a->ts.u.derived->components->ts.u.derived)) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); + + return NULL; +} + + +gfc_expr * +gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b) +{ + /* Avoid simplification of resolved symbols. */ + if (is_last_ref_vtab (a) || is_last_ref_vtab (b)) + return NULL; + + /* Return .false. if the dynamic type can never be the + same. */ + if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok) + || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok)) + && !gfc_type_compatible (&a->ts, &b->ts) + && !gfc_type_compatible (&b->ts, &a->ts)) + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); + + if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_derived_types (a->ts.u.derived, + b->ts.u.derived)); +} + + +gfc_expr * +gfc_simplify_floor (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *result; + mpfr_t floor; + int kind; + + kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind); + if (kind == -1) + gfc_internal_error ("gfc_simplify_floor(): Bad kind"); + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + mpfr_init2 (floor, mpfr_get_prec (e->value.real)); + mpfr_floor (floor, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); + gfc_mpfr_to_mpz (result->value.integer, floor, &e->where); + + mpfr_clear (floor); + + return range_check (result, "FLOOR"); +} + + +gfc_expr * +gfc_simplify_fraction (gfc_expr *x) +{ + gfc_expr *result; + mpfr_exp_t e; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + /* FRACTION(inf) = NaN. */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); + return result; + } + + /* mpfr_frexp() correctly handles zeros and NaNs. */ + mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "FRACTION"); +} + + +gfc_expr * +gfc_simplify_gamma (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "GAMMA"); +} + + +gfc_expr * +gfc_simplify_huge (gfc_expr *e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + + switch (e->ts.type) + { + case BT_INTEGER: + mpz_set (result->value.integer, gfc_integer_kinds[i].huge); + break; + + case BT_REAL: + mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return result; +} + + +gfc_expr * +gfc_simplify_hypot (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); + return range_check (result, "HYPOT"); +} + + +/* We use the processor's collating sequence, because all + systems that gfortran currently works on are ASCII. */ + +gfc_expr * +gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + gfc_char_t index; + int k; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (e->value.character.length != 1) + { + gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; + } + + index = e->value.character.string[0]; + + if (warn_surprising && index > 127) + gfc_warning (OPT_Wsurprising, + "Argument of IACHAR function at %L outside of range 0..127", + &e->where); + + k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_int_expr (k, &e->where, index); + + return range_check (result, "IACHAR"); +} + + +static gfc_expr * +do_bit_and (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_and (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, -1, do_bit_and); +} + + +static gfc_expr * +do_bit_ior (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_ior (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, do_bit_ior); +} + + +gfc_expr * +gfc_simplify_iand (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + mpz_and (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IAND"); +} + + +gfc_expr * +gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int k, pos; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + gfc_extract_int (y, &pos); + + k = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + result = gfc_copy_expr (x); + + convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); + + mpz_clrbit (result->value.integer, pos); + + gfc_convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) +{ + gfc_expr *result; + int pos, len; + int i, k, bitsize; + int *bits; + + if (x->expr_type != EXPR_CONSTANT + || y->expr_type != EXPR_CONSTANT + || z->expr_type != EXPR_CONSTANT) + return NULL; + + gfc_extract_int (y, &pos); + gfc_extract_int (z, &len); + + k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false); + + bitsize = gfc_integer_kinds[k].bit_size; + + if (pos + len > bitsize) + { + gfc_error ("Sum of second and third arguments of IBITS exceeds " + "bit size at %L", &y->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); + + bits = XCNEWVEC (int, bitsize); + + for (i = 0; i < bitsize; i++) + bits[i] = 0; + + for (i = 0; i < len; i++) + bits[i] = mpz_tstbit (x->value.integer, i + pos); + + for (i = 0; i < bitsize; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i); + else if (bits[i] == 1) + mpz_setbit (result->value.integer, i); + else + gfc_internal_error ("IBITS: Bad bit"); + } + + free (bits); + + gfc_convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int k, pos; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + gfc_extract_int (y, &pos); + + k = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + result = gfc_copy_expr (x); + + convert_mpz_to_unsigned (result->value.integer, + gfc_integer_kinds[k].bit_size); + + mpz_setbit (result->value.integer, pos); + + gfc_convert_mpz_to_signed (result->value.integer, + gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + gfc_char_t index; + int k; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (e->value.character.length != 1) + { + gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; + } + + index = e->value.character.string[0]; + + k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_int_expr (k, &e->where, index); + + return range_check (result, "ICHAR"); +} + + +gfc_expr * +gfc_simplify_ieor (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + mpz_xor (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IEOR"); +} + + +gfc_expr * +gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) +{ + gfc_expr *result; + int back, len, lensub; + int i, j, k, count, index = 0, start; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT + || ( b != NULL && b->expr_type != EXPR_CONSTANT)) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); + + len = x->value.character.length; + lensub = y->value.character.length; + + if (len < lensub) + { + mpz_set_si (result->value.integer, 0); + return result; + } + + if (back == 0) + { + if (lensub == 0) + { + mpz_set_si (result->value.integer, 1); + return result; + } + else if (lensub == 1) + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[i]) + { + index = i + 1; + goto done; + } + } + } + } + else + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[i]) + { + start = i; + count = 0; + + for (k = 0; k < lensub; k++) + { + if (y->value.character.string[k] + == x->value.character.string[k + start]) + count++; + } + + if (count == lensub) + { + index = start + 1; + goto done; + } + } + } + } + } + + } + else + { + if (lensub == 0) + { + mpz_set_si (result->value.integer, len + 1); + return result; + } + else if (lensub == 1) + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[len - i]) + { + index = len - i + 1; + goto done; + } + } + } + } + else + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] + == x->value.character.string[len - i]) + { + start = len - i; + if (start <= len - lensub) + { + count = 0; + for (k = 0; k < lensub; k++) + if (y->value.character.string[k] + == x->value.character.string[k + start]) + count++; + + if (count == lensub) + { + index = start + 1; + goto done; + } + } + else + { + continue; + } + } + } + } + } + } + +done: + mpz_set_si (result->value.integer, index); + return range_check (result, "INDEX"); +} + + +static gfc_expr * +simplify_intconv (gfc_expr *e, int kind, const char *name) +{ + gfc_expr *result = NULL; + int tmp1, tmp2; + + /* Convert BOZ to integer, and return without range checking. */ + if (e->ts.type == BT_BOZ) + { + if (!gfc_boz2int (e, kind)) + return NULL; + result = gfc_copy_expr (e); + return result; + } + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + /* For explicit conversion, turn off -Wconversion and -Wconversion-extra + warnings. */ + tmp1 = warn_conversion; + tmp2 = warn_conversion_extra; + warn_conversion = warn_conversion_extra = 0; + + result = gfc_convert_constant (e, BT_INTEGER, kind); + + warn_conversion = tmp1; + warn_conversion_extra = tmp2; + + if (result == &gfc_bad_expr) + return &gfc_bad_expr; + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_int (gfc_expr *e, gfc_expr *k) +{ + int kind; + + kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + + return simplify_intconv (e, kind, "INT"); +} + +gfc_expr * +gfc_simplify_int2 (gfc_expr *e) +{ + return simplify_intconv (e, 2, "INT2"); +} + + +gfc_expr * +gfc_simplify_int8 (gfc_expr *e) +{ + return simplify_intconv (e, 8, "INT8"); +} + + +gfc_expr * +gfc_simplify_long (gfc_expr *e) +{ + return simplify_intconv (e, 4, "LONG"); +} + + +gfc_expr * +gfc_simplify_ifix (gfc_expr *e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &e->where); + gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); + + gfc_free_expr (rtrunc); + + return range_check (result, "IFIX"); +} + + +gfc_expr * +gfc_simplify_idint (gfc_expr *e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + mpfr_trunc (rtrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &e->where); + gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where); + + gfc_free_expr (rtrunc); + + return range_check (result, "IDINT"); +} + + +gfc_expr * +gfc_simplify_ior (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where); + mpz_ior (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IOR"); +} + + +static gfc_expr * +do_bit_xor (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_INTEGER + && result->expr_type == EXPR_CONSTANT); + + mpz_xor (result->value.integer, result->value.integer, e->value.integer); + return result; +} + + +gfc_expr * +gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, do_bit_xor); +} + + +gfc_expr * +gfc_simplify_is_iostat_end (gfc_expr *x) +{ + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpz_cmp_si (x->value.integer, + LIBERROR_END) == 0); +} + + +gfc_expr * +gfc_simplify_is_iostat_eor (gfc_expr *x) +{ + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpz_cmp_si (x->value.integer, + LIBERROR_EOR) == 0); +} + + +gfc_expr * +gfc_simplify_isnan (gfc_expr *x) +{ + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &x->where, + mpfr_nan_p (x->value.real)); +} + + +/* Performs a shift on its first argument. Depending on the last + argument, the shift can be arithmetic, i.e. with filling from the + left like in the SHIFTA intrinsic. */ +static gfc_expr * +simplify_shift (gfc_expr *e, gfc_expr *s, const char *name, + bool arithmetic, int direction) +{ + gfc_expr *result; + int ashift, *bits, i, k, bitsize, shift; + + if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) + return NULL; + + gfc_extract_int (s, &shift); + + k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false); + bitsize = gfc_integer_kinds[k].bit_size; + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + + if (shift == 0) + { + mpz_set (result->value.integer, e->value.integer); + return result; + } + + if (direction > 0 && shift < 0) + { + /* Left shift, as in SHIFTL. */ + gfc_error ("Second argument of %s is negative at %L", name, &e->where); + return &gfc_bad_expr; + } + else if (direction < 0) + { + /* Right shift, as in SHIFTR or SHIFTA. */ + if (shift < 0) + { + gfc_error ("Second argument of %s is negative at %L", + name, &e->where); + return &gfc_bad_expr; + } + + shift = -shift; + } + + ashift = (shift >= 0 ? shift : -shift); + + if (ashift > bitsize) + { + gfc_error ("Magnitude of second argument of %s exceeds bit size " + "at %L", name, &e->where); + return &gfc_bad_expr; + } + + bits = XCNEWVEC (int, bitsize); + + for (i = 0; i < bitsize; i++) + bits[i] = mpz_tstbit (e->value.integer, i); + + if (shift > 0) + { + /* Left shift. */ + for (i = 0; i < shift; i++) + mpz_clrbit (result->value.integer, i); + + for (i = 0; i < bitsize - shift; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + else + mpz_setbit (result->value.integer, i + shift); + } + } + else + { + /* Right shift. */ + if (arithmetic && bits[bitsize - 1]) + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_setbit (result->value.integer, i); + else + for (i = bitsize - 1; i >= bitsize - ashift; i--) + mpz_clrbit (result->value.integer, i); + + for (i = bitsize - 1; i >= ashift; i--) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i - ashift); + else + mpz_setbit (result->value.integer, i - ashift); + } + } + + gfc_convert_mpz_to_signed (result->value.integer, bitsize); + free (bits); + + return result; +} + + +gfc_expr * +gfc_simplify_ishft (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "ISHFT", false, 0); +} + + +gfc_expr * +gfc_simplify_lshift (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "LSHIFT", false, 1); +} + + +gfc_expr * +gfc_simplify_rshift (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "RSHIFT", true, -1); +} + + +gfc_expr * +gfc_simplify_shifta (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTA", true, -1); +} + + +gfc_expr * +gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTL", false, 1); +} + + +gfc_expr * +gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s) +{ + return simplify_shift (e, s, "SHIFTR", false, -1); +} + + +gfc_expr * +gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz) +{ + gfc_expr *result; + int shift, ashift, isize, ssize, delta, k; + int i, *bits; + + if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) + return NULL; + + gfc_extract_int (s, &shift); + + k = gfc_validate_kind (e->ts.type, e->ts.kind, false); + isize = gfc_integer_kinds[k].bit_size; + + if (sz != NULL) + { + if (sz->expr_type != EXPR_CONSTANT) + return NULL; + + gfc_extract_int (sz, &ssize); + } + else + ssize = isize; + + if (shift >= 0) + ashift = shift; + else + ashift = -shift; + + if (ashift > ssize) + { + if (sz == NULL) + gfc_error ("Magnitude of second argument of ISHFTC exceeds " + "BIT_SIZE of first argument at %C"); + else + gfc_error ("Absolute value of SHIFT shall be less than or equal " + "to SIZE at %C"); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + + mpz_set (result->value.integer, e->value.integer); + + if (shift == 0) + return result; + + convert_mpz_to_unsigned (result->value.integer, isize); + + bits = XCNEWVEC (int, ssize); + + for (i = 0; i < ssize; i++) + bits[i] = mpz_tstbit (e->value.integer, i); + + delta = ssize - ashift; + + if (shift > 0) + { + for (i = 0; i < delta; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + else + mpz_setbit (result->value.integer, i + shift); + } + + for (i = delta; i < ssize; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i - delta); + else + mpz_setbit (result->value.integer, i - delta); + } + } + else + { + for (i = 0; i < ashift; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + delta); + else + mpz_setbit (result->value.integer, i + delta); + } + + for (i = ashift; i < ssize; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + else + mpz_setbit (result->value.integer, i + shift); + } + } + + gfc_convert_mpz_to_signed (result->value.integer, isize); + + free (bits); + return result; +} + + +gfc_expr * +gfc_simplify_kind (gfc_expr *e) +{ + return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind); +} + + +static gfc_expr * +simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, + gfc_array_spec *as, gfc_ref *ref, bool coarray) +{ + gfc_expr *l, *u, *result; + int k; + + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + + /* For non-variables, LBOUND(expr, DIM=n) = 1 and + UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */ + if (!coarray && array->expr_type != EXPR_VARIABLE) + { + if (upper) + { + gfc_expr* dim = result; + mpz_set_si (dim->value.integer, d); + + result = simplify_size (array, dim, k); + gfc_free_expr (dim); + if (!result) + goto returnNull; + } + else + mpz_set_si (result->value.integer, 1); + + goto done; + } + + /* Otherwise, we have a variable expression. */ + gcc_assert (array->expr_type == EXPR_VARIABLE); + gcc_assert (as); + + if (!gfc_resolve_array_spec (as, 0)) + return NULL; + + /* The last dimension of an assumed-size array is special. */ + if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper) + || (coarray && d == as->rank + as->corank + && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE))) + { + if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT) + { + gfc_free_expr (result); + return gfc_copy_expr (as->lower[d-1]); + } + + goto returnNull; + } + + result = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + + /* Then, we need to know the extent of the given dimension. */ + if (coarray || (ref->u.ar.type == AR_FULL && !ref->next)) + { + gfc_expr *declared_bound; + int empty_bound; + bool constant_lbound, constant_ubound; + + l = as->lower[d-1]; + u = as->upper[d-1]; + + gcc_assert (l != NULL); + + constant_lbound = l->expr_type == EXPR_CONSTANT; + constant_ubound = u && u->expr_type == EXPR_CONSTANT; + + empty_bound = upper ? 0 : 1; + declared_bound = upper ? u : l; + + if ((!upper && !constant_lbound) + || (upper && !constant_ubound)) + goto returnNull; + + if (!coarray) + { + /* For {L,U}BOUND, the value depends on whether the array + is empty. We can nevertheless simplify if the declared bound + has the same value as that of an empty array, in which case + the result isn't dependent on the array emptyness. */ + if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0) + mpz_set_si (result->value.integer, empty_bound); + else if (!constant_lbound || !constant_ubound) + /* Array emptyness can't be determined, we can't simplify. */ + goto returnNull; + else if (mpz_cmp (l->value.integer, u->value.integer) > 0) + mpz_set_si (result->value.integer, empty_bound); + else + mpz_set (result->value.integer, declared_bound->value.integer); + } + else + mpz_set (result->value.integer, declared_bound->value.integer); + } + else + { + if (upper) + { + int d2 = 0, cnt = 0; + for (int idx = 0; idx < ref->u.ar.dimen; ++idx) + { + if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT) + d2++; + else if (cnt < d - 1) + cnt++; + else + break; + } + if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL)) + goto returnNull; + } + else + mpz_set_si (result->value.integer, (long int) 1); + } + +done: + return range_check (result, upper ? "UBOUND" : "LBOUND"); + +returnNull: + gfc_free_expr (result); + return NULL; +} + + +static gfc_expr * +simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) +{ + gfc_ref *ref; + gfc_array_spec *as; + ar_type type = AR_UNKNOWN; + int d; + + if (array->ts.type == BT_CLASS) + return NULL; + + if (array->expr_type != EXPR_VARIABLE) + { + as = NULL; + ref = NULL; + goto done; + } + + /* Do not attempt to resolve if error has already been issued. */ + if (array->symtree->n.sym->error) + return NULL; + + /* Follow any component references. */ + as = array->symtree->n.sym->as; + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + type = ref->u.ar.type; + switch (ref->u.ar.type) + { + case AR_ELEMENT: + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + goto done; + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + case REF_INQUIRY: + continue; + } + } + + gcc_unreachable (); + + done: + + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK + || (as->type == AS_ASSUMED_SHAPE && upper))) + return NULL; + + /* 'array' shall not be an unallocated allocatable variable or a pointer that + is not associated. */ + if (array->expr_type == EXPR_VARIABLE + && (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer)) + return NULL; + + gcc_assert (!as + || (as->type != AS_DEFERRED + && array->expr_type == EXPR_VARIABLE + && !gfc_expr_attr (array).allocatable + && !gfc_expr_attr (array).pointer)); + + if (dim == NULL) + { + /* Multi-dimensional bounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + int k; + + /* UBOUND(ARRAY) is not valid for an assumed-size array. */ + if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE) + { + /* An error message will be emitted in + check_assumed_size_reference (resolve.c). */ + return &gfc_bad_expr; + } + + /* Simplify the bounds for each dimension. */ + for (d = 0; d < array->rank; d++) + { + bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref, + false); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + + if (gfc_seen_div0) + return &gfc_bad_expr; + else + return bounds[d]; + } + } + + /* Allocate the result expression. */ + k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND", + gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + e = gfc_get_array_expr (BT_INTEGER, k, &array->where); + + /* The result is a rank 1 array; its size is the rank of the first + argument to {L,U}BOUND. */ + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], array->rank); + + /* Create the constructor for this array. */ + for (d = 0; d < array->rank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); + + return e; + } + else + { + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_si (dim->value.integer); + + if ((d < 1 || d > array->rank) + || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) + { + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } + + if (as && as->type == AS_ASSUMED_RANK) + return NULL; + + return simplify_bound_dim (array, kind, d, upper, as, ref, false); + } +} + + +static gfc_expr * +simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) +{ + gfc_ref *ref; + gfc_array_spec *as; + int d; + + if (array->expr_type != EXPR_VARIABLE) + return NULL; + + /* Follow any component references. */ + as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) + ? array->ts.u.derived->components->as + : array->symtree->n.sym->as; + for (ref = array->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + if (ref->u.ar.as->corank > 0) + { + gcc_assert (as == ref->u.ar.as); + goto done; + } + as = NULL; + continue; + + case AR_FULL: + /* We're done because 'as' has already been set in the + previous iteration. */ + goto done; + + case AR_UNKNOWN: + return NULL; + + case AR_SECTION: + as = ref->u.ar.as; + goto done; + } + + gcc_unreachable (); + + case REF_COMPONENT: + as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + case REF_INQUIRY: + continue; + } + } + + if (!as) + gcc_unreachable (); + + done: + + if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) + return NULL; + + if (dim == NULL) + { + /* Multi-dimensional cobounds. */ + gfc_expr *bounds[GFC_MAX_DIMENSIONS]; + gfc_expr *e; + int k; + + /* Simplify the cobounds for each dimension. */ + for (d = 0; d < as->corank; d++) + { + bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, + upper, as, ref, true); + if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) + { + int j; + + for (j = 0; j < d; j++) + gfc_free_expr (bounds[j]); + return bounds[d]; + } + } + + /* Allocate the result expression. */ + e = gfc_get_expr (); + e->where = array->where; + e->expr_type = EXPR_ARRAY; + e->ts.type = BT_INTEGER; + k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND", + gfc_default_integer_kind); + if (k == -1) + { + gfc_free_expr (e); + return &gfc_bad_expr; + } + e->ts.kind = k; + + /* The result is a rank 1 array; its size is the rank of the first + argument to {L,U}COBOUND. */ + e->rank = 1; + e->shape = gfc_get_shape (1); + mpz_init_set_ui (e->shape[0], as->corank); + + /* Create the constructor for this array. */ + for (d = 0; d < as->corank; d++) + gfc_constructor_append_expr (&e->value.constructor, + bounds[d], &e->where); + return e; + } + else + { + /* A DIM argument is specified. */ + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_si (dim->value.integer); + + if (d < 1 || d > as->corank) + { + gfc_error ("DIM argument at %L is out of bounds", &dim->where); + return &gfc_bad_expr; + } + + return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); + } +} + + +gfc_expr * +gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_bound (array, dim, kind, 0); +} + + +gfc_expr * +gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_cobound (array, dim, kind, 0); +} + +gfc_expr * +gfc_simplify_leadz (gfc_expr *e) +{ + unsigned long lz, bs; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + bs = gfc_integer_kinds[i].bit_size; + if (mpz_cmp_si (e->value.integer, 0) == 0) + lz = bs; + else if (mpz_cmp_si (e->value.integer, 0) < 0) + lz = 0; + else + lz = bs - mpz_sizeinbase (e->value.integer, 2); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz); +} + + +/* Check for constant length of a substring. */ + +static bool +substring_has_constant_len (gfc_expr *e) +{ + gfc_ref *ref; + HOST_WIDE_INT istart, iend, length; + bool equal_length = false; + + if (e->ts.type != BT_CHARACTER) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY) + break; + + if (!ref + || ref->type != REF_SUBSTRING + || !ref->u.ss.start + || ref->u.ss.start->expr_type != EXPR_CONSTANT + || !ref->u.ss.end + || ref->u.ss.end->expr_type != EXPR_CONSTANT) + return false; + + /* Basic checks on substring starting and ending indices. */ + if (!gfc_resolve_substring (ref, &equal_length)) + return false; + + istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer); + iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer); + + if (istart <= iend) + length = iend - istart + 1; + else + length = 0; + + /* Fix substring length. */ + e->value.character.length = length; + + return true; +} + + +gfc_expr * +gfc_simplify_len (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + if (e->expr_type == EXPR_CONSTANT + || substring_has_constant_len (e)) + { + result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); + mpz_set_si (result->value.integer, e->value.character.length); + return range_check (result, "LEN"); + } + else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT + && e->ts.u.cl->length->ts.type == BT_INTEGER) + { + result = gfc_get_constant_expr (BT_INTEGER, k, &e->where); + mpz_set (result->value.integer, e->ts.u.cl->length->value.integer); + return range_check (result, "LEN"); + } + else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER + && e->symtree->n.sym + && e->symtree->n.sym->ts.type != BT_DERIVED + && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target + && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED + && e->symtree->n.sym->assoc->target->symtree->n.sym + && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym)) + + /* The expression in assoc->target points to a ref to the _data component + of the unlimited polymorphic entity. To get the _len component the last + _data ref needs to be stripped and a ref to the _len component added. */ + return gfc_get_len_component (e->symtree->n.sym->assoc->target, k); + else + return NULL; +} + + +gfc_expr * +gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind) +{ + gfc_expr *result; + size_t count, len, i; + int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + for (count = 0, i = 1; i <= len; i++) + if (e->value.character.string[len - i] == ' ') + count++; + else + break; + + result = gfc_get_int_expr (k, &e->where, len - count); + return range_check (result, "LEN_TRIM"); +} + +gfc_expr * +gfc_simplify_lgamma (gfc_expr *x) +{ + gfc_expr *result; + int sg; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE); + + return range_check (result, "LGAMMA"); +} + + +gfc_expr * +gfc_simplify_lge (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) >= 0); +} + + +gfc_expr * +gfc_simplify_lgt (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) > 0); +} + + +gfc_expr * +gfc_simplify_lle (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) <= 0); +} + + +gfc_expr * +gfc_simplify_llt (gfc_expr *a, gfc_expr *b) +{ + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, + gfc_compare_string (a, b) < 0); +} + + +gfc_expr * +gfc_simplify_log (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + if (mpfr_sgn (x->value.real) <= 0) + { + gfc_error ("Argument of LOG at %L cannot be less than or equal " + "to zero", &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + mpfr_log (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + if (mpfr_zero_p (mpc_realref (x->value.complex)) + && mpfr_zero_p (mpc_imagref (x->value.complex))) + { + gfc_error ("Complex argument of LOG at %L cannot be zero", + &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + gfc_set_model_kind (x->ts.kind); + mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("gfc_simplify_log: bad type"); + } + + return range_check (result, "LOG"); +} + + +gfc_expr * +gfc_simplify_log10 (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_sgn (x->value.real) <= 0) + { + gfc_error ("Argument of LOG10 at %L cannot be less than or equal " + "to zero", &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE); + + return range_check (result, "LOG10"); +} + + +gfc_expr * +gfc_simplify_logical (gfc_expr *e, gfc_expr *k) +{ + int kind; + + kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind); + if (kind < 0) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_get_logical_expr (kind, &e->where, e->value.logical); +} + + +gfc_expr* +gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) +{ + gfc_expr *result; + int row, result_rows, col, result_columns; + int stride_a, offset_a, stride_b, offset_b; + + if (!is_constant_array_expr (matrix_a) + || !is_constant_array_expr (matrix_b)) + return NULL; + + /* MATMUL should do mixed-mode arithmetic. Set the result type. */ + if (matrix_a->ts.type != matrix_b->ts.type) + { + gfc_expr e; + e.expr_type = EXPR_OP; + gfc_clear_ts (&e.ts); + e.value.op.op = INTRINSIC_NONE; + e.value.op.op1 = matrix_a; + e.value.op.op2 = matrix_b; + gfc_type_convert_binary (&e, 1); + result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where); + } + else + { + result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind, + &matrix_a->where); + } + + if (matrix_a->rank == 1 && matrix_b->rank == 2) + { + result_rows = 1; + result_columns = mpz_get_si (matrix_b->shape[1]); + stride_a = 1; + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_columns); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 1) + { + result_rows = mpz_get_si (matrix_a->shape[0]); + result_columns = 1; + stride_a = mpz_get_si (matrix_a->shape[0]); + stride_b = 1; + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 2) + { + result_rows = mpz_get_si (matrix_a->shape[0]); + result_columns = mpz_get_si (matrix_b->shape[1]); + stride_a = mpz_get_si (matrix_a->shape[0]); + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 2; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + mpz_init_set_si (result->shape[1], result_columns); + } + else + gcc_unreachable(); + + offset_b = 0; + for (col = 0; col < result_columns; ++col) + { + offset_a = 0; + + for (row = 0; row < result_rows; ++row) + { + gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a, + matrix_b, 1, offset_b, false); + gfc_constructor_append_expr (&result->value.constructor, + e, NULL); + + offset_a += 1; + } + + offset_b += stride_b; + } + + return result; +} + + +gfc_expr * +gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + bool fail = gfc_extract_int (i, &arg); + gcc_assert (!fail); + + if (!gfc_check_mask (i, kind_arg)) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKR(n) = 2^n - 1 */ + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, arg); + mpz_sub_ui (result->value.integer, result->value.integer, 1); + + gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg) +{ + gfc_expr *result; + int kind, arg, k; + mpz_t z; + + if (i->expr_type != EXPR_CONSTANT) + return NULL; + + kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + k = gfc_validate_kind (BT_INTEGER, kind, false); + + bool fail = gfc_extract_int (i, &arg); + gcc_assert (!fail); + + if (!gfc_check_mask (i, kind_arg)) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where); + + /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */ + mpz_init_set_ui (z, 1); + mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size); + mpz_set_ui (result->value.integer, 1); + mpz_mul_2exp (result->value.integer, result->value.integer, + gfc_integer_kinds[k].bit_size - arg); + mpz_sub (result->value.integer, z, result->value.integer); + mpz_clear (z); + + gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) +{ + gfc_expr * result; + gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor; + + if (mask->expr_type == EXPR_CONSTANT) + { + result = gfc_copy_expr (mask->value.logical ? tsource : fsource); + /* Parenthesis is needed to get lower bounds of 1. */ + result = gfc_get_parentheses (result); + gfc_simplify_expr (result, 1); + return result; + } + + if (!mask->rank || !is_constant_array_expr (mask) + || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource)) + return NULL; + + result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind, + &tsource->where); + if (tsource->ts.type == BT_DERIVED) + result->ts.u.derived = tsource->ts.u.derived; + else if (tsource->ts.type == BT_CHARACTER) + result->ts.u.cl = tsource->ts.u.cl; + + tsource_ctor = gfc_constructor_first (tsource->value.constructor); + fsource_ctor = gfc_constructor_first (fsource->value.constructor); + mask_ctor = gfc_constructor_first (mask->value.constructor); + + while (mask_ctor) + { + if (mask_ctor->expr->value.logical) + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (tsource_ctor->expr), + NULL); + else + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (fsource_ctor->expr), + NULL); + tsource_ctor = gfc_constructor_next (tsource_ctor); + fsource_ctor = gfc_constructor_next (fsource_ctor); + mask_ctor = gfc_constructor_next (mask_ctor); + } + + result->shape = gfc_get_shape (1); + gfc_array_size (result, &result->shape[0]); + + return result; +} + + +gfc_expr * +gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr) +{ + mpz_t arg1, arg2, mask; + gfc_expr *result; + + if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT + || mask_expr->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where); + + /* Convert all argument to unsigned. */ + mpz_init_set (arg1, i->value.integer); + mpz_init_set (arg2, j->value.integer); + mpz_init_set (mask, mask_expr->value.integer); + + /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */ + mpz_and (arg1, arg1, mask); + mpz_com (mask, mask); + mpz_and (arg2, arg2, mask); + mpz_ior (result->value.integer, arg1, arg2); + + mpz_clear (arg1); + mpz_clear (arg2); + mpz_clear (mask); + + return result; +} + + +/* Selects between current value and extremum for simplify_min_max + and simplify_minval_maxval. */ +static int +min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) +{ + int ret; + + switch (arg->ts.type) + { + case BT_INTEGER: + if (extremum->ts.kind < arg->ts.kind) + extremum->ts.kind = arg->ts.kind; + ret = mpz_cmp (arg->value.integer, + extremum->value.integer) * sign; + if (ret > 0) + mpz_set (extremum->value.integer, arg->value.integer); + break; + + case BT_REAL: + if (extremum->ts.kind < arg->ts.kind) + extremum->ts.kind = arg->ts.kind; + if (mpfr_nan_p (extremum->value.real)) + { + ret = 1; + mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); + } + else if (mpfr_nan_p (arg->value.real)) + ret = -1; + else + { + ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign; + if (ret > 0) + mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); + } + break; + + case BT_CHARACTER: +#define LENGTH(x) ((x)->value.character.length) +#define STRING(x) ((x)->value.character.string) + if (LENGTH (extremum) < LENGTH(arg)) + { + gfc_char_t *tmp = STRING(extremum); + + STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1); + memcpy (STRING(extremum), tmp, + LENGTH(extremum) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ', + LENGTH(arg) - LENGTH(extremum)); + STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */ + LENGTH(extremum) = LENGTH(arg); + free (tmp); + } + ret = gfc_compare_string (arg, extremum) * sign; + if (ret > 0) + { + free (STRING(extremum)); + STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); + memcpy (STRING(extremum), STRING(arg), + LENGTH(arg) * sizeof (gfc_char_t)); + gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ', + LENGTH(extremum) - LENGTH(arg)); + STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */ + } +#undef LENGTH +#undef STRING + break; + + default: + gfc_internal_error ("simplify_min_max(): Bad type in arglist"); + } + if (back_val && ret == 0) + ret = 1; + + return ret; +} + + +/* This function is special since MAX() can take any number of + arguments. The simplified expression is a rewritten version of the + argument list containing at most one constant element. Other + constant elements are deleted. Because the argument list has + already been checked, this function always succeeds. sign is 1 for + MAX(), -1 for MIN(). */ + +static gfc_expr * +simplify_min_max (gfc_expr *expr, int sign) +{ + int tmp1, tmp2; + gfc_actual_arglist *arg, *last, *extremum; + gfc_expr *tmp, *ret; + const char *fname; + + last = NULL; + extremum = NULL; + + arg = expr->value.function.actual; + + for (; arg; last = arg, arg = arg->next) + { + if (arg->expr->expr_type != EXPR_CONSTANT) + continue; + + if (extremum == NULL) + { + extremum = arg; + continue; + } + + min_max_choose (arg->expr, extremum->expr, sign); + + /* Delete the extra constant argument. */ + last->next = arg->next; + + arg->next = NULL; + gfc_free_actual_arglist (arg); + arg = last; + } + + /* If there is one value left, replace the function call with the + expression. */ + if (expr->value.function.actual->next != NULL) + return NULL; + + /* Handle special cases of specific functions (min|max)1 and + a(min|max)0. */ + + tmp = expr->value.function.actual->expr; + fname = expr->value.function.isym->name; + + if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind) + && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0)) + { + /* Explicit conversion, turn off -Wconversion and -Wconversion-extra + warnings. */ + tmp1 = warn_conversion; + tmp2 = warn_conversion_extra; + warn_conversion = warn_conversion_extra = 0; + + ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind); + + warn_conversion = tmp1; + warn_conversion_extra = tmp2; + } + else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind) + && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0)) + { + ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind); + } + else + ret = gfc_copy_expr (tmp); + + return ret; + +} + + +gfc_expr * +gfc_simplify_min (gfc_expr *e) +{ + return simplify_min_max (e, -1); +} + + +gfc_expr * +gfc_simplify_max (gfc_expr *e) +{ + return simplify_min_max (e, 1); +} + +/* Helper function for gfc_simplify_minval. */ + +static gfc_expr * +gfc_min (gfc_expr *op1, gfc_expr *op2) +{ + min_max_choose (op1, op2, -1); + gfc_free_expr (op1); + return op2; +} + +/* Simplify minval for constant arrays. */ + +gfc_expr * +gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, INT_MAX, gfc_min); +} + +/* Helper function for gfc_simplify_maxval. */ + +static gfc_expr * +gfc_max (gfc_expr *op1, gfc_expr *op2) +{ + min_max_choose (op1, op2, 1); + gfc_free_expr (op1); + return op2; +} + + +/* Simplify maxval for constant arrays. */ + +gfc_expr * +gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, INT_MIN, gfc_max); +} + + +/* Transform minloc or maxloc of an array, according to MASK, + to the scalar result. This code is mostly identical to + simplify_transformation_to_scalar. */ + +static gfc_expr * +simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, + gfc_expr *extremum, int sign, bool back_val) +{ + gfc_expr *a, *m; + gfc_constructor *array_ctor, *mask_ctor; + mpz_t count; + + mpz_set_si (result->value.integer, 0); + + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + array_ctor = gfc_constructor_first (array->value.constructor); + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + else + mask_ctor = NULL; + + mpz_init_set_si (count, 0); + while (array_ctor) + { + mpz_add_ui (count, count, 1); + a = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + /* A constant MASK equals .TRUE. here and can be ignored. */ + if (mask_ctor) + { + m = mask_ctor->expr; + mask_ctor = gfc_constructor_next (mask_ctor); + if (!m->value.logical) + continue; + } + if (min_max_choose (a, extremum, sign, back_val) > 0) + mpz_set (result->value.integer, count); + } + mpz_clear (count); + gfc_free_expr (extremum); + return result; +} + +/* Simplify minloc / maxloc in the absence of a dim argument. */ + +static gfc_expr * +simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum, + gfc_expr *array, gfc_expr *mask, int sign, + bool back_val) +{ + ssize_t res[GFC_MAX_DIMENSIONS]; + int i, n; + gfc_constructor *result_ctor, *array_ctor, *mask_ctor; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS]; + gfc_expr *a, *m; + bool continue_loop; + bool ma; + + for (i = 0; irank; i++) + res[i] = -1; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + goto finish; + + if (array->shape == NULL) + goto finish; + + for (i = 0; i < array->rank; i++) + { + count[i] = 0; + sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); + extent[i] = mpz_get_si (array->shape[i]); + if (extent[i] <= 0) + goto finish; + } + + continue_loop = true; + array_ctor = gfc_constructor_first (array->value.constructor); + if (mask && mask->rank > 0) + mask_ctor = gfc_constructor_first (mask->value.constructor); + else + mask_ctor = NULL; + + /* Loop over the array elements (and mask), keeping track of + the indices to return. */ + while (continue_loop) + { + do + { + a = array_ctor->expr; + if (mask_ctor) + { + m = mask_ctor->expr; + ma = m->value.logical; + mask_ctor = gfc_constructor_next (mask_ctor); + } + else + ma = true; + + if (ma && min_max_choose (a, extremum, sign, back_val) > 0) + { + for (i = 0; irank; i++) + res[i] = count[i]; + } + array_ctor = gfc_constructor_next (array_ctor); + count[0] ++; + } while (count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + n++; + if (n >= array->rank) + { + continue_loop = false; + break; + } + else + count[n] ++; + } while (count[n] == extent[n]); + } + + finish: + gfc_free_expr (extremum); + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; irank; i++) + { + gfc_expr *r_expr; + r_expr = result_ctor->expr; + mpz_set_si (r_expr->value.integer, res[i] + 1); + result_ctor = gfc_constructor_next (result_ctor); + } + return result; +} + +/* Helper function for gfc_simplify_minmaxloc - build an array + expression with n elements. */ + +static gfc_expr * +new_array (bt type, int kind, int n, locus *where) +{ + gfc_expr *result; + int i; + + result = gfc_get_array_expr (type, kind, where); + result->rank = 1; + result->shape = gfc_get_shape(1); + mpz_init_set_si (result->shape[0], n); + for (i = 0; i < n; i++) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_get_constant_expr (type, kind, where), + NULL); + } + + return result; +} + +/* Simplify minloc and maxloc. This code is mostly identical to + simplify_transformation_to_array. */ + +static gfc_expr * +simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, + gfc_expr *dim, gfc_expr *mask, + gfc_expr *extremum, int sign, bool back_val) +{ + mpz_t size; + int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; + gfc_expr **arrayvec, **resultvec, **base, **src, **dest; + gfc_constructor *array_ctor, *mask_ctor, *result_ctor; + + int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], + tmpstride[GFC_MAX_DIMENSIONS]; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + /* Build an indexed table for array element expressions to minimize + linked-list traversal. Masked elements are set to NULL. */ + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + arrayvec = XCNEWVEC (gfc_expr*, arraysize); + + array_ctor = gfc_constructor_first (array->value.constructor); + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + + for (i = 0; i < arraysize; ++i) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + + if (mask_ctor) + { + if (!mask_ctor->expr->value.logical) + arrayvec[i] = NULL; + + mask_ctor = gfc_constructor_next (mask_ctor); + } + } + + /* Same for the result expression. */ + gfc_array_size (result, &size); + resultsize = mpz_get_ui (size); + mpz_clear (size); + + resultvec = XCNEWVEC (gfc_expr*, resultsize); + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + resultvec[i] = result_ctor->expr; + result_ctor = gfc_constructor_next (result_ctor); + } + + gfc_extract_int (dim, &dim_index); + dim_index -= 1; /* zero-base index */ + dim_extent = 0; + dim_stride = 0; + + for (i = 0, n = 0; i < array->rank; ++i) + { + count[i] = 0; + tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); + if (i == dim_index) + { + dim_extent = mpz_get_si (array->shape[i]); + dim_stride = tmpstride[i]; + continue; + } + + extent[n] = mpz_get_si (array->shape[i]); + sstride[n] = tmpstride[i]; + dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; + n += 1; + } + + done = resultsize <= 0; + base = arrayvec; + dest = resultvec; + while (!done) + { + gfc_expr *ex; + ex = gfc_copy_expr (extremum); + for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) + { + if (*src && min_max_choose (*src, ex, sign, back_val) > 0) + mpz_set_si ((*dest)->value.integer, n + 1); + } + + count[0]++; + base += sstride[0]; + dest += dstride[0]; + gfc_free_expr (ex); + + n = 0; + while (!done && count[n] == extent[n]) + { + count[n] = 0; + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + + n++; + if (n < result->rank) + { + /* If the nested loop is unrolled GFC_MAX_DIMENSIONS + times, we'd warn for the last iteration, because the + array index will have already been incremented to the + array sizes, and we can't tell that this must make + the test against result->rank false, because ranks + must not exceed GFC_MAX_DIMENSIONS. */ + GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) + count[n]++; + base += sstride[n]; + dest += dstride[n]; + GCC_DIAGNOSTIC_POP + } + else + done = true; + } + } + + /* Place updated expression in result constructor. */ + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); + } + + free (arrayvec); + free (resultvec); + free (extremum); + return result; +} + +/* Simplify minloc and maxloc for constant arrays. */ + +static gfc_expr * +gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, + gfc_expr *kind, gfc_expr *back, int sign) +{ + gfc_expr *result; + gfc_expr *extremum; + int ikind; + int init_val; + bool back_val = false; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + if (kind) + { + if (gfc_extract_int (kind, &ikind, -1)) + return NULL; + } + else + ikind = gfc_default_integer_kind; + + if (back) + { + if (back->expr_type != EXPR_CONSTANT) + return NULL; + + back_val = back->value.logical; + } + + if (sign < 0) + init_val = INT_MAX; + else if (sign > 0) + init_val = INT_MIN; + else + gcc_unreachable(); + + extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); + init_result_expr (extremum, init_val, array); + + if (dim) + { + result = transformational_result (array, dim, BT_INTEGER, + ikind, &array->where); + init_result_expr (result, 0, array); + + if (array->rank == 1) + return simplify_minmaxloc_to_scalar (result, array, mask, extremum, + sign, back_val); + else + return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, + sign, back_val); + } + else + { + result = new_array (BT_INTEGER, ikind, array->rank, &array->where); + return simplify_minmaxloc_nodim (result, extremum, array, mask, + sign, back_val); + } +} + +gfc_expr * +gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, + gfc_expr *back) +{ + return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); +} + +gfc_expr * +gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, + gfc_expr *back) +{ + return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1); +} + +/* Simplify findloc to scalar. Similar to + simplify_minmaxloc_to_scalar. */ + +static gfc_expr * +simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value, + gfc_expr *mask, int back_val) +{ + gfc_expr *a, *m; + gfc_constructor *array_ctor, *mask_ctor; + mpz_t count; + + mpz_set_si (result->value.integer, 0); + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + array_ctor = gfc_constructor_first (array->value.constructor); + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + else + mask_ctor = NULL; + + mpz_init_set_si (count, 0); + while (array_ctor) + { + mpz_add_ui (count, count, 1); + a = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + /* A constant MASK equals .TRUE. here and can be ignored. */ + if (mask_ctor) + { + m = mask_ctor->expr; + mask_ctor = gfc_constructor_next (mask_ctor); + if (!m->value.logical) + continue; + } + if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) + { + /* We have a match. If BACK is true, continue so we find + the last one. */ + mpz_set (result->value.integer, count); + if (!back_val) + break; + } + } + mpz_clear (count); + return result; +} + +/* Simplify findloc in the absence of a dim argument. Similar to + simplify_minmaxloc_nodim. */ + +static gfc_expr * +simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array, + gfc_expr *mask, bool back_val) +{ + ssize_t res[GFC_MAX_DIMENSIONS]; + int i, n; + gfc_constructor *result_ctor, *array_ctor, *mask_ctor; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS]; + gfc_expr *a, *m; + bool continue_loop; + bool ma; + + for (i = 0; i < array->rank; i++) + res[i] = -1; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + goto finish; + + for (i = 0; i < array->rank; i++) + { + count[i] = 0; + sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); + extent[i] = mpz_get_si (array->shape[i]); + if (extent[i] <= 0) + goto finish; + } + + continue_loop = true; + array_ctor = gfc_constructor_first (array->value.constructor); + if (mask && mask->rank > 0) + mask_ctor = gfc_constructor_first (mask->value.constructor); + else + mask_ctor = NULL; + + /* Loop over the array elements (and mask), keeping track of + the indices to return. */ + while (continue_loop) + { + do + { + a = array_ctor->expr; + if (mask_ctor) + { + m = mask_ctor->expr; + ma = m->value.logical; + mask_ctor = gfc_constructor_next (mask_ctor); + } + else + ma = true; + + if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) + { + for (i = 0; i < array->rank; i++) + res[i] = count[i]; + if (!back_val) + goto finish; + } + array_ctor = gfc_constructor_next (array_ctor); + count[0] ++; + } while (count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + n++; + if (n >= array->rank) + { + continue_loop = false; + break; + } + else + count[n] ++; + } while (count[n] == extent[n]); + } + +finish: + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < array->rank; i++) + { + gfc_expr *r_expr; + r_expr = result_ctor->expr; + mpz_set_si (r_expr->value.integer, res[i] + 1); + result_ctor = gfc_constructor_next (result_ctor); + } + return result; +} + + +/* Simplify findloc to an array. Similar to + simplify_minmaxloc_to_array. */ + +static gfc_expr * +simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value, + gfc_expr *dim, gfc_expr *mask, bool back_val) +{ + mpz_t size; + int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; + gfc_expr **arrayvec, **resultvec, **base, **src, **dest; + gfc_constructor *array_ctor, *mask_ctor, *result_ctor; + + int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], + tmpstride[GFC_MAX_DIMENSIONS]; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + /* Build an indexed table for array element expressions to minimize + linked-list traversal. Masked elements are set to NULL. */ + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + arrayvec = XCNEWVEC (gfc_expr*, arraysize); + + array_ctor = gfc_constructor_first (array->value.constructor); + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + + for (i = 0; i < arraysize; ++i) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + + if (mask_ctor) + { + if (!mask_ctor->expr->value.logical) + arrayvec[i] = NULL; + + mask_ctor = gfc_constructor_next (mask_ctor); + } + } + + /* Same for the result expression. */ + gfc_array_size (result, &size); + resultsize = mpz_get_ui (size); + mpz_clear (size); + + resultvec = XCNEWVEC (gfc_expr*, resultsize); + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + resultvec[i] = result_ctor->expr; + result_ctor = gfc_constructor_next (result_ctor); + } + + gfc_extract_int (dim, &dim_index); + + dim_index -= 1; /* Zero-base index. */ + dim_extent = 0; + dim_stride = 0; + + for (i = 0, n = 0; i < array->rank; ++i) + { + count[i] = 0; + tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); + if (i == dim_index) + { + dim_extent = mpz_get_si (array->shape[i]); + dim_stride = tmpstride[i]; + continue; + } + + extent[n] = mpz_get_si (array->shape[i]); + sstride[n] = tmpstride[i]; + dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; + n += 1; + } + + done = resultsize <= 0; + base = arrayvec; + dest = resultvec; + while (!done) + { + for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) + { + if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0) + { + mpz_set_si ((*dest)->value.integer, n + 1); + if (!back_val) + break; + } + } + + count[0]++; + base += sstride[0]; + dest += dstride[0]; + + n = 0; + while (!done && count[n] == extent[n]) + { + count[n] = 0; + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + + n++; + if (n < result->rank) + { + /* If the nested loop is unrolled GFC_MAX_DIMENSIONS + times, we'd warn for the last iteration, because the + array index will have already been incremented to the + array sizes, and we can't tell that this must make + the test against result->rank false, because ranks + must not exceed GFC_MAX_DIMENSIONS. */ + GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) + count[n]++; + base += sstride[n]; + dest += dstride[n]; + GCC_DIAGNOSTIC_POP + } + else + done = true; + } + } + + /* Place updated expression in result constructor. */ + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); + } + + free (arrayvec); + free (resultvec); + return result; +} + +/* Simplify findloc. */ + +gfc_expr * +gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim, + gfc_expr *mask, gfc_expr *kind, gfc_expr *back) +{ + gfc_expr *result; + int ikind; + bool back_val = false; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (! gfc_is_constant_expr (value)) + return 0; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + if (kind) + { + if (gfc_extract_int (kind, &ikind, -1)) + return NULL; + } + else + ikind = gfc_default_integer_kind; + + if (back) + { + if (back->expr_type != EXPR_CONSTANT) + return NULL; + + back_val = back->value.logical; + } + + if (dim) + { + result = transformational_result (array, dim, BT_INTEGER, + ikind, &array->where); + init_result_expr (result, 0, array); + + if (array->rank == 1) + return simplify_findloc_to_scalar (result, array, value, mask, + back_val); + else + return simplify_findloc_to_array (result, array, value, dim, mask, + back_val); + } + else + { + result = new_array (BT_INTEGER, ikind, array->rank, &array->where); + return simplify_findloc_nodim (result, value, array, mask, back_val); + } + return NULL; +} + +gfc_expr * +gfc_simplify_maxexponent (gfc_expr *x) +{ + int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &x->where, + gfc_real_kinds[i].max_exponent); +} + + +gfc_expr * +gfc_simplify_minexponent (gfc_expr *x) +{ + int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &x->where, + gfc_real_kinds[i].min_exponent); +} + + +gfc_expr * +gfc_simplify_mod (gfc_expr *a, gfc_expr *p) +{ + gfc_expr *result; + int kind; + + /* First check p. */ + if (p->expr_type != EXPR_CONSTANT) + return NULL; + + /* p shall not be 0. */ + switch (p->ts.type) + { + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + gfc_error ("Argument %qs of MOD at %L shall not be zero", + "P", &p->where); + return &gfc_bad_expr; + } + break; + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + gfc_error ("Argument %qs of MOD at %L shall not be zero", + "P", &p->where); + return &gfc_bad_expr; + } + break; + default: + gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); + } + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; + result = gfc_get_constant_expr (a->ts.type, kind, &a->where); + + if (a->ts.type == BT_INTEGER) + mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); + else + { + gfc_set_model_kind (kind); + mpfr_fmod (result->value.real, a->value.real, p->value.real, + GFC_RND_MODE); + } + + return range_check (result, "MOD"); +} + + +gfc_expr * +gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) +{ + gfc_expr *result; + int kind; + + /* First check p. */ + if (p->expr_type != EXPR_CONSTANT) + return NULL; + + /* p shall not be 0. */ + switch (p->ts.type) + { + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + gfc_error ("Argument %qs of MODULO at %L shall not be zero", + "P", &p->where); + return &gfc_bad_expr; + } + break; + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + gfc_error ("Argument %qs of MODULO at %L shall not be zero", + "P", &p->where); + return &gfc_bad_expr; + } + break; + default: + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + } + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; + result = gfc_get_constant_expr (a->ts.type, kind, &a->where); + + if (a->ts.type == BT_INTEGER) + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + else + { + gfc_set_model_kind (kind); + mpfr_fmod (result->value.real, a->value.real, p->value.real, + GFC_RND_MODE); + if (mpfr_cmp_ui (result->value.real, 0) != 0) + { + if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) + mpfr_add (result->value.real, result->value.real, p->value.real, + GFC_RND_MODE); + } + else + mpfr_copysign (result->value.real, result->value.real, + p->value.real, GFC_RND_MODE); + } + + return range_check (result, "MODULO"); +} + + +gfc_expr * +gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) +{ + gfc_expr *result; + mpfr_exp_t emin, emax; + int kind; + + if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_copy_expr (x); + + /* Save current values of emin and emax. */ + emin = mpfr_get_emin (); + emax = mpfr_get_emax (); + + /* Set emin and emax for the current model number. */ + kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); + mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent - + mpfr_get_prec(result->value.real) + 1); + mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1); + mpfr_check_range (result->value.real, 0, MPFR_RNDU); + + if (mpfr_sgn (s->value.real) > 0) + { + mpfr_nextabove (result->value.real); + mpfr_subnormalize (result->value.real, 0, MPFR_RNDU); + } + else + { + mpfr_nextbelow (result->value.real); + mpfr_subnormalize (result->value.real, 0, MPFR_RNDD); + } + + mpfr_set_emin (emin); + mpfr_set_emax (emax); + + /* Only NaN can occur. Do not use range check as it gives an + error for denormal numbers. */ + if (mpfr_nan_p (result->value.real) && flag_range_check) + { + gfc_error ("Result of NEAREST is NaN at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + return result; +} + + +static gfc_expr * +simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) +{ + gfc_expr *itrunc, *result; + int kind; + + kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + itrunc = gfc_copy_expr (e); + mpfr_round (itrunc->value.real, e->value.real); + + result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); + gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); + + gfc_free_expr (itrunc); + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_new_line (gfc_expr *e) +{ + gfc_expr *result; + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1); + result->value.character.string[0] = '\n'; + + return result; +} + + +gfc_expr * +gfc_simplify_nint (gfc_expr *e, gfc_expr *k) +{ + return simplify_nint ("NINT", e, k); +} + + +gfc_expr * +gfc_simplify_idnint (gfc_expr *e) +{ + return simplify_nint ("IDNINT", e, NULL); +} + +static int norm2_scale; + +static gfc_expr * +norm2_add_squared (gfc_expr *result, gfc_expr *e) +{ + mpfr_t tmp; + + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + gfc_set_model_kind (result->ts.kind); + int index = gfc_validate_kind (BT_REAL, result->ts.kind, false); + mpfr_exp_t exp; + if (mpfr_regular_p (result->value.real)) + { + exp = mpfr_get_exp (result->value.real); + /* If result is getting close to overflowing, scale down. */ + if (exp >= gfc_real_kinds[index].max_exponent - 4 + && norm2_scale <= gfc_real_kinds[index].max_exponent - 2) + { + norm2_scale += 2; + mpfr_div_ui (result->value.real, result->value.real, 16, + GFC_RND_MODE); + } + } + + mpfr_init (tmp); + if (mpfr_regular_p (e->value.real)) + { + exp = mpfr_get_exp (e->value.real); + /* If e**2 would overflow or close to overflowing, scale down. */ + if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2) + { + int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4; + mpfr_set_ui (tmp, 1, GFC_RND_MODE); + mpfr_set_exp (tmp, new_scale - norm2_scale); + mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); + mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE); + norm2_scale = new_scale; + } + } + if (norm2_scale) + { + mpfr_set_ui (tmp, 1, GFC_RND_MODE); + mpfr_set_exp (tmp, norm2_scale); + mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE); + } + else + mpfr_set (tmp, e->value.real, GFC_RND_MODE); + mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE); + mpfr_add (result->value.real, result->value.real, tmp, + GFC_RND_MODE); + mpfr_clear (tmp); + + return result; +} + + +static gfc_expr * +norm2_do_sqrt (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_REAL + && result->expr_type == EXPR_CONSTANT); + + if (result != e) + mpfr_set (result->value.real, e->value.real, GFC_RND_MODE); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + if (norm2_scale && mpfr_regular_p (result->value.real)) + { + mpfr_t tmp; + mpfr_init (tmp); + mpfr_set_ui (tmp, 1, GFC_RND_MODE); + mpfr_set_exp (tmp, norm2_scale); + mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); + mpfr_clear (tmp); + } + norm2_scale = 0; + + return result; +} + + +gfc_expr * +gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) +{ + gfc_expr *result; + bool size_zero; + + size_zero = gfc_is_size_zero_array (e); + + if (!(is_constant_array_expr (e) || size_zero) + || (dim != NULL && !gfc_is_constant_expr (dim))) + return NULL; + + result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); + init_result_expr (result, 0, NULL); + + if (size_zero) + return result; + + norm2_scale = 0; + if (!dim || e->rank == 1) + { + result = simplify_transformation_to_scalar (result, e, NULL, + norm2_add_squared); + mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE); + if (norm2_scale && mpfr_regular_p (result->value.real)) + { + mpfr_t tmp; + mpfr_init (tmp); + mpfr_set_ui (tmp, 1, GFC_RND_MODE); + mpfr_set_exp (tmp, norm2_scale); + mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE); + mpfr_clear (tmp); + } + norm2_scale = 0; + } + else + result = simplify_transformation_to_array (result, e, dim, NULL, + norm2_add_squared, + norm2_do_sqrt); + + return result; +} + + +gfc_expr * +gfc_simplify_not (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpz_com (result->value.integer, e->value.integer); + + return range_check (result, "NOT"); +} + + +gfc_expr * +gfc_simplify_null (gfc_expr *mold) +{ + gfc_expr *result; + + if (mold) + { + result = gfc_copy_expr (mold); + result->expr_type = EXPR_NULL; + } + else + result = gfc_get_null_expr (NULL); + + return result; +} + + +gfc_expr * +gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) +{ + gfc_expr *result; + + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return &gfc_bad_expr; + } + + if (flag_coarray != GFC_FCOARRAY_SINGLE) + return NULL; + + if (failed && failed->expr_type != EXPR_CONSTANT) + return NULL; + + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + + if (failed && failed->value.logical != 0) + mpz_set_si (result->value.integer, 0); + else + mpz_set_si (result->value.integer, 1); + + return result; +} + + +gfc_expr * +gfc_simplify_or (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + + switch (x->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_ior (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "OR"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + x->value.logical || y->value.logical); + default: + gcc_unreachable(); + } +} + + +gfc_expr * +gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) +{ + gfc_expr *result; + gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; + + if (!is_constant_array_expr (array) + || !is_constant_array_expr (vector) + || (!gfc_is_constant_expr (mask) + && !is_constant_array_expr (mask))) + return NULL; + + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + if (array->ts.type == BT_DERIVED) + result->ts.u.derived = array->ts.u.derived; + + array_ctor = gfc_constructor_first (array->value.constructor); + vector_ctor = vector + ? gfc_constructor_first (vector->value.constructor) + : NULL; + + if (mask->expr_type == EXPR_CONSTANT + && mask->value.logical) + { + /* Copy all elements of ARRAY to RESULT. */ + while (array_ctor) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); + + array_ctor = gfc_constructor_next (array_ctor); + vector_ctor = gfc_constructor_next (vector_ctor); + } + } + else if (mask->expr_type == EXPR_ARRAY) + { + /* Copy only those elements of ARRAY to RESULT whose + MASK equals .TRUE.. */ + mask_ctor = gfc_constructor_first (mask->value.constructor); + while (mask_ctor) + { + if (mask_ctor->expr->value.logical) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (array_ctor->expr), + NULL); + vector_ctor = gfc_constructor_next (vector_ctor); + } + + array_ctor = gfc_constructor_next (array_ctor); + mask_ctor = gfc_constructor_next (mask_ctor); + } + } + + /* Append any left-over elements from VECTOR to RESULT. */ + while (vector_ctor) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (vector_ctor->expr), + NULL); + vector_ctor = gfc_constructor_next (vector_ctor); + } + + result->shape = gfc_get_shape (1); + gfc_array_size (result, &result->shape[0]); + + if (array->ts.type == BT_CHARACTER) + result->ts.u.cl = array->ts.u.cl; + + return result; +} + + +static gfc_expr * +do_xor (gfc_expr *result, gfc_expr *e) +{ + gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT); + gcc_assert (result->ts.type == BT_LOGICAL + && result->expr_type == EXPR_CONSTANT); + + result->value.logical = result->value.logical != e->value.logical; + return result; +} + + +gfc_expr * +gfc_simplify_is_contiguous (gfc_expr *array) +{ + if (gfc_is_simply_contiguous (array, false, true)) + return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1); + + if (gfc_is_not_contiguous (array)) + return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0); + + return NULL; +} + + +gfc_expr * +gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) +{ + return simplify_transformation (e, dim, NULL, 0, do_xor); +} + + +gfc_expr * +gfc_simplify_popcnt (gfc_expr *e) +{ + int res, k; + mpz_t x; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + k = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + /* Convert argument to unsigned, then count the '1' bits. */ + mpz_init_set (x, e->value.integer); + convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size); + res = mpz_popcount (x); + mpz_clear (x); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res); +} + + +gfc_expr * +gfc_simplify_poppar (gfc_expr *e) +{ + gfc_expr *popcnt; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + popcnt = gfc_simplify_popcnt (e); + gcc_assert (popcnt); + + bool fail = gfc_extract_int (popcnt, &i); + gcc_assert (!fail); + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2); +} + + +gfc_expr * +gfc_simplify_precision (gfc_expr *e) +{ + int i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, + gfc_real_kinds[i].precision); +} + + +gfc_expr * +gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 1, gfc_multiply); +} + + +gfc_expr * +gfc_simplify_radix (gfc_expr *e) +{ + int i; + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + switch (e->ts.type) + { + case BT_INTEGER: + i = gfc_integer_kinds[i].radix; + break; + + case BT_REAL: + i = gfc_real_kinds[i].radix; + break; + + default: + gcc_unreachable (); + } + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); +} + + +gfc_expr * +gfc_simplify_range (gfc_expr *e) +{ + int i; + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + + switch (e->ts.type) + { + case BT_INTEGER: + i = gfc_integer_kinds[i].range; + break; + + case BT_REAL: + case BT_COMPLEX: + i = gfc_real_kinds[i].range; + break; + + default: + gcc_unreachable (); + } + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i); +} + + +gfc_expr * +gfc_simplify_rank (gfc_expr *e) +{ + /* Assumed rank. */ + if (e->rank == -1) + return NULL; + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); +} + + +gfc_expr * +gfc_simplify_real (gfc_expr *e, gfc_expr *k) +{ + gfc_expr *result = NULL; + int kind, tmp1, tmp2; + + /* Convert BOZ to real, and return without range checking. */ + if (e->ts.type == BT_BOZ) + { + /* Determine kind for conversion of the BOZ. */ + if (k) + gfc_extract_int (k, &kind); + else + kind = gfc_default_real_kind; + + if (!gfc_boz2real (e, kind)) + return NULL; + result = gfc_copy_expr (e); + return result; + } + + if (e->ts.type == BT_COMPLEX) + kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); + else + kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind); + + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + /* For explicit conversion, turn off -Wconversion and -Wconversion-extra + warnings. */ + tmp1 = warn_conversion; + tmp2 = warn_conversion_extra; + warn_conversion = warn_conversion_extra = 0; + + result = gfc_convert_constant (e, BT_REAL, kind); + + warn_conversion = tmp1; + warn_conversion_extra = tmp2; + + if (result == &gfc_bad_expr) + return &gfc_bad_expr; + + return range_check (result, "REAL"); +} + + +gfc_expr * +gfc_simplify_realpart (gfc_expr *e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpc_real (result->value.real, e->value.complex, GFC_RND_MODE); + + return range_check (result, "REALPART"); +} + +gfc_expr * +gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) +{ + gfc_expr *result; + gfc_charlen_t len; + mpz_t ncopies; + bool have_length = false; + + /* If NCOPIES isn't a constant, there's nothing we can do. */ + if (n->expr_type != EXPR_CONSTANT) + return NULL; + + /* If NCOPIES is negative, it's an error. */ + if (mpz_sgn (n->value.integer) < 0) + { + gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", + &n->where); + return &gfc_bad_expr; + } + + /* If we don't know the character length, we can do no more. */ + if (e->ts.u.cl && e->ts.u.cl->length + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) + { + len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer); + have_length = true; + } + else if (e->expr_type == EXPR_CONSTANT + && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL)) + { + len = e->value.character.length; + } + else + return NULL; + + /* If the source length is 0, any value of NCOPIES is valid + and everything behaves as if NCOPIES == 0. */ + mpz_init (ncopies); + if (len == 0) + mpz_set_ui (ncopies, 0); + else + mpz_set (ncopies, n->value.integer); + + /* Check that NCOPIES isn't too large. */ + if (len) + { + mpz_t max, mlen; + int i; + + /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ + mpz_init (max); + i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); + + if (have_length) + { + mpz_tdiv_q (max, gfc_integer_kinds[i].huge, + e->ts.u.cl->length->value.integer); + } + else + { + mpz_init (mlen); + gfc_mpz_set_hwi (mlen, len); + mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen); + mpz_clear (mlen); + } + + /* The check itself. */ + if (mpz_cmp (ncopies, max) > 0) + { + mpz_clear (max); + mpz_clear (ncopies); + gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", + &n->where); + return &gfc_bad_expr; + } + + mpz_clear (max); + } + mpz_clear (ncopies); + + /* For further simplification, we need the character string to be + constant. */ + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + HOST_WIDE_INT ncop; + if (len || + (e->ts.u.cl->length && + mpz_sgn (e->ts.u.cl->length->value.integer) != 0)) + { + bool fail = gfc_extract_hwi (n, &ncop); + gcc_assert (!fail); + } + else + ncop = 0; + + if (ncop == 0) + return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0); + + len = e->value.character.length; + gfc_charlen_t nlen = ncop * len; + + /* Here's a semi-arbitrary limit. If the string is longer than 1 GB + (2**28 elements * 4 bytes (wide chars) per element) defer to + runtime instead of consuming (unbounded) memory and CPU at + compile time. */ + if (nlen > 268435456) + { + gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L" + " deferred to runtime, expect bugs", &e->where); + return NULL; + } + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen); + for (size_t i = 0; i < (size_t) ncop; i++) + for (size_t j = 0; j < (size_t) len; j++) + result->value.character.string[j+i*len]= e->value.character.string[j]; + + result->value.character.string[nlen] = '\0'; /* For debugger */ + return result; +} + + +/* This one is a bear, but mainly has to do with shuffling elements. */ + +gfc_expr * +gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, + gfc_expr *pad, gfc_expr *order_exp) +{ + int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; + int i, rank, npad, x[GFC_MAX_DIMENSIONS]; + mpz_t index, size; + unsigned long j; + size_t nsource; + gfc_expr *e, *result; + bool zerosize = false; + + /* Check that argument expression types are OK. */ + if (!is_constant_array_expr (source) + || !is_constant_array_expr (shape_exp) + || !is_constant_array_expr (pad) + || !is_constant_array_expr (order_exp)) + return NULL; + + if (source->shape == NULL) + return NULL; + + /* Proceed with simplification, unpacking the array. */ + + mpz_init (index); + rank = 0; + + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + x[i] = 0; + + for (;;) + { + e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank); + if (e == NULL) + break; + + gfc_extract_int (e, &shape[rank]); + + gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS); + if (shape[rank] < 0) + { + gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a " + "negative value %d for dimension %d", + &shape_exp->where, shape[rank], rank+1); + return &gfc_bad_expr; + } + + rank++; + } + + gcc_assert (rank > 0); + + /* Now unpack the order array if present. */ + if (order_exp == NULL) + { + for (i = 0; i < rank; i++) + order[i] = i; + } + else + { + mpz_t size; + int order_size, shape_size; + + if (order_exp->rank != shape_exp->rank) + { + gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different", + &order_exp->where, &shape_exp->where); + return &gfc_bad_expr; + } + + gfc_array_size (shape_exp, &size); + shape_size = mpz_get_ui (size); + mpz_clear (size); + gfc_array_size (order_exp, &size); + order_size = mpz_get_ui (size); + mpz_clear (size); + if (order_size != shape_size) + { + gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different", + &order_exp->where, &shape_exp->where); + return &gfc_bad_expr; + } + + for (i = 0; i < rank; i++) + { + e = gfc_constructor_lookup_expr (order_exp->value.constructor, i); + gcc_assert (e); + + gfc_extract_int (e, &order[i]); + + if (order[i] < 1 || order[i] > rank) + { + gfc_error ("Element with a value of %d in ORDER at %L must be " + "in the range [1, ..., %d] for the RESHAPE intrinsic " + "near %L", order[i], &order_exp->where, rank, + &shape_exp->where); + return &gfc_bad_expr; + } + + order[i]--; + if (x[order[i]] != 0) + { + gfc_error ("ORDER at %L is not a permutation of the size of " + "SHAPE at %L", &order_exp->where, &shape_exp->where); + return &gfc_bad_expr; + } + x[order[i]] = 1; + } + } + + /* Count the elements in the source and padding arrays. */ + + npad = 0; + if (pad != NULL) + { + gfc_array_size (pad, &size); + npad = mpz_get_ui (size); + mpz_clear (size); + } + + gfc_array_size (source, &size); + nsource = mpz_get_ui (size); + mpz_clear (size); + + /* If it weren't for that pesky permutation we could just loop + through the source and round out any shortage with pad elements. + But no, someone just had to have the compiler do something the + user should be doing. */ + + for (i = 0; i < rank; i++) + x[i] = 0; + + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; + if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL) + result->ts = source->ts; + result->rank = rank; + result->shape = gfc_get_shape (rank); + for (i = 0; i < rank; i++) + { + mpz_init_set_ui (result->shape[i], shape[i]); + if (shape[i] == 0) + zerosize = true; + } + + if (zerosize) + goto sizezero; + + while (nsource > 0 || npad > 0) + { + /* Figure out which element to extract. */ + mpz_set_ui (index, 0); + + for (i = rank - 1; i >= 0; i--) + { + mpz_add_ui (index, index, x[order[i]]); + if (i != 0) + mpz_mul_ui (index, index, shape[order[i - 1]]); + } + + if (mpz_cmp_ui (index, INT_MAX) > 0) + gfc_internal_error ("Reshaped array too large at %C"); + + j = mpz_get_ui (index); + + if (j < nsource) + e = gfc_constructor_lookup_expr (source->value.constructor, j); + else + { + if (npad <= 0) + { + mpz_clear (index); + return NULL; + } + j = j - nsource; + j = j % npad; + e = gfc_constructor_lookup_expr (pad->value.constructor, j); + } + gcc_assert (e); + + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (e), &e->where); + + /* Calculate the next element. */ + i = 0; + +inc: + if (++x[i] < shape[i]) + continue; + x[i++] = 0; + if (i < rank) + goto inc; + + break; + } + +sizezero: + + mpz_clear (index); + + return result; +} + + +gfc_expr * +gfc_simplify_rrspacing (gfc_expr *x) +{ + gfc_expr *result; + int i; + long int e, p; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (x->ts.type, x->ts.kind, false); + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + /* RRSPACING(+/- 0.0) = 0.0 */ + if (mpfr_zero_p (x->value.real)) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + /* RRSPACING(inf) = NaN */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); + return result; + } + + /* RRSPACING(NaN) = same NaN */ + if (mpfr_nan_p (x->value.real)) + { + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + return result; + } + + /* | x * 2**(-e) | * 2**p. */ + mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE); + e = - (long int) mpfr_get_exp (x->value.real); + mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE); + + p = (long int) gfc_real_kinds[i].digits; + mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE); + + return range_check (result, "RRSPACING"); +} + + +gfc_expr * +gfc_simplify_scale (gfc_expr *x, gfc_expr *i) +{ + int k, neg_flag, power, exp_range; + mpfr_t scale, radix; + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + if (mpfr_zero_p (x->value.real)) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + k = gfc_validate_kind (BT_REAL, x->ts.kind, false); + + exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; + + /* This check filters out values of i that would overflow an int. */ + if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 + || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) + { + gfc_error ("Result of SCALE overflows its kind at %L", &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + /* Compute scale = radix ** power. */ + power = mpz_get_si (i->value.integer); + + if (power >= 0) + neg_flag = 0; + else + { + neg_flag = 1; + power = -power; + } + + gfc_set_model_kind (x->ts.kind); + mpfr_init (scale); + mpfr_init (radix); + mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE); + mpfr_pow_ui (scale, radix, power, GFC_RND_MODE); + + if (neg_flag) + mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE); + else + mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE); + + mpfr_clears (scale, radix, NULL); + + return range_check (result, "SCALE"); +} + + +/* Variants of strspn and strcspn that operate on wide characters. */ + +static size_t +wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c == '\0') + break; + i++; + } + + return i; +} + +static size_t +wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2) +{ + size_t i = 0; + const gfc_char_t *c; + + while (s1[i]) + { + for (c = s2; *c; c++) + { + if (s1[i] == *c) + break; + } + if (*c) + break; + i++; + } + + return i; +} + + +gfc_expr * +gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind) +{ + gfc_expr *result; + int back; + size_t i; + size_t indx, len, lenc; + int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT + || ( b != NULL && b->expr_type != EXPR_CONSTANT)) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + len = e->value.character.length; + lenc = c->value.character.length; + + if (len == 0 || lenc == 0) + { + indx = 0; + } + else + { + if (back == 0) + { + indx = wide_strcspn (e->value.character.string, + c->value.character.string) + 1; + if (indx > len) + indx = 0; + } + else + for (indx = len; indx > 0; indx--) + { + for (i = 0; i < lenc; i++) + { + if (c->value.character.string[i] + == e->value.character.string[indx - 1]) + break; + } + if (i < lenc) + break; + } + } + + result = gfc_get_int_expr (k, &e->where, indx); + return range_check (result, "SCAN"); +} + + +gfc_expr * +gfc_simplify_selected_char_kind (gfc_expr *e) +{ + int kind; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_compare_with_Cstring (e, "ascii", false) == 0 + || gfc_compare_with_Cstring (e, "default", false) == 0) + kind = 1; + else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0) + kind = 4; + else + kind = -1; + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); +} + + +gfc_expr * +gfc_simplify_selected_int_kind (gfc_expr *e) +{ + int i, kind, range; + + if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range)) + return NULL; + + kind = INT_MAX; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].range >= range + && gfc_integer_kinds[i].kind < kind) + kind = gfc_integer_kinds[i].kind; + + if (kind == INT_MAX) + kind = -1; + + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind); +} + + +gfc_expr * +gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx) +{ + int range, precision, radix, i, kind, found_precision, found_range, + found_radix; + locus *loc = &gfc_current_locus; + + if (p == NULL) + precision = 0; + else + { + if (p->expr_type != EXPR_CONSTANT + || gfc_extract_int (p, &precision)) + return NULL; + loc = &p->where; + } + + if (q == NULL) + range = 0; + else + { + if (q->expr_type != EXPR_CONSTANT + || gfc_extract_int (q, &range)) + return NULL; + + if (!loc) + loc = &q->where; + } + + if (rdx == NULL) + radix = 0; + else + { + if (rdx->expr_type != EXPR_CONSTANT + || gfc_extract_int (rdx, &radix)) + return NULL; + + if (!loc) + loc = &rdx->where; + } + + kind = INT_MAX; + found_precision = 0; + found_range = 0; + found_radix = 0; + + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + { + if (gfc_real_kinds[i].precision >= precision) + found_precision = 1; + + if (gfc_real_kinds[i].range >= range) + found_range = 1; + + if (radix == 0 || gfc_real_kinds[i].radix == radix) + found_radix = 1; + + if (gfc_real_kinds[i].precision >= precision + && gfc_real_kinds[i].range >= range + && (radix == 0 || gfc_real_kinds[i].radix == radix) + && gfc_real_kinds[i].kind < kind) + kind = gfc_real_kinds[i].kind; + } + + if (kind == INT_MAX) + { + if (found_radix && found_range && !found_precision) + kind = -1; + else if (found_radix && found_precision && !found_range) + kind = -2; + else if (found_radix && !found_precision && !found_range) + kind = -3; + else if (found_radix) + kind = -4; + else + kind = -5; + } + + return gfc_get_int_expr (gfc_default_integer_kind, loc, kind); +} + + +gfc_expr * +gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) +{ + gfc_expr *result; + mpfr_t exp, absv, log2, pow2, frac; + unsigned long exp2; + + if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + /* SET_EXPONENT (+/-0.0, I) = +/- 0.0 + SET_EXPONENT (NaN) = same NaN */ + if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real)) + { + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + return result; + } + + /* SET_EXPONENT (inf) = NaN */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); + return result; + } + + gfc_set_model_kind (x->ts.kind); + mpfr_init (absv); + mpfr_init (log2); + mpfr_init (exp); + mpfr_init (pow2); + mpfr_init (frac); + + mpfr_abs (absv, x->value.real, GFC_RND_MODE); + mpfr_log2 (log2, absv, GFC_RND_MODE); + + mpfr_trunc (log2, log2); + mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); + + /* Old exponent value, and fraction. */ + mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); + + mpfr_div (frac, absv, pow2, GFC_RND_MODE); + + /* New exponent. */ + exp2 = (unsigned long) mpz_get_d (i->value.integer); + mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE); + + mpfr_clears (absv, log2, pow2, frac, NULL); + + return range_check (result, "SET_EXPONENT"); +} + + +gfc_expr * +gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) +{ + mpz_t shape[GFC_MAX_DIMENSIONS]; + gfc_expr *result, *e, *f; + gfc_array_ref *ar; + int n; + bool t; + int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); + + if (source->rank == -1) + return NULL; + + result = gfc_get_array_expr (BT_INTEGER, k, &source->where); + result->shape = gfc_get_shape (1); + mpz_init (result->shape[0]); + + if (source->rank == 0) + return result; + + if (source->expr_type == EXPR_VARIABLE) + { + ar = gfc_find_array_ref (source); + t = gfc_array_ref_shape (ar, shape); + } + else if (source->shape) + { + t = true; + for (n = 0; n < source->rank; n++) + { + mpz_init (shape[n]); + mpz_set (shape[n], source->shape[n]); + } + } + else + t = false; + + for (n = 0; n < source->rank; n++) + { + e = gfc_get_constant_expr (BT_INTEGER, k, &source->where); + + if (t) + mpz_set (e->value.integer, shape[n]); + else + { + mpz_set_ui (e->value.integer, n + 1); + + f = simplify_size (source, e, k); + gfc_free_expr (e); + if (f == NULL) + { + gfc_free_expr (result); + return NULL; + } + else + e = f; + } + + if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr) + { + gfc_free_expr (result); + if (t) + gfc_clear_shape (shape, source->rank); + return &gfc_bad_expr; + } + + gfc_constructor_append_expr (&result->value.constructor, e, NULL); + } + + if (t) + gfc_clear_shape (shape, source->rank); + + mpz_set_si (result->shape[0], source->rank); + + return result; +} + + +static gfc_expr * +simplify_size (gfc_expr *array, gfc_expr *dim, int k) +{ + mpz_t size; + gfc_expr *return_value; + int d; + gfc_ref *ref; + + /* For unary operations, the size of the result is given by the size + of the operand. For binary ones, it's the size of the first operand + unless it is scalar, then it is the size of the second. */ + if (array->expr_type == EXPR_OP && !array->value.op.uop) + { + gfc_expr* replacement; + gfc_expr* simplified; + + switch (array->value.op.op) + { + /* Unary operations. */ + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_PARENTHESES: + replacement = array->value.op.op1; + break; + + /* Binary operations. If any one of the operands is scalar, take + the other one's size. If both of them are arrays, it does not + matter -- try to find one with known shape, if possible. */ + default: + if (array->value.op.op1->rank == 0) + replacement = array->value.op.op2; + else if (array->value.op.op2->rank == 0) + replacement = array->value.op.op1; + else + { + simplified = simplify_size (array->value.op.op1, dim, k); + if (simplified) + return simplified; + + replacement = array->value.op.op2; + } + break; + } + + /* Try to reduce it directly if possible. */ + simplified = simplify_size (replacement, dim, k); + + /* Otherwise, we build a new SIZE call. This is hopefully at least + simpler than the original one. */ + if (!simplified) + { + gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k); + simplified = gfc_build_intrinsic_call (gfc_current_ns, + GFC_ISYM_SIZE, "size", + array->where, 3, + gfc_copy_expr (replacement), + gfc_copy_expr (dim), + kind); + } + return simplified; + } + + for (ref = array->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.as) + gfc_resolve_array_spec (ref->u.ar.as, 0); + + if (dim == NULL) + { + if (!gfc_array_size (array, &size)) + return NULL; + } + else + { + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_ui (dim->value.integer) - 1; + if (!gfc_array_dimen_size (array, d, &size)) + return NULL; + } + + return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where); + mpz_set (return_value->value.integer, size); + mpz_clear (size); + + return return_value; +} + + +gfc_expr * +gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + gfc_expr *result; + int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + result = simplify_size (array, dim, k); + if (result == NULL || result == &gfc_bad_expr) + return result; + + return range_check (result, "SIZE"); +} + + +/* SIZEOF and C_SIZEOF return the size in bytes of an array element + multiplied by the array size. */ + +gfc_expr * +gfc_simplify_sizeof (gfc_expr *x) +{ + gfc_expr *result = NULL; + mpz_t array_size; + size_t res_size; + + if (x->ts.type == BT_CLASS || x->ts.deferred) + return NULL; + + if (x->ts.type == BT_CHARACTER + && (!x->ts.u.cl || !x->ts.u.cl->length + || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) + return NULL; + + if (x->rank && x->expr_type != EXPR_ARRAY + && !gfc_array_size (x, &array_size)) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &x->where); + gfc_target_expr_size (x, &res_size); + mpz_set_si (result->value.integer, res_size); + + return result; +} + + +/* STORAGE_SIZE returns the size in bits of a single array element. */ + +gfc_expr * +gfc_simplify_storage_size (gfc_expr *x, + gfc_expr *kind) +{ + gfc_expr *result = NULL; + int k; + size_t siz; + + if (x->ts.type == BT_CLASS || x->ts.deferred) + return NULL; + + if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT + && (!x->ts.u.cl || !x->ts.u.cl->length + || x->ts.u.cl->length->expr_type != EXPR_CONSTANT)) + return NULL; + + k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind); + if (k == -1) + return &gfc_bad_expr; + + result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); + + gfc_element_size (x, &siz); + mpz_set_si (result->value.integer, siz); + mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); + + return range_check (result, "STORAGE_SIZE"); +} + + +gfc_expr * +gfc_simplify_sign (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + mpz_abs (result->value.integer, x->value.integer); + if (mpz_sgn (y->value.integer) < 0) + mpz_neg (result->value.integer, result->value.integer); + break; + + case BT_REAL: + if (flag_sign_zero) + mpfr_copysign (result->value.real, x->value.real, y->value.real, + GFC_RND_MODE); + else + mpfr_setsign (result->value.real, x->value.real, + mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); + break; + + default: + gfc_internal_error ("Bad type in gfc_simplify_sign"); + } + + return result; +} + + +gfc_expr * +gfc_simplify_sin (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model (x->value.real); + mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("in gfc_simplify_sin(): Bad type"); + } + + return range_check (result, "SIN"); +} + + +gfc_expr * +gfc_simplify_sinh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "SINH"); +} + + +/* The argument is always a double precision real that is converted to + single precision. TODO: Rounding! */ + +gfc_expr * +gfc_simplify_sngl (gfc_expr *a) +{ + gfc_expr *result; + int tmp1, tmp2; + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + /* For explicit conversion, turn off -Wconversion and -Wconversion-extra + warnings. */ + tmp1 = warn_conversion; + tmp2 = warn_conversion_extra; + warn_conversion = warn_conversion_extra = 0; + + result = gfc_real2real (a, gfc_default_real_kind); + + warn_conversion = tmp1; + warn_conversion_extra = tmp2; + + return range_check (result, "SNGL"); +} + + +gfc_expr * +gfc_simplify_spacing (gfc_expr *x) +{ + gfc_expr *result; + int i; + long int en, ep; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (x->ts.type, x->ts.kind, false); + result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where); + + /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */ + if (mpfr_zero_p (x->value.real)) + { + mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); + return result; + } + + /* SPACING(inf) = NaN */ + if (mpfr_inf_p (x->value.real)) + { + mpfr_set_nan (result->value.real); + return result; + } + + /* SPACING(NaN) = same NaN */ + if (mpfr_nan_p (x->value.real)) + { + mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); + return result; + } + + /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p + are the radix, exponent of x, and precision. This excludes the + possibility of subnormal numbers. Fortran 2003 states the result is + b**max(e - p, emin - 1). */ + + ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits; + en = (long int) gfc_real_kinds[i].min_exponent - 1; + en = en > ep ? en : ep; + + mpfr_set_ui (result->value.real, 1, GFC_RND_MODE); + mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE); + + return range_check (result, "SPACING"); +} + + +gfc_expr * +gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr) +{ + gfc_expr *result = NULL; + int nelem, i, j, dim, ncopies; + mpz_t size; + + if ((!gfc_is_constant_expr (source) + && !is_constant_array_expr (source)) + || !gfc_is_constant_expr (dim_expr) + || !gfc_is_constant_expr (ncopies_expr)) + return NULL; + + gcc_assert (dim_expr->ts.type == BT_INTEGER); + gfc_extract_int (dim_expr, &dim); + dim -= 1; /* zero-base DIM */ + + gcc_assert (ncopies_expr->ts.type == BT_INTEGER); + gfc_extract_int (ncopies_expr, &ncopies); + ncopies = MAX (ncopies, 0); + + /* Do not allow the array size to exceed the limit for an array + constructor. */ + if (source->expr_type == EXPR_ARRAY) + { + if (!gfc_array_size (source, &size)) + gfc_internal_error ("Failure getting length of a constant array."); + } + else + mpz_init_set_ui (size, 1); + + nelem = mpz_get_si (size) * ncopies; + if (nelem > flag_max_array_constructor) + { + if (gfc_init_expr_flag) + { + gfc_error ("The number of elements (%d) in the array constructor " + "at %L requires an increase of the allowed %d upper " + "limit. See %<-fmax-array-constructor%> option.", + nelem, &source->where, flag_max_array_constructor); + return &gfc_bad_expr; + } + else + return NULL; + } + + if (source->expr_type == EXPR_CONSTANT + || source->expr_type == EXPR_STRUCTURE) + { + gcc_assert (dim == 0); + + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], ncopies); + + for (i = 0; i < ncopies; ++i) + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (source), NULL); + } + else if (source->expr_type == EXPR_ARRAY) + { + int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS]; + gfc_constructor *source_ctor; + + gcc_assert (source->rank < GFC_MAX_DIMENSIONS); + gcc_assert (dim >= 0 && dim <= source->rank); + + result = gfc_get_array_expr (source->ts.type, source->ts.kind, + &source->where); + if (source->ts.type == BT_DERIVED) + result->ts.u.derived = source->ts.u.derived; + result->rank = source->rank + 1; + result->shape = gfc_get_shape (result->rank); + + for (i = 0, j = 0; i < result->rank; ++i) + { + if (i != dim) + mpz_init_set (result->shape[i], source->shape[j++]); + else + mpz_init_set_si (result->shape[i], ncopies); + + extent[i] = mpz_get_si (result->shape[i]); + rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1]; + } + + offset = 0; + for (source_ctor = gfc_constructor_first (source->value.constructor); + source_ctor; source_ctor = gfc_constructor_next (source_ctor)) + { + for (i = 0; i < ncopies; ++i) + gfc_constructor_insert_expr (&result->value.constructor, + gfc_copy_expr (source_ctor->expr), + NULL, offset + i * rstride[dim]); + + offset += (dim == 0 ? ncopies : 1); + } + } + else + { + gfc_error ("Simplification of SPREAD at %C not yet implemented"); + return &gfc_bad_expr; + } + + if (source->ts.type == BT_CHARACTER) + result->ts.u.cl = source->ts.u.cl; + + return result; +} + + +gfc_expr * +gfc_simplify_sqrt (gfc_expr *e) +{ + gfc_expr *result = NULL; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + switch (e->ts.type) + { + case BT_REAL: + if (mpfr_cmp_si (e->value.real, 0) < 0) + { + gfc_error ("Argument of SQRT at %L has a negative value", + &e->where); + return &gfc_bad_expr; + } + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model (e->value.real); + + result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); + mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gfc_internal_error ("invalid argument of SQRT at %L", &e->where); + } + + return range_check (result, "SQRT"); +} + + +gfc_expr * +gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) +{ + return simplify_transformation (array, dim, mask, 0, gfc_add); +} + + +/* Simplify COTAN(X) where X has the unit of radian. */ + +gfc_expr * +gfc_simplify_cotan (gfc_expr *x) +{ + gfc_expr *result; + mpc_t swp, *val; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + /* There is no builtin mpc_cot, so compute cot = cos / sin. */ + val = &result->value.complex; + mpc_init2 (swp, mpfr_get_default_prec ()); + mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE, + GFC_MPC_RND_MODE); + mpc_div (*val, swp, *val, GFC_MPC_RND_MODE); + mpc_clear (swp); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "COTAN"); +} + + +gfc_expr * +gfc_simplify_tan (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "TAN"); +} + + +gfc_expr * +gfc_simplify_tanh (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE); + break; + + default: + gcc_unreachable (); + } + + return range_check (result, "TANH"); +} + + +gfc_expr * +gfc_simplify_tiny (gfc_expr *e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (BT_REAL, e->ts.kind, false); + + result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE); + + return result; +} + + +gfc_expr * +gfc_simplify_trailz (gfc_expr *e) +{ + unsigned long tz, bs; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (e->ts.type, e->ts.kind, false); + bs = gfc_integer_kinds[i].bit_size; + tz = mpz_scan1 (e->value.integer, 0); + + return gfc_get_int_expr (gfc_default_integer_kind, + &e->where, MIN (tz, bs)); +} + + +gfc_expr * +gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) +{ + gfc_expr *result; + gfc_expr *mold_element; + size_t source_size; + size_t result_size; + size_t buffer_size; + mpz_t tmp; + unsigned char *buffer; + size_t result_length; + + if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size)) + return NULL; + + if (!gfc_resolve_expr (mold)) + return NULL; + if (gfc_init_expr_flag && !gfc_is_constant_expr (mold)) + return NULL; + + if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, + &result_size, &result_length)) + return NULL; + + /* Calculate the size of the source. */ + if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp)) + gfc_internal_error ("Failure getting length of a constant array."); + + /* Create an empty new expression with the appropriate characteristics. */ + result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind, + &source->where); + result->ts = mold->ts; + + mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor) + ? gfc_constructor_first (mold->value.constructor)->expr + : mold; + + /* Set result character length, if needed. Note that this needs to be + set even for array expressions, in order to pass this information into + gfc_target_interpret_expr. */ + if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) + result->value.character.length = mold_element->value.character.length; + + /* Set the number of elements in the result, and determine its size. */ + + if (mold->expr_type == EXPR_ARRAY || mold->rank || size) + { + result->expr_type = EXPR_ARRAY; + result->rank = 1; + result->shape = gfc_get_shape (1); + mpz_init_set_ui (result->shape[0], result_length); + } + else + result->rank = 0; + + /* Allocate the buffer to store the binary version of the source. */ + buffer_size = MAX (source_size, result_size); + buffer = (unsigned char*)alloca (buffer_size); + memset (buffer, 0, buffer_size); + + /* Now write source to the buffer. */ + gfc_target_encode_expr (source, buffer, buffer_size); + + /* And read the buffer back into the new expression. */ + gfc_target_interpret_expr (buffer, buffer_size, result, false); + + return result; +} + + +gfc_expr * +gfc_simplify_transpose (gfc_expr *matrix) +{ + int row, matrix_rows, col, matrix_cols; + gfc_expr *result; + + if (!is_constant_array_expr (matrix)) + return NULL; + + gcc_assert (matrix->rank == 2); + + if (matrix->shape == NULL) + return NULL; + + result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind, + &matrix->where); + result->rank = 2; + result->shape = gfc_get_shape (result->rank); + mpz_init_set (result->shape[0], matrix->shape[1]); + mpz_init_set (result->shape[1], matrix->shape[0]); + + if (matrix->ts.type == BT_CHARACTER) + result->ts.u.cl = matrix->ts.u.cl; + else if (matrix->ts.type == BT_DERIVED) + result->ts.u.derived = matrix->ts.u.derived; + + matrix_rows = mpz_get_si (matrix->shape[0]); + matrix_cols = mpz_get_si (matrix->shape[1]); + for (row = 0; row < matrix_rows; ++row) + for (col = 0; col < matrix_cols; ++col) + { + gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor, + col * matrix_rows + row); + gfc_constructor_insert_expr (&result->value.constructor, + gfc_copy_expr (e), &matrix->where, + row * matrix_cols + col); + } + + return result; +} + + +gfc_expr * +gfc_simplify_trim (gfc_expr *e) +{ + gfc_expr *result; + int count, i, len, lentrim; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + for (count = 0, i = 1; i <= len; ++i) + { + if (e->value.character.string[len - i] == ' ') + count++; + else + break; + } + + lentrim = len - count; + + result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim); + for (i = 0; i < lentrim; i++) + result->value.character.string[i] = e->value.character.string[i]; + + return result; +} + + +gfc_expr * +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + gfc_expr *result; + gfc_ref *ref; + gfc_array_spec *as; + gfc_constructor *sub_cons; + bool first_image; + int d; + + if (!is_constant_array_expr (sub)) + return NULL; + + /* Follow any component references. */ + as = coarray->symtree->n.sym->as; + for (ref = coarray->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + as = ref->u.ar.as; + + if (as->type == AS_DEFERRED) + return NULL; + + /* "valid sequence of cosubscripts" are required; thus, return 0 unless + the cosubscript addresses the first image. */ + + sub_cons = gfc_constructor_first (sub->value.constructor); + first_image = true; + + for (d = 1; d <= as->corank; d++) + { + gfc_expr *ca_bound; + int cmp; + + gcc_assert (sub_cons != NULL); + + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, + NULL, true); + if (ca_bound == NULL) + return NULL; + + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer); + + if (cmp == 0) + { + gfc_free_expr (ca_bound); + sub_cons = gfc_constructor_next (sub_cons); + continue; + } + + first_image = false; + + if (cmp > 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY lower bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + gfc_free_expr (ca_bound); + + /* Check whether upperbound is valid for the multi-images case. */ + if (d < as->corank) + { + ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as, + NULL, true); + if (ca_bound == &gfc_bad_expr) + return ca_bound; + + if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT + && mpz_cmp (ca_bound->value.integer, + sub_cons->expr->value.integer) < 0) + { + gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, " + "SUB has %ld and COARRAY upper bound is %ld)", + &coarray->where, d, + mpz_get_si (sub_cons->expr->value.integer), + mpz_get_si (ca_bound->value.integer)); + gfc_free_expr (ca_bound); + return &gfc_bad_expr; + } + + if (ca_bound) + gfc_free_expr (ca_bound); + } + + sub_cons = gfc_constructor_next (sub_cons); + } + + gcc_assert (sub_cons == NULL); + + if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image) + return NULL; + + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + if (first_image) + mpz_set_si (result->value.integer, 1); + else + mpz_set_si (result->value.integer, 0); + + return result; +} + +gfc_expr * +gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) +{ + if (flag_coarray == GFC_FCOARRAY_NONE) + { + gfc_current_locus = *gfc_current_intrinsic_where; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); + return &gfc_bad_expr; + } + + /* Simplification is possible for fcoarray = single only. For all other modes + the result depends on runtime conditions. */ + if (flag_coarray != GFC_FCOARRAY_SINGLE) + return NULL; + + if (gfc_is_constant_expr (image)) + { + gfc_expr *result; + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &image->where); + if (mpz_get_si (image->value.integer) == 1) + mpz_set_si (result->value.integer, 0); + else + mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE); + return result; + } + else + return NULL; +} + + +gfc_expr * +gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, + gfc_expr *distance ATTRIBUTE_UNUSED) +{ + if (flag_coarray != GFC_FCOARRAY_SINGLE) + return NULL; + + /* If no coarray argument has been passed or when the first argument + is actually a distance argment. */ + if (coarray == NULL || !gfc_is_coarray (coarray)) + { + gfc_expr *result; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_set_si (result->value.integer, 1); + return result; + } + + /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */ + return simplify_cobound (coarray, dim, NULL, 0); +} + + +gfc_expr * +gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_bound (array, dim, kind, 1); +} + +gfc_expr * +gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + return simplify_cobound (array, dim, kind, 1); +} + + +gfc_expr * +gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) +{ + gfc_expr *result, *e; + gfc_constructor *vector_ctor, *mask_ctor, *field_ctor; + + if (!is_constant_array_expr (vector) + || !is_constant_array_expr (mask) + || (!gfc_is_constant_expr (field) + && !is_constant_array_expr (field))) + return NULL; + + result = gfc_get_array_expr (vector->ts.type, vector->ts.kind, + &vector->where); + if (vector->ts.type == BT_DERIVED) + result->ts.u.derived = vector->ts.u.derived; + result->rank = mask->rank; + result->shape = gfc_copy_shape (mask->shape, mask->rank); + + if (vector->ts.type == BT_CHARACTER) + result->ts.u.cl = vector->ts.u.cl; + + vector_ctor = gfc_constructor_first (vector->value.constructor); + mask_ctor = gfc_constructor_first (mask->value.constructor); + field_ctor + = field->expr_type == EXPR_ARRAY + ? gfc_constructor_first (field->value.constructor) + : NULL; + + while (mask_ctor) + { + if (mask_ctor->expr->value.logical) + { + gcc_assert (vector_ctor); + e = gfc_copy_expr (vector_ctor->expr); + vector_ctor = gfc_constructor_next (vector_ctor); + } + else if (field->expr_type == EXPR_ARRAY) + e = gfc_copy_expr (field_ctor->expr); + else + e = gfc_copy_expr (field); + + gfc_constructor_append_expr (&result->value.constructor, e, NULL); + + mask_ctor = gfc_constructor_next (mask_ctor); + field_ctor = gfc_constructor_next (field_ctor); + } + + return result; +} + + +gfc_expr * +gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind) +{ + gfc_expr *result; + int back; + size_t index, len, lenset; + size_t i; + int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind); + + if (k == -1) + return &gfc_bad_expr; + + if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT + || ( b != NULL && b->expr_type != EXPR_CONSTANT)) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + result = gfc_get_constant_expr (BT_INTEGER, k, &s->where); + + len = s->value.character.length; + lenset = set->value.character.length; + + if (len == 0) + { + mpz_set_ui (result->value.integer, 0); + return result; + } + + if (back == 0) + { + if (lenset == 0) + { + mpz_set_ui (result->value.integer, 1); + return result; + } + + index = wide_strspn (s->value.character.string, + set->value.character.string) + 1; + if (index > len) + index = 0; + + } + else + { + if (lenset == 0) + { + mpz_set_ui (result->value.integer, len); + return result; + } + for (index = len; index > 0; index --) + { + for (i = 0; i < lenset; i++) + { + if (s->value.character.string[index - 1] + == set->value.character.string[i]) + break; + } + if (i == lenset) + break; + } + } + + mpz_set_ui (result->value.integer, index); + return result; +} + + +gfc_expr * +gfc_simplify_xor (gfc_expr *x, gfc_expr *y) +{ + gfc_expr *result; + int kind; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + + switch (x->ts.type) + { + case BT_INTEGER: + result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); + mpz_xor (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "XOR"); + + case BT_LOGICAL: + return gfc_get_logical_expr (kind, &x->where, + (x->value.logical && !y->value.logical) + || (!x->value.logical && y->value.logical)); + + default: + gcc_unreachable (); + } +} + + +/****************** Constant simplification *****************/ + +/* Master function to convert one constant to another. While this is + used as a simplification function, it requires the destination type + and kind information which is supplied by a special case in + do_simplify(). */ + +gfc_expr * +gfc_convert_constant (gfc_expr *e, bt type, int kind) +{ + gfc_expr *result, *(*f) (gfc_expr *, int); + gfc_constructor *c, *t; + + switch (e->ts.type) + { + case BT_INTEGER: + switch (type) + { + case BT_INTEGER: + f = gfc_int2int; + break; + case BT_REAL: + f = gfc_int2real; + break; + case BT_COMPLEX: + f = gfc_int2complex; + break; + case BT_LOGICAL: + f = gfc_int2log; + break; + default: + goto oops; + } + break; + + case BT_REAL: + switch (type) + { + case BT_INTEGER: + f = gfc_real2int; + break; + case BT_REAL: + f = gfc_real2real; + break; + case BT_COMPLEX: + f = gfc_real2complex; + break; + default: + goto oops; + } + break; + + case BT_COMPLEX: + switch (type) + { + case BT_INTEGER: + f = gfc_complex2int; + break; + case BT_REAL: + f = gfc_complex2real; + break; + case BT_COMPLEX: + f = gfc_complex2complex; + break; + + default: + goto oops; + } + break; + + case BT_LOGICAL: + switch (type) + { + case BT_INTEGER: + f = gfc_log2int; + break; + case BT_LOGICAL: + f = gfc_log2log; + break; + default: + goto oops; + } + break; + + case BT_HOLLERITH: + switch (type) + { + case BT_INTEGER: + f = gfc_hollerith2int; + break; + + case BT_REAL: + f = gfc_hollerith2real; + break; + + case BT_COMPLEX: + f = gfc_hollerith2complex; + break; + + case BT_CHARACTER: + f = gfc_hollerith2character; + break; + + case BT_LOGICAL: + f = gfc_hollerith2logical; + break; + + default: + goto oops; + } + break; + + case BT_CHARACTER: + switch (type) + { + case BT_INTEGER: + f = gfc_character2int; + break; + + case BT_REAL: + f = gfc_character2real; + break; + + case BT_COMPLEX: + f = gfc_character2complex; + break; + + case BT_CHARACTER: + f = gfc_character2character; + break; + + case BT_LOGICAL: + f = gfc_character2logical; + break; + + default: + goto oops; + } + break; + + default: + oops: + return &gfc_bad_expr; + } + + result = NULL; + + switch (e->expr_type) + { + case EXPR_CONSTANT: + result = f (e, kind); + if (result == NULL) + return &gfc_bad_expr; + break; + + case EXPR_ARRAY: + if (!gfc_is_constant_expr (e)) + break; + + result = gfc_get_array_expr (type, kind, &e->where); + result->shape = gfc_copy_shape (e->shape, e->rank); + result->rank = e->rank; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + gfc_expr *tmp; + if (c->iterator == NULL) + { + if (c->expr->expr_type == EXPR_ARRAY) + tmp = gfc_convert_constant (c->expr, type, kind); + else if (c->expr->expr_type == EXPR_OP) + { + if (!gfc_simplify_expr (c->expr, 1)) + return &gfc_bad_expr; + tmp = f (c->expr, kind); + } + else + tmp = f (c->expr, kind); + } + else + tmp = gfc_convert_constant (c->expr, type, kind); + + if (tmp == NULL || tmp == &gfc_bad_expr) + { + gfc_free_expr (result); + return NULL; + } + + t = gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); + if (c->iterator) + t->iterator = gfc_copy_iterator (c->iterator); + } + + break; + + default: + break; + } + + return result; +} + + +/* Function for converting character constants. */ +gfc_expr * +gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind) +{ + gfc_expr *result; + int i; + + if (!gfc_is_constant_expr (e)) + return NULL; + + if (e->expr_type == EXPR_CONSTANT) + { + /* Simple case of a scalar. */ + result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where); + if (result == NULL) + return &gfc_bad_expr; + + result->value.character.length = e->value.character.length; + result->value.character.string + = gfc_get_wide_string (e->value.character.length + 1); + memcpy (result->value.character.string, e->value.character.string, + (e->value.character.length + 1) * sizeof (gfc_char_t)); + + /* Check we only have values representable in the destination kind. */ + for (i = 0; i < result->value.character.length; i++) + if (!gfc_check_character_range (result->value.character.string[i], + kind)) + { + gfc_error ("Character %qs in string at %L cannot be converted " + "into character kind %d", + gfc_print_wide_char (result->value.character.string[i]), + &e->where, kind); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + return result; + } + else if (e->expr_type == EXPR_ARRAY) + { + /* For an array constructor, we convert each constructor element. */ + gfc_constructor *c; + + result = gfc_get_array_expr (type, kind, &e->where); + result->shape = gfc_copy_shape (e->shape, e->rank); + result->rank = e->rank; + result->ts.u.cl = e->ts.u.cl; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind); + if (tmp == &gfc_bad_expr) + { + gfc_free_expr (result); + return &gfc_bad_expr; + } + + if (tmp == NULL) + { + gfc_free_expr (result); + return NULL; + } + + gfc_constructor_append_expr (&result->value.constructor, + tmp, &c->where); + } + + return result; + } + else + return NULL; +} + + +gfc_expr * +gfc_simplify_compiler_options (void) +{ + char *str; + gfc_expr *result; + + str = gfc_get_option_string (); + result = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, str, strlen (str)); + free (str); + return result; +} + + +gfc_expr * +gfc_simplify_compiler_version (void) +{ + char *buffer; + size_t len; + + len = strlen ("GCC version ") + strlen (version_string); + buffer = XALLOCAVEC (char, len + 1); + snprintf (buffer, len + 1, "GCC version %s", version_string); + return gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, buffer, len); +} + +/* Simplification routines for intrinsics of IEEE modules. */ + +gfc_expr * +simplify_ieee_selected_real_kind (gfc_expr *expr) +{ + gfc_actual_arglist *arg; + gfc_expr *p = NULL, *q = NULL, *rdx = NULL; + + arg = expr->value.function.actual; + p = arg->expr; + if (arg->next) + { + q = arg->next->expr; + if (arg->next->next) + rdx = arg->next->next->expr; + } + + /* Currently, if IEEE is supported and this module is built, it means + all our floating-point types conform to IEEE. Hence, we simply handle + IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */ + return gfc_simplify_selected_real_kind (p, q, rdx); +} + +gfc_expr * +simplify_ieee_support (gfc_expr *expr) +{ + /* We consider that if the IEEE modules are loaded, we have full support + for flags, halting and rounding, which are the three functions + (IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant + expressions. One day, we will need libgfortran to detect support and + communicate it back to us, allowing for partial support. */ + + return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where, + true); +} + +bool +matches_ieee_function_name (gfc_symbol *sym, const char *name) +{ + int n = strlen(name); + + if (!strncmp(sym->name, name, n)) + return true; + + /* If a generic was used and renamed, we need more work to find out. + Compare the specific name. */ + if (sym->generic && !strncmp(sym->generic->sym->name, name, n)) + return true; + + return false; +} + +gfc_expr * +gfc_simplify_ieee_functions (gfc_expr *expr) +{ + gfc_symbol* sym = expr->symtree->n.sym; + + if (matches_ieee_function_name(sym, "ieee_selected_real_kind")) + return simplify_ieee_selected_real_kind (expr); + else if (matches_ieee_function_name(sym, "ieee_support_flag") + || matches_ieee_function_name(sym, "ieee_support_halting") + || matches_ieee_function_name(sym, "ieee_support_rounding")) + return simplify_ieee_support (expr); + else + return NULL; +} diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c deleted file mode 100644 index 73f30c2..0000000 --- a/gcc/fortran/st.c +++ /dev/null @@ -1,334 +0,0 @@ -/* Build executable statement trees. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -/* Executable statements are strung together into a singly linked list - of code structures. These structures are later translated into GCC - GENERIC tree structures and from there to executable code for a - target. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "gfortran.h" - -gfc_code new_st; - - -/* Zeroes out the new_st structure. */ - -void -gfc_clear_new_st (void) -{ - memset (&new_st, '\0', sizeof (new_st)); - new_st.op = EXEC_NOP; -} - - -/* Get a gfc_code structure, initialized with the current locus - and a statement code 'op'. */ - -gfc_code * -gfc_get_code (gfc_exec_op op) -{ - gfc_code *c; - - c = XCNEW (gfc_code); - c->op = op; - c->loc = gfc_current_locus; - return c; -} - - -/* Given some part of a gfc_code structure, append a set of code to - its tail, returning a pointer to the new tail. */ - -gfc_code * -gfc_append_code (gfc_code *tail, gfc_code *new_code) -{ - if (tail != NULL) - { - while (tail->next != NULL) - tail = tail->next; - - tail->next = new_code; - } - - while (new_code->next != NULL) - new_code = new_code->next; - - return new_code; -} - - -/* Free a single code structure, but not the actual structure itself. */ - -void -gfc_free_statement (gfc_code *p) -{ - if (p->expr1) - gfc_free_expr (p->expr1); - if (p->expr2) - gfc_free_expr (p->expr2); - - switch (p->op) - { - case EXEC_NOP: - case EXEC_END_BLOCK: - case EXEC_END_NESTED_BLOCK: - case EXEC_ASSIGN: - case EXEC_INIT_ASSIGN: - case EXEC_GOTO: - case EXEC_CYCLE: - case EXEC_RETURN: - case EXEC_END_PROCEDURE: - case EXEC_IF: - case EXEC_PAUSE: - case EXEC_STOP: - case EXEC_ERROR_STOP: - case EXEC_EXIT: - case EXEC_WHERE: - case EXEC_IOLENGTH: - case EXEC_POINTER_ASSIGN: - case EXEC_DO_WHILE: - case EXEC_CONTINUE: - case EXEC_TRANSFER: - case EXEC_LABEL_ASSIGN: - case EXEC_ENTRY: - case EXEC_ARITHMETIC_IF: - case EXEC_CRITICAL: - case EXEC_SYNC_ALL: - case EXEC_SYNC_IMAGES: - case EXEC_SYNC_MEMORY: - case EXEC_LOCK: - case EXEC_UNLOCK: - case EXEC_EVENT_POST: - case EXEC_EVENT_WAIT: - case EXEC_FAIL_IMAGE: - case EXEC_CHANGE_TEAM: - case EXEC_END_TEAM: - case EXEC_FORM_TEAM: - case EXEC_SYNC_TEAM: - break; - - case EXEC_BLOCK: - gfc_free_namespace (p->ext.block.ns); - gfc_free_association_list (p->ext.block.assoc); - break; - - case EXEC_COMPCALL: - case EXEC_CALL_PPC: - case EXEC_CALL: - case EXEC_ASSIGN_CALL: - gfc_free_actual_arglist (p->ext.actual); - break; - - case EXEC_SELECT: - case EXEC_SELECT_TYPE: - case EXEC_SELECT_RANK: - if (p->ext.block.case_list) - gfc_free_case_list (p->ext.block.case_list); - break; - - case EXEC_DO: - gfc_free_iterator (p->ext.iterator, 1); - break; - - case EXEC_ALLOCATE: - case EXEC_DEALLOCATE: - gfc_free_alloc_list (p->ext.alloc.list); - break; - - case EXEC_OPEN: - gfc_free_open (p->ext.open); - break; - - case EXEC_CLOSE: - gfc_free_close (p->ext.close); - break; - - case EXEC_BACKSPACE: - case EXEC_ENDFILE: - case EXEC_REWIND: - case EXEC_FLUSH: - gfc_free_filepos (p->ext.filepos); - break; - - case EXEC_INQUIRE: - gfc_free_inquire (p->ext.inquire); - break; - - case EXEC_WAIT: - gfc_free_wait (p->ext.wait); - break; - - case EXEC_READ: - case EXEC_WRITE: - gfc_free_dt (p->ext.dt); - break; - - case EXEC_DT_END: - /* The ext.dt member is a duplicate pointer and doesn't need to - be freed. */ - break; - - case EXEC_DO_CONCURRENT: - case EXEC_FORALL: - gfc_free_forall_iterator (p->ext.forall_iterator); - break; - - case EXEC_OACC_DECLARE: - if (p->ext.oacc_declare) - gfc_free_oacc_declare_clauses (p->ext.oacc_declare); - break; - - case EXEC_OACC_ATOMIC: - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_LOOP: - case EXEC_OACC_UPDATE: - case EXEC_OACC_WAIT: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OACC_ROUTINE: - case EXEC_OMP_ATOMIC: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DEPOBJ: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_ERROR: - case EXEC_OMP_LOOP: - case EXEC_OMP_END_SINGLE: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_ORDERED: - case EXEC_OMP_MASKED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SCAN: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_WORKSHARE: - gfc_free_omp_clauses (p->ext.omp_clauses); - break; - - case EXEC_OMP_END_CRITICAL: - free (CONST_CAST (char *, p->ext.omp_name)); - break; - - case EXEC_OMP_FLUSH: - gfc_free_omp_namelist (p->ext.omp_namelist, false); - break; - - case EXEC_OMP_BARRIER: - case EXEC_OMP_MASTER: - case EXEC_OMP_END_NOWAIT: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - break; - - default: - gfc_internal_error ("gfc_free_statement(): Bad statement"); - } -} - - -/* Free a code statement and all other code structures linked to it. */ - -void -gfc_free_statements (gfc_code *p) -{ - gfc_code *q; - - for (; p; p = q) - { - q = p->next; - - if (p->block) - gfc_free_statements (p->block); - gfc_free_statement (p); - free (p); - } -} - - -/* Free an association list (of an ASSOCIATE statement). */ - -void -gfc_free_association_list (gfc_association_list* assoc) -{ - if (!assoc) - return; - - gfc_free_association_list (assoc->next); - free (assoc); -} diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc new file mode 100644 index 0000000..73f30c2 --- /dev/null +++ b/gcc/fortran/st.cc @@ -0,0 +1,334 @@ +/* Build executable statement trees. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +/* Executable statements are strung together into a singly linked list + of code structures. These structures are later translated into GCC + GENERIC tree structures and from there to executable code for a + target. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "gfortran.h" + +gfc_code new_st; + + +/* Zeroes out the new_st structure. */ + +void +gfc_clear_new_st (void) +{ + memset (&new_st, '\0', sizeof (new_st)); + new_st.op = EXEC_NOP; +} + + +/* Get a gfc_code structure, initialized with the current locus + and a statement code 'op'. */ + +gfc_code * +gfc_get_code (gfc_exec_op op) +{ + gfc_code *c; + + c = XCNEW (gfc_code); + c->op = op; + c->loc = gfc_current_locus; + return c; +} + + +/* Given some part of a gfc_code structure, append a set of code to + its tail, returning a pointer to the new tail. */ + +gfc_code * +gfc_append_code (gfc_code *tail, gfc_code *new_code) +{ + if (tail != NULL) + { + while (tail->next != NULL) + tail = tail->next; + + tail->next = new_code; + } + + while (new_code->next != NULL) + new_code = new_code->next; + + return new_code; +} + + +/* Free a single code structure, but not the actual structure itself. */ + +void +gfc_free_statement (gfc_code *p) +{ + if (p->expr1) + gfc_free_expr (p->expr1); + if (p->expr2) + gfc_free_expr (p->expr2); + + switch (p->op) + { + case EXEC_NOP: + case EXEC_END_BLOCK: + case EXEC_END_NESTED_BLOCK: + case EXEC_ASSIGN: + case EXEC_INIT_ASSIGN: + case EXEC_GOTO: + case EXEC_CYCLE: + case EXEC_RETURN: + case EXEC_END_PROCEDURE: + case EXEC_IF: + case EXEC_PAUSE: + case EXEC_STOP: + case EXEC_ERROR_STOP: + case EXEC_EXIT: + case EXEC_WHERE: + case EXEC_IOLENGTH: + case EXEC_POINTER_ASSIGN: + case EXEC_DO_WHILE: + case EXEC_CONTINUE: + case EXEC_TRANSFER: + case EXEC_LABEL_ASSIGN: + case EXEC_ENTRY: + case EXEC_ARITHMETIC_IF: + case EXEC_CRITICAL: + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: + case EXEC_LOCK: + case EXEC_UNLOCK: + case EXEC_EVENT_POST: + case EXEC_EVENT_WAIT: + case EXEC_FAIL_IMAGE: + case EXEC_CHANGE_TEAM: + case EXEC_END_TEAM: + case EXEC_FORM_TEAM: + case EXEC_SYNC_TEAM: + break; + + case EXEC_BLOCK: + gfc_free_namespace (p->ext.block.ns); + gfc_free_association_list (p->ext.block.assoc); + break; + + case EXEC_COMPCALL: + case EXEC_CALL_PPC: + case EXEC_CALL: + case EXEC_ASSIGN_CALL: + gfc_free_actual_arglist (p->ext.actual); + break; + + case EXEC_SELECT: + case EXEC_SELECT_TYPE: + case EXEC_SELECT_RANK: + if (p->ext.block.case_list) + gfc_free_case_list (p->ext.block.case_list); + break; + + case EXEC_DO: + gfc_free_iterator (p->ext.iterator, 1); + break; + + case EXEC_ALLOCATE: + case EXEC_DEALLOCATE: + gfc_free_alloc_list (p->ext.alloc.list); + break; + + case EXEC_OPEN: + gfc_free_open (p->ext.open); + break; + + case EXEC_CLOSE: + gfc_free_close (p->ext.close); + break; + + case EXEC_BACKSPACE: + case EXEC_ENDFILE: + case EXEC_REWIND: + case EXEC_FLUSH: + gfc_free_filepos (p->ext.filepos); + break; + + case EXEC_INQUIRE: + gfc_free_inquire (p->ext.inquire); + break; + + case EXEC_WAIT: + gfc_free_wait (p->ext.wait); + break; + + case EXEC_READ: + case EXEC_WRITE: + gfc_free_dt (p->ext.dt); + break; + + case EXEC_DT_END: + /* The ext.dt member is a duplicate pointer and doesn't need to + be freed. */ + break; + + case EXEC_DO_CONCURRENT: + case EXEC_FORALL: + gfc_free_forall_iterator (p->ext.forall_iterator); + break; + + case EXEC_OACC_DECLARE: + if (p->ext.oacc_declare) + gfc_free_oacc_declare_clauses (p->ext.oacc_declare); + break; + + case EXEC_OACC_ATOMIC: + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_LOOP: + case EXEC_OACC_UPDATE: + case EXEC_OACC_WAIT: + case EXEC_OACC_CACHE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ROUTINE: + case EXEC_OMP_ATOMIC: + case EXEC_OMP_CANCEL: + case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_ERROR: + case EXEC_OMP_LOOP: + case EXEC_OMP_END_SINGLE: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_ORDERED: + case EXEC_OMP_MASKED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SCAN: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SIMD: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_WORKSHARE: + gfc_free_omp_clauses (p->ext.omp_clauses); + break; + + case EXEC_OMP_END_CRITICAL: + free (CONST_CAST (char *, p->ext.omp_name)); + break; + + case EXEC_OMP_FLUSH: + gfc_free_omp_namelist (p->ext.omp_namelist, false); + break; + + case EXEC_OMP_BARRIER: + case EXEC_OMP_MASTER: + case EXEC_OMP_END_NOWAIT: + case EXEC_OMP_TASKGROUP: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + break; + + default: + gfc_internal_error ("gfc_free_statement(): Bad statement"); + } +} + + +/* Free a code statement and all other code structures linked to it. */ + +void +gfc_free_statements (gfc_code *p) +{ + gfc_code *q; + + for (; p; p = q) + { + q = p->next; + + if (p->block) + gfc_free_statements (p->block); + gfc_free_statement (p); + free (p); + } +} + + +/* Free an association list (of an ASSOCIATE statement). */ + +void +gfc_free_association_list (gfc_association_list* assoc) +{ + if (!assoc) + return; + + gfc_free_association_list (assoc->next); + free (assoc); +} diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c deleted file mode 100644 index 1a4b022..0000000 --- a/gcc/fortran/symbol.c +++ /dev/null @@ -1,5251 +0,0 @@ -/* Maintain binary trees of symbols. - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Andy Vaught - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "gfortran.h" -#include "parse.h" -#include "match.h" -#include "constructor.h" - - -/* Strings for all symbol attributes. We use these for dumping the - parse tree, in error messages, and also when reading and writing - modules. */ - -const mstring flavors[] = -{ - minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM), - minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE), - minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), - minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), - minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), - minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT), - minit (NULL, -1) -}; - -const mstring procedures[] = -{ - minit ("UNKNOWN-PROC", PROC_UNKNOWN), - minit ("MODULE-PROC", PROC_MODULE), - minit ("INTERNAL-PROC", PROC_INTERNAL), - minit ("DUMMY-PROC", PROC_DUMMY), - minit ("INTRINSIC-PROC", PROC_INTRINSIC), - minit ("EXTERNAL-PROC", PROC_EXTERNAL), - minit ("STATEMENT-PROC", PROC_ST_FUNCTION), - minit (NULL, -1) -}; - -const mstring intents[] = -{ - minit ("UNKNOWN-INTENT", INTENT_UNKNOWN), - minit ("IN", INTENT_IN), - minit ("OUT", INTENT_OUT), - minit ("INOUT", INTENT_INOUT), - minit (NULL, -1) -}; - -const mstring access_types[] = -{ - minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN), - minit ("PUBLIC", ACCESS_PUBLIC), - minit ("PRIVATE", ACCESS_PRIVATE), - minit (NULL, -1) -}; - -const mstring ifsrc_types[] = -{ - minit ("UNKNOWN", IFSRC_UNKNOWN), - minit ("DECL", IFSRC_DECL), - minit ("BODY", IFSRC_IFBODY) -}; - -const mstring save_status[] = -{ - minit ("UNKNOWN", SAVE_NONE), - minit ("EXPLICIT-SAVE", SAVE_EXPLICIT), - minit ("IMPLICIT-SAVE", SAVE_IMPLICIT), -}; - -/* Set the mstrings for DTIO procedure names. */ -const mstring dtio_procs[] = -{ - minit ("_dtio_formatted_read", DTIO_RF), - minit ("_dtio_formatted_write", DTIO_WF), - minit ("_dtio_unformatted_read", DTIO_RUF), - minit ("_dtio_unformatted_write", DTIO_WUF), -}; - -/* This is to make sure the backend generates setup code in the correct - order. */ - -static int next_dummy_order = 1; - - -gfc_namespace *gfc_current_ns; -gfc_namespace *gfc_global_ns_list; - -gfc_gsymbol *gfc_gsym_root = NULL; - -gfc_symbol *gfc_derived_types; - -static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL }; -static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var; - - -/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ - -/* The following static variable indicates whether a particular element has - been explicitly set or not. */ - -static int new_flag[GFC_LETTERS]; - - -/* Handle a correctly parsed IMPLICIT NONE. */ - -void -gfc_set_implicit_none (bool type, bool external, locus *loc) -{ - int i; - - if (external) - gfc_current_ns->has_implicit_none_export = 1; - - if (type) - { - gfc_current_ns->seen_implicit_none = 1; - for (i = 0; i < GFC_LETTERS; i++) - { - if (gfc_current_ns->set_flag[i]) - { - gfc_error_now ("IMPLICIT NONE (type) statement at %L following an " - "IMPLICIT statement", loc); - return; - } - gfc_clear_ts (&gfc_current_ns->default_type[i]); - gfc_current_ns->set_flag[i] = 1; - } - } -} - - -/* Reset the implicit range flags. */ - -void -gfc_clear_new_implicit (void) -{ - int i; - - for (i = 0; i < GFC_LETTERS; i++) - new_flag[i] = 0; -} - - -/* Prepare for a new implicit range. Sets flags in new_flag[]. */ - -bool -gfc_add_new_implicit_range (int c1, int c2) -{ - int i; - - c1 -= 'a'; - c2 -= 'a'; - - for (i = c1; i <= c2; i++) - { - if (new_flag[i]) - { - gfc_error ("Letter %qc already set in IMPLICIT statement at %C", - i + 'A'); - return false; - } - - new_flag[i] = 1; - } - - return true; -} - - -/* Add a matched implicit range for gfc_set_implicit(). Check if merging - the new implicit types back into the existing types will work. */ - -bool -gfc_merge_new_implicit (gfc_typespec *ts) -{ - int i; - - if (gfc_current_ns->seen_implicit_none) - { - gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE"); - return false; - } - - for (i = 0; i < GFC_LETTERS; i++) - { - if (new_flag[i]) - { - if (gfc_current_ns->set_flag[i]) - { - gfc_error ("Letter %qc already has an IMPLICIT type at %C", - i + 'A'); - return false; - } - - gfc_current_ns->default_type[i] = *ts; - gfc_current_ns->implicit_loc[i] = gfc_current_locus; - gfc_current_ns->set_flag[i] = 1; - } - } - return true; -} - - -/* Given a symbol, return a pointer to the typespec for its default type. */ - -gfc_typespec * -gfc_get_default_type (const char *name, gfc_namespace *ns) -{ - char letter; - - letter = name[0]; - - if (flag_allow_leading_underscore && letter == '_') - gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by " - "gfortran developers, and should not be used for " - "implicitly typed variables"); - - if (letter < 'a' || letter > 'z') - gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name); - - if (ns == NULL) - ns = gfc_current_ns; - - return &ns->default_type[letter - 'a']; -} - - -/* Recursively append candidate SYM to CANDIDATES. Store the number of - candidates in CANDIDATES_LEN. */ - -static void -lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym, - char **&candidates, - size_t &candidates_len) -{ - gfc_symtree *p; - - if (sym == NULL) - return; - - if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE) - vec_push (candidates, candidates_len, sym->name); - p = sym->left; - if (p) - lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); - - p = sym->right; - if (p) - lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); -} - - -/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */ - -static const char* -lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol) -{ - char **candidates = NULL; - size_t candidates_len = 0; - lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates, - candidates_len); - return gfc_closest_fuzzy_match (sym_name, candidates); -} - - -/* Given a pointer to a symbol, set its type according to the first - letter of its name. Fails if the letter in question has no default - type. */ - -bool -gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) -{ - gfc_typespec *ts; - - if (sym->ts.type != BT_UNKNOWN) - gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); - - ts = gfc_get_default_type (sym->name, ns); - - if (ts->type == BT_UNKNOWN) - { - if (error_flag && !sym->attr.untyped && !gfc_query_suppress_errors ()) - { - const char *guessed = lookup_symbol_fuzzy (sym->name, sym); - if (guessed) - gfc_error ("Symbol %qs at %L has no IMPLICIT type" - "; did you mean %qs?", - sym->name, &sym->declared_at, guessed); - else - gfc_error ("Symbol %qs at %L has no IMPLICIT type", - sym->name, &sym->declared_at); - sym->attr.untyped = 1; /* Ensure we only give an error once. */ - } - - return false; - } - - sym->ts = *ts; - sym->attr.implicit_type = 1; - - if (ts->type == BT_CHARACTER && ts->u.cl) - sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl); - else if (ts->type == BT_CLASS - && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) - return false; - - if (sym->attr.is_bind_c == 1 && warn_c_binding_type) - { - /* BIND(C) variables should not be implicitly declared. */ - gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) " - "variable %qs at %L may not be C interoperable", - sym->name, &sym->declared_at); - sym->ts.f90_type = sym->ts.type; - } - - if (sym->attr.dummy != 0) - { - if (sym->ns->proc_name != NULL - && (sym->ns->proc_name->attr.subroutine != 0 - || sym->ns->proc_name->attr.function != 0) - && sym->ns->proc_name->attr.is_bind_c != 0 - && warn_c_binding_type) - { - /* Dummy args to a BIND(C) routine may not be interoperable if - they are implicitly typed. */ - gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable " - "%qs at %L may not be C interoperable but it is a " - "dummy argument to the BIND(C) procedure %qs at %L", - sym->name, &(sym->declared_at), - sym->ns->proc_name->name, - &(sym->ns->proc_name->declared_at)); - sym->ts.f90_type = sym->ts.type; - } - } - - return true; -} - - -/* This function is called from parse.c(parse_progunit) to check the - type of the function is not implicitly typed in the host namespace - and to implicitly type the function result, if necessary. */ - -void -gfc_check_function_type (gfc_namespace *ns) -{ - gfc_symbol *proc = ns->proc_name; - - if (!proc->attr.contained || proc->result->attr.implicit_type) - return; - - if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL) - { - if (gfc_set_default_type (proc->result, 0, gfc_current_ns)) - { - if (proc->result != proc) - { - proc->ts = proc->result->ts; - proc->as = gfc_copy_array_spec (proc->result->as); - proc->attr.dimension = proc->result->attr.dimension; - proc->attr.pointer = proc->result->attr.pointer; - proc->attr.allocatable = proc->result->attr.allocatable; - } - } - else if (!proc->result->attr.proc_pointer) - { - gfc_error ("Function result %qs at %L has no IMPLICIT type", - proc->result->name, &proc->result->declared_at); - proc->result->attr.untyped = 1; - } - } -} - - -/******************** Symbol attribute stuff *********************/ - -/* This is a generic conflict-checker. We do this to avoid having a - single conflict in two places. */ - -#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; } -#define conf2(a) if (attr->a) { a2 = a; goto conflict; } -#define conf_std(a, b, std) if (attr->a && attr->b)\ - {\ - a1 = a;\ - a2 = b;\ - standard = std;\ - goto conflict_std;\ - } - -bool -gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) -{ - static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", - *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", - *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC", - *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)", - *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL", - *privat = "PRIVATE", *recursive = "RECURSIVE", - *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", - *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", - *function = "FUNCTION", *subroutine = "SUBROUTINE", - *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", - *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", - *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", - *volatile_ = "VOLATILE", *is_protected = "PROTECTED", - *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT", - *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", - *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", - *pdt_len = "LEN", *pdt_kind = "KIND"; - static const char *threadprivate = "THREADPRIVATE"; - static const char *omp_declare_target = "OMP DECLARE TARGET"; - static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; - static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; - static const char *oacc_declare_create = "OACC DECLARE CREATE"; - static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; - static const char *oacc_declare_device_resident = - "OACC DECLARE DEVICE_RESIDENT"; - - const char *a1, *a2; - int standard; - - if (attr->artificial) - return true; - - if (where == NULL) - where = &gfc_current_locus; - - if (attr->pointer && attr->intent != INTENT_UNKNOWN) - { - a1 = pointer; - a2 = intent; - standard = GFC_STD_F2003; - goto conflict_std; - } - - if (attr->in_namelist && (attr->allocatable || attr->pointer)) - { - a1 = in_namelist; - a2 = attr->allocatable ? allocatable : pointer; - standard = GFC_STD_F2003; - goto conflict_std; - } - - /* Check for attributes not allowed in a BLOCK DATA. */ - if (gfc_current_state () == COMP_BLOCK_DATA) - { - a1 = NULL; - - if (attr->in_namelist) - a1 = in_namelist; - if (attr->allocatable) - a1 = allocatable; - if (attr->external) - a1 = external; - if (attr->optional) - a1 = optional; - if (attr->access == ACCESS_PRIVATE) - a1 = privat; - if (attr->access == ACCESS_PUBLIC) - a1 = publik; - if (attr->intent != INTENT_UNKNOWN) - a1 = intent; - - if (a1 != NULL) - { - gfc_error - ("%s attribute not allowed in BLOCK DATA program unit at %L", - a1, where); - return false; - } - } - - if (attr->save == SAVE_EXPLICIT) - { - conf (dummy, save); - conf (in_common, save); - conf (result, save); - conf (automatic, save); - - switch (attr->flavor) - { - case FL_PROGRAM: - case FL_BLOCK_DATA: - case FL_MODULE: - case FL_LABEL: - case_fl_struct: - case FL_PARAMETER: - a1 = gfc_code2string (flavors, attr->flavor); - a2 = save; - goto conflict; - case FL_NAMELIST: - gfc_error ("Namelist group name at %L cannot have the " - "SAVE attribute", where); - return false; - case FL_PROCEDURE: - /* Conflicts between SAVE and PROCEDURE will be checked at - resolution stage, see "resolve_fl_procedure". */ - case FL_VARIABLE: - default: - break; - } - } - - /* The copying of procedure dummy arguments for module procedures in - a submodule occur whilst the current state is COMP_CONTAINS. It - is necessary, therefore, to let this through. */ - if (name && attr->dummy - && (attr->function || attr->subroutine) - && gfc_current_state () == COMP_CONTAINS - && !(gfc_new_block && gfc_new_block->abr_modproc_decl)) - gfc_error_now ("internal procedure %qs at %L conflicts with " - "DUMMY argument", name, where); - - conf (dummy, entry); - conf (dummy, intrinsic); - conf (dummy, threadprivate); - conf (dummy, omp_declare_target); - conf (dummy, omp_declare_target_link); - conf (pointer, target); - conf (pointer, intrinsic); - conf (pointer, elemental); - conf (pointer, codimension); - conf (allocatable, elemental); - - conf (in_common, automatic); - conf (result, automatic); - conf (use_assoc, automatic); - conf (dummy, automatic); - - conf (target, external); - conf (target, intrinsic); - - if (!attr->if_source) - conf (external, dimension); /* See Fortran 95's R504. */ - - conf (external, intrinsic); - conf (entry, intrinsic); - conf (abstract, intrinsic); - - if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) - conf (external, subroutine); - - if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003, - "Procedure pointer at %C")) - return false; - - conf (allocatable, pointer); - conf_std (allocatable, dummy, GFC_STD_F2003); - conf_std (allocatable, function, GFC_STD_F2003); - conf_std (allocatable, result, GFC_STD_F2003); - conf_std (elemental, recursive, GFC_STD_F2018); - - conf (in_common, dummy); - conf (in_common, allocatable); - conf (in_common, codimension); - conf (in_common, result); - - conf (in_equivalence, use_assoc); - conf (in_equivalence, codimension); - conf (in_equivalence, dummy); - conf (in_equivalence, target); - conf (in_equivalence, pointer); - conf (in_equivalence, function); - conf (in_equivalence, result); - conf (in_equivalence, entry); - conf (in_equivalence, allocatable); - conf (in_equivalence, threadprivate); - conf (in_equivalence, omp_declare_target); - conf (in_equivalence, omp_declare_target_link); - conf (in_equivalence, oacc_declare_create); - conf (in_equivalence, oacc_declare_copyin); - conf (in_equivalence, oacc_declare_deviceptr); - conf (in_equivalence, oacc_declare_device_resident); - conf (in_equivalence, is_bind_c); - - conf (dummy, result); - conf (entry, result); - conf (generic, result); - conf (generic, omp_declare_target); - conf (generic, omp_declare_target_link); - - conf (function, subroutine); - - if (!function && !subroutine) - conf (is_bind_c, dummy); - - conf (is_bind_c, cray_pointer); - conf (is_bind_c, cray_pointee); - conf (is_bind_c, codimension); - conf (is_bind_c, allocatable); - conf (is_bind_c, elemental); - - /* Need to also get volatile attr, according to 5.1 of F2003 draft. - Parameter conflict caught below. Also, value cannot be specified - for a dummy procedure. */ - - /* Cray pointer/pointee conflicts. */ - conf (cray_pointer, cray_pointee); - conf (cray_pointer, dimension); - conf (cray_pointer, codimension); - conf (cray_pointer, contiguous); - conf (cray_pointer, pointer); - conf (cray_pointer, target); - conf (cray_pointer, allocatable); - conf (cray_pointer, external); - conf (cray_pointer, intrinsic); - conf (cray_pointer, in_namelist); - conf (cray_pointer, function); - conf (cray_pointer, subroutine); - conf (cray_pointer, entry); - - conf (cray_pointee, allocatable); - conf (cray_pointee, contiguous); - conf (cray_pointee, codimension); - conf (cray_pointee, intent); - conf (cray_pointee, optional); - conf (cray_pointee, dummy); - conf (cray_pointee, target); - conf (cray_pointee, intrinsic); - conf (cray_pointee, pointer); - conf (cray_pointee, entry); - conf (cray_pointee, in_common); - conf (cray_pointee, in_equivalence); - conf (cray_pointee, threadprivate); - conf (cray_pointee, omp_declare_target); - conf (cray_pointee, omp_declare_target_link); - conf (cray_pointee, oacc_declare_create); - conf (cray_pointee, oacc_declare_copyin); - conf (cray_pointee, oacc_declare_deviceptr); - conf (cray_pointee, oacc_declare_device_resident); - - conf (data, dummy); - conf (data, function); - conf (data, result); - conf (data, allocatable); - - conf (value, pointer) - conf (value, allocatable) - conf (value, subroutine) - conf (value, function) - conf (value, volatile_) - conf (value, dimension) - conf (value, codimension) - conf (value, external) - - conf (codimension, result) - - if (attr->value - && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) - { - a1 = value; - a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout; - goto conflict; - } - - conf (is_protected, intrinsic) - conf (is_protected, in_common) - - conf (asynchronous, intrinsic) - conf (asynchronous, external) - - conf (volatile_, intrinsic) - conf (volatile_, external) - - if (attr->volatile_ && attr->intent == INTENT_IN) - { - a1 = volatile_; - a2 = intent_in; - goto conflict; - } - - conf (procedure, allocatable) - conf (procedure, dimension) - conf (procedure, codimension) - conf (procedure, intrinsic) - conf (procedure, target) - conf (procedure, value) - conf (procedure, volatile_) - conf (procedure, asynchronous) - conf (procedure, entry) - - conf (proc_pointer, abstract) - conf (proc_pointer, omp_declare_target) - conf (proc_pointer, omp_declare_target_link) - - conf (entry, omp_declare_target) - conf (entry, omp_declare_target_link) - conf (entry, oacc_declare_create) - conf (entry, oacc_declare_copyin) - conf (entry, oacc_declare_deviceptr) - conf (entry, oacc_declare_device_resident) - - conf (pdt_kind, allocatable) - conf (pdt_kind, pointer) - conf (pdt_kind, dimension) - conf (pdt_kind, codimension) - - conf (pdt_len, allocatable) - conf (pdt_len, pointer) - conf (pdt_len, dimension) - conf (pdt_len, codimension) - conf (pdt_len, pdt_kind) - - if (attr->access == ACCESS_PRIVATE) - { - a1 = privat; - conf2 (pdt_kind); - conf2 (pdt_len); - } - - a1 = gfc_code2string (flavors, attr->flavor); - - if (attr->in_namelist - && attr->flavor != FL_VARIABLE - && attr->flavor != FL_PROCEDURE - && attr->flavor != FL_UNKNOWN) - { - a2 = in_namelist; - goto conflict; - } - - switch (attr->flavor) - { - case FL_PROGRAM: - case FL_BLOCK_DATA: - case FL_MODULE: - case FL_LABEL: - conf2 (codimension); - conf2 (dimension); - conf2 (dummy); - conf2 (volatile_); - conf2 (asynchronous); - conf2 (contiguous); - conf2 (pointer); - conf2 (is_protected); - conf2 (target); - conf2 (external); - conf2 (intrinsic); - conf2 (allocatable); - conf2 (result); - conf2 (in_namelist); - conf2 (optional); - conf2 (function); - conf2 (subroutine); - conf2 (threadprivate); - conf2 (omp_declare_target); - conf2 (omp_declare_target_link); - conf2 (oacc_declare_create); - conf2 (oacc_declare_copyin); - conf2 (oacc_declare_deviceptr); - conf2 (oacc_declare_device_resident); - - if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE) - { - a2 = attr->access == ACCESS_PUBLIC ? publik : privat; - gfc_error ("%s attribute applied to %s %s at %L", a2, a1, - name, where); - return false; - } - - if (attr->is_bind_c) - { - gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where); - return false; - } - - break; - - case FL_VARIABLE: - break; - - case FL_NAMELIST: - conf2 (result); - break; - - case FL_PROCEDURE: - /* Conflicts with INTENT, SAVE and RESULT will be checked - at resolution stage, see "resolve_fl_procedure". */ - - if (attr->subroutine) - { - a1 = subroutine; - conf2 (target); - conf2 (allocatable); - conf2 (volatile_); - conf2 (asynchronous); - conf2 (in_namelist); - conf2 (codimension); - conf2 (dimension); - conf2 (function); - if (!attr->proc_pointer) - conf2 (threadprivate); - } - - /* Procedure pointers in COMMON blocks are allowed in F03, - * but forbidden per F08:C5100. */ - if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) - conf2 (in_common); - - conf2 (omp_declare_target_link); - - switch (attr->proc) - { - case PROC_ST_FUNCTION: - conf2 (dummy); - conf2 (target); - break; - - case PROC_MODULE: - conf2 (dummy); - break; - - case PROC_DUMMY: - conf2 (result); - conf2 (threadprivate); - break; - - default: - break; - } - - break; - - case_fl_struct: - conf2 (dummy); - conf2 (pointer); - conf2 (target); - conf2 (external); - conf2 (intrinsic); - conf2 (allocatable); - conf2 (optional); - conf2 (entry); - conf2 (function); - conf2 (subroutine); - conf2 (threadprivate); - conf2 (result); - conf2 (omp_declare_target); - conf2 (omp_declare_target_link); - conf2 (oacc_declare_create); - conf2 (oacc_declare_copyin); - conf2 (oacc_declare_deviceptr); - conf2 (oacc_declare_device_resident); - - if (attr->intent != INTENT_UNKNOWN) - { - a2 = intent; - goto conflict; - } - break; - - case FL_PARAMETER: - conf2 (external); - conf2 (intrinsic); - conf2 (optional); - conf2 (allocatable); - conf2 (function); - conf2 (subroutine); - conf2 (entry); - conf2 (contiguous); - conf2 (pointer); - conf2 (is_protected); - conf2 (target); - conf2 (dummy); - conf2 (in_common); - conf2 (value); - conf2 (volatile_); - conf2 (asynchronous); - conf2 (threadprivate); - conf2 (value); - conf2 (codimension); - conf2 (result); - if (!attr->is_iso_c) - conf2 (is_bind_c); - break; - - default: - break; - } - - return true; - -conflict: - if (name == NULL) - gfc_error ("%s attribute conflicts with %s attribute at %L", - a1, a2, where); - else - gfc_error ("%s attribute conflicts with %s attribute in %qs at %L", - a1, a2, name, where); - - return false; - -conflict_std: - if (name == NULL) - { - return gfc_notify_std (standard, "%s attribute conflicts " - "with %s attribute at %L", a1, a2, - where); - } - else - { - return gfc_notify_std (standard, "%s attribute conflicts " - "with %s attribute in %qs at %L", - a1, a2, name, where); - } -} - -#undef conf -#undef conf2 -#undef conf_std - - -/* Mark a symbol as referenced. */ - -void -gfc_set_sym_referenced (gfc_symbol *sym) -{ - - if (sym->attr.referenced) - return; - - sym->attr.referenced = 1; - - /* Remember which order dummy variables are accessed in. */ - if (sym->attr.dummy) - sym->dummy_order = next_dummy_order++; -} - - -/* Common subroutine called by attribute changing subroutines in order - to prevent them from changing a symbol that has been - use-associated. Returns zero if it is OK to change the symbol, - nonzero if not. */ - -static int -check_used (symbol_attribute *attr, const char *name, locus *where) -{ - - if (attr->use_assoc == 0) - return 0; - - if (where == NULL) - where = &gfc_current_locus; - - if (name == NULL) - gfc_error ("Cannot change attributes of USE-associated symbol at %L", - where); - else - gfc_error ("Cannot change attributes of USE-associated symbol %s at %L", - name, where); - - return 1; -} - - -/* Generate an error because of a duplicate attribute. */ - -static void -duplicate_attr (const char *attr, locus *where) -{ - - if (where == NULL) - where = &gfc_current_locus; - - gfc_error ("Duplicate %s attribute specified at %L", attr, where); -} - - -bool -gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr, - locus *where ATTRIBUTE_UNUSED) -{ - attr->ext_attr |= 1 << ext_attr; - return true; -} - - -/* Called from decl.c (attr_decl1) to check attributes, when declared - separately. */ - -bool -gfc_add_attribute (symbol_attribute *attr, locus *where) -{ - if (check_used (attr, NULL, where)) - return false; - - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_allocatable (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->allocatable && ! gfc_submodule_procedure(attr)) - { - duplicate_attr ("ALLOCATABLE", where); - return false; - } - - if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY - && !gfc_find_state (COMP_INTERFACE)) - { - gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L", - where); - return false; - } - - attr->allocatable = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where) -{ - if (check_used (attr, name, where)) - return false; - - if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY, - "Duplicate AUTOMATIC attribute specified at %L", where)) - return false; - - attr->automatic = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->codimension) - { - duplicate_attr ("CODIMENSION", where); - return false; - } - - if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY - && !gfc_find_state (COMP_INTERFACE)) - { - gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body " - "at %L", name, where); - return false; - } - - attr->codimension = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->dimension && ! gfc_submodule_procedure(attr)) - { - duplicate_attr ("DIMENSION", where); - return false; - } - - if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY - && !gfc_find_state (COMP_INTERFACE)) - { - gfc_error ("DIMENSION specified for %qs outside its INTERFACE body " - "at %L", name, where); - return false; - } - - attr->dimension = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - attr->contiguous = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_external (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->external) - { - duplicate_attr ("EXTERNAL", where); - return false; - } - - if (attr->pointer && attr->if_source != IFSRC_IFBODY) - { - attr->pointer = 0; - attr->proc_pointer = 1; - } - - attr->external = 1; - - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_intrinsic (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->intrinsic) - { - duplicate_attr ("INTRINSIC", where); - return false; - } - - attr->intrinsic = 1; - - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_optional (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->optional) - { - duplicate_attr ("OPTIONAL", where); - return false; - } - - attr->optional = 1; - return gfc_check_conflict (attr, NULL, where); -} - -bool -gfc_add_kind (symbol_attribute *attr, locus *where) -{ - if (attr->pdt_kind) - { - duplicate_attr ("KIND", where); - return false; - } - - attr->pdt_kind = 1; - return gfc_check_conflict (attr, NULL, where); -} - -bool -gfc_add_len (symbol_attribute *attr, locus *where) -{ - if (attr->pdt_len) - { - duplicate_attr ("LEN", where); - return false; - } - - attr->pdt_len = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_pointer (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->pointer && !(attr->if_source == IFSRC_IFBODY - && !gfc_find_state (COMP_INTERFACE)) - && ! gfc_submodule_procedure(attr)) - { - duplicate_attr ("POINTER", where); - return false; - } - - if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY) - || (attr->if_source == IFSRC_IFBODY - && !gfc_find_state (COMP_INTERFACE))) - attr->proc_pointer = 1; - else - attr->pointer = 1; - - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_cray_pointer (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - attr->cray_pointer = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_cray_pointee (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->cray_pointee) - { - gfc_error ("Cray Pointee at %L appears in multiple pointer()" - " statements", where); - return false; - } - - attr->cray_pointee = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_protected (symbol_attribute *attr, const char *name, locus *where) -{ - if (check_used (attr, name, where)) - return false; - - if (attr->is_protected) - { - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate PROTECTED attribute specified at %L", - where)) - return false; - } - - attr->is_protected = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_result (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - attr->result = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_save (symbol_attribute *attr, save_state s, const char *name, - locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (s == SAVE_EXPLICIT && gfc_pure (NULL)) - { - gfc_error - ("SAVE attribute at %L cannot be specified in a PURE procedure", - where); - return false; - } - - if (s == SAVE_EXPLICIT) - gfc_unset_implicit_pure (NULL); - - if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT - && (flag_automatic || pedantic)) - { - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate SAVE attribute specified at %L", - where)) - return false; - } - - attr->save = s; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_value (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->value) - { - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate VALUE attribute specified at %L", - where)) - return false; - } - - attr->value = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) -{ - /* No check_used needed as 11.2.1 of the F2003 standard allows - that the local identifier made accessible by a use statement can be - given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ - - if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate VOLATILE attribute specified at %L", - where)) - return false; - - /* F2008: C1282 A designator of a variable with the VOLATILE attribute - shall not appear in a pure subprogram. - - F2018: C1588 A local variable of a pure subprogram, or of a BLOCK - construct within a pure subprogram, shall not have the SAVE or - VOLATILE attribute. */ - if (gfc_pure (NULL)) - { - gfc_error ("VOLATILE attribute at %L cannot be specified in a " - "PURE procedure", where); - return false; - } - - - attr->volatile_ = 1; - attr->volatile_ns = gfc_current_ns; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) -{ - /* No check_used needed as 11.2.1 of the F2003 standard allows - that the local identifier made accessible by a use statement can be - given a ASYNCHRONOUS attribute. */ - - if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns) - if (!gfc_notify_std (GFC_STD_LEGACY, - "Duplicate ASYNCHRONOUS attribute specified at %L", - where)) - return false; - - attr->asynchronous = 1; - attr->asynchronous_ns = gfc_current_ns; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->threadprivate) - { - duplicate_attr ("THREADPRIVATE", where); - return false; - } - - attr->threadprivate = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_omp_declare_target (symbol_attribute *attr, const char *name, - locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->omp_declare_target) - return true; - - attr->omp_declare_target = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, - locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->omp_declare_target_link) - return true; - - attr->omp_declare_target_link = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, - locus *where) -{ - if (check_used (attr, name, where)) - return false; - - if (attr->oacc_declare_create) - return true; - - attr->oacc_declare_create = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name, - locus *where) -{ - if (check_used (attr, name, where)) - return false; - - if (attr->oacc_declare_copyin) - return true; - - attr->oacc_declare_copyin = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name, - locus *where) -{ - if (check_used (attr, name, where)) - return false; - - if (attr->oacc_declare_deviceptr) - return true; - - attr->oacc_declare_deviceptr = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name, - locus *where) -{ - if (check_used (attr, name, where)) - return false; - - if (attr->oacc_declare_device_resident) - return true; - - attr->oacc_declare_device_resident = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_target (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->target) - { - duplicate_attr ("TARGET", where); - return false; - } - - attr->target = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - /* Duplicate dummy arguments are allowed due to ENTRY statements. */ - attr->dummy = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - /* Duplicate attribute already checked for. */ - attr->in_common = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where) -{ - - /* Duplicate attribute already checked for. */ - attr->in_equivalence = 1; - if (!gfc_check_conflict (attr, name, where)) - return false; - - if (attr->flavor == FL_VARIABLE) - return true; - - return gfc_add_flavor (attr, FL_VARIABLE, name, where); -} - - -bool -gfc_add_data (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - attr->data = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where) -{ - - attr->in_namelist = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - attr->sequence = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_elemental (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->elemental) - { - duplicate_attr ("ELEMENTAL", where); - return false; - } - - attr->elemental = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_pure (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->pure) - { - duplicate_attr ("PURE", where); - return false; - } - - attr->pure = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_recursive (symbol_attribute *attr, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->recursive) - { - duplicate_attr ("RECURSIVE", where); - return false; - } - - attr->recursive = 1; - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->entry) - { - duplicate_attr ("ENTRY", where); - return false; - } - - attr->entry = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_function (symbol_attribute *attr, const char *name, locus *where) -{ - - if (attr->flavor != FL_PROCEDURE - && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) - return false; - - attr->function = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where) -{ - - if (attr->flavor != FL_PROCEDURE - && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) - return false; - - attr->subroutine = 1; - - /* If we are looking at a BLOCK DATA statement and we encounter a - name with a leading underscore (which must be - compiler-generated), do not check. See PR 84394. */ - - if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA) - return gfc_check_conflict (attr, name, where); - else - return true; -} - - -bool -gfc_add_generic (symbol_attribute *attr, const char *name, locus *where) -{ - - if (attr->flavor != FL_PROCEDURE - && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) - return false; - - attr->generic = 1; - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->flavor != FL_PROCEDURE - && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) - return false; - - if (attr->procedure) - { - duplicate_attr ("PROCEDURE", where); - return false; - } - - attr->procedure = 1; - - return gfc_check_conflict (attr, NULL, where); -} - - -bool -gfc_add_abstract (symbol_attribute* attr, locus* where) -{ - if (attr->abstract) - { - duplicate_attr ("ABSTRACT", where); - return false; - } - - attr->abstract = 1; - - return gfc_check_conflict (attr, NULL, where); -} - - -/* Flavors are special because some flavors are not what Fortran - considers attributes and can be reaffirmed multiple times. */ - -bool -gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, - locus *where) -{ - - if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE - || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f) - || f == FL_NAMELIST) && check_used (attr, name, where)) - return false; - - if (attr->flavor == f && f == FL_VARIABLE) - return true; - - /* Copying a procedure dummy argument for a module procedure in a - submodule results in the flavor being copied and would result in - an error without this. */ - if (attr->flavor == f && f == FL_PROCEDURE - && gfc_new_block && gfc_new_block->abr_modproc_decl) - return true; - - if (attr->flavor != FL_UNKNOWN) - { - if (where == NULL) - where = &gfc_current_locus; - - if (name) - gfc_error ("%s attribute of %qs conflicts with %s attribute at %L", - gfc_code2string (flavors, attr->flavor), name, - gfc_code2string (flavors, f), where); - else - gfc_error ("%s attribute conflicts with %s attribute at %L", - gfc_code2string (flavors, attr->flavor), - gfc_code2string (flavors, f), where); - - return false; - } - - attr->flavor = f; - - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_procedure (symbol_attribute *attr, procedure_type t, - const char *name, locus *where) -{ - - if (check_used (attr, name, where)) - return false; - - if (attr->flavor != FL_PROCEDURE - && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) - return false; - - if (where == NULL) - where = &gfc_current_locus; - - if (attr->proc != PROC_UNKNOWN && !attr->module_procedure - && attr->access == ACCESS_UNKNOWN) - { - if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL - && !gfc_notification_std (GFC_STD_F2008)) - gfc_error ("%s procedure at %L is already declared as %s " - "procedure. \nF2008: A pointer function assignment " - "is ambiguous if it is the first executable statement " - "after the specification block. Please add any other " - "kind of executable statement before it. FIXME", - gfc_code2string (procedures, t), where, - gfc_code2string (procedures, attr->proc)); - else - gfc_error ("%s procedure at %L is already declared as %s " - "procedure", gfc_code2string (procedures, t), where, - gfc_code2string (procedures, attr->proc)); - - return false; - } - - attr->proc = t; - - /* Statement functions are always scalar and functions. */ - if (t == PROC_ST_FUNCTION - && ((!attr->function && !gfc_add_function (attr, name, where)) - || attr->dimension)) - return false; - - return gfc_check_conflict (attr, name, where); -} - - -bool -gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where) -{ - - if (check_used (attr, NULL, where)) - return false; - - if (attr->intent == INTENT_UNKNOWN) - { - attr->intent = intent; - return gfc_check_conflict (attr, NULL, where); - } - - if (where == NULL) - where = &gfc_current_locus; - - gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L", - gfc_intent_string (attr->intent), - gfc_intent_string (intent), where); - - return false; -} - - -/* No checks for use-association in public and private statements. */ - -bool -gfc_add_access (symbol_attribute *attr, gfc_access access, - const char *name, locus *where) -{ - - if (attr->access == ACCESS_UNKNOWN - || (attr->use_assoc && attr->access != ACCESS_PRIVATE)) - { - attr->access = access; - return gfc_check_conflict (attr, name, where); - } - - if (where == NULL) - where = &gfc_current_locus; - gfc_error ("ACCESS specification at %L was already specified", where); - - return false; -} - - -/* Set the is_bind_c field for the given symbol_attribute. */ - -bool -gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, - int is_proc_lang_bind_spec) -{ - - if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE) - gfc_error_now ("BIND(C) attribute at %L can only be used for " - "variables or common blocks", where); - else if (attr->is_bind_c) - gfc_error_now ("Duplicate BIND attribute specified at %L", where); - else - attr->is_bind_c = 1; - - if (where == NULL) - where = &gfc_current_locus; - - if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)) - return false; - - return gfc_check_conflict (attr, name, where); -} - - -/* Set the extension field for the given symbol_attribute. */ - -bool -gfc_add_extension (symbol_attribute *attr, locus *where) -{ - if (where == NULL) - where = &gfc_current_locus; - - if (attr->extension) - gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where); - else - attr->extension = 1; - - if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where)) - return false; - - return true; -} - - -bool -gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, - gfc_formal_arglist * formal, locus *where) -{ - if (check_used (&sym->attr, sym->name, where)) - return false; - - /* Skip the following checks in the case of a module_procedures in a - submodule since they will manifestly fail. */ - if (sym->attr.module_procedure == 1 - && source == IFSRC_DECL) - goto finish; - - if (where == NULL) - where = &gfc_current_locus; - - if (sym->attr.if_source != IFSRC_UNKNOWN - && sym->attr.if_source != IFSRC_DECL) - { - gfc_error ("Symbol %qs at %L already has an explicit interface", - sym->name, where); - return false; - } - - if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable)) - { - gfc_error ("%qs at %L has attributes specified outside its INTERFACE " - "body", sym->name, where); - return false; - } - -finish: - sym->formal = formal; - sym->attr.if_source = source; - - return true; -} - - -/* Add a type to a symbol. */ - -bool -gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) -{ - sym_flavor flavor; - bt type; - - if (where == NULL) - where = &gfc_current_locus; - - if (sym->result) - type = sym->result->ts.type; - else - type = sym->ts.type; - - if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name) - type = sym->ns->proc_name->ts.type; - - if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type) - && !(gfc_state_stack->previous && gfc_state_stack->previous->previous - && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) - && !sym->attr.module_procedure) - { - if (sym->attr.use_assoc) - gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " - "use-associated at %L", sym->name, where, sym->module, - &sym->declared_at); - else if (sym->attr.function && sym->attr.result) - gfc_error ("Symbol %qs at %L already has basic type of %s", - sym->ns->proc_name->name, where, gfc_basic_typename (type)); - else - gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, - where, gfc_basic_typename (type)); - return false; - } - - if (sym->attr.procedure && sym->ts.interface) - { - gfc_error ("Procedure %qs at %L may not have basic type of %s", - sym->name, where, gfc_basic_typename (ts->type)); - return false; - } - - flavor = sym->attr.flavor; - - if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE - || flavor == FL_LABEL - || (flavor == FL_PROCEDURE && sym->attr.subroutine) - || flavor == FL_DERIVED || flavor == FL_NAMELIST) - { - gfc_error ("Symbol %qs at %L cannot have a type", - sym->ns->proc_name ? sym->ns->proc_name->name : sym->name, - where); - return false; - } - - sym->ts = *ts; - return true; -} - - -/* Clears all attributes. */ - -void -gfc_clear_attr (symbol_attribute *attr) -{ - memset (attr, 0, sizeof (symbol_attribute)); -} - - -/* Check for missing attributes in the new symbol. Currently does - nothing, but it's not clear that it is unnecessary yet. */ - -bool -gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED, - locus *where ATTRIBUTE_UNUSED) -{ - - return true; -} - - -/* Copy an attribute to a symbol attribute, bit by bit. Some - attributes have a lot of side-effects but cannot be present given - where we are called from, so we ignore some bits. */ - -bool -gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) -{ - int is_proc_lang_bind_spec; - - /* In line with the other attributes, we only add bits but do not remove - them; cf. also PR 41034. */ - dest->ext_attr |= src->ext_attr; - - if (src->allocatable && !gfc_add_allocatable (dest, where)) - goto fail; - - if (src->automatic && !gfc_add_automatic (dest, NULL, where)) - goto fail; - if (src->dimension && !gfc_add_dimension (dest, NULL, where)) - goto fail; - if (src->codimension && !gfc_add_codimension (dest, NULL, where)) - goto fail; - if (src->contiguous && !gfc_add_contiguous (dest, NULL, where)) - goto fail; - if (src->optional && !gfc_add_optional (dest, where)) - goto fail; - if (src->pointer && !gfc_add_pointer (dest, where)) - goto fail; - if (src->is_protected && !gfc_add_protected (dest, NULL, where)) - goto fail; - if (src->save && !gfc_add_save (dest, src->save, NULL, where)) - goto fail; - if (src->value && !gfc_add_value (dest, NULL, where)) - goto fail; - if (src->volatile_ && !gfc_add_volatile (dest, NULL, where)) - goto fail; - if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) - goto fail; - if (src->threadprivate - && !gfc_add_threadprivate (dest, NULL, where)) - goto fail; - if (src->omp_declare_target - && !gfc_add_omp_declare_target (dest, NULL, where)) - goto fail; - if (src->omp_declare_target_link - && !gfc_add_omp_declare_target_link (dest, NULL, where)) - goto fail; - if (src->oacc_declare_create - && !gfc_add_oacc_declare_create (dest, NULL, where)) - goto fail; - if (src->oacc_declare_copyin - && !gfc_add_oacc_declare_copyin (dest, NULL, where)) - goto fail; - if (src->oacc_declare_deviceptr - && !gfc_add_oacc_declare_deviceptr (dest, NULL, where)) - goto fail; - if (src->oacc_declare_device_resident - && !gfc_add_oacc_declare_device_resident (dest, NULL, where)) - goto fail; - if (src->target && !gfc_add_target (dest, where)) - goto fail; - if (src->dummy && !gfc_add_dummy (dest, NULL, where)) - goto fail; - if (src->result && !gfc_add_result (dest, NULL, where)) - goto fail; - if (src->entry) - dest->entry = 1; - - if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where)) - goto fail; - - if (src->in_common && !gfc_add_in_common (dest, NULL, where)) - goto fail; - - if (src->generic && !gfc_add_generic (dest, NULL, where)) - goto fail; - if (src->function && !gfc_add_function (dest, NULL, where)) - goto fail; - if (src->subroutine && !gfc_add_subroutine (dest, NULL, where)) - goto fail; - - if (src->sequence && !gfc_add_sequence (dest, NULL, where)) - goto fail; - if (src->elemental && !gfc_add_elemental (dest, where)) - goto fail; - if (src->pure && !gfc_add_pure (dest, where)) - goto fail; - if (src->recursive && !gfc_add_recursive (dest, where)) - goto fail; - - if (src->flavor != FL_UNKNOWN - && !gfc_add_flavor (dest, src->flavor, NULL, where)) - goto fail; - - if (src->intent != INTENT_UNKNOWN - && !gfc_add_intent (dest, src->intent, where)) - goto fail; - - if (src->access != ACCESS_UNKNOWN - && !gfc_add_access (dest, src->access, NULL, where)) - goto fail; - - if (!gfc_missing_attr (dest, where)) - goto fail; - - if (src->cray_pointer && !gfc_add_cray_pointer (dest, where)) - goto fail; - if (src->cray_pointee && !gfc_add_cray_pointee (dest, where)) - goto fail; - - is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0); - if (src->is_bind_c - && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)) - return false; - - if (src->is_c_interop) - dest->is_c_interop = 1; - if (src->is_iso_c) - dest->is_iso_c = 1; - - if (src->external && !gfc_add_external (dest, where)) - goto fail; - if (src->intrinsic && !gfc_add_intrinsic (dest, where)) - goto fail; - if (src->proc_pointer) - dest->proc_pointer = 1; - - return true; - -fail: - return false; -} - - -/* A function to generate a dummy argument symbol using that from the - interface declaration. Can be used for the result symbol as well if - the flag is set. */ - -int -gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result) -{ - int rc; - - rc = gfc_get_symbol (sym->name, NULL, dsym); - if (rc) - return rc; - - if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus)) - return 1; - - if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr), - &gfc_current_locus)) - return 1; - - if ((*dsym)->attr.dimension) - (*dsym)->as = gfc_copy_array_spec (sym->as); - - (*dsym)->attr.class_ok = sym->attr.class_ok; - - if ((*dsym) != NULL && !result - && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL) - || !gfc_missing_attr (&(*dsym)->attr, NULL))) - return 1; - else if ((*dsym) != NULL && result - && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL) - || !gfc_missing_attr (&(*dsym)->attr, NULL))) - return 1; - - return 0; -} - - -/************** Component name management ************/ - -/* Component names of a derived type form their own little namespaces - that are separate from all other spaces. The space is composed of - a singly linked list of gfc_component structures whose head is - located in the parent symbol. */ - - -/* Add a component name to a symbol. The call fails if the name is - already present. On success, the component pointer is modified to - point to the additional component structure. */ - -bool -gfc_add_component (gfc_symbol *sym, const char *name, - gfc_component **component) -{ - gfc_component *p, *tail; - - /* Check for existing components with the same name, but not for union - components or containers. Unions and maps are anonymous so they have - unique internal names which will never conflict. - Don't use gfc_find_component here because it calls gfc_use_derived, - but the derived type may not be fully defined yet. */ - tail = NULL; - - for (p = sym->components; p; p = p->next) - { - if (strcmp (p->name, name) == 0) - { - gfc_error ("Component %qs at %C already declared at %L", - name, &p->loc); - return false; - } - - tail = p; - } - - if (sym->attr.extension - && gfc_find_component (sym->components->ts.u.derived, - name, true, true, NULL)) - { - gfc_error ("Component %qs at %C already in the parent type " - "at %L", name, &sym->components->ts.u.derived->declared_at); - return false; - } - - /* Allocate a new component. */ - p = gfc_get_component (); - - if (tail == NULL) - sym->components = p; - else - tail->next = p; - - p->name = gfc_get_string ("%s", name); - p->loc = gfc_current_locus; - p->ts.type = BT_UNKNOWN; - - *component = p; - return true; -} - - -/* Recursive function to switch derived types of all symbol in a - namespace. */ - -static void -switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to) -{ - gfc_symbol *sym; - - if (st == NULL) - return; - - sym = st->n.sym; - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from) - sym->ts.u.derived = to; - - switch_types (st->left, from, to); - switch_types (st->right, from, to); -} - - -/* This subroutine is called when a derived type is used in order to - make the final determination about which version to use. The - standard requires that a type be defined before it is 'used', but - such types can appear in IMPLICIT statements before the actual - definition. 'Using' in this context means declaring a variable to - be that type or using the type constructor. - - If a type is used and the components haven't been defined, then we - have to have a derived type in a parent unit. We find the node in - the other namespace and point the symtree node in this namespace to - that node. Further reference to this name point to the correct - node. If we can't find the node in a parent namespace, then we have - an error. - - This subroutine takes a pointer to a symbol node and returns a - pointer to the translated node or NULL for an error. Usually there - is no translation and we return the node we were passed. */ - -gfc_symbol * -gfc_use_derived (gfc_symbol *sym) -{ - gfc_symbol *s; - gfc_typespec *t; - gfc_symtree *st; - int i; - - if (!sym) - return NULL; - - if (sym->attr.unlimited_polymorphic) - return sym; - - if (sym->attr.generic) - sym = gfc_find_dt_in_generic (sym); - - if (sym->components != NULL || sym->attr.zero_comp) - return sym; /* Already defined. */ - - if (sym->ns->parent == NULL) - goto bad; - - if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) - { - gfc_error ("Symbol %qs at %C is ambiguous", sym->name); - return NULL; - } - - if (s == NULL || !gfc_fl_struct (s->attr.flavor)) - goto bad; - - /* Get rid of symbol sym, translating all references to s. */ - for (i = 0; i < GFC_LETTERS; i++) - { - t = &sym->ns->default_type[i]; - if (t->u.derived == sym) - t->u.derived = s; - } - - st = gfc_find_symtree (sym->ns->sym_root, sym->name); - st->n.sym = s; - - s->refs++; - - /* Unlink from list of modified symbols. */ - gfc_commit_symbol (sym); - - switch_types (sym->ns->sym_root, sym, s); - - /* TODO: Also have to replace sym -> s in other lists like - namelists, common lists and interface lists. */ - gfc_free_symbol (sym); - - return s; - -bad: - gfc_error ("Derived type %qs at %C is being used before it is defined", - sym->name); - return NULL; -} - - -/* Find the component with the given name in the union type symbol. - If ref is not NULL it will be set to the chain of components through which - the component can actually be accessed. This is necessary for unions because - intermediate structures may be maps, nested structures, or other unions, - all of which may (or must) be 'anonymous' to user code. */ - -static gfc_component * -find_union_component (gfc_symbol *un, const char *name, - bool noaccess, gfc_ref **ref) -{ - gfc_component *m, *check; - gfc_ref *sref, *tmp; - - for (m = un->components; m; m = m->next) - { - check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp); - if (check == NULL) - continue; - - /* Found component somewhere in m; chain the refs together. */ - if (ref) - { - /* Map ref. */ - sref = gfc_get_ref (); - sref->type = REF_COMPONENT; - sref->u.c.component = m; - sref->u.c.sym = m->ts.u.derived; - sref->next = tmp; - - *ref = sref; - } - /* Other checks (such as access) were done in the recursive calls. */ - return check; - } - return NULL; -} - - -/* Recursively append candidate COMPONENT structures to CANDIDATES. Store - the number of total candidates in CANDIDATES_LEN. */ - -static void -lookup_component_fuzzy_find_candidates (gfc_component *component, - char **&candidates, - size_t &candidates_len) -{ - for (gfc_component *p = component; p; p = p->next) - vec_push (candidates, candidates_len, p->name); -} - - -/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */ - -static const char* -lookup_component_fuzzy (const char *member, gfc_component *component) -{ - char **candidates = NULL; - size_t candidates_len = 0; - lookup_component_fuzzy_find_candidates (component, candidates, - candidates_len); - return gfc_closest_fuzzy_match (member, candidates); -} - - -/* Given a derived type node and a component name, try to locate the - component structure. Returns the NULL pointer if the component is - not found or the components are private. If noaccess is set, no access - checks are done. If silent is set, an error will not be generated if - the component cannot be found or accessed. - - If ref is not NULL, *ref is set to represent the chain of components - required to get to the ultimate component. - - If the component is simply a direct subcomponent, or is inherited from a - parent derived type in the given derived type, this is a single ref with its - component set to the returned component. - - Otherwise, *ref is constructed as a chain of subcomponents. This occurs - when the component is found through an implicit chain of nested union and - map components. Unions and maps are "anonymous" substructures in FORTRAN - which cannot be explicitly referenced, but the reference chain must be - considered as in C for backend translation to correctly compute layouts. - (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */ - -gfc_component * -gfc_find_component (gfc_symbol *sym, const char *name, - bool noaccess, bool silent, gfc_ref **ref) -{ - gfc_component *p, *check; - gfc_ref *sref = NULL, *tmp = NULL; - - if (name == NULL || sym == NULL) - return NULL; - - if (sym->attr.flavor == FL_DERIVED) - sym = gfc_use_derived (sym); - else - gcc_assert (gfc_fl_struct (sym->attr.flavor)); - - if (sym == NULL) - return NULL; - - /* Handle UNIONs specially - mutually recursive with gfc_find_component. */ - if (sym->attr.flavor == FL_UNION) - return find_union_component (sym, name, noaccess, ref); - - if (ref) *ref = NULL; - for (p = sym->components; p; p = p->next) - { - /* Nest search into union's maps. */ - if (p->ts.type == BT_UNION) - { - check = find_union_component (p->ts.u.derived, name, noaccess, &tmp); - if (check != NULL) - { - /* Union ref. */ - if (ref) - { - sref = gfc_get_ref (); - sref->type = REF_COMPONENT; - sref->u.c.component = p; - sref->u.c.sym = p->ts.u.derived; - sref->next = tmp; - *ref = sref; - } - return check; - } - } - else if (strcmp (p->name, name) == 0) - break; - - continue; - } - - if (p && sym->attr.use_assoc && !noaccess) - { - bool is_parent_comp = sym->attr.extension && (p == sym->components); - if (p->attr.access == ACCESS_PRIVATE || - (p->attr.access != ACCESS_PUBLIC - && sym->component_access == ACCESS_PRIVATE - && !is_parent_comp)) - { - if (!silent) - gfc_error ("Component %qs at %C is a PRIVATE component of %qs", - name, sym->name); - return NULL; - } - } - - if (p == NULL - && sym->attr.extension - && sym->components->ts.type == BT_DERIVED) - { - p = gfc_find_component (sym->components->ts.u.derived, name, - noaccess, silent, ref); - /* Do not overwrite the error. */ - if (p == NULL) - return p; - } - - if (p == NULL && !silent) - { - const char *guessed = lookup_component_fuzzy (name, sym->components); - if (guessed) - gfc_error ("%qs at %C is not a member of the %qs structure" - "; did you mean %qs?", - name, sym->name, guessed); - else - gfc_error ("%qs at %C is not a member of the %qs structure", - name, sym->name); - } - - /* Component was found; build the ultimate component reference. */ - if (p != NULL && ref) - { - tmp = gfc_get_ref (); - tmp->type = REF_COMPONENT; - tmp->u.c.component = p; - tmp->u.c.sym = sym; - /* Link the final component ref to the end of the chain of subrefs. */ - if (sref) - { - *ref = sref; - for (; sref->next; sref = sref->next) - ; - sref->next = tmp; - } - else - *ref = tmp; - } - - return p; -} - - -/* Given a symbol, free all of the component structures and everything - they point to. */ - -static void -free_components (gfc_component *p) -{ - gfc_component *q; - - for (; p; p = q) - { - q = p->next; - - gfc_free_array_spec (p->as); - gfc_free_expr (p->initializer); - if (p->kind_expr) - gfc_free_expr (p->kind_expr); - if (p->param_list) - gfc_free_actual_arglist (p->param_list); - free (p->tb); - p->tb = NULL; - free (p); - } -} - - -/******************** Statement label management ********************/ - -/* Comparison function for statement labels, used for managing the - binary tree. */ - -static int -compare_st_labels (void *a1, void *b1) -{ - int a = ((gfc_st_label *) a1)->value; - int b = ((gfc_st_label *) b1)->value; - - return (b - a); -} - - -/* Free a single gfc_st_label structure, making sure the tree is not - messed up. This function is called only when some parse error - occurs. */ - -void -gfc_free_st_label (gfc_st_label *label) -{ - - if (label == NULL) - return; - - gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); - - if (label->format != NULL) - gfc_free_expr (label->format); - - free (label); -} - - -/* Free a whole tree of gfc_st_label structures. */ - -static void -free_st_labels (gfc_st_label *label) -{ - - if (label == NULL) - return; - - free_st_labels (label->left); - free_st_labels (label->right); - - if (label->format != NULL) - gfc_free_expr (label->format); - free (label); -} - - -/* Given a label number, search for and return a pointer to the label - structure, creating it if it does not exist. */ - -gfc_st_label * -gfc_get_st_label (int labelno) -{ - gfc_st_label *lp; - gfc_namespace *ns; - - if (gfc_current_state () == COMP_DERIVED) - ns = gfc_current_block ()->f2k_derived; - else - { - /* Find the namespace of the scoping unit: - If we're in a BLOCK construct, jump to the parent namespace. */ - ns = gfc_current_ns; - while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL) - ns = ns->parent; - } - - /* First see if the label is already in this namespace. */ - lp = ns->st_labels; - while (lp) - { - if (lp->value == labelno) - return lp; - - if (lp->value < labelno) - lp = lp->left; - else - lp = lp->right; - } - - lp = XCNEW (gfc_st_label); - - lp->value = labelno; - lp->defined = ST_LABEL_UNKNOWN; - lp->referenced = ST_LABEL_UNKNOWN; - lp->ns = ns; - - gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels); - - return lp; -} - - -/* Called when a statement with a statement label is about to be - accepted. We add the label to the list of the current namespace, - making sure it hasn't been defined previously and referenced - correctly. */ - -void -gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) -{ - int labelno; - - labelno = lp->value; - - if (lp->defined != ST_LABEL_UNKNOWN) - gfc_error ("Duplicate statement label %d at %L and %L", labelno, - &lp->where, label_locus); - else - { - lp->where = *label_locus; - - switch (type) - { - case ST_LABEL_FORMAT: - if (lp->referenced == ST_LABEL_TARGET - || lp->referenced == ST_LABEL_DO_TARGET) - gfc_error ("Label %d at %C already referenced as branch target", - labelno); - else - lp->defined = ST_LABEL_FORMAT; - - break; - - case ST_LABEL_TARGET: - case ST_LABEL_DO_TARGET: - if (lp->referenced == ST_LABEL_FORMAT) - gfc_error ("Label %d at %C already referenced as a format label", - labelno); - else - lp->defined = type; - - if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET - && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, - "DO termination statement which is not END DO" - " or CONTINUE with label %d at %C", labelno)) - return; - break; - - default: - lp->defined = ST_LABEL_BAD_TARGET; - lp->referenced = ST_LABEL_BAD_TARGET; - } - } -} - - -/* Reference a label. Given a label and its type, see if that - reference is consistent with what is known about that label, - updating the unknown state. Returns false if something goes - wrong. */ - -bool -gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) -{ - gfc_sl_type label_type; - int labelno; - bool rc; - - if (lp == NULL) - return true; - - labelno = lp->value; - - if (lp->defined != ST_LABEL_UNKNOWN) - label_type = lp->defined; - else - { - label_type = lp->referenced; - lp->where = gfc_current_locus; - } - - if (label_type == ST_LABEL_FORMAT - && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET)) - { - gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); - rc = false; - goto done; - } - - if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET - || label_type == ST_LABEL_BAD_TARGET) - && type == ST_LABEL_FORMAT) - { - gfc_error ("Label %d at %C previously used as branch target", labelno); - rc = false; - goto done; - } - - if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET - && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, - "Shared DO termination label %d at %C", labelno)) - return false; - - if (type == ST_LABEL_DO_TARGET - && !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement " - "at %L", &gfc_current_locus)) - return false; - - if (lp->referenced != ST_LABEL_DO_TARGET) - lp->referenced = type; - rc = true; - -done: - return rc; -} - - -/************** Symbol table management subroutines ****************/ - -/* Basic details: Fortran 95 requires a potentially unlimited number - of distinct namespaces when compiling a program unit. This case - occurs during a compilation of internal subprograms because all of - the internal subprograms must be read before we can start - generating code for the host. - - Given the tricky nature of the Fortran grammar, we must be able to - undo changes made to a symbol table if the current interpretation - of a statement is found to be incorrect. Whenever a symbol is - looked up, we make a copy of it and link to it. All of these - symbols are kept in a vector so that we can commit or - undo the changes at a later time. - - A symtree may point to a symbol node outside of its namespace. In - this case, that symbol has been used as a host associated variable - at some previous time. */ - -/* Allocate a new namespace structure. Copies the implicit types from - PARENT if PARENT_TYPES is set. */ - -gfc_namespace * -gfc_get_namespace (gfc_namespace *parent, int parent_types) -{ - gfc_namespace *ns; - gfc_typespec *ts; - int in; - int i; - - ns = XCNEW (gfc_namespace); - ns->sym_root = NULL; - ns->uop_root = NULL; - ns->tb_sym_root = NULL; - ns->finalizers = NULL; - ns->default_access = ACCESS_UNKNOWN; - ns->parent = parent; - - for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) - { - ns->operator_access[in] = ACCESS_UNKNOWN; - ns->tb_op[in] = NULL; - } - - /* Initialize default implicit types. */ - for (i = 'a'; i <= 'z'; i++) - { - ns->set_flag[i - 'a'] = 0; - ts = &ns->default_type[i - 'a']; - - if (parent_types && ns->parent != NULL) - { - /* Copy parent settings. */ - *ts = ns->parent->default_type[i - 'a']; - continue; - } - - if (flag_implicit_none != 0) - { - gfc_clear_ts (ts); - continue; - } - - if ('i' <= i && i <= 'n') - { - ts->type = BT_INTEGER; - ts->kind = gfc_default_integer_kind; - } - else - { - ts->type = BT_REAL; - ts->kind = gfc_default_real_kind; - } - } - - ns->refs = 1; - - return ns; -} - - -/* Comparison function for symtree nodes. */ - -static int -compare_symtree (void *_st1, void *_st2) -{ - gfc_symtree *st1, *st2; - - st1 = (gfc_symtree *) _st1; - st2 = (gfc_symtree *) _st2; - - return strcmp (st1->name, st2->name); -} - - -/* Allocate a new symtree node and associate it with the new symbol. */ - -gfc_symtree * -gfc_new_symtree (gfc_symtree **root, const char *name) -{ - gfc_symtree *st; - - st = XCNEW (gfc_symtree); - st->name = gfc_get_string ("%s", name); - - gfc_insert_bbt (root, st, compare_symtree); - return st; -} - - -/* Delete a symbol from the tree. Does not free the symbol itself! */ - -void -gfc_delete_symtree (gfc_symtree **root, const char *name) -{ - gfc_symtree st, *st0; - const char *p; - - /* Submodules are marked as mod.submod. When freeing a submodule - symbol, the symtree only has "submod", so adjust that here. */ - - p = strrchr(name, '.'); - if (p) - p++; - else - p = name; - - st0 = gfc_find_symtree (*root, p); - - st.name = gfc_get_string ("%s", p); - gfc_delete_bbt (root, &st, compare_symtree); - - free (st0); -} - - -/* Given a root symtree node and a name, try to find the symbol within - the namespace. Returns NULL if the symbol is not found. */ - -gfc_symtree * -gfc_find_symtree (gfc_symtree *st, const char *name) -{ - int c; - - while (st != NULL) - { - c = strcmp (name, st->name); - if (c == 0) - return st; - - st = (c < 0) ? st->left : st->right; - } - - return NULL; -} - - -/* Return a symtree node with a name that is guaranteed to be unique - within the namespace and corresponds to an illegal fortran name. */ - -gfc_symtree * -gfc_get_unique_symtree (gfc_namespace *ns) -{ - char name[GFC_MAX_SYMBOL_LEN + 1]; - static int serial = 0; - - sprintf (name, "@%d", serial++); - return gfc_new_symtree (&ns->sym_root, name); -} - - -/* Given a name find a user operator node, creating it if it doesn't - exist. These are much simpler than symbols because they can't be - ambiguous with one another. */ - -gfc_user_op * -gfc_get_uop (const char *name) -{ - gfc_user_op *uop; - gfc_symtree *st; - gfc_namespace *ns = gfc_current_ns; - - if (ns->omp_udr_ns) - ns = ns->parent; - st = gfc_find_symtree (ns->uop_root, name); - if (st != NULL) - return st->n.uop; - - st = gfc_new_symtree (&ns->uop_root, name); - - uop = st->n.uop = XCNEW (gfc_user_op); - uop->name = gfc_get_string ("%s", name); - uop->access = ACCESS_UNKNOWN; - uop->ns = ns; - - return uop; -} - - -/* Given a name find the user operator node. Returns NULL if it does - not exist. */ - -gfc_user_op * -gfc_find_uop (const char *name, gfc_namespace *ns) -{ - gfc_symtree *st; - - if (ns == NULL) - ns = gfc_current_ns; - - st = gfc_find_symtree (ns->uop_root, name); - return (st == NULL) ? NULL : st->n.uop; -} - - -/* Update a symbol's common_block field, and take care of the associated - memory management. */ - -static void -set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block) -{ - if (sym->common_block == common_block) - return; - - if (sym->common_block && sym->common_block->name[0] != '\0') - { - sym->common_block->refs--; - if (sym->common_block->refs == 0) - free (sym->common_block); - } - sym->common_block = common_block; -} - - -/* Remove a gfc_symbol structure and everything it points to. */ - -void -gfc_free_symbol (gfc_symbol *&sym) -{ - - if (sym == NULL) - return; - - gfc_free_array_spec (sym->as); - - free_components (sym->components); - - gfc_free_expr (sym->value); - - gfc_free_namelist (sym->namelist); - - if (sym->ns != sym->formal_ns) - gfc_free_namespace (sym->formal_ns); - - if (!sym->attr.generic_copy) - gfc_free_interface (sym->generic); - - gfc_free_formal_arglist (sym->formal); - - gfc_free_namespace (sym->f2k_derived); - - set_symbol_common_block (sym, NULL); - - if (sym->param_list) - gfc_free_actual_arglist (sym->param_list); - - free (sym); - sym = NULL; -} - - -/* Decrease the reference counter and free memory when we reach zero. */ - -void -gfc_release_symbol (gfc_symbol *&sym) -{ - if (sym == NULL) - return; - - if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns - && (!sym->attr.entry || !sym->module)) - { - /* As formal_ns contains a reference to sym, delete formal_ns just - before the deletion of sym. */ - gfc_namespace *ns = sym->formal_ns; - sym->formal_ns = NULL; - gfc_free_namespace (ns); - } - - sym->refs--; - if (sym->refs > 0) - return; - - gcc_assert (sym->refs == 0); - gfc_free_symbol (sym); -} - - -/* Allocate and initialize a new symbol node. */ - -gfc_symbol * -gfc_new_symbol (const char *name, gfc_namespace *ns) -{ - gfc_symbol *p; - - p = XCNEW (gfc_symbol); - - gfc_clear_ts (&p->ts); - gfc_clear_attr (&p->attr); - p->ns = ns; - p->declared_at = gfc_current_locus; - p->name = gfc_get_string ("%s", name); - - return p; -} - - -/* Generate an error if a symbol is ambiguous, and set the error flag - on it. */ - -static void -ambiguous_symbol (const char *name, gfc_symtree *st) -{ - - if (st->n.sym->error) - return; - - if (st->n.sym->module) - gfc_error ("Name %qs at %C is an ambiguous reference to %qs " - "from module %qs", name, st->n.sym->name, st->n.sym->module); - else - gfc_error ("Name %qs at %C is an ambiguous reference to %qs " - "from current program unit", name, st->n.sym->name); - - st->n.sym->error = 1; -} - - -/* If we're in a SELECT TYPE block, check if the variable 'st' matches any - selector on the stack. If yes, replace it by the corresponding temporary. */ - -static void -select_type_insert_tmp (gfc_symtree **st) -{ - gfc_select_type_stack *stack = select_type_stack; - for (; stack; stack = stack->prev) - if ((*st)->n.sym == stack->selector && stack->tmp) - { - *st = stack->tmp; - select_type_insert_tmp (st); - return; - } -} - - -/* Look for a symtree in the current procedure -- that is, go up to - parent namespaces but only if inside a BLOCK. Returns NULL if not found. */ - -gfc_symtree* -gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns) -{ - while (ns) - { - gfc_symtree* st = gfc_find_symtree (ns->sym_root, name); - if (st) - return st; - - if (!ns->construct_entities) - break; - ns = ns->parent; - } - - return NULL; -} - - -/* Search for a symtree starting in the current namespace, resorting to - any parent namespaces if requested by a nonzero parent_flag. - Returns nonzero if the name is ambiguous. */ - -int -gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, - gfc_symtree **result) -{ - gfc_symtree *st; - - if (ns == NULL) - ns = gfc_current_ns; - - do - { - st = gfc_find_symtree (ns->sym_root, name); - if (st != NULL) - { - select_type_insert_tmp (&st); - - *result = st; - /* Ambiguous generic interfaces are permitted, as long - as the specific interfaces are different. */ - if (st->ambiguous && !st->n.sym->attr.generic) - { - ambiguous_symbol (name, st); - return 1; - } - - return 0; - } - - if (!parent_flag) - break; - - /* Don't escape an interface block. */ - if (ns && !ns->has_import_set - && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) - break; - - ns = ns->parent; - } - while (ns != NULL); - - if (gfc_current_state() == COMP_DERIVED - && gfc_current_block ()->attr.pdt_template) - { - gfc_symbol *der = gfc_current_block (); - for (; der; der = gfc_get_derived_super_type (der)) - { - if (der->f2k_derived && der->f2k_derived->sym_root) - { - st = gfc_find_symtree (der->f2k_derived->sym_root, name); - if (st) - break; - } - } - *result = st; - return 0; - } - - *result = NULL; - - return 0; -} - - -/* Same, but returns the symbol instead. */ - -int -gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag, - gfc_symbol **result) -{ - gfc_symtree *st; - int i; - - i = gfc_find_sym_tree (name, ns, parent_flag, &st); - - if (st == NULL) - *result = NULL; - else - *result = st->n.sym; - - return i; -} - - -/* Tells whether there is only one set of changes in the stack. */ - -static bool -single_undo_checkpoint_p (void) -{ - if (latest_undo_chgset == &default_undo_chgset_var) - { - gcc_assert (latest_undo_chgset->previous == NULL); - return true; - } - else - { - gcc_assert (latest_undo_chgset->previous != NULL); - return false; - } -} - -/* Save symbol with the information necessary to back it out. */ - -void -gfc_save_symbol_data (gfc_symbol *sym) -{ - gfc_symbol *s; - unsigned i; - - if (!single_undo_checkpoint_p ()) - { - /* If there is more than one change set, look for the symbol in the - current one. If it is found there, we can reuse it. */ - FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) - if (s == sym) - { - gcc_assert (sym->gfc_new || sym->old_symbol != NULL); - return; - } - } - else if (sym->gfc_new || sym->old_symbol != NULL) - return; - - s = XCNEW (gfc_symbol); - *s = *sym; - sym->old_symbol = s; - sym->gfc_new = 0; - - latest_undo_chgset->syms.safe_push (sym); -} - - -/* Given a name, find a symbol, or create it if it does not exist yet - in the current namespace. If the symbol is found we make sure that - it's OK. - - The integer return code indicates - 0 All OK - 1 The symbol name was ambiguous - 2 The name meant to be established was already host associated. - - So if the return value is nonzero, then an error was issued. */ - -int -gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, - bool allow_subroutine) -{ - gfc_symtree *st; - gfc_symbol *p; - - /* This doesn't usually happen during resolution. */ - if (ns == NULL) - ns = gfc_current_ns; - - /* Try to find the symbol in ns. */ - st = gfc_find_symtree (ns->sym_root, name); - - if (st == NULL && ns->omp_udr_ns) - { - ns = ns->parent; - st = gfc_find_symtree (ns->sym_root, name); - } - - if (st == NULL) - { - /* If not there, create a new symbol. */ - p = gfc_new_symbol (name, ns); - - /* Add to the list of tentative symbols. */ - p->old_symbol = NULL; - p->mark = 1; - p->gfc_new = 1; - latest_undo_chgset->syms.safe_push (p); - - st = gfc_new_symtree (&ns->sym_root, name); - st->n.sym = p; - p->refs++; - - } - else - { - /* Make sure the existing symbol is OK. Ambiguous - generic interfaces are permitted, as long as the - specific interfaces are different. */ - if (st->ambiguous && !st->n.sym->attr.generic) - { - ambiguous_symbol (name, st); - return 1; - } - - p = st->n.sym; - if (p->ns != ns && (!p->attr.function || ns->proc_name != p) - && !(allow_subroutine && p->attr.subroutine) - && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY - && (ns->has_import_set || p->attr.imported))) - { - /* Symbol is from another namespace. */ - gfc_error ("Symbol %qs at %C has already been host associated", - name); - return 2; - } - - p->mark = 1; - - /* Copy in case this symbol is changed. */ - gfc_save_symbol_data (p); - } - - *result = st; - return 0; -} - - -int -gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result) -{ - gfc_symtree *st; - int i; - - i = gfc_get_sym_tree (name, ns, &st, false); - if (i != 0) - return i; - - if (st) - *result = st->n.sym; - else - *result = NULL; - return i; -} - - -/* Subroutine that searches for a symbol, creating it if it doesn't - exist, but tries to host-associate the symbol if possible. */ - -int -gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) -{ - gfc_symtree *st; - int i; - - i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); - - if (st != NULL) - { - gfc_save_symbol_data (st->n.sym); - *result = st; - return i; - } - - i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st); - if (i) - return i; - - if (st != NULL) - { - *result = st; - return 0; - } - - return gfc_get_sym_tree (name, gfc_current_ns, result, false); -} - - -int -gfc_get_ha_symbol (const char *name, gfc_symbol **result) -{ - int i; - gfc_symtree *st; - - i = gfc_get_ha_sym_tree (name, &st); - - if (st) - *result = st->n.sym; - else - *result = NULL; - - return i; -} - - -/* Search for the symtree belonging to a gfc_common_head; we cannot use - head->name as the common_root symtree's name might be mangled. */ - -static gfc_symtree * -find_common_symtree (gfc_symtree *st, gfc_common_head *head) -{ - - gfc_symtree *result; - - if (st == NULL) - return NULL; - - if (st->n.common == head) - return st; - - result = find_common_symtree (st->left, head); - if (!result) - result = find_common_symtree (st->right, head); - - return result; -} - - -/* Restore previous state of symbol. Just copy simple stuff. */ - -static void -restore_old_symbol (gfc_symbol *p) -{ - gfc_symbol *old; - - p->mark = 0; - old = p->old_symbol; - - p->ts.type = old->ts.type; - p->ts.kind = old->ts.kind; - - p->attr = old->attr; - - if (p->value != old->value) - { - gcc_checking_assert (old->value == NULL); - gfc_free_expr (p->value); - p->value = NULL; - } - - if (p->as != old->as) - { - if (p->as) - gfc_free_array_spec (p->as); - p->as = old->as; - } - - p->generic = old->generic; - p->component_access = old->component_access; - - if (p->namelist != NULL && old->namelist == NULL) - { - gfc_free_namelist (p->namelist); - p->namelist = NULL; - } - else - { - if (p->namelist_tail != old->namelist_tail) - { - gfc_free_namelist (old->namelist_tail->next); - old->namelist_tail->next = NULL; - } - } - - p->namelist_tail = old->namelist_tail; - - if (p->formal != old->formal) - { - gfc_free_formal_arglist (p->formal); - p->formal = old->formal; - } - - set_symbol_common_block (p, old->common_block); - p->common_head = old->common_head; - - p->old_symbol = old->old_symbol; - free (old); -} - - -/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free - the structure itself. */ - -static void -free_undo_change_set_data (gfc_undo_change_set &cs) -{ - cs.syms.release (); - cs.tbps.release (); -} - - -/* Given a change set pointer, free its target's contents and update it with - the address of the previous change set. Note that only the contents are - freed, not the target itself (the contents' container). It is not a problem - as the latter will be a local variable usually. */ - -static void -pop_undo_change_set (gfc_undo_change_set *&cs) -{ - free_undo_change_set_data (*cs); - cs = cs->previous; -} - - -static void free_old_symbol (gfc_symbol *sym); - - -/* Merges the current change set into the previous one. The changes themselves - are left untouched; only one checkpoint is forgotten. */ - -void -gfc_drop_last_undo_checkpoint (void) -{ - gfc_symbol *s, *t; - unsigned i, j; - - FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) - { - /* No need to loop in this case. */ - if (s->old_symbol == NULL) - continue; - - /* Remove the duplicate symbols. */ - FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t) - if (t == s) - { - latest_undo_chgset->previous->syms.unordered_remove (j); - - /* S->OLD_SYMBOL is the backup symbol for S as it was at the - last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL - shall contain from now on the backup symbol for S as it was - at the checkpoint before. */ - if (s->old_symbol->gfc_new) - { - gcc_assert (s->old_symbol->old_symbol == NULL); - s->gfc_new = s->old_symbol->gfc_new; - free_old_symbol (s); - } - else - restore_old_symbol (s->old_symbol); - break; - } - } - - latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms); - latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps); - - pop_undo_change_set (latest_undo_chgset); -} - - -/* Undoes all the changes made to symbols since the previous checkpoint. - This subroutine is made simpler due to the fact that attributes are - never removed once added. */ - -void -gfc_restore_last_undo_checkpoint (void) -{ - gfc_symbol *p; - unsigned i; - - FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) - { - /* Symbol in a common block was new. Or was old and just put in common */ - if (p->common_block - && (p->gfc_new || !p->old_symbol->common_block)) - { - /* If the symbol was added to any common block, it - needs to be removed to stop the resolver looking - for a (possibly) dead symbol. */ - if (p->common_block->head == p && !p->common_next) - { - gfc_symtree st, *st0; - st0 = find_common_symtree (p->ns->common_root, - p->common_block); - if (st0) - { - st.name = st0->name; - gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree); - free (st0); - } - } - - if (p->common_block->head == p) - p->common_block->head = p->common_next; - else - { - gfc_symbol *cparent, *csym; - - cparent = p->common_block->head; - csym = cparent->common_next; - - while (csym != p) - { - cparent = csym; - csym = csym->common_next; - } - - gcc_assert(cparent->common_next == p); - cparent->common_next = csym->common_next; - } - p->common_next = NULL; - } - if (p->gfc_new) - { - /* The derived type is saved in the symtree with the first - letter capitalized; the all lower-case version to the - derived type contains its associated generic function. */ - if (gfc_fl_struct (p->attr.flavor)) - gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name)); - else - gfc_delete_symtree (&p->ns->sym_root, p->name); - - gfc_release_symbol (p); - } - else - restore_old_symbol (p); - } - - latest_undo_chgset->syms.truncate (0); - latest_undo_chgset->tbps.truncate (0); - - if (!single_undo_checkpoint_p ()) - pop_undo_change_set (latest_undo_chgset); -} - - -/* Makes sure that there is only one set of changes; in other words we haven't - forgotten to pair a call to gfc_new_checkpoint with a call to either - gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */ - -static void -enforce_single_undo_checkpoint (void) -{ - gcc_checking_assert (single_undo_checkpoint_p ()); -} - - -/* Undoes all the changes made to symbols in the current statement. */ - -void -gfc_undo_symbols (void) -{ - enforce_single_undo_checkpoint (); - gfc_restore_last_undo_checkpoint (); -} - - -/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the - components of old_symbol that might need deallocation are the "allocatables" - that are restored in gfc_undo_symbols(), with two exceptions: namelist and - namelist_tail. In case these differ between old_symbol and sym, it's just - because sym->namelist has gotten a few more items. */ - -static void -free_old_symbol (gfc_symbol *sym) -{ - - if (sym->old_symbol == NULL) - return; - - if (sym->old_symbol->as != sym->as) - gfc_free_array_spec (sym->old_symbol->as); - - if (sym->old_symbol->value != sym->value) - gfc_free_expr (sym->old_symbol->value); - - if (sym->old_symbol->formal != sym->formal) - gfc_free_formal_arglist (sym->old_symbol->formal); - - free (sym->old_symbol); - sym->old_symbol = NULL; -} - - -/* Makes the changes made in the current statement permanent-- gets - rid of undo information. */ - -void -gfc_commit_symbols (void) -{ - gfc_symbol *p; - gfc_typebound_proc *tbp; - unsigned i; - - enforce_single_undo_checkpoint (); - - FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) - { - p->mark = 0; - p->gfc_new = 0; - free_old_symbol (p); - } - latest_undo_chgset->syms.truncate (0); - - FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp) - tbp->error = 0; - latest_undo_chgset->tbps.truncate (0); -} - - -/* Makes the changes made in one symbol permanent -- gets rid of undo - information. */ - -void -gfc_commit_symbol (gfc_symbol *sym) -{ - gfc_symbol *p; - unsigned i; - - enforce_single_undo_checkpoint (); - - FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) - if (p == sym) - { - latest_undo_chgset->syms.unordered_remove (i); - break; - } - - sym->mark = 0; - sym->gfc_new = 0; - - free_old_symbol (sym); -} - - -/* Recursively free trees containing type-bound procedures. */ - -static void -free_tb_tree (gfc_symtree *t) -{ - if (t == NULL) - return; - - free_tb_tree (t->left); - free_tb_tree (t->right); - - /* TODO: Free type-bound procedure u.generic */ - free (t->n.tb); - t->n.tb = NULL; - free (t); -} - - -/* Recursive function that deletes an entire tree and all the common - head structures it points to. */ - -static void -free_common_tree (gfc_symtree * common_tree) -{ - if (common_tree == NULL) - return; - - free_common_tree (common_tree->left); - free_common_tree (common_tree->right); - - free (common_tree); -} - - -/* Recursive function that deletes an entire tree and all the common - head structures it points to. */ - -static void -free_omp_udr_tree (gfc_symtree * omp_udr_tree) -{ - if (omp_udr_tree == NULL) - return; - - free_omp_udr_tree (omp_udr_tree->left); - free_omp_udr_tree (omp_udr_tree->right); - - gfc_free_omp_udr (omp_udr_tree->n.omp_udr); - free (omp_udr_tree); -} - - -/* Recursive function that deletes an entire tree and all the user - operator nodes that it contains. */ - -static void -free_uop_tree (gfc_symtree *uop_tree) -{ - if (uop_tree == NULL) - return; - - free_uop_tree (uop_tree->left); - free_uop_tree (uop_tree->right); - - gfc_free_interface (uop_tree->n.uop->op); - free (uop_tree->n.uop); - free (uop_tree); -} - - -/* Recursive function that deletes an entire tree and all the symbols - that it contains. */ - -static void -free_sym_tree (gfc_symtree *sym_tree) -{ - if (sym_tree == NULL) - return; - - free_sym_tree (sym_tree->left); - free_sym_tree (sym_tree->right); - - gfc_release_symbol (sym_tree->n.sym); - free (sym_tree); -} - - -/* Free the gfc_equiv_info's. */ - -static void -gfc_free_equiv_infos (gfc_equiv_info *s) -{ - if (s == NULL) - return; - gfc_free_equiv_infos (s->next); - free (s); -} - - -/* Free the gfc_equiv_lists. */ - -static void -gfc_free_equiv_lists (gfc_equiv_list *l) -{ - if (l == NULL) - return; - gfc_free_equiv_lists (l->next); - gfc_free_equiv_infos (l->equiv); - free (l); -} - - -/* Free a finalizer procedure list. */ - -void -gfc_free_finalizer (gfc_finalizer* el) -{ - if (el) - { - gfc_release_symbol (el->proc_sym); - free (el); - } -} - -static void -gfc_free_finalizer_list (gfc_finalizer* list) -{ - while (list) - { - gfc_finalizer* current = list; - list = list->next; - gfc_free_finalizer (current); - } -} - - -/* Create a new gfc_charlen structure and add it to a namespace. - If 'old_cl' is given, the newly created charlen will be a copy of it. */ - -gfc_charlen* -gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl) -{ - gfc_charlen *cl; - - cl = gfc_get_charlen (); - - /* Copy old_cl. */ - if (old_cl) - { - cl->length = gfc_copy_expr (old_cl->length); - cl->length_from_typespec = old_cl->length_from_typespec; - cl->backend_decl = old_cl->backend_decl; - cl->passed_length = old_cl->passed_length; - cl->resolved = old_cl->resolved; - } - - /* Put into namespace. */ - cl->next = ns->cl_list; - ns->cl_list = cl; - - return cl; -} - - -/* Free the charlen list from cl to end (end is not freed). - Free the whole list if end is NULL. */ - -static void -gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end) -{ - gfc_charlen *cl2; - - for (; cl != end; cl = cl2) - { - gcc_assert (cl); - - cl2 = cl->next; - gfc_free_expr (cl->length); - free (cl); - } -} - - -/* Free entry list structs. */ - -static void -free_entry_list (gfc_entry_list *el) -{ - gfc_entry_list *next; - - if (el == NULL) - return; - - next = el->next; - free (el); - free_entry_list (next); -} - - -/* Free a namespace structure and everything below it. Interface - lists associated with intrinsic operators are not freed. These are - taken care of when a specific name is freed. */ - -void -gfc_free_namespace (gfc_namespace *&ns) -{ - gfc_namespace *p, *q; - int i; - gfc_was_finalized *f; - - if (ns == NULL) - return; - - ns->refs--; - if (ns->refs > 0) - return; - - gcc_assert (ns->refs == 0); - - gfc_free_statements (ns->code); - - free_sym_tree (ns->sym_root); - free_uop_tree (ns->uop_root); - free_common_tree (ns->common_root); - free_omp_udr_tree (ns->omp_udr_root); - free_tb_tree (ns->tb_sym_root); - free_tb_tree (ns->tb_uop_root); - gfc_free_finalizer_list (ns->finalizers); - gfc_free_omp_declare_simd_list (ns->omp_declare_simd); - gfc_free_omp_declare_variant_list (ns->omp_declare_variant); - gfc_free_charlen (ns->cl_list, NULL); - free_st_labels (ns->st_labels); - - free_entry_list (ns->entries); - gfc_free_equiv (ns->equiv); - gfc_free_equiv_lists (ns->equiv_lists); - gfc_free_use_stmts (ns->use_stmts); - - for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) - gfc_free_interface (ns->op[i]); - - gfc_free_data (ns->data); - - /* Free all the expr + component combinations that have been - finalized. */ - f = ns->was_finalized; - while (f) - { - gfc_was_finalized* current = f; - f = f->next; - free (current); - } - - p = ns->contained; - free (ns); - ns = NULL; - - /* Recursively free any contained namespaces. */ - while (p != NULL) - { - q = p; - p = p->sibling; - gfc_free_namespace (q); - } -} - - -void -gfc_symbol_init_2 (void) -{ - - gfc_current_ns = gfc_get_namespace (NULL, 0); -} - - -void -gfc_symbol_done_2 (void) -{ - if (gfc_current_ns != NULL) - { - /* free everything from the root. */ - while (gfc_current_ns->parent != NULL) - gfc_current_ns = gfc_current_ns->parent; - gfc_free_namespace (gfc_current_ns); - gfc_current_ns = NULL; - } - gfc_derived_types = NULL; - - enforce_single_undo_checkpoint (); - free_undo_change_set_data (*latest_undo_chgset); -} - - -/* Count how many nodes a symtree has. */ - -static unsigned -count_st_nodes (const gfc_symtree *st) -{ - unsigned nodes; - if (!st) - return 0; - - nodes = count_st_nodes (st->left); - nodes++; - nodes += count_st_nodes (st->right); - - return nodes; -} - - -/* Convert symtree tree into symtree vector. */ - -static unsigned -fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr) -{ - if (!st) - return node_cntr; - - node_cntr = fill_st_vector (st->left, st_vec, node_cntr); - st_vec[node_cntr++] = st; - node_cntr = fill_st_vector (st->right, st_vec, node_cntr); - - return node_cntr; -} - - -/* Traverse namespace. As the functions might modify the symtree, we store the - symtree as a vector and operate on this vector. Note: We assume that - sym_func or st_func never deletes nodes from the symtree - only adding is - allowed. Additionally, newly added nodes are not traversed. */ - -static void -do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *), - void (*sym_func) (gfc_symbol *)) -{ - gfc_symtree **st_vec; - unsigned nodes, i, node_cntr; - - gcc_assert ((st_func && !sym_func) || (!st_func && sym_func)); - nodes = count_st_nodes (st); - st_vec = XALLOCAVEC (gfc_symtree *, nodes); - node_cntr = 0; - fill_st_vector (st, st_vec, node_cntr); - - if (sym_func) - { - /* Clear marks. */ - for (i = 0; i < nodes; i++) - st_vec[i]->n.sym->mark = 0; - for (i = 0; i < nodes; i++) - if (!st_vec[i]->n.sym->mark) - { - (*sym_func) (st_vec[i]->n.sym); - st_vec[i]->n.sym->mark = 1; - } - } - else - for (i = 0; i < nodes; i++) - (*st_func) (st_vec[i]); -} - - -/* Recursively traverse the symtree nodes. */ - -void -gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *)) -{ - do_traverse_symtree (st, st_func, NULL); -} - - -/* Call a given function for all symbols in the namespace. We take - care that each gfc_symbol node is called exactly once. */ - -void -gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *)) -{ - do_traverse_symtree (ns->sym_root, NULL, sym_func); -} - - -/* Return TRUE when name is the name of an intrinsic type. */ - -bool -gfc_is_intrinsic_typename (const char *name) -{ - if (strcmp (name, "integer") == 0 - || strcmp (name, "real") == 0 - || strcmp (name, "character") == 0 - || strcmp (name, "logical") == 0 - || strcmp (name, "complex") == 0 - || strcmp (name, "doubleprecision") == 0 - || strcmp (name, "doublecomplex") == 0) - return true; - else - return false; -} - - -/* Return TRUE if the symbol is an automatic variable. */ - -static bool -gfc_is_var_automatic (gfc_symbol *sym) -{ - /* Pointer and allocatable variables are never automatic. */ - if (sym->attr.pointer || sym->attr.allocatable) - return false; - /* Check for arrays with non-constant size. */ - if (sym->attr.dimension && sym->as - && !gfc_is_compile_time_shape (sym->as)) - return true; - /* Check for non-constant length character variables. */ - if (sym->ts.type == BT_CHARACTER - && sym->ts.u.cl - && !gfc_is_constant_expr (sym->ts.u.cl->length)) - return true; - /* Variables with explicit AUTOMATIC attribute. */ - if (sym->attr.automatic) - return true; - - return false; -} - -/* Given a symbol, mark it as SAVEd if it is allowed. */ - -static void -save_symbol (gfc_symbol *sym) -{ - - if (sym->attr.use_assoc) - return; - - if (sym->attr.in_common - || sym->attr.in_equivalence - || sym->attr.dummy - || sym->attr.result - || sym->attr.flavor != FL_VARIABLE) - return; - /* Automatic objects are not saved. */ - if (gfc_is_var_automatic (sym)) - return; - gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at); -} - - -/* Mark those symbols which can be SAVEd as such. */ - -void -gfc_save_all (gfc_namespace *ns) -{ - gfc_traverse_ns (ns, save_symbol); -} - - -/* Make sure that no changes to symbols are pending. */ - -void -gfc_enforce_clean_symbol_state(void) -{ - enforce_single_undo_checkpoint (); - gcc_assert (latest_undo_chgset->syms.is_empty ()); -} - - -/************** Global symbol handling ************/ - - -/* Search a tree for the global symbol. */ - -gfc_gsymbol * -gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) -{ - int c; - - if (symbol == NULL) - return NULL; - - while (symbol) - { - c = strcmp (name, symbol->name); - if (!c) - return symbol; - - symbol = (c < 0) ? symbol->left : symbol->right; - } - - return NULL; -} - - -/* Case insensitive search a tree for the global symbol. */ - -gfc_gsymbol * -gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name) -{ - int c; - - if (symbol == NULL) - return NULL; - - while (symbol) - { - c = strcasecmp (name, symbol->name); - if (!c) - return symbol; - - symbol = (c < 0) ? symbol->left : symbol->right; - } - - return NULL; -} - - -/* Compare two global symbols. Used for managing the BB tree. */ - -static int -gsym_compare (void *_s1, void *_s2) -{ - gfc_gsymbol *s1, *s2; - - s1 = (gfc_gsymbol *) _s1; - s2 = (gfc_gsymbol *) _s2; - return strcmp (s1->name, s2->name); -} - - -/* Get a global symbol, creating it if it doesn't exist. */ - -gfc_gsymbol * -gfc_get_gsymbol (const char *name, bool bind_c) -{ - gfc_gsymbol *s; - - s = gfc_find_gsymbol (gfc_gsym_root, name); - if (s != NULL) - return s; - - s = XCNEW (gfc_gsymbol); - s->type = GSYM_UNKNOWN; - s->name = gfc_get_string ("%s", name); - s->bind_c = bind_c; - - gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare); - - return s; -} - -void -gfc_traverse_gsymbol (gfc_gsymbol *gsym, - void (*do_something) (gfc_gsymbol *, void *), - void *data) -{ - if (gsym->left) - gfc_traverse_gsymbol (gsym->left, do_something, data); - - (*do_something) (gsym, data); - - if (gsym->right) - gfc_traverse_gsymbol (gsym->right, do_something, data); -} - -static gfc_symbol * -get_iso_c_binding_dt (int sym_id) -{ - gfc_symbol *dt_list = gfc_derived_types; - - /* Loop through the derived types in the name list, searching for - the desired symbol from iso_c_binding. Search the parent namespaces - if necessary and requested to (parent_flag). */ - if (dt_list) - { - while (dt_list->dt_next != gfc_derived_types) - { - if (dt_list->from_intmod != INTMOD_NONE - && dt_list->intmod_sym_id == sym_id) - return dt_list; - - dt_list = dt_list->dt_next; - } - } - - return NULL; -} - - -/* Verifies that the given derived type symbol, derived_sym, is interoperable - with C. This is necessary for any derived type that is BIND(C) and for - derived types that are parameters to functions that are BIND(C). All - fields of the derived type are required to be interoperable, and are tested - for such. If an error occurs, the errors are reported here, allowing for - multiple errors to be handled for a single derived type. */ - -bool -verify_bind_c_derived_type (gfc_symbol *derived_sym) -{ - gfc_component *curr_comp = NULL; - bool is_c_interop = false; - bool retval = true; - - if (derived_sym == NULL) - gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is " - "unexpectedly NULL"); - - /* If we've already looked at this derived symbol, do not look at it again - so we don't repeat warnings/errors. */ - if (derived_sym->ts.is_c_interop) - return true; - - /* The derived type must have the BIND attribute to be interoperable - J3/04-007, Section 15.2.3. */ - if (derived_sym->attr.is_bind_c != 1) - { - derived_sym->ts.is_c_interop = 0; - gfc_error_now ("Derived type %qs declared at %L must have the BIND " - "attribute to be C interoperable", derived_sym->name, - &(derived_sym->declared_at)); - retval = false; - } - - curr_comp = derived_sym->components; - - /* Fortran 2003 allows an empty derived type. C99 appears to disallow an - empty struct. Section 15.2 in Fortran 2003 states: "The following - subclauses define the conditions under which a Fortran entity is - interoperable. If a Fortran entity is interoperable, an equivalent - entity may be defined by means of C and the Fortran entity is said - to be interoperable with the C entity. There does not have to be such - an interoperating C entity." - */ - if (curr_comp == NULL) - { - gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, " - "and may be inaccessible by the C companion processor", - derived_sym->name, &(derived_sym->declared_at)); - derived_sym->ts.is_c_interop = 1; - derived_sym->attr.is_bind_c = 1; - return true; - } - - - /* Initialize the derived type as being C interoperable. - If we find an error in the components, this will be set false. */ - derived_sym->ts.is_c_interop = 1; - - /* Loop through the list of components to verify that the kind of - each is a C interoperable type. */ - do - { - /* The components cannot be pointers (fortran sense). - J3/04-007, Section 15.2.3, C1505. */ - if (curr_comp->attr.pointer != 0) - { - gfc_error ("Component %qs at %L cannot have the " - "POINTER attribute because it is a member " - "of the BIND(C) derived type %qs at %L", - curr_comp->name, &(curr_comp->loc), - derived_sym->name, &(derived_sym->declared_at)); - retval = false; - } - - if (curr_comp->attr.proc_pointer != 0) - { - gfc_error ("Procedure pointer component %qs at %L cannot be a member" - " of the BIND(C) derived type %qs at %L", curr_comp->name, - &curr_comp->loc, derived_sym->name, - &derived_sym->declared_at); - retval = false; - } - - /* The components cannot be allocatable. - J3/04-007, Section 15.2.3, C1505. */ - if (curr_comp->attr.allocatable != 0) - { - gfc_error ("Component %qs at %L cannot have the " - "ALLOCATABLE attribute because it is a member " - "of the BIND(C) derived type %qs at %L", - curr_comp->name, &(curr_comp->loc), - derived_sym->name, &(derived_sym->declared_at)); - retval = false; - } - - /* BIND(C) derived types must have interoperable components. */ - if (curr_comp->ts.type == BT_DERIVED - && curr_comp->ts.u.derived->ts.is_iso_c != 1 - && curr_comp->ts.u.derived != derived_sym) - { - /* This should be allowed; the draft says a derived-type cannot - have type parameters if it is has the BIND attribute. Type - parameters seem to be for making parameterized derived types. - There's no need to verify the type if it is c_ptr/c_funptr. */ - retval = verify_bind_c_derived_type (curr_comp->ts.u.derived); - } - else - { - /* Grab the typespec for the given component and test the kind. */ - is_c_interop = gfc_verify_c_interop (&(curr_comp->ts)); - - if (!is_c_interop) - { - /* Report warning and continue since not fatal. The - draft does specify a constraint that requires all fields - to interoperate, but if the user says real(4), etc., it - may interoperate with *something* in C, but the compiler - most likely won't know exactly what. Further, it may not - interoperate with the same data type(s) in C if the user - recompiles with different flags (e.g., -m32 and -m64 on - x86_64 and using integer(4) to claim interop with a - C_LONG). */ - if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type) - /* If the derived type is bind(c), all fields must be - interop. */ - gfc_warning (OPT_Wc_binding_type, - "Component %qs in derived type %qs at %L " - "may not be C interoperable, even though " - "derived type %qs is BIND(C)", - curr_comp->name, derived_sym->name, - &(curr_comp->loc), derived_sym->name); - else if (warn_c_binding_type) - /* If derived type is param to bind(c) routine, or to one - of the iso_c_binding procs, it must be interoperable, so - all fields must interop too. */ - gfc_warning (OPT_Wc_binding_type, - "Component %qs in derived type %qs at %L " - "may not be C interoperable", - curr_comp->name, derived_sym->name, - &(curr_comp->loc)); - } - } - - curr_comp = curr_comp->next; - } while (curr_comp != NULL); - - if (derived_sym->attr.sequence != 0) - { - gfc_error ("Derived type %qs at %L cannot have the SEQUENCE " - "attribute because it is BIND(C)", derived_sym->name, - &(derived_sym->declared_at)); - retval = false; - } - - /* Mark the derived type as not being C interoperable if we found an - error. If there were only warnings, proceed with the assumption - it's interoperable. */ - if (!retval) - derived_sym->ts.is_c_interop = 0; - - return retval; -} - - -/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */ - -static bool -gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree) -{ - gfc_constructor *c; - - gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym); - dt_symtree->n.sym->attr.referenced = 1; - - tmp_sym->attr.is_c_interop = 1; - tmp_sym->attr.is_bind_c = 1; - tmp_sym->ts.is_c_interop = 1; - tmp_sym->ts.is_iso_c = 1; - tmp_sym->ts.type = BT_DERIVED; - tmp_sym->ts.f90_type = BT_VOID; - tmp_sym->attr.flavor = FL_PARAMETER; - tmp_sym->ts.u.derived = dt_symtree->n.sym; - - /* Set the c_address field of c_null_ptr and c_null_funptr to - the value of NULL. */ - tmp_sym->value = gfc_get_expr (); - tmp_sym->value->expr_type = EXPR_STRUCTURE; - tmp_sym->value->ts.type = BT_DERIVED; - tmp_sym->value->ts.f90_type = BT_VOID; - tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; - gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL); - c = gfc_constructor_first (tmp_sym->value->value.constructor); - c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - c->expr->ts.is_iso_c = 1; - - return true; -} - - -/* Add a formal argument, gfc_formal_arglist, to the - end of the given list of arguments. Set the reference to the - provided symbol, param_sym, in the argument. */ - -static void -add_formal_arg (gfc_formal_arglist **head, - gfc_formal_arglist **tail, - gfc_formal_arglist *formal_arg, - gfc_symbol *param_sym) -{ - /* Put in list, either as first arg or at the tail (curr arg). */ - if (*head == NULL) - *head = *tail = formal_arg; - else - { - (*tail)->next = formal_arg; - (*tail) = formal_arg; - } - - (*tail)->sym = param_sym; - (*tail)->next = NULL; - - return; -} - - -/* Add a procedure interface to the given symbol (i.e., store a - reference to the list of formal arguments). */ - -static void -add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal) -{ - - sym->formal = formal; - sym->attr.if_source = source; -} - - -/* Copy the formal args from an existing symbol, src, into a new - symbol, dest. New formal args are created, and the description of - each arg is set according to the existing ones. This function is - used when creating procedure declaration variables from a procedure - declaration statement (see match_proc_decl()) to create the formal - args based on the args of a given named interface. - - When an actual argument list is provided, skip the absent arguments - unless copy_type is true. - To be used together with gfc_se->ignore_optional. */ - -void -gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src, - gfc_actual_arglist *actual, bool copy_type) -{ - gfc_formal_arglist *head = NULL; - gfc_formal_arglist *tail = NULL; - gfc_formal_arglist *formal_arg = NULL; - gfc_intrinsic_arg *curr_arg = NULL; - gfc_formal_arglist *formal_prev = NULL; - gfc_actual_arglist *act_arg = actual; - /* Save current namespace so we can change it for formal args. */ - gfc_namespace *parent_ns = gfc_current_ns; - - /* Create a new namespace, which will be the formal ns (namespace - of the formal args). */ - gfc_current_ns = gfc_get_namespace (parent_ns, 0); - gfc_current_ns->proc_name = dest; - - for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) - { - /* Skip absent arguments. */ - if (actual) - { - gcc_assert (act_arg != NULL); - if (act_arg->expr == NULL) - { - act_arg = act_arg->next; - continue; - } - } - formal_arg = gfc_get_formal_arglist (); - gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym)); - - /* May need to copy more info for the symbol. */ - if (copy_type && act_arg->expr != NULL) - { - formal_arg->sym->ts = act_arg->expr->ts; - if (act_arg->expr->rank > 0) - { - formal_arg->sym->attr.dimension = 1; - formal_arg->sym->as = gfc_get_array_spec(); - formal_arg->sym->as->rank = -1; - formal_arg->sym->as->type = AS_ASSUMED_RANK; - } - if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0) - formal_arg->sym->pass_as_value = 1; - } - else - formal_arg->sym->ts = curr_arg->ts; - - formal_arg->sym->attr.optional = curr_arg->optional; - formal_arg->sym->attr.value = curr_arg->value; - formal_arg->sym->attr.intent = curr_arg->intent; - formal_arg->sym->attr.flavor = FL_VARIABLE; - formal_arg->sym->attr.dummy = 1; - - if (formal_arg->sym->ts.type == BT_CHARACTER) - formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - - /* If this isn't the first arg, set up the next ptr. For the - last arg built, the formal_arg->next will never get set to - anything other than NULL. */ - if (formal_prev != NULL) - formal_prev->next = formal_arg; - else - formal_arg->next = NULL; - - formal_prev = formal_arg; - - /* Add arg to list of formal args. */ - add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); - - /* Validate changes. */ - gfc_commit_symbol (formal_arg->sym); - if (actual) - act_arg = act_arg->next; - } - - /* Add the interface to the symbol. */ - add_proc_interface (dest, IFSRC_DECL, head); - - /* Store the formal namespace information. */ - if (dest->formal != NULL) - /* The current ns should be that for the dest proc. */ - dest->formal_ns = gfc_current_ns; - /* Restore the current namespace to what it was on entry. */ - gfc_current_ns = parent_ns; -} - - -static int -std_for_isocbinding_symbol (int id) -{ - switch (id) - { -#define NAMED_INTCST(a,b,c,d) \ - case a:\ - return d; -#include "iso-c-binding.def" -#undef NAMED_INTCST - -#define NAMED_FUNCTION(a,b,c,d) \ - case a:\ - return d; -#define NAMED_SUBROUTINE(a,b,c,d) \ - case a:\ - return d; -#include "iso-c-binding.def" -#undef NAMED_FUNCTION -#undef NAMED_SUBROUTINE - - default: - return GFC_STD_F2003; - } -} - -/* Generate the given set of C interoperable kind objects, or all - interoperable kinds. This function will only be given kind objects - for valid iso_c_binding defined types because this is verified when - the 'use' statement is parsed. If the user gives an 'only' clause, - the specific kinds are looked up; if they don't exist, an error is - reported. If the user does not give an 'only' clause, all - iso_c_binding symbols are generated. If a list of specific kinds - is given, it must have a NULL in the first empty spot to mark the - end of the list. For C_null_(fun)ptr, dt_symtree has to be set and - point to the symtree for c_(fun)ptr. */ - -gfc_symtree * -generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, - const char *local_name, gfc_symtree *dt_symtree, - bool hidden) -{ - const char *const name = (local_name && local_name[0]) - ? local_name : c_interop_kinds_table[s].name; - gfc_symtree *tmp_symtree; - gfc_symbol *tmp_sym = NULL; - int index; - - if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR) - return NULL; - - tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); - if (hidden - && (!tmp_symtree || !tmp_symtree->n.sym - || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING - || tmp_symtree->n.sym->intmod_sym_id != s)) - tmp_symtree = NULL; - - /* Already exists in this scope so don't re-add it. */ - if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL - && (!tmp_sym->attr.generic - || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL) - && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING) - { - if (tmp_sym->attr.flavor == FL_DERIVED - && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id)) - { - if (gfc_derived_types) - { - tmp_sym->dt_next = gfc_derived_types->dt_next; - gfc_derived_types->dt_next = tmp_sym; - } - else - { - tmp_sym->dt_next = tmp_sym; - } - gfc_derived_types = tmp_sym; - } - - return tmp_symtree; - } - - /* Create the sym tree in the current ns. */ - if (hidden) - { - tmp_symtree = gfc_get_unique_symtree (gfc_current_ns); - tmp_sym = gfc_new_symbol (name, gfc_current_ns); - - /* Add to the list of tentative symbols. */ - latest_undo_chgset->syms.safe_push (tmp_sym); - tmp_sym->old_symbol = NULL; - tmp_sym->mark = 1; - tmp_sym->gfc_new = 1; - - tmp_symtree->n.sym = tmp_sym; - tmp_sym->refs++; - } - else - { - gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); - gcc_assert (tmp_symtree); - tmp_sym = tmp_symtree->n.sym; - } - - /* Say what module this symbol belongs to. */ - tmp_sym->module = gfc_get_string ("%s", mod_name); - tmp_sym->from_intmod = INTMOD_ISO_C_BINDING; - tmp_sym->intmod_sym_id = s; - tmp_sym->attr.is_iso_c = 1; - tmp_sym->attr.use_assoc = 1; - - gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR - || s == ISOCBINDING_NULL_PTR); - - switch (s) - { - -#define NAMED_INTCST(a,b,c,d) case a : -#define NAMED_REALCST(a,b,c,d) case a : -#define NAMED_CMPXCST(a,b,c,d) case a : -#define NAMED_LOGCST(a,b,c) case a : -#define NAMED_CHARKNDCST(a,b,c) case a : -#include "iso-c-binding.def" - - tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, - c_interop_kinds_table[s].value); - - /* Initialize an integer constant expression node. */ - tmp_sym->attr.flavor = FL_PARAMETER; - tmp_sym->ts.type = BT_INTEGER; - tmp_sym->ts.kind = gfc_default_integer_kind; - - /* Mark this type as a C interoperable one. */ - tmp_sym->ts.is_c_interop = 1; - tmp_sym->ts.is_iso_c = 1; - tmp_sym->value->ts.is_c_interop = 1; - tmp_sym->value->ts.is_iso_c = 1; - tmp_sym->attr.is_c_interop = 1; - - /* Tell what f90 type this c interop kind is valid. */ - tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type; - - break; - - -#define NAMED_CHARCST(a,b,c) case a : -#include "iso-c-binding.def" - - /* Initialize an integer constant expression node for the - length of the character. */ - tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind, - &gfc_current_locus, NULL, 1); - tmp_sym->value->ts.is_c_interop = 1; - tmp_sym->value->ts.is_iso_c = 1; - tmp_sym->value->value.character.length = 1; - tmp_sym->value->value.character.string[0] - = (gfc_char_t) c_interop_kinds_table[s].value; - tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, - NULL, 1); - - /* May not need this in both attr and ts, but do need in - attr for writing module file. */ - tmp_sym->attr.is_c_interop = 1; - - tmp_sym->attr.flavor = FL_PARAMETER; - tmp_sym->ts.type = BT_CHARACTER; - - /* Need to set it to the C_CHAR kind. */ - tmp_sym->ts.kind = gfc_default_character_kind; - - /* Mark this type as a C interoperable one. */ - tmp_sym->ts.is_c_interop = 1; - tmp_sym->ts.is_iso_c = 1; - - /* Tell what f90 type this c interop kind is valid. */ - tmp_sym->ts.f90_type = BT_CHARACTER; - - break; - - case ISOCBINDING_PTR: - case ISOCBINDING_FUNPTR: - { - gfc_symbol *dt_sym; - gfc_component *tmp_comp = NULL; - - /* Generate real derived type. */ - if (hidden) - dt_sym = tmp_sym; - else - { - const char *hidden_name; - gfc_interface *intr, *head; - - hidden_name = gfc_dt_upper_string (tmp_sym->name); - tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, - hidden_name); - gcc_assert (tmp_symtree == NULL); - gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false); - dt_sym = tmp_symtree->n.sym; - dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR - ? "c_ptr" : "c_funptr"); - - /* Generate an artificial generic function. */ - head = tmp_sym->generic; - intr = gfc_get_interface (); - intr->sym = dt_sym; - intr->where = gfc_current_locus; - intr->next = head; - tmp_sym->generic = intr; - - if (!tmp_sym->attr.generic - && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)) - return NULL; - - if (!tmp_sym->attr.function - && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)) - return NULL; - } - - /* Say what module this symbol belongs to. */ - dt_sym->module = gfc_get_string ("%s", mod_name); - dt_sym->from_intmod = INTMOD_ISO_C_BINDING; - dt_sym->intmod_sym_id = s; - dt_sym->attr.use_assoc = 1; - - /* Initialize an integer constant expression node. */ - dt_sym->attr.flavor = FL_DERIVED; - dt_sym->ts.is_c_interop = 1; - dt_sym->attr.is_c_interop = 1; - dt_sym->attr.private_comp = 1; - dt_sym->component_access = ACCESS_PRIVATE; - dt_sym->ts.is_iso_c = 1; - dt_sym->ts.type = BT_DERIVED; - dt_sym->ts.f90_type = BT_VOID; - - /* A derived type must have the bind attribute to be - interoperable (J3/04-007, Section 15.2.3), even though - the binding label is not used. */ - dt_sym->attr.is_bind_c = 1; - - dt_sym->attr.referenced = 1; - dt_sym->ts.u.derived = dt_sym; - - /* Add the symbol created for the derived type to the current ns. */ - if (gfc_derived_types) - { - dt_sym->dt_next = gfc_derived_types->dt_next; - gfc_derived_types->dt_next = dt_sym; - } - else - { - dt_sym->dt_next = dt_sym; - } - gfc_derived_types = dt_sym; - - gfc_add_component (dt_sym, "c_address", &tmp_comp); - if (tmp_comp == NULL) - gcc_unreachable (); - - tmp_comp->ts.type = BT_INTEGER; - - /* Set this because the module will need to read/write this field. */ - tmp_comp->ts.f90_type = BT_INTEGER; - - /* The kinds for c_ptr and c_funptr are the same. */ - index = get_c_kind ("c_ptr", c_interop_kinds_table); - tmp_comp->ts.kind = c_interop_kinds_table[index].value; - tmp_comp->attr.access = ACCESS_PRIVATE; - - /* Mark the component as C interoperable. */ - tmp_comp->ts.is_c_interop = 1; - } - - break; - - case ISOCBINDING_NULL_PTR: - case ISOCBINDING_NULL_FUNPTR: - gen_special_c_interop_ptr (tmp_sym, dt_symtree); - break; - - default: - gcc_unreachable (); - } - gfc_commit_symbol (tmp_sym); - return tmp_symtree; -} - - -/* Check that a symbol is already typed. If strict is not set, an untyped - symbol is acceptable for non-standard-conforming mode. */ - -bool -gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, - bool strict, locus where) -{ - gcc_assert (sym); - - if (gfc_matching_prefix) - return true; - - /* Check for the type and try to give it an implicit one. */ - if (sym->ts.type == BT_UNKNOWN - && !gfc_set_default_type (sym, 0, ns)) - { - if (strict) - { - gfc_error ("Symbol %qs is used before it is typed at %L", - sym->name, &where); - return false; - } - - if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before" - " it is typed at %L", sym->name, &where)) - return false; - } - - /* Everything is ok. */ - return true; -} - - -/* Construct a typebound-procedure structure. Those are stored in a tentative - list and marked `error' until symbols are committed. */ - -gfc_typebound_proc* -gfc_get_typebound_proc (gfc_typebound_proc *tb0) -{ - gfc_typebound_proc *result; - - result = XCNEW (gfc_typebound_proc); - if (tb0) - *result = *tb0; - result->error = 1; - - latest_undo_chgset->tbps.safe_push (result); - - return result; -} - - -/* Get the super-type of a given derived type. */ - -gfc_symbol* -gfc_get_derived_super_type (gfc_symbol* derived) -{ - gcc_assert (derived); - - if (derived->attr.generic) - derived = gfc_find_dt_in_generic (derived); - - if (!derived->attr.extension) - return NULL; - - gcc_assert (derived->components); - gcc_assert (derived->components->ts.type == BT_DERIVED); - gcc_assert (derived->components->ts.u.derived); - - if (derived->components->ts.u.derived->attr.generic) - return gfc_find_dt_in_generic (derived->components->ts.u.derived); - - return derived->components->ts.u.derived; -} - - -/* Check if a derived type t2 is an extension of (or equal to) a type t1. */ - -bool -gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) -{ - while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension) - t2 = gfc_get_derived_super_type (t2); - return gfc_compare_derived_types (t1, t2); -} - - -/* Check if two typespecs are type compatible (F03:5.1.1.2): - If ts1 is nonpolymorphic, ts2 must be the same type. - If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */ - -bool -gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) -{ - bool is_class1 = (ts1->type == BT_CLASS); - bool is_class2 = (ts2->type == BT_CLASS); - bool is_derived1 = (ts1->type == BT_DERIVED); - bool is_derived2 = (ts2->type == BT_DERIVED); - bool is_union1 = (ts1->type == BT_UNION); - bool is_union2 = (ts2->type == BT_UNION); - - if (is_class1 - && ts1->u.derived->components - && ((ts1->u.derived->attr.is_class - && ts1->u.derived->components->ts.u.derived->attr - .unlimited_polymorphic) - || ts1->u.derived->attr.unlimited_polymorphic)) - return 1; - - if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2 - && !is_union1 && !is_union2) - return (ts1->type == ts2->type); - - if ((is_derived1 && is_derived2) || (is_union1 && is_union2)) - return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); - - if (is_derived1 && is_class2) - return gfc_compare_derived_types (ts1->u.derived, - ts2->u.derived->attr.is_class ? - ts2->u.derived->components->ts.u.derived - : ts2->u.derived); - if (is_class1 && is_derived2) - return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? - ts1->u.derived->components->ts.u.derived - : ts1->u.derived, - ts2->u.derived); - else if (is_class1 && is_class2) - return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? - ts1->u.derived->components->ts.u.derived - : ts1->u.derived, - ts2->u.derived->attr.is_class ? - ts2->u.derived->components->ts.u.derived - : ts2->u.derived); - else - return 0; -} - - -/* Find the parent-namespace of the current function. If we're inside - BLOCK constructs, it may not be the current one. */ - -gfc_namespace* -gfc_find_proc_namespace (gfc_namespace* ns) -{ - while (ns->construct_entities) - { - ns = ns->parent; - gcc_assert (ns); - } - - return ns; -} - - -/* Check if an associate-variable should be translated as an `implicit' pointer - internally (if it is associated to a variable and not an array with - descriptor). */ - -bool -gfc_is_associate_pointer (gfc_symbol* sym) -{ - if (!sym->assoc) - return false; - - if (sym->ts.type == BT_CLASS) - return true; - - if (sym->ts.type == BT_CHARACTER - && sym->ts.deferred - && sym->assoc->target - && sym->assoc->target->expr_type == EXPR_FUNCTION) - return true; - - if (!sym->assoc->variable) - return false; - - if (sym->attr.dimension && sym->as->type != AS_EXPLICIT) - return false; - - return true; -} - - -gfc_symbol * -gfc_find_dt_in_generic (gfc_symbol *sym) -{ - gfc_interface *intr = NULL; - - if (!sym || gfc_fl_struct (sym->attr.flavor)) - return sym; - - if (sym->attr.generic) - for (intr = sym->generic; intr; intr = intr->next) - if (gfc_fl_struct (intr->sym->attr.flavor)) - break; - return intr ? intr->sym : NULL; -} - - -/* Get the dummy arguments from a procedure symbol. If it has been declared - via a PROCEDURE statement with a named interface, ts.interface will be set - and the arguments need to be taken from there. */ - -gfc_formal_arglist * -gfc_sym_get_dummy_args (gfc_symbol *sym) -{ - gfc_formal_arglist *dummies; - - if (sym == NULL) - return NULL; - - dummies = sym->formal; - if (dummies == NULL && sym->ts.interface != NULL) - dummies = sym->ts.interface->formal; - - return dummies; -} diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc new file mode 100644 index 0000000..1a4b022 --- /dev/null +++ b/gcc/fortran/symbol.cc @@ -0,0 +1,5251 @@ +/* Maintain binary trees of symbols. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "gfortran.h" +#include "parse.h" +#include "match.h" +#include "constructor.h" + + +/* Strings for all symbol attributes. We use these for dumping the + parse tree, in error messages, and also when reading and writing + modules. */ + +const mstring flavors[] = +{ + minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM), + minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE), + minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), + minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), + minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), + minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT), + minit (NULL, -1) +}; + +const mstring procedures[] = +{ + minit ("UNKNOWN-PROC", PROC_UNKNOWN), + minit ("MODULE-PROC", PROC_MODULE), + minit ("INTERNAL-PROC", PROC_INTERNAL), + minit ("DUMMY-PROC", PROC_DUMMY), + minit ("INTRINSIC-PROC", PROC_INTRINSIC), + minit ("EXTERNAL-PROC", PROC_EXTERNAL), + minit ("STATEMENT-PROC", PROC_ST_FUNCTION), + minit (NULL, -1) +}; + +const mstring intents[] = +{ + minit ("UNKNOWN-INTENT", INTENT_UNKNOWN), + minit ("IN", INTENT_IN), + minit ("OUT", INTENT_OUT), + minit ("INOUT", INTENT_INOUT), + minit (NULL, -1) +}; + +const mstring access_types[] = +{ + minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN), + minit ("PUBLIC", ACCESS_PUBLIC), + minit ("PRIVATE", ACCESS_PRIVATE), + minit (NULL, -1) +}; + +const mstring ifsrc_types[] = +{ + minit ("UNKNOWN", IFSRC_UNKNOWN), + minit ("DECL", IFSRC_DECL), + minit ("BODY", IFSRC_IFBODY) +}; + +const mstring save_status[] = +{ + minit ("UNKNOWN", SAVE_NONE), + minit ("EXPLICIT-SAVE", SAVE_EXPLICIT), + minit ("IMPLICIT-SAVE", SAVE_IMPLICIT), +}; + +/* Set the mstrings for DTIO procedure names. */ +const mstring dtio_procs[] = +{ + minit ("_dtio_formatted_read", DTIO_RF), + minit ("_dtio_formatted_write", DTIO_WF), + minit ("_dtio_unformatted_read", DTIO_RUF), + minit ("_dtio_unformatted_write", DTIO_WUF), +}; + +/* This is to make sure the backend generates setup code in the correct + order. */ + +static int next_dummy_order = 1; + + +gfc_namespace *gfc_current_ns; +gfc_namespace *gfc_global_ns_list; + +gfc_gsymbol *gfc_gsym_root = NULL; + +gfc_symbol *gfc_derived_types; + +static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL }; +static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var; + + +/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ + +/* The following static variable indicates whether a particular element has + been explicitly set or not. */ + +static int new_flag[GFC_LETTERS]; + + +/* Handle a correctly parsed IMPLICIT NONE. */ + +void +gfc_set_implicit_none (bool type, bool external, locus *loc) +{ + int i; + + if (external) + gfc_current_ns->has_implicit_none_export = 1; + + if (type) + { + gfc_current_ns->seen_implicit_none = 1; + for (i = 0; i < GFC_LETTERS; i++) + { + if (gfc_current_ns->set_flag[i]) + { + gfc_error_now ("IMPLICIT NONE (type) statement at %L following an " + "IMPLICIT statement", loc); + return; + } + gfc_clear_ts (&gfc_current_ns->default_type[i]); + gfc_current_ns->set_flag[i] = 1; + } + } +} + + +/* Reset the implicit range flags. */ + +void +gfc_clear_new_implicit (void) +{ + int i; + + for (i = 0; i < GFC_LETTERS; i++) + new_flag[i] = 0; +} + + +/* Prepare for a new implicit range. Sets flags in new_flag[]. */ + +bool +gfc_add_new_implicit_range (int c1, int c2) +{ + int i; + + c1 -= 'a'; + c2 -= 'a'; + + for (i = c1; i <= c2; i++) + { + if (new_flag[i]) + { + gfc_error ("Letter %qc already set in IMPLICIT statement at %C", + i + 'A'); + return false; + } + + new_flag[i] = 1; + } + + return true; +} + + +/* Add a matched implicit range for gfc_set_implicit(). Check if merging + the new implicit types back into the existing types will work. */ + +bool +gfc_merge_new_implicit (gfc_typespec *ts) +{ + int i; + + if (gfc_current_ns->seen_implicit_none) + { + gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE"); + return false; + } + + for (i = 0; i < GFC_LETTERS; i++) + { + if (new_flag[i]) + { + if (gfc_current_ns->set_flag[i]) + { + gfc_error ("Letter %qc already has an IMPLICIT type at %C", + i + 'A'); + return false; + } + + gfc_current_ns->default_type[i] = *ts; + gfc_current_ns->implicit_loc[i] = gfc_current_locus; + gfc_current_ns->set_flag[i] = 1; + } + } + return true; +} + + +/* Given a symbol, return a pointer to the typespec for its default type. */ + +gfc_typespec * +gfc_get_default_type (const char *name, gfc_namespace *ns) +{ + char letter; + + letter = name[0]; + + if (flag_allow_leading_underscore && letter == '_') + gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by " + "gfortran developers, and should not be used for " + "implicitly typed variables"); + + if (letter < 'a' || letter > 'z') + gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name); + + if (ns == NULL) + ns = gfc_current_ns; + + return &ns->default_type[letter - 'a']; +} + + +/* Recursively append candidate SYM to CANDIDATES. Store the number of + candidates in CANDIDATES_LEN. */ + +static void +lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym, + char **&candidates, + size_t &candidates_len) +{ + gfc_symtree *p; + + if (sym == NULL) + return; + + if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE) + vec_push (candidates, candidates_len, sym->name); + p = sym->left; + if (p) + lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); + + p = sym->right; + if (p) + lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); +} + + +/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */ + +static const char* +lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol) +{ + char **candidates = NULL; + size_t candidates_len = 0; + lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates, + candidates_len); + return gfc_closest_fuzzy_match (sym_name, candidates); +} + + +/* Given a pointer to a symbol, set its type according to the first + letter of its name. Fails if the letter in question has no default + type. */ + +bool +gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) +{ + gfc_typespec *ts; + + if (sym->ts.type != BT_UNKNOWN) + gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); + + ts = gfc_get_default_type (sym->name, ns); + + if (ts->type == BT_UNKNOWN) + { + if (error_flag && !sym->attr.untyped && !gfc_query_suppress_errors ()) + { + const char *guessed = lookup_symbol_fuzzy (sym->name, sym); + if (guessed) + gfc_error ("Symbol %qs at %L has no IMPLICIT type" + "; did you mean %qs?", + sym->name, &sym->declared_at, guessed); + else + gfc_error ("Symbol %qs at %L has no IMPLICIT type", + sym->name, &sym->declared_at); + sym->attr.untyped = 1; /* Ensure we only give an error once. */ + } + + return false; + } + + sym->ts = *ts; + sym->attr.implicit_type = 1; + + if (ts->type == BT_CHARACTER && ts->u.cl) + sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl); + else if (ts->type == BT_CLASS + && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) + return false; + + if (sym->attr.is_bind_c == 1 && warn_c_binding_type) + { + /* BIND(C) variables should not be implicitly declared. */ + gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) " + "variable %qs at %L may not be C interoperable", + sym->name, &sym->declared_at); + sym->ts.f90_type = sym->ts.type; + } + + if (sym->attr.dummy != 0) + { + if (sym->ns->proc_name != NULL + && (sym->ns->proc_name->attr.subroutine != 0 + || sym->ns->proc_name->attr.function != 0) + && sym->ns->proc_name->attr.is_bind_c != 0 + && warn_c_binding_type) + { + /* Dummy args to a BIND(C) routine may not be interoperable if + they are implicitly typed. */ + gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable " + "%qs at %L may not be C interoperable but it is a " + "dummy argument to the BIND(C) procedure %qs at %L", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name, + &(sym->ns->proc_name->declared_at)); + sym->ts.f90_type = sym->ts.type; + } + } + + return true; +} + + +/* This function is called from parse.c(parse_progunit) to check the + type of the function is not implicitly typed in the host namespace + and to implicitly type the function result, if necessary. */ + +void +gfc_check_function_type (gfc_namespace *ns) +{ + gfc_symbol *proc = ns->proc_name; + + if (!proc->attr.contained || proc->result->attr.implicit_type) + return; + + if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL) + { + if (gfc_set_default_type (proc->result, 0, gfc_current_ns)) + { + if (proc->result != proc) + { + proc->ts = proc->result->ts; + proc->as = gfc_copy_array_spec (proc->result->as); + proc->attr.dimension = proc->result->attr.dimension; + proc->attr.pointer = proc->result->attr.pointer; + proc->attr.allocatable = proc->result->attr.allocatable; + } + } + else if (!proc->result->attr.proc_pointer) + { + gfc_error ("Function result %qs at %L has no IMPLICIT type", + proc->result->name, &proc->result->declared_at); + proc->result->attr.untyped = 1; + } + } +} + + +/******************** Symbol attribute stuff *********************/ + +/* This is a generic conflict-checker. We do this to avoid having a + single conflict in two places. */ + +#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; } +#define conf2(a) if (attr->a) { a2 = a; goto conflict; } +#define conf_std(a, b, std) if (attr->a && attr->b)\ + {\ + a1 = a;\ + a2 = b;\ + standard = std;\ + goto conflict_std;\ + } + +bool +gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) +{ + static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", + *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", + *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC", + *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)", + *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL", + *privat = "PRIVATE", *recursive = "RECURSIVE", + *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", + *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", + *function = "FUNCTION", *subroutine = "SUBROUTINE", + *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", + *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", + *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", + *volatile_ = "VOLATILE", *is_protected = "PROTECTED", + *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", + *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT", + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", + *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", + *pdt_len = "LEN", *pdt_kind = "KIND"; + static const char *threadprivate = "THREADPRIVATE"; + static const char *omp_declare_target = "OMP DECLARE TARGET"; + static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; + static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; + static const char *oacc_declare_create = "OACC DECLARE CREATE"; + static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; + static const char *oacc_declare_device_resident = + "OACC DECLARE DEVICE_RESIDENT"; + + const char *a1, *a2; + int standard; + + if (attr->artificial) + return true; + + if (where == NULL) + where = &gfc_current_locus; + + if (attr->pointer && attr->intent != INTENT_UNKNOWN) + { + a1 = pointer; + a2 = intent; + standard = GFC_STD_F2003; + goto conflict_std; + } + + if (attr->in_namelist && (attr->allocatable || attr->pointer)) + { + a1 = in_namelist; + a2 = attr->allocatable ? allocatable : pointer; + standard = GFC_STD_F2003; + goto conflict_std; + } + + /* Check for attributes not allowed in a BLOCK DATA. */ + if (gfc_current_state () == COMP_BLOCK_DATA) + { + a1 = NULL; + + if (attr->in_namelist) + a1 = in_namelist; + if (attr->allocatable) + a1 = allocatable; + if (attr->external) + a1 = external; + if (attr->optional) + a1 = optional; + if (attr->access == ACCESS_PRIVATE) + a1 = privat; + if (attr->access == ACCESS_PUBLIC) + a1 = publik; + if (attr->intent != INTENT_UNKNOWN) + a1 = intent; + + if (a1 != NULL) + { + gfc_error + ("%s attribute not allowed in BLOCK DATA program unit at %L", + a1, where); + return false; + } + } + + if (attr->save == SAVE_EXPLICIT) + { + conf (dummy, save); + conf (in_common, save); + conf (result, save); + conf (automatic, save); + + switch (attr->flavor) + { + case FL_PROGRAM: + case FL_BLOCK_DATA: + case FL_MODULE: + case FL_LABEL: + case_fl_struct: + case FL_PARAMETER: + a1 = gfc_code2string (flavors, attr->flavor); + a2 = save; + goto conflict; + case FL_NAMELIST: + gfc_error ("Namelist group name at %L cannot have the " + "SAVE attribute", where); + return false; + case FL_PROCEDURE: + /* Conflicts between SAVE and PROCEDURE will be checked at + resolution stage, see "resolve_fl_procedure". */ + case FL_VARIABLE: + default: + break; + } + } + + /* The copying of procedure dummy arguments for module procedures in + a submodule occur whilst the current state is COMP_CONTAINS. It + is necessary, therefore, to let this through. */ + if (name && attr->dummy + && (attr->function || attr->subroutine) + && gfc_current_state () == COMP_CONTAINS + && !(gfc_new_block && gfc_new_block->abr_modproc_decl)) + gfc_error_now ("internal procedure %qs at %L conflicts with " + "DUMMY argument", name, where); + + conf (dummy, entry); + conf (dummy, intrinsic); + conf (dummy, threadprivate); + conf (dummy, omp_declare_target); + conf (dummy, omp_declare_target_link); + conf (pointer, target); + conf (pointer, intrinsic); + conf (pointer, elemental); + conf (pointer, codimension); + conf (allocatable, elemental); + + conf (in_common, automatic); + conf (result, automatic); + conf (use_assoc, automatic); + conf (dummy, automatic); + + conf (target, external); + conf (target, intrinsic); + + if (!attr->if_source) + conf (external, dimension); /* See Fortran 95's R504. */ + + conf (external, intrinsic); + conf (entry, intrinsic); + conf (abstract, intrinsic); + + if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) + conf (external, subroutine); + + if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003, + "Procedure pointer at %C")) + return false; + + conf (allocatable, pointer); + conf_std (allocatable, dummy, GFC_STD_F2003); + conf_std (allocatable, function, GFC_STD_F2003); + conf_std (allocatable, result, GFC_STD_F2003); + conf_std (elemental, recursive, GFC_STD_F2018); + + conf (in_common, dummy); + conf (in_common, allocatable); + conf (in_common, codimension); + conf (in_common, result); + + conf (in_equivalence, use_assoc); + conf (in_equivalence, codimension); + conf (in_equivalence, dummy); + conf (in_equivalence, target); + conf (in_equivalence, pointer); + conf (in_equivalence, function); + conf (in_equivalence, result); + conf (in_equivalence, entry); + conf (in_equivalence, allocatable); + conf (in_equivalence, threadprivate); + conf (in_equivalence, omp_declare_target); + conf (in_equivalence, omp_declare_target_link); + conf (in_equivalence, oacc_declare_create); + conf (in_equivalence, oacc_declare_copyin); + conf (in_equivalence, oacc_declare_deviceptr); + conf (in_equivalence, oacc_declare_device_resident); + conf (in_equivalence, is_bind_c); + + conf (dummy, result); + conf (entry, result); + conf (generic, result); + conf (generic, omp_declare_target); + conf (generic, omp_declare_target_link); + + conf (function, subroutine); + + if (!function && !subroutine) + conf (is_bind_c, dummy); + + conf (is_bind_c, cray_pointer); + conf (is_bind_c, cray_pointee); + conf (is_bind_c, codimension); + conf (is_bind_c, allocatable); + conf (is_bind_c, elemental); + + /* Need to also get volatile attr, according to 5.1 of F2003 draft. + Parameter conflict caught below. Also, value cannot be specified + for a dummy procedure. */ + + /* Cray pointer/pointee conflicts. */ + conf (cray_pointer, cray_pointee); + conf (cray_pointer, dimension); + conf (cray_pointer, codimension); + conf (cray_pointer, contiguous); + conf (cray_pointer, pointer); + conf (cray_pointer, target); + conf (cray_pointer, allocatable); + conf (cray_pointer, external); + conf (cray_pointer, intrinsic); + conf (cray_pointer, in_namelist); + conf (cray_pointer, function); + conf (cray_pointer, subroutine); + conf (cray_pointer, entry); + + conf (cray_pointee, allocatable); + conf (cray_pointee, contiguous); + conf (cray_pointee, codimension); + conf (cray_pointee, intent); + conf (cray_pointee, optional); + conf (cray_pointee, dummy); + conf (cray_pointee, target); + conf (cray_pointee, intrinsic); + conf (cray_pointee, pointer); + conf (cray_pointee, entry); + conf (cray_pointee, in_common); + conf (cray_pointee, in_equivalence); + conf (cray_pointee, threadprivate); + conf (cray_pointee, omp_declare_target); + conf (cray_pointee, omp_declare_target_link); + conf (cray_pointee, oacc_declare_create); + conf (cray_pointee, oacc_declare_copyin); + conf (cray_pointee, oacc_declare_deviceptr); + conf (cray_pointee, oacc_declare_device_resident); + + conf (data, dummy); + conf (data, function); + conf (data, result); + conf (data, allocatable); + + conf (value, pointer) + conf (value, allocatable) + conf (value, subroutine) + conf (value, function) + conf (value, volatile_) + conf (value, dimension) + conf (value, codimension) + conf (value, external) + + conf (codimension, result) + + if (attr->value + && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) + { + a1 = value; + a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout; + goto conflict; + } + + conf (is_protected, intrinsic) + conf (is_protected, in_common) + + conf (asynchronous, intrinsic) + conf (asynchronous, external) + + conf (volatile_, intrinsic) + conf (volatile_, external) + + if (attr->volatile_ && attr->intent == INTENT_IN) + { + a1 = volatile_; + a2 = intent_in; + goto conflict; + } + + conf (procedure, allocatable) + conf (procedure, dimension) + conf (procedure, codimension) + conf (procedure, intrinsic) + conf (procedure, target) + conf (procedure, value) + conf (procedure, volatile_) + conf (procedure, asynchronous) + conf (procedure, entry) + + conf (proc_pointer, abstract) + conf (proc_pointer, omp_declare_target) + conf (proc_pointer, omp_declare_target_link) + + conf (entry, omp_declare_target) + conf (entry, omp_declare_target_link) + conf (entry, oacc_declare_create) + conf (entry, oacc_declare_copyin) + conf (entry, oacc_declare_deviceptr) + conf (entry, oacc_declare_device_resident) + + conf (pdt_kind, allocatable) + conf (pdt_kind, pointer) + conf (pdt_kind, dimension) + conf (pdt_kind, codimension) + + conf (pdt_len, allocatable) + conf (pdt_len, pointer) + conf (pdt_len, dimension) + conf (pdt_len, codimension) + conf (pdt_len, pdt_kind) + + if (attr->access == ACCESS_PRIVATE) + { + a1 = privat; + conf2 (pdt_kind); + conf2 (pdt_len); + } + + a1 = gfc_code2string (flavors, attr->flavor); + + if (attr->in_namelist + && attr->flavor != FL_VARIABLE + && attr->flavor != FL_PROCEDURE + && attr->flavor != FL_UNKNOWN) + { + a2 = in_namelist; + goto conflict; + } + + switch (attr->flavor) + { + case FL_PROGRAM: + case FL_BLOCK_DATA: + case FL_MODULE: + case FL_LABEL: + conf2 (codimension); + conf2 (dimension); + conf2 (dummy); + conf2 (volatile_); + conf2 (asynchronous); + conf2 (contiguous); + conf2 (pointer); + conf2 (is_protected); + conf2 (target); + conf2 (external); + conf2 (intrinsic); + conf2 (allocatable); + conf2 (result); + conf2 (in_namelist); + conf2 (optional); + conf2 (function); + conf2 (subroutine); + conf2 (threadprivate); + conf2 (omp_declare_target); + conf2 (omp_declare_target_link); + conf2 (oacc_declare_create); + conf2 (oacc_declare_copyin); + conf2 (oacc_declare_deviceptr); + conf2 (oacc_declare_device_resident); + + if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE) + { + a2 = attr->access == ACCESS_PUBLIC ? publik : privat; + gfc_error ("%s attribute applied to %s %s at %L", a2, a1, + name, where); + return false; + } + + if (attr->is_bind_c) + { + gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where); + return false; + } + + break; + + case FL_VARIABLE: + break; + + case FL_NAMELIST: + conf2 (result); + break; + + case FL_PROCEDURE: + /* Conflicts with INTENT, SAVE and RESULT will be checked + at resolution stage, see "resolve_fl_procedure". */ + + if (attr->subroutine) + { + a1 = subroutine; + conf2 (target); + conf2 (allocatable); + conf2 (volatile_); + conf2 (asynchronous); + conf2 (in_namelist); + conf2 (codimension); + conf2 (dimension); + conf2 (function); + if (!attr->proc_pointer) + conf2 (threadprivate); + } + + /* Procedure pointers in COMMON blocks are allowed in F03, + * but forbidden per F08:C5100. */ + if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) + conf2 (in_common); + + conf2 (omp_declare_target_link); + + switch (attr->proc) + { + case PROC_ST_FUNCTION: + conf2 (dummy); + conf2 (target); + break; + + case PROC_MODULE: + conf2 (dummy); + break; + + case PROC_DUMMY: + conf2 (result); + conf2 (threadprivate); + break; + + default: + break; + } + + break; + + case_fl_struct: + conf2 (dummy); + conf2 (pointer); + conf2 (target); + conf2 (external); + conf2 (intrinsic); + conf2 (allocatable); + conf2 (optional); + conf2 (entry); + conf2 (function); + conf2 (subroutine); + conf2 (threadprivate); + conf2 (result); + conf2 (omp_declare_target); + conf2 (omp_declare_target_link); + conf2 (oacc_declare_create); + conf2 (oacc_declare_copyin); + conf2 (oacc_declare_deviceptr); + conf2 (oacc_declare_device_resident); + + if (attr->intent != INTENT_UNKNOWN) + { + a2 = intent; + goto conflict; + } + break; + + case FL_PARAMETER: + conf2 (external); + conf2 (intrinsic); + conf2 (optional); + conf2 (allocatable); + conf2 (function); + conf2 (subroutine); + conf2 (entry); + conf2 (contiguous); + conf2 (pointer); + conf2 (is_protected); + conf2 (target); + conf2 (dummy); + conf2 (in_common); + conf2 (value); + conf2 (volatile_); + conf2 (asynchronous); + conf2 (threadprivate); + conf2 (value); + conf2 (codimension); + conf2 (result); + if (!attr->is_iso_c) + conf2 (is_bind_c); + break; + + default: + break; + } + + return true; + +conflict: + if (name == NULL) + gfc_error ("%s attribute conflicts with %s attribute at %L", + a1, a2, where); + else + gfc_error ("%s attribute conflicts with %s attribute in %qs at %L", + a1, a2, name, where); + + return false; + +conflict_std: + if (name == NULL) + { + return gfc_notify_std (standard, "%s attribute conflicts " + "with %s attribute at %L", a1, a2, + where); + } + else + { + return gfc_notify_std (standard, "%s attribute conflicts " + "with %s attribute in %qs at %L", + a1, a2, name, where); + } +} + +#undef conf +#undef conf2 +#undef conf_std + + +/* Mark a symbol as referenced. */ + +void +gfc_set_sym_referenced (gfc_symbol *sym) +{ + + if (sym->attr.referenced) + return; + + sym->attr.referenced = 1; + + /* Remember which order dummy variables are accessed in. */ + if (sym->attr.dummy) + sym->dummy_order = next_dummy_order++; +} + + +/* Common subroutine called by attribute changing subroutines in order + to prevent them from changing a symbol that has been + use-associated. Returns zero if it is OK to change the symbol, + nonzero if not. */ + +static int +check_used (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->use_assoc == 0) + return 0; + + if (where == NULL) + where = &gfc_current_locus; + + if (name == NULL) + gfc_error ("Cannot change attributes of USE-associated symbol at %L", + where); + else + gfc_error ("Cannot change attributes of USE-associated symbol %s at %L", + name, where); + + return 1; +} + + +/* Generate an error because of a duplicate attribute. */ + +static void +duplicate_attr (const char *attr, locus *where) +{ + + if (where == NULL) + where = &gfc_current_locus; + + gfc_error ("Duplicate %s attribute specified at %L", attr, where); +} + + +bool +gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr, + locus *where ATTRIBUTE_UNUSED) +{ + attr->ext_attr |= 1 << ext_attr; + return true; +} + + +/* Called from decl.c (attr_decl1) to check attributes, when declared + separately. */ + +bool +gfc_add_attribute (symbol_attribute *attr, locus *where) +{ + if (check_used (attr, NULL, where)) + return false; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_allocatable (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->allocatable && ! gfc_submodule_procedure(attr)) + { + duplicate_attr ("ALLOCATABLE", where); + return false; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + { + gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L", + where); + return false; + } + + attr->allocatable = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY, + "Duplicate AUTOMATIC attribute specified at %L", where)) + return false; + + attr->automatic = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->codimension) + { + duplicate_attr ("CODIMENSION", where); + return false; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + { + gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body " + "at %L", name, where); + return false; + } + + attr->codimension = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->dimension && ! gfc_submodule_procedure(attr)) + { + duplicate_attr ("DIMENSION", where); + return false; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + { + gfc_error ("DIMENSION specified for %qs outside its INTERFACE body " + "at %L", name, where); + return false; + } + + attr->dimension = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->contiguous = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_external (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->external) + { + duplicate_attr ("EXTERNAL", where); + return false; + } + + if (attr->pointer && attr->if_source != IFSRC_IFBODY) + { + attr->pointer = 0; + attr->proc_pointer = 1; + } + + attr->external = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_intrinsic (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->intrinsic) + { + duplicate_attr ("INTRINSIC", where); + return false; + } + + attr->intrinsic = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_optional (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->optional) + { + duplicate_attr ("OPTIONAL", where); + return false; + } + + attr->optional = 1; + return gfc_check_conflict (attr, NULL, where); +} + +bool +gfc_add_kind (symbol_attribute *attr, locus *where) +{ + if (attr->pdt_kind) + { + duplicate_attr ("KIND", where); + return false; + } + + attr->pdt_kind = 1; + return gfc_check_conflict (attr, NULL, where); +} + +bool +gfc_add_len (symbol_attribute *attr, locus *where) +{ + if (attr->pdt_len) + { + duplicate_attr ("LEN", where); + return false; + } + + attr->pdt_len = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_pointer (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->pointer && !(attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE)) + && ! gfc_submodule_procedure(attr)) + { + duplicate_attr ("POINTER", where); + return false; + } + + if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY) + || (attr->if_source == IFSRC_IFBODY + && !gfc_find_state (COMP_INTERFACE))) + attr->proc_pointer = 1; + else + attr->pointer = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_cray_pointer (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + attr->cray_pointer = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_cray_pointee (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->cray_pointee) + { + gfc_error ("Cray Pointee at %L appears in multiple pointer()" + " statements", where); + return false; + } + + attr->cray_pointee = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_protected (symbol_attribute *attr, const char *name, locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->is_protected) + { + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate PROTECTED attribute specified at %L", + where)) + return false; + } + + attr->is_protected = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_result (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->result = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_save (symbol_attribute *attr, save_state s, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (s == SAVE_EXPLICIT && gfc_pure (NULL)) + { + gfc_error + ("SAVE attribute at %L cannot be specified in a PURE procedure", + where); + return false; + } + + if (s == SAVE_EXPLICIT) + gfc_unset_implicit_pure (NULL); + + if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT + && (flag_automatic || pedantic)) + { + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate SAVE attribute specified at %L", + where)) + return false; + } + + attr->save = s; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_value (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->value) + { + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate VALUE attribute specified at %L", + where)) + return false; + } + + attr->value = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) +{ + /* No check_used needed as 11.2.1 of the F2003 standard allows + that the local identifier made accessible by a use statement can be + given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ + + if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate VOLATILE attribute specified at %L", + where)) + return false; + + /* F2008: C1282 A designator of a variable with the VOLATILE attribute + shall not appear in a pure subprogram. + + F2018: C1588 A local variable of a pure subprogram, or of a BLOCK + construct within a pure subprogram, shall not have the SAVE or + VOLATILE attribute. */ + if (gfc_pure (NULL)) + { + gfc_error ("VOLATILE attribute at %L cannot be specified in a " + "PURE procedure", where); + return false; + } + + + attr->volatile_ = 1; + attr->volatile_ns = gfc_current_ns; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) +{ + /* No check_used needed as 11.2.1 of the F2003 standard allows + that the local identifier made accessible by a use statement can be + given a ASYNCHRONOUS attribute. */ + + if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Duplicate ASYNCHRONOUS attribute specified at %L", + where)) + return false; + + attr->asynchronous = 1; + attr->asynchronous_ns = gfc_current_ns; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->threadprivate) + { + duplicate_attr ("THREADPRIVATE", where); + return false; + } + + attr->threadprivate = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_omp_declare_target (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target) + return true; + + attr->omp_declare_target = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target_link) + return true; + + attr->omp_declare_target_link = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_create) + return true; + + attr->oacc_declare_create = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_copyin) + return true; + + attr->oacc_declare_copyin = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_deviceptr) + return true; + + attr->oacc_declare_deviceptr = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name, + locus *where) +{ + if (check_used (attr, name, where)) + return false; + + if (attr->oacc_declare_device_resident) + return true; + + attr->oacc_declare_device_resident = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_target (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->target) + { + duplicate_attr ("TARGET", where); + return false; + } + + attr->target = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + /* Duplicate dummy arguments are allowed due to ENTRY statements. */ + attr->dummy = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + /* Duplicate attribute already checked for. */ + attr->in_common = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where) +{ + + /* Duplicate attribute already checked for. */ + attr->in_equivalence = 1; + if (!gfc_check_conflict (attr, name, where)) + return false; + + if (attr->flavor == FL_VARIABLE) + return true; + + return gfc_add_flavor (attr, FL_VARIABLE, name, where); +} + + +bool +gfc_add_data (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->data = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where) +{ + + attr->in_namelist = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + attr->sequence = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_elemental (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->elemental) + { + duplicate_attr ("ELEMENTAL", where); + return false; + } + + attr->elemental = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_pure (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->pure) + { + duplicate_attr ("PURE", where); + return false; + } + + attr->pure = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_recursive (symbol_attribute *attr, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->recursive) + { + duplicate_attr ("RECURSIVE", where); + return false; + } + + attr->recursive = 1; + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->entry) + { + duplicate_attr ("ENTRY", where); + return false; + } + + attr->entry = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_function (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + attr->function = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + attr->subroutine = 1; + + /* If we are looking at a BLOCK DATA statement and we encounter a + name with a leading underscore (which must be + compiler-generated), do not check. See PR 84394. */ + + if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA) + return gfc_check_conflict (attr, name, where); + else + return true; +} + + +bool +gfc_add_generic (symbol_attribute *attr, const char *name, locus *where) +{ + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + attr->generic = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + if (attr->procedure) + { + duplicate_attr ("PROCEDURE", where); + return false; + } + + attr->procedure = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +bool +gfc_add_abstract (symbol_attribute* attr, locus* where) +{ + if (attr->abstract) + { + duplicate_attr ("ABSTRACT", where); + return false; + } + + attr->abstract = 1; + + return gfc_check_conflict (attr, NULL, where); +} + + +/* Flavors are special because some flavors are not what Fortran + considers attributes and can be reaffirmed multiple times. */ + +bool +gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, + locus *where) +{ + + if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE + || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f) + || f == FL_NAMELIST) && check_used (attr, name, where)) + return false; + + if (attr->flavor == f && f == FL_VARIABLE) + return true; + + /* Copying a procedure dummy argument for a module procedure in a + submodule results in the flavor being copied and would result in + an error without this. */ + if (attr->flavor == f && f == FL_PROCEDURE + && gfc_new_block && gfc_new_block->abr_modproc_decl) + return true; + + if (attr->flavor != FL_UNKNOWN) + { + if (where == NULL) + where = &gfc_current_locus; + + if (name) + gfc_error ("%s attribute of %qs conflicts with %s attribute at %L", + gfc_code2string (flavors, attr->flavor), name, + gfc_code2string (flavors, f), where); + else + gfc_error ("%s attribute conflicts with %s attribute at %L", + gfc_code2string (flavors, attr->flavor), + gfc_code2string (flavors, f), where); + + return false; + } + + attr->flavor = f; + + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_procedure (symbol_attribute *attr, procedure_type t, + const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->flavor != FL_PROCEDURE + && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) + return false; + + if (where == NULL) + where = &gfc_current_locus; + + if (attr->proc != PROC_UNKNOWN && !attr->module_procedure + && attr->access == ACCESS_UNKNOWN) + { + if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL + && !gfc_notification_std (GFC_STD_F2008)) + gfc_error ("%s procedure at %L is already declared as %s " + "procedure. \nF2008: A pointer function assignment " + "is ambiguous if it is the first executable statement " + "after the specification block. Please add any other " + "kind of executable statement before it. FIXME", + gfc_code2string (procedures, t), where, + gfc_code2string (procedures, attr->proc)); + else + gfc_error ("%s procedure at %L is already declared as %s " + "procedure", gfc_code2string (procedures, t), where, + gfc_code2string (procedures, attr->proc)); + + return false; + } + + attr->proc = t; + + /* Statement functions are always scalar and functions. */ + if (t == PROC_ST_FUNCTION + && ((!attr->function && !gfc_add_function (attr, name, where)) + || attr->dimension)) + return false; + + return gfc_check_conflict (attr, name, where); +} + + +bool +gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where) +{ + + if (check_used (attr, NULL, where)) + return false; + + if (attr->intent == INTENT_UNKNOWN) + { + attr->intent = intent; + return gfc_check_conflict (attr, NULL, where); + } + + if (where == NULL) + where = &gfc_current_locus; + + gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L", + gfc_intent_string (attr->intent), + gfc_intent_string (intent), where); + + return false; +} + + +/* No checks for use-association in public and private statements. */ + +bool +gfc_add_access (symbol_attribute *attr, gfc_access access, + const char *name, locus *where) +{ + + if (attr->access == ACCESS_UNKNOWN + || (attr->use_assoc && attr->access != ACCESS_PRIVATE)) + { + attr->access = access; + return gfc_check_conflict (attr, name, where); + } + + if (where == NULL) + where = &gfc_current_locus; + gfc_error ("ACCESS specification at %L was already specified", where); + + return false; +} + + +/* Set the is_bind_c field for the given symbol_attribute. */ + +bool +gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, + int is_proc_lang_bind_spec) +{ + + if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE) + gfc_error_now ("BIND(C) attribute at %L can only be used for " + "variables or common blocks", where); + else if (attr->is_bind_c) + gfc_error_now ("Duplicate BIND attribute specified at %L", where); + else + attr->is_bind_c = 1; + + if (where == NULL) + where = &gfc_current_locus; + + if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)) + return false; + + return gfc_check_conflict (attr, name, where); +} + + +/* Set the extension field for the given symbol_attribute. */ + +bool +gfc_add_extension (symbol_attribute *attr, locus *where) +{ + if (where == NULL) + where = &gfc_current_locus; + + if (attr->extension) + gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where); + else + attr->extension = 1; + + if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where)) + return false; + + return true; +} + + +bool +gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, + gfc_formal_arglist * formal, locus *where) +{ + if (check_used (&sym->attr, sym->name, where)) + return false; + + /* Skip the following checks in the case of a module_procedures in a + submodule since they will manifestly fail. */ + if (sym->attr.module_procedure == 1 + && source == IFSRC_DECL) + goto finish; + + if (where == NULL) + where = &gfc_current_locus; + + if (sym->attr.if_source != IFSRC_UNKNOWN + && sym->attr.if_source != IFSRC_DECL) + { + gfc_error ("Symbol %qs at %L already has an explicit interface", + sym->name, where); + return false; + } + + if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable)) + { + gfc_error ("%qs at %L has attributes specified outside its INTERFACE " + "body", sym->name, where); + return false; + } + +finish: + sym->formal = formal; + sym->attr.if_source = source; + + return true; +} + + +/* Add a type to a symbol. */ + +bool +gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) +{ + sym_flavor flavor; + bt type; + + if (where == NULL) + where = &gfc_current_locus; + + if (sym->result) + type = sym->result->ts.type; + else + type = sym->ts.type; + + if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name) + type = sym->ns->proc_name->ts.type; + + if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type) + && !(gfc_state_stack->previous && gfc_state_stack->previous->previous + && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) + && !sym->attr.module_procedure) + { + if (sym->attr.use_assoc) + gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " + "use-associated at %L", sym->name, where, sym->module, + &sym->declared_at); + else if (sym->attr.function && sym->attr.result) + gfc_error ("Symbol %qs at %L already has basic type of %s", + sym->ns->proc_name->name, where, gfc_basic_typename (type)); + else + gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, + where, gfc_basic_typename (type)); + return false; + } + + if (sym->attr.procedure && sym->ts.interface) + { + gfc_error ("Procedure %qs at %L may not have basic type of %s", + sym->name, where, gfc_basic_typename (ts->type)); + return false; + } + + flavor = sym->attr.flavor; + + if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE + || flavor == FL_LABEL + || (flavor == FL_PROCEDURE && sym->attr.subroutine) + || flavor == FL_DERIVED || flavor == FL_NAMELIST) + { + gfc_error ("Symbol %qs at %L cannot have a type", + sym->ns->proc_name ? sym->ns->proc_name->name : sym->name, + where); + return false; + } + + sym->ts = *ts; + return true; +} + + +/* Clears all attributes. */ + +void +gfc_clear_attr (symbol_attribute *attr) +{ + memset (attr, 0, sizeof (symbol_attribute)); +} + + +/* Check for missing attributes in the new symbol. Currently does + nothing, but it's not clear that it is unnecessary yet. */ + +bool +gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED, + locus *where ATTRIBUTE_UNUSED) +{ + + return true; +} + + +/* Copy an attribute to a symbol attribute, bit by bit. Some + attributes have a lot of side-effects but cannot be present given + where we are called from, so we ignore some bits. */ + +bool +gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) +{ + int is_proc_lang_bind_spec; + + /* In line with the other attributes, we only add bits but do not remove + them; cf. also PR 41034. */ + dest->ext_attr |= src->ext_attr; + + if (src->allocatable && !gfc_add_allocatable (dest, where)) + goto fail; + + if (src->automatic && !gfc_add_automatic (dest, NULL, where)) + goto fail; + if (src->dimension && !gfc_add_dimension (dest, NULL, where)) + goto fail; + if (src->codimension && !gfc_add_codimension (dest, NULL, where)) + goto fail; + if (src->contiguous && !gfc_add_contiguous (dest, NULL, where)) + goto fail; + if (src->optional && !gfc_add_optional (dest, where)) + goto fail; + if (src->pointer && !gfc_add_pointer (dest, where)) + goto fail; + if (src->is_protected && !gfc_add_protected (dest, NULL, where)) + goto fail; + if (src->save && !gfc_add_save (dest, src->save, NULL, where)) + goto fail; + if (src->value && !gfc_add_value (dest, NULL, where)) + goto fail; + if (src->volatile_ && !gfc_add_volatile (dest, NULL, where)) + goto fail; + if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) + goto fail; + if (src->threadprivate + && !gfc_add_threadprivate (dest, NULL, where)) + goto fail; + if (src->omp_declare_target + && !gfc_add_omp_declare_target (dest, NULL, where)) + goto fail; + if (src->omp_declare_target_link + && !gfc_add_omp_declare_target_link (dest, NULL, where)) + goto fail; + if (src->oacc_declare_create + && !gfc_add_oacc_declare_create (dest, NULL, where)) + goto fail; + if (src->oacc_declare_copyin + && !gfc_add_oacc_declare_copyin (dest, NULL, where)) + goto fail; + if (src->oacc_declare_deviceptr + && !gfc_add_oacc_declare_deviceptr (dest, NULL, where)) + goto fail; + if (src->oacc_declare_device_resident + && !gfc_add_oacc_declare_device_resident (dest, NULL, where)) + goto fail; + if (src->target && !gfc_add_target (dest, where)) + goto fail; + if (src->dummy && !gfc_add_dummy (dest, NULL, where)) + goto fail; + if (src->result && !gfc_add_result (dest, NULL, where)) + goto fail; + if (src->entry) + dest->entry = 1; + + if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where)) + goto fail; + + if (src->in_common && !gfc_add_in_common (dest, NULL, where)) + goto fail; + + if (src->generic && !gfc_add_generic (dest, NULL, where)) + goto fail; + if (src->function && !gfc_add_function (dest, NULL, where)) + goto fail; + if (src->subroutine && !gfc_add_subroutine (dest, NULL, where)) + goto fail; + + if (src->sequence && !gfc_add_sequence (dest, NULL, where)) + goto fail; + if (src->elemental && !gfc_add_elemental (dest, where)) + goto fail; + if (src->pure && !gfc_add_pure (dest, where)) + goto fail; + if (src->recursive && !gfc_add_recursive (dest, where)) + goto fail; + + if (src->flavor != FL_UNKNOWN + && !gfc_add_flavor (dest, src->flavor, NULL, where)) + goto fail; + + if (src->intent != INTENT_UNKNOWN + && !gfc_add_intent (dest, src->intent, where)) + goto fail; + + if (src->access != ACCESS_UNKNOWN + && !gfc_add_access (dest, src->access, NULL, where)) + goto fail; + + if (!gfc_missing_attr (dest, where)) + goto fail; + + if (src->cray_pointer && !gfc_add_cray_pointer (dest, where)) + goto fail; + if (src->cray_pointee && !gfc_add_cray_pointee (dest, where)) + goto fail; + + is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0); + if (src->is_bind_c + && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)) + return false; + + if (src->is_c_interop) + dest->is_c_interop = 1; + if (src->is_iso_c) + dest->is_iso_c = 1; + + if (src->external && !gfc_add_external (dest, where)) + goto fail; + if (src->intrinsic && !gfc_add_intrinsic (dest, where)) + goto fail; + if (src->proc_pointer) + dest->proc_pointer = 1; + + return true; + +fail: + return false; +} + + +/* A function to generate a dummy argument symbol using that from the + interface declaration. Can be used for the result symbol as well if + the flag is set. */ + +int +gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result) +{ + int rc; + + rc = gfc_get_symbol (sym->name, NULL, dsym); + if (rc) + return rc; + + if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus)) + return 1; + + if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr), + &gfc_current_locus)) + return 1; + + if ((*dsym)->attr.dimension) + (*dsym)->as = gfc_copy_array_spec (sym->as); + + (*dsym)->attr.class_ok = sym->attr.class_ok; + + if ((*dsym) != NULL && !result + && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL) + || !gfc_missing_attr (&(*dsym)->attr, NULL))) + return 1; + else if ((*dsym) != NULL && result + && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL) + || !gfc_missing_attr (&(*dsym)->attr, NULL))) + return 1; + + return 0; +} + + +/************** Component name management ************/ + +/* Component names of a derived type form their own little namespaces + that are separate from all other spaces. The space is composed of + a singly linked list of gfc_component structures whose head is + located in the parent symbol. */ + + +/* Add a component name to a symbol. The call fails if the name is + already present. On success, the component pointer is modified to + point to the additional component structure. */ + +bool +gfc_add_component (gfc_symbol *sym, const char *name, + gfc_component **component) +{ + gfc_component *p, *tail; + + /* Check for existing components with the same name, but not for union + components or containers. Unions and maps are anonymous so they have + unique internal names which will never conflict. + Don't use gfc_find_component here because it calls gfc_use_derived, + but the derived type may not be fully defined yet. */ + tail = NULL; + + for (p = sym->components; p; p = p->next) + { + if (strcmp (p->name, name) == 0) + { + gfc_error ("Component %qs at %C already declared at %L", + name, &p->loc); + return false; + } + + tail = p; + } + + if (sym->attr.extension + && gfc_find_component (sym->components->ts.u.derived, + name, true, true, NULL)) + { + gfc_error ("Component %qs at %C already in the parent type " + "at %L", name, &sym->components->ts.u.derived->declared_at); + return false; + } + + /* Allocate a new component. */ + p = gfc_get_component (); + + if (tail == NULL) + sym->components = p; + else + tail->next = p; + + p->name = gfc_get_string ("%s", name); + p->loc = gfc_current_locus; + p->ts.type = BT_UNKNOWN; + + *component = p; + return true; +} + + +/* Recursive function to switch derived types of all symbol in a + namespace. */ + +static void +switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to) +{ + gfc_symbol *sym; + + if (st == NULL) + return; + + sym = st->n.sym; + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from) + sym->ts.u.derived = to; + + switch_types (st->left, from, to); + switch_types (st->right, from, to); +} + + +/* This subroutine is called when a derived type is used in order to + make the final determination about which version to use. The + standard requires that a type be defined before it is 'used', but + such types can appear in IMPLICIT statements before the actual + definition. 'Using' in this context means declaring a variable to + be that type or using the type constructor. + + If a type is used and the components haven't been defined, then we + have to have a derived type in a parent unit. We find the node in + the other namespace and point the symtree node in this namespace to + that node. Further reference to this name point to the correct + node. If we can't find the node in a parent namespace, then we have + an error. + + This subroutine takes a pointer to a symbol node and returns a + pointer to the translated node or NULL for an error. Usually there + is no translation and we return the node we were passed. */ + +gfc_symbol * +gfc_use_derived (gfc_symbol *sym) +{ + gfc_symbol *s; + gfc_typespec *t; + gfc_symtree *st; + int i; + + if (!sym) + return NULL; + + if (sym->attr.unlimited_polymorphic) + return sym; + + if (sym->attr.generic) + sym = gfc_find_dt_in_generic (sym); + + if (sym->components != NULL || sym->attr.zero_comp) + return sym; /* Already defined. */ + + if (sym->ns->parent == NULL) + goto bad; + + if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) + { + gfc_error ("Symbol %qs at %C is ambiguous", sym->name); + return NULL; + } + + if (s == NULL || !gfc_fl_struct (s->attr.flavor)) + goto bad; + + /* Get rid of symbol sym, translating all references to s. */ + for (i = 0; i < GFC_LETTERS; i++) + { + t = &sym->ns->default_type[i]; + if (t->u.derived == sym) + t->u.derived = s; + } + + st = gfc_find_symtree (sym->ns->sym_root, sym->name); + st->n.sym = s; + + s->refs++; + + /* Unlink from list of modified symbols. */ + gfc_commit_symbol (sym); + + switch_types (sym->ns->sym_root, sym, s); + + /* TODO: Also have to replace sym -> s in other lists like + namelists, common lists and interface lists. */ + gfc_free_symbol (sym); + + return s; + +bad: + gfc_error ("Derived type %qs at %C is being used before it is defined", + sym->name); + return NULL; +} + + +/* Find the component with the given name in the union type symbol. + If ref is not NULL it will be set to the chain of components through which + the component can actually be accessed. This is necessary for unions because + intermediate structures may be maps, nested structures, or other unions, + all of which may (or must) be 'anonymous' to user code. */ + +static gfc_component * +find_union_component (gfc_symbol *un, const char *name, + bool noaccess, gfc_ref **ref) +{ + gfc_component *m, *check; + gfc_ref *sref, *tmp; + + for (m = un->components; m; m = m->next) + { + check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp); + if (check == NULL) + continue; + + /* Found component somewhere in m; chain the refs together. */ + if (ref) + { + /* Map ref. */ + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = m; + sref->u.c.sym = m->ts.u.derived; + sref->next = tmp; + + *ref = sref; + } + /* Other checks (such as access) were done in the recursive calls. */ + return check; + } + return NULL; +} + + +/* Recursively append candidate COMPONENT structures to CANDIDATES. Store + the number of total candidates in CANDIDATES_LEN. */ + +static void +lookup_component_fuzzy_find_candidates (gfc_component *component, + char **&candidates, + size_t &candidates_len) +{ + for (gfc_component *p = component; p; p = p->next) + vec_push (candidates, candidates_len, p->name); +} + + +/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */ + +static const char* +lookup_component_fuzzy (const char *member, gfc_component *component) +{ + char **candidates = NULL; + size_t candidates_len = 0; + lookup_component_fuzzy_find_candidates (component, candidates, + candidates_len); + return gfc_closest_fuzzy_match (member, candidates); +} + + +/* Given a derived type node and a component name, try to locate the + component structure. Returns the NULL pointer if the component is + not found or the components are private. If noaccess is set, no access + checks are done. If silent is set, an error will not be generated if + the component cannot be found or accessed. + + If ref is not NULL, *ref is set to represent the chain of components + required to get to the ultimate component. + + If the component is simply a direct subcomponent, or is inherited from a + parent derived type in the given derived type, this is a single ref with its + component set to the returned component. + + Otherwise, *ref is constructed as a chain of subcomponents. This occurs + when the component is found through an implicit chain of nested union and + map components. Unions and maps are "anonymous" substructures in FORTRAN + which cannot be explicitly referenced, but the reference chain must be + considered as in C for backend translation to correctly compute layouts. + (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */ + +gfc_component * +gfc_find_component (gfc_symbol *sym, const char *name, + bool noaccess, bool silent, gfc_ref **ref) +{ + gfc_component *p, *check; + gfc_ref *sref = NULL, *tmp = NULL; + + if (name == NULL || sym == NULL) + return NULL; + + if (sym->attr.flavor == FL_DERIVED) + sym = gfc_use_derived (sym); + else + gcc_assert (gfc_fl_struct (sym->attr.flavor)); + + if (sym == NULL) + return NULL; + + /* Handle UNIONs specially - mutually recursive with gfc_find_component. */ + if (sym->attr.flavor == FL_UNION) + return find_union_component (sym, name, noaccess, ref); + + if (ref) *ref = NULL; + for (p = sym->components; p; p = p->next) + { + /* Nest search into union's maps. */ + if (p->ts.type == BT_UNION) + { + check = find_union_component (p->ts.u.derived, name, noaccess, &tmp); + if (check != NULL) + { + /* Union ref. */ + if (ref) + { + sref = gfc_get_ref (); + sref->type = REF_COMPONENT; + sref->u.c.component = p; + sref->u.c.sym = p->ts.u.derived; + sref->next = tmp; + *ref = sref; + } + return check; + } + } + else if (strcmp (p->name, name) == 0) + break; + + continue; + } + + if (p && sym->attr.use_assoc && !noaccess) + { + bool is_parent_comp = sym->attr.extension && (p == sym->components); + if (p->attr.access == ACCESS_PRIVATE || + (p->attr.access != ACCESS_PUBLIC + && sym->component_access == ACCESS_PRIVATE + && !is_parent_comp)) + { + if (!silent) + gfc_error ("Component %qs at %C is a PRIVATE component of %qs", + name, sym->name); + return NULL; + } + } + + if (p == NULL + && sym->attr.extension + && sym->components->ts.type == BT_DERIVED) + { + p = gfc_find_component (sym->components->ts.u.derived, name, + noaccess, silent, ref); + /* Do not overwrite the error. */ + if (p == NULL) + return p; + } + + if (p == NULL && !silent) + { + const char *guessed = lookup_component_fuzzy (name, sym->components); + if (guessed) + gfc_error ("%qs at %C is not a member of the %qs structure" + "; did you mean %qs?", + name, sym->name, guessed); + else + gfc_error ("%qs at %C is not a member of the %qs structure", + name, sym->name); + } + + /* Component was found; build the ultimate component reference. */ + if (p != NULL && ref) + { + tmp = gfc_get_ref (); + tmp->type = REF_COMPONENT; + tmp->u.c.component = p; + tmp->u.c.sym = sym; + /* Link the final component ref to the end of the chain of subrefs. */ + if (sref) + { + *ref = sref; + for (; sref->next; sref = sref->next) + ; + sref->next = tmp; + } + else + *ref = tmp; + } + + return p; +} + + +/* Given a symbol, free all of the component structures and everything + they point to. */ + +static void +free_components (gfc_component *p) +{ + gfc_component *q; + + for (; p; p = q) + { + q = p->next; + + gfc_free_array_spec (p->as); + gfc_free_expr (p->initializer); + if (p->kind_expr) + gfc_free_expr (p->kind_expr); + if (p->param_list) + gfc_free_actual_arglist (p->param_list); + free (p->tb); + p->tb = NULL; + free (p); + } +} + + +/******************** Statement label management ********************/ + +/* Comparison function for statement labels, used for managing the + binary tree. */ + +static int +compare_st_labels (void *a1, void *b1) +{ + int a = ((gfc_st_label *) a1)->value; + int b = ((gfc_st_label *) b1)->value; + + return (b - a); +} + + +/* Free a single gfc_st_label structure, making sure the tree is not + messed up. This function is called only when some parse error + occurs. */ + +void +gfc_free_st_label (gfc_st_label *label) +{ + + if (label == NULL) + return; + + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + + if (label->format != NULL) + gfc_free_expr (label->format); + + free (label); +} + + +/* Free a whole tree of gfc_st_label structures. */ + +static void +free_st_labels (gfc_st_label *label) +{ + + if (label == NULL) + return; + + free_st_labels (label->left); + free_st_labels (label->right); + + if (label->format != NULL) + gfc_free_expr (label->format); + free (label); +} + + +/* Given a label number, search for and return a pointer to the label + structure, creating it if it does not exist. */ + +gfc_st_label * +gfc_get_st_label (int labelno) +{ + gfc_st_label *lp; + gfc_namespace *ns; + + if (gfc_current_state () == COMP_DERIVED) + ns = gfc_current_block ()->f2k_derived; + else + { + /* Find the namespace of the scoping unit: + If we're in a BLOCK construct, jump to the parent namespace. */ + ns = gfc_current_ns; + while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL) + ns = ns->parent; + } + + /* First see if the label is already in this namespace. */ + lp = ns->st_labels; + while (lp) + { + if (lp->value == labelno) + return lp; + + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + + lp = XCNEW (gfc_st_label); + + lp->value = labelno; + lp->defined = ST_LABEL_UNKNOWN; + lp->referenced = ST_LABEL_UNKNOWN; + lp->ns = ns; + + gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels); + + return lp; +} + + +/* Called when a statement with a statement label is about to be + accepted. We add the label to the list of the current namespace, + making sure it hasn't been defined previously and referenced + correctly. */ + +void +gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) +{ + int labelno; + + labelno = lp->value; + + if (lp->defined != ST_LABEL_UNKNOWN) + gfc_error ("Duplicate statement label %d at %L and %L", labelno, + &lp->where, label_locus); + else + { + lp->where = *label_locus; + + switch (type) + { + case ST_LABEL_FORMAT: + if (lp->referenced == ST_LABEL_TARGET + || lp->referenced == ST_LABEL_DO_TARGET) + gfc_error ("Label %d at %C already referenced as branch target", + labelno); + else + lp->defined = ST_LABEL_FORMAT; + + break; + + case ST_LABEL_TARGET: + case ST_LABEL_DO_TARGET: + if (lp->referenced == ST_LABEL_FORMAT) + gfc_error ("Label %d at %C already referenced as a format label", + labelno); + else + lp->defined = type; + + if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET + && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, + "DO termination statement which is not END DO" + " or CONTINUE with label %d at %C", labelno)) + return; + break; + + default: + lp->defined = ST_LABEL_BAD_TARGET; + lp->referenced = ST_LABEL_BAD_TARGET; + } + } +} + + +/* Reference a label. Given a label and its type, see if that + reference is consistent with what is known about that label, + updating the unknown state. Returns false if something goes + wrong. */ + +bool +gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) +{ + gfc_sl_type label_type; + int labelno; + bool rc; + + if (lp == NULL) + return true; + + labelno = lp->value; + + if (lp->defined != ST_LABEL_UNKNOWN) + label_type = lp->defined; + else + { + label_type = lp->referenced; + lp->where = gfc_current_locus; + } + + if (label_type == ST_LABEL_FORMAT + && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET)) + { + gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); + rc = false; + goto done; + } + + if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET + || label_type == ST_LABEL_BAD_TARGET) + && type == ST_LABEL_FORMAT) + { + gfc_error ("Label %d at %C previously used as branch target", labelno); + rc = false; + goto done; + } + + if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET + && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, + "Shared DO termination label %d at %C", labelno)) + return false; + + if (type == ST_LABEL_DO_TARGET + && !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement " + "at %L", &gfc_current_locus)) + return false; + + if (lp->referenced != ST_LABEL_DO_TARGET) + lp->referenced = type; + rc = true; + +done: + return rc; +} + + +/************** Symbol table management subroutines ****************/ + +/* Basic details: Fortran 95 requires a potentially unlimited number + of distinct namespaces when compiling a program unit. This case + occurs during a compilation of internal subprograms because all of + the internal subprograms must be read before we can start + generating code for the host. + + Given the tricky nature of the Fortran grammar, we must be able to + undo changes made to a symbol table if the current interpretation + of a statement is found to be incorrect. Whenever a symbol is + looked up, we make a copy of it and link to it. All of these + symbols are kept in a vector so that we can commit or + undo the changes at a later time. + + A symtree may point to a symbol node outside of its namespace. In + this case, that symbol has been used as a host associated variable + at some previous time. */ + +/* Allocate a new namespace structure. Copies the implicit types from + PARENT if PARENT_TYPES is set. */ + +gfc_namespace * +gfc_get_namespace (gfc_namespace *parent, int parent_types) +{ + gfc_namespace *ns; + gfc_typespec *ts; + int in; + int i; + + ns = XCNEW (gfc_namespace); + ns->sym_root = NULL; + ns->uop_root = NULL; + ns->tb_sym_root = NULL; + ns->finalizers = NULL; + ns->default_access = ACCESS_UNKNOWN; + ns->parent = parent; + + for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) + { + ns->operator_access[in] = ACCESS_UNKNOWN; + ns->tb_op[in] = NULL; + } + + /* Initialize default implicit types. */ + for (i = 'a'; i <= 'z'; i++) + { + ns->set_flag[i - 'a'] = 0; + ts = &ns->default_type[i - 'a']; + + if (parent_types && ns->parent != NULL) + { + /* Copy parent settings. */ + *ts = ns->parent->default_type[i - 'a']; + continue; + } + + if (flag_implicit_none != 0) + { + gfc_clear_ts (ts); + continue; + } + + if ('i' <= i && i <= 'n') + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + } + else + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + } + } + + ns->refs = 1; + + return ns; +} + + +/* Comparison function for symtree nodes. */ + +static int +compare_symtree (void *_st1, void *_st2) +{ + gfc_symtree *st1, *st2; + + st1 = (gfc_symtree *) _st1; + st2 = (gfc_symtree *) _st2; + + return strcmp (st1->name, st2->name); +} + + +/* Allocate a new symtree node and associate it with the new symbol. */ + +gfc_symtree * +gfc_new_symtree (gfc_symtree **root, const char *name) +{ + gfc_symtree *st; + + st = XCNEW (gfc_symtree); + st->name = gfc_get_string ("%s", name); + + gfc_insert_bbt (root, st, compare_symtree); + return st; +} + + +/* Delete a symbol from the tree. Does not free the symbol itself! */ + +void +gfc_delete_symtree (gfc_symtree **root, const char *name) +{ + gfc_symtree st, *st0; + const char *p; + + /* Submodules are marked as mod.submod. When freeing a submodule + symbol, the symtree only has "submod", so adjust that here. */ + + p = strrchr(name, '.'); + if (p) + p++; + else + p = name; + + st0 = gfc_find_symtree (*root, p); + + st.name = gfc_get_string ("%s", p); + gfc_delete_bbt (root, &st, compare_symtree); + + free (st0); +} + + +/* Given a root symtree node and a name, try to find the symbol within + the namespace. Returns NULL if the symbol is not found. */ + +gfc_symtree * +gfc_find_symtree (gfc_symtree *st, const char *name) +{ + int c; + + while (st != NULL) + { + c = strcmp (name, st->name); + if (c == 0) + return st; + + st = (c < 0) ? st->left : st->right; + } + + return NULL; +} + + +/* Return a symtree node with a name that is guaranteed to be unique + within the namespace and corresponds to an illegal fortran name. */ + +gfc_symtree * +gfc_get_unique_symtree (gfc_namespace *ns) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int serial = 0; + + sprintf (name, "@%d", serial++); + return gfc_new_symtree (&ns->sym_root, name); +} + + +/* Given a name find a user operator node, creating it if it doesn't + exist. These are much simpler than symbols because they can't be + ambiguous with one another. */ + +gfc_user_op * +gfc_get_uop (const char *name) +{ + gfc_user_op *uop; + gfc_symtree *st; + gfc_namespace *ns = gfc_current_ns; + + if (ns->omp_udr_ns) + ns = ns->parent; + st = gfc_find_symtree (ns->uop_root, name); + if (st != NULL) + return st->n.uop; + + st = gfc_new_symtree (&ns->uop_root, name); + + uop = st->n.uop = XCNEW (gfc_user_op); + uop->name = gfc_get_string ("%s", name); + uop->access = ACCESS_UNKNOWN; + uop->ns = ns; + + return uop; +} + + +/* Given a name find the user operator node. Returns NULL if it does + not exist. */ + +gfc_user_op * +gfc_find_uop (const char *name, gfc_namespace *ns) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + + st = gfc_find_symtree (ns->uop_root, name); + return (st == NULL) ? NULL : st->n.uop; +} + + +/* Update a symbol's common_block field, and take care of the associated + memory management. */ + +static void +set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block) +{ + if (sym->common_block == common_block) + return; + + if (sym->common_block && sym->common_block->name[0] != '\0') + { + sym->common_block->refs--; + if (sym->common_block->refs == 0) + free (sym->common_block); + } + sym->common_block = common_block; +} + + +/* Remove a gfc_symbol structure and everything it points to. */ + +void +gfc_free_symbol (gfc_symbol *&sym) +{ + + if (sym == NULL) + return; + + gfc_free_array_spec (sym->as); + + free_components (sym->components); + + gfc_free_expr (sym->value); + + gfc_free_namelist (sym->namelist); + + if (sym->ns != sym->formal_ns) + gfc_free_namespace (sym->formal_ns); + + if (!sym->attr.generic_copy) + gfc_free_interface (sym->generic); + + gfc_free_formal_arglist (sym->formal); + + gfc_free_namespace (sym->f2k_derived); + + set_symbol_common_block (sym, NULL); + + if (sym->param_list) + gfc_free_actual_arglist (sym->param_list); + + free (sym); + sym = NULL; +} + + +/* Decrease the reference counter and free memory when we reach zero. */ + +void +gfc_release_symbol (gfc_symbol *&sym) +{ + if (sym == NULL) + return; + + if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns + && (!sym->attr.entry || !sym->module)) + { + /* As formal_ns contains a reference to sym, delete formal_ns just + before the deletion of sym. */ + gfc_namespace *ns = sym->formal_ns; + sym->formal_ns = NULL; + gfc_free_namespace (ns); + } + + sym->refs--; + if (sym->refs > 0) + return; + + gcc_assert (sym->refs == 0); + gfc_free_symbol (sym); +} + + +/* Allocate and initialize a new symbol node. */ + +gfc_symbol * +gfc_new_symbol (const char *name, gfc_namespace *ns) +{ + gfc_symbol *p; + + p = XCNEW (gfc_symbol); + + gfc_clear_ts (&p->ts); + gfc_clear_attr (&p->attr); + p->ns = ns; + p->declared_at = gfc_current_locus; + p->name = gfc_get_string ("%s", name); + + return p; +} + + +/* Generate an error if a symbol is ambiguous, and set the error flag + on it. */ + +static void +ambiguous_symbol (const char *name, gfc_symtree *st) +{ + + if (st->n.sym->error) + return; + + if (st->n.sym->module) + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " + "from module %qs", name, st->n.sym->name, st->n.sym->module); + else + gfc_error ("Name %qs at %C is an ambiguous reference to %qs " + "from current program unit", name, st->n.sym->name); + + st->n.sym->error = 1; +} + + +/* If we're in a SELECT TYPE block, check if the variable 'st' matches any + selector on the stack. If yes, replace it by the corresponding temporary. */ + +static void +select_type_insert_tmp (gfc_symtree **st) +{ + gfc_select_type_stack *stack = select_type_stack; + for (; stack; stack = stack->prev) + if ((*st)->n.sym == stack->selector && stack->tmp) + { + *st = stack->tmp; + select_type_insert_tmp (st); + return; + } +} + + +/* Look for a symtree in the current procedure -- that is, go up to + parent namespaces but only if inside a BLOCK. Returns NULL if not found. */ + +gfc_symtree* +gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns) +{ + while (ns) + { + gfc_symtree* st = gfc_find_symtree (ns->sym_root, name); + if (st) + return st; + + if (!ns->construct_entities) + break; + ns = ns->parent; + } + + return NULL; +} + + +/* Search for a symtree starting in the current namespace, resorting to + any parent namespaces if requested by a nonzero parent_flag. + Returns nonzero if the name is ambiguous. */ + +int +gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, + gfc_symtree **result) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + + do + { + st = gfc_find_symtree (ns->sym_root, name); + if (st != NULL) + { + select_type_insert_tmp (&st); + + *result = st; + /* Ambiguous generic interfaces are permitted, as long + as the specific interfaces are different. */ + if (st->ambiguous && !st->n.sym->attr.generic) + { + ambiguous_symbol (name, st); + return 1; + } + + return 0; + } + + if (!parent_flag) + break; + + /* Don't escape an interface block. */ + if (ns && !ns->has_import_set + && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) + break; + + ns = ns->parent; + } + while (ns != NULL); + + if (gfc_current_state() == COMP_DERIVED + && gfc_current_block ()->attr.pdt_template) + { + gfc_symbol *der = gfc_current_block (); + for (; der; der = gfc_get_derived_super_type (der)) + { + if (der->f2k_derived && der->f2k_derived->sym_root) + { + st = gfc_find_symtree (der->f2k_derived->sym_root, name); + if (st) + break; + } + } + *result = st; + return 0; + } + + *result = NULL; + + return 0; +} + + +/* Same, but returns the symbol instead. */ + +int +gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag, + gfc_symbol **result) +{ + gfc_symtree *st; + int i; + + i = gfc_find_sym_tree (name, ns, parent_flag, &st); + + if (st == NULL) + *result = NULL; + else + *result = st->n.sym; + + return i; +} + + +/* Tells whether there is only one set of changes in the stack. */ + +static bool +single_undo_checkpoint_p (void) +{ + if (latest_undo_chgset == &default_undo_chgset_var) + { + gcc_assert (latest_undo_chgset->previous == NULL); + return true; + } + else + { + gcc_assert (latest_undo_chgset->previous != NULL); + return false; + } +} + +/* Save symbol with the information necessary to back it out. */ + +void +gfc_save_symbol_data (gfc_symbol *sym) +{ + gfc_symbol *s; + unsigned i; + + if (!single_undo_checkpoint_p ()) + { + /* If there is more than one change set, look for the symbol in the + current one. If it is found there, we can reuse it. */ + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) + if (s == sym) + { + gcc_assert (sym->gfc_new || sym->old_symbol != NULL); + return; + } + } + else if (sym->gfc_new || sym->old_symbol != NULL) + return; + + s = XCNEW (gfc_symbol); + *s = *sym; + sym->old_symbol = s; + sym->gfc_new = 0; + + latest_undo_chgset->syms.safe_push (sym); +} + + +/* Given a name, find a symbol, or create it if it does not exist yet + in the current namespace. If the symbol is found we make sure that + it's OK. + + The integer return code indicates + 0 All OK + 1 The symbol name was ambiguous + 2 The name meant to be established was already host associated. + + So if the return value is nonzero, then an error was issued. */ + +int +gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, + bool allow_subroutine) +{ + gfc_symtree *st; + gfc_symbol *p; + + /* This doesn't usually happen during resolution. */ + if (ns == NULL) + ns = gfc_current_ns; + + /* Try to find the symbol in ns. */ + st = gfc_find_symtree (ns->sym_root, name); + + if (st == NULL && ns->omp_udr_ns) + { + ns = ns->parent; + st = gfc_find_symtree (ns->sym_root, name); + } + + if (st == NULL) + { + /* If not there, create a new symbol. */ + p = gfc_new_symbol (name, ns); + + /* Add to the list of tentative symbols. */ + p->old_symbol = NULL; + p->mark = 1; + p->gfc_new = 1; + latest_undo_chgset->syms.safe_push (p); + + st = gfc_new_symtree (&ns->sym_root, name); + st->n.sym = p; + p->refs++; + + } + else + { + /* Make sure the existing symbol is OK. Ambiguous + generic interfaces are permitted, as long as the + specific interfaces are different. */ + if (st->ambiguous && !st->n.sym->attr.generic) + { + ambiguous_symbol (name, st); + return 1; + } + + p = st->n.sym; + if (p->ns != ns && (!p->attr.function || ns->proc_name != p) + && !(allow_subroutine && p->attr.subroutine) + && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY + && (ns->has_import_set || p->attr.imported))) + { + /* Symbol is from another namespace. */ + gfc_error ("Symbol %qs at %C has already been host associated", + name); + return 2; + } + + p->mark = 1; + + /* Copy in case this symbol is changed. */ + gfc_save_symbol_data (p); + } + + *result = st; + return 0; +} + + +int +gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result) +{ + gfc_symtree *st; + int i; + + i = gfc_get_sym_tree (name, ns, &st, false); + if (i != 0) + return i; + + if (st) + *result = st->n.sym; + else + *result = NULL; + return i; +} + + +/* Subroutine that searches for a symbol, creating it if it doesn't + exist, but tries to host-associate the symbol if possible. */ + +int +gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) +{ + gfc_symtree *st; + int i; + + i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + + if (st != NULL) + { + gfc_save_symbol_data (st->n.sym); + *result = st; + return i; + } + + i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st); + if (i) + return i; + + if (st != NULL) + { + *result = st; + return 0; + } + + return gfc_get_sym_tree (name, gfc_current_ns, result, false); +} + + +int +gfc_get_ha_symbol (const char *name, gfc_symbol **result) +{ + int i; + gfc_symtree *st; + + i = gfc_get_ha_sym_tree (name, &st); + + if (st) + *result = st->n.sym; + else + *result = NULL; + + return i; +} + + +/* Search for the symtree belonging to a gfc_common_head; we cannot use + head->name as the common_root symtree's name might be mangled. */ + +static gfc_symtree * +find_common_symtree (gfc_symtree *st, gfc_common_head *head) +{ + + gfc_symtree *result; + + if (st == NULL) + return NULL; + + if (st->n.common == head) + return st; + + result = find_common_symtree (st->left, head); + if (!result) + result = find_common_symtree (st->right, head); + + return result; +} + + +/* Restore previous state of symbol. Just copy simple stuff. */ + +static void +restore_old_symbol (gfc_symbol *p) +{ + gfc_symbol *old; + + p->mark = 0; + old = p->old_symbol; + + p->ts.type = old->ts.type; + p->ts.kind = old->ts.kind; + + p->attr = old->attr; + + if (p->value != old->value) + { + gcc_checking_assert (old->value == NULL); + gfc_free_expr (p->value); + p->value = NULL; + } + + if (p->as != old->as) + { + if (p->as) + gfc_free_array_spec (p->as); + p->as = old->as; + } + + p->generic = old->generic; + p->component_access = old->component_access; + + if (p->namelist != NULL && old->namelist == NULL) + { + gfc_free_namelist (p->namelist); + p->namelist = NULL; + } + else + { + if (p->namelist_tail != old->namelist_tail) + { + gfc_free_namelist (old->namelist_tail->next); + old->namelist_tail->next = NULL; + } + } + + p->namelist_tail = old->namelist_tail; + + if (p->formal != old->formal) + { + gfc_free_formal_arglist (p->formal); + p->formal = old->formal; + } + + set_symbol_common_block (p, old->common_block); + p->common_head = old->common_head; + + p->old_symbol = old->old_symbol; + free (old); +} + + +/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free + the structure itself. */ + +static void +free_undo_change_set_data (gfc_undo_change_set &cs) +{ + cs.syms.release (); + cs.tbps.release (); +} + + +/* Given a change set pointer, free its target's contents and update it with + the address of the previous change set. Note that only the contents are + freed, not the target itself (the contents' container). It is not a problem + as the latter will be a local variable usually. */ + +static void +pop_undo_change_set (gfc_undo_change_set *&cs) +{ + free_undo_change_set_data (*cs); + cs = cs->previous; +} + + +static void free_old_symbol (gfc_symbol *sym); + + +/* Merges the current change set into the previous one. The changes themselves + are left untouched; only one checkpoint is forgotten. */ + +void +gfc_drop_last_undo_checkpoint (void) +{ + gfc_symbol *s, *t; + unsigned i, j; + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) + { + /* No need to loop in this case. */ + if (s->old_symbol == NULL) + continue; + + /* Remove the duplicate symbols. */ + FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t) + if (t == s) + { + latest_undo_chgset->previous->syms.unordered_remove (j); + + /* S->OLD_SYMBOL is the backup symbol for S as it was at the + last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL + shall contain from now on the backup symbol for S as it was + at the checkpoint before. */ + if (s->old_symbol->gfc_new) + { + gcc_assert (s->old_symbol->old_symbol == NULL); + s->gfc_new = s->old_symbol->gfc_new; + free_old_symbol (s); + } + else + restore_old_symbol (s->old_symbol); + break; + } + } + + latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms); + latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps); + + pop_undo_change_set (latest_undo_chgset); +} + + +/* Undoes all the changes made to symbols since the previous checkpoint. + This subroutine is made simpler due to the fact that attributes are + never removed once added. */ + +void +gfc_restore_last_undo_checkpoint (void) +{ + gfc_symbol *p; + unsigned i; + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) + { + /* Symbol in a common block was new. Or was old and just put in common */ + if (p->common_block + && (p->gfc_new || !p->old_symbol->common_block)) + { + /* If the symbol was added to any common block, it + needs to be removed to stop the resolver looking + for a (possibly) dead symbol. */ + if (p->common_block->head == p && !p->common_next) + { + gfc_symtree st, *st0; + st0 = find_common_symtree (p->ns->common_root, + p->common_block); + if (st0) + { + st.name = st0->name; + gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree); + free (st0); + } + } + + if (p->common_block->head == p) + p->common_block->head = p->common_next; + else + { + gfc_symbol *cparent, *csym; + + cparent = p->common_block->head; + csym = cparent->common_next; + + while (csym != p) + { + cparent = csym; + csym = csym->common_next; + } + + gcc_assert(cparent->common_next == p); + cparent->common_next = csym->common_next; + } + p->common_next = NULL; + } + if (p->gfc_new) + { + /* The derived type is saved in the symtree with the first + letter capitalized; the all lower-case version to the + derived type contains its associated generic function. */ + if (gfc_fl_struct (p->attr.flavor)) + gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name)); + else + gfc_delete_symtree (&p->ns->sym_root, p->name); + + gfc_release_symbol (p); + } + else + restore_old_symbol (p); + } + + latest_undo_chgset->syms.truncate (0); + latest_undo_chgset->tbps.truncate (0); + + if (!single_undo_checkpoint_p ()) + pop_undo_change_set (latest_undo_chgset); +} + + +/* Makes sure that there is only one set of changes; in other words we haven't + forgotten to pair a call to gfc_new_checkpoint with a call to either + gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */ + +static void +enforce_single_undo_checkpoint (void) +{ + gcc_checking_assert (single_undo_checkpoint_p ()); +} + + +/* Undoes all the changes made to symbols in the current statement. */ + +void +gfc_undo_symbols (void) +{ + enforce_single_undo_checkpoint (); + gfc_restore_last_undo_checkpoint (); +} + + +/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the + components of old_symbol that might need deallocation are the "allocatables" + that are restored in gfc_undo_symbols(), with two exceptions: namelist and + namelist_tail. In case these differ between old_symbol and sym, it's just + because sym->namelist has gotten a few more items. */ + +static void +free_old_symbol (gfc_symbol *sym) +{ + + if (sym->old_symbol == NULL) + return; + + if (sym->old_symbol->as != sym->as) + gfc_free_array_spec (sym->old_symbol->as); + + if (sym->old_symbol->value != sym->value) + gfc_free_expr (sym->old_symbol->value); + + if (sym->old_symbol->formal != sym->formal) + gfc_free_formal_arglist (sym->old_symbol->formal); + + free (sym->old_symbol); + sym->old_symbol = NULL; +} + + +/* Makes the changes made in the current statement permanent-- gets + rid of undo information. */ + +void +gfc_commit_symbols (void) +{ + gfc_symbol *p; + gfc_typebound_proc *tbp; + unsigned i; + + enforce_single_undo_checkpoint (); + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) + { + p->mark = 0; + p->gfc_new = 0; + free_old_symbol (p); + } + latest_undo_chgset->syms.truncate (0); + + FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp) + tbp->error = 0; + latest_undo_chgset->tbps.truncate (0); +} + + +/* Makes the changes made in one symbol permanent -- gets rid of undo + information. */ + +void +gfc_commit_symbol (gfc_symbol *sym) +{ + gfc_symbol *p; + unsigned i; + + enforce_single_undo_checkpoint (); + + FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) + if (p == sym) + { + latest_undo_chgset->syms.unordered_remove (i); + break; + } + + sym->mark = 0; + sym->gfc_new = 0; + + free_old_symbol (sym); +} + + +/* Recursively free trees containing type-bound procedures. */ + +static void +free_tb_tree (gfc_symtree *t) +{ + if (t == NULL) + return; + + free_tb_tree (t->left); + free_tb_tree (t->right); + + /* TODO: Free type-bound procedure u.generic */ + free (t->n.tb); + t->n.tb = NULL; + free (t); +} + + +/* Recursive function that deletes an entire tree and all the common + head structures it points to. */ + +static void +free_common_tree (gfc_symtree * common_tree) +{ + if (common_tree == NULL) + return; + + free_common_tree (common_tree->left); + free_common_tree (common_tree->right); + + free (common_tree); +} + + +/* Recursive function that deletes an entire tree and all the common + head structures it points to. */ + +static void +free_omp_udr_tree (gfc_symtree * omp_udr_tree) +{ + if (omp_udr_tree == NULL) + return; + + free_omp_udr_tree (omp_udr_tree->left); + free_omp_udr_tree (omp_udr_tree->right); + + gfc_free_omp_udr (omp_udr_tree->n.omp_udr); + free (omp_udr_tree); +} + + +/* Recursive function that deletes an entire tree and all the user + operator nodes that it contains. */ + +static void +free_uop_tree (gfc_symtree *uop_tree) +{ + if (uop_tree == NULL) + return; + + free_uop_tree (uop_tree->left); + free_uop_tree (uop_tree->right); + + gfc_free_interface (uop_tree->n.uop->op); + free (uop_tree->n.uop); + free (uop_tree); +} + + +/* Recursive function that deletes an entire tree and all the symbols + that it contains. */ + +static void +free_sym_tree (gfc_symtree *sym_tree) +{ + if (sym_tree == NULL) + return; + + free_sym_tree (sym_tree->left); + free_sym_tree (sym_tree->right); + + gfc_release_symbol (sym_tree->n.sym); + free (sym_tree); +} + + +/* Free the gfc_equiv_info's. */ + +static void +gfc_free_equiv_infos (gfc_equiv_info *s) +{ + if (s == NULL) + return; + gfc_free_equiv_infos (s->next); + free (s); +} + + +/* Free the gfc_equiv_lists. */ + +static void +gfc_free_equiv_lists (gfc_equiv_list *l) +{ + if (l == NULL) + return; + gfc_free_equiv_lists (l->next); + gfc_free_equiv_infos (l->equiv); + free (l); +} + + +/* Free a finalizer procedure list. */ + +void +gfc_free_finalizer (gfc_finalizer* el) +{ + if (el) + { + gfc_release_symbol (el->proc_sym); + free (el); + } +} + +static void +gfc_free_finalizer_list (gfc_finalizer* list) +{ + while (list) + { + gfc_finalizer* current = list; + list = list->next; + gfc_free_finalizer (current); + } +} + + +/* Create a new gfc_charlen structure and add it to a namespace. + If 'old_cl' is given, the newly created charlen will be a copy of it. */ + +gfc_charlen* +gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl) +{ + gfc_charlen *cl; + + cl = gfc_get_charlen (); + + /* Copy old_cl. */ + if (old_cl) + { + cl->length = gfc_copy_expr (old_cl->length); + cl->length_from_typespec = old_cl->length_from_typespec; + cl->backend_decl = old_cl->backend_decl; + cl->passed_length = old_cl->passed_length; + cl->resolved = old_cl->resolved; + } + + /* Put into namespace. */ + cl->next = ns->cl_list; + ns->cl_list = cl; + + return cl; +} + + +/* Free the charlen list from cl to end (end is not freed). + Free the whole list if end is NULL. */ + +static void +gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end) +{ + gfc_charlen *cl2; + + for (; cl != end; cl = cl2) + { + gcc_assert (cl); + + cl2 = cl->next; + gfc_free_expr (cl->length); + free (cl); + } +} + + +/* Free entry list structs. */ + +static void +free_entry_list (gfc_entry_list *el) +{ + gfc_entry_list *next; + + if (el == NULL) + return; + + next = el->next; + free (el); + free_entry_list (next); +} + + +/* Free a namespace structure and everything below it. Interface + lists associated with intrinsic operators are not freed. These are + taken care of when a specific name is freed. */ + +void +gfc_free_namespace (gfc_namespace *&ns) +{ + gfc_namespace *p, *q; + int i; + gfc_was_finalized *f; + + if (ns == NULL) + return; + + ns->refs--; + if (ns->refs > 0) + return; + + gcc_assert (ns->refs == 0); + + gfc_free_statements (ns->code); + + free_sym_tree (ns->sym_root); + free_uop_tree (ns->uop_root); + free_common_tree (ns->common_root); + free_omp_udr_tree (ns->omp_udr_root); + free_tb_tree (ns->tb_sym_root); + free_tb_tree (ns->tb_uop_root); + gfc_free_finalizer_list (ns->finalizers); + gfc_free_omp_declare_simd_list (ns->omp_declare_simd); + gfc_free_omp_declare_variant_list (ns->omp_declare_variant); + gfc_free_charlen (ns->cl_list, NULL); + free_st_labels (ns->st_labels); + + free_entry_list (ns->entries); + gfc_free_equiv (ns->equiv); + gfc_free_equiv_lists (ns->equiv_lists); + gfc_free_use_stmts (ns->use_stmts); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + gfc_free_interface (ns->op[i]); + + gfc_free_data (ns->data); + + /* Free all the expr + component combinations that have been + finalized. */ + f = ns->was_finalized; + while (f) + { + gfc_was_finalized* current = f; + f = f->next; + free (current); + } + + p = ns->contained; + free (ns); + ns = NULL; + + /* Recursively free any contained namespaces. */ + while (p != NULL) + { + q = p; + p = p->sibling; + gfc_free_namespace (q); + } +} + + +void +gfc_symbol_init_2 (void) +{ + + gfc_current_ns = gfc_get_namespace (NULL, 0); +} + + +void +gfc_symbol_done_2 (void) +{ + if (gfc_current_ns != NULL) + { + /* free everything from the root. */ + while (gfc_current_ns->parent != NULL) + gfc_current_ns = gfc_current_ns->parent; + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = NULL; + } + gfc_derived_types = NULL; + + enforce_single_undo_checkpoint (); + free_undo_change_set_data (*latest_undo_chgset); +} + + +/* Count how many nodes a symtree has. */ + +static unsigned +count_st_nodes (const gfc_symtree *st) +{ + unsigned nodes; + if (!st) + return 0; + + nodes = count_st_nodes (st->left); + nodes++; + nodes += count_st_nodes (st->right); + + return nodes; +} + + +/* Convert symtree tree into symtree vector. */ + +static unsigned +fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr) +{ + if (!st) + return node_cntr; + + node_cntr = fill_st_vector (st->left, st_vec, node_cntr); + st_vec[node_cntr++] = st; + node_cntr = fill_st_vector (st->right, st_vec, node_cntr); + + return node_cntr; +} + + +/* Traverse namespace. As the functions might modify the symtree, we store the + symtree as a vector and operate on this vector. Note: We assume that + sym_func or st_func never deletes nodes from the symtree - only adding is + allowed. Additionally, newly added nodes are not traversed. */ + +static void +do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *), + void (*sym_func) (gfc_symbol *)) +{ + gfc_symtree **st_vec; + unsigned nodes, i, node_cntr; + + gcc_assert ((st_func && !sym_func) || (!st_func && sym_func)); + nodes = count_st_nodes (st); + st_vec = XALLOCAVEC (gfc_symtree *, nodes); + node_cntr = 0; + fill_st_vector (st, st_vec, node_cntr); + + if (sym_func) + { + /* Clear marks. */ + for (i = 0; i < nodes; i++) + st_vec[i]->n.sym->mark = 0; + for (i = 0; i < nodes; i++) + if (!st_vec[i]->n.sym->mark) + { + (*sym_func) (st_vec[i]->n.sym); + st_vec[i]->n.sym->mark = 1; + } + } + else + for (i = 0; i < nodes; i++) + (*st_func) (st_vec[i]); +} + + +/* Recursively traverse the symtree nodes. */ + +void +gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *)) +{ + do_traverse_symtree (st, st_func, NULL); +} + + +/* Call a given function for all symbols in the namespace. We take + care that each gfc_symbol node is called exactly once. */ + +void +gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *)) +{ + do_traverse_symtree (ns->sym_root, NULL, sym_func); +} + + +/* Return TRUE when name is the name of an intrinsic type. */ + +bool +gfc_is_intrinsic_typename (const char *name) +{ + if (strcmp (name, "integer") == 0 + || strcmp (name, "real") == 0 + || strcmp (name, "character") == 0 + || strcmp (name, "logical") == 0 + || strcmp (name, "complex") == 0 + || strcmp (name, "doubleprecision") == 0 + || strcmp (name, "doublecomplex") == 0) + return true; + else + return false; +} + + +/* Return TRUE if the symbol is an automatic variable. */ + +static bool +gfc_is_var_automatic (gfc_symbol *sym) +{ + /* Pointer and allocatable variables are never automatic. */ + if (sym->attr.pointer || sym->attr.allocatable) + return false; + /* Check for arrays with non-constant size. */ + if (sym->attr.dimension && sym->as + && !gfc_is_compile_time_shape (sym->as)) + return true; + /* Check for non-constant length character variables. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl + && !gfc_is_constant_expr (sym->ts.u.cl->length)) + return true; + /* Variables with explicit AUTOMATIC attribute. */ + if (sym->attr.automatic) + return true; + + return false; +} + +/* Given a symbol, mark it as SAVEd if it is allowed. */ + +static void +save_symbol (gfc_symbol *sym) +{ + + if (sym->attr.use_assoc) + return; + + if (sym->attr.in_common + || sym->attr.in_equivalence + || sym->attr.dummy + || sym->attr.result + || sym->attr.flavor != FL_VARIABLE) + return; + /* Automatic objects are not saved. */ + if (gfc_is_var_automatic (sym)) + return; + gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at); +} + + +/* Mark those symbols which can be SAVEd as such. */ + +void +gfc_save_all (gfc_namespace *ns) +{ + gfc_traverse_ns (ns, save_symbol); +} + + +/* Make sure that no changes to symbols are pending. */ + +void +gfc_enforce_clean_symbol_state(void) +{ + enforce_single_undo_checkpoint (); + gcc_assert (latest_undo_chgset->syms.is_empty ()); +} + + +/************** Global symbol handling ************/ + + +/* Search a tree for the global symbol. */ + +gfc_gsymbol * +gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) +{ + int c; + + if (symbol == NULL) + return NULL; + + while (symbol) + { + c = strcmp (name, symbol->name); + if (!c) + return symbol; + + symbol = (c < 0) ? symbol->left : symbol->right; + } + + return NULL; +} + + +/* Case insensitive search a tree for the global symbol. */ + +gfc_gsymbol * +gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name) +{ + int c; + + if (symbol == NULL) + return NULL; + + while (symbol) + { + c = strcasecmp (name, symbol->name); + if (!c) + return symbol; + + symbol = (c < 0) ? symbol->left : symbol->right; + } + + return NULL; +} + + +/* Compare two global symbols. Used for managing the BB tree. */ + +static int +gsym_compare (void *_s1, void *_s2) +{ + gfc_gsymbol *s1, *s2; + + s1 = (gfc_gsymbol *) _s1; + s2 = (gfc_gsymbol *) _s2; + return strcmp (s1->name, s2->name); +} + + +/* Get a global symbol, creating it if it doesn't exist. */ + +gfc_gsymbol * +gfc_get_gsymbol (const char *name, bool bind_c) +{ + gfc_gsymbol *s; + + s = gfc_find_gsymbol (gfc_gsym_root, name); + if (s != NULL) + return s; + + s = XCNEW (gfc_gsymbol); + s->type = GSYM_UNKNOWN; + s->name = gfc_get_string ("%s", name); + s->bind_c = bind_c; + + gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare); + + return s; +} + +void +gfc_traverse_gsymbol (gfc_gsymbol *gsym, + void (*do_something) (gfc_gsymbol *, void *), + void *data) +{ + if (gsym->left) + gfc_traverse_gsymbol (gsym->left, do_something, data); + + (*do_something) (gsym, data); + + if (gsym->right) + gfc_traverse_gsymbol (gsym->right, do_something, data); +} + +static gfc_symbol * +get_iso_c_binding_dt (int sym_id) +{ + gfc_symbol *dt_list = gfc_derived_types; + + /* Loop through the derived types in the name list, searching for + the desired symbol from iso_c_binding. Search the parent namespaces + if necessary and requested to (parent_flag). */ + if (dt_list) + { + while (dt_list->dt_next != gfc_derived_types) + { + if (dt_list->from_intmod != INTMOD_NONE + && dt_list->intmod_sym_id == sym_id) + return dt_list; + + dt_list = dt_list->dt_next; + } + } + + return NULL; +} + + +/* Verifies that the given derived type symbol, derived_sym, is interoperable + with C. This is necessary for any derived type that is BIND(C) and for + derived types that are parameters to functions that are BIND(C). All + fields of the derived type are required to be interoperable, and are tested + for such. If an error occurs, the errors are reported here, allowing for + multiple errors to be handled for a single derived type. */ + +bool +verify_bind_c_derived_type (gfc_symbol *derived_sym) +{ + gfc_component *curr_comp = NULL; + bool is_c_interop = false; + bool retval = true; + + if (derived_sym == NULL) + gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is " + "unexpectedly NULL"); + + /* If we've already looked at this derived symbol, do not look at it again + so we don't repeat warnings/errors. */ + if (derived_sym->ts.is_c_interop) + return true; + + /* The derived type must have the BIND attribute to be interoperable + J3/04-007, Section 15.2.3. */ + if (derived_sym->attr.is_bind_c != 1) + { + derived_sym->ts.is_c_interop = 0; + gfc_error_now ("Derived type %qs declared at %L must have the BIND " + "attribute to be C interoperable", derived_sym->name, + &(derived_sym->declared_at)); + retval = false; + } + + curr_comp = derived_sym->components; + + /* Fortran 2003 allows an empty derived type. C99 appears to disallow an + empty struct. Section 15.2 in Fortran 2003 states: "The following + subclauses define the conditions under which a Fortran entity is + interoperable. If a Fortran entity is interoperable, an equivalent + entity may be defined by means of C and the Fortran entity is said + to be interoperable with the C entity. There does not have to be such + an interoperating C entity." + */ + if (curr_comp == NULL) + { + gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, " + "and may be inaccessible by the C companion processor", + derived_sym->name, &(derived_sym->declared_at)); + derived_sym->ts.is_c_interop = 1; + derived_sym->attr.is_bind_c = 1; + return true; + } + + + /* Initialize the derived type as being C interoperable. + If we find an error in the components, this will be set false. */ + derived_sym->ts.is_c_interop = 1; + + /* Loop through the list of components to verify that the kind of + each is a C interoperable type. */ + do + { + /* The components cannot be pointers (fortran sense). + J3/04-007, Section 15.2.3, C1505. */ + if (curr_comp->attr.pointer != 0) + { + gfc_error ("Component %qs at %L cannot have the " + "POINTER attribute because it is a member " + "of the BIND(C) derived type %qs at %L", + curr_comp->name, &(curr_comp->loc), + derived_sym->name, &(derived_sym->declared_at)); + retval = false; + } + + if (curr_comp->attr.proc_pointer != 0) + { + gfc_error ("Procedure pointer component %qs at %L cannot be a member" + " of the BIND(C) derived type %qs at %L", curr_comp->name, + &curr_comp->loc, derived_sym->name, + &derived_sym->declared_at); + retval = false; + } + + /* The components cannot be allocatable. + J3/04-007, Section 15.2.3, C1505. */ + if (curr_comp->attr.allocatable != 0) + { + gfc_error ("Component %qs at %L cannot have the " + "ALLOCATABLE attribute because it is a member " + "of the BIND(C) derived type %qs at %L", + curr_comp->name, &(curr_comp->loc), + derived_sym->name, &(derived_sym->declared_at)); + retval = false; + } + + /* BIND(C) derived types must have interoperable components. */ + if (curr_comp->ts.type == BT_DERIVED + && curr_comp->ts.u.derived->ts.is_iso_c != 1 + && curr_comp->ts.u.derived != derived_sym) + { + /* This should be allowed; the draft says a derived-type cannot + have type parameters if it is has the BIND attribute. Type + parameters seem to be for making parameterized derived types. + There's no need to verify the type if it is c_ptr/c_funptr. */ + retval = verify_bind_c_derived_type (curr_comp->ts.u.derived); + } + else + { + /* Grab the typespec for the given component and test the kind. */ + is_c_interop = gfc_verify_c_interop (&(curr_comp->ts)); + + if (!is_c_interop) + { + /* Report warning and continue since not fatal. The + draft does specify a constraint that requires all fields + to interoperate, but if the user says real(4), etc., it + may interoperate with *something* in C, but the compiler + most likely won't know exactly what. Further, it may not + interoperate with the same data type(s) in C if the user + recompiles with different flags (e.g., -m32 and -m64 on + x86_64 and using integer(4) to claim interop with a + C_LONG). */ + if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type) + /* If the derived type is bind(c), all fields must be + interop. */ + gfc_warning (OPT_Wc_binding_type, + "Component %qs in derived type %qs at %L " + "may not be C interoperable, even though " + "derived type %qs is BIND(C)", + curr_comp->name, derived_sym->name, + &(curr_comp->loc), derived_sym->name); + else if (warn_c_binding_type) + /* If derived type is param to bind(c) routine, or to one + of the iso_c_binding procs, it must be interoperable, so + all fields must interop too. */ + gfc_warning (OPT_Wc_binding_type, + "Component %qs in derived type %qs at %L " + "may not be C interoperable", + curr_comp->name, derived_sym->name, + &(curr_comp->loc)); + } + } + + curr_comp = curr_comp->next; + } while (curr_comp != NULL); + + if (derived_sym->attr.sequence != 0) + { + gfc_error ("Derived type %qs at %L cannot have the SEQUENCE " + "attribute because it is BIND(C)", derived_sym->name, + &(derived_sym->declared_at)); + retval = false; + } + + /* Mark the derived type as not being C interoperable if we found an + error. If there were only warnings, proceed with the assumption + it's interoperable. */ + if (!retval) + derived_sym->ts.is_c_interop = 0; + + return retval; +} + + +/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */ + +static bool +gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree) +{ + gfc_constructor *c; + + gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym); + dt_symtree->n.sym->attr.referenced = 1; + + tmp_sym->attr.is_c_interop = 1; + tmp_sym->attr.is_bind_c = 1; + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + tmp_sym->ts.type = BT_DERIVED; + tmp_sym->ts.f90_type = BT_VOID; + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.u.derived = dt_symtree->n.sym; + + /* Set the c_address field of c_null_ptr and c_null_funptr to + the value of NULL. */ + tmp_sym->value = gfc_get_expr (); + tmp_sym->value->expr_type = EXPR_STRUCTURE; + tmp_sym->value->ts.type = BT_DERIVED; + tmp_sym->value->ts.f90_type = BT_VOID; + tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; + gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL); + c = gfc_constructor_first (tmp_sym->value->value.constructor); + c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + c->expr->ts.is_iso_c = 1; + + return true; +} + + +/* Add a formal argument, gfc_formal_arglist, to the + end of the given list of arguments. Set the reference to the + provided symbol, param_sym, in the argument. */ + +static void +add_formal_arg (gfc_formal_arglist **head, + gfc_formal_arglist **tail, + gfc_formal_arglist *formal_arg, + gfc_symbol *param_sym) +{ + /* Put in list, either as first arg or at the tail (curr arg). */ + if (*head == NULL) + *head = *tail = formal_arg; + else + { + (*tail)->next = formal_arg; + (*tail) = formal_arg; + } + + (*tail)->sym = param_sym; + (*tail)->next = NULL; + + return; +} + + +/* Add a procedure interface to the given symbol (i.e., store a + reference to the list of formal arguments). */ + +static void +add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal) +{ + + sym->formal = formal; + sym->attr.if_source = source; +} + + +/* Copy the formal args from an existing symbol, src, into a new + symbol, dest. New formal args are created, and the description of + each arg is set according to the existing ones. This function is + used when creating procedure declaration variables from a procedure + declaration statement (see match_proc_decl()) to create the formal + args based on the args of a given named interface. + + When an actual argument list is provided, skip the absent arguments + unless copy_type is true. + To be used together with gfc_se->ignore_optional. */ + +void +gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src, + gfc_actual_arglist *actual, bool copy_type) +{ + gfc_formal_arglist *head = NULL; + gfc_formal_arglist *tail = NULL; + gfc_formal_arglist *formal_arg = NULL; + gfc_intrinsic_arg *curr_arg = NULL; + gfc_formal_arglist *formal_prev = NULL; + gfc_actual_arglist *act_arg = actual; + /* Save current namespace so we can change it for formal args. */ + gfc_namespace *parent_ns = gfc_current_ns; + + /* Create a new namespace, which will be the formal ns (namespace + of the formal args). */ + gfc_current_ns = gfc_get_namespace (parent_ns, 0); + gfc_current_ns->proc_name = dest; + + for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) + { + /* Skip absent arguments. */ + if (actual) + { + gcc_assert (act_arg != NULL); + if (act_arg->expr == NULL) + { + act_arg = act_arg->next; + continue; + } + } + formal_arg = gfc_get_formal_arglist (); + gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym)); + + /* May need to copy more info for the symbol. */ + if (copy_type && act_arg->expr != NULL) + { + formal_arg->sym->ts = act_arg->expr->ts; + if (act_arg->expr->rank > 0) + { + formal_arg->sym->attr.dimension = 1; + formal_arg->sym->as = gfc_get_array_spec(); + formal_arg->sym->as->rank = -1; + formal_arg->sym->as->type = AS_ASSUMED_RANK; + } + if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0) + formal_arg->sym->pass_as_value = 1; + } + else + formal_arg->sym->ts = curr_arg->ts; + + formal_arg->sym->attr.optional = curr_arg->optional; + formal_arg->sym->attr.value = curr_arg->value; + formal_arg->sym->attr.intent = curr_arg->intent; + formal_arg->sym->attr.flavor = FL_VARIABLE; + formal_arg->sym->attr.dummy = 1; + + if (formal_arg->sym->ts.type == BT_CHARACTER) + formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + + /* If this isn't the first arg, set up the next ptr. For the + last arg built, the formal_arg->next will never get set to + anything other than NULL. */ + if (formal_prev != NULL) + formal_prev->next = formal_arg; + else + formal_arg->next = NULL; + + formal_prev = formal_arg; + + /* Add arg to list of formal args. */ + add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); + + /* Validate changes. */ + gfc_commit_symbol (formal_arg->sym); + if (actual) + act_arg = act_arg->next; + } + + /* Add the interface to the symbol. */ + add_proc_interface (dest, IFSRC_DECL, head); + + /* Store the formal namespace information. */ + if (dest->formal != NULL) + /* The current ns should be that for the dest proc. */ + dest->formal_ns = gfc_current_ns; + /* Restore the current namespace to what it was on entry. */ + gfc_current_ns = parent_ns; +} + + +static int +std_for_isocbinding_symbol (int id) +{ + switch (id) + { +#define NAMED_INTCST(a,b,c,d) \ + case a:\ + return d; +#include "iso-c-binding.def" +#undef NAMED_INTCST + +#define NAMED_FUNCTION(a,b,c,d) \ + case a:\ + return d; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a:\ + return d; +#include "iso-c-binding.def" +#undef NAMED_FUNCTION +#undef NAMED_SUBROUTINE + + default: + return GFC_STD_F2003; + } +} + +/* Generate the given set of C interoperable kind objects, or all + interoperable kinds. This function will only be given kind objects + for valid iso_c_binding defined types because this is verified when + the 'use' statement is parsed. If the user gives an 'only' clause, + the specific kinds are looked up; if they don't exist, an error is + reported. If the user does not give an 'only' clause, all + iso_c_binding symbols are generated. If a list of specific kinds + is given, it must have a NULL in the first empty spot to mark the + end of the list. For C_null_(fun)ptr, dt_symtree has to be set and + point to the symtree for c_(fun)ptr. */ + +gfc_symtree * +generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, + const char *local_name, gfc_symtree *dt_symtree, + bool hidden) +{ + const char *const name = (local_name && local_name[0]) + ? local_name : c_interop_kinds_table[s].name; + gfc_symtree *tmp_symtree; + gfc_symbol *tmp_sym = NULL; + int index; + + if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR) + return NULL; + + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (hidden + && (!tmp_symtree || !tmp_symtree->n.sym + || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING + || tmp_symtree->n.sym->intmod_sym_id != s)) + tmp_symtree = NULL; + + /* Already exists in this scope so don't re-add it. */ + if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL + && (!tmp_sym->attr.generic + || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL) + && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING) + { + if (tmp_sym->attr.flavor == FL_DERIVED + && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id)) + { + if (gfc_derived_types) + { + tmp_sym->dt_next = gfc_derived_types->dt_next; + gfc_derived_types->dt_next = tmp_sym; + } + else + { + tmp_sym->dt_next = tmp_sym; + } + gfc_derived_types = tmp_sym; + } + + return tmp_symtree; + } + + /* Create the sym tree in the current ns. */ + if (hidden) + { + tmp_symtree = gfc_get_unique_symtree (gfc_current_ns); + tmp_sym = gfc_new_symbol (name, gfc_current_ns); + + /* Add to the list of tentative symbols. */ + latest_undo_chgset->syms.safe_push (tmp_sym); + tmp_sym->old_symbol = NULL; + tmp_sym->mark = 1; + tmp_sym->gfc_new = 1; + + tmp_symtree->n.sym = tmp_sym; + tmp_sym->refs++; + } + else + { + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + gcc_assert (tmp_symtree); + tmp_sym = tmp_symtree->n.sym; + } + + /* Say what module this symbol belongs to. */ + tmp_sym->module = gfc_get_string ("%s", mod_name); + tmp_sym->from_intmod = INTMOD_ISO_C_BINDING; + tmp_sym->intmod_sym_id = s; + tmp_sym->attr.is_iso_c = 1; + tmp_sym->attr.use_assoc = 1; + + gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR + || s == ISOCBINDING_NULL_PTR); + + switch (s) + { + +#define NAMED_INTCST(a,b,c,d) case a : +#define NAMED_REALCST(a,b,c,d) case a : +#define NAMED_CMPXCST(a,b,c,d) case a : +#define NAMED_LOGCST(a,b,c) case a : +#define NAMED_CHARKNDCST(a,b,c) case a : +#include "iso-c-binding.def" + + tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, + c_interop_kinds_table[s].value); + + /* Initialize an integer constant expression node. */ + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.type = BT_INTEGER; + tmp_sym->ts.kind = gfc_default_integer_kind; + + /* Mark this type as a C interoperable one. */ + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + tmp_sym->value->ts.is_c_interop = 1; + tmp_sym->value->ts.is_iso_c = 1; + tmp_sym->attr.is_c_interop = 1; + + /* Tell what f90 type this c interop kind is valid. */ + tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type; + + break; + + +#define NAMED_CHARCST(a,b,c) case a : +#include "iso-c-binding.def" + + /* Initialize an integer constant expression node for the + length of the character. */ + tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind, + &gfc_current_locus, NULL, 1); + tmp_sym->value->ts.is_c_interop = 1; + tmp_sym->value->ts.is_iso_c = 1; + tmp_sym->value->value.character.length = 1; + tmp_sym->value->value.character.string[0] + = (gfc_char_t) c_interop_kinds_table[s].value; + tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, + NULL, 1); + + /* May not need this in both attr and ts, but do need in + attr for writing module file. */ + tmp_sym->attr.is_c_interop = 1; + + tmp_sym->attr.flavor = FL_PARAMETER; + tmp_sym->ts.type = BT_CHARACTER; + + /* Need to set it to the C_CHAR kind. */ + tmp_sym->ts.kind = gfc_default_character_kind; + + /* Mark this type as a C interoperable one. */ + tmp_sym->ts.is_c_interop = 1; + tmp_sym->ts.is_iso_c = 1; + + /* Tell what f90 type this c interop kind is valid. */ + tmp_sym->ts.f90_type = BT_CHARACTER; + + break; + + case ISOCBINDING_PTR: + case ISOCBINDING_FUNPTR: + { + gfc_symbol *dt_sym; + gfc_component *tmp_comp = NULL; + + /* Generate real derived type. */ + if (hidden) + dt_sym = tmp_sym; + else + { + const char *hidden_name; + gfc_interface *intr, *head; + + hidden_name = gfc_dt_upper_string (tmp_sym->name); + tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, + hidden_name); + gcc_assert (tmp_symtree == NULL); + gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false); + dt_sym = tmp_symtree->n.sym; + dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR + ? "c_ptr" : "c_funptr"); + + /* Generate an artificial generic function. */ + head = tmp_sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + tmp_sym->generic = intr; + + if (!tmp_sym->attr.generic + && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)) + return NULL; + + if (!tmp_sym->attr.function + && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)) + return NULL; + } + + /* Say what module this symbol belongs to. */ + dt_sym->module = gfc_get_string ("%s", mod_name); + dt_sym->from_intmod = INTMOD_ISO_C_BINDING; + dt_sym->intmod_sym_id = s; + dt_sym->attr.use_assoc = 1; + + /* Initialize an integer constant expression node. */ + dt_sym->attr.flavor = FL_DERIVED; + dt_sym->ts.is_c_interop = 1; + dt_sym->attr.is_c_interop = 1; + dt_sym->attr.private_comp = 1; + dt_sym->component_access = ACCESS_PRIVATE; + dt_sym->ts.is_iso_c = 1; + dt_sym->ts.type = BT_DERIVED; + dt_sym->ts.f90_type = BT_VOID; + + /* A derived type must have the bind attribute to be + interoperable (J3/04-007, Section 15.2.3), even though + the binding label is not used. */ + dt_sym->attr.is_bind_c = 1; + + dt_sym->attr.referenced = 1; + dt_sym->ts.u.derived = dt_sym; + + /* Add the symbol created for the derived type to the current ns. */ + if (gfc_derived_types) + { + dt_sym->dt_next = gfc_derived_types->dt_next; + gfc_derived_types->dt_next = dt_sym; + } + else + { + dt_sym->dt_next = dt_sym; + } + gfc_derived_types = dt_sym; + + gfc_add_component (dt_sym, "c_address", &tmp_comp); + if (tmp_comp == NULL) + gcc_unreachable (); + + tmp_comp->ts.type = BT_INTEGER; + + /* Set this because the module will need to read/write this field. */ + tmp_comp->ts.f90_type = BT_INTEGER; + + /* The kinds for c_ptr and c_funptr are the same. */ + index = get_c_kind ("c_ptr", c_interop_kinds_table); + tmp_comp->ts.kind = c_interop_kinds_table[index].value; + tmp_comp->attr.access = ACCESS_PRIVATE; + + /* Mark the component as C interoperable. */ + tmp_comp->ts.is_c_interop = 1; + } + + break; + + case ISOCBINDING_NULL_PTR: + case ISOCBINDING_NULL_FUNPTR: + gen_special_c_interop_ptr (tmp_sym, dt_symtree); + break; + + default: + gcc_unreachable (); + } + gfc_commit_symbol (tmp_sym); + return tmp_symtree; +} + + +/* Check that a symbol is already typed. If strict is not set, an untyped + symbol is acceptable for non-standard-conforming mode. */ + +bool +gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, + bool strict, locus where) +{ + gcc_assert (sym); + + if (gfc_matching_prefix) + return true; + + /* Check for the type and try to give it an implicit one. */ + if (sym->ts.type == BT_UNKNOWN + && !gfc_set_default_type (sym, 0, ns)) + { + if (strict) + { + gfc_error ("Symbol %qs is used before it is typed at %L", + sym->name, &where); + return false; + } + + if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before" + " it is typed at %L", sym->name, &where)) + return false; + } + + /* Everything is ok. */ + return true; +} + + +/* Construct a typebound-procedure structure. Those are stored in a tentative + list and marked `error' until symbols are committed. */ + +gfc_typebound_proc* +gfc_get_typebound_proc (gfc_typebound_proc *tb0) +{ + gfc_typebound_proc *result; + + result = XCNEW (gfc_typebound_proc); + if (tb0) + *result = *tb0; + result->error = 1; + + latest_undo_chgset->tbps.safe_push (result); + + return result; +} + + +/* Get the super-type of a given derived type. */ + +gfc_symbol* +gfc_get_derived_super_type (gfc_symbol* derived) +{ + gcc_assert (derived); + + if (derived->attr.generic) + derived = gfc_find_dt_in_generic (derived); + + if (!derived->attr.extension) + return NULL; + + gcc_assert (derived->components); + gcc_assert (derived->components->ts.type == BT_DERIVED); + gcc_assert (derived->components->ts.u.derived); + + if (derived->components->ts.u.derived->attr.generic) + return gfc_find_dt_in_generic (derived->components->ts.u.derived); + + return derived->components->ts.u.derived; +} + + +/* Check if a derived type t2 is an extension of (or equal to) a type t1. */ + +bool +gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) +{ + while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension) + t2 = gfc_get_derived_super_type (t2); + return gfc_compare_derived_types (t1, t2); +} + + +/* Check if two typespecs are type compatible (F03:5.1.1.2): + If ts1 is nonpolymorphic, ts2 must be the same type. + If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */ + +bool +gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) +{ + bool is_class1 = (ts1->type == BT_CLASS); + bool is_class2 = (ts2->type == BT_CLASS); + bool is_derived1 = (ts1->type == BT_DERIVED); + bool is_derived2 = (ts2->type == BT_DERIVED); + bool is_union1 = (ts1->type == BT_UNION); + bool is_union2 = (ts2->type == BT_UNION); + + if (is_class1 + && ts1->u.derived->components + && ((ts1->u.derived->attr.is_class + && ts1->u.derived->components->ts.u.derived->attr + .unlimited_polymorphic) + || ts1->u.derived->attr.unlimited_polymorphic)) + return 1; + + if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2 + && !is_union1 && !is_union2) + return (ts1->type == ts2->type); + + if ((is_derived1 && is_derived2) || (is_union1 && is_union2)) + return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); + + if (is_derived1 && is_class2) + return gfc_compare_derived_types (ts1->u.derived, + ts2->u.derived->attr.is_class ? + ts2->u.derived->components->ts.u.derived + : ts2->u.derived); + if (is_class1 && is_derived2) + return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? + ts1->u.derived->components->ts.u.derived + : ts1->u.derived, + ts2->u.derived); + else if (is_class1 && is_class2) + return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? + ts1->u.derived->components->ts.u.derived + : ts1->u.derived, + ts2->u.derived->attr.is_class ? + ts2->u.derived->components->ts.u.derived + : ts2->u.derived); + else + return 0; +} + + +/* Find the parent-namespace of the current function. If we're inside + BLOCK constructs, it may not be the current one. */ + +gfc_namespace* +gfc_find_proc_namespace (gfc_namespace* ns) +{ + while (ns->construct_entities) + { + ns = ns->parent; + gcc_assert (ns); + } + + return ns; +} + + +/* Check if an associate-variable should be translated as an `implicit' pointer + internally (if it is associated to a variable and not an array with + descriptor). */ + +bool +gfc_is_associate_pointer (gfc_symbol* sym) +{ + if (!sym->assoc) + return false; + + if (sym->ts.type == BT_CLASS) + return true; + + if (sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && sym->assoc->target + && sym->assoc->target->expr_type == EXPR_FUNCTION) + return true; + + if (!sym->assoc->variable) + return false; + + if (sym->attr.dimension && sym->as->type != AS_EXPLICIT) + return false; + + return true; +} + + +gfc_symbol * +gfc_find_dt_in_generic (gfc_symbol *sym) +{ + gfc_interface *intr = NULL; + + if (!sym || gfc_fl_struct (sym->attr.flavor)) + return sym; + + if (sym->attr.generic) + for (intr = sym->generic; intr; intr = intr->next) + if (gfc_fl_struct (intr->sym->attr.flavor)) + break; + return intr ? intr->sym : NULL; +} + + +/* Get the dummy arguments from a procedure symbol. If it has been declared + via a PROCEDURE statement with a named interface, ts.interface will be set + and the arguments need to be taken from there. */ + +gfc_formal_arglist * +gfc_sym_get_dummy_args (gfc_symbol *sym) +{ + gfc_formal_arglist *dummies; + + if (sym == NULL) + return NULL; + + dummies = sym->formal; + if (dummies == NULL && sym->ts.interface != NULL) + dummies = sym->ts.interface->formal; + + return dummies; +} diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c deleted file mode 100644 index 9b5af8d..0000000 --- a/gcc/fortran/target-memory.c +++ /dev/null @@ -1,806 +0,0 @@ -/* Simulate storage of variables into target memory. - Copyright (C) 2007-2022 Free Software Foundation, Inc. - Contributed by Paul Thomas and Brooks Moses - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "gfortran.h" -#include "trans.h" -#include "fold-const.h" -#include "stor-layout.h" -#include "arith.h" -#include "constructor.h" -#include "trans-const.h" -#include "trans-types.h" -#include "target-memory.h" - -/* --------------------------------------------------------------- */ -/* Calculate the size of an expression. */ - - -static size_t -size_integer (int kind) -{ - return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind))); -} - - -static size_t -size_float (int kind) -{ - return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind))); -} - - -static size_t -size_complex (int kind) -{ - return 2 * size_float (kind); -} - - -static size_t -size_logical (int kind) -{ - return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind))); -} - - -static size_t -size_character (gfc_charlen_t length, int kind) -{ - int i = gfc_validate_kind (BT_CHARACTER, kind, false); - return length * gfc_character_kinds[i].bit_size / 8; -} - - -/* Return the size of a single element of the given expression. - Equivalent to gfc_target_expr_size for scalars. */ - -bool -gfc_element_size (gfc_expr *e, size_t *siz) -{ - tree type; - - switch (e->ts.type) - { - case BT_INTEGER: - *siz = size_integer (e->ts.kind); - return true; - case BT_REAL: - *siz = size_float (e->ts.kind); - return true; - case BT_COMPLEX: - *siz = size_complex (e->ts.kind); - return true; - case BT_LOGICAL: - *siz = size_logical (e->ts.kind); - return true; - case BT_CHARACTER: - if (e->expr_type == EXPR_CONSTANT) - *siz = size_character (e->value.character.length, e->ts.kind); - else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT - && e->ts.u.cl->length->ts.type == BT_INTEGER) - { - HOST_WIDE_INT length; - - gfc_extract_hwi (e->ts.u.cl->length, &length); - *siz = size_character (length, e->ts.kind); - } - else - { - *siz = 0; - return false; - } - return true; - - case BT_HOLLERITH: - *siz = e->representation.length; - return true; - case BT_DERIVED: - case BT_CLASS: - case BT_VOID: - case BT_ASSUMED: - case BT_PROCEDURE: - { - /* Determine type size without clobbering the typespec for ISO C - binding types. */ - gfc_typespec ts; - HOST_WIDE_INT size; - ts = e->ts; - type = gfc_typenode_for_spec (&ts); - size = int_size_in_bytes (type); - gcc_assert (size >= 0); - *siz = size; - } - return true; - default: - gfc_internal_error ("Invalid expression in gfc_element_size."); - *siz = 0; - return false; - } -} - - -/* Return the size of an expression in its target representation. */ - -bool -gfc_target_expr_size (gfc_expr *e, size_t *size) -{ - mpz_t tmp; - size_t asz, el_size; - - gcc_assert (e != NULL); - - *size = 0; - if (e->rank) - { - if (gfc_array_size (e, &tmp)) - asz = mpz_get_ui (tmp); - else - return false; - } - else - asz = 1; - - if (!gfc_element_size (e, &el_size)) - return false; - *size = asz * el_size; - return true; -} - - -/* The encode_* functions export a value into a buffer, and - return the number of bytes of the buffer that have been - used. */ - -static unsigned HOST_WIDE_INT -encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size) -{ - mpz_t array_size; - int i; - int ptr = 0; - - gfc_constructor_base ctor = expr->value.constructor; - - gfc_array_size (expr, &array_size); - for (i = 0; i < (int)mpz_get_ui (array_size); i++) - { - ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i), - &buffer[ptr], buffer_size - ptr); - } - - mpz_clear (array_size); - return ptr; -} - - -static int -encode_integer (int kind, mpz_t integer, unsigned char *buffer, - size_t buffer_size) -{ - return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind), - buffer, buffer_size); -} - - -static int -encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size) -{ - return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer, - buffer_size); -} - - -static int -encode_complex (int kind, mpc_t cmplx, - unsigned char *buffer, size_t buffer_size) -{ - int size; - size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size); - size += encode_float (kind, mpc_imagref (cmplx), - &buffer[size], buffer_size - size); - return size; -} - - -static int -encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size) -{ - return native_encode_expr (build_int_cst (gfc_get_logical_type (kind), - logical), - buffer, buffer_size); -} - - -size_t -gfc_encode_character (int kind, size_t length, const gfc_char_t *string, - unsigned char *buffer, size_t buffer_size) -{ - size_t elsize = size_character (1, kind); - tree type = gfc_get_char_type (kind); - - gcc_assert (buffer_size >= size_character (length, kind)); - - for (size_t i = 0; i < length; i++) - native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize], - elsize); - - return length; -} - - -static unsigned HOST_WIDE_INT -encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) -{ - gfc_constructor *c; - gfc_component *cmp; - int ptr; - tree type; - HOST_WIDE_INT size; - - type = gfc_typenode_for_spec (&source->ts); - - for (c = gfc_constructor_first (source->value.constructor), - cmp = source->ts.u.derived->components; - c; - c = gfc_constructor_next (c), cmp = cmp->next) - { - gcc_assert (cmp); - if (!c->expr) - continue; - ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) - + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; - - if (c->expr->expr_type == EXPR_NULL) - { - size = int_size_in_bytes (TREE_TYPE (cmp->backend_decl)); - gcc_assert (size >= 0); - memset (&buffer[ptr], 0, size); - } - else - gfc_target_encode_expr (c->expr, &buffer[ptr], - buffer_size - ptr); - } - - size = int_size_in_bytes (type); - gcc_assert (size >= 0); - return size; -} - - -/* Write a constant expression in binary form to a buffer. */ -unsigned HOST_WIDE_INT -gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, - size_t buffer_size) -{ - if (source == NULL) - return 0; - - if (source->expr_type == EXPR_ARRAY) - return encode_array (source, buffer, buffer_size); - - gcc_assert (source->expr_type == EXPR_CONSTANT - || source->expr_type == EXPR_STRUCTURE - || source->expr_type == EXPR_SUBSTRING); - - /* If we already have a target-memory representation, we use that rather - than recreating one. */ - if (source->representation.string) - { - memcpy (buffer, source->representation.string, - source->representation.length); - return source->representation.length; - } - - switch (source->ts.type) - { - case BT_INTEGER: - return encode_integer (source->ts.kind, source->value.integer, buffer, - buffer_size); - case BT_REAL: - return encode_float (source->ts.kind, source->value.real, buffer, - buffer_size); - case BT_COMPLEX: - return encode_complex (source->ts.kind, source->value.complex, - buffer, buffer_size); - case BT_LOGICAL: - return encode_logical (source->ts.kind, source->value.logical, buffer, - buffer_size); - case BT_CHARACTER: - if (source->expr_type == EXPR_CONSTANT || source->ref == NULL) - return gfc_encode_character (source->ts.kind, - source->value.character.length, - source->value.character.string, - buffer, buffer_size); - else - { - HOST_WIDE_INT start, end; - - gcc_assert (source->expr_type == EXPR_SUBSTRING); - gfc_extract_hwi (source->ref->u.ss.start, &start); - gfc_extract_hwi (source->ref->u.ss.end, &end); - return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0), - &source->value.character.string[start-1], - buffer, buffer_size); - } - - case BT_DERIVED: - if (source->ts.u.derived->ts.f90_type == BT_VOID) - { - gfc_constructor *c; - gcc_assert (source->expr_type == EXPR_STRUCTURE); - c = gfc_constructor_first (source->value.constructor); - gcc_assert (c->expr->expr_type == EXPR_CONSTANT - && c->expr->ts.type == BT_INTEGER); - return encode_integer (gfc_index_integer_kind, c->expr->value.integer, - buffer, buffer_size); - } - - return encode_derived (source, buffer, buffer_size); - default: - gfc_internal_error ("Invalid expression in gfc_target_encode_expr."); - return 0; - } -} - - -static size_t -interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) -{ - gfc_constructor_base base = NULL; - size_t array_size = 1; - size_t ptr = 0; - - /* Calculate array size from its shape and rank. */ - gcc_assert (result->rank > 0 && result->shape); - - for (int i = 0; i < result->rank; i++) - array_size *= mpz_get_ui (result->shape[i]); - - /* Iterate over array elements, producing constructors. */ - for (size_t i = 0; i < array_size; i++) - { - gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind, - &result->where); - e->ts = result->ts; - - if (e->ts.type == BT_CHARACTER) - e->value.character.length = result->value.character.length; - - gfc_constructor_append_expr (&base, e, &result->where); - - ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, - true); - } - - result->value.constructor = base; - return ptr; -} - - -int -gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size, - mpz_t integer) -{ - mpz_init (integer); - gfc_conv_tree_to_mpz (integer, - native_interpret_expr (gfc_get_int_type (kind), - buffer, buffer_size)); - return size_integer (kind); -} - - -int -gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size, - mpfr_t real) -{ - gfc_set_model_kind (kind); - mpfr_init (real); - gfc_conv_tree_to_mpfr (real, - native_interpret_expr (gfc_get_real_type (kind), - buffer, buffer_size)); - - return size_float (kind); -} - - -int -gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size, - mpc_t complex) -{ - int size; - size = gfc_interpret_float (kind, &buffer[0], buffer_size, - mpc_realref (complex)); - size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, - mpc_imagref (complex)); - return size; -} - - -int -gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size, - int *logical) -{ - tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer, - buffer_size); - *logical = wi::to_wide (t) == 0 ? 0 : 1; - return size_logical (kind); -} - - -size_t -gfc_interpret_character (unsigned char *buffer, size_t buffer_size, - gfc_expr *result) -{ - if (result->ts.u.cl && result->ts.u.cl->length) - result->value.character.length = - gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer); - - gcc_assert (buffer_size >= size_character (result->value.character.length, - result->ts.kind)); - result->value.character.string = - gfc_get_wide_string (result->value.character.length + 1); - - if (result->ts.kind == gfc_default_character_kind) - for (size_t i = 0; i < (size_t) result->value.character.length; i++) - result->value.character.string[i] = (gfc_char_t) buffer[i]; - else - { - mpz_t integer; - size_t bytes = size_character (1, result->ts.kind); - mpz_init (integer); - gcc_assert (bytes <= sizeof (unsigned long)); - - for (size_t i = 0; i < (size_t) result->value.character.length; i++) - { - gfc_conv_tree_to_mpz (integer, - native_interpret_expr (gfc_get_char_type (result->ts.kind), - &buffer[bytes*i], buffer_size-bytes*i)); - result->value.character.string[i] - = (gfc_char_t) mpz_get_ui (integer); - } - - mpz_clear (integer); - } - - result->value.character.string[result->value.character.length] = '\0'; - - return size_character (result->value.character.length, result->ts.kind); -} - - -int -gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) -{ - gfc_component *cmp; - int ptr; - tree type; - - /* The attributes of the derived type need to be bolted to the floor. */ - result->expr_type = EXPR_STRUCTURE; - - cmp = result->ts.u.derived->components; - - if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING - && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR - || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)) - { - gfc_constructor *c; - gfc_expr *e; - /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec - sets this to BT_INTEGER. */ - result->ts.type = BT_DERIVED; - e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where); - c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); - c->n.component = cmp; - gfc_target_interpret_expr (buffer, buffer_size, e, true); - e->ts.is_iso_c = 1; - return int_size_in_bytes (ptr_type_node); - } - - type = gfc_typenode_for_spec (&result->ts); - - /* Run through the derived type components. */ - for (;cmp; cmp = cmp->next) - { - gfc_constructor *c; - gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, - &result->where); - e->ts = cmp->ts; - - /* Copy shape, if needed. */ - if (cmp->as && cmp->as->rank) - { - int n; - - if (cmp->as->type != AS_EXPLICIT) - return 0; - - e->expr_type = EXPR_ARRAY; - e->rank = cmp->as->rank; - - e->shape = gfc_get_shape (e->rank); - for (n = 0; n < e->rank; n++) - { - mpz_init_set_ui (e->shape[n], 1); - mpz_add (e->shape[n], e->shape[n], - cmp->as->upper[n]->value.integer); - mpz_sub (e->shape[n], e->shape[n], - cmp->as->lower[n]->value.integer); - } - } - - c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); - - /* The constructor points to the component. */ - c->n.component = cmp; - - /* Calculate the offset, which consists of the FIELD_OFFSET in - bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized, - and additional bits of FIELD_BIT_OFFSET. The code assumes that all - sizes of the components are multiples of BITS_PER_UNIT, - i.e. there are, e.g., no bit fields. */ - - gcc_assert (cmp->backend_decl); - ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl)); - gcc_assert (ptr % 8 == 0); - ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); - - gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token); - gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true); - } - - return int_size_in_bytes (type); -} - - -/* Read a binary buffer to a constant expression. */ -size_t -gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, - gfc_expr *result, bool convert_widechar) -{ - if (result->expr_type == EXPR_ARRAY) - return interpret_array (buffer, buffer_size, result); - - switch (result->ts.type) - { - case BT_INTEGER: - result->representation.length = - gfc_interpret_integer (result->ts.kind, buffer, buffer_size, - result->value.integer); - break; - - case BT_REAL: - result->representation.length = - gfc_interpret_float (result->ts.kind, buffer, buffer_size, - result->value.real); - break; - - case BT_COMPLEX: - result->representation.length = - gfc_interpret_complex (result->ts.kind, buffer, buffer_size, - result->value.complex); - break; - - case BT_LOGICAL: - result->representation.length = - gfc_interpret_logical (result->ts.kind, buffer, buffer_size, - &result->value.logical); - break; - - case BT_CHARACTER: - result->representation.length = - gfc_interpret_character (buffer, buffer_size, result); - break; - - case BT_CLASS: - result->ts = CLASS_DATA (result)->ts; - /* Fall through. */ - case BT_DERIVED: - result->representation.length = - gfc_interpret_derived (buffer, buffer_size, result); - gcc_assert (result->representation.length >= 0); - break; - - case BT_VOID: - /* This deals with caf_tokens. */ - result->representation.length = - gfc_interpret_integer (result->ts.kind, buffer, buffer_size, - result->value.integer); - break; - - default: - gfc_internal_error ("Invalid expression in gfc_target_interpret_expr."); - break; - } - - if (result->ts.type == BT_CHARACTER && convert_widechar) - result->representation.string - = gfc_widechar_to_char (result->value.character.string, - result->value.character.length); - else - { - result->representation.string = - XCNEWVEC (char, result->representation.length + 1); - memcpy (result->representation.string, buffer, - result->representation.length); - result->representation.string[result->representation.length] = '\0'; - } - - return result->representation.length; -} - - -/* --------------------------------------------------------------- */ -/* Two functions used by trans-common.c to write overlapping - equivalence initializers to a buffer. This is added to the union - and the original initializers freed. */ - - -/* Writes the values of a constant expression to a char buffer. If another - unequal initializer has already been written to the buffer, this is an - error. */ - -static size_t -expr_to_char (gfc_expr *e, locus *loc, - unsigned char *data, unsigned char *chk, size_t len) -{ - int i; - int ptr; - gfc_constructor *c; - gfc_component *cmp; - unsigned char *buffer; - - if (e == NULL) - return 0; - - /* Take a derived type, one component at a time, using the offsets from the backend - declaration. */ - if (e->ts.type == BT_DERIVED) - { - for (c = gfc_constructor_first (e->value.constructor), - cmp = e->ts.u.derived->components; - c; c = gfc_constructor_next (c), cmp = cmp->next) - { - gcc_assert (cmp && cmp->backend_decl); - if (!c->expr) - continue; - ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) - + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; - expr_to_char (c->expr, loc, &data[ptr], &chk[ptr], len); - } - return len; - } - - /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate - to the target, in a buffer and check off the initialized part of the buffer. */ - gfc_target_expr_size (e, &len); - buffer = (unsigned char*)alloca (len); - len = gfc_target_encode_expr (e, buffer, len); - - for (i = 0; i < (int)len; i++) - { - if (chk[i] && (buffer[i] != data[i])) - { - if (loc) - gfc_error ("Overlapping unequal initializers in EQUIVALENCE " - "at %L", loc); - else - gfc_error ("Overlapping unequal initializers in EQUIVALENCE " - "at %C"); - return 0; - } - chk[i] = 0xFF; - } - - memcpy (data, buffer, len); - return len; -} - - -/* Writes the values from the equivalence initializers to a char* array - that will be written to the constructor to make the initializer for - the union declaration. */ - -size_t -gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc, - unsigned char *data, - unsigned char *chk, size_t length) -{ - size_t len = 0; - gfc_constructor * c; - - switch (e->expr_type) - { - case EXPR_CONSTANT: - case EXPR_STRUCTURE: - len = expr_to_char (e, loc, &data[0], &chk[0], length); - break; - - case EXPR_ARRAY: - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) - { - size_t elt_size; - - gfc_target_expr_size (c->expr, &elt_size); - - if (mpz_cmp_si (c->offset, 0) != 0) - len = elt_size * (size_t)mpz_get_si (c->offset); - - len = len + gfc_merge_initializers (ts, c->expr, loc, &data[len], - &chk[len], length - len); - } - break; - - default: - return 0; - } - - return len; -} - - -/* Transfer the bitpattern of a (integer) BOZ to real or complex variables. - When successful, no BOZ or nothing to do, true is returned. */ - -bool -gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts) -{ - size_t buffer_size, boz_bit_size, ts_bit_size; - int index; - unsigned char *buffer; - - if (expr->ts.type != BT_INTEGER) - return true; - - /* Don't convert BOZ to logical, character, derived etc. */ - gcc_assert (ts->type == BT_REAL); - - buffer_size = size_float (ts->kind); - ts_bit_size = buffer_size * 8; - - /* Convert BOZ to the smallest possible integer kind. */ - boz_bit_size = mpz_sizeinbase (expr->value.integer, 2); - - gcc_assert (boz_bit_size <= ts_bit_size); - - for (index = 0; gfc_integer_kinds[index].kind != 0; ++index) - if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size) - break; - - expr->ts.kind = gfc_integer_kinds[index].kind; - buffer_size = MAX (buffer_size, size_integer (expr->ts.kind)); - - buffer = (unsigned char*)alloca (buffer_size); - encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size); - mpz_clear (expr->value.integer); - - mpfr_init (expr->value.real); - gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real); - - expr->ts.type = ts->type; - expr->ts.kind = ts->kind; - - return true; -} diff --git a/gcc/fortran/target-memory.cc b/gcc/fortran/target-memory.cc new file mode 100644 index 0000000..9b5af8d --- /dev/null +++ b/gcc/fortran/target-memory.cc @@ -0,0 +1,806 @@ +/* Simulate storage of variables into target memory. + Copyright (C) 2007-2022 Free Software Foundation, Inc. + Contributed by Paul Thomas and Brooks Moses + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "gfortran.h" +#include "trans.h" +#include "fold-const.h" +#include "stor-layout.h" +#include "arith.h" +#include "constructor.h" +#include "trans-const.h" +#include "trans-types.h" +#include "target-memory.h" + +/* --------------------------------------------------------------- */ +/* Calculate the size of an expression. */ + + +static size_t +size_integer (int kind) +{ + return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind))); +} + + +static size_t +size_float (int kind) +{ + return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind))); +} + + +static size_t +size_complex (int kind) +{ + return 2 * size_float (kind); +} + + +static size_t +size_logical (int kind) +{ + return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind))); +} + + +static size_t +size_character (gfc_charlen_t length, int kind) +{ + int i = gfc_validate_kind (BT_CHARACTER, kind, false); + return length * gfc_character_kinds[i].bit_size / 8; +} + + +/* Return the size of a single element of the given expression. + Equivalent to gfc_target_expr_size for scalars. */ + +bool +gfc_element_size (gfc_expr *e, size_t *siz) +{ + tree type; + + switch (e->ts.type) + { + case BT_INTEGER: + *siz = size_integer (e->ts.kind); + return true; + case BT_REAL: + *siz = size_float (e->ts.kind); + return true; + case BT_COMPLEX: + *siz = size_complex (e->ts.kind); + return true; + case BT_LOGICAL: + *siz = size_logical (e->ts.kind); + return true; + case BT_CHARACTER: + if (e->expr_type == EXPR_CONSTANT) + *siz = size_character (e->value.character.length, e->ts.kind); + else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT + && e->ts.u.cl->length->ts.type == BT_INTEGER) + { + HOST_WIDE_INT length; + + gfc_extract_hwi (e->ts.u.cl->length, &length); + *siz = size_character (length, e->ts.kind); + } + else + { + *siz = 0; + return false; + } + return true; + + case BT_HOLLERITH: + *siz = e->representation.length; + return true; + case BT_DERIVED: + case BT_CLASS: + case BT_VOID: + case BT_ASSUMED: + case BT_PROCEDURE: + { + /* Determine type size without clobbering the typespec for ISO C + binding types. */ + gfc_typespec ts; + HOST_WIDE_INT size; + ts = e->ts; + type = gfc_typenode_for_spec (&ts); + size = int_size_in_bytes (type); + gcc_assert (size >= 0); + *siz = size; + } + return true; + default: + gfc_internal_error ("Invalid expression in gfc_element_size."); + *siz = 0; + return false; + } +} + + +/* Return the size of an expression in its target representation. */ + +bool +gfc_target_expr_size (gfc_expr *e, size_t *size) +{ + mpz_t tmp; + size_t asz, el_size; + + gcc_assert (e != NULL); + + *size = 0; + if (e->rank) + { + if (gfc_array_size (e, &tmp)) + asz = mpz_get_ui (tmp); + else + return false; + } + else + asz = 1; + + if (!gfc_element_size (e, &el_size)) + return false; + *size = asz * el_size; + return true; +} + + +/* The encode_* functions export a value into a buffer, and + return the number of bytes of the buffer that have been + used. */ + +static unsigned HOST_WIDE_INT +encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size) +{ + mpz_t array_size; + int i; + int ptr = 0; + + gfc_constructor_base ctor = expr->value.constructor; + + gfc_array_size (expr, &array_size); + for (i = 0; i < (int)mpz_get_ui (array_size); i++) + { + ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i), + &buffer[ptr], buffer_size - ptr); + } + + mpz_clear (array_size); + return ptr; +} + + +static int +encode_integer (int kind, mpz_t integer, unsigned char *buffer, + size_t buffer_size) +{ + return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind), + buffer, buffer_size); +} + + +static int +encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size) +{ + return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer, + buffer_size); +} + + +static int +encode_complex (int kind, mpc_t cmplx, + unsigned char *buffer, size_t buffer_size) +{ + int size; + size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size); + size += encode_float (kind, mpc_imagref (cmplx), + &buffer[size], buffer_size - size); + return size; +} + + +static int +encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size) +{ + return native_encode_expr (build_int_cst (gfc_get_logical_type (kind), + logical), + buffer, buffer_size); +} + + +size_t +gfc_encode_character (int kind, size_t length, const gfc_char_t *string, + unsigned char *buffer, size_t buffer_size) +{ + size_t elsize = size_character (1, kind); + tree type = gfc_get_char_type (kind); + + gcc_assert (buffer_size >= size_character (length, kind)); + + for (size_t i = 0; i < length; i++) + native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize], + elsize); + + return length; +} + + +static unsigned HOST_WIDE_INT +encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) +{ + gfc_constructor *c; + gfc_component *cmp; + int ptr; + tree type; + HOST_WIDE_INT size; + + type = gfc_typenode_for_spec (&source->ts); + + for (c = gfc_constructor_first (source->value.constructor), + cmp = source->ts.u.derived->components; + c; + c = gfc_constructor_next (c), cmp = cmp->next) + { + gcc_assert (cmp); + if (!c->expr) + continue; + ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; + + if (c->expr->expr_type == EXPR_NULL) + { + size = int_size_in_bytes (TREE_TYPE (cmp->backend_decl)); + gcc_assert (size >= 0); + memset (&buffer[ptr], 0, size); + } + else + gfc_target_encode_expr (c->expr, &buffer[ptr], + buffer_size - ptr); + } + + size = int_size_in_bytes (type); + gcc_assert (size >= 0); + return size; +} + + +/* Write a constant expression in binary form to a buffer. */ +unsigned HOST_WIDE_INT +gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, + size_t buffer_size) +{ + if (source == NULL) + return 0; + + if (source->expr_type == EXPR_ARRAY) + return encode_array (source, buffer, buffer_size); + + gcc_assert (source->expr_type == EXPR_CONSTANT + || source->expr_type == EXPR_STRUCTURE + || source->expr_type == EXPR_SUBSTRING); + + /* If we already have a target-memory representation, we use that rather + than recreating one. */ + if (source->representation.string) + { + memcpy (buffer, source->representation.string, + source->representation.length); + return source->representation.length; + } + + switch (source->ts.type) + { + case BT_INTEGER: + return encode_integer (source->ts.kind, source->value.integer, buffer, + buffer_size); + case BT_REAL: + return encode_float (source->ts.kind, source->value.real, buffer, + buffer_size); + case BT_COMPLEX: + return encode_complex (source->ts.kind, source->value.complex, + buffer, buffer_size); + case BT_LOGICAL: + return encode_logical (source->ts.kind, source->value.logical, buffer, + buffer_size); + case BT_CHARACTER: + if (source->expr_type == EXPR_CONSTANT || source->ref == NULL) + return gfc_encode_character (source->ts.kind, + source->value.character.length, + source->value.character.string, + buffer, buffer_size); + else + { + HOST_WIDE_INT start, end; + + gcc_assert (source->expr_type == EXPR_SUBSTRING); + gfc_extract_hwi (source->ref->u.ss.start, &start); + gfc_extract_hwi (source->ref->u.ss.end, &end); + return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0), + &source->value.character.string[start-1], + buffer, buffer_size); + } + + case BT_DERIVED: + if (source->ts.u.derived->ts.f90_type == BT_VOID) + { + gfc_constructor *c; + gcc_assert (source->expr_type == EXPR_STRUCTURE); + c = gfc_constructor_first (source->value.constructor); + gcc_assert (c->expr->expr_type == EXPR_CONSTANT + && c->expr->ts.type == BT_INTEGER); + return encode_integer (gfc_index_integer_kind, c->expr->value.integer, + buffer, buffer_size); + } + + return encode_derived (source, buffer, buffer_size); + default: + gfc_internal_error ("Invalid expression in gfc_target_encode_expr."); + return 0; + } +} + + +static size_t +interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) +{ + gfc_constructor_base base = NULL; + size_t array_size = 1; + size_t ptr = 0; + + /* Calculate array size from its shape and rank. */ + gcc_assert (result->rank > 0 && result->shape); + + for (int i = 0; i < result->rank; i++) + array_size *= mpz_get_ui (result->shape[i]); + + /* Iterate over array elements, producing constructors. */ + for (size_t i = 0; i < array_size; i++) + { + gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind, + &result->where); + e->ts = result->ts; + + if (e->ts.type == BT_CHARACTER) + e->value.character.length = result->value.character.length; + + gfc_constructor_append_expr (&base, e, &result->where); + + ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, + true); + } + + result->value.constructor = base; + return ptr; +} + + +int +gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size, + mpz_t integer) +{ + mpz_init (integer); + gfc_conv_tree_to_mpz (integer, + native_interpret_expr (gfc_get_int_type (kind), + buffer, buffer_size)); + return size_integer (kind); +} + + +int +gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size, + mpfr_t real) +{ + gfc_set_model_kind (kind); + mpfr_init (real); + gfc_conv_tree_to_mpfr (real, + native_interpret_expr (gfc_get_real_type (kind), + buffer, buffer_size)); + + return size_float (kind); +} + + +int +gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size, + mpc_t complex) +{ + int size; + size = gfc_interpret_float (kind, &buffer[0], buffer_size, + mpc_realref (complex)); + size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, + mpc_imagref (complex)); + return size; +} + + +int +gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size, + int *logical) +{ + tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer, + buffer_size); + *logical = wi::to_wide (t) == 0 ? 0 : 1; + return size_logical (kind); +} + + +size_t +gfc_interpret_character (unsigned char *buffer, size_t buffer_size, + gfc_expr *result) +{ + if (result->ts.u.cl && result->ts.u.cl->length) + result->value.character.length = + gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer); + + gcc_assert (buffer_size >= size_character (result->value.character.length, + result->ts.kind)); + result->value.character.string = + gfc_get_wide_string (result->value.character.length + 1); + + if (result->ts.kind == gfc_default_character_kind) + for (size_t i = 0; i < (size_t) result->value.character.length; i++) + result->value.character.string[i] = (gfc_char_t) buffer[i]; + else + { + mpz_t integer; + size_t bytes = size_character (1, result->ts.kind); + mpz_init (integer); + gcc_assert (bytes <= sizeof (unsigned long)); + + for (size_t i = 0; i < (size_t) result->value.character.length; i++) + { + gfc_conv_tree_to_mpz (integer, + native_interpret_expr (gfc_get_char_type (result->ts.kind), + &buffer[bytes*i], buffer_size-bytes*i)); + result->value.character.string[i] + = (gfc_char_t) mpz_get_ui (integer); + } + + mpz_clear (integer); + } + + result->value.character.string[result->value.character.length] = '\0'; + + return size_character (result->value.character.length, result->ts.kind); +} + + +int +gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) +{ + gfc_component *cmp; + int ptr; + tree type; + + /* The attributes of the derived type need to be bolted to the floor. */ + result->expr_type = EXPR_STRUCTURE; + + cmp = result->ts.u.derived->components; + + if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING + && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR + || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)) + { + gfc_constructor *c; + gfc_expr *e; + /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec + sets this to BT_INTEGER. */ + result->ts.type = BT_DERIVED; + e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where); + c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); + c->n.component = cmp; + gfc_target_interpret_expr (buffer, buffer_size, e, true); + e->ts.is_iso_c = 1; + return int_size_in_bytes (ptr_type_node); + } + + type = gfc_typenode_for_spec (&result->ts); + + /* Run through the derived type components. */ + for (;cmp; cmp = cmp->next) + { + gfc_constructor *c; + gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, + &result->where); + e->ts = cmp->ts; + + /* Copy shape, if needed. */ + if (cmp->as && cmp->as->rank) + { + int n; + + if (cmp->as->type != AS_EXPLICIT) + return 0; + + e->expr_type = EXPR_ARRAY; + e->rank = cmp->as->rank; + + e->shape = gfc_get_shape (e->rank); + for (n = 0; n < e->rank; n++) + { + mpz_init_set_ui (e->shape[n], 1); + mpz_add (e->shape[n], e->shape[n], + cmp->as->upper[n]->value.integer); + mpz_sub (e->shape[n], e->shape[n], + cmp->as->lower[n]->value.integer); + } + } + + c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); + + /* The constructor points to the component. */ + c->n.component = cmp; + + /* Calculate the offset, which consists of the FIELD_OFFSET in + bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized, + and additional bits of FIELD_BIT_OFFSET. The code assumes that all + sizes of the components are multiples of BITS_PER_UNIT, + i.e. there are, e.g., no bit fields. */ + + gcc_assert (cmp->backend_decl); + ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl)); + gcc_assert (ptr % 8 == 0); + ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); + + gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token); + gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true); + } + + return int_size_in_bytes (type); +} + + +/* Read a binary buffer to a constant expression. */ +size_t +gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, + gfc_expr *result, bool convert_widechar) +{ + if (result->expr_type == EXPR_ARRAY) + return interpret_array (buffer, buffer_size, result); + + switch (result->ts.type) + { + case BT_INTEGER: + result->representation.length = + gfc_interpret_integer (result->ts.kind, buffer, buffer_size, + result->value.integer); + break; + + case BT_REAL: + result->representation.length = + gfc_interpret_float (result->ts.kind, buffer, buffer_size, + result->value.real); + break; + + case BT_COMPLEX: + result->representation.length = + gfc_interpret_complex (result->ts.kind, buffer, buffer_size, + result->value.complex); + break; + + case BT_LOGICAL: + result->representation.length = + gfc_interpret_logical (result->ts.kind, buffer, buffer_size, + &result->value.logical); + break; + + case BT_CHARACTER: + result->representation.length = + gfc_interpret_character (buffer, buffer_size, result); + break; + + case BT_CLASS: + result->ts = CLASS_DATA (result)->ts; + /* Fall through. */ + case BT_DERIVED: + result->representation.length = + gfc_interpret_derived (buffer, buffer_size, result); + gcc_assert (result->representation.length >= 0); + break; + + case BT_VOID: + /* This deals with caf_tokens. */ + result->representation.length = + gfc_interpret_integer (result->ts.kind, buffer, buffer_size, + result->value.integer); + break; + + default: + gfc_internal_error ("Invalid expression in gfc_target_interpret_expr."); + break; + } + + if (result->ts.type == BT_CHARACTER && convert_widechar) + result->representation.string + = gfc_widechar_to_char (result->value.character.string, + result->value.character.length); + else + { + result->representation.string = + XCNEWVEC (char, result->representation.length + 1); + memcpy (result->representation.string, buffer, + result->representation.length); + result->representation.string[result->representation.length] = '\0'; + } + + return result->representation.length; +} + + +/* --------------------------------------------------------------- */ +/* Two functions used by trans-common.c to write overlapping + equivalence initializers to a buffer. This is added to the union + and the original initializers freed. */ + + +/* Writes the values of a constant expression to a char buffer. If another + unequal initializer has already been written to the buffer, this is an + error. */ + +static size_t +expr_to_char (gfc_expr *e, locus *loc, + unsigned char *data, unsigned char *chk, size_t len) +{ + int i; + int ptr; + gfc_constructor *c; + gfc_component *cmp; + unsigned char *buffer; + + if (e == NULL) + return 0; + + /* Take a derived type, one component at a time, using the offsets from the backend + declaration. */ + if (e->ts.type == BT_DERIVED) + { + for (c = gfc_constructor_first (e->value.constructor), + cmp = e->ts.u.derived->components; + c; c = gfc_constructor_next (c), cmp = cmp->next) + { + gcc_assert (cmp && cmp->backend_decl); + if (!c->expr) + continue; + ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; + expr_to_char (c->expr, loc, &data[ptr], &chk[ptr], len); + } + return len; + } + + /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate + to the target, in a buffer and check off the initialized part of the buffer. */ + gfc_target_expr_size (e, &len); + buffer = (unsigned char*)alloca (len); + len = gfc_target_encode_expr (e, buffer, len); + + for (i = 0; i < (int)len; i++) + { + if (chk[i] && (buffer[i] != data[i])) + { + if (loc) + gfc_error ("Overlapping unequal initializers in EQUIVALENCE " + "at %L", loc); + else + gfc_error ("Overlapping unequal initializers in EQUIVALENCE " + "at %C"); + return 0; + } + chk[i] = 0xFF; + } + + memcpy (data, buffer, len); + return len; +} + + +/* Writes the values from the equivalence initializers to a char* array + that will be written to the constructor to make the initializer for + the union declaration. */ + +size_t +gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc, + unsigned char *data, + unsigned char *chk, size_t length) +{ + size_t len = 0; + gfc_constructor * c; + + switch (e->expr_type) + { + case EXPR_CONSTANT: + case EXPR_STRUCTURE: + len = expr_to_char (e, loc, &data[0], &chk[0], length); + break; + + case EXPR_ARRAY: + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + size_t elt_size; + + gfc_target_expr_size (c->expr, &elt_size); + + if (mpz_cmp_si (c->offset, 0) != 0) + len = elt_size * (size_t)mpz_get_si (c->offset); + + len = len + gfc_merge_initializers (ts, c->expr, loc, &data[len], + &chk[len], length - len); + } + break; + + default: + return 0; + } + + return len; +} + + +/* Transfer the bitpattern of a (integer) BOZ to real or complex variables. + When successful, no BOZ or nothing to do, true is returned. */ + +bool +gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts) +{ + size_t buffer_size, boz_bit_size, ts_bit_size; + int index; + unsigned char *buffer; + + if (expr->ts.type != BT_INTEGER) + return true; + + /* Don't convert BOZ to logical, character, derived etc. */ + gcc_assert (ts->type == BT_REAL); + + buffer_size = size_float (ts->kind); + ts_bit_size = buffer_size * 8; + + /* Convert BOZ to the smallest possible integer kind. */ + boz_bit_size = mpz_sizeinbase (expr->value.integer, 2); + + gcc_assert (boz_bit_size <= ts_bit_size); + + for (index = 0; gfc_integer_kinds[index].kind != 0; ++index) + if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size) + break; + + expr->ts.kind = gfc_integer_kinds[index].kind; + buffer_size = MAX (buffer_size, size_integer (expr->ts.kind)); + + buffer = (unsigned char*)alloca (buffer_size); + encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size); + mpz_clear (expr->value.integer); + + mpfr_init (expr->value.real); + gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real); + + expr->ts.type = ts->type; + expr->ts.kind = ts->kind; + + return true; +} diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c deleted file mode 100644 index a77f331..0000000 --- a/gcc/fortran/trans-array.c +++ /dev/null @@ -1,11714 +0,0 @@ -/* Array translation routines - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - and Steven Bosscher - -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 -. */ - -/* trans-array.c-- Various array related code, including scalarization, - allocation, initialization and other support routines. */ - -/* How the scalarizer works. - In gfortran, array expressions use the same core routines as scalar - expressions. - First, a Scalarization State (SS) chain is built. This is done by walking - the expression tree, and building a linear list of the terms in the - expression. As the tree is walked, scalar subexpressions are translated. - - The scalarization parameters are stored in a gfc_loopinfo structure. - First the start and stride of each term is calculated by - gfc_conv_ss_startstride. During this process the expressions for the array - descriptors and data pointers are also translated. - - If the expression is an assignment, we must then resolve any dependencies. - In Fortran all the rhs values of an assignment must be evaluated before - any assignments take place. This can require a temporary array to store the - values. We also require a temporary when we are passing array expressions - or vector subscripts as procedure parameters. - - Array sections are passed without copying to a temporary. These use the - scalarizer to determine the shape of the section. The flag - loop->array_parameter tells the scalarizer that the actual values and loop - variables will not be required. - - The function gfc_conv_loop_setup generates the scalarization setup code. - It determines the range of the scalarizing loop variables. If a temporary - is required, this is created and initialized. Code for scalar expressions - taken outside the loop is also generated at this time. Next the offset and - scaling required to translate from loop variables to array indices for each - term is calculated. - - A call to gfc_start_scalarized_body marks the start of the scalarized - expression. This creates a scope and declares the loop variables. Before - calling this gfc_make_ss_chain_used must be used to indicate which terms - will be used inside this loop. - - The scalar gfc_conv_* functions are then used to build the main body of the - scalarization loop. Scalarization loop variables and precalculated scalar - values are automatically substituted. Note that gfc_advance_se_ss_chain - must be used, rather than changing the se->ss directly. - - For assignment expressions requiring a temporary two sub loops are - generated. The first stores the result of the expression in the temporary, - the second copies it to the result. A call to - gfc_trans_scalarized_loop_boundary marks the end of the main loop code and - the start of the copying loop. The temporary may be less than full rank. - - Finally gfc_trans_scalarizing_loops is called to generate the implicit do - loops. The loops are added to the pre chain of the loopinfo. The post - chain may still contain cleanup code. - - After the loop code has been added into its parent scope gfc_cleanup_loop - is called to free all the SS allocated by the scalarizer. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "tree.h" -#include "gfortran.h" -#include "gimple-expr.h" -#include "trans.h" -#include "fold-const.h" -#include "constructor.h" -#include "trans-types.h" -#include "trans-array.h" -#include "trans-const.h" -#include "dependency.h" - -static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); - -/* The contents of this structure aren't actually used, just the address. */ -static gfc_ss gfc_ss_terminator_var; -gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; - - -static tree -gfc_array_dataptr_type (tree desc) -{ - return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))); -} - -/* Build expressions to access members of the CFI descriptor. */ -#define CFI_FIELD_BASE_ADDR 0 -#define CFI_FIELD_ELEM_LEN 1 -#define CFI_FIELD_VERSION 2 -#define CFI_FIELD_RANK 3 -#define CFI_FIELD_ATTRIBUTE 4 -#define CFI_FIELD_TYPE 5 -#define CFI_FIELD_DIM 6 - -#define CFI_DIM_FIELD_LOWER_BOUND 0 -#define CFI_DIM_FIELD_EXTENT 1 -#define CFI_DIM_FIELD_SM 2 - -static tree -gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx) -{ - tree type = TREE_TYPE (desc); - gcc_assert (TREE_CODE (type) == RECORD_TYPE - && TYPE_FIELDS (type) - && (strcmp ("base_addr", - IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type)))) - == 0)); - tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx); - gcc_assert (field != NULL_TREE); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - -tree -gfc_get_cfi_desc_base_addr (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR); -} - -tree -gfc_get_cfi_desc_elem_len (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN); -} - -tree -gfc_get_cfi_desc_version (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION); -} - -tree -gfc_get_cfi_desc_rank (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK); -} - -tree -gfc_get_cfi_desc_type (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE); -} - -tree -gfc_get_cfi_desc_attribute (tree desc) -{ - return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE); -} - -static tree -gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx) -{ - tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM); - tmp = gfc_build_array_ref (tmp, idx, NULL); - tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); - gcc_assert (field != NULL_TREE); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); -} - -tree -gfc_get_cfi_dim_lbound (tree desc, tree idx) -{ - return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND); -} - -tree -gfc_get_cfi_dim_extent (tree desc, tree idx) -{ - return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT); -} - -tree -gfc_get_cfi_dim_sm (tree desc, tree idx) -{ - return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM); -} - -#undef CFI_FIELD_BASE_ADDR -#undef CFI_FIELD_ELEM_LEN -#undef CFI_FIELD_VERSION -#undef CFI_FIELD_RANK -#undef CFI_FIELD_ATTRIBUTE -#undef CFI_FIELD_TYPE -#undef CFI_FIELD_DIM - -#undef CFI_DIM_FIELD_LOWER_BOUND -#undef CFI_DIM_FIELD_EXTENT -#undef CFI_DIM_FIELD_SM - -/* Build expressions to access the members of an array descriptor. - It's surprisingly easy to mess up here, so never access - an array descriptor by "brute force", always use these - functions. This also avoids problems if we change the format - of an array descriptor. - - To understand these magic numbers, look at the comments - before gfc_build_array_type() in trans-types.c. - - The code within these defines should be the only code which knows the format - of an array descriptor. - - Any code just needing to read obtain the bounds of an array should use - gfc_conv_array_* rather than the following functions as these will return - know constant values, and work with arrays which do not have descriptors. - - Don't forget to #undef these! */ - -#define DATA_FIELD 0 -#define OFFSET_FIELD 1 -#define DTYPE_FIELD 2 -#define SPAN_FIELD 3 -#define DIMENSION_FIELD 4 -#define CAF_TOKEN_FIELD 5 - -#define STRIDE_SUBFIELD 0 -#define LBOUND_SUBFIELD 1 -#define UBOUND_SUBFIELD 2 - -static tree -gfc_get_descriptor_field (tree desc, unsigned field_idx) -{ - tree type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - - tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx); - gcc_assert (field != NULL_TREE); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); -} - -/* This provides READ-ONLY access to the data field. The field itself - doesn't have the proper type. */ - -tree -gfc_conv_descriptor_data_get (tree desc) -{ - tree type = TREE_TYPE (desc); - if (TREE_CODE (type) == REFERENCE_TYPE) - gcc_unreachable (); - - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field); -} - -/* This provides WRITE access to the data field. - - TUPLES_P is true if we are generating tuples. - - This function gets called through the following macros: - gfc_conv_descriptor_data_set - gfc_conv_descriptor_data_set. */ - -void -gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) -{ - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value)); -} - - -/* This provides address access to the data field. This should only be - used by array allocation, passing this on to the runtime. */ - -tree -gfc_conv_descriptor_data_addr (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - return gfc_build_addr_expr (NULL_TREE, field); -} - -static tree -gfc_conv_descriptor_offset (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_offset_get (tree desc) -{ - return gfc_conv_descriptor_offset (desc); -} - -void -gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, - tree value) -{ - tree t = gfc_conv_descriptor_offset (desc); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - - -tree -gfc_conv_descriptor_dtype (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD); - gcc_assert (TREE_TYPE (field) == get_dtype_type_node ()); - return field; -} - -static tree -gfc_conv_descriptor_span (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, SPAN_FIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_span_get (tree desc) -{ - return gfc_conv_descriptor_span (desc); -} - -void -gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, - tree value) -{ - tree t = gfc_conv_descriptor_span (desc); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - - -tree -gfc_conv_descriptor_rank (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK); - gcc_assert (tmp != NULL_TREE - && TREE_TYPE (tmp) == signed_char_type_node); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - dtype, tmp, NULL_TREE); -} - - -/* Return the element length from the descriptor dtype field. */ - -tree -gfc_conv_descriptor_elem_len (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), - GFC_DTYPE_ELEM_LEN); - gcc_assert (tmp != NULL_TREE - && TREE_TYPE (tmp) == size_type_node); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - dtype, tmp, NULL_TREE); -} - - -tree -gfc_conv_descriptor_attribute (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), - GFC_DTYPE_ATTRIBUTE); - gcc_assert (tmp!= NULL_TREE - && TREE_TYPE (tmp) == short_integer_type_node); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - dtype, tmp, NULL_TREE); -} - -tree -gfc_conv_descriptor_type (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE); - gcc_assert (tmp!= NULL_TREE - && TREE_TYPE (tmp) == signed_char_type_node); - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - dtype, tmp, NULL_TREE); -} - -tree -gfc_get_descriptor_dimension (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD); - gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); - return field; -} - - -static tree -gfc_conv_descriptor_dimension (tree desc, tree dim) -{ - tree tmp; - - tmp = gfc_get_descriptor_dimension (desc); - - return gfc_build_array_ref (tmp, dim, NULL); -} - - -tree -gfc_conv_descriptor_token (tree desc) -{ - gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); - tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD); - /* Should be a restricted pointer - except in the finalization wrapper. */ - gcc_assert (TREE_TYPE (field) == prvoid_type_node - || TREE_TYPE (field) == pvoid_type_node); - return field; -} - -static tree -gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx) -{ - tree tmp = gfc_conv_descriptor_dimension (desc, dim); - tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); - gcc_assert (field != NULL_TREE); - - return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); -} - -static tree -gfc_conv_descriptor_stride (tree desc, tree dim) -{ - tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_stride_get (tree desc, tree dim) -{ - tree type = TREE_TYPE (desc); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - if (integer_zerop (dim) - && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT - ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) - return gfc_index_one_node; - - return gfc_conv_descriptor_stride (desc, dim); -} - -void -gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_stride (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -static tree -gfc_conv_descriptor_lbound (tree desc, tree dim) -{ - tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_lbound_get (tree desc, tree dim) -{ - return gfc_conv_descriptor_lbound (desc, dim); -} - -void -gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_lbound (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -static tree -gfc_conv_descriptor_ubound (tree desc, tree dim) -{ - tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD); - gcc_assert (TREE_TYPE (field) == gfc_array_index_type); - return field; -} - -tree -gfc_conv_descriptor_ubound_get (tree desc, tree dim) -{ - return gfc_conv_descriptor_ubound (desc, dim); -} - -void -gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, - tree dim, tree value) -{ - tree t = gfc_conv_descriptor_ubound (desc, dim); - gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); -} - -/* Build a null array descriptor constructor. */ - -tree -gfc_build_null_descriptor (tree type) -{ - tree field; - tree tmp; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - gcc_assert (DATA_FIELD == 0); - field = TYPE_FIELDS (type); - - /* Set a NULL data pointer. */ - tmp = build_constructor_single (type, field, null_pointer_node); - TREE_CONSTANT (tmp) = 1; - /* All other fields are ignored. */ - - return tmp; -} - - -/* Modify a descriptor such that the lbound of a given dimension is the value - specified. This also updates ubound and offset accordingly. */ - -void -gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, - int dim, tree new_lbound) -{ - tree offs, ubound, lbound, stride; - tree diff, offs_diff; - - new_lbound = fold_convert (gfc_array_index_type, new_lbound); - - offs = gfc_conv_descriptor_offset_get (desc); - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); - stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); - - /* Get difference (new - old) by which to shift stuff. */ - diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - new_lbound, lbound); - - /* Shift ubound and offset accordingly. This has to be done before - updating the lbound, as they depend on the lbound expression! */ - ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, diff); - gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); - offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - diff, stride); - offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - offs, offs_diff); - gfc_conv_descriptor_offset_set (block, desc, offs); - - /* Finally set lbound to value we want. */ - gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); -} - - -/* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */ - -void -gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off, - tree *dtype_off, tree *span_off, - tree *dim_off, tree *dim_size, - tree *stride_suboff, tree *lower_suboff, - tree *upper_suboff) -{ - tree field; - tree type; - - type = TYPE_MAIN_VARIANT (desc_type); - field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD); - *data_off = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); - *dtype_off = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); - *span_off = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); - *dim_off = byte_position (field); - type = TREE_TYPE (TREE_TYPE (field)); - *dim_size = TYPE_SIZE_UNIT (type); - field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD); - *stride_suboff = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD); - *lower_suboff = byte_position (field); - field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD); - *upper_suboff = byte_position (field); -} - - -/* Cleanup those #defines. */ - -#undef DATA_FIELD -#undef OFFSET_FIELD -#undef DTYPE_FIELD -#undef SPAN_FIELD -#undef DIMENSION_FIELD -#undef CAF_TOKEN_FIELD -#undef STRIDE_SUBFIELD -#undef LBOUND_SUBFIELD -#undef UBOUND_SUBFIELD - - -/* Mark a SS chain as used. Flags specifies in which loops the SS is used. - flags & 1 = Main loop body. - flags & 2 = temp copy loop. */ - -void -gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) -{ - for (; ss != gfc_ss_terminator; ss = ss->next) - ss->info->useflags = flags; -} - - -/* Free a gfc_ss chain. */ - -void -gfc_free_ss_chain (gfc_ss * ss) -{ - gfc_ss *next; - - while (ss != gfc_ss_terminator) - { - gcc_assert (ss != NULL); - next = ss->next; - gfc_free_ss (ss); - ss = next; - } -} - - -static void -free_ss_info (gfc_ss_info *ss_info) -{ - int n; - - ss_info->refcount--; - if (ss_info->refcount > 0) - return; - - gcc_assert (ss_info->refcount == 0); - - switch (ss_info->type) - { - case GFC_SS_SECTION: - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (ss_info->data.array.subscript[n]) - gfc_free_ss_chain (ss_info->data.array.subscript[n]); - break; - - default: - break; - } - - free (ss_info); -} - - -/* Free a SS. */ - -void -gfc_free_ss (gfc_ss * ss) -{ - free_ss_info (ss->info); - free (ss); -} - - -/* Creates and initializes an array type gfc_ss struct. */ - -gfc_ss * -gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - int i; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = type; - ss_info->expr = expr; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = next; - ss->dimen = dimen; - for (i = 0; i < ss->dimen; i++) - ss->dim[i] = i; - - return ss; -} - - -/* Creates and initializes a temporary type gfc_ss struct. */ - -gfc_ss * -gfc_get_temp_ss (tree type, tree string_length, int dimen) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - int i; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = GFC_SS_TEMP; - ss_info->string_length = string_length; - ss_info->data.temp.type = type; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = gfc_ss_terminator; - ss->dimen = dimen; - for (i = 0; i < ss->dimen; i++) - ss->dim[i] = i; - - return ss; -} - - -/* Creates and initializes a scalar type gfc_ss struct. */ - -gfc_ss * -gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) -{ - gfc_ss *ss; - gfc_ss_info *ss_info; - - ss_info = gfc_get_ss_info (); - ss_info->refcount++; - ss_info->type = GFC_SS_SCALAR; - ss_info->expr = expr; - - ss = gfc_get_ss (); - ss->info = ss_info; - ss->next = next; - - return ss; -} - - -/* Free all the SS associated with a loop. */ - -void -gfc_cleanup_loop (gfc_loopinfo * loop) -{ - gfc_loopinfo *loop_next, **ploop; - gfc_ss *ss; - gfc_ss *next; - - ss = loop->ss; - while (ss != gfc_ss_terminator) - { - gcc_assert (ss != NULL); - next = ss->loop_chain; - gfc_free_ss (ss); - ss = next; - } - - /* Remove reference to self in the parent loop. */ - if (loop->parent) - for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next) - if (*ploop == loop) - { - *ploop = loop->next; - break; - } - - /* Free non-freed nested loops. */ - for (loop = loop->nested; loop; loop = loop_next) - { - loop_next = loop->next; - gfc_cleanup_loop (loop); - free (loop); - } -} - - -static void -set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop) -{ - int n; - - for (; ss != gfc_ss_terminator; ss = ss->next) - { - ss->loop = loop; - - if (ss->info->type == GFC_SS_SCALAR - || ss->info->type == GFC_SS_REFERENCE - || ss->info->type == GFC_SS_TEMP) - continue; - - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (ss->info->data.array.subscript[n] != NULL) - set_ss_loop (ss->info->data.array.subscript[n], loop); - } -} - - -/* Associate a SS chain with a loop. */ - -void -gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) -{ - gfc_ss *ss; - gfc_loopinfo *nested_loop; - - if (head == gfc_ss_terminator) - return; - - set_ss_loop (head, loop); - - ss = head; - for (; ss && ss != gfc_ss_terminator; ss = ss->next) - { - if (ss->nested_ss) - { - nested_loop = ss->nested_ss->loop; - - /* More than one ss can belong to the same loop. Hence, we add the - loop to the chain only if it is different from the previously - added one, to avoid duplicate nested loops. */ - if (nested_loop != loop->nested) - { - gcc_assert (nested_loop->parent == NULL); - nested_loop->parent = loop; - - gcc_assert (nested_loop->next == NULL); - nested_loop->next = loop->nested; - loop->nested = nested_loop; - } - else - gcc_assert (nested_loop->parent == loop); - } - - if (ss->next == gfc_ss_terminator) - ss->loop_chain = loop->ss; - else - ss->loop_chain = ss->next; - } - gcc_assert (ss == gfc_ss_terminator); - loop->ss = head; -} - - -/* Returns true if the expression is an array pointer. */ - -static bool -is_pointer_array (tree expr) -{ - if (expr == NULL_TREE - || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr)) - || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) - return false; - - if (TREE_CODE (expr) == VAR_DECL - && GFC_DECL_PTR_ARRAY_P (expr)) - return true; - - if (TREE_CODE (expr) == PARM_DECL - && GFC_DECL_PTR_ARRAY_P (expr)) - return true; - - if (TREE_CODE (expr) == INDIRECT_REF - && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) - return true; - - /* The field declaration is marked as an pointer array. */ - if (TREE_CODE (expr) == COMPONENT_REF - && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) - && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) - return true; - - return false; -} - - -/* If the symbol or expression reference a CFI descriptor, return the - pointer to the converted gfc descriptor. If an array reference is - present as the last argument, check that it is the one applied to - the CFI descriptor in the expression. Note that the CFI object is - always the symbol in the expression! */ - -static bool -get_CFI_desc (gfc_symbol *sym, gfc_expr *expr, - tree *desc, gfc_array_ref *ar) -{ - tree tmp; - - if (!is_CFI_desc (sym, expr)) - return false; - - if (expr && ar) - { - if (!(expr->ref && expr->ref->type == REF_ARRAY) - || (&expr->ref->u.ar != ar)) - return false; - } - - if (sym == NULL) - tmp = expr->symtree->n.sym->backend_decl; - else - tmp = sym->backend_decl; - - if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) - tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); - - *desc = tmp; - return true; -} - - -/* Return the span of an array. */ - -tree -gfc_get_array_span (tree desc, gfc_expr *expr) -{ - tree tmp; - - if (is_pointer_array (desc) - || (get_CFI_desc (NULL, expr, &desc, NULL) - && (POINTER_TYPE_P (TREE_TYPE (desc)) - ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc))) - : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))))) - { - if (POINTER_TYPE_P (TREE_TYPE (desc))) - desc = build_fold_indirect_ref_loc (input_location, desc); - - /* This will have the span field set. */ - tmp = gfc_conv_descriptor_span_get (desc); - } - else if (expr->ts.type == BT_ASSUMED) - { - if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc)) - desc = GFC_DECL_SAVED_DESCRIPTOR (desc); - if (POINTER_TYPE_P (TREE_TYPE (desc))) - desc = build_fold_indirect_ref_loc (input_location, desc); - tmp = gfc_conv_descriptor_span_get (desc); - } - else if (TREE_CODE (desc) == COMPONENT_REF - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) - { - /* The descriptor is a class _data field and so use the vtable - size for the receiving span field. */ - tmp = gfc_get_vptr_from_expr (desc); - tmp = gfc_vptr_size_get (tmp); - } - else if (expr && expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym->ts.type == BT_CLASS - && expr->ref->type == REF_COMPONENT - && expr->ref->next->type == REF_ARRAY - && expr->ref->next->next == NULL - && CLASS_DATA (expr->symtree->n.sym)->attr.dimension) - { - /* Dummys come in sometimes with the descriptor detached from - the class field or declaration. */ - tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl); - tmp = gfc_vptr_size_get (tmp); - } - else - { - /* If none of the fancy stuff works, the span is the element - size of the array. Attempt to deal with unbounded character - types if possible. Otherwise, return NULL_TREE. */ - tmp = gfc_get_element_type (TREE_TYPE (desc)); - if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) - { - gcc_assert (expr->ts.type == BT_CHARACTER); - - tmp = gfc_get_character_len_in_bytes (tmp); - - if (tmp == NULL_TREE || integer_zerop (tmp)) - { - tree bs; - - tmp = gfc_get_expr_charlen (expr); - tmp = fold_convert (gfc_array_index_type, tmp); - bs = build_int_cst (gfc_array_index_type, expr->ts.kind); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, bs); - } - - tmp = (tmp && !integer_zerop (tmp)) - ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); - } - else - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (tmp)); - } - return tmp; -} - - -/* Generate an initializer for a static pointer or allocatable array. */ - -void -gfc_trans_static_array_pointer (gfc_symbol * sym) -{ - tree type; - - gcc_assert (TREE_STATIC (sym->backend_decl)); - /* Just zero the data member. */ - type = TREE_TYPE (sym->backend_decl); - DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type); -} - - -/* If the bounds of SE's loop have not yet been set, see if they can be - determined from array spec AS, which is the array spec of a called - function. MAPPING maps the callee's dummy arguments to the values - that the caller is passing. Add any initialization and finalization - code to SE. */ - -void -gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, - gfc_se * se, gfc_array_spec * as) -{ - int n, dim, total_dim; - gfc_se tmpse; - gfc_ss *ss; - tree lower; - tree upper; - tree tmp; - - total_dim = 0; - - if (!as || as->type != AS_EXPLICIT) - return; - - for (ss = se->ss; ss; ss = ss->parent) - { - total_dim += ss->loop->dimen; - for (n = 0; n < ss->loop->dimen; n++) - { - /* The bound is known, nothing to do. */ - if (ss->loop->to[n] != NULL_TREE) - continue; - - dim = ss->dim[n]; - gcc_assert (dim < as->rank); - gcc_assert (ss->loop->dimen <= as->rank); - - /* Evaluate the lower bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - lower = fold_convert (gfc_array_index_type, tmpse.expr); - - /* ...and the upper bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - upper = fold_convert (gfc_array_index_type, tmpse.expr); - - /* Set the upper bound of the loop to UPPER - LOWER. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - tmp = gfc_evaluate_now (tmp, &se->pre); - ss->loop->to[n] = tmp; - } - } - - gcc_assert (total_dim == as->rank); -} - - -/* Generate code to allocate an array temporary, or create a variable to - hold the data. If size is NULL, zero the descriptor so that the - callee will allocate the array. If DEALLOC is true, also generate code to - free the array afterwards. - - If INITIAL is not NULL, it is packed using internal_pack and the result used - as data instead of allocating a fresh, unitialized area of memory. - - Initialization code is added to PRE and finalization code to POST. - DYNAMIC is true if the caller may want to extend the array later - using realloc. This prevents us from putting the array on the stack. */ - -static void -gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, - gfc_array_info * info, tree size, tree nelem, - tree initial, bool dynamic, bool dealloc) -{ - tree tmp; - tree desc; - bool onstack; - - desc = info->descriptor; - info->offset = gfc_index_zero_node; - if (size == NULL_TREE || integer_zerop (size)) - { - /* A callee allocated array. */ - gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); - onstack = FALSE; - } - else - { - /* Allocate the temporary. */ - onstack = !dynamic && initial == NULL_TREE - && (flag_stack_arrays - || gfc_can_put_var_on_stack (size)); - - if (onstack) - { - /* Make a temporary variable to hold the data. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem), - nelem, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, pre); - tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, - tmp); - tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), - tmp); - tmp = gfc_create_var (tmp, "A"); - /* If we're here only because of -fstack-arrays we have to - emit a DECL_EXPR to make the gimplifier emit alloca calls. */ - if (!gfc_can_put_var_on_stack (size)) - gfc_add_expr_to_block (pre, - fold_build1_loc (input_location, - DECL_EXPR, TREE_TYPE (tmp), - tmp)); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - gfc_conv_descriptor_data_set (pre, desc, tmp); - } - else - { - /* Allocate memory to hold the data or call internal_pack. */ - if (initial == NULL_TREE) - { - tmp = gfc_call_malloc (pre, NULL, size); - tmp = gfc_evaluate_now (tmp, pre); - } - else - { - tree packed; - tree source_data; - tree was_packed; - stmtblock_t do_copying; - - tmp = TREE_TYPE (initial); /* Pointer to descriptor. */ - gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); - tmp = TREE_TYPE (tmp); /* The descriptor itself. */ - tmp = gfc_get_element_type (tmp); - packed = gfc_create_var (build_pointer_type (tmp), "data"); - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, initial); - tmp = fold_convert (TREE_TYPE (packed), tmp); - gfc_add_modify (pre, packed, tmp); - - tmp = build_fold_indirect_ref_loc (input_location, - initial); - source_data = gfc_conv_descriptor_data_get (tmp); - - /* internal_pack may return source->data without any allocation - or copying if it is already packed. If that's the case, we - need to allocate and copy manually. */ - - gfc_start_block (&do_copying); - tmp = gfc_call_malloc (&do_copying, NULL, size); - tmp = fold_convert (TREE_TYPE (packed), tmp); - gfc_add_modify (&do_copying, packed, tmp); - tmp = gfc_build_memcpy_call (packed, source_data, size); - gfc_add_expr_to_block (&do_copying, tmp); - - was_packed = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, packed, - source_data); - tmp = gfc_finish_block (&do_copying); - tmp = build3_v (COND_EXPR, was_packed, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (pre, tmp); - - tmp = fold_convert (pvoid_type_node, packed); - } - - gfc_conv_descriptor_data_set (pre, desc, tmp); - } - } - info->data = gfc_conv_descriptor_data_get (desc); - - /* The offset is zero because we create temporaries with a zero - lower bound. */ - gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node); - - if (dealloc && !onstack) - { - /* Free the temporary. */ - tmp = gfc_conv_descriptor_data_get (desc); - tmp = gfc_call_free (tmp); - gfc_add_expr_to_block (post, tmp); - } -} - - -/* Get the scalarizer array dimension corresponding to actual array dimension - given by ARRAY_DIM. - - For example, if SS represents the array ref a(1,:,:,1), it is a - bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1, - and 1 for ARRAY_DIM=2. - If SS represents transpose(a(:,1,1,:)), it is again a bidimensional - scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for - ARRAY_DIM=3. - If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer - array. If called on the inner ss, the result would be respectively 0,1,2 for - ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1 - for ARRAY_DIM=1,2. */ - -static int -get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim) -{ - int array_ref_dim; - int n; - - array_ref_dim = 0; - - for (; ss; ss = ss->parent) - for (n = 0; n < ss->dimen; n++) - if (ss->dim[n] < array_dim) - array_ref_dim++; - - return array_ref_dim; -} - - -static gfc_ss * -innermost_ss (gfc_ss *ss) -{ - while (ss->nested_ss != NULL) - ss = ss->nested_ss; - - return ss; -} - - - -/* Get the array reference dimension corresponding to the given loop dimension. - It is different from the true array dimension given by the dim array in - the case of a partial array reference (i.e. a(:,:,1,:) for example) - It is different from the loop dimension in the case of a transposed array. - */ - -static int -get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) -{ - return get_scalarizer_dim_for_array_dim (innermost_ss (ss), - ss->dim[loop_dim]); -} - - -/* Use the information in the ss to obtain the required information about - the type and size of an array temporary, when the lhs in an assignment - is a class expression. */ - -static tree -get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) -{ - gfc_ss *lhs_ss; - gfc_ss *rhs_ss; - tree tmp; - tree tmp2; - tree vptr; - tree rhs_class_expr = NULL_TREE; - tree lhs_class_expr = NULL_TREE; - bool unlimited_rhs = false; - bool unlimited_lhs = false; - bool rhs_function = false; - gfc_symbol *vtab; - - /* The second element in the loop chain contains the source for the - temporary; ie. the rhs of the assignment. */ - rhs_ss = ss->loop->ss->loop_chain; - - if (rhs_ss != gfc_ss_terminator - && rhs_ss->info - && rhs_ss->info->expr - && rhs_ss->info->expr->ts.type == BT_CLASS - && rhs_ss->info->data.array.descriptor) - { - if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE) - rhs_class_expr - = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor); - else - rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr); - unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr); - if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION) - rhs_function = true; - } - - /* For an assignment the lhs is the next element in the loop chain. - If we have a class rhs, this had better be a class variable - expression! */ - lhs_ss = rhs_ss->loop_chain; - if (lhs_ss != gfc_ss_terminator - && lhs_ss->info - && lhs_ss->info->expr - && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE - && lhs_ss->info->expr->ts.type == BT_CLASS) - { - tmp = lhs_ss->info->data.array.descriptor; - unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr); - } - else - tmp = NULL_TREE; - - /* Get the lhs class expression. */ - if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator) - lhs_class_expr = gfc_get_class_from_expr (tmp); - else - return rhs_class_expr; - - gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr))); - - /* Set the lhs vptr and, if necessary, the _len field. */ - if (rhs_class_expr) - { - /* Both lhs and rhs are class expressions. */ - tmp = gfc_class_vptr_get (lhs_class_expr); - gfc_add_modify (pre, tmp, - fold_convert (TREE_TYPE (tmp), - gfc_class_vptr_get (rhs_class_expr))); - if (unlimited_lhs) - { - tmp = gfc_class_len_get (lhs_class_expr); - if (unlimited_rhs) - tmp2 = gfc_class_len_get (rhs_class_expr); - else - tmp2 = build_int_cst (TREE_TYPE (tmp), 0); - gfc_add_modify (pre, tmp, tmp2); - } - - if (rhs_function) - { - tmp = gfc_class_data_get (rhs_class_expr); - gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); - } - } - else - { - /* lhs is class and rhs is intrinsic or derived type. */ - *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor); - *eltype = gfc_get_element_type (*eltype); - vtab = gfc_find_vtab (&rhs_ss->info->expr->ts); - vptr = vtab->backend_decl; - if (vptr == NULL_TREE) - vptr = gfc_get_symbol_decl (vtab); - vptr = gfc_build_addr_expr (NULL_TREE, vptr); - tmp = gfc_class_vptr_get (lhs_class_expr); - gfc_add_modify (pre, tmp, - fold_convert (TREE_TYPE (tmp), vptr)); - - if (unlimited_lhs) - { - tmp = gfc_class_len_get (lhs_class_expr); - if (rhs_ss->info - && rhs_ss->info->expr - && rhs_ss->info->expr->ts.type == BT_CHARACTER) - tmp2 = build_int_cst (TREE_TYPE (tmp), - rhs_ss->info->expr->ts.kind); - else - tmp2 = build_int_cst (TREE_TYPE (tmp), 0); - gfc_add_modify (pre, tmp, tmp2); - } - } - - return rhs_class_expr; -} - - - -/* Generate code to create and initialize the descriptor for a temporary - array. This is used for both temporaries needed by the scalarizer, and - functions returning arrays. Adjusts the loop variables to be - zero-based, and calculates the loop bounds for callee allocated arrays. - Allocate the array unless it's callee allocated (we have a callee - allocated array if 'callee_alloc' is true, or if loop->to[n] is - NULL_TREE for any n). Also fills in the descriptor, data and offset - fields of info if known. Returns the size of the array, or NULL for a - callee allocated array. - - 'eltype' == NULL signals that the temporary should be a class object. - The 'initial' expression is used to obtain the size of the dynamic - type; otherwise the allocation and initialization proceeds as for any - other expression - - PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for - gfc_trans_allocate_array_storage. */ - -tree -gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, - tree eltype, tree initial, bool dynamic, - bool dealloc, bool callee_alloc, locus * where) -{ - gfc_loopinfo *loop; - gfc_ss *s; - gfc_array_info *info; - tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; - tree type; - tree desc; - tree tmp; - tree size; - tree nelem; - tree cond; - tree or_expr; - tree elemsize; - tree class_expr = NULL_TREE; - int n, dim, tmp_dim; - int total_dim = 0; - - /* This signals a class array for which we need the size of the - dynamic type. Generate an eltype and then the class expression. */ - if (eltype == NULL_TREE && initial) - { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); - class_expr = build_fold_indirect_ref_loc (input_location, initial); - /* Obtain the structure (class) expression. */ - class_expr = gfc_get_class_from_expr (class_expr); - gcc_assert (class_expr); - } - - /* Otherwise, some expressions, such as class functions, arising from - dependency checking in assignments come here with class element type. - The descriptor can be obtained from the ss->info and then converted - to the class object. */ - if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype)) - class_expr = get_class_info_from_ss (pre, ss, &eltype); - - /* If the dynamic type is not available, use the declared type. */ - if (eltype && GFC_CLASS_TYPE_P (eltype)) - eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype))); - - if (class_expr == NULL_TREE) - elemsize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (eltype)); - else - { - /* Unlimited polymorphic entities are initialised with NULL vptr. They - can be tested for by checking if the len field is present. If so - test the vptr before using the vtable size. */ - tmp = gfc_class_vptr_get (class_expr); - tmp = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), 0)); - elemsize = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, - tmp, - gfc_class_vtab_size_get (class_expr), - gfc_index_zero_node); - elemsize = gfc_evaluate_now (elemsize, pre); - elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize); - /* Casting the data as a character of the dynamic length ensures that - assignment of elements works when needed. */ - eltype = gfc_get_character_type_len (1, elemsize); - } - - memset (from, 0, sizeof (from)); - memset (to, 0, sizeof (to)); - - info = &ss->info->data.array; - - gcc_assert (ss->dimen > 0); - gcc_assert (ss->loop->dimen == ss->dimen); - - if (warn_array_temporaries && where) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", where); - - /* Set the lower bound to zero. */ - for (s = ss; s; s = s->parent) - { - loop = s->loop; - - total_dim += loop->dimen; - for (n = 0; n < loop->dimen; n++) - { - dim = s->dim[n]; - - /* Callee allocated arrays may not have a known bound yet. */ - if (loop->to[n]) - loop->to[n] = gfc_evaluate_now ( - fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]), - pre); - loop->from[n] = gfc_index_zero_node; - - /* We have just changed the loop bounds, we must clear the - corresponding specloop, so that delta calculation is not skipped - later in gfc_set_delta. */ - loop->specloop[n] = NULL; - - /* We are constructing the temporary's descriptor based on the loop - dimensions. As the dimensions may be accessed in arbitrary order - (think of transpose) the size taken from the n'th loop may not map - to the n'th dimension of the array. We need to reconstruct loop - infos in the right order before using it to set the descriptor - bounds. */ - tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim); - from[tmp_dim] = loop->from[n]; - to[tmp_dim] = loop->to[n]; - - info->delta[dim] = gfc_index_zero_node; - info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; - } - } - - /* Initialize the descriptor. */ - type = - gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1, - GFC_ARRAY_UNKNOWN, true); - desc = gfc_create_var (type, "atmp"); - GFC_DECL_PACKED_ARRAY (desc) = 1; - - /* Emit a DECL_EXPR for the variable sized array type in - GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type - sizes works correctly. */ - tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type)); - if (! TYPE_NAME (arraytype)) - TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, - NULL_TREE, arraytype); - gfc_add_expr_to_block (pre, build1 (DECL_EXPR, - arraytype, TYPE_NAME (arraytype))); - - if (class_expr != NULL_TREE) - { - tree class_data; - tree dtype; - - /* Create a class temporary. */ - tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); - gfc_add_modify (pre, tmp, class_expr); - - /* Assign the new descriptor to the _data field. This allows the - vptr _copy to be used for scalarized assignment since the class - temporary can be found from the descriptor. */ - class_data = gfc_class_data_get (tmp); - tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, - TREE_TYPE (desc), desc); - gfc_add_modify (pre, class_data, tmp); - - /* Take the dtype from the class expression. */ - dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); - tmp = gfc_conv_descriptor_dtype (class_data); - gfc_add_modify (pre, tmp, dtype); - - /* Point desc to the class _data field. */ - desc = class_data; - } - else - { - /* Fill in the array dtype. */ - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); - } - - info->descriptor = desc; - size = gfc_index_one_node; - - /* - Fill in the bounds and stride. This is a packed array, so: - - size = 1; - for (n = 0; n < rank; n++) - { - stride[n] = size - delta = ubound[n] + 1 - lbound[n]; - size = size * delta; - } - size = size * sizeof(element); - */ - - or_expr = NULL_TREE; - - /* If there is at least one null loop->to[n], it is a callee allocated - array. */ - for (n = 0; n < total_dim; n++) - if (to[n] == NULL_TREE) - { - size = NULL_TREE; - break; - } - - if (size == NULL_TREE) - for (s = ss; s; s = s->parent) - for (n = 0; n < s->loop->dimen; n++) - { - dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]); - - /* For a callee allocated array express the loop bounds in terms - of the descriptor fields. */ - tmp = fold_build2_loc (input_location, - MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); - s->loop->to[n] = tmp; - } - else - { - for (n = 0; n < total_dim; n++) - { - /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); - - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], - gfc_index_zero_node); - - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); - - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - to[n], gfc_index_one_node); - - /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - tmp, gfc_index_zero_node); - cond = gfc_evaluate_now (cond, pre); - - if (n == 0) - or_expr = cond; - else - or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, or_expr, cond); - - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - size = gfc_evaluate_now (size, pre); - } - } - - /* Get the size of the array. */ - if (size && !callee_alloc) - { - /* If or_expr is true, then the extent in at least one - dimension is zero and the size is set to zero. */ - size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, - or_expr, gfc_index_zero_node, size); - - nelem = size; - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, elemsize); - } - else - { - nelem = size; - size = NULL_TREE; - } - - /* Set the span. */ - tmp = fold_convert (gfc_array_index_type, elemsize); - gfc_conv_descriptor_span_set (pre, desc, tmp); - - gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, - dynamic, dealloc); - - while (ss->parent) - ss = ss->parent; - - if (ss->dimen > ss->loop->temp_dim) - ss->loop->temp_dim = ss->dimen; - - return size; -} - - -/* Return the number of iterations in a loop that starts at START, - ends at END, and has step STEP. */ - -static tree -gfc_get_iteration_count (tree start, tree end, tree step) -{ - tree tmp; - tree type; - - type = TREE_TYPE (step); - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, - build_int_cst (type, 1)); - tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp, - build_int_cst (type, 0)); - return fold_convert (gfc_array_index_type, tmp); -} - - -/* Extend the data in array DESC by EXTRA elements. */ - -static void -gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) -{ - tree arg0, arg1; - tree tmp; - tree size; - tree ubound; - - if (integer_zerop (extra)) - return; - - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); - - /* Add EXTRA to the upper bound. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, extra); - gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); - - /* Get the value of the current data pointer. */ - arg0 = gfc_conv_descriptor_data_get (desc); - - /* Calculate the new array size. */ - size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - ubound, gfc_index_one_node); - arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, tmp), - fold_convert (size_type_node, size)); - - /* Call the realloc() function. */ - tmp = gfc_call_realloc (pblock, arg0, arg1); - gfc_conv_descriptor_data_set (pblock, desc, tmp); -} - - -/* Return true if the bounds of iterator I can only be determined - at run time. */ - -static inline bool -gfc_iterator_has_dynamic_bounds (gfc_iterator * i) -{ - return (i->start->expr_type != EXPR_CONSTANT - || i->end->expr_type != EXPR_CONSTANT - || i->step->expr_type != EXPR_CONSTANT); -} - - -/* Split the size of constructor element EXPR into the sum of two terms, - one of which can be determined at compile time and one of which must - be calculated at run time. Set *SIZE to the former and return true - if the latter might be nonzero. */ - -static bool -gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) -{ - if (expr->expr_type == EXPR_ARRAY) - return gfc_get_array_constructor_size (size, expr->value.constructor); - else if (expr->rank > 0) - { - /* Calculate everything at run time. */ - mpz_set_ui (*size, 0); - return true; - } - else - { - /* A single element. */ - mpz_set_ui (*size, 1); - return false; - } -} - - -/* Like gfc_get_array_constructor_element_size, but applied to the whole - of array constructor C. */ - -static bool -gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) -{ - gfc_constructor *c; - gfc_iterator *i; - mpz_t val; - mpz_t len; - bool dynamic; - - mpz_set_ui (*size, 0); - mpz_init (len); - mpz_init (val); - - dynamic = false; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - i = c->iterator; - if (i && gfc_iterator_has_dynamic_bounds (i)) - dynamic = true; - else - { - dynamic |= gfc_get_array_constructor_element_size (&len, c->expr); - if (i) - { - /* Multiply the static part of the element size by the - number of iterations. */ - mpz_sub (val, i->end->value.integer, i->start->value.integer); - mpz_fdiv_q (val, val, i->step->value.integer); - mpz_add_ui (val, val, 1); - if (mpz_sgn (val) > 0) - mpz_mul (len, len, val); - else - mpz_set_ui (len, 0); - } - mpz_add (*size, *size, len); - } - } - mpz_clear (len); - mpz_clear (val); - return dynamic; -} - - -/* Make sure offset is a variable. */ - -static void -gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, - tree * offsetvar) -{ - /* We should have already created the offset variable. We cannot - create it here because we may be in an inner scope. */ - gcc_assert (*offsetvar != NULL_TREE); - gfc_add_modify (pblock, *offsetvar, *poffset); - *poffset = *offsetvar; - TREE_USED (*offsetvar) = 1; -} - - -/* Variables needed for bounds-checking. */ -static bool first_len; -static tree first_len_val; -static bool typespec_chararray_ctor; - -static void -gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, - tree offset, gfc_se * se, gfc_expr * expr) -{ - tree tmp; - - gfc_conv_expr (se, expr); - - /* Store the value. */ - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_descriptor_data_get (desc)); - tmp = gfc_build_array_ref (tmp, offset, NULL); - - if (expr->ts.type == BT_CHARACTER) - { - int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); - tree esize; - - esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); - esize = fold_convert (gfc_charlen_type_node, esize); - esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - TREE_TYPE (esize), esize, - build_int_cst (TREE_TYPE (esize), - gfc_character_kinds[i].bit_size / 8)); - - gfc_conv_string_parameter (se); - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - { - /* The temporary is an array of pointers. */ - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - else - { - /* The temporary is an array of string values. */ - tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp); - /* We know the temporary and the value will be the same length, - so can use memcpy. */ - gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind, - se->string_length, se->expr, expr->ts.kind); - } - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor) - { - if (first_len) - { - gfc_add_modify (&se->pre, first_len_val, - fold_convert (TREE_TYPE (first_len_val), - se->string_length)); - first_len = false; - } - else - { - /* Verify that all constructor elements are of the same - length. */ - tree rhs = fold_convert (TREE_TYPE (first_len_val), - se->string_length); - tree cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, first_len_val, - rhs); - gfc_trans_runtime_check - (true, false, cond, &se->pre, &expr->where, - "Different CHARACTER lengths (%ld/%ld) in array constructor", - fold_convert (long_integer_type_node, first_len_val), - fold_convert (long_integer_type_node, se->string_length)); - } - } - } - else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) - && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc)))) - { - /* Assignment of a CLASS array constructor to a derived type array. */ - if (expr->expr_type == EXPR_FUNCTION) - se->expr = gfc_evaluate_now (se->expr, pblock); - se->expr = gfc_class_data_get (se->expr); - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - else - { - /* TODO: Should the frontend already have done this conversion? */ - se->expr = fold_convert (TREE_TYPE (tmp), se->expr); - gfc_add_modify (&se->pre, tmp, se->expr); - } - - gfc_add_block_to_block (pblock, &se->pre); - gfc_add_block_to_block (pblock, &se->post); -} - - -/* Add the contents of an array to the constructor. DYNAMIC is as for - gfc_trans_array_constructor_value. */ - -static void -gfc_trans_array_constructor_subarray (stmtblock_t * pblock, - tree type ATTRIBUTE_UNUSED, - tree desc, gfc_expr * expr, - tree * poffset, tree * offsetvar, - bool dynamic) -{ - gfc_se se; - gfc_ss *ss; - gfc_loopinfo loop; - stmtblock_t body; - tree tmp; - tree size; - int n; - - /* We need this to be a variable so we can increment it. */ - gfc_put_offset_into_var (pblock, poffset, offsetvar); - - gfc_init_se (&se, NULL); - - /* Walk the array expression. */ - ss = gfc_walk_expr (expr); - gcc_assert (ss != gfc_ss_terminator); - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, ss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - /* Make sure the constructed array has room for the new data. */ - if (dynamic) - { - /* Set SIZE to the total number of elements in the subarray. */ - size = gfc_index_one_node; - for (n = 0; n < loop.dimen; n++) - { - tmp = gfc_get_iteration_count (loop.from[n], loop.to[n], - gfc_index_one_node); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - } - - /* Grow the constructed array by SIZE elements. */ - gfc_grow_array (&loop.pre, desc, size); - } - - /* Make the loop body. */ - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &body); - gfc_copy_loopinfo_to_se (&se, &loop); - se.ss = ss; - - gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr); - gcc_assert (se.ss == gfc_ss_terminator); - - /* Increment the offset. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - *poffset, gfc_index_one_node); - gfc_add_modify (&body, *poffset, tmp); - - /* Finish the loop. */ - gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&loop.pre, &loop.post); - tmp = gfc_finish_block (&loop.pre); - gfc_add_expr_to_block (pblock, tmp); - - gfc_cleanup_loop (&loop); -} - - -/* Assign the values to the elements of an array constructor. DYNAMIC - is true if descriptor DESC only contains enough data for the static - size calculated by gfc_get_array_constructor_size. When true, memory - for the dynamic parts must be allocated using realloc. */ - -static void -gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, - tree desc, gfc_constructor_base base, - tree * poffset, tree * offsetvar, - bool dynamic) -{ - tree tmp; - tree start = NULL_TREE; - tree end = NULL_TREE; - tree step = NULL_TREE; - stmtblock_t body; - gfc_se se; - mpz_t size; - gfc_constructor *c; - - tree shadow_loopvar = NULL_TREE; - gfc_saved_var saved_loopvar; - - mpz_init (size); - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) - { - /* If this is an iterator or an array, the offset must be a variable. */ - if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) - gfc_put_offset_into_var (pblock, poffset, offsetvar); - - /* Shadowing the iterator avoids changing its value and saves us from - keeping track of it. Further, it makes sure that there's always a - backend-decl for the symbol, even if there wasn't one before, - e.g. in the case of an iterator that appears in a specification - expression in an interface mapping. */ - if (c->iterator) - { - gfc_symbol *sym; - tree type; - - /* Evaluate loop bounds before substituting the loop variable - in case they depend on it. Such a case is invalid, but it is - not more expensive to do the right thing here. - See PR 44354. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->start); - gfc_add_block_to_block (pblock, &se.pre); - start = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->end); - gfc_add_block_to_block (pblock, &se.pre); - end = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->step); - gfc_add_block_to_block (pblock, &se.pre); - step = gfc_evaluate_now (se.expr, pblock); - - sym = c->iterator->var->symtree->n.sym; - type = gfc_typenode_for_spec (&sym->ts); - - shadow_loopvar = gfc_create_var (type, "shadow_loopvar"); - gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar); - } - - gfc_start_block (&body); - - if (c->expr->expr_type == EXPR_ARRAY) - { - /* Array constructors can be nested. */ - gfc_trans_array_constructor_value (&body, type, desc, - c->expr->value.constructor, - poffset, offsetvar, dynamic); - } - else if (c->expr->rank > 0) - { - gfc_trans_array_constructor_subarray (&body, type, desc, c->expr, - poffset, offsetvar, dynamic); - } - else - { - /* This code really upsets the gimplifier so don't bother for now. */ - gfc_constructor *p; - HOST_WIDE_INT n; - HOST_WIDE_INT size; - - p = c; - n = 0; - while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) - { - p = gfc_constructor_next (p); - n++; - } - if (n < 4) - { - /* Scalar values. */ - gfc_init_se (&se, NULL); - gfc_trans_array_ctor_element (&body, desc, *poffset, - &se, c->expr); - - *poffset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - *poffset, gfc_index_one_node); - } - else - { - /* Collect multiple scalar constants into a constructor. */ - vec *v = NULL; - tree init; - tree bound; - tree tmptype; - HOST_WIDE_INT idx = 0; - - p = c; - /* Count the number of consecutive scalar constants. */ - while (p && !(p->iterator - || p->expr->expr_type != EXPR_CONSTANT)) - { - gfc_init_se (&se, NULL); - gfc_conv_constant (&se, p->expr); - - if (c->expr->ts.type != BT_CHARACTER) - se.expr = fold_convert (type, se.expr); - /* For constant character array constructors we build - an array of pointers. */ - else if (POINTER_TYPE_P (type)) - se.expr = gfc_build_addr_expr - (gfc_get_pchar_type (p->expr->ts.kind), - se.expr); - - CONSTRUCTOR_APPEND_ELT (v, - build_int_cst (gfc_array_index_type, - idx++), - se.expr); - c = p; - p = gfc_constructor_next (p); - } - - bound = size_int (n - 1); - /* Create an array type to hold them. */ - tmptype = build_range_type (gfc_array_index_type, - gfc_index_zero_node, bound); - tmptype = build_array_type (type, tmptype); - - init = build_constructor (tmptype, v); - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - /* Create a static variable to hold the data. */ - tmp = gfc_create_var (tmptype, "data"); - TREE_STATIC (tmp) = 1; - TREE_CONSTANT (tmp) = 1; - TREE_READONLY (tmp) = 1; - DECL_INITIAL (tmp) = init; - init = tmp; - - /* Use BUILTIN_MEMCPY to assign the values. */ - tmp = gfc_conv_descriptor_data_get (desc); - tmp = build_fold_indirect_ref_loc (input_location, - tmp); - tmp = gfc_build_array_ref (tmp, *poffset, NULL); - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - init = gfc_build_addr_expr (NULL_TREE, init); - - size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); - bound = build_int_cst (size_type_node, n * size); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), - 3, tmp, init, bound); - gfc_add_expr_to_block (&body, tmp); - - *poffset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, *poffset, - build_int_cst (gfc_array_index_type, n)); - } - if (!INTEGER_CST_P (*poffset)) - { - gfc_add_modify (&body, *offsetvar, *poffset); - *poffset = *offsetvar; - } - } - - /* The frontend should already have done any expansions - at compile-time. */ - if (!c->iterator) - { - /* Pass the code as is. */ - tmp = gfc_finish_block (&body); - gfc_add_expr_to_block (pblock, tmp); - } - else - { - /* Build the implied do-loop. */ - stmtblock_t implied_do_block; - tree cond; - tree exit_label; - tree loopbody; - tree tmp2; - - loopbody = gfc_finish_block (&body); - - /* Create a new block that holds the implied-do loop. A temporary - loop-variable is used. */ - gfc_start_block(&implied_do_block); - - /* Initialize the loop. */ - gfc_add_modify (&implied_do_block, shadow_loopvar, start); - - /* If this array expands dynamically, and the number of iterations - is not constant, we won't have allocated space for the static - part of C->EXPR's size. Do that now. */ - if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator)) - { - /* Get the number of iterations. */ - tmp = gfc_get_iteration_count (shadow_loopvar, end, step); - - /* Get the static part of C->EXPR's size. */ - gfc_get_array_constructor_element_size (&size, c->expr); - tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); - - /* Grow the array by TMP * TMP2 elements. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, tmp2); - gfc_grow_array (&implied_do_block, desc, tmp); - } - - /* Generate the loop body. */ - exit_label = gfc_build_label_decl (NULL_TREE); - gfc_start_block (&body); - - /* Generate the exit condition. Depending on the sign of - the step variable we have to generate the correct - comparison. */ - tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - step, build_int_cst (TREE_TYPE (step), 0)); - cond = fold_build3_loc (input_location, COND_EXPR, - logical_type_node, tmp, - fold_build2_loc (input_location, GT_EXPR, - logical_type_node, shadow_loopvar, end), - fold_build2_loc (input_location, LT_EXPR, - logical_type_node, shadow_loopvar, end)); - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = build3_v (COND_EXPR, cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&body, tmp); - - /* The main loop body. */ - gfc_add_expr_to_block (&body, loopbody); - - /* Increase loop variable by step. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (shadow_loopvar), shadow_loopvar, - step); - gfc_add_modify (&body, shadow_loopvar, tmp); - - /* Finish the loop. */ - tmp = gfc_finish_block (&body); - tmp = build1_v (LOOP_EXPR, tmp); - gfc_add_expr_to_block (&implied_do_block, tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&implied_do_block, tmp); - - /* Finish the implied-do loop. */ - tmp = gfc_finish_block(&implied_do_block); - gfc_add_expr_to_block(pblock, tmp); - - gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar); - } - } - mpz_clear (size); -} - - -/* The array constructor code can create a string length with an operand - in the form of a temporary variable. This variable will retain its - context (current_function_decl). If we store this length tree in a - gfc_charlen structure which is shared by a variable in another - context, the resulting gfc_charlen structure with a variable in a - different context, we could trip the assertion in expand_expr_real_1 - when it sees that a variable has been created in one context and - referenced in another. - - If this might be the case, we create a new gfc_charlen structure and - link it into the current namespace. */ - -static void -store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl) -{ - if (force_new_cl) - { - gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp); - *clp = new_cl; - } - (*clp)->backend_decl = len; -} - -/* A catch-all to obtain the string length for anything that is not - a substring of non-constant length, a constant, array or variable. */ - -static void -get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) -{ - gfc_se se; - - /* Don't bother if we already know the length is a constant. */ - if (*len && INTEGER_CST_P (*len)) - return; - - if (!e->ref && e->ts.u.cl && e->ts.u.cl->length - && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - /* This is easy. */ - gfc_conv_const_charlen (e->ts.u.cl); - *len = e->ts.u.cl->backend_decl; - } - else - { - /* Otherwise, be brutal even if inefficient. */ - gfc_init_se (&se, NULL); - - /* No function call, in case of side effects. */ - se.no_function_call = 1; - if (e->rank == 0) - gfc_conv_expr (&se, e); - else - gfc_conv_expr_descriptor (&se, e); - - /* Fix the value. */ - *len = gfc_evaluate_now (se.string_length, &se.pre); - - gfc_add_block_to_block (block, &se.pre); - gfc_add_block_to_block (block, &se.post); - - store_backend_decl (&e->ts.u.cl, *len, true); - } -} - - -/* Figure out the string length of a variable reference expression. - Used by get_array_ctor_strlen. */ - -static void -get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) -{ - gfc_ref *ref; - gfc_typespec *ts; - mpz_t char_len; - gfc_se se; - - /* Don't bother if we already know the length is a constant. */ - if (*len && INTEGER_CST_P (*len)) - return; - - ts = &expr->symtree->n.sym->ts; - for (ref = expr->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_ARRAY: - /* Array references don't change the string length. */ - if (ts->deferred) - get_array_ctor_all_strlen (block, expr, len); - break; - - case REF_COMPONENT: - /* Use the length of the component. */ - ts = &ref->u.c.component->ts; - break; - - case REF_SUBSTRING: - if (ref->u.ss.end == NULL - || ref->u.ss.start->expr_type != EXPR_CONSTANT - || ref->u.ss.end->expr_type != EXPR_CONSTANT) - { - /* Note that this might evaluate expr. */ - get_array_ctor_all_strlen (block, expr, len); - return; - } - mpz_init_set_ui (char_len, 1); - mpz_add (char_len, char_len, ref->u.ss.end->value.integer); - mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); - *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node); - mpz_clear (char_len); - return; - - case REF_INQUIRY: - break; - - default: - gcc_unreachable (); - } - } - - /* A last ditch attempt that is sometimes needed for deferred characters. */ - if (!ts->u.cl->backend_decl) - { - gfc_init_se (&se, NULL); - if (expr->rank) - gfc_conv_expr_descriptor (&se, expr); - else - gfc_conv_expr (&se, expr); - gcc_assert (se.string_length != NULL_TREE); - gfc_add_block_to_block (block, &se.pre); - ts->u.cl->backend_decl = se.string_length; - } - - *len = ts->u.cl->backend_decl; -} - - -/* Figure out the string length of a character array constructor. - If len is NULL, don't calculate the length; this happens for recursive calls - when a sub-array-constructor is an element but not at the first position, - so when we're not interested in the length. - Returns TRUE if all elements are character constants. */ - -bool -get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) -{ - gfc_constructor *c; - bool is_const; - - is_const = TRUE; - - if (gfc_constructor_first (base) == NULL) - { - if (len) - *len = build_int_cstu (gfc_charlen_type_node, 0); - return is_const; - } - - /* Loop over all constructor elements to find out is_const, but in len we - want to store the length of the first, not the last, element. We can - of course exit the loop as soon as is_const is found to be false. */ - for (c = gfc_constructor_first (base); - c && is_const; c = gfc_constructor_next (c)) - { - switch (c->expr->expr_type) - { - case EXPR_CONSTANT: - if (len && !(*len && INTEGER_CST_P (*len))) - *len = build_int_cstu (gfc_charlen_type_node, - c->expr->value.character.length); - break; - - case EXPR_ARRAY: - if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) - is_const = false; - break; - - case EXPR_VARIABLE: - is_const = false; - if (len) - get_array_ctor_var_strlen (block, c->expr, len); - break; - - default: - is_const = false; - if (len) - get_array_ctor_all_strlen (block, c->expr, len); - break; - } - - /* After the first iteration, we don't want the length modified. */ - len = NULL; - } - - return is_const; -} - -/* Check whether the array constructor C consists entirely of constant - elements, and if so returns the number of those elements, otherwise - return zero. Note, an empty or NULL array constructor returns zero. */ - -unsigned HOST_WIDE_INT -gfc_constant_array_constructor_p (gfc_constructor_base base) -{ - unsigned HOST_WIDE_INT nelem = 0; - - gfc_constructor *c = gfc_constructor_first (base); - while (c) - { - if (c->iterator - || c->expr->rank > 0 - || c->expr->expr_type != EXPR_CONSTANT) - return 0; - c = gfc_constructor_next (c); - nelem++; - } - return nelem; -} - - -/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY, - and the tree type of it's elements, TYPE, return a static constant - variable that is compile-time initialized. */ - -tree -gfc_build_constant_array_constructor (gfc_expr * expr, tree type) -{ - tree tmptype, init, tmp; - HOST_WIDE_INT nelem; - gfc_constructor *c; - gfc_array_spec as; - gfc_se se; - int i; - vec *v = NULL; - - /* First traverse the constructor list, converting the constants - to tree to build an initializer. */ - nelem = 0; - c = gfc_constructor_first (expr->value.constructor); - while (c) - { - gfc_init_se (&se, NULL); - gfc_conv_constant (&se, c->expr); - if (c->expr->ts.type != BT_CHARACTER) - se.expr = fold_convert (type, se.expr); - else if (POINTER_TYPE_P (type)) - se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), - se.expr); - CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), - se.expr); - c = gfc_constructor_next (c); - nelem++; - } - - /* Next determine the tree type for the array. We use the gfortran - front-end's gfc_get_nodesc_array_type in order to create a suitable - GFC_ARRAY_TYPE_P that may be used by the scalarizer. */ - - memset (&as, 0, sizeof (gfc_array_spec)); - - as.rank = expr->rank; - as.type = AS_EXPLICIT; - if (!expr->shape) - { - as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, nelem - 1); - } - else - for (i = 0; i < expr->rank; i++) - { - int tmp = (int) mpz_get_si (expr->shape[i]); - as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, tmp - 1); - } - - tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); - - /* as is not needed anymore. */ - for (i = 0; i < as.rank + as.corank; i++) - { - gfc_free_expr (as.lower[i]); - gfc_free_expr (as.upper[i]); - } - - init = build_constructor (tmptype, v); - - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - - tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"), - tmptype); - DECL_ARTIFICIAL (tmp) = 1; - DECL_IGNORED_P (tmp) = 1; - TREE_STATIC (tmp) = 1; - TREE_CONSTANT (tmp) = 1; - TREE_READONLY (tmp) = 1; - DECL_INITIAL (tmp) = init; - pushdecl (tmp); - - return tmp; -} - - -/* Translate a constant EXPR_ARRAY array constructor for the scalarizer. - This mostly initializes the scalarizer state info structure with the - appropriate values to directly use the array created by the function - gfc_build_constant_array_constructor. */ - -static void -trans_constant_array_constructor (gfc_ss * ss, tree type) -{ - gfc_array_info *info; - tree tmp; - int i; - - tmp = gfc_build_constant_array_constructor (ss->info->expr, type); - - info = &ss->info->data.array; - - info->descriptor = tmp; - info->data = gfc_build_addr_expr (NULL_TREE, tmp); - info->offset = gfc_index_zero_node; - - for (i = 0; i < ss->dimen; i++) - { - info->delta[i] = gfc_index_zero_node; - info->start[i] = gfc_index_zero_node; - info->end[i] = gfc_index_zero_node; - info->stride[i] = gfc_index_one_node; - } -} - - -static int -get_rank (gfc_loopinfo *loop) -{ - int rank; - - rank = 0; - for (; loop; loop = loop->parent) - rank += loop->dimen; - - return rank; -} - - -/* Helper routine of gfc_trans_array_constructor to determine if the - bounds of the loop specified by LOOP are constant and simple enough - to use with trans_constant_array_constructor. Returns the - iteration count of the loop if suitable, and NULL_TREE otherwise. */ - -static tree -constant_array_constructor_loop_size (gfc_loopinfo * l) -{ - gfc_loopinfo *loop; - tree size = gfc_index_one_node; - tree tmp; - int i, total_dim; - - total_dim = get_rank (l); - - for (loop = l; loop; loop = loop->parent) - { - for (i = 0; i < loop->dimen; i++) - { - /* If the bounds aren't constant, return NULL_TREE. */ - if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) - return NULL_TREE; - if (!integer_zerop (loop->from[i])) - { - /* Only allow nonzero "from" in one-dimensional arrays. */ - if (total_dim != 1) - return NULL_TREE; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[i], loop->from[i]); - } - else - tmp = loop->to[i]; - 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); - } - } - - return size; -} - - -static tree * -get_loop_upper_bound_for_array (gfc_ss *array, int array_dim) -{ - gfc_ss *ss; - int n; - - gcc_assert (array->nested_ss == NULL); - - for (ss = array; ss; ss = ss->parent) - for (n = 0; n < ss->loop->dimen; n++) - if (array_dim == get_array_ref_dim_for_loop_dim (ss, n)) - return &(ss->loop->to[n]); - - gcc_unreachable (); -} - - -static gfc_loopinfo * -outermost_loop (gfc_loopinfo * loop) -{ - while (loop->parent != NULL) - loop = loop->parent; - - return loop; -} - - -/* Array constructors are handled by constructing a temporary, then using that - within the scalarization loop. This is not optimal, but seems by far the - simplest method. */ - -static void -trans_array_constructor (gfc_ss * ss, locus * where) -{ - gfc_constructor_base c; - tree offset; - tree offsetvar; - tree desc; - tree type; - tree tmp; - tree *loop_ubound0; - bool dynamic; - bool old_first_len, old_typespec_chararray_ctor; - tree old_first_len_val; - gfc_loopinfo *loop, *outer_loop; - gfc_ss_info *ss_info; - gfc_expr *expr; - gfc_ss *s; - tree neg_len; - char *msg; - - /* Save the old values for nested checking. */ - old_first_len = first_len; - old_first_len_val = first_len_val; - old_typespec_chararray_ctor = typespec_chararray_ctor; - - loop = ss->loop; - outer_loop = outermost_loop (loop); - ss_info = ss->info; - expr = ss_info->expr; - - /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no - typespec was given for the array constructor. */ - typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER - && expr->ts.u.cl - && expr->ts.u.cl->length_from_typespec); - - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) - { - first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); - first_len = true; - } - - gcc_assert (ss->dimen == ss->loop->dimen); - - c = expr->value.constructor; - if (expr->ts.type == BT_CHARACTER) - { - bool const_string; - bool force_new_cl = false; - - /* get_array_ctor_strlen walks the elements of the constructor, if a - typespec was given, we already know the string length and want the one - specified there. */ - if (typespec_chararray_ctor && expr->ts.u.cl->length - && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - { - gfc_se length_se; - - const_string = false; - gfc_init_se (&length_se, NULL); - gfc_conv_expr_type (&length_se, expr->ts.u.cl->length, - gfc_charlen_type_node); - ss_info->string_length = length_se.expr; - - /* Check if the character length is negative. If it is, then - set LEN = 0. */ - neg_len = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, ss_info->string_length, - build_zero_cst (TREE_TYPE - (ss_info->string_length))); - /* Print a warning if bounds checking is enabled. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - msg = xasprintf ("Negative character length treated as LEN = 0"); - gfc_trans_runtime_check (false, true, neg_len, &length_se.pre, - where, msg); - free (msg); - } - - ss_info->string_length - = fold_build3_loc (input_location, COND_EXPR, - gfc_charlen_type_node, neg_len, - build_zero_cst - (TREE_TYPE (ss_info->string_length)), - ss_info->string_length); - ss_info->string_length = gfc_evaluate_now (ss_info->string_length, - &length_se.pre); - gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); - gfc_add_block_to_block (&outer_loop->post, &length_se.post); - } - else - { - const_string = get_array_ctor_strlen (&outer_loop->pre, c, - &ss_info->string_length); - force_new_cl = true; - } - - /* Complex character array constructors should have been taken care of - and not end up here. */ - gcc_assert (ss_info->string_length); - - store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl); - - type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length); - if (const_string) - type = build_pointer_type (type); - } - else - type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS - ? &CLASS_DATA (expr)->ts : &expr->ts); - - /* See if the constructor determines the loop bounds. */ - dynamic = false; - - loop_ubound0 = get_loop_upper_bound_for_array (ss, 0); - - if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE) - { - /* We have a multidimensional parameter. */ - for (s = ss; s; s = s->parent) - { - int n; - for (n = 0; n < s->loop->dimen; n++) - { - s->loop->from[n] = gfc_index_zero_node; - s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]], - gfc_index_integer_kind); - s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - s->loop->to[n], - gfc_index_one_node); - } - } - } - - if (*loop_ubound0 == NULL_TREE) - { - mpz_t size; - - /* We should have a 1-dimensional, zero-based loop. */ - gcc_assert (loop->parent == NULL && loop->nested == NULL); - gcc_assert (loop->dimen == 1); - gcc_assert (integer_zerop (loop->from[0])); - - /* Split the constructor size into a static part and a dynamic part. - Allocate the static size up-front and record whether the dynamic - size might be nonzero. */ - mpz_init (size); - dynamic = gfc_get_array_constructor_size (&size, c); - mpz_sub_ui (size, size, 1); - loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); - mpz_clear (size); - } - - /* Special case constant array constructors. */ - if (!dynamic) - { - unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c); - if (nelem > 0) - { - tree size = constant_array_constructor_loop_size (loop); - if (size && compare_tree_int (size, nelem) == 0) - { - trans_constant_array_constructor (ss, type); - goto finish; - } - } - } - - gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, - NULL_TREE, dynamic, true, false, where); - - desc = ss_info->data.array.descriptor; - offset = gfc_index_zero_node; - offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); - suppress_warning (offsetvar); - TREE_USED (offsetvar) = 0; - gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, - &offset, &offsetvar, dynamic); - - /* If the array grows dynamically, the upper bound of the loop variable - is determined by the array's final upper bound. */ - if (dynamic) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offsetvar, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); - if (*loop_ubound0 && VAR_P (*loop_ubound0)) - gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); - else - *loop_ubound0 = tmp; - } - - if (TREE_USED (offsetvar)) - pushdecl (offsetvar); - else - gcc_assert (INTEGER_CST_P (offset)); - -#if 0 - /* Disable bound checking for now because it's probably broken. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - gcc_unreachable (); - } -#endif - -finish: - /* Restore old values of globals. */ - first_len = old_first_len; - first_len_val = old_first_len_val; - typespec_chararray_ctor = old_typespec_chararray_ctor; -} - - -/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is - called after evaluating all of INFO's vector dimensions. Go through - each such vector dimension and see if we can now fill in any missing - loop bounds. */ - -static void -set_vector_loop_bounds (gfc_ss * ss) -{ - gfc_loopinfo *loop, *outer_loop; - gfc_array_info *info; - gfc_se se; - tree tmp; - tree desc; - tree zero; - int n; - int dim; - - outer_loop = outermost_loop (ss->loop); - - info = &ss->info->data.array; - - for (; ss; ss = ss->parent) - { - loop = ss->loop; - - for (n = 0; n < loop->dimen; n++) - { - dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR - || loop->to[n] != NULL) - continue; - - /* Loop variable N indexes vector dimension DIM, and we don't - yet know the upper bound of loop variable N. Set it to the - difference between the vector's upper and lower bounds. */ - gcc_assert (loop->from[n] == gfc_index_zero_node); - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_VECTOR); - - gfc_init_se (&se, NULL); - desc = info->subscript[dim]->info->data.array.descriptor; - zero = gfc_rank_cst[0]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, zero), - gfc_conv_descriptor_lbound_get (desc, zero)); - tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - loop->to[n] = tmp; - } - } -} - - -/* Tells whether a scalar argument to an elemental procedure is saved out - of a scalarization loop as a value or as a reference. */ - -bool -gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) -{ - if (ss_info->type != GFC_SS_REFERENCE) - return false; - - if (ss_info->data.scalar.needs_temporary) - return false; - - /* If the actual argument can be absent (in other words, it can - be a NULL reference), don't try to evaluate it; pass instead - the reference directly. */ - if (ss_info->can_be_null_ref) - return true; - - /* If the expression is of polymorphic type, it's actual size is not known, - so we avoid copying it anywhere. */ - if (ss_info->data.scalar.dummy_arg - && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type - == BT_CLASS - && ss_info->expr->ts.type == BT_CLASS) - return true; - - /* If the expression is a data reference of aggregate type, - and the data reference is not used on the left hand side, - avoid a copy by saving a reference to the content. */ - if (!ss_info->data.scalar.needs_temporary - && (ss_info->expr->ts.type == BT_DERIVED - || ss_info->expr->ts.type == BT_CLASS) - && gfc_expr_is_variable (ss_info->expr)) - return true; - - /* Otherwise the expression is evaluated to a temporary variable before the - scalarization loop. */ - return false; -} - - -/* Add the pre and post chains for all the scalar expressions in a SS chain - to loop. This is called after the loop parameters have been calculated, - but before the actual scalarizing loops. */ - -static void -gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, - locus * where) -{ - gfc_loopinfo *nested_loop, *outer_loop; - gfc_se se; - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_expr *expr; - int n; - - /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise, - arguments could get evaluated multiple times. */ - if (ss->is_alloc_lhs) - return; - - outer_loop = outermost_loop (loop); - - /* TODO: This can generate bad code if there are ordering dependencies, - e.g., a callee allocated function and an unknown size constructor. */ - gcc_assert (ss != NULL); - - for (; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gcc_assert (ss); - - /* Cross loop arrays are handled from within the most nested loop. */ - if (ss->nested_ss != NULL) - continue; - - ss_info = ss->info; - expr = ss_info->expr; - info = &ss_info->data.array; - - switch (ss_info->type) - { - case GFC_SS_SCALAR: - /* Scalar expression. Evaluate this now. This includes elemental - dimension indices, but not array section bounds. */ - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - - if (expr->ts.type != BT_CHARACTER - && !gfc_is_alloc_class_scalar_function (expr)) - { - /* Move the evaluation of scalar expressions outside the - scalarization loop, except for WHERE assignments. */ - if (subscript) - se.expr = convert(gfc_array_index_type, se.expr); - if (!ss_info->where) - se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre); - gfc_add_block_to_block (&outer_loop->pre, &se.post); - } - else - gfc_add_block_to_block (&outer_loop->post, &se.post); - - ss_info->data.scalar.value = se.expr; - ss_info->string_length = se.string_length; - break; - - case GFC_SS_REFERENCE: - /* Scalar argument to elemental procedure. */ - gfc_init_se (&se, NULL); - if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) - gfc_conv_expr_reference (&se, expr); - else - { - /* Evaluate the argument outside the loop and pass - a reference to the value. */ - gfc_conv_expr (&se, expr); - } - - /* Ensure that a pointer to the string is stored. */ - if (expr->ts.type == BT_CHARACTER) - gfc_conv_string_parameter (&se); - - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - if (gfc_is_class_scalar_expr (expr)) - /* This is necessary because the dynamic type will always be - large than the declared type. In consequence, assigning - the value to a temporary could segfault. - OOP-TODO: see if this is generally correct or is the value - has to be written to an allocated temporary, whose address - is passed via ss_info. */ - ss_info->data.scalar.value = se.expr; - else - ss_info->data.scalar.value = gfc_evaluate_now (se.expr, - &outer_loop->pre); - - ss_info->string_length = se.string_length; - break; - - case GFC_SS_SECTION: - /* Add the expressions for scalar and vector subscripts. */ - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (info->subscript[n]) - gfc_add_loop_ss_code (loop, info->subscript[n], true, where); - - set_vector_loop_bounds (ss); - break; - - case GFC_SS_VECTOR: - /* Get the vector's descriptor and store it in SS. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_descriptor (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - info->descriptor = se.expr; - break; - - case GFC_SS_INTRINSIC: - gfc_add_intrinsic_ss_code (loop, ss); - break; - - case GFC_SS_FUNCTION: - /* Array function return value. We call the function and save its - result in a temporary for use inside the loop. */ - gfc_init_se (&se, NULL); - se.loop = loop; - se.ss = ss; - if (gfc_is_class_array_function (expr)) - expr->must_finalize = 1; - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - ss_info->string_length = se.string_length; - break; - - case GFC_SS_CONSTRUCTOR: - if (expr->ts.type == BT_CHARACTER - && ss_info->string_length == NULL - && expr->ts.u.cl - && expr->ts.u.cl->length - && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, expr->ts.u.cl->length, - gfc_charlen_type_node); - ss_info->string_length = se.expr; - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - } - trans_array_constructor (ss, where); - break; - - case GFC_SS_TEMP: - case GFC_SS_COMPONENT: - /* Do nothing. These are handled elsewhere. */ - break; - - default: - gcc_unreachable (); - } - } - - if (!subscript) - for (nested_loop = loop->nested; nested_loop; - nested_loop = nested_loop->next) - gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); -} - - -/* Translate expressions for the descriptor and data pointer of a SS. */ -/*GCC ARRAYS*/ - -static void -gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) -{ - gfc_se se; - gfc_ss_info *ss_info; - gfc_array_info *info; - tree tmp; - - ss_info = ss->info; - info = &ss_info->data.array; - - /* Get the descriptor for the array to be scalarized. */ - gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE); - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - gfc_conv_expr_lhs (&se, ss_info->expr); - gfc_add_block_to_block (block, &se.pre); - info->descriptor = se.expr; - ss_info->string_length = se.string_length; - - if (base) - { - if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred - && ss_info->expr->ts.u.cl->length == NULL) - { - /* Emit a DECL_EXPR for the variable sized array type in - GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type - sizes works correctly. */ - tree arraytype = TREE_TYPE ( - GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor))); - if (! TYPE_NAME (arraytype)) - TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, - NULL_TREE, arraytype); - gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype, - TYPE_NAME (arraytype))); - } - /* Also the data pointer. */ - tmp = gfc_conv_array_data (se.expr); - /* If this is a variable or address or a class array, use it directly. - Otherwise we must evaluate it now to avoid breaking dependency - analysis by pulling the expressions for elemental array indices - inside the loop. */ - if (!(DECL_P (tmp) - || (TREE_CODE (tmp) == ADDR_EXPR - && DECL_P (TREE_OPERAND (tmp, 0))) - || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) - && TREE_CODE (se.expr) == COMPONENT_REF - && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))) - tmp = gfc_evaluate_now (tmp, block); - info->data = tmp; - - tmp = gfc_conv_array_offset (se.expr); - info->offset = gfc_evaluate_now (tmp, block); - - /* Make absolutely sure that the saved_offset is indeed saved - so that the variable is still accessible after the loops - are translated. */ - info->saved_offset = info->offset; - } -} - - -/* Initialize a gfc_loopinfo structure. */ - -void -gfc_init_loopinfo (gfc_loopinfo * loop) -{ - int n; - - memset (loop, 0, sizeof (gfc_loopinfo)); - gfc_init_block (&loop->pre); - gfc_init_block (&loop->post); - - /* Initially scalarize in order and default to no loop reversal. */ - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - { - loop->order[n] = n; - loop->reverse[n] = GFC_INHIBIT_REVERSE; - } - - loop->ss = gfc_ss_terminator; -} - - -/* Copies the loop variable info to a gfc_se structure. Does not copy the SS - chain. */ - -void -gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop) -{ - se->loop = loop; -} - - -/* Return an expression for the data pointer of an array. */ - -tree -gfc_conv_array_data (tree descriptor) -{ - tree type; - - type = TREE_TYPE (descriptor); - if (GFC_ARRAY_TYPE_P (type)) - { - if (TREE_CODE (type) == POINTER_TYPE) - return descriptor; - else - { - /* Descriptorless arrays. */ - return gfc_build_addr_expr (NULL_TREE, descriptor); - } - } - else - return gfc_conv_descriptor_data_get (descriptor); -} - - -/* Return an expression for the base offset of an array. */ - -tree -gfc_conv_array_offset (tree descriptor) -{ - tree type; - - type = TREE_TYPE (descriptor); - if (GFC_ARRAY_TYPE_P (type)) - return GFC_TYPE_ARRAY_OFFSET (type); - else - return gfc_conv_descriptor_offset_get (descriptor); -} - - -/* Get an expression for the array stride. */ - -tree -gfc_conv_array_stride (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - /* For descriptorless arrays use the array size. */ - tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); - if (tmp != NULL_TREE) - return tmp; - - tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Like gfc_conv_array_stride, but for the lower bound. */ - -tree -gfc_conv_array_lbound (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (tmp != NULL_TREE) - return tmp; - - tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Like gfc_conv_array_stride, but for the upper bound. */ - -tree -gfc_conv_array_ubound (tree descriptor, int dim) -{ - tree tmp; - tree type; - - type = TREE_TYPE (descriptor); - - tmp = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (tmp != NULL_TREE) - return tmp; - - /* This should only ever happen when passing an assumed shape array - as an actual parameter. The value will never be used. */ - if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))) - return gfc_index_zero_node; - - tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]); - return tmp; -} - - -/* Generate code to perform an array index bound check. */ - -static tree -trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, - locus * where, bool check_upper) -{ - tree fault; - tree tmp_lo, tmp_up; - tree descriptor; - char *msg; - const char * name = NULL; - - if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) - return index; - - descriptor = ss->info->data.array.descriptor; - - index = gfc_evaluate_now (index, &se->pre); - - /* We find a name for the error message. */ - name = ss->info->expr->symtree->n.sym->name; - gcc_assert (name != NULL); - - if (VAR_P (descriptor)) - name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); - - /* If upper bound is present, include both bounds in the error message. */ - if (check_upper) - { - tmp_lo = gfc_conv_array_lbound (descriptor, n); - tmp_up = gfc_conv_array_ubound (descriptor, n); - - if (name) - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", n+1, name); - else - msg = xasprintf ("Index '%%ld' of dimension %d " - "outside of expected range (%%ld:%%ld)", n+1); - - fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - index, tmp_lo); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo), - fold_convert (long_integer_type_node, tmp_up)); - fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - index, tmp_up); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo), - fold_convert (long_integer_type_node, tmp_up)); - free (msg); - } - else - { - tmp_lo = gfc_conv_array_lbound (descriptor, n); - - if (name) - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", n+1, name); - else - msg = xasprintf ("Index '%%ld' of dimension %d " - "below lower bound of %%ld", n+1); - - fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - index, tmp_lo); - gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, - fold_convert (long_integer_type_node, index), - fold_convert (long_integer_type_node, tmp_lo)); - free (msg); - } - - return index; -} - - -/* Return the offset for an index. Performs bound checking for elemental - dimensions. Single element references are processed separately. - DIM is the array dimension, I is the loop dimension. */ - -static tree -conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, - gfc_array_ref * ar, tree stride) -{ - gfc_array_info *info; - tree index; - tree desc; - tree data; - - info = &ss->info->data.array; - - /* Get the index into the array for this dimension. */ - if (ar) - { - gcc_assert (ar->type != AR_ELEMENT); - switch (ar->dimen_type[dim]) - { - case DIMEN_THIS_IMAGE: - gcc_unreachable (); - break; - case DIMEN_ELEMENT: - /* Elemental dimension. */ - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_SCALAR); - /* We've already translated this value outside the loop. */ - index = info->subscript[dim]->info->data.scalar.value; - - index = trans_array_bound_check (se, ss, index, dim, &ar->where, - ar->as->type != AS_ASSUMED_SIZE - || dim < ar->dimen - 1); - break; - - case DIMEN_VECTOR: - gcc_assert (info && se->loop); - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_VECTOR); - desc = info->subscript[dim]->info->data.array.descriptor; - - /* Get a zero-based index into the vector. */ - index = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - se->loop->loopvar[i], se->loop->from[i]); - - /* Multiply the index by the stride. */ - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - index, gfc_conv_array_stride (desc, 0)); - - /* Read the vector to get an index into info->descriptor. */ - data = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (desc)); - index = gfc_build_array_ref (data, index, NULL); - index = gfc_evaluate_now (index, &se->pre); - index = fold_convert (gfc_array_index_type, index); - - /* Do any bounds checking on the final info->descriptor index. */ - index = trans_array_bound_check (se, ss, index, dim, &ar->where, - ar->as->type != AS_ASSUMED_SIZE - || dim < ar->dimen - 1); - break; - - case DIMEN_RANGE: - /* Scalarized dimension. */ - gcc_assert (info && se->loop); - - /* Multiply the loop variable by the stride and delta. */ - index = se->loop->loopvar[i]; - if (!integer_onep (info->stride[dim])) - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, index, - info->stride[dim]); - if (!integer_zerop (info->delta[dim])) - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, - info->delta[dim]); - break; - - default: - gcc_unreachable (); - } - } - else - { - /* Temporary array or derived type component. */ - gcc_assert (se->loop); - index = se->loop->loopvar[se->loop->order[i]]; - - /* Pointer functions can have stride[0] different from unity. - Use the stride returned by the function call and stored in - the descriptor for the temporary. */ - if (se->ss && se->ss->info->type == GFC_SS_FUNCTION - && se->ss->info->expr - && se->ss->info->expr->symtree - && se->ss->info->expr->symtree->n.sym->result - && se->ss->info->expr->symtree->n.sym->result->attr.pointer) - stride = gfc_conv_descriptor_stride_get (info->descriptor, - gfc_rank_cst[dim]); - - if (info->delta[dim] && !integer_zerop (info->delta[dim])) - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, info->delta[dim]); - } - - /* Multiply by the stride. */ - if (stride != NULL && !integer_onep (stride)) - index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - index, stride); - - return index; -} - - -/* Build a scalarized array reference using the vptr 'size'. */ - -static bool -build_class_array_ref (gfc_se *se, tree base, tree index) -{ - tree size; - tree decl = NULL_TREE; - tree tmp; - gfc_expr *expr = se->ss->info->expr; - gfc_expr *class_expr; - gfc_typespec *ts; - gfc_symbol *sym; - - tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE; - - if (tmp != NULL_TREE) - decl = tmp; - else - { - /* The base expression does not contain a class component, either - because it is a temporary array or array descriptor. Class - array functions are correctly resolved above. */ - if (!expr - || (expr->ts.type != BT_CLASS - && !gfc_is_class_array_ref (expr, NULL))) - return false; - - /* Obtain the expression for the class entity or component that is - followed by an array reference, which is not an element, so that - the span of the array can be obtained. */ - class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts); - - if (!ts) - return false; - - sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL; - if (sym && sym->attr.function - && sym == sym->result - && sym->backend_decl == current_function_decl) - /* The temporary is the data field of the class data component - of the current function. */ - decl = gfc_get_fake_result_decl (sym, 0); - else if (sym) - { - if (decl == NULL_TREE) - decl = expr->symtree->n.sym->backend_decl; - /* For class arrays the tree containing the class is stored in - GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. - For all others it's sym's backend_decl directly. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - } - else - decl = gfc_get_class_from_gfc_expr (class_expr); - - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - return false; - } - - se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); - - size = gfc_class_vtab_size_get (decl); - /* For unlimited polymorphic entities then _len component needs to be - multiplied with the size. */ - size = gfc_resize_class_size_with_len (&se->pre, decl, size); - size = fold_convert (TREE_TYPE (index), size); - - /* Return the element in the se expression. */ - se->expr = gfc_build_spanned_array_ref (base, index, size); - return true; -} - - -/* Build a scalarized reference to an array. */ - -static void -gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) -{ - gfc_array_info *info; - tree decl = NULL_TREE; - tree index; - tree base; - gfc_ss *ss; - gfc_expr *expr; - int n; - - ss = se->ss; - expr = ss->info->expr; - info = &ss->info->data.array; - if (ar) - n = se->loop->order[0]; - else - n = 0; - - index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0); - /* Add the offset for this dimension to the stored offset for all other - dimensions. */ - if (info->offset && !integer_zerop (info->offset)) - index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - index, info->offset); - - base = build_fold_indirect_ref_loc (input_location, info->data); - - /* Use the vptr 'size' field to access the element of a class array. */ - if (build_class_array_ref (se, base, index)) - return; - - if (get_CFI_desc (NULL, expr, &decl, ar)) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* A pointer array component can be detected from its field decl. Fix - the descriptor, mark the resulting variable decl and pass it to - gfc_build_array_ref. */ - if (is_pointer_array (info->descriptor) - || (expr && expr->ts.deferred && info->descriptor - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))) - { - if (TREE_CODE (info->descriptor) == COMPONENT_REF) - decl = info->descriptor; - else if (TREE_CODE (info->descriptor) == INDIRECT_REF) - decl = TREE_OPERAND (info->descriptor, 0); - - if (decl == NULL_TREE) - decl = info->descriptor; - } - - se->expr = gfc_build_array_ref (base, index, decl); -} - - -/* Translate access of temporary array. */ - -void -gfc_conv_tmp_array_ref (gfc_se * se) -{ - se->string_length = se->ss->info->string_length; - gfc_conv_scalarized_array_ref (se, NULL); - gfc_advance_se_ss_chain (se); -} - -/* Add T to the offset pair *OFFSET, *CST_OFFSET. */ - -static void -add_to_offset (tree *cst_offset, tree *offset, tree t) -{ - if (TREE_CODE (t) == INTEGER_CST) - *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t); - else - { - if (!integer_zerop (*offset)) - *offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, *offset, t); - else - *offset = t; - } -} - - -static tree -build_array_ref (tree desc, tree offset, tree decl, tree vptr) -{ - tree tmp; - tree type; - tree cdesc; - - /* For class arrays the class declaration is stored in the saved - descriptor. */ - if (INDIRECT_REF_P (desc) - && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) - && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) - cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( - TREE_OPERAND (desc, 0))); - else - cdesc = desc; - - /* Class container types do not always have the GFC_CLASS_TYPE_P - but the canonical type does. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc)) - && TREE_CODE (cdesc) == COMPONENT_REF) - { - type = TREE_TYPE (TREE_OPERAND (cdesc, 0)); - if (TYPE_CANONICAL (type) - && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) - vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0)); - } - - tmp = gfc_conv_array_data (desc); - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl, vptr); - return tmp; -} - - -/* Build an array reference. se->expr already holds the array descriptor. - This should be either a variable, indirect variable reference or component - reference. For arrays which do not have a descriptor, se->expr will be - the data pointer. - a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ - -void -gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, - locus * where) -{ - int n; - tree offset, cst_offset; - tree tmp; - tree stride; - tree decl = NULL_TREE; - gfc_se indexse; - gfc_se tmpse; - gfc_symbol * sym = expr->symtree->n.sym; - char *var_name = NULL; - - if (ar->dimen == 0) - { - gcc_assert (ar->codimen || sym->attr.select_rank_temporary - || (ar->as && ar->as->corank)); - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) - se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); - else - { - if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) - && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - - /* Use the actual tree type and not the wrapped coarray. */ - if (!se->want_pointer) - se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), - se->expr); - } - - return; - } - - /* Handle scalarized references separately. */ - if (ar->type != AR_ELEMENT) - { - gfc_conv_scalarized_array_ref (se, ar); - gfc_advance_se_ss_chain (se); - return; - } - - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - size_t len; - gfc_ref *ref; - - len = strlen (sym->name) + 1; - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY && &ref->u.ar == ar) - break; - if (ref->type == REF_COMPONENT) - len += 2 + strlen (ref->u.c.component->name); - } - - var_name = XALLOCAVEC (char, len); - strcpy (var_name, sym->name); - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY && &ref->u.ar == ar) - break; - if (ref->type == REF_COMPONENT) - { - strcat (var_name, "%%"); - strcat (var_name, ref->u.c.component->name); - } - } - } - - decl = se->expr; - if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED) - decl = sym->backend_decl; - - cst_offset = offset = gfc_index_zero_node; - add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl)); - - /* Calculate the offsets from all the dimensions. Make sure to associate - the final offset so that we form a chain of loop invariant summands. */ - for (n = ar->dimen - 1; n >= 0; n--) - { - /* Calculate the index for this dimension. */ - gfc_init_se (&indexse, se); - gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &indexse.pre); - - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check) - { - /* Check array bounds. */ - tree cond; - char *msg; - - /* Evaluate the indexse.expr only once. */ - indexse.expr = save_expr (indexse.expr); - - /* Lower bound. */ - tmp = gfc_conv_array_lbound (decl, n); - if (sym->attr.temporary) - { - gfc_init_se (&tmpse, se); - gfc_conv_expr_type (&tmpse, ar->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - tmp = tmpse.expr; - } - - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - indexse.expr, tmp); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", n+1, var_name); - gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, - fold_convert (long_integer_type_node, - indexse.expr), - fold_convert (long_integer_type_node, tmp)); - free (msg); - - /* Upper bound, but not for the last dimension of assumed-size - arrays. */ - if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE) - { - tmp = gfc_conv_array_ubound (decl, n); - if (sym->attr.temporary) - { - gfc_init_se (&tmpse, se); - gfc_conv_expr_type (&tmpse, ar->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - tmp = tmpse.expr; - } - - cond = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, indexse.expr, tmp); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "above upper bound of %%ld", n+1, var_name); - gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, - fold_convert (long_integer_type_node, - indexse.expr), - fold_convert (long_integer_type_node, tmp)); - free (msg); - } - } - - /* Multiply the index by the stride. */ - stride = gfc_conv_array_stride (decl, n); - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - indexse.expr, stride); - - /* And add it to the total. */ - add_to_offset (&cst_offset, &offset, tmp); - } - - if (!integer_zerop (cst_offset)) - offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, offset, cst_offset); - - /* A pointer array component can be detected from its field decl. Fix - the descriptor, mark the resulting variable decl and pass it to - build_array_ref. */ - decl = NULL_TREE; - if (get_CFI_desc (sym, expr, &decl, ar)) - decl = build_fold_indirect_ref_loc (input_location, decl); - if (!expr->ts.deferred && !sym->attr.codimension - && is_pointer_array (se->expr)) - { - if (TREE_CODE (se->expr) == COMPONENT_REF) - decl = se->expr; - else if (TREE_CODE (se->expr) == INDIRECT_REF) - decl = TREE_OPERAND (se->expr, 0); - else - decl = se->expr; - } - else if (expr->ts.deferred - || (sym->ts.type == BT_CHARACTER - && sym->attr.select_type_temporary)) - { - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) - { - decl = se->expr; - if (TREE_CODE (decl) == INDIRECT_REF) - decl = TREE_OPERAND (decl, 0); - } - else - decl = sym->backend_decl; - } - else if (sym->ts.type == BT_CLASS) - { - if (UNLIMITED_POLY (sym)) - { - gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); - gfc_init_se (&tmpse, NULL); - gfc_conv_expr (&tmpse, class_expr); - if (!se->class_vptr) - se->class_vptr = gfc_class_vptr_get (tmpse.expr); - gfc_free_expr (class_expr); - decl = tmpse.expr; - } - else - decl = NULL_TREE; - } - - se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); -} - - -/* Add the offset corresponding to array's ARRAY_DIM dimension and loop's - LOOP_DIM dimension (if any) to array's offset. */ - -static void -add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss, - gfc_array_ref *ar, int array_dim, int loop_dim) -{ - gfc_se se; - gfc_array_info *info; - tree stride, index; - - info = &ss->info->data.array; - - gfc_init_se (&se, NULL); - se.loop = loop; - se.expr = info->descriptor; - stride = gfc_conv_array_stride (info->descriptor, array_dim); - index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride); - gfc_add_block_to_block (pblock, &se.pre); - - info->offset = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - info->offset, index); - info->offset = gfc_evaluate_now (info->offset, pblock); -} - - -/* Generate the code to be executed immediately before entering a - scalarization loop. */ - -static void -gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, - stmtblock_t * pblock) -{ - tree stride; - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_ss_type ss_type; - gfc_ss *ss, *pss; - gfc_loopinfo *ploop; - gfc_array_ref *ar; - int i; - - /* This code will be executed before entering the scalarization loop - for this dimension. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - ss_info = ss->info; - - if ((ss_info->useflags & flag) == 0) - continue; - - ss_type = ss_info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_FUNCTION - && ss_type != GFC_SS_CONSTRUCTOR - && ss_type != GFC_SS_COMPONENT) - continue; - - info = &ss_info->data.array; - - gcc_assert (dim < ss->dimen); - gcc_assert (ss->dimen == loop->dimen); - - if (info->ref) - ar = &info->ref->u.ar; - else - ar = NULL; - - if (dim == loop->dimen - 1 && loop->parent != NULL) - { - /* If we are in the outermost dimension of this loop, the previous - dimension shall be in the parent loop. */ - gcc_assert (ss->parent != NULL); - - pss = ss->parent; - ploop = loop->parent; - - /* ss and ss->parent are about the same array. */ - gcc_assert (ss_info == pss->info); - } - else - { - ploop = loop; - pss = ss; - } - - if (dim == loop->dimen - 1) - i = 0; - else - i = dim + 1; - - /* For the time being, there is no loop reordering. */ - gcc_assert (i == ploop->order[i]); - i = ploop->order[i]; - - if (dim == loop->dimen - 1 && loop->parent == NULL) - { - stride = gfc_conv_array_stride (info->descriptor, - innermost_ss (ss)->dim[i]); - - /* Calculate the stride of the innermost loop. Hopefully this will - allow the backend optimizers to do their stuff more effectively. - */ - info->stride0 = gfc_evaluate_now (stride, pblock); - - /* For the outermost loop calculate the offset due to any - elemental dimensions. It will have been initialized with the - base offset of the array. */ - if (info->ref) - { - for (i = 0; i < ar->dimen; i++) - { - if (ar->dimen_type[i] != DIMEN_ELEMENT) - continue; - - add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1); - } - } - } - else - /* Add the offset for the previous loop dimension. */ - add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i); - - /* Remember this offset for the second loop. */ - if (dim == loop->temp_dim - 1 && loop->parent == NULL) - info->saved_offset = info->offset; - } -} - - -/* Start a scalarized expression. Creates a scope and declares loop - variables. */ - -void -gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) -{ - int dim; - int n; - int flags; - - gcc_assert (!loop->array_parameter); - - for (dim = loop->dimen - 1; dim >= 0; dim--) - { - n = loop->order[dim]; - - gfc_start_block (&loop->code[n]); - - /* Create the loop variable. */ - loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S"); - - if (dim < loop->temp_dim) - flags = 3; - else - flags = 1; - /* Calculate values that will be constant within this loop. */ - gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]); - } - gfc_start_block (pbody); -} - - -/* Generates the actual loop code for a scalarization loop. */ - -static void -gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, - stmtblock_t * pbody) -{ - stmtblock_t block; - tree cond; - tree tmp; - tree loopbody; - tree exit_label; - tree stmt; - tree init; - tree incr; - - if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS - | OMPWS_SCALARIZER_BODY)) - == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS) - && n == loop->dimen - 1) - { - /* We create an OMP_FOR construct for the outermost scalarized loop. */ - init = make_tree_vec (1); - cond = make_tree_vec (1); - incr = make_tree_vec (1); - - /* Cycle statement is implemented with a goto. Exit statement must not - be present for this loop. */ - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - - /* Label for cycle statements (if needed). */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (pbody, tmp); - - stmt = make_node (OMP_FOR); - - TREE_TYPE (stmt) = void_type_node; - OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody); - - OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location, - OMP_CLAUSE_SCHEDULE); - OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt)) - = OMP_CLAUSE_SCHEDULE_STATIC; - if (ompws_flags & OMPWS_NOWAIT) - OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt)) - = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT); - - /* Initialize the loopvar. */ - TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n], - loop->from[n]); - OMP_FOR_INIT (stmt) = init; - /* The exit condition. */ - TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR, - logical_type_node, - loop->loopvar[n], loop->to[n]); - SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location); - OMP_FOR_COND (stmt) = cond; - /* Increment the loopvar. */ - tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - loop->loopvar[n], gfc_index_one_node); - TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, loop->loopvar[n], tmp); - OMP_FOR_INCR (stmt) = incr; - - ompws_flags &= ~OMPWS_CURR_SINGLEUNIT; - gfc_add_expr_to_block (&loop->code[n], stmt); - } - else - { - bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) - && (loop->temp_ss == NULL); - - loopbody = gfc_finish_block (pbody); - - if (reverse_loop) - std::swap (loop->from[n], loop->to[n]); - - /* Initialize the loopvar. */ - if (loop->loopvar[n] != loop->from[n]) - gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); - - exit_label = gfc_build_label_decl (NULL_TREE); - - /* Generate the loop body. */ - gfc_init_block (&block); - - /* The exit condition. */ - cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR, - logical_type_node, loop->loopvar[n], loop->to[n]); - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - - /* The main body. */ - gfc_add_expr_to_block (&block, loopbody); - - /* Increment the loopvar. */ - tmp = fold_build2_loc (input_location, - reverse_loop ? MINUS_EXPR : PLUS_EXPR, - gfc_array_index_type, loop->loopvar[n], - gfc_index_one_node); - - gfc_add_modify (&block, loop->loopvar[n], tmp); - - /* Build the loop. */ - tmp = gfc_finish_block (&block); - tmp = build1_v (LOOP_EXPR, tmp); - gfc_add_expr_to_block (&loop->code[n], tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&loop->code[n], tmp); - } - -} - - -/* Finishes and generates the loops for a scalarized expression. */ - -void -gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) -{ - int dim; - int n; - gfc_ss *ss; - stmtblock_t *pblock; - tree tmp; - - pblock = body; - /* Generate the loops. */ - for (dim = 0; dim < loop->dimen; dim++) - { - n = loop->order[dim]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - loop->loopvar[n] = NULL_TREE; - pblock = &loop->code[n]; - } - - tmp = gfc_finish_block (pblock); - gfc_add_expr_to_block (&loop->pre, tmp); - - /* Clear all the used flags. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - if (ss->parent == NULL) - ss->info->useflags = 0; -} - - -/* Finish the main body of a scalarized expression, and start the secondary - copying body. */ - -void -gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) -{ - int dim; - int n; - stmtblock_t *pblock; - gfc_ss *ss; - - pblock = body; - /* We finish as many loops as are used by the temporary. */ - for (dim = 0; dim < loop->temp_dim - 1; dim++) - { - n = loop->order[dim]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - loop->loopvar[n] = NULL_TREE; - pblock = &loop->code[n]; - } - - /* We don't want to finish the outermost loop entirely. */ - n = loop->order[loop->temp_dim - 1]; - gfc_trans_scalarized_loop_end (loop, n, pblock); - - /* Restore the initial offsets. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - gfc_ss_info *ss_info; - - ss_info = ss->info; - - if ((ss_info->useflags & 2) == 0) - continue; - - ss_type = ss_info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_FUNCTION - && ss_type != GFC_SS_CONSTRUCTOR - && ss_type != GFC_SS_COMPONENT) - continue; - - ss_info->data.array.offset = ss_info->data.array.saved_offset; - } - - /* Restart all the inner loops we just finished. */ - for (dim = loop->temp_dim - 2; dim >= 0; dim--) - { - n = loop->order[dim]; - - gfc_start_block (&loop->code[n]); - - loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q"); - - gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]); - } - - /* Start a block for the secondary copying code. */ - gfc_start_block (body); -} - - -/* Precalculate (either lower or upper) bound of an array section. - BLOCK: Block in which the (pre)calculation code will go. - BOUNDS[DIM]: Where the bound value will be stored once evaluated. - VALUES[DIM]: Specified bound (NULL <=> unspecified). - DESC: Array descriptor from which the bound will be picked if unspecified - (either lower or upper bound according to LBOUND). */ - -static void -evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, - tree desc, int dim, bool lbound, bool deferred) -{ - gfc_se se; - gfc_expr * input_val = values[dim]; - tree *output = &bounds[dim]; - - - if (input_val) - { - /* Specified section bound. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, input_val, gfc_array_index_type); - gfc_add_block_to_block (block, &se.pre); - *output = se.expr; - } - else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - { - /* The gfc_conv_array_lbound () routine returns a constant zero for - deferred length arrays, which in the scalarizer wreaks havoc, when - copying to a (newly allocated) one-based array. - Keep returning the actual result in sync for both bounds. */ - *output = lbound ? gfc_conv_descriptor_lbound_get (desc, - gfc_rank_cst[dim]): - gfc_conv_descriptor_ubound_get (desc, - gfc_rank_cst[dim]); - } - else - { - /* No specific bound specified so use the bound of the array. */ - *output = lbound ? gfc_conv_array_lbound (desc, dim) : - gfc_conv_array_ubound (desc, dim); - } - *output = gfc_evaluate_now (*output, block); -} - - -/* Calculate the lower bound of an array section. */ - -static void -gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) -{ - gfc_expr *stride = NULL; - tree desc; - gfc_se se; - gfc_array_info *info; - gfc_array_ref *ar; - - gcc_assert (ss->info->type == GFC_SS_SECTION); - - info = &ss->info->data.array; - ar = &info->ref->u.ar; - - if (ar->dimen_type[dim] == DIMEN_VECTOR) - { - /* We use a zero-based index to access the vector. */ - info->start[dim] = gfc_index_zero_node; - info->end[dim] = NULL; - info->stride[dim] = gfc_index_one_node; - return; - } - - gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE - || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); - desc = info->descriptor; - stride = ar->stride[dim]; - - - /* Calculate the start of the range. For vector subscripts this will - be the range of the vector. */ - evaluate_bound (block, info->start, ar->start, desc, dim, true, - ar->as->type == AS_DEFERRED); - - /* Similarly calculate the end. Although this is not used in the - scalarizer, it is needed when checking bounds and where the end - is an expression with side-effects. */ - evaluate_bound (block, info->end, ar->end, desc, dim, false, - ar->as->type == AS_DEFERRED); - - - /* Calculate the stride. */ - if (stride == NULL) - info->stride[dim] = gfc_index_one_node; - else - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, stride, gfc_array_index_type); - gfc_add_block_to_block (block, &se.pre); - info->stride[dim] = gfc_evaluate_now (se.expr, block); - } -} - - -/* Calculates the range start and stride for a SS chain. Also gets the - descriptor and data pointer. The range of vector subscripts is the size - of the vector. Array bounds are also checked. */ - -void -gfc_conv_ss_startstride (gfc_loopinfo * loop) -{ - int n; - tree tmp; - gfc_ss *ss; - tree desc; - - gfc_loopinfo * const outer_loop = outermost_loop (loop); - - loop->dimen = 0; - /* Determine the rank of the loop. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - switch (ss->info->type) - { - case GFC_SS_SECTION: - case GFC_SS_CONSTRUCTOR: - case GFC_SS_FUNCTION: - case GFC_SS_COMPONENT: - loop->dimen = ss->dimen; - goto done; - - /* As usual, lbound and ubound are exceptions!. */ - case GFC_SS_INTRINSIC: - switch (ss->info->expr->value.function.isym->id) - { - case GFC_ISYM_LBOUND: - case GFC_ISYM_UBOUND: - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_SHAPE: - case GFC_ISYM_THIS_IMAGE: - loop->dimen = ss->dimen; - goto done; - - default: - break; - } - - default: - break; - } - } - - /* We should have determined the rank of the expression by now. If - not, that's bad news. */ - gcc_unreachable (); - -done: - /* Loop over all the SS in the chain. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_info *ss_info; - gfc_array_info *info; - gfc_expr *expr; - - ss_info = ss->info; - expr = ss_info->expr; - info = &ss_info->data.array; - - if (expr && expr->shape && !info->shape) - info->shape = expr->shape; - - switch (ss_info->type) - { - case GFC_SS_SECTION: - /* Get the descriptor for the array. If it is a cross loops array, - we got the descriptor already in the outermost loop. */ - if (ss->parent == NULL) - gfc_conv_ss_descriptor (&outer_loop->pre, ss, - !loop->array_parameter); - - for (n = 0; n < ss->dimen; n++) - gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]); - break; - - case GFC_SS_INTRINSIC: - switch (expr->value.function.isym->id) - { - /* Fall through to supply start and stride. */ - case GFC_ISYM_LBOUND: - case GFC_ISYM_UBOUND: - /* This is the variant without DIM=... */ - gcc_assert (expr->value.function.actual->next->expr == NULL); - /* Fall through. */ - - case GFC_ISYM_SHAPE: - { - gfc_expr *arg; - - arg = expr->value.function.actual->expr; - if (arg->rank == -1) - { - gfc_se se; - tree rank, tmp; - - /* The rank (hence the return value's shape) is unknown, - we have to retrieve it. */ - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - gfc_conv_expr (&se, arg); - /* This is a bare variable, so there is no preliminary - or cleanup code. */ - gcc_assert (se.pre.head == NULL_TREE - && se.post.head == NULL_TREE); - rank = gfc_conv_descriptor_rank (se.expr); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, - rank), - gfc_index_one_node); - info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre); - info->start[0] = gfc_index_zero_node; - info->stride[0] = gfc_index_one_node; - continue; - } - /* Otherwise fall through GFC_SS_FUNCTION. */ - gcc_fallthrough (); - } - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_THIS_IMAGE: - break; - - default: - continue; - } - - /* FALLTHRU */ - case GFC_SS_CONSTRUCTOR: - case GFC_SS_FUNCTION: - for (n = 0; n < ss->dimen; n++) - { - int dim = ss->dim[n]; - - info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; - } - break; - - default: - break; - } - } - - /* The rest is just runtime bounds checking. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - stmtblock_t block; - tree lbound, ubound; - tree end; - tree size[GFC_MAX_DIMENSIONS]; - tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3; - gfc_array_info *info; - char *msg; - int dim; - - gfc_start_block (&block); - - for (n = 0; n < loop->dimen; n++) - size[n] = NULL_TREE; - - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - stmtblock_t inner; - gfc_ss_info *ss_info; - gfc_expr *expr; - locus *expr_loc; - const char *expr_name; - - ss_info = ss->info; - if (ss_info->type != GFC_SS_SECTION) - continue; - - /* Catch allocatable lhs in f2003. */ - if (flag_realloc_lhs && ss->no_bounds_check) - continue; - - expr = ss_info->expr; - expr_loc = &expr->where; - expr_name = expr->symtree->name; - - gfc_start_block (&inner); - - /* TODO: range checking for mapped dimensions. */ - info = &ss_info->data.array; - - /* This code only checks ranges. Elemental and vector - dimensions are checked later. */ - for (n = 0; n < loop->dimen; n++) - { - bool check_upper; - - dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) - continue; - - if (dim == info->ref->u.ar.dimen - 1 - && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) - check_upper = false; - else - check_upper = true; - - /* Zero stride is not allowed. */ - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - info->stride[dim], gfc_index_zero_node); - msg = xasprintf ("Zero stride is not allowed, for dimension %d " - "of array '%s'", dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg); - free (msg); - - desc = info->descriptor; - - /* This is the run-time equivalent of resolve.c's - check_dimension(). The logical is more readable there - than it is here, with all the trees. */ - lbound = gfc_conv_array_lbound (desc, dim); - end = info->end[dim]; - if (check_upper) - ubound = gfc_conv_array_ubound (desc, dim); - else - ubound = NULL; - - /* non_zerosized is true when the selected range is not - empty. */ - stride_pos = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, info->stride[dim], - gfc_index_zero_node); - tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - info->start[dim], end); - stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, stride_pos, tmp); - - stride_neg = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->stride[dim], gfc_index_zero_node); - tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - info->start[dim], end); - stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - stride_neg, tmp); - non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, - stride_pos, stride_neg); - - /* Check the start of the range against the lower and upper - bounds of the array, if the range is not empty. - If upper bound is present, include both bounds in the - error message. */ - if (check_upper) - { - tmp = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - non_zerosized, tmp); - tmp2 = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, - info->start[dim], ubound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - non_zerosized, tmp2); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound), - fold_convert (long_integer_type_node, ubound)); - free (msg); - } - else - { - tmp = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, - info->start[dim], lbound); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, info->start[dim]), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - - /* Compute the last element of the range, which is not - necessarily "end" (think 0:5:3, which doesn't contain 5) - and check it against both lower and upper bounds. */ - - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, - info->start[dim]); - tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, tmp); - tmp2 = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, tmp, lbound); - tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp2); - if (check_upper) - { - tmp3 = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, tmp, ubound); - tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, non_zerosized, tmp3); - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - gfc_trans_runtime_check (true, false, tmp3, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, ubound), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - else - { - msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - dim + 1, expr_name); - gfc_trans_runtime_check (true, false, tmp2, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, lbound)); - free (msg); - } - - /* Check the section sizes match. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, end, - info->start[dim]); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, tmp); - tmp = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, tmp, - build_int_cst (gfc_array_index_type, 0)); - /* We remember the size of the first section, and check all the - others against this. */ - if (size[n]) - { - tmp3 = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, size[n]); - msg = xasprintf ("Array bound mismatch for dimension %d " - "of array '%s' (%%ld/%%ld)", - dim + 1, expr_name); - - gfc_trans_runtime_check (true, false, tmp3, &inner, - expr_loc, msg, - fold_convert (long_integer_type_node, tmp), - fold_convert (long_integer_type_node, size[n])); - - free (msg); - } - else - size[n] = gfc_evaluate_now (tmp, &inner); - } - - tmp = gfc_finish_block (&inner); - - /* For optional arguments, only check bounds if the argument is - present. */ - if ((expr->symtree->n.sym->attr.optional - || expr->symtree->n.sym->attr.not_always_present) - && expr->symtree->n.sym->attr.dummy) - tmp = build3_v (COND_EXPR, - gfc_conv_expr_present (expr->symtree->n.sym), - tmp, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - - } - - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&outer_loop->pre, tmp); - } - - for (loop = loop->nested; loop; loop = loop->next) - gfc_conv_ss_startstride (loop); -} - -/* Return true if both symbols could refer to the same data object. Does - not take account of aliasing due to equivalence statements. */ - -static int -symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer, - bool lsym_target, bool rsym_pointer, bool rsym_target) -{ - /* Aliasing isn't possible if the symbols have different base types. */ - if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) - return 0; - - /* Pointers can point to other pointers and target objects. */ - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - return 1; - - /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7 - and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already - checked above. */ - if (lsym_target && rsym_target - && ((lsym->attr.dummy && !lsym->attr.contiguous - && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE)) - || (rsym->attr.dummy && !rsym->attr.contiguous - && (!rsym->attr.dimension - || rsym->as->type == AS_ASSUMED_SHAPE)))) - return 1; - - return 0; -} - - -/* Return true if the two SS could be aliased, i.e. both point to the same data - object. */ -/* TODO: resolve aliases based on frontend expressions. */ - -static int -gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) -{ - gfc_ref *lref; - gfc_ref *rref; - gfc_expr *lexpr, *rexpr; - gfc_symbol *lsym; - gfc_symbol *rsym; - bool lsym_pointer, lsym_target, rsym_pointer, rsym_target; - - lexpr = lss->info->expr; - rexpr = rss->info->expr; - - lsym = lexpr->symtree->n.sym; - rsym = rexpr->symtree->n.sym; - - lsym_pointer = lsym->attr.pointer; - lsym_target = lsym->attr.target; - rsym_pointer = rsym->attr.pointer; - rsym_target = rsym->attr.target; - - if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS - && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS) - return 0; - - /* For derived types we must check all the component types. We can ignore - array references as these will have the same base type as the previous - component ref. */ - for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next) - { - if (lref->type != REF_COMPONENT) - continue; - - lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer; - lsym_target = lsym_target || lref->u.c.sym->attr.target; - - if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lref->u.c.component->ts, - &rsym->ts)) - return 1; - } - - for (rref = rexpr->ref; rref != rss->info->data.array.ref; - rref = rref->next) - { - if (rref->type != REF_COMPONENT) - continue; - - rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; - rsym_target = lsym_target || rref->u.c.sym->attr.target; - - if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym, - lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lref->u.c.component->ts, - &rref->u.c.sym->ts)) - return 1; - if (gfc_compare_types (&lref->u.c.sym->ts, - &rref->u.c.component->ts)) - return 1; - if (gfc_compare_types (&lref->u.c.component->ts, - &rref->u.c.component->ts)) - return 1; - } - } - } - - lsym_pointer = lsym->attr.pointer; - lsym_target = lsym->attr.target; - - for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next) - { - if (rref->type != REF_COMPONENT) - break; - - rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; - rsym_target = lsym_target || rref->u.c.sym->attr.target; - - if (symbols_could_alias (rref->u.c.sym, lsym, - lsym_pointer, lsym_target, - rsym_pointer, rsym_target)) - return 1; - - if ((lsym_pointer && (rsym_pointer || rsym_target)) - || (rsym_pointer && (lsym_pointer || lsym_target))) - { - if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts)) - return 1; - } - } - - return 0; -} - - -/* Resolve array data dependencies. Creates a temporary if required. */ -/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to - dependency.c. */ - -void -gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, - gfc_ss * rss) -{ - gfc_ss *ss; - gfc_ref *lref; - gfc_ref *rref; - gfc_ss_info *ss_info; - gfc_expr *dest_expr; - gfc_expr *ss_expr; - int nDepend = 0; - int i, j; - - loop->temp_ss = NULL; - dest_expr = dest->info->expr; - - for (ss = rss; ss != gfc_ss_terminator; ss = ss->next) - { - ss_info = ss->info; - ss_expr = ss_info->expr; - - if (ss_info->array_outer_dependency) - { - nDepend = 1; - break; - } - - if (ss_info->type != GFC_SS_SECTION) - { - if (flag_realloc_lhs - && dest_expr != ss_expr - && gfc_is_reallocatable_lhs (dest_expr) - && ss_expr->rank) - nDepend = gfc_check_dependency (dest_expr, ss_expr, true); - - /* Check for cases like c(:)(1:2) = c(2)(2:3) */ - if (!nDepend && dest_expr->rank > 0 - && dest_expr->ts.type == BT_CHARACTER - && ss_expr->expr_type == EXPR_VARIABLE) - - nDepend = gfc_check_dependency (dest_expr, ss_expr, false); - - if (ss_info->type == GFC_SS_REFERENCE - && gfc_check_dependency (dest_expr, ss_expr, false)) - ss_info->data.scalar.needs_temporary = 1; - - if (nDepend) - break; - else - continue; - } - - if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym) - { - if (gfc_could_be_alias (dest, ss) - || gfc_are_equivalenced_arrays (dest_expr, ss_expr)) - { - nDepend = 1; - break; - } - } - else - { - lref = dest_expr->ref; - rref = ss_expr->ref; - - nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); - - if (nDepend == 1) - break; - - for (i = 0; i < dest->dimen; i++) - for (j = 0; j < ss->dimen; j++) - if (i != j - && dest->dim[i] == ss->dim[j]) - { - /* If we don't access array elements in the same order, - there is a dependency. */ - nDepend = 1; - goto temporary; - } -#if 0 - /* TODO : loop shifting. */ - if (nDepend == 1) - { - /* Mark the dimensions for LOOP SHIFTING */ - for (n = 0; n < loop->dimen; n++) - { - int dim = dest->data.info.dim[n]; - - if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - depends[n] = 2; - else if (! gfc_is_same_range (&lref->u.ar, - &rref->u.ar, dim, 0)) - depends[n] = 1; - } - - /* Put all the dimensions with dependencies in the - innermost loops. */ - dim = 0; - for (n = 0; n < loop->dimen; n++) - { - gcc_assert (loop->order[n] == n); - if (depends[n]) - loop->order[dim++] = n; - } - for (n = 0; n < loop->dimen; n++) - { - if (! depends[n]) - loop->order[dim++] = n; - } - - gcc_assert (dim == loop->dimen); - break; - } -#endif - } - } - -temporary: - - if (nDepend == 1) - { - tree base_type = gfc_typenode_for_spec (&dest_expr->ts); - if (GFC_ARRAY_TYPE_P (base_type) - || GFC_DESCRIPTOR_TYPE_P (base_type)) - base_type = gfc_get_element_type (base_type); - loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length, - loop->dimen); - gfc_add_ss_to_loop (loop, loop->temp_ss); - } - else - loop->temp_ss = NULL; -} - - -/* Browse through each array's information from the scalarizer and set the loop - bounds according to the "best" one (per dimension), i.e. the one which - provides the most information (constant bounds, shape, etc.). */ - -static void -set_loop_bounds (gfc_loopinfo *loop) -{ - int n, dim, spec_dim; - gfc_array_info *info; - gfc_array_info *specinfo; - gfc_ss *ss; - tree tmp; - gfc_ss **loopspec; - bool dynamic[GFC_MAX_DIMENSIONS]; - mpz_t *cshape; - mpz_t i; - bool nonoptional_arr; - - gfc_loopinfo * const outer_loop = outermost_loop (loop); - - loopspec = loop->specloop; - - mpz_init (i); - for (n = 0; n < loop->dimen; n++) - { - loopspec[n] = NULL; - dynamic[n] = false; - - /* If there are both optional and nonoptional array arguments, scalarize - over the nonoptional; otherwise, it does not matter as then all - (optional) arrays have to be present per F2008, 125.2.12p3(6). */ - - nonoptional_arr = false; - - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP - && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref) - { - nonoptional_arr = true; - break; - } - - /* We use one SS term, and use that to determine the bounds of the - loop for this dimension. We try to pick the simplest term. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - - ss_type = ss->info->type; - if (ss_type == GFC_SS_SCALAR - || ss_type == GFC_SS_TEMP - || ss_type == GFC_SS_REFERENCE - || (ss->info->can_be_null_ref && nonoptional_arr)) - continue; - - info = &ss->info->data.array; - dim = ss->dim[n]; - - if (loopspec[n] != NULL) - { - specinfo = &loopspec[n]->info->data.array; - spec_dim = loopspec[n]->dim[n]; - } - else - { - /* Silence uninitialized warnings. */ - specinfo = NULL; - spec_dim = 0; - } - - if (info->shape) - { - /* The frontend has worked out the size for us. */ - if (!loopspec[n] - || !specinfo->shape - || !integer_zerop (specinfo->start[spec_dim])) - /* Prefer zero-based descriptors if possible. */ - loopspec[n] = ss; - continue; - } - - if (ss_type == GFC_SS_CONSTRUCTOR) - { - gfc_constructor_base base; - /* An unknown size constructor will always be rank one. - Higher rank constructors will either have known shape, - or still be wrapped in a call to reshape. */ - gcc_assert (loop->dimen == 1); - - /* Always prefer to use the constructor bounds if the size - can be determined at compile time. Prefer not to otherwise, - since the general case involves realloc, and it's better to - avoid that overhead if possible. */ - base = ss->info->expr->value.constructor; - dynamic[n] = gfc_get_array_constructor_size (&i, base); - if (!dynamic[n] || !loopspec[n]) - loopspec[n] = ss; - continue; - } - - /* Avoid using an allocatable lhs in an assignment, since - there might be a reallocation coming. */ - if (loopspec[n] && ss->is_alloc_lhs) - continue; - - if (!loopspec[n]) - loopspec[n] = ss; - /* Criteria for choosing a loop specifier (most important first): - doesn't need realloc - stride of one - known stride - known lower bound - known upper bound - */ - else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) - loopspec[n] = ss; - else if (integer_onep (info->stride[dim]) - && !integer_onep (specinfo->stride[spec_dim])) - loopspec[n] = ss; - else if (INTEGER_CST_P (info->stride[dim]) - && !INTEGER_CST_P (specinfo->stride[spec_dim])) - loopspec[n] = ss; - else if (INTEGER_CST_P (info->start[dim]) - && !INTEGER_CST_P (specinfo->start[spec_dim]) - && integer_onep (info->stride[dim]) - == integer_onep (specinfo->stride[spec_dim]) - && INTEGER_CST_P (info->stride[dim]) - == INTEGER_CST_P (specinfo->stride[spec_dim])) - loopspec[n] = ss; - /* We don't work out the upper bound. - else if (INTEGER_CST_P (info->finish[n]) - && ! INTEGER_CST_P (specinfo->finish[n])) - loopspec[n] = ss; */ - } - - /* We should have found the scalarization loop specifier. If not, - that's bad news. */ - gcc_assert (loopspec[n]); - - info = &loopspec[n]->info->data.array; - dim = loopspec[n]->dim[n]; - - /* Set the extents of this range. */ - cshape = info->shape; - if (cshape && INTEGER_CST_P (info->start[dim]) - && INTEGER_CST_P (info->stride[dim])) - { - loop->from[n] = info->start[dim]; - mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]); - mpz_sub_ui (i, i, 1); - /* To = from + (size - 1) * stride. */ - tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); - if (!integer_onep (info->stride[dim])) - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - info->stride[dim]); - loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - loop->from[n], tmp); - } - else - { - loop->from[n] = info->start[dim]; - switch (loopspec[n]->info->type) - { - case GFC_SS_CONSTRUCTOR: - /* The upper bound is calculated when we expand the - constructor. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; - - case GFC_SS_SECTION: - /* Use the end expression if it exists and is not constant, - so that it is only evaluated once. */ - loop->to[n] = info->end[dim]; - break; - - case GFC_SS_FUNCTION: - /* The loop bound will be set when we generate the call. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; - - case GFC_SS_INTRINSIC: - { - gfc_expr *expr = loopspec[n]->info->expr; - - /* The {l,u}bound of an assumed rank. */ - if (expr->value.function.isym->id == GFC_ISYM_SHAPE) - gcc_assert (expr->value.function.actual->expr->rank == -1); - else - gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND - || expr->value.function.isym->id == GFC_ISYM_UBOUND) - && expr->value.function.actual->next->expr == NULL - && expr->value.function.actual->expr->rank == -1); - - loop->to[n] = info->end[dim]; - break; - } - - case GFC_SS_COMPONENT: - { - if (info->end[dim] != NULL_TREE) - { - loop->to[n] = info->end[dim]; - break; - } - else - gcc_unreachable (); - } - - default: - gcc_unreachable (); - } - } - - /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[dim])) - info->delta[dim] = gfc_index_zero_node; - else - { - /* Set the delta for this section. */ - info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre); - /* Number of iterations is (end - start + step) / step. - with start = 0, this simplifies to - last = end / step; - for (i = 0; i<=last; i++){...}; */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, loop->to[n], - loop->from[n]); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, - gfc_array_index_type, tmp, info->stride[dim]); - tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - tmp, build_int_cst (gfc_array_index_type, -1)); - loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre); - /* Make the loop variable start at 0. */ - loop->from[n] = gfc_index_zero_node; - } - } - mpz_clear (i); - - for (loop = loop->nested; loop; loop = loop->next) - set_loop_bounds (loop); -} - - -/* Initialize the scalarization loop. Creates the loop variables. Determines - the range of the loop variables. Creates a temporary if required. - Also generates code for scalar expressions which have been - moved outside the loop. */ - -void -gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) -{ - gfc_ss *tmp_ss; - tree tmp; - - set_loop_bounds (loop); - - /* Add all the scalar code that can be taken out of the loops. - This may include calculating the loop bounds, so do it before - allocating the temporary. */ - gfc_add_loop_ss_code (loop, loop->ss, false, where); - - tmp_ss = loop->temp_ss; - /* If we want a temporary then create it. */ - if (tmp_ss != NULL) - { - gfc_ss_info *tmp_ss_info; - - tmp_ss_info = tmp_ss->info; - gcc_assert (tmp_ss_info->type == GFC_SS_TEMP); - gcc_assert (loop->parent == NULL); - - /* Make absolutely sure that this is a complete type. */ - if (tmp_ss_info->string_length) - tmp_ss_info->data.temp.type - = gfc_get_character_type_len_for_eltype - (TREE_TYPE (tmp_ss_info->data.temp.type), - tmp_ss_info->string_length); - - tmp = tmp_ss_info->data.temp.type; - memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info)); - tmp_ss_info->type = GFC_SS_SECTION; - - gcc_assert (tmp_ss->dimen != 0); - - gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp, - NULL_TREE, false, true, false, where); - } - - /* For array parameters we don't have loop variables, so don't calculate the - translations. */ - if (!loop->array_parameter) - gfc_set_delta (loop); -} - - -/* Calculates how to transform from loop variables to array indices for each - array: once loop bounds are chosen, sets the difference (DELTA field) between - loop bounds and array reference bounds, for each array info. */ - -void -gfc_set_delta (gfc_loopinfo *loop) -{ - gfc_ss *ss, **loopspec; - gfc_array_info *info; - tree tmp; - int n, dim; - - gfc_loopinfo * const outer_loop = outermost_loop (loop); - - loopspec = loop->specloop; - - /* Calculate the translation from loop variables to array indices. */ - for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - { - gfc_ss_type ss_type; - - ss_type = ss->info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_COMPONENT - && ss_type != GFC_SS_CONSTRUCTOR) - continue; - - info = &ss->info->data.array; - - for (n = 0; n < ss->dimen; n++) - { - /* If we are specifying the range the delta is already set. */ - if (loopspec[n] != ss) - { - dim = ss->dim[n]; - - /* Calculate the offset relative to the loop variable. - First multiply by the stride. */ - tmp = loop->from[n]; - if (!integer_onep (info->stride[dim])) - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, info->stride[dim]); - - /* Then subtract this from our starting value. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - info->start[dim], tmp); - - info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); - } - } - } - - for (loop = loop->nested; loop; loop = loop->next) - gfc_set_delta (loop); -} - - -/* Calculate the size of a given array dimension from the bounds. This - is simply (ubound - lbound + 1) if this expression is positive - or 0 if it is negative (pick either one if it is zero). Optionally - (if or_expr is present) OR the (expression != 0) condition to it. */ - -tree -gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) -{ - tree res; - tree cond; - - /* Calculate (ubound - lbound + 1). */ - res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - ubound, lbound); - res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res, - gfc_index_one_node); - - /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res, - gfc_index_zero_node); - res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - gfc_index_zero_node, res); - - /* Build OR expression. */ - if (or_expr) - *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, *or_expr, cond); - - return res; -} - - -/* For an array descriptor, get the total number of elements. This is just - the product of the extents along from_dim to to_dim. */ - -static tree -gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim) -{ - tree res; - int dim; - - res = gfc_index_one_node; - - for (dim = from_dim; dim < to_dim; ++dim) - { - tree lbound; - tree ubound; - tree extent; - - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); - - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); - res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - res, extent); - } - - return res; -} - - -/* Full size of an array. */ - -tree -gfc_conv_descriptor_size (tree desc, int rank) -{ - return gfc_conv_descriptor_size_1 (desc, 0, rank); -} - - -/* Size of a coarray for all dimensions but the last. */ - -tree -gfc_conv_descriptor_cosize (tree desc, int rank, int corank) -{ - return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1); -} - - -/* Fills in an array descriptor, and returns the size of the array. - The size will be a simple_val, ie a variable or a constant. Also - calculates the offset of the base. The pointer argument overflow, - which should be of integer type, will increase in value if overflow - occurs during the size calculation. Returns the size of the array. - { - stride = 1; - offset = 0; - for (n = 0; n < rank; n++) - { - a.lbound[n] = specified_lower_bound; - offset = offset + a.lbond[n] * stride; - size = 1 - lbound; - a.ubound[n] = specified_upper_bound; - a.stride[n] = stride; - size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound - overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); - stride = stride * size; - } - for (n = rank; n < rank+corank; n++) - (Set lcobound/ucobound as above.) - element_size = sizeof (array element); - if (!rank) - return element_size - stride = (size_t) stride; - overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0); - stride = stride * element_size; - return (stride); - } */ -/*GCC ARRAYS*/ - -static tree -gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, - gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, - stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr, - tree *element_size) -{ - tree type; - tree tmp; - tree size; - tree offset; - tree stride; - tree or_expr; - tree thencase; - tree elsecase; - tree cond; - tree var; - stmtblock_t thenblock; - stmtblock_t elseblock; - gfc_expr *ubound; - gfc_se se; - int n; - - type = TREE_TYPE (descriptor); - - stride = gfc_index_one_node; - offset = gfc_index_zero_node; - - /* Set the dtype before the alloc, because registration of coarrays needs - it initialized. */ - if (expr->ts.type == BT_CHARACTER - && expr->ts.deferred - && VAR_P (expr->ts.u.cl->backend_decl)) - { - type = gfc_typenode_for_spec (&expr->ts); - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); - } - else if (expr->ts.type == BT_CHARACTER - && expr->ts.deferred - && TREE_CODE (descriptor) == COMPONENT_REF) - { - /* Deferred character components have their string length tucked away - in a hidden field of the derived type. Obtain that and use it to - set the dtype. The charlen backend decl is zero because the field - type is zero length. */ - gfc_ref *ref; - tmp = NULL_TREE; - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT - && gfc_deferred_strlen (ref->u.c.component, &tmp)) - break; - gcc_assert (tmp != NULL_TREE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - TREE_OPERAND (descriptor, 0), tmp, NULL_TREE); - tmp = fold_convert (gfc_charlen_type_node, tmp); - type = gfc_get_character_type_len (expr->ts.kind, tmp); - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); - } - else - { - tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype (type)); - } - - or_expr = logical_false_node; - - for (n = 0; n < rank; n++) - { - tree conv_lbound; - tree conv_ubound; - - /* We have 3 possibilities for determining the size of the array: - lower == NULL => lbound = 1, ubound = upper[n] - upper[n] = NULL => lbound = 1, ubound = lower[n] - upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ - ubound = upper[n]; - - /* Set lower bound. */ - gfc_init_se (&se, NULL); - if (expr3_desc != NULL_TREE) - { - if (e3_has_nodescriptor) - /* The lbound of nondescriptor arrays like array constructors, - nonallocatable/nonpointer function results/variables, - start at zero, but when allocating it, the standard expects - the array to start at one. */ - se.expr = gfc_index_one_node; - else - se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, - gfc_rank_cst[n]); - } - else if (lower == NULL) - se.expr = gfc_index_one_node; - else - { - gcc_assert (lower[n]); - if (ubound) - { - gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - } - else - { - se.expr = gfc_index_one_node; - ubound = lower[n]; - } - } - gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - conv_lbound = se.expr; - - /* Work out the offset for this component. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - se.expr, stride); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, tmp); - - /* Set upper bound. */ - gfc_init_se (&se, NULL); - if (expr3_desc != NULL_TREE) - { - if (e3_has_nodescriptor) - { - /* The lbound of nondescriptor arrays like array constructors, - nonallocatable/nonpointer function results/variables, - start at zero, but when allocating it, the standard expects - the array to start at one. Therefore fix the upper bound to be - (desc.ubound - desc.lbound) + 1. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_ubound_get ( - expr3_desc, gfc_rank_cst[n]), - gfc_conv_descriptor_lbound_get ( - expr3_desc, gfc_rank_cst[n])); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); - se.expr = gfc_evaluate_now (tmp, pblock); - } - else - se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, - gfc_rank_cst[n]); - } - else - { - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - if (ubound->expr_type == EXPR_FUNCTION) - se.expr = gfc_evaluate_now (se.expr, pblock); - } - gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - conv_ubound = se.expr; - - /* Store the stride. */ - gfc_conv_descriptor_stride_set (descriptor_block, descriptor, - gfc_rank_cst[n], stride); - - /* Calculate size and check whether extent is negative. */ - size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr); - size = gfc_evaluate_now (size, pblock); - - /* Check whether multiplying the stride by the number of - elements in this dimension would overflow. We must also check - whether the current dimension has zero size in order to avoid - division by zero. - */ - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, - TYPE_MAX_VALUE (gfc_array_index_type)), - size); - cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - logical_type_node, tmp, stride), - PRED_FORTRAN_OVERFLOW); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_one_node, integer_zero_node); - cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, size, - gfc_index_zero_node), - PRED_FORTRAN_SIZE_ZERO); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_zero_node, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - *overflow, tmp); - *overflow = gfc_evaluate_now (tmp, pblock); - - /* Multiply the stride by the number of elements in this dimension. */ - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, size); - stride = gfc_evaluate_now (stride, pblock); - } - - for (n = rank; n < rank + corank; n++) - { - ubound = upper[n]; - - /* Set lower bound. */ - gfc_init_se (&se, NULL); - if (lower == NULL || lower[n] == NULL) - { - gcc_assert (n == rank + corank - 1); - se.expr = gfc_index_one_node; - } - else - { - if (ubound || n == rank + corank - 1) - { - gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - } - else - { - se.expr = gfc_index_one_node; - ubound = lower[n]; - } - } - gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - - if (n < rank + corank - 1) - { - gfc_init_se (&se, NULL); - gcc_assert (ubound); - gfc_conv_expr_type (&se, ubound, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, - gfc_rank_cst[n], se.expr); - } - } - - /* The stride is the number of elements in the array, so multiply by the - size of an element to get the total size. Obviously, if there is a - SOURCE expression (expr3) we must use its element size. */ - if (expr3_elem_size != NULL_TREE) - tmp = expr3_elem_size; - else if (expr3 != NULL) - { - if (expr3->ts.type == BT_CLASS) - { - gfc_se se_sz; - gfc_expr *sz = gfc_copy_expr (expr3); - gfc_add_vptr_component (sz); - gfc_add_size_component (sz); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - tmp = se_sz.expr; - } - else - { - tmp = gfc_typenode_for_spec (&expr3->ts); - tmp = TYPE_SIZE_UNIT (tmp); - } - } - else - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - - /* Convert to size_t. */ - *element_size = fold_convert (size_type_node, tmp); - - if (rank == 0) - return *element_size; - - *nelems = gfc_evaluate_now (stride, pblock); - stride = fold_convert (size_type_node, stride); - - /* First check for overflow. Since an array of type character can - have zero element_size, we must check for that before - dividing. */ - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - size_type_node, - TYPE_MAX_VALUE (size_type_node), *element_size); - cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - logical_type_node, tmp, stride), - PRED_FORTRAN_OVERFLOW); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_one_node, integer_zero_node); - cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, *element_size, - build_int_cst (size_type_node, 0)), - PRED_FORTRAN_SIZE_ZERO); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, - integer_zero_node, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - *overflow, tmp); - *overflow = gfc_evaluate_now (tmp, pblock); - - size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - stride, *element_size); - - if (poffset != NULL) - { - offset = gfc_evaluate_now (offset, pblock); - *poffset = offset; - } - - if (integer_zerop (or_expr)) - return size; - if (integer_onep (or_expr)) - return build_int_cst (size_type_node, 0); - - var = gfc_create_var (TREE_TYPE (size), "size"); - gfc_start_block (&thenblock); - gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0)); - thencase = gfc_finish_block (&thenblock); - - gfc_start_block (&elseblock); - gfc_add_modify (&elseblock, var, size); - elsecase = gfc_finish_block (&elseblock); - - tmp = gfc_evaluate_now (or_expr, pblock); - tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); - gfc_add_expr_to_block (pblock, tmp); - - return var; -} - - -/* Retrieve the last ref from the chain. This routine is specific to - gfc_array_allocate ()'s needs. */ - -bool -retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) -{ - gfc_ref *ref, *prev_ref; - - ref = *ref_in; - /* Prevent warnings for uninitialized variables. */ - prev_ref = *prev_ref_in; - while (ref && ref->next != NULL) - { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT - || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); - prev_ref = ref; - ref = ref->next; - } - - if (ref == NULL || ref->type != REF_ARRAY) - return false; - - *ref_in = ref; - *prev_ref_in = prev_ref; - return true; -} - -/* Initializes the descriptor and generates a call to _gfor_allocate. Does - the work for an ALLOCATE statement. */ -/*GCC ARRAYS*/ - -bool -gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, - tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor) -{ - tree tmp; - tree pointer; - tree offset = NULL_TREE; - tree token = NULL_TREE; - tree size; - tree msg; - tree error = NULL_TREE; - tree overflow; /* Boolean storing whether size calculation overflows. */ - tree var_overflow = NULL_TREE; - tree cond; - tree set_descriptor; - tree not_prev_allocated = NULL_TREE; - tree element_size = NULL_TREE; - stmtblock_t set_descriptor_block; - stmtblock_t elseblock; - gfc_expr **lower; - gfc_expr **upper; - gfc_ref *ref, *prev_ref = NULL, *coref; - bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false, - non_ulimate_coarray_ptr_comp; - - ref = expr->ref; - - /* Find the last reference in the chain. */ - if (!retrieve_last_ref (&ref, &prev_ref)) - return false; - - /* Take the allocatable and coarray properties solely from the expr-ref's - attributes and not from source=-expression. */ - if (!prev_ref) - { - allocatable = expr->symtree->n.sym->attr.allocatable; - dimension = expr->symtree->n.sym->attr.dimension; - non_ulimate_coarray_ptr_comp = false; - } - else - { - allocatable = prev_ref->u.c.component->attr.allocatable; - /* Pointer components in coarrayed derived types must be treated - specially in that they are registered without a check if the are - already associated. This does not hold for ultimate coarray - pointers. */ - non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer - && !prev_ref->u.c.component->attr.codimension); - dimension = prev_ref->u.c.component->attr.dimension; - } - - /* For allocatable/pointer arrays in derived types, one of the refs has to be - a coarray. In this case it does not matter whether we are on this_image - or not. */ - coarray = false; - for (coref = expr->ref; coref; coref = coref->next) - if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0) - { - coarray = true; - break; - } - - if (!dimension) - gcc_assert (coarray); - - if (ref->u.ar.type == AR_FULL && expr3 != NULL) - { - gfc_ref *old_ref = ref; - /* F08:C633: Array shape from expr3. */ - ref = expr3->ref; - - /* Find the last reference in the chain. */ - if (!retrieve_last_ref (&ref, &prev_ref)) - { - if (expr3->expr_type == EXPR_FUNCTION - && gfc_expr_attr (expr3).dimension) - ref = old_ref; - else - return false; - } - alloc_w_e3_arr_spec = true; - } - - /* Figure out the size of the array. */ - switch (ref->u.ar.type) - { - case AR_ELEMENT: - if (!coarray) - { - lower = NULL; - upper = ref->u.ar.start; - break; - } - /* Fall through. */ - - case AR_SECTION: - lower = ref->u.ar.start; - upper = ref->u.ar.end; - break; - - case AR_FULL: - gcc_assert (ref->u.ar.as->type == AS_EXPLICIT - || alloc_w_e3_arr_spec); - - lower = ref->u.ar.as->lower; - upper = ref->u.ar.as->upper; - break; - - default: - gcc_unreachable (); - break; - } - - overflow = integer_zero_node; - - if (expr->ts.type == BT_CHARACTER - && TREE_CODE (se->string_length) == COMPONENT_REF - && expr->ts.u.cl->backend_decl != se->string_length - && VAR_P (expr->ts.u.cl->backend_decl)) - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl), - se->string_length)); - - gfc_init_block (&set_descriptor_block); - /* Take the corank only from the actual ref and not from the coref. The - later will mislead the generation of the array dimensions for allocatable/ - pointer components in derived types. */ - size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank - : ref->u.ar.as->rank, - coarray ? ref->u.ar.as->corank : 0, - &offset, lower, upper, - &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3, e3_arr_desc, - e3_has_nodescriptor, expr, &element_size); - - if (dimension) - { - var_overflow = gfc_create_var (integer_type_node, "overflow"); - gfc_add_modify (&se->pre, var_overflow, overflow); - - if (status == NULL_TREE) - { - /* Generate the block of code handling overflow. */ - msg = gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const - ("Integer overflow when calculating the amount of " - "memory to allocate")); - error = build_call_expr_loc (input_location, - gfor_fndecl_runtime_error, 1, msg); - } - else - { - tree status_type = TREE_TYPE (status); - stmtblock_t set_status_block; - - gfc_start_block (&set_status_block); - gfc_add_modify (&set_status_block, status, - build_int_cst (status_type, LIBERROR_ALLOCATION)); - error = gfc_finish_block (&set_status_block); - } - } - - /* Allocate memory to store the data. */ - if (POINTER_TYPE_P (TREE_TYPE (se->expr))) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - - if (coarray && flag_coarray == GFC_FCOARRAY_LIB) - { - pointer = non_ulimate_coarray_ptr_comp ? se->expr - : gfc_conv_descriptor_data_get (se->expr); - token = gfc_conv_descriptor_token (se->expr); - token = gfc_build_addr_expr (NULL_TREE, token); - } - else - pointer = gfc_conv_descriptor_data_get (se->expr); - STRIP_NOPS (pointer); - - if (allocatable) - { - not_prev_allocated = gfc_create_var (logical_type_node, - "not_prev_allocated"); - tmp = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, pointer, - build_int_cst (TREE_TYPE (pointer), 0)); - - gfc_add_modify (&se->pre, not_prev_allocated, tmp); - } - - gfc_start_block (&elseblock); - - /* The allocatable variant takes the old pointer as first argument. */ - if (allocatable) - gfc_allocate_allocatable (&elseblock, pointer, size, token, - status, errmsg, errlen, label_finish, expr, - coref != NULL ? coref->u.ar.as->corank : 0); - else if (non_ulimate_coarray_ptr_comp && token) - /* The token is set only for GFC_FCOARRAY_LIB mode. */ - gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status, - errmsg, errlen, - GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY); - else - gfc_allocate_using_malloc (&elseblock, pointer, size, status); - - if (dimension) - { - cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, - logical_type_node, var_overflow, integer_zero_node), - PRED_FORTRAN_OVERFLOW); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - error, gfc_finish_block (&elseblock)); - } - else - tmp = gfc_finish_block (&elseblock); - - gfc_add_expr_to_block (&se->pre, tmp); - - /* Update the array descriptor with the offset and the span. */ - if (dimension) - { - gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); - tmp = fold_convert (gfc_array_index_type, element_size); - gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); - } - - set_descriptor = gfc_finish_block (&set_descriptor_block); - if (status != NULL_TREE) - { - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, status, - build_int_cst (TREE_TYPE (status), 0)); - - if (not_prev_allocated != NULL_TREE) - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, not_prev_allocated); - - gfc_add_expr_to_block (&se->pre, - fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, - set_descriptor, - build_empty_stmt (input_location))); - } - else - gfc_add_expr_to_block (&se->pre, set_descriptor); - - return true; -} - - -/* Create an array constructor from an initialization expression. - We assume the frontend already did any expansions and conversions. */ - -tree -gfc_conv_array_initializer (tree type, gfc_expr * expr) -{ - gfc_constructor *c; - tree tmp; - gfc_se se; - tree index, range; - vec *v = NULL; - - if (expr->expr_type == EXPR_VARIABLE - && expr->symtree->n.sym->attr.flavor == FL_PARAMETER - && expr->symtree->n.sym->value) - expr = expr->symtree->n.sym->value; - - switch (expr->expr_type) - { - case EXPR_CONSTANT: - case EXPR_STRUCTURE: - /* A single scalar or derived type value. Create an array with all - elements equal to that value. */ - gfc_init_se (&se, NULL); - - if (expr->expr_type == EXPR_CONSTANT) - gfc_conv_constant (&se, expr); - else - gfc_conv_structure (&se, expr, 1); - - CONSTRUCTOR_APPEND_ELT (v, build2 (RANGE_EXPR, gfc_array_index_type, - TYPE_MIN_VALUE (TYPE_DOMAIN (type)), - TYPE_MAX_VALUE (TYPE_DOMAIN (type))), - se.expr); - break; - - case EXPR_ARRAY: - /* Create a vector of all the elements. */ - for (c = gfc_constructor_first (expr->value.constructor); - c && c->expr; c = gfc_constructor_next (c)) - { - if (c->iterator) - { - /* Problems occur when we get something like - integer :: a(lots) = (/(i, i=1, lots)/) */ - gfc_fatal_error ("The number of elements in the array " - "constructor at %L requires an increase of " - "the allowed %d upper limit. See " - "%<-fmax-array-constructor%> option", - &expr->where, flag_max_array_constructor); - return NULL_TREE; - } - if (mpz_cmp_si (c->offset, 0) != 0) - index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); - else - index = NULL_TREE; - - if (mpz_cmp_si (c->repeat, 1) > 0) - { - tree tmp1, tmp2; - mpz_t maxval; - - mpz_init (maxval); - mpz_add (maxval, c->offset, c->repeat); - mpz_sub_ui (maxval, maxval, 1); - tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - if (mpz_cmp_si (c->offset, 0) != 0) - { - mpz_add_ui (maxval, c->offset, 1); - tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); - } - else - tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); - - range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2); - mpz_clear (maxval); - } - else - range = NULL; - - gfc_init_se (&se, NULL); - switch (c->expr->expr_type) - { - case EXPR_CONSTANT: - gfc_conv_constant (&se, c->expr); - - /* See gfortran.dg/charlen_15.f90 for instance. */ - if (TREE_CODE (se.expr) == STRING_CST - && TREE_CODE (type) == ARRAY_TYPE) - { - tree atype = type; - while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE) - atype = TREE_TYPE (atype); - gcc_checking_assert (TREE_CODE (TREE_TYPE (atype)) - == INTEGER_TYPE); - gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr)) - == TREE_TYPE (atype)); - if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr))) - > tree_to_uhwi (TYPE_SIZE_UNIT (atype))) - { - unsigned HOST_WIDE_INT size - = tree_to_uhwi (TYPE_SIZE_UNIT (atype)); - const char *p = TREE_STRING_POINTER (se.expr); - - se.expr = build_string (size, p); - } - TREE_TYPE (se.expr) = atype; - } - break; - - case EXPR_STRUCTURE: - gfc_conv_structure (&se, c->expr, 1); - break; - - default: - /* Catch those occasional beasts that do not simplify - for one reason or another, assuming that if they are - standard defying the frontend will catch them. */ - gfc_conv_expr (&se, c->expr); - break; - } - - if (range == NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - else - { - if (index != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); - CONSTRUCTOR_APPEND_ELT (v, range, se.expr); - } - } - break; - - case EXPR_NULL: - return gfc_build_null_descriptor (type); - - default: - gcc_unreachable (); - } - - /* Create a constructor from the list of elements. */ - tmp = build_constructor (type, v); - TREE_CONSTANT (tmp) = 1; - return tmp; -} - - -/* Generate code to evaluate non-constant coarray cobounds. */ - -void -gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, - const gfc_symbol *sym) -{ - int dim; - tree ubound; - tree lbound; - gfc_se se; - gfc_array_spec *as; - - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; - - for (dim = as->rank; dim < as->rank + as->corank; dim++) - { - /* Evaluate non-constant array bound expressions. */ - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } - } -} - - -/* Generate code to evaluate non-constant array bounds. Sets *poffset and - returns the size (in elements) of the array. */ - -tree -gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, - stmtblock_t * pblock) -{ - gfc_array_spec *as; - tree size; - tree stride; - tree offset; - tree ubound; - tree lbound; - tree tmp; - gfc_se se; - - int dim; - - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; - - size = gfc_index_one_node; - offset = gfc_index_zero_node; - for (dim = 0; dim < as->rank; dim++) - { - /* Evaluate non-constant array bound expressions. */ - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } - /* The offset of this dimension. offset = offset - lbound * stride. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - lbound, size); - offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - offset, tmp); - - /* The size of this dimension, and the stride of the next. */ - if (dim + 1 < as->rank) - stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1); - else - stride = GFC_TYPE_ARRAY_SIZE (type); - - if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, ubound, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - if (stride) - gfc_add_modify (pblock, stride, tmp); - else - stride = gfc_evaluate_now (tmp, pblock); - - /* Make sure that negative size arrays are translated - to being zero size. */ - tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - stride, gfc_index_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, tmp, - stride, gfc_index_zero_node); - gfc_add_modify (pblock, stride, tmp); - } - - size = stride; - } - - gfc_trans_array_cobounds (type, pblock, sym); - gfc_trans_vla_type_sizes (sym, pblock); - - *poffset = offset; - return size; -} - - -/* Generate code to initialize/allocate an array variable. */ - -void -gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, - gfc_wrapped_block * block) -{ - stmtblock_t init; - tree type; - tree tmp = NULL_TREE; - tree size; - tree offset; - tree space; - tree inittree; - bool onstack; - - gcc_assert (!(sym->attr.pointer || sym->attr.allocatable)); - - /* Do nothing for USEd variables. */ - if (sym->attr.use_assoc) - return; - - type = TREE_TYPE (decl); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - onstack = TREE_CODE (type) != POINTER_TYPE; - - gfc_init_block (&init); - - /* Evaluate character string length. */ - if (sym->ts.type == BT_CHARACTER - && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - { - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - gfc_trans_vla_type_sizes (sym, &init); - - /* Emit a DECL_EXPR for this variable, which will cause the - gimplifier to allocate storage, and all that good stuff. */ - tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&init, tmp); - } - - if (onstack) - { - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - return; - } - - type = TREE_TYPE (type); - - gcc_assert (!sym->attr.use_assoc); - gcc_assert (!TREE_STATIC (decl)); - gcc_assert (!sym->module); - - if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - size = gfc_trans_array_bounds (type, sym, &offset, &init); - - /* Don't actually allocate space for Cray Pointees. */ - if (sym->attr.cray_pointee) - { - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - return; - } - - if (flag_stack_arrays) - { - gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE); - space = build_decl (gfc_get_location (&sym->declared_at), - VAR_DECL, create_tmp_var_name ("A"), - TREE_TYPE (TREE_TYPE (decl))); - gfc_trans_vla_type_sizes (sym, &init); - } - else - { - /* The size is the number of elements in the array, so multiply by the - size of an element to get the total size. */ - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, fold_convert (gfc_array_index_type, tmp)); - - /* Allocate memory to hold the data. */ - tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); - gfc_add_modify (&init, decl, tmp); - - /* Free the temporary. */ - tmp = gfc_call_free (decl); - space = NULL_TREE; - } - - /* Set offset of the array. */ - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - /* Automatic arrays should not have initializers. */ - gcc_assert (!sym->value); - - inittree = gfc_finish_block (&init); - - if (space) - { - tree addr; - pushdecl (space); - - /* Don't create new scope, emit the DECL_EXPR in exactly the scope - where also space is located. */ - gfc_init_block (&init); - tmp = fold_build1_loc (input_location, DECL_EXPR, - TREE_TYPE (space), space); - gfc_add_expr_to_block (&init, tmp); - addr = fold_build1_loc (gfc_get_location (&sym->declared_at), - ADDR_EXPR, TREE_TYPE (decl), space); - gfc_add_modify (&init, decl, addr); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - tmp = NULL_TREE; - } - gfc_add_init_cleanup (block, inittree, tmp); -} - - -/* Generate entry and exit code for g77 calling convention arrays. */ - -void -gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) -{ - tree parm; - tree type; - locus loc; - tree offset; - tree tmp; - tree stmt; - stmtblock_t init; - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - - /* Descriptor type. */ - parm = sym->backend_decl; - type = TREE_TYPE (parm); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - - gfc_start_block (&init); - - if (sym->ts.type == BT_CHARACTER - && VAR_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - /* Evaluate the bounds of the array. */ - gfc_trans_array_bounds (type, sym, &offset, &init); - - /* Set the offset. */ - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - /* Set the pointer itself if we aren't using the parameter directly. */ - if (TREE_CODE (parm) != PARM_DECL) - { - tmp = GFC_DECL_SAVED_DESCRIPTOR (parm); - if (sym->ts.type == BT_CLASS) - { - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_class_data_get (tmp); - tmp = gfc_conv_descriptor_data_get (tmp); - } - tmp = convert (TREE_TYPE (parm), tmp); - gfc_add_modify (&init, parm, tmp); - } - stmt = gfc_finish_block (&init); - - gfc_restore_backend_locus (&loc); - - /* Add the initialization code to the start of the function. */ - - if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) - || sym->attr.optional - || sym->attr.not_always_present) - { - tree nullify; - if (TREE_CODE (parm) != PARM_DECL) - nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - parm, null_pointer_node); - else - nullify = build_empty_stmt (input_location); - tmp = gfc_conv_expr_present (sym, true); - stmt = build3_v (COND_EXPR, tmp, stmt, nullify); - } - - gfc_add_init_cleanup (block, stmt, NULL_TREE); -} - - -/* Modify the descriptor of an array parameter so that it has the - correct lower bound. Also move the upper bound accordingly. - If the array is not packed, it will be copied into a temporary. - For each dimension we set the new lower and upper bounds. Then we copy the - stride and calculate the offset for this dimension. We also work out - what the stride of a packed array would be, and see it the two match. - If the array need repacking, we set the stride to the values we just - calculated, recalculate the offset and copy the array data. - Code is also added to copy the data back at the end of the function. - */ - -void -gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, - gfc_wrapped_block * block) -{ - tree size; - tree type; - tree offset; - locus loc; - stmtblock_t init; - tree stmtInit, stmtCleanup; - tree lbound; - tree ubound; - tree dubound; - tree dlbound; - tree dumdesc; - tree tmp; - tree stride, stride2; - tree stmt_packed; - tree stmt_unpacked; - tree partial; - gfc_se se; - int n; - int checkparm; - int no_repack; - bool optional_arg; - gfc_array_spec *as; - bool is_classarray = IS_CLASS_ARRAY (sym); - - /* Do nothing for pointer and allocatable arrays. */ - if ((sym->ts.type != BT_CLASS && sym->attr.pointer) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) - || sym->attr.allocatable - || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) - return; - - if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) - { - gfc_trans_g77_array (sym, block); - return; - } - - loc.nextc = NULL; - gfc_save_backend_locus (&loc); - /* loc.nextc is not set by save_backend_locus but the location routines - depend on it. */ - if (loc.nextc == NULL) - loc.nextc = loc.lb->line; - gfc_set_backend_locus (&sym->declared_at); - - /* Descriptor type. */ - type = TREE_TYPE (tmpdesc); - gcc_assert (GFC_ARRAY_TYPE_P (type)); - dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - if (is_classarray) - /* For a class array the dummy array descriptor is in the _class - component. */ - dumdesc = gfc_class_data_get (dumdesc); - else - dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); - as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; - gfc_start_block (&init); - - if (sym->ts.type == BT_CHARACTER - && VAR_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - /* TODO: Fix the exclusion of class arrays from extent checking. */ - checkparm = (as->type == AS_EXPLICIT && !is_classarray - && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); - - no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) - || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); - - if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) - { - /* For non-constant shape arrays we only check if the first dimension - is contiguous. Repacking higher dimensions wouldn't gain us - anything as we still don't know the array stride. */ - partial = gfc_create_var (logical_type_node, "partial"); - TREE_USED (partial) = 1; - tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, - gfc_index_one_node); - gfc_add_modify (&init, partial, tmp); - } - else - partial = NULL_TREE; - - /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive - here, however I think it does the right thing. */ - if (no_repack) - { - /* Set the first stride. */ - stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - stride = gfc_evaluate_now (stride, &init); - - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - stride, gfc_index_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node, stride); - stride = GFC_TYPE_ARRAY_STRIDE (type, 0); - gfc_add_modify (&init, stride, tmp); - - /* Allow the user to disable array repacking. */ - stmt_unpacked = NULL_TREE; - } - else - { - gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0))); - /* A library call to repack the array if necessary. */ - tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - stmt_unpacked = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, tmp); - - stride = gfc_index_one_node; - - if (warn_array_temporaries) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", &loc); - } - - /* This is for the case where the array data is used directly without - calling the repack function. */ - if (no_repack || partial != NULL_TREE) - stmt_packed = gfc_conv_descriptor_data_get (dumdesc); - else - stmt_packed = NULL_TREE; - - /* Assign the data pointer. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) - { - /* Don't repack unknown shape arrays when the first stride is 1. */ - tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed), - partial, stmt_packed, stmt_unpacked); - } - else - tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; - gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); - - offset = gfc_index_zero_node; - size = gfc_index_one_node; - - /* Evaluate the bounds of the array. */ - for (n = 0; n < as->rank; n++) - { - if (checkparm || !as->upper[n]) - { - /* Get the bounds of the actual parameter. */ - dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); - dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); - } - else - { - dubound = NULL_TREE; - dlbound = NULL_TREE; - } - - lbound = GFC_TYPE_ARRAY_LBOUND (type, n); - if (!INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&init, &se.pre); - gfc_add_modify (&init, lbound, se.expr); - } - - ubound = GFC_TYPE_ARRAY_UBOUND (type, n); - /* Set the desired upper bound. */ - if (as->upper[n]) - { - /* We know what we want the upper bound to be. */ - if (!INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&init, &se.pre); - gfc_add_modify (&init, ubound, se.expr); - } - - /* Check the sizes match. */ - if (checkparm) - { - /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ - char * msg; - tree temp; - - temp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - temp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, temp); - stride2 = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, dubound, - dlbound); - stride2 = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, stride2); - tmp = fold_build2_loc (input_location, NE_EXPR, - gfc_array_index_type, temp, stride2); - msg = xasprintf ("Dimension %d of array '%s' has extent " - "%%ld instead of %%ld", n+1, sym->name); - - gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, - fold_convert (long_integer_type_node, temp), - fold_convert (long_integer_type_node, stride2)); - - free (msg); - } - } - else - { - /* For assumed shape arrays move the upper bound by the same amount - as the lower bound. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, dubound, dlbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, lbound); - gfc_add_modify (&init, ubound, tmp); - } - /* The offset of this dimension. offset = offset - lbound * stride. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - lbound, stride); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, offset, tmp); - - /* The size of this dimension, and the stride of the next. */ - if (n + 1 < as->rank) - { - stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); - - if (no_repack || partial != NULL_TREE) - stmt_unpacked = - gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - - /* Figure out the stride if not a known constant. */ - if (!INTEGER_CST_P (stride)) - { - if (no_repack) - stmt_packed = NULL_TREE; - else - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, ubound, tmp); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - stmt_packed = size; - } - - /* Assign the stride. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) - tmp = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, partial, - stmt_unpacked, stmt_packed); - else - tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; - gfc_add_modify (&init, stride, tmp); - } - } - else - { - stride = GFC_TYPE_ARRAY_SIZE (type); - - if (stride && !INTEGER_CST_P (stride)) - { - /* Calculate size = stride * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - ubound, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&init, stride, tmp); - } - } - } - - gfc_trans_array_cobounds (type, &init, sym); - - /* Set the offset. */ - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_trans_vla_type_sizes (sym, &init); - - stmtInit = gfc_finish_block (&init); - - /* Only do the entry/initialization code if the arg is present. */ - dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - optional_arg = (sym->attr.optional - || (sym->ns->proc_name->attr.entry_master - && sym->attr.dummy)); - if (optional_arg) - { - tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node); - zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - tmpdesc, zero_init); - tmp = gfc_conv_expr_present (sym, true); - stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init); - } - - /* Cleanup code. */ - if (no_repack) - stmtCleanup = NULL_TREE; - else - { - stmtblock_t cleanup; - gfc_start_block (&cleanup); - - if (sym->attr.intent != INTENT_IN) - { - /* Copy the data back. */ - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc); - gfc_add_expr_to_block (&cleanup, tmp); - } - - /* Free the temporary. */ - tmp = gfc_call_free (tmpdesc); - gfc_add_expr_to_block (&cleanup, tmp); - - stmtCleanup = gfc_finish_block (&cleanup); - - /* Only do the cleanup if the array was repacked. */ - if (is_classarray) - /* For a class array the dummy array descriptor is in the _class - component. */ - tmp = gfc_class_data_get (dumdesc); - else - tmp = build_fold_indirect_ref_loc (input_location, dumdesc); - tmp = gfc_conv_descriptor_data_get (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, tmpdesc); - stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, - build_empty_stmt (input_location)); - - if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, - build_empty_stmt (input_location)); - } - } - - /* We don't need to free any memory allocated by internal_pack as it will - be freed at the end of the function by pop_context. */ - gfc_add_init_cleanup (block, stmtInit, stmtCleanup); - - gfc_restore_backend_locus (&loc); -} - - -/* Calculate the overall offset, including subreferences. */ -void -gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, - bool subref, gfc_expr *expr) -{ - tree tmp; - tree field; - tree stride; - tree index; - gfc_ref *ref; - gfc_se start; - int n; - - /* If offset is NULL and this is not a subreferenced array, there is - nothing to do. */ - if (offset == NULL_TREE) - { - if (subref) - offset = gfc_index_zero_node; - else - return; - } - - tmp = build_array_ref (desc, offset, NULL, NULL); - - /* Offset the data pointer for pointer assignments from arrays with - subreferences; e.g. my_integer => my_type(:)%integer_component. */ - if (subref) - { - /* Go past the array reference. */ - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && - ref->u.ar.type != AR_ELEMENT) - { - ref = ref->next; - break; - } - - /* Calculate the offset for each subsequent subreference. */ - for (; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_COMPONENT: - field = ref->u.c.component->backend_decl; - gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), - tmp, field, NULL_TREE); - break; - - case REF_SUBSTRING: - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); - gfc_add_block_to_block (block, &start.pre); - tmp = gfc_build_array_ref (tmp, start.expr, NULL); - break; - - case REF_ARRAY: - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE - && ref->u.ar.type == AR_ELEMENT); - - /* TODO - Add bounds checking. */ - stride = gfc_index_one_node; - index = gfc_index_zero_node; - for (n = 0; n < ref->u.ar.dimen; n++) - { - tree itmp; - tree jtmp; - - /* Update the index. */ - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type); - itmp = gfc_evaluate_now (start.expr, block); - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type); - jtmp = gfc_evaluate_now (start.expr, block); - itmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, itmp, jtmp); - itmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, itmp, stride); - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, itmp, index); - index = gfc_evaluate_now (index, block); - - /* Update the stride. */ - gfc_init_se (&start, NULL); - gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type); - itmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, start.expr, - jtmp); - itmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, itmp); - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, itmp); - stride = gfc_evaluate_now (stride, block); - } - - /* Apply the index to obtain the array element. */ - tmp = gfc_build_array_ref (tmp, index, NULL); - break; - - case REF_INQUIRY: - switch (ref->u.i) - { - case INQUIRY_RE: - tmp = fold_build1_loc (input_location, REALPART_EXPR, - TREE_TYPE (TREE_TYPE (tmp)), tmp); - break; - - case INQUIRY_IM: - tmp = fold_build1_loc (input_location, IMAGPART_EXPR, - TREE_TYPE (TREE_TYPE (tmp)), tmp); - break; - - default: - break; - } - break; - - default: - gcc_unreachable (); - break; - } - } - } - - /* Set the target data pointer. */ - offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp); - gfc_conv_descriptor_data_set (block, parm, offset); -} - - -/* gfc_conv_expr_descriptor needs the string length an expression - so that the size of the temporary can be obtained. This is done - by adding up the string lengths of all the elements in the - expression. Function with non-constant expressions have their - string lengths mapped onto the actual arguments using the - interface mapping machinery in trans-expr.c. */ -static void -get_array_charlen (gfc_expr *expr, gfc_se *se) -{ - gfc_interface_mapping mapping; - gfc_formal_arglist *formal; - gfc_actual_arglist *arg; - gfc_se tse; - gfc_expr *e; - - if (expr->ts.u.cl->length - && gfc_is_constant_expr (expr->ts.u.cl->length)) - { - if (!expr->ts.u.cl->backend_decl) - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - return; - } - - switch (expr->expr_type) - { - case EXPR_ARRAY: - - /* This is somewhat brutal. The expression for the first - element of the array is evaluated and assigned to a - new string length for the original expression. */ - e = gfc_constructor_first (expr->value.constructor)->expr; - - gfc_init_se (&tse, NULL); - - /* Avoid evaluating trailing array references since all we need is - the string length. */ - if (e->rank) - tse.descriptor_only = 1; - if (e->rank && e->expr_type != EXPR_VARIABLE) - gfc_conv_expr_descriptor (&tse, e); - else - gfc_conv_expr (&tse, e); - - gfc_add_block_to_block (&se->pre, &tse.pre); - gfc_add_block_to_block (&se->post, &tse.post); - - if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl)) - { - expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - expr->ts.u.cl->backend_decl = - gfc_create_var (gfc_charlen_type_node, "sln"); - } - - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - tse.string_length); - - /* Make sure that deferred length components point to the hidden - string_length component. */ - if (TREE_CODE (tse.expr) == COMPONENT_REF - && TREE_CODE (tse.string_length) == COMPONENT_REF - && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0)) - e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl; - - return; - - case EXPR_OP: - get_array_charlen (expr->value.op.op1, se); - - /* For parentheses the expression ts.u.cl should be identical. */ - if (expr->value.op.op == INTRINSIC_PARENTHESES) - { - if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl) - expr->ts.u.cl->backend_decl - = expr->value.op.op1->ts.u.cl->backend_decl; - return; - } - - expr->ts.u.cl->backend_decl = - gfc_create_var (gfc_charlen_type_node, "sln"); - - if (expr->value.op.op2) - { - get_array_charlen (expr->value.op.op2, se); - - gcc_assert (expr->value.op.op == INTRINSIC_CONCAT); - - /* Add the string lengths and assign them to the expression - string length backend declaration. */ - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - fold_build2_loc (input_location, PLUS_EXPR, - gfc_charlen_type_node, - expr->value.op.op1->ts.u.cl->backend_decl, - expr->value.op.op2->ts.u.cl->backend_decl)); - } - else - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, - expr->value.op.op1->ts.u.cl->backend_decl); - break; - - case EXPR_FUNCTION: - if (expr->value.function.esym == NULL - || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - break; - } - - /* Map expressions involving the dummy arguments onto the actual - argument expressions. */ - gfc_init_interface_mapping (&mapping); - formal = gfc_sym_get_dummy_args (expr->symtree->n.sym); - arg = expr->value.function.actual; - - /* Set se = NULL in the calls to the interface mapping, to suppress any - backend stuff. */ - for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) - { - if (!arg->expr) - continue; - if (formal->sym) - gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr); - } - - gfc_init_se (&tse, NULL); - - /* Build the expression for the character length and convert it. */ - gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length); - - gfc_add_block_to_block (&se->pre, &tse.pre); - gfc_add_block_to_block (&se->post, &tse.post); - tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); - tse.expr = fold_build2_loc (input_location, MAX_EXPR, - TREE_TYPE (tse.expr), tse.expr, - build_zero_cst (TREE_TYPE (tse.expr))); - expr->ts.u.cl->backend_decl = tse.expr; - gfc_free_interface_mapping (&mapping); - break; - - default: - gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); - break; - } -} - - -/* Helper function to check dimensions. */ -static bool -transposed_dims (gfc_ss *ss) -{ - int n; - - for (n = 0; n < ss->dimen; n++) - if (ss->dim[n] != n) - return true; - return false; -} - - -/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an - AR_FULL, suitable for the scalarizer. */ - -static gfc_ss * -walk_coarray (gfc_expr *e) -{ - gfc_ss *ss; - - gcc_assert (gfc_get_corank (e) > 0); - - ss = gfc_walk_expr (e); - - /* Fix scalar coarray. */ - if (ss == gfc_ss_terminator) - { - gfc_ref *ref; - - ref = e->ref; - while (ref) - { - if (ref->type == REF_ARRAY - && ref->u.ar.codimen > 0) - break; - - ref = ref->next; - } - - gcc_assert (ref != NULL); - if (ref->u.ar.type == AR_ELEMENT) - ref->u.ar.type = AR_SECTION; - ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref)); - } - - return ss; -} - - -/* Convert an array for passing as an actual argument. Expressions and - vector subscripts are evaluated and stored in a temporary, which is then - passed. For whole arrays the descriptor is passed. For array sections - a modified copy of the descriptor is passed, but using the original data. - - This function is also used for array pointer assignments, and there - are three cases: - - - se->want_pointer && !se->direct_byref - EXPR is an actual argument. On exit, se->expr contains a - pointer to the array descriptor. - - - !se->want_pointer && !se->direct_byref - EXPR is an actual argument to an intrinsic function or the - left-hand side of a pointer assignment. On exit, se->expr - contains the descriptor for EXPR. - - - !se->want_pointer && se->direct_byref - EXPR is the right-hand side of a pointer assignment and - se->expr is the descriptor for the previously-evaluated - left-hand side. The function creates an assignment from - EXPR to se->expr. - - - The se->force_tmp flag disables the non-copying descriptor optimization - that is used for transpose. It may be used in cases where there is an - alias between the transpose argument and another argument in the same - function call. */ - -void -gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) -{ - gfc_ss *ss; - gfc_ss_type ss_type; - gfc_ss_info *ss_info; - gfc_loopinfo loop; - gfc_array_info *info; - int need_tmp; - int n; - tree tmp; - tree desc; - stmtblock_t block; - tree start; - int full; - bool subref_array_target = false; - bool deferred_array_component = false; - gfc_expr *arg, *ss_expr; - - if (se->want_coarray) - ss = walk_coarray (expr); - else - ss = gfc_walk_expr (expr); - - gcc_assert (ss != NULL); - gcc_assert (ss != gfc_ss_terminator); - - ss_info = ss->info; - ss_type = ss_info->type; - ss_expr = ss_info->expr; - - /* Special case: TRANSPOSE which needs no temporary. */ - while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym - && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL) - { - /* This is a call to transpose which has already been handled by the - scalarizer, so that we just need to get its argument's descriptor. */ - gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); - expr = expr->value.function.actual->expr; - } - - if (!se->direct_byref) - se->unlimited_polymorphic = UNLIMITED_POLY (expr); - - /* Special case things we know we can pass easily. */ - switch (expr->expr_type) - { - case EXPR_VARIABLE: - /* If we have a linear array section, we can pass it directly. - Otherwise we need to copy it into a temporary. */ - - gcc_assert (ss_type == GFC_SS_SECTION); - gcc_assert (ss_expr == expr); - info = &ss_info->data.array; - - /* Get the descriptor for the array. */ - gfc_conv_ss_descriptor (&se->pre, ss, 0); - desc = info->descriptor; - - /* The charlen backend decl for deferred character components cannot - be used because it is fixed at zero. Instead, the hidden string - length component is used. */ - if (expr->ts.type == BT_CHARACTER - && expr->ts.deferred - && TREE_CODE (desc) == COMPONENT_REF) - deferred_array_component = true; - - subref_array_target = (is_subref_array (expr) - && (se->direct_byref - || expr->ts.type == BT_CHARACTER)); - need_tmp = (gfc_ref_needs_temporary_p (expr->ref) - && !subref_array_target); - - if (se->force_tmp) - need_tmp = 1; - else if (se->force_no_tmp) - need_tmp = 0; - - if (need_tmp) - full = 0; - else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - { - /* Create a new descriptor if the array doesn't have one. */ - full = 0; - } - else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only) - full = 1; - else if (se->direct_byref) - full = 0; - else if (info->ref->u.ar.dimen == 0 && !info->ref->next) - full = 1; - else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer) - full = 0; - else - full = gfc_full_array_ref_p (info->ref, NULL); - - if (full && !transposed_dims (ss)) - { - if (se->direct_byref && !se->byref_noassign) - { - /* Copy the descriptor for pointer assignments. */ - gfc_add_modify (&se->pre, se->expr, desc); - - /* Add any offsets from subreferences. */ - gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE, - subref_array_target, expr); - - /* ....and set the span field. */ - tmp = gfc_conv_descriptor_span_get (desc); - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); - } - else if (se->want_pointer) - { - /* We pass full arrays directly. This means that pointers and - allocatable arrays should also work. */ - se->expr = gfc_build_addr_expr (NULL_TREE, desc); - } - else - { - se->expr = desc; - } - - if (expr->ts.type == BT_CHARACTER && !deferred_array_component) - se->string_length = gfc_get_expr_charlen (expr); - /* The ss_info string length is returned set to the value of the - hidden string length component. */ - else if (deferred_array_component) - se->string_length = ss_info->string_length; - - gfc_free_ss_chain (ss); - return; - } - break; - - case EXPR_FUNCTION: - /* A transformational function return value will be a temporary - array descriptor. We still need to go through the scalarizer - to create the descriptor. Elemental functions are handled as - arbitrary expressions, i.e. copy to a temporary. */ - - if (se->direct_byref) - { - gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr); - - /* For pointer assignments pass the descriptor directly. */ - if (se->ss == NULL) - se->ss = ss; - else - gcc_assert (se->ss == ss); - - if (!is_pointer_array (se->expr)) - { - tmp = gfc_get_element_type (TREE_TYPE (se->expr)); - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (tmp)); - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); - } - - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - gfc_conv_expr (se, expr); - - gfc_free_ss_chain (ss); - return; - } - - if (ss_expr != expr || ss_type != GFC_SS_FUNCTION) - { - if (ss_expr != expr) - /* Elemental function. */ - gcc_assert ((expr->value.function.esym != NULL - && expr->value.function.esym->attr.elemental) - || (expr->value.function.isym != NULL - && expr->value.function.isym->elemental) - || (gfc_expr_attr (expr).proc_pointer - && gfc_expr_attr (expr).elemental) - || gfc_inline_intrinsic_function_p (expr)); - - need_tmp = 1; - if (expr->ts.type == BT_CHARACTER - && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) - get_array_charlen (expr, se); - - info = NULL; - } - else - { - /* Transformational function. */ - info = &ss_info->data.array; - need_tmp = 0; - } - break; - - case EXPR_ARRAY: - /* Constant array constructors don't need a temporary. */ - if (ss_type == GFC_SS_CONSTRUCTOR - && expr->ts.type != BT_CHARACTER - && gfc_constant_array_constructor_p (expr->value.constructor)) - { - need_tmp = 0; - info = &ss_info->data.array; - } - else - { - need_tmp = 1; - info = NULL; - } - break; - - default: - /* Something complicated. Copy it into a temporary. */ - need_tmp = 1; - info = NULL; - break; - } - - /* If we are creating a temporary, we don't need to bother about aliases - anymore. */ - if (need_tmp) - se->force_tmp = 0; - - gfc_init_loopinfo (&loop); - - /* Associate the SS with the loop. */ - gfc_add_ss_to_loop (&loop, ss); - - /* Tell the scalarizer not to bother creating loop variables, etc. */ - if (!need_tmp) - loop.array_parameter = 1; - else - /* The right-hand side of a pointer assignment mustn't use a temporary. */ - gcc_assert (!se->direct_byref); - - /* Do we need bounds checking or not? */ - ss->no_bounds_check = expr->no_bounds_check; - - /* Setup the scalarizing loops and bounds. */ - gfc_conv_ss_startstride (&loop); - - if (need_tmp) - { - if (expr->ts.type == BT_CHARACTER - && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY)) - get_array_charlen (expr, se); - - /* Tell the scalarizer to make a temporary. */ - loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts), - ((expr->ts.type == BT_CHARACTER) - ? expr->ts.u.cl->backend_decl - : NULL), - loop.dimen); - - se->string_length = loop.temp_ss->info->string_length; - gcc_assert (loop.temp_ss->dimen == loop.dimen); - gfc_add_ss_to_loop (&loop, loop.temp_ss); - } - - gfc_conv_loop_setup (&loop, & expr->where); - - if (need_tmp) - { - /* Copy into a temporary and pass that. We don't need to copy the data - back because expressions and vector subscripts must be INTENT_IN. */ - /* TODO: Optimize passing function return values. */ - gfc_se lse; - gfc_se rse; - bool deep_copy; - - /* Start the copying loops. */ - gfc_mark_ss_chain_used (loop.temp_ss, 1); - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &block); - - /* Copy each data element. */ - gfc_init_se (&lse, NULL); - gfc_copy_loopinfo_to_se (&lse, &loop); - gfc_init_se (&rse, NULL); - gfc_copy_loopinfo_to_se (&rse, &loop); - - lse.ss = loop.temp_ss; - rse.ss = ss; - - gfc_conv_scalarized_array_ref (&lse, NULL); - if (expr->ts.type == BT_CHARACTER) - { - gfc_conv_expr (&rse, expr); - if (POINTER_TYPE_P (TREE_TYPE (rse.expr))) - rse.expr = build_fold_indirect_ref_loc (input_location, - rse.expr); - } - else - gfc_conv_expr_val (&rse, expr); - - gfc_add_block_to_block (&block, &rse.pre); - gfc_add_block_to_block (&block, &lse.pre); - - lse.string_length = rse.string_length; - - deep_copy = !se->data_not_needed - && (expr->expr_type == EXPR_VARIABLE - || expr->expr_type == EXPR_ARRAY); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, - deep_copy, false); - gfc_add_expr_to_block (&block, tmp); - - /* Finish the copying loops. */ - gfc_trans_scalarizing_loops (&loop, &block); - - desc = loop.temp_ss->info->data.array.descriptor; - } - else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss)) - { - desc = info->descriptor; - se->string_length = ss_info->string_length; - } - else - { - /* We pass sections without copying to a temporary. Make a new - descriptor and point it at the section we want. The loop variable - limits will be the limits of the section. - A function may decide to repack the array to speed up access, but - we're not bothered about that here. */ - int dim, ndim, codim; - tree parm; - tree parmtype; - tree dtype; - tree stride; - tree from; - tree to; - tree base; - tree offset; - - ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; - - if (se->want_coarray) - { - gfc_array_ref *ar = &info->ref->u.ar; - - codim = gfc_get_corank (expr); - for (n = 0; n < codim - 1; n++) - { - /* Make sure we are not lost somehow. */ - gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE); - - /* Make sure the call to gfc_conv_section_startstride won't - generate unnecessary code to calculate stride. */ - gcc_assert (ar->stride[n + ndim] == NULL); - - gfc_conv_section_startstride (&loop.pre, ss, n + ndim); - loop.from[n + loop.dimen] = info->start[n + ndim]; - loop.to[n + loop.dimen] = info->end[n + ndim]; - } - - gcc_assert (n == codim - 1); - evaluate_bound (&loop.pre, info->start, ar->start, - info->descriptor, n + ndim, true, - ar->as->type == AS_DEFERRED); - loop.from[n + loop.dimen] = info->start[n + ndim]; - } - else - codim = 0; - - /* Set the string_length for a character array. */ - if (expr->ts.type == BT_CHARACTER) - { - if (deferred_array_component) - se->string_length = ss_info->string_length; - else - se->string_length = gfc_get_expr_charlen (expr); - - if (VAR_P (se->string_length) - && expr->ts.u.cl->backend_decl == se->string_length) - tmp = ss_info->string_length; - else - tmp = se->string_length; - - if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl)) - gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); - else - expr->ts.u.cl->backend_decl = tmp; - } - - /* If we have an array section, are assigning or passing an array - section argument make sure that the lower bound is 1. References - to the full array should otherwise keep the original bounds. */ - if (!info->ref || info->ref->u.ar.type != AR_FULL) - for (dim = 0; dim < loop.dimen; dim++) - if (!integer_onep (loop.from[dim])) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, gfc_index_one_node, - loop.from[dim]); - loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - loop.to[dim], tmp); - loop.from[dim] = gfc_index_one_node; - } - - desc = info->descriptor; - if (se->direct_byref && !se->byref_noassign) - { - /* For pointer assignments we fill in the destination. */ - parm = se->expr; - parmtype = TREE_TYPE (parm); - } - else - { - /* Otherwise make a new one. */ - if (expr->ts.type == BT_CHARACTER) - parmtype = gfc_typenode_for_spec (&expr->ts); - else - parmtype = gfc_get_element_type (TREE_TYPE (desc)); - - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, - loop.from, loop.to, 0, - GFC_ARRAY_UNKNOWN, false); - parm = gfc_create_var (parmtype, "parm"); - - /* When expression is a class object, then add the class' handle to - the parm_decl. */ - if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE) - { - gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); - gfc_se classse; - - /* class_expr can be NULL, when no _class ref is in expr. - We must not fix this here with a gfc_fix_class_ref (). */ - if (class_expr) - { - gfc_init_se (&classse, NULL); - gfc_conv_expr (&classse, class_expr); - gfc_free_expr (class_expr); - - gcc_assert (classse.pre.head == NULL_TREE - && classse.post.head == NULL_TREE); - gfc_allocate_lang_decl (parm); - GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr; - } - } - } - - /* Set the span field. */ - tmp = gfc_get_array_span (desc, expr); - if (tmp) - gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); - - /* The following can be somewhat confusing. We have two - descriptors, a new one and the original array. - {parm, parmtype, dim} refer to the new one. - {desc, type, n, loop} refer to the original, which maybe - a descriptorless array. - The bounds of the scalarization are the bounds of the section. - We don't have to worry about numeric overflows when calculating - the offsets because all elements are within the array data. */ - - /* Set the dtype. */ - tmp = gfc_conv_descriptor_dtype (parm); - if (se->unlimited_polymorphic) - dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen); - else if (expr->ts.type == BT_ASSUMED) - { - tree tmp2 = desc; - if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2)) - tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2); - if (POINTER_TYPE_P (TREE_TYPE (tmp2))) - tmp2 = build_fold_indirect_ref_loc (input_location, tmp2); - dtype = gfc_conv_descriptor_dtype (tmp2); - } - else - dtype = gfc_get_dtype (parmtype); - gfc_add_modify (&loop.pre, tmp, dtype); - - /* The 1st element in the section. */ - base = gfc_index_zero_node; - - /* The offset from the 1st element in the section. */ - offset = gfc_index_zero_node; - - for (n = 0; n < ndim; n++) - { - stride = gfc_conv_array_stride (desc, n); - - /* Work out the 1st element in the section. */ - if (info->ref - && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) - { - gcc_assert (info->subscript[n] - && info->subscript[n]->info->type == GFC_SS_SCALAR); - start = info->subscript[n]->info->data.scalar.value; - } - else - { - /* Evaluate and remember the start of the section. */ - start = info->start[n]; - stride = gfc_evaluate_now (stride, &loop.pre); - } - - tmp = gfc_conv_array_lbound (desc, n); - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), - start, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp, stride); - base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), - base, tmp); - - if (info->ref - && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) - { - /* For elemental dimensions, we only need the 1st - element in the section. */ - continue; - } - - /* Vector subscripts need copying and are handled elsewhere. */ - if (info->ref) - gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE); - - /* look for the corresponding scalarizer dimension: dim. */ - for (dim = 0; dim < ndim; dim++) - if (ss->dim[dim] == n) - break; - - /* loop exited early: the DIM being looked for has been found. */ - gcc_assert (dim < ndim); - - /* Set the new lower bound. */ - from = loop.from[dim]; - to = loop.to[dim]; - - gfc_conv_descriptor_lbound_set (&loop.pre, parm, - gfc_rank_cst[dim], from); - - /* Set the new upper bound. */ - gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[dim], to); - - /* Multiply the stride by the section stride to get the - total stride. */ - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - stride, info->stride[n]); - - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (offset), stride, from); - offset = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (offset), offset, tmp); - - /* Store the new stride. */ - gfc_conv_descriptor_stride_set (&loop.pre, parm, - gfc_rank_cst[dim], stride); - } - - for (n = loop.dimen; n < loop.dimen + codim; n++) - { - from = loop.from[n]; - to = loop.to[n]; - gfc_conv_descriptor_lbound_set (&loop.pre, parm, - gfc_rank_cst[n], from); - if (n < loop.dimen + codim - 1) - gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[n], to); - } - - if (se->data_not_needed) - gfc_conv_descriptor_data_set (&loop.pre, parm, - gfc_index_zero_node); - else - /* Point the data pointer at the 1st element in the section. */ - gfc_get_dataptr_offset (&loop.pre, parm, desc, base, - subref_array_target, expr); - - gfc_conv_descriptor_offset_set (&loop.pre, parm, offset); - - desc = parm; - } - - /* For class arrays add the class tree into the saved descriptor to - enable getting of _vptr and the like. */ - if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) - && IS_CLASS_ARRAY (expr->symtree->n.sym)) - { - gfc_allocate_lang_decl (desc); - GFC_DECL_SAVED_DESCRIPTOR (desc) = - DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ? - GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) - : expr->symtree->n.sym->backend_decl; - } - else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc) - && IS_CLASS_ARRAY (expr)) - { - tree vtype; - gfc_allocate_lang_decl (desc); - tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class"); - GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp; - vtype = gfc_class_vptr_get (tmp); - gfc_add_modify (&se->pre, vtype, - gfc_build_addr_expr (TREE_TYPE (vtype), - gfc_find_vtab (&expr->ts)->backend_decl)); - } - if (!se->direct_byref || se->byref_noassign) - { - /* Get a pointer to the new descriptor. */ - if (se->want_pointer) - se->expr = gfc_build_addr_expr (NULL_TREE, desc); - else - se->expr = desc; - } - - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->post, &loop.post); - - /* Cleanup the scalarizer. */ - gfc_cleanup_loop (&loop); -} - - -/* Calculate the array size (number of elements); if dim != NULL_TREE, - return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */ -tree -gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim) -{ - if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - { - gcc_assert (dim == NULL_TREE); - return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); - } - tree size, tmp, rank = NULL_TREE, cond = NULL_TREE; - symbol_attribute attr = gfc_expr_attr (expr); - gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); - if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) - || !dim) - { - if (expr->rank < 0) - rank = fold_convert (signed_char_type_node, - gfc_conv_descriptor_rank (desc)); - else - rank = build_int_cst (signed_char_type_node, expr->rank); - } - - if (dim || expr->rank == 1) - { - if (!dim) - dim = gfc_index_zero_node; - tree ubound = gfc_conv_descriptor_ubound_get (desc, dim); - tree lbound = gfc_conv_descriptor_lbound_get (desc, dim); - - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - /* if (!allocatable && !pointer && assumed rank) - size = (idx == rank && ubound[rank-1] == -1 ? -1 : size; - else - size = max (0, size); */ - size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - size, gfc_index_zero_node); - if (!attr.pointer && !attr.allocatable - && as && as->type == AS_ASSUMED_RANK) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, - rank, build_int_cst (signed_char_type_node, 1)); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - fold_convert (signed_char_type_node, dim), - tmp); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - gfc_conv_descriptor_ubound_get (desc, dim), - build_int_cst (gfc_array_index_type, -1)); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, - cond, tmp); - tmp = build_int_cst (gfc_array_index_type, -1); - size = build3_loc (input_location, COND_EXPR, gfc_array_index_type, - cond, tmp, size); - } - return size; - } - - /* size = 1. */ - size = gfc_create_var (gfc_array_index_type, "size"); - gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1)); - tree extent = gfc_create_var (gfc_array_index_type, "extent"); - - stmtblock_t cond_block, loop_body; - gfc_init_block (&cond_block); - gfc_init_block (&loop_body); - - /* Loop: for (i = 0; i < rank; ++i). */ - tree idx = gfc_create_var (signed_char_type_node, "idx"); - /* Loop body. */ - /* #if (assumed-rank + !allocatable && !pointer) - if (idx == rank - 1 && dim[idx].ubound == -1) - extent = -1; - else - #endif - extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1 - if (extent < 0) - extent = 0 - size *= extent. */ - cond = NULL_TREE; - if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, - rank, build_int_cst (signed_char_type_node, 1)); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - idx, tmp); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - gfc_conv_descriptor_ubound_get (desc, idx), - build_int_cst (gfc_array_index_type, -1)); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, - cond, tmp); - } - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, idx), - gfc_conv_descriptor_lbound_get (desc, idx)); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - gfc_add_modify (&cond_block, extent, tmp); - tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - extent, gfc_index_zero_node); - tmp = build3_v (COND_EXPR, tmp, - fold_build2_loc (input_location, MODIFY_EXPR, - gfc_array_index_type, - extent, gfc_index_zero_node), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&cond_block, tmp); - tmp = gfc_finish_block (&cond_block); - if (cond) - tmp = build3_v (COND_EXPR, cond, - fold_build2_loc (input_location, MODIFY_EXPR, - gfc_array_index_type, extent, - build_int_cst (gfc_array_index_type, -1)), - tmp); - gfc_add_expr_to_block (&loop_body, tmp); - /* size *= extent. */ - gfc_add_modify (&loop_body, size, - fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, extent)); - /* Generate loop. */ - gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, - build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - return size; -} - -/* Helper function for gfc_conv_array_parameter if array size needs to be - computed. */ - -static void -array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size) -{ - tree elem; - *size = gfc_tree_array_size (block, desc, expr, NULL); - elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - *size, fold_convert (gfc_array_index_type, elem)); -} - -/* Helper function - return true if the argument is a pointer. */ - -static bool -is_pointer (gfc_expr *e) -{ - gfc_symbol *sym; - - if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL) - return false; - - sym = e->symtree->n.sym; - if (sym == NULL) - return false; - - return sym->attr.pointer || sym->attr.proc_pointer; -} - -/* Convert an array for passing as an actual parameter. */ - -void -gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, - const gfc_symbol *fsym, const char *proc_name, - tree *size) -{ - tree ptr; - tree desc; - tree tmp = NULL_TREE; - tree stmt; - tree parent = DECL_CONTEXT (current_function_decl); - bool full_array_var; - bool this_array_result; - bool contiguous; - bool no_pack; - bool array_constructor; - bool good_allocatable; - bool ultimate_ptr_comp; - bool ultimate_alloc_comp; - gfc_symbol *sym; - stmtblock_t block; - gfc_ref *ref; - - ultimate_ptr_comp = false; - ultimate_alloc_comp = false; - - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->next == NULL) - break; - - if (ref->type == REF_COMPONENT) - { - ultimate_ptr_comp = ref->u.c.component->attr.pointer; - ultimate_alloc_comp = ref->u.c.component->attr.allocatable; - } - } - - full_array_var = false; - contiguous = false; - - if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp) - full_array_var = gfc_full_array_ref_p (ref, &contiguous); - - sym = full_array_var ? expr->symtree->n.sym : NULL; - - /* The symbol should have an array specification. */ - gcc_assert (!sym || sym->as || ref->u.ar.as); - - if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) - { - get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); - expr->ts.u.cl->backend_decl = tmp; - se->string_length = tmp; - } - - /* Is this the result of the enclosing procedure? */ - this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); - if (this_array_result - && (sym->backend_decl != current_function_decl) - && (sym->backend_decl != parent)) - this_array_result = false; - - /* Passing address of the array if it is not pointer or assumed-shape. */ - if (full_array_var && g77 && !this_array_result - && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) - { - tmp = gfc_get_symbol_decl (sym); - - if (sym->ts.type == BT_CHARACTER) - se->string_length = sym->ts.u.cl->backend_decl; - - if (!sym->attr.pointer - && sym->as - && sym->as->type != AS_ASSUMED_SHAPE - && sym->as->type != AS_DEFERRED - && sym->as->type != AS_ASSUMED_RANK - && !sym->attr.allocatable) - { - /* Some variables are declared directly, others are declared as - pointers and allocated on the heap. */ - if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp))) - se->expr = tmp; - else - se->expr = gfc_build_addr_expr (NULL_TREE, tmp); - if (size) - array_parameter_size (&se->pre, tmp, expr, size); - return; - } - - if (sym->attr.allocatable) - { - if (sym->attr.dummy || sym->attr.result) - { - gfc_conv_expr_descriptor (se, expr); - tmp = se->expr; - } - if (size) - array_parameter_size (&se->pre, tmp, expr, size); - se->expr = gfc_conv_array_data (tmp); - return; - } - } - - /* A convenient reduction in scope. */ - contiguous = g77 && !this_array_result && contiguous; - - /* There is no need to pack and unpack the array, if it is contiguous - and not a deferred- or assumed-shape array, or if it is simply - contiguous. */ - no_pack = ((sym && sym->as - && !sym->attr.pointer - && sym->as->type != AS_DEFERRED - && sym->as->type != AS_ASSUMED_RANK - && sym->as->type != AS_ASSUMED_SHAPE) - || - (ref && ref->u.ar.as - && ref->u.ar.as->type != AS_DEFERRED - && ref->u.ar.as->type != AS_ASSUMED_RANK - && ref->u.ar.as->type != AS_ASSUMED_SHAPE) - || - gfc_is_simply_contiguous (expr, false, true)); - - no_pack = contiguous && no_pack; - - /* If we have an EXPR_OP or a function returning an explicit-shaped - or allocatable array, an array temporary will be generated which - does not need to be packed / unpacked if passed to an - explicit-shape dummy array. */ - - if (g77) - { - if (expr->expr_type == EXPR_OP) - no_pack = 1; - else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym) - { - gfc_symbol *result = expr->value.function.esym->result; - if (result->attr.dimension - && (result->as->type == AS_EXPLICIT - || result->attr.allocatable - || result->attr.contiguous)) - no_pack = 1; - } - } - - /* Array constructors are always contiguous and do not need packing. */ - array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY; - - /* Same is true of contiguous sections from allocatable variables. */ - good_allocatable = contiguous - && expr->symtree - && expr->symtree->n.sym->attr.allocatable; - - /* Or ultimate allocatable components. */ - ultimate_alloc_comp = contiguous && ultimate_alloc_comp; - - if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) - { - gfc_conv_expr_descriptor (se, expr); - /* Deallocate the allocatable components of structures that are - not variable. */ - if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) - { - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank); - - /* The components shall be deallocated before their containing entity. */ - gfc_prepend_expr_to_block (&se->post, tmp); - } - if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) - se->string_length = expr->ts.u.cl->backend_decl; - if (size) - array_parameter_size (&se->pre, se->expr, expr, size); - se->expr = gfc_conv_array_data (se->expr); - return; - } - - if (this_array_result) - { - /* Result of the enclosing function. */ - gfc_conv_expr_descriptor (se, expr); - if (size) - array_parameter_size (&se->pre, se->expr, expr, size); - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - - if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) - se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location, - se->expr)); - - return; - } - else - { - /* Every other type of array. */ - se->want_pointer = 1; - gfc_conv_expr_descriptor (se, expr); - - if (size) - array_parameter_size (&se->pre, - build_fold_indirect_ref_loc (input_location, - se->expr), - expr, size); - } - - /* Deallocate the allocatable components of structures that are - not variable, for descriptorless arguments. - Arguments with a descriptor are handled in gfc_conv_procedure_call. */ - if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) - { - tmp = build_fold_indirect_ref_loc (input_location, se->expr); - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); - - /* The components shall be deallocated before their containing entity. */ - gfc_prepend_expr_to_block (&se->post, tmp); - } - - if (g77 || (fsym && fsym->attr.contiguous - && !gfc_is_simply_contiguous (expr, false, true))) - { - tree origptr = NULL_TREE; - - desc = se->expr; - - /* For contiguous arrays, save the original value of the descriptor. */ - if (!g77) - { - origptr = gfc_create_var (pvoid_type_node, "origptr"); - tmp = build_fold_indirect_ref_loc (input_location, desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (origptr), origptr, - fold_convert (TREE_TYPE (origptr), tmp)); - gfc_add_expr_to_block (&se->pre, tmp); - } - - /* Repack the array. */ - if (warn_array_temporaries) - { - if (fsym) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L for argument %qs", - &expr->where, fsym->name); - else - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", &expr->where); - } - - /* When optmizing, we can use gfc_conv_subref_array_arg for - making the packing and unpacking operation visible to the - optimizers. */ - - if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE - && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr) - && !(expr->symtree->n.sym->as - && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK) - && (fsym == NULL || fsym->ts.type != BT_ASSUMED)) - { - gfc_conv_subref_array_arg (se, expr, g77, - fsym ? fsym->attr.intent : INTENT_INOUT, - false, fsym, proc_name, sym, true); - return; - } - - ptr = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, desc); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - { - tmp = gfc_conv_expr_present (sym); - ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), - tmp, fold_convert (TREE_TYPE (se->expr), ptr), - fold_convert (TREE_TYPE (se->expr), null_pointer_node)); - } - - ptr = gfc_evaluate_now (ptr, &se->pre); - - /* Use the packed data for the actual argument, except for contiguous arrays, - where the descriptor's data component is set. */ - if (g77) - se->expr = ptr; - else - { - tmp = build_fold_indirect_ref_loc (input_location, desc); - - gfc_ss * ss = gfc_walk_expr (expr); - if (!transposed_dims (ss)) - gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); - else - { - tree old_field, new_field; - - /* The original descriptor has transposed dims so we can't reuse - it directly; we have to create a new one. */ - tree old_desc = tmp; - tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc"); - - old_field = gfc_conv_descriptor_dtype (old_desc); - new_field = gfc_conv_descriptor_dtype (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); - - old_field = gfc_conv_descriptor_offset (old_desc); - new_field = gfc_conv_descriptor_offset (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); - - for (int i = 0; i < expr->rank; i++) - { - old_field = gfc_conv_descriptor_dimension (old_desc, - gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]); - new_field = gfc_conv_descriptor_dimension (new_desc, - gfc_rank_cst[i]); - gfc_add_modify (&se->pre, new_field, old_field); - } - - if (flag_coarray == GFC_FCOARRAY_LIB - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc)) - == GFC_ARRAY_ALLOCATABLE) - { - old_field = gfc_conv_descriptor_token (old_desc); - new_field = gfc_conv_descriptor_token (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); - } - - gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr); - se->expr = gfc_build_addr_expr (NULL_TREE, new_desc); - } - gfc_free_ss (ss); - } - - if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) - { - 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_fold_indirect_ref_loc (input_location, - desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - gfc_conv_expr_present (sym), tmp); - - gfc_trans_runtime_check (false, true, tmp, &se->pre, - &expr->where, msg); - free (msg); - } - - gfc_start_block (&block); - - /* Copy the data back. */ - if (fsym == NULL || fsym->attr.intent != INTENT_IN) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, desc, ptr); - gfc_add_expr_to_block (&block, tmp); - } - - /* Free the temporary. */ - tmp = gfc_call_free (ptr); - gfc_add_expr_to_block (&block, tmp); - - stmt = gfc_finish_block (&block); - - gfc_init_block (&block); - /* Only if it was repacked. This code needs to be executed before the - loop cleanup code. */ - tmp = build_fold_indirect_ref_loc (input_location, - desc); - tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - fold_convert (TREE_TYPE (tmp), ptr), tmp); - - if (fsym && fsym->attr.optional && sym && sym->attr.optional) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - gfc_conv_expr_present (sym), tmp); - - tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &se->post); - - gfc_init_block (&se->post); - - /* Reset the descriptor pointer. */ - if (!g77) - { - tmp = build_fold_indirect_ref_loc (input_location, desc); - gfc_conv_descriptor_data_set (&se->post, tmp, origptr); - } - - gfc_add_block_to_block (&se->post, &block); - } -} - - -/* This helper function calculates the size in words of a full array. */ - -tree -gfc_full_array_size (stmtblock_t *block, tree decl, int rank) -{ - tree idx; - tree nelems; - tree tmp; - idx = gfc_rank_cst[rank - 1]; - nelems = gfc_conv_descriptor_ubound_get (decl, idx); - tmp = gfc_conv_descriptor_lbound_get (decl, idx); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - nelems, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, block); - - nelems = gfc_conv_descriptor_stride_get (decl, idx); - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - nelems, tmp); - return gfc_evaluate_now (tmp, block); -} - - -/* Allocate dest to the same size as src, and copy src -> dest. - If no_malloc is set, only the copy is done. */ - -static tree -duplicate_allocatable (tree dest, tree src, tree type, int rank, - bool no_malloc, bool no_memcpy, tree str_sz, - tree add_when_allocated) -{ - tree tmp; - tree size; - tree nelems; - tree null_cond; - tree null_data; - stmtblock_t block; - - /* If the source is null, set the destination to null. Then, - allocate memory to the destination. */ - gfc_init_block (&block); - - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - { - gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - if (str_sz != NULL_TREE) - size = str_sz; - else - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); - - if (!no_malloc) - { - tmp = gfc_call_malloc (&block, type, size); - gfc_add_modify (&block, dest, fold_convert (type, tmp)); - } - - if (!no_memcpy) - { - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - } - else - { - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - if (rank) - nelems = gfc_full_array_size (&block, src, rank); - else - nelems = gfc_index_one_node; - - if (str_sz != NULL_TREE) - tmp = fold_convert (gfc_array_index_type, str_sz); - else - tmp = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - nelems, tmp); - if (!no_malloc) - { - tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src)); - tmp = gfc_call_malloc (&block, tmp, size); - gfc_conv_descriptor_data_set (&block, dest, tmp); - } - - /* We know the temporary and the value will be the same length, - so can use memcpy. */ - if (!no_memcpy) - { - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, - gfc_conv_descriptor_data_get (dest), - gfc_conv_descriptor_data_get (src), - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - } - - gfc_add_expr_to_block (&block, add_when_allocated); - tmp = gfc_finish_block (&block); - - /* Null the destination if the source is null; otherwise do - the allocate and copy. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) - null_cond = src; - else - null_cond = gfc_conv_descriptor_data_get (src); - - null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - null_cond, null_pointer_node); - return build3_v (COND_EXPR, null_cond, tmp, null_data); -} - - -/* Allocate dest to the same size as src, and copy data src -> dest. */ - -tree -gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank, - tree add_when_allocated) -{ - return duplicate_allocatable (dest, src, type, rank, false, false, - NULL_TREE, add_when_allocated); -} - - -/* Copy data src -> dest. */ - -tree -gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) -{ - return duplicate_allocatable (dest, src, type, rank, true, false, - NULL_TREE, NULL_TREE); -} - -/* Allocate dest to the same size as src, but don't copy anything. */ - -tree -gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) -{ - return duplicate_allocatable (dest, src, type, rank, false, true, - NULL_TREE, NULL_TREE); -} - - -static tree -duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, - tree type, int rank) -{ - tree tmp; - tree size; - tree nelems; - tree null_cond; - tree null_data; - stmtblock_t block, globalblock; - - /* If the source is null, set the destination to null. Then, - allocate memory to the destination. */ - gfc_init_block (&block); - gfc_init_block (&globalblock); - - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - { - gfc_se se; - symbol_attribute attr; - tree dummy_desc; - - gfc_init_se (&se, NULL); - gfc_clear_attr (&attr); - attr.allocatable = 1; - dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr); - gfc_add_block_to_block (&globalblock, &se.pre); - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); - - gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); - gfc_allocate_using_caf_lib (&block, dummy_desc, size, - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - - gfc_allocate_using_caf_lib (&block, dummy_desc, - fold_convert (size_type_node, size), - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC); - - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - else - { - /* Set the rank or unitialized memory access may be reported. */ - tmp = gfc_conv_descriptor_rank (dest); - gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank)); - - if (rank) - nelems = gfc_full_array_size (&block, src, rank); - else - nelems = integer_one_node; - - tmp = fold_convert (size_type_node, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, nelems), tmp); - - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node, - size), - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); - null_data = gfc_finish_block (&block); - - gfc_init_block (&block); - gfc_allocate_using_caf_lib (&block, dest, - fold_convert (size_type_node, size), - gfc_build_addr_expr (NULL_TREE, dest_tok), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC); - - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, - gfc_conv_descriptor_data_get (dest), - gfc_conv_descriptor_data_get (src), - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&block, tmp); - } - - tmp = gfc_finish_block (&block); - - /* Null the destination if the source is null; otherwise do - the register and copy. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) - null_cond = src; - else - null_cond = gfc_conv_descriptor_data_get (src); - - null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - null_cond, null_pointer_node); - gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp, - null_data)); - return gfc_finish_block (&globalblock); -} - - -/* Helper function to abstract whether coarray processing is enabled. */ - -static bool -caf_enabled (int caf_mode) -{ - return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) - == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY; -} - - -/* Helper function to abstract whether coarray processing is enabled - and we are in a derived type coarray. */ - -static bool -caf_in_coarray (int caf_mode) -{ - static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY - | GFC_STRUCTURE_CAF_MODE_IN_COARRAY; - return (caf_mode & pat) == pat; -} - - -/* Helper function to abstract whether coarray is to deallocate only. */ - -bool -gfc_caf_is_dealloc_only (int caf_mode) -{ - return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) - == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY; -} - - -/* Recursively traverse an object of derived type, generating code to - deallocate, nullify or copy allocatable components. This is the work horse - function for the functions named in this enum. */ - -enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, - COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP, - ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY, - BCAST_ALLOC_COMP}; - -static gfc_actual_arglist *pdt_param_list; - -static tree -structure_alloc_comps (gfc_symbol * der_type, tree decl, - tree dest, int rank, int purpose, int caf_mode, - gfc_co_subroutines_args *args) -{ - gfc_component *c; - gfc_loopinfo loop; - stmtblock_t fnblock; - stmtblock_t loopbody; - stmtblock_t tmpblock; - tree decl_type; - tree tmp; - tree comp; - tree dcmp; - tree nelems; - tree index; - tree var; - tree cdecl; - tree ctype; - tree vref, dref; - tree null_cond = NULL_TREE; - tree add_when_allocated; - tree dealloc_fndecl; - tree caf_token; - gfc_symbol *vtab; - int caf_dereg_mode; - symbol_attribute *attr; - bool deallocate_called; - - gfc_init_block (&fnblock); - - decl_type = TREE_TYPE (decl); - - if ((POINTER_TYPE_P (decl_type)) - || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) - { - decl = build_fold_indirect_ref_loc (input_location, decl); - /* Deref dest in sync with decl, but only when it is not NULL. */ - if (dest) - dest = build_fold_indirect_ref_loc (input_location, dest); - - /* Update the decl_type because it got dereferenced. */ - decl_type = TREE_TYPE (decl); - } - - /* If this is an array of derived types with allocatable components - build a loop and recursively call this function. */ - if (TREE_CODE (decl_type) == ARRAY_TYPE - || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) - { - tmp = gfc_conv_array_data (decl); - var = build_fold_indirect_ref_loc (input_location, tmp); - - /* Get the number of elements - 1 and set the counter. */ - if (GFC_DESCRIPTOR_TYPE_P (decl_type)) - { - /* Use the descriptor for an allocatable array. Since this - is a full array reference, we only need the descriptor - information from dimension = rank. */ - tmp = gfc_full_array_size (&fnblock, decl, rank); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); - - null_cond = gfc_conv_descriptor_data_get (decl); - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, null_cond, - build_int_cst (TREE_TYPE (null_cond), 0)); - } - else - { - /* Otherwise use the TYPE_DOMAIN information. */ - tmp = array_type_nelts (decl_type); - tmp = fold_convert (gfc_array_index_type, tmp); - } - - /* Remember that this is, in fact, the no. of elements - 1. */ - nelems = gfc_evaluate_now (tmp, &fnblock); - index = gfc_create_var (gfc_array_index_type, "S"); - - /* Build the body of the loop. */ - gfc_init_block (&loopbody); - - vref = gfc_build_array_ref (var, index, NULL); - - if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) - { - tmp = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (dest)); - dref = gfc_build_array_ref (tmp, index, NULL); - tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP, caf_mode, args); - } - else - tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, - caf_mode, args); - - 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_add_block_to_block (&fnblock, &loop.pre); - - tmp = gfc_finish_block (&fnblock); - /* When copying allocateable components, the above implements the - deep copy. Nevertheless is a deep copy only allowed, when the current - component is allocated, for which code will be generated in - gfc_duplicate_allocatable (), where the deep copy code is just added - into the if's body, by adding tmp (the deep copy code) as last - argument to gfc_duplicate_allocatable (). */ - if (purpose == COPY_ALLOC_COMP - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) - tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank, - tmp); - else if (null_cond != NULL_TREE) - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - - return tmp; - } - - if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type) - { - tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0, args); - gfc_add_expr_to_block (&fnblock, tmp); - } - else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp) - { - tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP, 0, args); - gfc_add_expr_to_block (&fnblock, tmp); - } - - /* Otherwise, act on the components or recursively call self to - act on a chain of components. */ - for (c = der_type->components; c; c = c->next) - { - bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED - || c->ts.type == BT_CLASS) - && c->ts.u.derived->attr.alloc_comp; - bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived) - || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived); - - bool is_pdt_type = c->ts.type == BT_DERIVED - && c->ts.u.derived->attr.pdt_type; - - cdecl = c->backend_decl; - ctype = TREE_TYPE (cdecl); - - switch (purpose) - { - - case BCAST_ALLOC_COMP: - - tree ubound; - tree cdesc; - stmtblock_t derived_type_block; - - gfc_init_block (&tmpblock); - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* Shortcut to get the attributes of the component. */ - if (c->ts.type == BT_CLASS) - { - attr = &CLASS_DATA (c)->attr; - if (attr->class_pointer) - continue; - } - else - { - attr = &c->attr; - if (attr->pointer) - continue; - } - - add_when_allocated = NULL_TREE; - if (cmp_has_alloc_comps - && !c->attr.pointer && !c->attr.proc_pointer) - { - if (c->ts.type == BT_CLASS) - { - rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; - add_when_allocated - = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, - comp, NULL_TREE, rank, purpose, - caf_mode, args); - } - else - { - rank = c->as ? c->as->rank : 0; - add_when_allocated = structure_alloc_comps (c->ts.u.derived, - comp, NULL_TREE, - rank, purpose, - caf_mode, args); - } - } - - gfc_init_block (&derived_type_block); - if (add_when_allocated) - gfc_add_expr_to_block (&derived_type_block, add_when_allocated); - tmp = gfc_finish_block (&derived_type_block); - gfc_add_expr_to_block (&tmpblock, tmp); - - /* Convert the component into a rank 1 descriptor type. */ - if (attr->dimension) - { - tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&tmpblock, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->as->rank - : c->as->rank); - } - else - { - tmp = TREE_TYPE (comp); - ubound = build_int_cst (gfc_array_index_type, 1); - } - - cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, - &ubound, 1, - GFC_ARRAY_ALLOCATABLE, false); - - cdesc = gfc_create_var (cdesc, "cdesc"); - DECL_ARTIFICIAL (cdesc) = 1; - - gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, - gfc_index_zero_node, ubound); - - if (attr->dimension) - comp = gfc_conv_descriptor_data_get (comp); - else - { - gfc_se se; - - gfc_init_se (&se, NULL); - - comp = gfc_conv_scalar_to_descriptor (&se, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->attr - : c->attr); - comp = gfc_build_addr_expr (NULL_TREE, comp); - gfc_add_block_to_block (&tmpblock, &se.pre); - } - - gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); - - tree fndecl; - - fndecl = build_call_expr_loc (input_location, - gfor_fndecl_co_broadcast, 5, - gfc_build_addr_expr (pvoid_type_node,cdesc), - args->image_index, - null_pointer_node, null_pointer_node, - null_pointer_node); - - gfc_add_expr_to_block (&tmpblock, fndecl); - gfc_add_block_to_block (&fnblock, &tmpblock); - - break; - - case DEALLOCATE_ALLOC_COMP: - - gfc_init_block (&tmpblock); - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* Shortcut to get the attributes of the component. */ - if (c->ts.type == BT_CLASS) - { - attr = &CLASS_DATA (c)->attr; - if (attr->class_pointer) - continue; - } - else - { - attr = &c->attr; - if (attr->pointer) - continue; - } - - if ((c->ts.type == BT_DERIVED && !c->attr.pointer) - || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) - /* Call the finalizer, which will free the memory and nullify the - pointer of an array. */ - deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, - caf_enabled (caf_mode)) - && attr->dimension; - else - deallocate_called = false; - - /* Add the _class ref for classes. */ - if (c->ts.type == BT_CLASS && attr->allocatable) - comp = gfc_class_data_get (comp); - - add_when_allocated = NULL_TREE; - if (cmp_has_alloc_comps - && !c->attr.pointer && !c->attr.proc_pointer - && !same_type - && !deallocate_called) - { - /* Add checked deallocation of the components. This code is - obviously added because the finalizer is not trusted to free - all memory. */ - if (c->ts.type == BT_CLASS) - { - rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; - add_when_allocated - = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, - comp, NULL_TREE, rank, purpose, - caf_mode, args); - } - else - { - rank = c->as ? c->as->rank : 0; - add_when_allocated = structure_alloc_comps (c->ts.u.derived, - comp, NULL_TREE, - rank, purpose, - caf_mode, args); - } - } - - if (attr->allocatable && !same_type - && (!attr->codimension || caf_enabled (caf_mode))) - { - /* Handle all types of components besides components of the - same_type as the current one, because those would create an - endless loop. */ - caf_dereg_mode - = (caf_in_coarray (caf_mode) || attr->codimension) - ? (gfc_caf_is_dealloc_only (caf_mode) - ? GFC_CAF_COARRAY_DEALLOCATE_ONLY - : GFC_CAF_COARRAY_DEREGISTER) - : GFC_CAF_COARRAY_NOCOARRAY; - - caf_token = NULL_TREE; - /* Coarray components are handled directly by - deallocate_with_status. */ - if (!attr->codimension - && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY) - { - if (c->caf_token) - caf_token = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (c->caf_token), - decl, c->caf_token, NULL_TREE); - else if (attr->dimension && !attr->proc_pointer) - caf_token = gfc_conv_descriptor_token (comp); - } - if (attr->dimension && !attr->codimension && !attr->proc_pointer) - /* When this is an array but not in conjunction with a coarray - then add the data-ref. For coarray'ed arrays the data-ref - is added by deallocate_with_status. */ - comp = gfc_conv_descriptor_data_get (comp); - - tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, - NULL, caf_dereg_mode, - add_when_allocated, caf_token); - - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (attr->allocatable && !attr->codimension - && !deallocate_called) - { - /* Case of recursive allocatable derived types. */ - tree is_allocated; - tree ubound; - tree cdesc; - stmtblock_t dealloc_block; - - gfc_init_block (&dealloc_block); - if (add_when_allocated) - gfc_add_expr_to_block (&dealloc_block, add_when_allocated); - - /* Convert the component into a rank 1 descriptor type. */ - if (attr->dimension) - { - tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&dealloc_block, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->as->rank - : c->as->rank); - } - else - { - tmp = TREE_TYPE (comp); - ubound = build_int_cst (gfc_array_index_type, 1); - } - - cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, - &ubound, 1, - GFC_ARRAY_ALLOCATABLE, false); - - cdesc = gfc_create_var (cdesc, "cdesc"); - DECL_ARTIFICIAL (cdesc) = 1; - - gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, - gfc_index_zero_node, ubound); - - if (attr->dimension) - comp = gfc_conv_descriptor_data_get (comp); - - gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); - - /* Now call the deallocator. */ - vtab = gfc_find_vtab (&c->ts); - if (vtab->backend_decl == NULL) - gfc_get_symbol_decl (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); - dealloc_fndecl = gfc_vptr_deallocate_get (tmp); - dealloc_fndecl = build_fold_indirect_ref_loc (input_location, - dealloc_fndecl); - tmp = build_int_cst (TREE_TYPE (comp), 0); - is_allocated = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - comp); - cdesc = gfc_build_addr_expr (NULL_TREE, cdesc); - - tmp = build_call_expr_loc (input_location, - dealloc_fndecl, 1, - cdesc); - gfc_add_expr_to_block (&dealloc_block, tmp); - - tmp = gfc_finish_block (&dealloc_block); - - tmp = fold_build3_loc (input_location, COND_EXPR, - void_type_node, is_allocated, tmp, - build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&tmpblock, tmp); - } - else if (add_when_allocated) - gfc_add_expr_to_block (&tmpblock, add_when_allocated); - - if (c->ts.type == BT_CLASS && attr->allocatable - && (!attr->codimension || !caf_enabled (caf_mode))) - { - /* Finally, reset the vptr to the declared type vtable and, if - necessary reset the _len field. - - First recover the reference to the component and obtain - the vptr. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - tmp = gfc_class_vptr_get (comp); - - if (UNLIMITED_POLY (c)) - { - /* Both vptr and _len field should be nulled. */ - gfc_add_modify (&tmpblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - tmp = gfc_class_len_get (comp); - gfc_add_modify (&tmpblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - } - else - { - /* Build the vtable address and set the vptr with it. */ - tree vtab; - gfc_symbol *vtable; - vtable = gfc_find_derived_vtab (c->ts.u.derived); - vtab = vtable->backend_decl; - if (vtab == NULL_TREE) - vtab = gfc_get_symbol_decl (vtable); - vtab = gfc_build_addr_expr (NULL, vtab); - vtab = fold_convert (TREE_TYPE (tmp), vtab); - gfc_add_modify (&tmpblock, tmp, vtab); - } - } - - /* Now add the deallocation of this component. */ - gfc_add_block_to_block (&fnblock, &tmpblock); - break; - - case NULLIFY_ALLOC_COMP: - /* Nullify - - allocatable components (regular or in class) - - components that have allocatable components - - pointer components when in a coarray. - Skip everything else especially proc_pointers, which may come - coupled with the regular pointer attribute. */ - if (c->attr.proc_pointer - || !(c->attr.allocatable || (c->ts.type == BT_CLASS - && CLASS_DATA (c)->attr.allocatable) - || (cmp_has_alloc_comps - && ((c->ts.type == BT_DERIVED && !c->attr.pointer) - || (c->ts.type == BT_CLASS - && !CLASS_DATA (c)->attr.class_pointer))) - || (caf_in_coarray (caf_mode) && c->attr.pointer))) - continue; - - /* Process class components first, because they always have the - pointer-attribute set which would be caught wrong else. */ - if (c->ts.type == BT_CLASS - && (CLASS_DATA (c)->attr.allocatable - || CLASS_DATA (c)->attr.class_pointer)) - { - tree vptr_decl; - - /* Allocatable CLASS components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - vptr_decl = gfc_class_vptr_get (comp); - - comp = gfc_class_data_get (comp); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) - gfc_conv_descriptor_data_set (&fnblock, comp, - null_pointer_node); - else - { - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - gfc_add_expr_to_block (&fnblock, tmp); - } - - /* The dynamic type of a disassociated pointer or unallocated - allocatable variable is its declared type. An unlimited - polymorphic entity has no declared type. */ - if (!UNLIMITED_POLY (c)) - { - vtab = gfc_find_derived_vtab (c->ts.u.derived); - if (!vtab->backend_decl) - gfc_get_symbol_decl (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); - } - else - tmp = build_int_cst (TREE_TYPE (vptr_decl), 0); - - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, vptr_decl, tmp); - gfc_add_expr_to_block (&fnblock, tmp); - - cmp_has_alloc_comps = false; - } - /* Coarrays need the component to be nulled before the api-call - is made. */ - else if (c->attr.pointer || c->attr.allocatable) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->attr.dimension || c->attr.codimension) - gfc_conv_descriptor_data_set (&fnblock, comp, - null_pointer_node); - else - gfc_add_modify (&fnblock, comp, - build_int_cst (TREE_TYPE (comp), 0)); - if (gfc_deferred_strlen (c, &comp)) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (comp), - decl, comp, NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (comp), comp, - build_int_cst (TREE_TYPE (comp), 0)); - gfc_add_expr_to_block (&fnblock, tmp); - } - cmp_has_alloc_comps = false; - } - - if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode)) - { - /* Register a component of a derived type coarray with the - coarray library. Do not register ultimate component - coarrays here. They are treated like regular coarrays and - are either allocated on all images or on none. */ - tree token; - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->attr.dimension) - { - /* Set the dtype, because caf_register needs it. */ - gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp), - gfc_get_dtype (TREE_TYPE (comp))); - tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - token = gfc_conv_descriptor_token (tmp); - } - else - { - gfc_se se; - - gfc_init_se (&se, NULL); - token = fold_build3_loc (input_location, COMPONENT_REF, - pvoid_type_node, decl, c->caf_token, - NULL_TREE); - comp = gfc_conv_scalar_to_descriptor (&se, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->attr - : c->attr); - gfc_add_block_to_block (&fnblock, &se.pre); - } - - gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node, - gfc_build_addr_expr (NULL_TREE, - token), - NULL_TREE, NULL_TREE, NULL_TREE, - GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); - } - - if (cmp_has_alloc_comps) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - rank = c->as ? c->as->rank : 0; - tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose, caf_mode, args); - gfc_add_expr_to_block (&fnblock, tmp); - } - break; - - case REASSIGN_CAF_COMP: - if (caf_enabled (caf_mode) - && (c->attr.codimension - || (c->ts.type == BT_CLASS - && (CLASS_DATA (c)->attr.coarray_comp - || caf_in_coarray (caf_mode))) - || (c->ts.type == BT_DERIVED - && (c->ts.u.derived->attr.coarray_comp - || caf_in_coarray (caf_mode)))) - && !same_type) - { - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - dest, cdecl, NULL_TREE); - - if (c->attr.codimension) - { - if (c->ts.type == BT_CLASS) - { - comp = gfc_class_data_get (comp); - dcmp = gfc_class_data_get (dcmp); - } - gfc_conv_descriptor_data_set (&fnblock, dcmp, - gfc_conv_descriptor_data_get (comp)); - } - else - { - tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, - rank, purpose, caf_mode - | GFC_STRUCTURE_CAF_MODE_IN_COARRAY, - args); - gfc_add_expr_to_block (&fnblock, tmp); - } - } - break; - - case COPY_ALLOC_COMP: - if (c->attr.pointer || c->attr.proc_pointer) - continue; - - /* We need source and destination components. */ - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, - cdecl, NULL_TREE); - dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, - cdecl, NULL_TREE); - dcmp = fold_convert (TREE_TYPE (comp), dcmp); - - if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) - { - tree ftn_tree; - tree size; - tree dst_data; - tree src_data; - tree null_data; - - dst_data = gfc_class_data_get (dcmp); - src_data = gfc_class_data_get (comp); - size = fold_convert (size_type_node, - gfc_class_vtab_size_get (comp)); - - if (CLASS_DATA (c)->attr.dimension) - { - nelems = gfc_conv_descriptor_size (src_data, - CLASS_DATA (c)->as->rank); - size = fold_build2_loc (input_location, MULT_EXPR, - size_type_node, size, - fold_convert (size_type_node, - nelems)); - } - else - nelems = build_int_cst (size_type_node, 1); - - if (CLASS_DATA (c)->attr.dimension - || CLASS_DATA (c)->attr.codimension) - { - src_data = gfc_conv_descriptor_data_get (src_data); - dst_data = gfc_conv_descriptor_data_get (dst_data); - } - - gfc_init_block (&tmpblock); - - gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp), - gfc_class_vptr_get (comp)); - - /* Copy the unlimited '_len' field. If it is greater than zero - (ie. a character(_len)), multiply it by size and use this - for the malloc call. */ - if (UNLIMITED_POLY (c)) - { - gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp), - gfc_class_len_get (comp)); - size = gfc_resize_class_size_with_len (&tmpblock, comp, size); - } - - /* Coarray component have to have the same allocation status and - shape/type-parameter/effective-type on the LHS and RHS of an - intrinsic assignment. Hence, we did not deallocated them - and - do not allocate them here. */ - if (!CLASS_DATA (c)->attr.codimension) - { - ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC); - tmp = build_call_expr_loc (input_location, ftn_tree, 1, size); - gfc_add_modify (&tmpblock, dst_data, - fold_convert (TREE_TYPE (dst_data), tmp)); - } - - tmp = gfc_copy_class_to_class (comp, dcmp, nelems, - UNLIMITED_POLY (c)); - gfc_add_expr_to_block (&tmpblock, tmp); - tmp = gfc_finish_block (&tmpblock); - - gfc_init_block (&tmpblock); - gfc_add_modify (&tmpblock, dst_data, - fold_convert (TREE_TYPE (dst_data), - null_pointer_node)); - null_data = gfc_finish_block (&tmpblock); - - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, src_data, - null_pointer_node); - - gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond, - tmp, null_data)); - continue; - } - - /* To implement guarded deep copy, i.e., deep copy only allocatable - components that are really allocated, the deep copy code has to - be generated first and then added to the if-block in - gfc_duplicate_allocatable (). */ - if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type) - { - rank = c->as ? c->as->rank : 0; - tmp = fold_convert (TREE_TYPE (dcmp), comp); - gfc_add_modify (&fnblock, dcmp, tmp); - add_when_allocated = structure_alloc_comps (c->ts.u.derived, - comp, dcmp, - rank, purpose, - caf_mode, args); - } - else - add_when_allocated = NULL_TREE; - - if (gfc_deferred_strlen (c, &tmp)) - { - tree len, size; - len = tmp; - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (len), - decl, len, NULL_TREE); - len = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (len), - dest, len, NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (len), len, tmp); - gfc_add_expr_to_block (&fnblock, tmp); - size = size_of_string_in_bytes (c->ts.kind, len); - /* This component cannot have allocatable components, - therefore add_when_allocated of duplicate_allocatable () - is always NULL. */ - tmp = duplicate_allocatable (dcmp, comp, ctype, rank, - false, false, size, NULL_TREE); - gfc_add_expr_to_block (&fnblock, tmp); - } - else if (c->attr.pdt_array) - { - tmp = duplicate_allocatable (dcmp, comp, ctype, - c->as ? c->as->rank : 0, - false, false, NULL_TREE, NULL_TREE); - gfc_add_expr_to_block (&fnblock, tmp); - } - else if ((c->attr.allocatable) - && !c->attr.proc_pointer && !same_type - && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension - || caf_in_coarray (caf_mode))) - { - rank = c->as ? c->as->rank : 0; - if (c->attr.codimension) - tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); - else if (flag_coarray == GFC_FCOARRAY_LIB - && caf_in_coarray (caf_mode)) - { - tree dst_tok; - if (c->as) - dst_tok = gfc_conv_descriptor_token (dcmp); - else - { - /* For a scalar allocatable component the caf_token is - the next component. */ - if (!c->caf_token) - c->caf_token = c->next->backend_decl; - dst_tok = fold_build3_loc (input_location, - COMPONENT_REF, - pvoid_type_node, dest, - c->caf_token, - NULL_TREE); - } - tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp, - ctype, rank); - } - else - tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank, - add_when_allocated); - gfc_add_expr_to_block (&fnblock, tmp); - } - else - if (cmp_has_alloc_comps || is_pdt_type) - gfc_add_expr_to_block (&fnblock, add_when_allocated); - - break; - - case ALLOCATE_PDT_COMP: - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - - /* Set the PDT KIND and LEN fields. */ - if (c->attr.pdt_kind || c->attr.pdt_len) - { - gfc_se tse; - gfc_expr *c_expr = NULL; - gfc_actual_arglist *param = pdt_param_list; - gfc_init_se (&tse, NULL); - for (; param; param = param->next) - if (param->name && !strcmp (c->name, param->name)) - c_expr = param->expr; - - if (!c_expr) - c_expr = c->initializer; - - if (c_expr) - { - gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); - gfc_add_modify (&fnblock, comp, tse.expr); - } - } - - if (c->attr.pdt_string) - { - gfc_se tse; - gfc_init_se (&tse, NULL); - tree strlen = NULL_TREE; - gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length); - /* Convert the parameterized string length to its value. The - string length is stored in a hidden field in the same way as - deferred string lengths. */ - gfc_insert_parameter_exprs (e, pdt_param_list); - if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE) - { - gfc_conv_expr_type (&tse, e, - TREE_TYPE (strlen)); - strlen = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (strlen), - decl, strlen, NULL_TREE); - gfc_add_modify (&fnblock, strlen, tse.expr); - c->ts.u.cl->backend_decl = strlen; - } - gfc_free_expr (e); - - /* Scalar parameterized strings can be allocated now. */ - if (!c->as) - { - tmp = fold_convert (gfc_array_index_type, strlen); - tmp = size_of_string_in_bytes (c->ts.kind, tmp); - tmp = gfc_evaluate_now (tmp, &fnblock); - tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp); - gfc_add_modify (&fnblock, comp, tmp); - } - } - - /* Allocate parameterized arrays of parameterized derived types. */ - if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) - && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) - continue; - - if (c->ts.type == BT_CLASS) - comp = gfc_class_data_get (comp); - - if (c->attr.pdt_array) - { - gfc_se tse; - int i; - tree size = gfc_index_one_node; - tree offset = gfc_index_zero_node; - tree lower, upper; - gfc_expr *e; - - /* This chunk takes the expressions for 'lower' and 'upper' - in the arrayspec and substitutes in the expressions for - the parameters from 'pdt_param_list'. The descriptor - fields can then be filled from the values so obtained. */ - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))); - for (i = 0; i < c->as->rank; i++) - { - gfc_init_se (&tse, NULL); - e = gfc_copy_expr (c->as->lower[i]); - gfc_insert_parameter_exprs (e, pdt_param_list); - gfc_conv_expr_type (&tse, e, gfc_array_index_type); - gfc_free_expr (e); - lower = tse.expr; - gfc_conv_descriptor_lbound_set (&fnblock, comp, - gfc_rank_cst[i], - lower); - e = gfc_copy_expr (c->as->upper[i]); - gfc_insert_parameter_exprs (e, pdt_param_list); - gfc_conv_expr_type (&tse, e, gfc_array_index_type); - gfc_free_expr (e); - upper = tse.expr; - gfc_conv_descriptor_ubound_set (&fnblock, comp, - gfc_rank_cst[i], - upper); - gfc_conv_descriptor_stride_set (&fnblock, comp, - gfc_rank_cst[i], - size); - size = gfc_evaluate_now (size, &fnblock); - offset = fold_build2_loc (input_location, - MINUS_EXPR, - gfc_array_index_type, - offset, size); - offset = gfc_evaluate_now (offset, &fnblock); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - upper, lower); - 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 (&fnblock, comp, offset); - if (c->ts.type == BT_CLASS) - { - tmp = gfc_get_vptr_from_expr (comp); - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_vptr_size_get (tmp); - } - else - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype)); - tmp = fold_convert (gfc_array_index_type, tmp); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - size = gfc_evaluate_now (size, &fnblock); - tmp = gfc_call_malloc (&fnblock, NULL, size); - gfc_conv_descriptor_data_set (&fnblock, comp, tmp); - tmp = gfc_conv_descriptor_dtype (comp); - gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype)); - - if (c->initializer && c->initializer->rank) - { - gfc_init_se (&tse, NULL); - e = gfc_copy_expr (c->initializer); - gfc_insert_parameter_exprs (e, pdt_param_list); - gfc_conv_expr_descriptor (&tse, e); - gfc_add_block_to_block (&fnblock, &tse.pre); - gfc_free_expr (e); - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, - gfc_conv_descriptor_data_get (comp), - gfc_conv_descriptor_data_get (tse.expr), - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (&fnblock, tmp); - gfc_add_block_to_block (&fnblock, &tse.post); - } - } - - /* Recurse in to PDT components. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived && c->ts.u.derived->attr.pdt_type - && !(c->attr.pointer || c->attr.allocatable)) - { - bool is_deferred = false; - gfc_actual_arglist *tail = c->param_list; - - for (; tail; tail = tail->next) - if (!tail->expr) - is_deferred = true; - - tail = is_deferred ? pdt_param_list : c->param_list; - tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp, - c->as ? c->as->rank : 0, - tail); - gfc_add_expr_to_block (&fnblock, tmp); - } - - break; - - case DEALLOCATE_PDT_COMP: - /* Deallocate array or parameterized string length components - of parameterized derived types. */ - if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) - && !c->attr.pdt_string - && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) - continue; - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->ts.type == BT_CLASS) - comp = gfc_class_data_get (comp); - - /* Recurse in to PDT components. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived && c->ts.u.derived->attr.pdt_type - && (!c->attr.pointer && !c->attr.allocatable)) - { - tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp, - c->as ? c->as->rank : 0); - gfc_add_expr_to_block (&fnblock, tmp); - } - - if (c->attr.pdt_array) - { - tmp = gfc_conv_descriptor_data_get (comp); - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - tmp = gfc_call_free (tmp); - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); - } - else if (c->attr.pdt_string) - { - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - tmp = gfc_call_free (comp); - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); - gfc_add_modify (&fnblock, comp, tmp); - } - - break; - - case CHECK_PDT_DUMMY: - - comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, - decl, cdecl, NULL_TREE); - if (c->ts.type == BT_CLASS) - comp = gfc_class_data_get (comp); - - /* Recurse in to PDT components. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && c->ts.u.derived && c->ts.u.derived->attr.pdt_type) - { - tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp, - c->as ? c->as->rank : 0, - pdt_param_list); - gfc_add_expr_to_block (&fnblock, tmp); - } - - if (!c->attr.pdt_len) - continue; - else - { - gfc_se tse; - gfc_expr *c_expr = NULL; - gfc_actual_arglist *param = pdt_param_list; - - gfc_init_se (&tse, NULL); - for (; param; param = param->next) - if (!strcmp (c->name, param->name) - && param->spec_type == SPEC_EXPLICIT) - c_expr = param->expr; - - if (c_expr) - { - tree error, cond, cname; - gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - comp, tse.expr); - cname = gfc_build_cstring_const (c->name); - cname = gfc_build_addr_expr (pchar_type_node, cname); - error = gfc_trans_runtime_error (true, NULL, - "The value of the PDT LEN " - "parameter '%s' does not " - "agree with that in the " - "dummy declaration", - cname); - tmp = fold_build3_loc (input_location, COND_EXPR, - void_type_node, cond, error, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - } - } - break; - - default: - gcc_unreachable (); - break; - } - } - - return gfc_finish_block (&fnblock); -} - -/* Recursively traverse an object of derived type, generating code to - nullify allocatable components. */ - -tree -gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, - int caf_mode) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); -} - - -/* Recursively traverse an object of derived type, generating code to - deallocate allocatable components. */ - -tree -gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, - int caf_mode) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); -} - -tree -gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, - tree image_index, tree stat, tree errmsg, - tree errmsg_len) -{ - tree tmp, array; - gfc_se argse; - stmtblock_t block, post_block; - gfc_co_subroutines_args args; - - args.image_index = image_index; - args.stat = stat; - args.errmsg = errmsg; - args.errmsg_len = errmsg_len; - - if (rank == 0) - { - gfc_start_block (&block); - gfc_init_block (&post_block); - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - array = argse.expr; - } - else - { - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, expr); - array = argse.expr; - } - - tmp = structure_alloc_comps (derived, array, NULL_TREE, rank, - BCAST_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args); - return tmp; -} - -/* Recursively traverse an object of derived type, generating code to - deallocate allocatable components. But do not deallocate coarrays. - To be used for intrinsic assignment, which may not change the allocation - status of coarrays. */ - -tree -gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP, 0, NULL); -} - - -tree -gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) -{ - return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL); -} - - -/* Recursively traverse an object of derived type, generating code to - copy it and its allocatable components. */ - -tree -gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, - int caf_mode) -{ - return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, - caf_mode, NULL); -} - - -/* Recursively traverse an object of derived type, generating code to - copy only its allocatable components. */ - -tree -gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) -{ - return structure_alloc_comps (der_type, decl, dest, rank, - COPY_ONLY_ALLOC_COMP, 0, NULL); -} - - -/* Recursively traverse an object of parameterized derived type, generating - code to allocate parameterized components. */ - -tree -gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank, - gfc_actual_arglist *param_list) -{ - tree res; - gfc_actual_arglist *old_param_list = pdt_param_list; - pdt_param_list = param_list; - res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - ALLOCATE_PDT_COMP, 0, NULL); - pdt_param_list = old_param_list; - return res; -} - -/* Recursively traverse an object of parameterized derived type, generating - code to deallocate parameterized components. */ - -tree -gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) -{ - return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0, NULL); -} - - -/* Recursively traverse a dummy of parameterized derived type to check the - values of LEN parameters. */ - -tree -gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank, - gfc_actual_arglist *param_list) -{ - tree res; - gfc_actual_arglist *old_param_list = pdt_param_list; - pdt_param_list = param_list; - res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - CHECK_PDT_DUMMY, 0, NULL); - pdt_param_list = old_param_list; - return res; -} - - -/* Returns the value of LBOUND for an expression. This could be broken out - from gfc_conv_intrinsic_bound but this seemed to be simpler. This is - called by gfc_alloc_allocatable_for_assignment. */ -static tree -get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) -{ - tree lbound; - tree ubound; - tree stride; - tree cond, cond1, cond3, cond4; - tree tmp; - gfc_ref *ref; - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - { - tmp = gfc_rank_cst[dim]; - lbound = gfc_conv_descriptor_lbound_get (desc, tmp); - ubound = gfc_conv_descriptor_ubound_get (desc, tmp); - stride = gfc_conv_descriptor_stride_get (desc, tmp); - cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - ubound, lbound); - cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - stride, gfc_index_zero_node); - cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, cond3, cond1); - cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - stride, gfc_index_zero_node); - if (assumed_size) - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - tmp, build_int_cst (gfc_array_index_type, - expr->rank - 1)); - else - cond = logical_false_node; - - cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond3, cond4); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, cond1); - - return fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - lbound, gfc_index_one_node); - } - - if (expr->expr_type == EXPR_FUNCTION) - { - /* A conversion function, so use the argument. */ - gcc_assert (expr->value.function.isym - && expr->value.function.isym->conversion); - expr = expr->value.function.actual->expr; - } - - if (expr->expr_type == EXPR_VARIABLE) - { - tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl); - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->as - && ref->next - && ref->next->u.ar.type == AR_FULL) - tmp = TREE_TYPE (ref->u.c.component->backend_decl); - } - return GFC_TYPE_ARRAY_LBOUND(tmp, dim); - } - - return gfc_index_one_node; -} - - -/* Returns true if an expression represents an lhs that can be reallocated - on assignment. */ - -bool -gfc_is_reallocatable_lhs (gfc_expr *expr) -{ - gfc_ref * ref; - gfc_symbol *sym; - - if (!expr->ref) - return false; - - sym = expr->symtree->n.sym; - - if (sym->attr.associate_var && !expr->ref) - return false; - - /* An allocatable class variable with no reference. */ - if (sym->ts.type == BT_CLASS - && !sym->attr.associate_var - && CLASS_DATA (sym)->attr.allocatable - && expr->ref - && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL - && expr->ref->next == NULL) - || (expr->ref->type == REF_COMPONENT - && strcmp (expr->ref->u.c.component->name, "_data") == 0 - && (expr->ref->next == NULL - || (expr->ref->next->type == REF_ARRAY - && expr->ref->next->u.ar.type == AR_FULL - && expr->ref->next->next == NULL))))) - return true; - - /* An allocatable variable. */ - if (sym->attr.allocatable - && !sym->attr.associate_var - && expr->ref - && expr->ref->type == REF_ARRAY - && expr->ref->u.ar.type == AR_FULL) - return true; - - /* All that can be left are allocatable components. */ - if ((sym->ts.type != BT_DERIVED - && sym->ts.type != BT_CLASS) - || !sym->ts.u.derived->attr.alloc_comp) - return false; - - /* Find a component ref followed by an array reference. */ - for (ref = expr->ref; ref; ref = ref->next) - if (ref->next - && ref->type == REF_COMPONENT - && ref->next->type == REF_ARRAY - && !ref->next->next) - break; - - if (!ref) - return false; - - /* Return true if valid reallocatable lhs. */ - if (ref->u.c.component->attr.allocatable - && ref->next->u.ar.type == AR_FULL) - return true; - - return false; -} - - -static tree -concat_str_length (gfc_expr* expr) -{ - tree type; - tree len1; - tree len2; - gfc_se se; - - type = gfc_typenode_for_spec (&expr->value.op.op1->ts); - len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - if (len1 == NULL_TREE) - { - if (expr->value.op.op1->expr_type == EXPR_OP) - len1 = concat_str_length (expr->value.op.op1); - else if (expr->value.op.op1->expr_type == EXPR_CONSTANT) - len1 = build_int_cst (gfc_charlen_type_node, - expr->value.op.op1->value.character.length); - else if (expr->value.op.op1->ts.u.cl->length) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length); - len1 = se.expr; - } - else - { - /* Last resort! */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - se.descriptor_only = 1; - gfc_conv_expr (&se, expr->value.op.op1); - len1 = se.string_length; - } - } - - type = gfc_typenode_for_spec (&expr->value.op.op2->ts); - len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - if (len2 == NULL_TREE) - { - if (expr->value.op.op2->expr_type == EXPR_OP) - len2 = concat_str_length (expr->value.op.op2); - else if (expr->value.op.op2->expr_type == EXPR_CONSTANT) - len2 = build_int_cst (gfc_charlen_type_node, - expr->value.op.op2->value.character.length); - else if (expr->value.op.op2->ts.u.cl->length) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length); - len2 = se.expr; - } - else - { - /* Last resort! */ - gfc_init_se (&se, NULL); - se.want_pointer = 1; - se.descriptor_only = 1; - gfc_conv_expr (&se, expr->value.op.op2); - len2 = se.string_length; - } - } - - gcc_assert(len1 && len2); - len1 = fold_convert (gfc_charlen_type_node, len1); - len2 = fold_convert (gfc_charlen_type_node, len2); - - return fold_build2_loc (input_location, PLUS_EXPR, - gfc_charlen_type_node, len1, len2); -} - - -/* Allocate the lhs of an assignment to an allocatable array, otherwise - reallocate it. */ - -tree -gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, - gfc_expr *expr1, - gfc_expr *expr2) -{ - stmtblock_t realloc_block; - stmtblock_t alloc_block; - stmtblock_t fblock; - gfc_ss *rss; - gfc_ss *lss; - gfc_array_info *linfo; - tree realloc_expr; - tree alloc_expr; - tree size1; - tree size2; - tree elemsize1; - tree elemsize2; - tree array1; - tree cond_null; - tree cond; - tree tmp; - tree tmp2; - tree lbound; - tree ubound; - tree desc; - tree old_desc; - tree desc2; - tree offset; - tree jump_label1; - tree jump_label2; - tree neq_size; - tree lbd; - tree class_expr2 = NULL_TREE; - int n; - int dim; - gfc_array_spec * as; - bool coarray = (flag_coarray == GFC_FCOARRAY_LIB - && gfc_caf_attr (expr1, true).codimension); - tree token; - gfc_se caf_se; - - /* x = f(...) with x allocatable. In this case, expr1 is the rhs. - Find the lhs expression in the loop chain and set expr1 and - expr2 accordingly. */ - if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL) - { - expr2 = expr1; - /* Find the ss for the lhs. */ - lss = loop->ss; - for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) - if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE) - break; - if (lss == gfc_ss_terminator) - return NULL_TREE; - expr1 = lss->info->expr; - } - - /* Bail out if this is not a valid allocate on assignment. */ - if (!gfc_is_reallocatable_lhs (expr1) - || (expr2 && !expr2->rank)) - return NULL_TREE; - - /* Find the ss for the lhs. */ - lss = loop->ss; - for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) - if (lss->info->expr == expr1) - break; - - if (lss == gfc_ss_terminator) - return NULL_TREE; - - linfo = &lss->info->data.array; - - /* Find an ss for the rhs. For operator expressions, we see the - ss's for the operands. Any one of these will do. */ - rss = loop->ss; - for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain) - if (rss->info->expr != expr1 && rss != loop->temp_ss) - break; - - if (expr2 && rss == gfc_ss_terminator) - return NULL_TREE; - - /* Ensure that the string length from the current scope is used. */ - if (expr2->ts.type == BT_CHARACTER - && expr2->expr_type == EXPR_FUNCTION - && !expr2->value.function.isym) - expr2->ts.u.cl->backend_decl = rss->info->string_length; - - gfc_start_block (&fblock); - - /* Since the lhs is allocatable, this must be a descriptor type. - Get the data and array size. */ - desc = linfo->descriptor; - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); - array1 = gfc_conv_descriptor_data_get (desc); - - if (expr2) - desc2 = rss->info->data.array.descriptor; - else - desc2 = NULL_TREE; - - /* Get the old lhs element size for deferred character and class expr1. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - if (expr1->ts.u.cl->backend_decl - && VAR_P (expr1->ts.u.cl->backend_decl)) - elemsize1 = expr1->ts.u.cl->backend_decl; - else - elemsize1 = lss->info->string_length; - } - else if (expr1->ts.type == BT_CLASS) - { - /* Unfortunately, the lhs vptr is set too early in many cases. - Play it safe by using the descriptor element length. */ - tmp = gfc_conv_descriptor_elem_len (desc); - elemsize1 = fold_convert (gfc_array_index_type, tmp); - } - else - elemsize1 = NULL_TREE; - if (elemsize1 != NULL_TREE) - elemsize1 = gfc_evaluate_now (elemsize1, &fblock); - - /* Get the new lhs size in bytes. */ - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - if (expr2->ts.deferred) - { - if (expr2->ts.u.cl->backend_decl - && VAR_P (expr2->ts.u.cl->backend_decl)) - tmp = expr2->ts.u.cl->backend_decl; - else - tmp = rss->info->string_length; - } - else - { - tmp = expr2->ts.u.cl->backend_decl; - if (!tmp && expr2->expr_type == EXPR_OP - && expr2->value.op.op == INTRINSIC_CONCAT) - { - tmp = concat_str_length (expr2); - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - else if (!tmp && expr2->ts.u.cl->length) - { - gfc_se tmpse; - gfc_init_se (&tmpse, NULL); - gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, - gfc_charlen_type_node); - tmp = tmpse.expr; - expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); - } - tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); - } - - if (expr1->ts.u.cl->backend_decl - && VAR_P (expr1->ts.u.cl->backend_decl)) - gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); - else - gfc_add_modify (&fblock, lss->info->string_length, tmp); - - if (expr1->ts.kind > 1) - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), - tmp, build_int_cst (TREE_TYPE (tmp), - expr1->ts.kind)); - } - else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) - { - tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, - expr1->ts.u.cl->backend_decl); - } - else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); - else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS) - { - tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE; - if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE) - tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2); - - if (tmp != NULL_TREE) - tmp = gfc_class_vtab_size_get (tmp); - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts)); - } - else - tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); - elemsize2 = fold_convert (gfc_array_index_type, tmp); - elemsize2 = gfc_evaluate_now (elemsize2, &fblock); - - /* 7.4.1.3 "If variable is an allocated allocatable variable, it is - deallocated if expr is an array of different shape or any of the - corresponding length type parameter values of variable and expr - differ." This assures F95 compatibility. */ - jump_label1 = gfc_build_label_decl (NULL_TREE); - jump_label2 = gfc_build_label_decl (NULL_TREE); - - /* Allocate if data is NULL. */ - cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - array1, build_int_cst (TREE_TYPE (array1), 0)); - - if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - tmp = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - lss->info->string_length, - rss->info->string_length); - cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, tmp, cond_null); - cond_null= gfc_evaluate_now (cond_null, &fblock); - } - else - cond_null= gfc_evaluate_now (cond_null, &fblock); - - tmp = build3_v (COND_EXPR, cond_null, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - - /* Get arrayspec if expr is a full array. */ - if (expr2 && expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym - && expr2->value.function.isym->conversion) - { - /* For conversion functions, take the arg. */ - gfc_expr *arg = expr2->value.function.actual->expr; - as = gfc_get_full_arrayspec_from_expr (arg); - } - else if (expr2) - as = gfc_get_full_arrayspec_from_expr (expr2); - else - as = NULL; - - /* If the lhs shape is not the same as the rhs jump to setting the - bounds and doing the reallocation....... */ - for (n = 0; n < expr1->rank; n++) - { - /* Check the shape. */ - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, lbound); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - tmp, ubound); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - tmp, gfc_index_zero_node); - tmp = build3_v (COND_EXPR, cond, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - } - - /* ...else if the element lengths are not the same also go to - setting the bounds and doing the reallocation.... */ - if (elemsize1 != NULL_TREE) - { - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - elemsize1, elemsize2); - tmp = build3_v (COND_EXPR, cond, - build1_v (GOTO_EXPR, jump_label1), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fblock, tmp); - } - - /* ....else jump past the (re)alloc code. */ - tmp = build1_v (GOTO_EXPR, jump_label2); - gfc_add_expr_to_block (&fblock, tmp); - - /* Add the label to start automatic (re)allocation. */ - tmp = build1_v (LABEL_EXPR, jump_label1); - gfc_add_expr_to_block (&fblock, tmp); - - /* If the lhs has not been allocated, its bounds will not have been - initialized and so its size is set to zero. */ - size1 = gfc_create_var (gfc_array_index_type, NULL); - gfc_init_block (&alloc_block); - gfc_add_modify (&alloc_block, size1, gfc_index_zero_node); - gfc_init_block (&realloc_block); - gfc_add_modify (&realloc_block, size1, - gfc_conv_descriptor_size (desc, expr1->rank)); - tmp = build3_v (COND_EXPR, cond_null, - gfc_finish_block (&alloc_block), - gfc_finish_block (&realloc_block)); - gfc_add_expr_to_block (&fblock, tmp); - - /* Get the rhs size and fix it. */ - size2 = gfc_index_one_node; - for (n = 0; n < expr2->rank; n++) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - size2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, size2); - } - size2 = gfc_evaluate_now (size2, &fblock); - - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - size1, size2); - - /* If the lhs is deferred length, assume that the element size - changes and force a reallocation. */ - if (expr1->ts.deferred) - neq_size = gfc_evaluate_now (logical_true_node, &fblock); - else - neq_size = gfc_evaluate_now (cond, &fblock); - - /* Deallocation of allocatable components will have to occur on - reallocation. Fix the old descriptor now. */ - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - old_desc = gfc_evaluate_now (desc, &fblock); - else - old_desc = NULL_TREE; - - /* Now modify the lhs descriptor and the associated scalarizer - variables. F2003 7.4.1.3: "If variable is or becomes an - unallocated allocatable variable, then it is allocated with each - deferred type parameter equal to the corresponding type parameters - of expr , with the shape of expr , and with each lower bound equal - to the corresponding element of LBOUND(expr)." - Reuse size1 to keep a dimension-by-dimension track of the - stride of the new array. */ - size1 = gfc_index_one_node; - offset = gfc_index_zero_node; - - for (n = 0; n < expr2->rank; n++) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - - lbound = gfc_index_one_node; - ubound = tmp; - - if (as) - { - lbd = get_std_lbound (expr2, desc2, n, - as->type == AS_ASSUMED_SIZE); - ubound = fold_build2_loc (input_location, - MINUS_EXPR, - gfc_array_index_type, - ubound, lbound); - ubound = fold_build2_loc (input_location, - PLUS_EXPR, - gfc_array_index_type, - ubound, lbd); - lbound = lbd; - } - - gfc_conv_descriptor_lbound_set (&fblock, desc, - gfc_rank_cst[n], - lbound); - gfc_conv_descriptor_ubound_set (&fblock, desc, - gfc_rank_cst[n], - ubound); - gfc_conv_descriptor_stride_set (&fblock, desc, - gfc_rank_cst[n], - size1); - lbound = gfc_conv_descriptor_lbound_get (desc, - gfc_rank_cst[n]); - tmp2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - lbound, size1); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp2); - size1 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - tmp, size1); - } - - /* Set the lhs descriptor and scalarizer offsets. For rank > 1, - the array offset is saved and the info.offset is used for a - running offset. Use the saved_offset instead. */ - tmp = gfc_conv_descriptor_offset (desc); - gfc_add_modify (&fblock, tmp, offset); - if (linfo->saved_offset - && VAR_P (linfo->saved_offset)) - gfc_add_modify (&fblock, linfo->saved_offset, tmp); - - /* Now set the deltas for the lhs. */ - for (n = 0; n < expr1->rank; n++) - { - tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - dim = lss->dim[n]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, - loop->from[dim]); - if (linfo->delta[dim] && VAR_P (linfo->delta[dim])) - gfc_add_modify (&fblock, linfo->delta[dim], tmp); - } - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - gfc_conv_descriptor_span_set (&fblock, desc, elemsize2); - - size2 = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - elemsize2, size2); - size2 = fold_convert (size_type_node, size2); - size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node, - size2, size_one_node); - size2 = gfc_evaluate_now (size2, &fblock); - - /* For deferred character length, the 'size' field of the dtype might - have changed so set the dtype. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - { - tree type; - tmp = gfc_conv_descriptor_dtype (desc); - if (expr2->ts.u.cl->backend_decl) - type = gfc_typenode_for_spec (&expr2->ts); - else - type = gfc_typenode_for_spec (&expr1->ts); - - gfc_add_modify (&fblock, tmp, - gfc_get_dtype_rank_type (expr1->rank,type)); - } - else if (expr1->ts.type == BT_CLASS) - { - tree type; - tmp = gfc_conv_descriptor_dtype (desc); - - if (expr2->ts.type != BT_CLASS) - type = gfc_typenode_for_spec (&expr2->ts); - else - type = gfc_get_character_type_len (1, elemsize2); - - gfc_add_modify (&fblock, tmp, - gfc_get_dtype_rank_type (expr2->rank,type)); - /* Set the _len field as well... */ - if (UNLIMITED_POLY (expr1)) - { - tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); - if (expr2->ts.type == BT_CHARACTER) - gfc_add_modify (&fblock, tmp, - fold_convert (TREE_TYPE (tmp), - TYPE_SIZE_UNIT (type))); - else - gfc_add_modify (&fblock, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - } - /* ...and the vptr. */ - tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0)); - if (expr2->ts.type == BT_CLASS && !VAR_P (desc2) - && TREE_CODE (desc2) == COMPONENT_REF) - { - tmp2 = gfc_get_class_from_expr (desc2); - tmp2 = gfc_class_vptr_get (tmp2); - } - else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE) - tmp2 = gfc_class_vptr_get (class_expr2); - else - { - tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); - tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); - } - - gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); - } - else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) - { - gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc), - gfc_get_dtype (TREE_TYPE (desc))); - } - - /* Realloc expression. Note that the scalarizer uses desc.data - in the array reference - (*desc.data)[]. */ - gfc_init_block (&realloc_block); - gfc_init_se (&caf_se, NULL); - - if (coarray) - { - token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1); - if (token == NULL_TREE) - { - tmp = gfc_get_tree_for_caf_expr (expr1); - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = build_fold_indirect_ref (tmp); - gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE, - expr1); - token = gfc_build_addr_expr (NULL_TREE, token); - } - - gfc_add_block_to_block (&realloc_block, &caf_se.pre); - } - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc, - expr1->rank); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - if (!coarray) - { - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_REALLOC), 2, - fold_convert (pvoid_type_node, array1), - size2); - gfc_conv_descriptor_data_set (&realloc_block, - desc, tmp); - } - else - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, token, - build_int_cst (integer_type_node, - GFC_CAF_COARRAY_DEALLOCATE_ONLY), - null_pointer_node, null_pointer_node, - integer_zero_node); - gfc_add_expr_to_block (&realloc_block, tmp); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_register, - 7, size2, - build_int_cst (integer_type_node, - GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY), - token, gfc_build_addr_expr (NULL_TREE, desc), - null_pointer_node, null_pointer_node, - integer_zero_node); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, - expr1->rank); - gfc_add_expr_to_block (&realloc_block, tmp); - } - - gfc_add_block_to_block (&realloc_block, &caf_se.post); - realloc_expr = gfc_finish_block (&realloc_block); - - /* Reallocate if sizes or dynamic types are different. */ - if (elemsize1) - { - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - elemsize1, elemsize2); - tmp = gfc_evaluate_now (tmp, &fblock); - neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, neq_size, tmp); - } - tmp = build3_v (COND_EXPR, neq_size, realloc_expr, - build_empty_stmt (input_location)); - - realloc_expr = tmp; - - /* Malloc expression. */ - gfc_init_block (&alloc_block); - if (!coarray) - { - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), - 1, size2); - gfc_conv_descriptor_data_set (&alloc_block, - desc, tmp); - } - else - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_register, - 7, size2, - build_int_cst (integer_type_node, - GFC_CAF_COARRAY_ALLOC), - token, gfc_build_addr_expr (NULL_TREE, desc), - null_pointer_node, null_pointer_node, - integer_zero_node); - gfc_add_expr_to_block (&alloc_block, tmp); - } - - - /* We already set the dtype in the case of deferred character - length arrays and class lvalues. */ - if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) - || coarray)) - && expr1->ts.type != BT_CLASS) - { - tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); - } - - if ((expr1->ts.type == BT_DERIVED) - && expr1->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, - expr1->rank); - gfc_add_expr_to_block (&alloc_block, tmp); - } - alloc_expr = gfc_finish_block (&alloc_block); - - /* Malloc if not allocated; realloc otherwise. */ - tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr); - gfc_add_expr_to_block (&fblock, tmp); - - /* Make sure that the scalarizer data pointer is updated. */ - if (linfo->data && VAR_P (linfo->data)) - { - tmp = gfc_conv_descriptor_data_get (desc); - gfc_add_modify (&fblock, linfo->data, tmp); - } - - /* Add the label for same shape lhs and rhs. */ - tmp = build1_v (LABEL_EXPR, jump_label2); - gfc_add_expr_to_block (&fblock, tmp); - - return gfc_finish_block (&fblock); -} - - -/* NULLIFY an allocatable/pointer array on function entry, free it on exit. - Do likewise, recursively if necessary, with the allocatable components of - derived types. This function is also called for assumed-rank arrays, which - are always dummy arguments. */ - -void -gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) -{ - tree type; - tree tmp; - tree descriptor; - stmtblock_t init; - stmtblock_t cleanup; - locus loc; - int rank; - bool sym_has_alloc_comp, has_finalizer; - - sym_has_alloc_comp = (sym->ts.type == BT_DERIVED - || sym->ts.type == BT_CLASS) - && sym->ts.u.derived->attr.alloc_comp; - has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED - ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; - - /* Make sure the frontend gets these right. */ - gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp - || has_finalizer - || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy)); - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - gfc_init_block (&init); - - gcc_assert (VAR_P (sym->backend_decl) - || TREE_CODE (sym->backend_decl) == PARM_DECL); - - if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - { - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &init); - } - - /* Dummy, use associated and result variables don't need anything special. */ - if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) - { - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - gfc_restore_backend_locus (&loc); - return; - } - - descriptor = sym->backend_decl; - - /* Although static, derived types with default initializers and - allocatable components must not be nulled wholesale; instead they - are treated component by component. */ - if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer) - { - /* SAVEd variables are not freed on exit. */ - gfc_trans_static_array_pointer (sym); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - gfc_restore_backend_locus (&loc); - return; - } - - /* Get the descriptor type. */ - type = TREE_TYPE (sym->backend_decl); - - if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS)) - && !(sym->attr.pointer || sym->attr.allocatable)) - { - if (!sym->attr.save - && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) - { - if (sym->value == NULL - || !gfc_has_default_initializer (sym->ts.u.derived)) - { - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, - descriptor, rank); - gfc_add_expr_to_block (&init, tmp); - } - else - gfc_init_default_dt (sym, &init, false); - } - } - else if (!GFC_DESCRIPTOR_TYPE_P (type)) - { - /* If the backend_decl is not a descriptor, we must have a pointer - to one. */ - descriptor = build_fold_indirect_ref_loc (input_location, - sym->backend_decl); - type = TREE_TYPE (descriptor); - } - - /* NULLIFY the data pointer, for non-saved allocatables. */ - if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable) - { - gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); - if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) - { - /* Declare the variable static so its array descriptor stays present - after leaving the scope. It may still be accessed through another - image. This may happen, for example, with the caf_mpi - implementation. */ - TREE_STATIC (descriptor) = 1; - tmp = gfc_conv_descriptor_token (descriptor); - gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - } - } - - /* Set initial TKR for pointers and allocatables */ - if (GFC_DESCRIPTOR_TYPE_P (type) - && (sym->attr.pointer || sym->attr.allocatable)) - { - tree etype; - - gcc_assert (sym->as && sym->as->rank>=0); - tmp = gfc_conv_descriptor_dtype (descriptor); - etype = gfc_get_element_type (type); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (tmp), tmp, - gfc_get_dtype_rank_type (sym->as->rank, etype)); - gfc_add_expr_to_block (&init, tmp); - } - gfc_restore_backend_locus (&loc); - gfc_init_block (&cleanup); - - /* Allocatable arrays need to be freed when they go out of scope. - The allocatable components of pointers must not be touched. */ - if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS - && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save - && !sym->ns->proc_name->attr.is_main_program) - { - gfc_expr *e; - sym->attr.referenced = 1; - e = gfc_lval_expr_from_sym (sym); - gfc_add_finalizer_call (&cleanup, e); - gfc_free_expr (e); - } - else if ((!sym->attr.allocatable || !has_finalizer) - && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) - && !sym->attr.pointer && !sym->attr.save - && !sym->ns->proc_name->attr.is_main_program) - { - int rank; - rank = sym->as ? sym->as->rank : 0; - tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&cleanup, tmp); - } - - if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) - && !sym->attr.save && !sym->attr.result - && !sym->ns->proc_name->attr.is_main_program) - { - gfc_expr *e; - e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL; - tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, e, - sym->attr.codimension - ? GFC_CAF_COARRAY_DEREGISTER - : GFC_CAF_COARRAY_NOCOARRAY); - if (e) - gfc_free_expr (e); - gfc_add_expr_to_block (&cleanup, tmp); - } - - gfc_add_init_cleanup (block, gfc_finish_block (&init), - gfc_finish_block (&cleanup)); -} - -/************ Expression Walking Functions ******************/ - -/* Walk a variable reference. - - Possible extension - multiple component subscripts. - x(:,:) = foo%a(:)%b(:) - Transforms to - forall (i=..., j=...) - x(i,j) = foo%a(j)%b(i) - end forall - This adds a fair amount of complexity because you need to deal with more - than one ref. Maybe handle in a similar manner to vector subscripts. - Maybe not worth the effort. */ - - -static gfc_ss * -gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ref *ref; - - gfc_fix_class_refs (expr); - - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) - break; - - return gfc_walk_array_ref (ss, expr, ref); -} - - -gfc_ss * -gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) -{ - gfc_array_ref *ar; - gfc_ss *newss; - int n; - - for (; ref; ref = ref->next) - { - if (ref->type == REF_SUBSTRING) - { - ss = gfc_get_scalar_ss (ss, ref->u.ss.start); - if (ref->u.ss.end) - ss = gfc_get_scalar_ss (ss, ref->u.ss.end); - } - - /* We're only interested in array sections from now on. */ - if (ref->type != REF_ARRAY) - continue; - - ar = &ref->u.ar; - - switch (ar->type) - { - case AR_ELEMENT: - for (n = ar->dimen - 1; n >= 0; n--) - ss = gfc_get_scalar_ss (ss, ar->start[n]); - break; - - case AR_FULL: - newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); - newss->info->data.array.ref = ref; - - /* Make sure array is the same as array(:,:), this way - we don't need to special case all the time. */ - ar->dimen = ar->as->rank; - for (n = 0; n < ar->dimen; n++) - { - ar->dimen_type[n] = DIMEN_RANGE; - - gcc_assert (ar->start[n] == NULL); - gcc_assert (ar->end[n] == NULL); - gcc_assert (ar->stride[n] == NULL); - } - ss = newss; - break; - - case AR_SECTION: - newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); - newss->info->data.array.ref = ref; - - /* We add SS chains for all the subscripts in the section. */ - for (n = 0; n < ar->dimen; n++) - { - gfc_ss *indexss; - - switch (ar->dimen_type[n]) - { - case DIMEN_ELEMENT: - /* Add SS for elemental (scalar) subscripts. */ - gcc_assert (ar->start[n]); - indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]); - indexss->loop_chain = gfc_ss_terminator; - newss->info->data.array.subscript[n] = indexss; - break; - - case DIMEN_RANGE: - /* We don't add anything for sections, just remember this - dimension for later. */ - newss->dim[newss->dimen] = n; - newss->dimen++; - break; - - case DIMEN_VECTOR: - /* Create a GFC_SS_VECTOR index in which we can store - the vector's descriptor. */ - indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n], - 1, GFC_SS_VECTOR); - indexss->loop_chain = gfc_ss_terminator; - newss->info->data.array.subscript[n] = indexss; - newss->dim[newss->dimen] = n; - newss->dimen++; - break; - - default: - /* We should know what sort of section it is by now. */ - gcc_unreachable (); - } - } - /* We should have at least one non-elemental dimension, - unless we are creating a descriptor for a (scalar) coarray. */ - gcc_assert (newss->dimen > 0 - || newss->info->data.array.ref->u.ar.as->corank > 0); - ss = newss; - break; - - default: - /* We should know what sort of section it is by now. */ - gcc_unreachable (); - } - - } - return ss; -} - - -/* Walk an expression operator. If only one operand of a binary expression is - scalar, we must also add the scalar term to the SS chain. */ - -static gfc_ss * -gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ss *head; - gfc_ss *head2; - - head = gfc_walk_subexpr (ss, expr->value.op.op1); - if (expr->value.op.op2 == NULL) - head2 = head; - else - head2 = gfc_walk_subexpr (head, expr->value.op.op2); - - /* All operands are scalar. Pass back and let the caller deal with it. */ - if (head2 == ss) - return head2; - - /* All operands require scalarization. */ - if (head != ss && (expr->value.op.op2 == NULL || head2 != head)) - return head2; - - /* One of the operands needs scalarization, the other is scalar. - Create a gfc_ss for the scalar expression. */ - if (head == ss) - { - /* First operand is scalar. We build the chain in reverse order, so - add the scalar SS after the second operand. */ - head = head2; - while (head && head->next != ss) - head = head->next; - /* Check we haven't somehow broken the chain. */ - gcc_assert (head); - head->next = gfc_get_scalar_ss (ss, expr->value.op.op1); - } - else /* head2 == head */ - { - gcc_assert (head2 == head); - /* Second operand is scalar. */ - head2 = gfc_get_scalar_ss (head2, expr->value.op.op2); - } - - return head2; -} - - -/* Reverse a SS chain. */ - -gfc_ss * -gfc_reverse_ss (gfc_ss * ss) -{ - gfc_ss *next; - gfc_ss *head; - - gcc_assert (ss != NULL); - - head = gfc_ss_terminator; - while (ss != gfc_ss_terminator) - { - next = ss->next; - /* Check we didn't somehow break the chain. */ - gcc_assert (next != NULL); - ss->next = head; - head = ss; - ss = next; - } - - return (head); -} - - -/* Given an expression referring to a procedure, return the symbol of its - interface. We can't get the procedure symbol directly as we have to handle - the case of (deferred) type-bound procedures. */ - -gfc_symbol * -gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) -{ - gfc_symbol *sym; - gfc_ref *ref; - - if (procedure_ref == NULL) - return NULL; - - /* Normal procedure case. */ - if (procedure_ref->expr_type == EXPR_FUNCTION - && procedure_ref->value.function.esym) - sym = procedure_ref->value.function.esym; - else - sym = procedure_ref->symtree->n.sym; - - /* Typebound procedure case. */ - for (ref = procedure_ref->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT - && ref->u.c.component->attr.proc_pointer) - sym = ref->u.c.component->ts.interface; - else - sym = NULL; - } - - return sym; -} - - -/* Given an expression referring to an intrinsic function call, - return the intrinsic symbol. */ - -gfc_intrinsic_sym * -gfc_get_intrinsic_for_expr (gfc_expr *call) -{ - if (call == NULL) - return NULL; - - /* Normal procedure case. */ - if (call->expr_type == EXPR_FUNCTION) - return call->value.function.isym; - else - return NULL; -} - - -/* Indicates whether an argument to an intrinsic function should be used in - scalarization. It is usually the case, except for some intrinsics - requiring the value to be constant, and using the value at compile time only. - As the value is not used at runtime in those cases, we don’t produce code - for it, and it should not be visible to the scalarizer. - FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual - argument being examined in that call, and ARG_NUM the index number - of ACTUAL_ARG in the list of arguments. - The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is - identified using the name in ACTUAL_ARG if it is present (that is: if it’s - a keyword argument), otherwise using ARG_NUM. */ - -static bool -arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, - gfc_dummy_arg *dummy_arg) -{ - if (function != NULL && dummy_arg != NULL) - { - switch (function->id) - { - case GFC_ISYM_INDEX: - case GFC_ISYM_LEN_TRIM: - case GFC_ISYM_MASKL: - case GFC_ISYM_MASKR: - case GFC_ISYM_SCAN: - case GFC_ISYM_VERIFY: - if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0) - return false; - /* Fallthrough. */ - - default: - break; - } - } - - return true; -} - - -/* Walk the arguments of an elemental function. - PROC_EXPR is used to check whether an argument is permitted to be absent. If - it is NULL, we don't do the check and the argument is assumed to be present. -*/ - -gfc_ss * -gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, - gfc_intrinsic_sym *intrinsic_sym, - gfc_ss_type type) -{ - int scalar; - gfc_ss *head; - gfc_ss *tail; - gfc_ss *newss; - - head = gfc_ss_terminator; - tail = NULL; - - scalar = 1; - for (; arg; arg = arg->next) - { - gfc_dummy_arg * const dummy_arg = arg->associated_dummy; - if (!arg->expr - || arg->expr->expr_type == EXPR_NULL - || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg)) - continue; - - newss = gfc_walk_subexpr (head, arg->expr); - if (newss == head) - { - /* Scalar argument. */ - gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); - newss = gfc_get_scalar_ss (head, arg->expr); - newss->info->type = type; - if (dummy_arg) - newss->info->data.scalar.dummy_arg = dummy_arg; - } - else - scalar = 0; - - if (dummy_arg != NULL - && gfc_dummy_arg_is_optional (*dummy_arg) - && arg->expr->expr_type == EXPR_VARIABLE - && (gfc_expr_attr (arg->expr).optional - || gfc_expr_attr (arg->expr).allocatable - || gfc_expr_attr (arg->expr).pointer)) - newss->info->can_be_null_ref = true; - - head = newss; - if (!tail) - { - tail = head; - while (tail->next != gfc_ss_terminator) - tail = tail->next; - } - } - - if (scalar) - { - /* If all the arguments are scalar we don't need the argument SS. */ - gfc_free_ss_chain (head); - /* Pass it back. */ - return ss; - } - - /* Add it onto the existing chain. */ - tail->next = ss; - return head; -} - - -/* Walk a function call. Scalar functions are passed back, and taken out of - scalarization loops. For elemental functions we walk their arguments. - The result of functions returning arrays is stored in a temporary outside - the loop, so that the function is only called once. Hence we do not need - to walk their arguments. */ - -static gfc_ss * -gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_intrinsic_sym *isym; - gfc_symbol *sym; - gfc_component *comp = NULL; - - isym = expr->value.function.isym; - - /* Handle intrinsic functions separately. */ - if (isym) - return gfc_walk_intrinsic_function (ss, expr, isym); - - sym = expr->value.function.esym; - if (!sym) - sym = expr->symtree->n.sym; - - if (gfc_is_class_array_function (expr)) - return gfc_get_array_ss (ss, expr, - CLASS_DATA (expr->value.function.esym->result)->as->rank, - GFC_SS_FUNCTION); - - /* A function that returns arrays. */ - comp = gfc_get_proc_ptr_comp (expr); - if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) - || (comp && comp->attr.dimension)) - return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); - - /* Walk the parameters of an elemental function. For now we always pass - by reference. */ - if (sym->attr.elemental || (comp && comp->attr.elemental)) - { - gfc_ss *old_ss = ss; - - ss = gfc_walk_elemental_function_args (old_ss, - expr->value.function.actual, - gfc_get_intrinsic_for_expr (expr), - GFC_SS_REFERENCE); - if (ss != old_ss - && (comp - || sym->attr.proc_pointer - || sym->attr.if_source != IFSRC_DECL - || sym->attr.array_outer_dependency)) - ss->info->array_outer_dependency = 1; - } - - /* Scalar functions are OK as these are evaluated outside the scalarization - loop. Pass back and let the caller deal with it. */ - return ss; -} - - -/* An array temporary is constructed for array constructors. */ - -static gfc_ss * -gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) -{ - return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR); -} - - -/* Walk an expression. Add walked expressions to the head of the SS chain. - A wholly scalar expression will not be added. */ - -gfc_ss * -gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) -{ - gfc_ss *head; - - switch (expr->expr_type) - { - case EXPR_VARIABLE: - head = gfc_walk_variable_expr (ss, expr); - return head; - - case EXPR_OP: - head = gfc_walk_op_expr (ss, expr); - return head; - - case EXPR_FUNCTION: - head = gfc_walk_function_expr (ss, expr); - return head; - - case EXPR_CONSTANT: - case EXPR_NULL: - case EXPR_STRUCTURE: - /* Pass back and let the caller deal with it. */ - break; - - case EXPR_ARRAY: - head = gfc_walk_array_constructor (ss, expr); - return head; - - case EXPR_SUBSTRING: - /* Pass back and let the caller deal with it. */ - break; - - default: - gfc_internal_error ("bad expression type during walk (%d)", - expr->expr_type); - } - return ss; -} - - -/* Entry point for expression walking. - A return value equal to the passed chain means this is - a scalar expression. It is up to the caller to take whatever action is - necessary to translate these. */ - -gfc_ss * -gfc_walk_expr (gfc_expr * expr) -{ - gfc_ss *res; - - res = gfc_walk_subexpr (gfc_ss_terminator, expr); - return gfc_reverse_ss (res); -} diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc new file mode 100644 index 0000000..a77f331 --- /dev/null +++ b/gcc/fortran/trans-array.cc @@ -0,0 +1,11714 @@ +/* Array translation routines + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + and Steven Bosscher + +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 +. */ + +/* trans-array.c-- Various array related code, including scalarization, + allocation, initialization and other support routines. */ + +/* How the scalarizer works. + In gfortran, array expressions use the same core routines as scalar + expressions. + First, a Scalarization State (SS) chain is built. This is done by walking + the expression tree, and building a linear list of the terms in the + expression. As the tree is walked, scalar subexpressions are translated. + + The scalarization parameters are stored in a gfc_loopinfo structure. + First the start and stride of each term is calculated by + gfc_conv_ss_startstride. During this process the expressions for the array + descriptors and data pointers are also translated. + + If the expression is an assignment, we must then resolve any dependencies. + In Fortran all the rhs values of an assignment must be evaluated before + any assignments take place. This can require a temporary array to store the + values. We also require a temporary when we are passing array expressions + or vector subscripts as procedure parameters. + + Array sections are passed without copying to a temporary. These use the + scalarizer to determine the shape of the section. The flag + loop->array_parameter tells the scalarizer that the actual values and loop + variables will not be required. + + The function gfc_conv_loop_setup generates the scalarization setup code. + It determines the range of the scalarizing loop variables. If a temporary + is required, this is created and initialized. Code for scalar expressions + taken outside the loop is also generated at this time. Next the offset and + scaling required to translate from loop variables to array indices for each + term is calculated. + + A call to gfc_start_scalarized_body marks the start of the scalarized + expression. This creates a scope and declares the loop variables. Before + calling this gfc_make_ss_chain_used must be used to indicate which terms + will be used inside this loop. + + The scalar gfc_conv_* functions are then used to build the main body of the + scalarization loop. Scalarization loop variables and precalculated scalar + values are automatically substituted. Note that gfc_advance_se_ss_chain + must be used, rather than changing the se->ss directly. + + For assignment expressions requiring a temporary two sub loops are + generated. The first stores the result of the expression in the temporary, + the second copies it to the result. A call to + gfc_trans_scalarized_loop_boundary marks the end of the main loop code and + the start of the copying loop. The temporary may be less than full rank. + + Finally gfc_trans_scalarizing_loops is called to generate the implicit do + loops. The loops are added to the pre chain of the loopinfo. The post + chain may still contain cleanup code. + + After the loop code has been added into its parent scope gfc_cleanup_loop + is called to free all the SS allocated by the scalarizer. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "gimple-expr.h" +#include "trans.h" +#include "fold-const.h" +#include "constructor.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +#include "dependency.h" + +static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); + +/* The contents of this structure aren't actually used, just the address. */ +static gfc_ss gfc_ss_terminator_var; +gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; + + +static tree +gfc_array_dataptr_type (tree desc) +{ + return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))); +} + +/* Build expressions to access members of the CFI descriptor. */ +#define CFI_FIELD_BASE_ADDR 0 +#define CFI_FIELD_ELEM_LEN 1 +#define CFI_FIELD_VERSION 2 +#define CFI_FIELD_RANK 3 +#define CFI_FIELD_ATTRIBUTE 4 +#define CFI_FIELD_TYPE 5 +#define CFI_FIELD_DIM 6 + +#define CFI_DIM_FIELD_LOWER_BOUND 0 +#define CFI_DIM_FIELD_EXTENT 1 +#define CFI_DIM_FIELD_SM 2 + +static tree +gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx) +{ + tree type = TREE_TYPE (desc); + gcc_assert (TREE_CODE (type) == RECORD_TYPE + && TYPE_FIELDS (type) + && (strcmp ("base_addr", + IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type)))) + == 0)); + tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx); + gcc_assert (field != NULL_TREE); + + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + +tree +gfc_get_cfi_desc_base_addr (tree desc) +{ + return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR); +} + +tree +gfc_get_cfi_desc_elem_len (tree desc) +{ + return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN); +} + +tree +gfc_get_cfi_desc_version (tree desc) +{ + return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION); +} + +tree +gfc_get_cfi_desc_rank (tree desc) +{ + return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK); +} + +tree +gfc_get_cfi_desc_type (tree desc) +{ + return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE); +} + +tree +gfc_get_cfi_desc_attribute (tree desc) +{ + return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE); +} + +static tree +gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx) +{ + tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM); + tmp = gfc_build_array_ref (tmp, idx, NULL); + tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); + gcc_assert (field != NULL_TREE); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + tmp, field, NULL_TREE); +} + +tree +gfc_get_cfi_dim_lbound (tree desc, tree idx) +{ + return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND); +} + +tree +gfc_get_cfi_dim_extent (tree desc, tree idx) +{ + return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT); +} + +tree +gfc_get_cfi_dim_sm (tree desc, tree idx) +{ + return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM); +} + +#undef CFI_FIELD_BASE_ADDR +#undef CFI_FIELD_ELEM_LEN +#undef CFI_FIELD_VERSION +#undef CFI_FIELD_RANK +#undef CFI_FIELD_ATTRIBUTE +#undef CFI_FIELD_TYPE +#undef CFI_FIELD_DIM + +#undef CFI_DIM_FIELD_LOWER_BOUND +#undef CFI_DIM_FIELD_EXTENT +#undef CFI_DIM_FIELD_SM + +/* Build expressions to access the members of an array descriptor. + It's surprisingly easy to mess up here, so never access + an array descriptor by "brute force", always use these + functions. This also avoids problems if we change the format + of an array descriptor. + + To understand these magic numbers, look at the comments + before gfc_build_array_type() in trans-types.c. + + The code within these defines should be the only code which knows the format + of an array descriptor. + + Any code just needing to read obtain the bounds of an array should use + gfc_conv_array_* rather than the following functions as these will return + know constant values, and work with arrays which do not have descriptors. + + Don't forget to #undef these! */ + +#define DATA_FIELD 0 +#define OFFSET_FIELD 1 +#define DTYPE_FIELD 2 +#define SPAN_FIELD 3 +#define DIMENSION_FIELD 4 +#define CAF_TOKEN_FIELD 5 + +#define STRIDE_SUBFIELD 0 +#define LBOUND_SUBFIELD 1 +#define UBOUND_SUBFIELD 2 + +static tree +gfc_get_descriptor_field (tree desc, unsigned field_idx) +{ + tree type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx); + gcc_assert (field != NULL_TREE); + + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + +/* This provides READ-ONLY access to the data field. The field itself + doesn't have the proper type. */ + +tree +gfc_conv_descriptor_data_get (tree desc) +{ + tree type = TREE_TYPE (desc); + if (TREE_CODE (type) == REFERENCE_TYPE) + gcc_unreachable (); + + tree field = gfc_get_descriptor_field (desc, DATA_FIELD); + return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field); +} + +/* This provides WRITE access to the data field. + + TUPLES_P is true if we are generating tuples. + + This function gets called through the following macros: + gfc_conv_descriptor_data_set + gfc_conv_descriptor_data_set. */ + +void +gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) +{ + tree field = gfc_get_descriptor_field (desc, DATA_FIELD); + gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value)); +} + + +/* This provides address access to the data field. This should only be + used by array allocation, passing this on to the runtime. */ + +tree +gfc_conv_descriptor_data_addr (tree desc) +{ + tree field = gfc_get_descriptor_field (desc, DATA_FIELD); + return gfc_build_addr_expr (NULL_TREE, field); +} + +static tree +gfc_conv_descriptor_offset (tree desc) +{ + tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD); + gcc_assert (TREE_TYPE (field) == gfc_array_index_type); + return field; +} + +tree +gfc_conv_descriptor_offset_get (tree desc) +{ + return gfc_conv_descriptor_offset (desc); +} + +void +gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, + tree value) +{ + tree t = gfc_conv_descriptor_offset (desc); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + + +tree +gfc_conv_descriptor_dtype (tree desc) +{ + tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD); + gcc_assert (TREE_TYPE (field) == get_dtype_type_node ()); + return field; +} + +static tree +gfc_conv_descriptor_span (tree desc) +{ + tree field = gfc_get_descriptor_field (desc, SPAN_FIELD); + gcc_assert (TREE_TYPE (field) == gfc_array_index_type); + return field; +} + +tree +gfc_conv_descriptor_span_get (tree desc) +{ + return gfc_conv_descriptor_span (desc); +} + +void +gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, + tree value) +{ + tree t = gfc_conv_descriptor_span (desc); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + + +tree +gfc_conv_descriptor_rank (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK); + gcc_assert (tmp != NULL_TREE + && TREE_TYPE (tmp) == signed_char_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + + +/* Return the element length from the descriptor dtype field. */ + +tree +gfc_conv_descriptor_elem_len (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), + GFC_DTYPE_ELEM_LEN); + gcc_assert (tmp != NULL_TREE + && TREE_TYPE (tmp) == size_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + + +tree +gfc_conv_descriptor_attribute (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), + GFC_DTYPE_ATTRIBUTE); + gcc_assert (tmp!= NULL_TREE + && TREE_TYPE (tmp) == short_integer_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + +tree +gfc_conv_descriptor_type (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE); + gcc_assert (tmp!= NULL_TREE + && TREE_TYPE (tmp) == signed_char_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + +tree +gfc_get_descriptor_dimension (tree desc) +{ + tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD); + gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); + return field; +} + + +static tree +gfc_conv_descriptor_dimension (tree desc, tree dim) +{ + tree tmp; + + tmp = gfc_get_descriptor_dimension (desc); + + return gfc_build_array_ref (tmp, dim, NULL); +} + + +tree +gfc_conv_descriptor_token (tree desc) +{ + gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); + tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD); + /* Should be a restricted pointer - except in the finalization wrapper. */ + gcc_assert (TREE_TYPE (field) == prvoid_type_node + || TREE_TYPE (field) == pvoid_type_node); + return field; +} + +static tree +gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx) +{ + tree tmp = gfc_conv_descriptor_dimension (desc, dim); + tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); + gcc_assert (field != NULL_TREE); + + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + tmp, field, NULL_TREE); +} + +static tree +gfc_conv_descriptor_stride (tree desc, tree dim) +{ + tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD); + gcc_assert (TREE_TYPE (field) == gfc_array_index_type); + return field; +} + +tree +gfc_conv_descriptor_stride_get (tree desc, tree dim) +{ + tree type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + if (integer_zerop (dim) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) + return gfc_index_one_node; + + return gfc_conv_descriptor_stride (desc, dim); +} + +void +gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, + tree dim, tree value) +{ + tree t = gfc_conv_descriptor_stride (desc, dim); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + +static tree +gfc_conv_descriptor_lbound (tree desc, tree dim) +{ + tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD); + gcc_assert (TREE_TYPE (field) == gfc_array_index_type); + return field; +} + +tree +gfc_conv_descriptor_lbound_get (tree desc, tree dim) +{ + return gfc_conv_descriptor_lbound (desc, dim); +} + +void +gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, + tree dim, tree value) +{ + tree t = gfc_conv_descriptor_lbound (desc, dim); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + +static tree +gfc_conv_descriptor_ubound (tree desc, tree dim) +{ + tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD); + gcc_assert (TREE_TYPE (field) == gfc_array_index_type); + return field; +} + +tree +gfc_conv_descriptor_ubound_get (tree desc, tree dim) +{ + return gfc_conv_descriptor_ubound (desc, dim); +} + +void +gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, + tree dim, tree value) +{ + tree t = gfc_conv_descriptor_ubound (desc, dim); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + +/* Build a null array descriptor constructor. */ + +tree +gfc_build_null_descriptor (tree type) +{ + tree field; + tree tmp; + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + gcc_assert (DATA_FIELD == 0); + field = TYPE_FIELDS (type); + + /* Set a NULL data pointer. */ + tmp = build_constructor_single (type, field, null_pointer_node); + TREE_CONSTANT (tmp) = 1; + /* All other fields are ignored. */ + + return tmp; +} + + +/* Modify a descriptor such that the lbound of a given dimension is the value + specified. This also updates ubound and offset accordingly. */ + +void +gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, + int dim, tree new_lbound) +{ + tree offs, ubound, lbound, stride; + tree diff, offs_diff; + + new_lbound = fold_convert (gfc_array_index_type, new_lbound); + + offs = gfc_conv_descriptor_offset_get (desc); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); + stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]); + + /* Get difference (new - old) by which to shift stuff. */ + diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + new_lbound, lbound); + + /* Shift ubound and offset accordingly. This has to be done before + updating the lbound, as they depend on the lbound expression! */ + ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + ubound, diff); + gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); + offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + diff, stride); + offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + offs, offs_diff); + gfc_conv_descriptor_offset_set (block, desc, offs); + + /* Finally set lbound to value we want. */ + gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound); +} + + +/* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */ + +void +gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off, + tree *dtype_off, tree *span_off, + tree *dim_off, tree *dim_size, + tree *stride_suboff, tree *lower_suboff, + tree *upper_suboff) +{ + tree field; + tree type; + + type = TYPE_MAIN_VARIANT (desc_type); + field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD); + *data_off = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); + *dtype_off = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); + *span_off = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); + *dim_off = byte_position (field); + type = TREE_TYPE (TREE_TYPE (field)); + *dim_size = TYPE_SIZE_UNIT (type); + field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD); + *stride_suboff = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD); + *lower_suboff = byte_position (field); + field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD); + *upper_suboff = byte_position (field); +} + + +/* Cleanup those #defines. */ + +#undef DATA_FIELD +#undef OFFSET_FIELD +#undef DTYPE_FIELD +#undef SPAN_FIELD +#undef DIMENSION_FIELD +#undef CAF_TOKEN_FIELD +#undef STRIDE_SUBFIELD +#undef LBOUND_SUBFIELD +#undef UBOUND_SUBFIELD + + +/* Mark a SS chain as used. Flags specifies in which loops the SS is used. + flags & 1 = Main loop body. + flags & 2 = temp copy loop. */ + +void +gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) +{ + for (; ss != gfc_ss_terminator; ss = ss->next) + ss->info->useflags = flags; +} + + +/* Free a gfc_ss chain. */ + +void +gfc_free_ss_chain (gfc_ss * ss) +{ + gfc_ss *next; + + while (ss != gfc_ss_terminator) + { + gcc_assert (ss != NULL); + next = ss->next; + gfc_free_ss (ss); + ss = next; + } +} + + +static void +free_ss_info (gfc_ss_info *ss_info) +{ + int n; + + ss_info->refcount--; + if (ss_info->refcount > 0) + return; + + gcc_assert (ss_info->refcount == 0); + + switch (ss_info->type) + { + case GFC_SS_SECTION: + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + if (ss_info->data.array.subscript[n]) + gfc_free_ss_chain (ss_info->data.array.subscript[n]); + break; + + default: + break; + } + + free (ss_info); +} + + +/* Free a SS. */ + +void +gfc_free_ss (gfc_ss * ss) +{ + free_ss_info (ss->info); + free (ss); +} + + +/* Creates and initializes an array type gfc_ss struct. */ + +gfc_ss * +gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) +{ + gfc_ss *ss; + gfc_ss_info *ss_info; + int i; + + ss_info = gfc_get_ss_info (); + ss_info->refcount++; + ss_info->type = type; + ss_info->expr = expr; + + ss = gfc_get_ss (); + ss->info = ss_info; + ss->next = next; + ss->dimen = dimen; + for (i = 0; i < ss->dimen; i++) + ss->dim[i] = i; + + return ss; +} + + +/* Creates and initializes a temporary type gfc_ss struct. */ + +gfc_ss * +gfc_get_temp_ss (tree type, tree string_length, int dimen) +{ + gfc_ss *ss; + gfc_ss_info *ss_info; + int i; + + ss_info = gfc_get_ss_info (); + ss_info->refcount++; + ss_info->type = GFC_SS_TEMP; + ss_info->string_length = string_length; + ss_info->data.temp.type = type; + + ss = gfc_get_ss (); + ss->info = ss_info; + ss->next = gfc_ss_terminator; + ss->dimen = dimen; + for (i = 0; i < ss->dimen; i++) + ss->dim[i] = i; + + return ss; +} + + +/* Creates and initializes a scalar type gfc_ss struct. */ + +gfc_ss * +gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) +{ + gfc_ss *ss; + gfc_ss_info *ss_info; + + ss_info = gfc_get_ss_info (); + ss_info->refcount++; + ss_info->type = GFC_SS_SCALAR; + ss_info->expr = expr; + + ss = gfc_get_ss (); + ss->info = ss_info; + ss->next = next; + + return ss; +} + + +/* Free all the SS associated with a loop. */ + +void +gfc_cleanup_loop (gfc_loopinfo * loop) +{ + gfc_loopinfo *loop_next, **ploop; + gfc_ss *ss; + gfc_ss *next; + + ss = loop->ss; + while (ss != gfc_ss_terminator) + { + gcc_assert (ss != NULL); + next = ss->loop_chain; + gfc_free_ss (ss); + ss = next; + } + + /* Remove reference to self in the parent loop. */ + if (loop->parent) + for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next) + if (*ploop == loop) + { + *ploop = loop->next; + break; + } + + /* Free non-freed nested loops. */ + for (loop = loop->nested; loop; loop = loop_next) + { + loop_next = loop->next; + gfc_cleanup_loop (loop); + free (loop); + } +} + + +static void +set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop) +{ + int n; + + for (; ss != gfc_ss_terminator; ss = ss->next) + { + ss->loop = loop; + + if (ss->info->type == GFC_SS_SCALAR + || ss->info->type == GFC_SS_REFERENCE + || ss->info->type == GFC_SS_TEMP) + continue; + + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + if (ss->info->data.array.subscript[n] != NULL) + set_ss_loop (ss->info->data.array.subscript[n], loop); + } +} + + +/* Associate a SS chain with a loop. */ + +void +gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) +{ + gfc_ss *ss; + gfc_loopinfo *nested_loop; + + if (head == gfc_ss_terminator) + return; + + set_ss_loop (head, loop); + + ss = head; + for (; ss && ss != gfc_ss_terminator; ss = ss->next) + { + if (ss->nested_ss) + { + nested_loop = ss->nested_ss->loop; + + /* More than one ss can belong to the same loop. Hence, we add the + loop to the chain only if it is different from the previously + added one, to avoid duplicate nested loops. */ + if (nested_loop != loop->nested) + { + gcc_assert (nested_loop->parent == NULL); + nested_loop->parent = loop; + + gcc_assert (nested_loop->next == NULL); + nested_loop->next = loop->nested; + loop->nested = nested_loop; + } + else + gcc_assert (nested_loop->parent == loop); + } + + if (ss->next == gfc_ss_terminator) + ss->loop_chain = loop->ss; + else + ss->loop_chain = ss->next; + } + gcc_assert (ss == gfc_ss_terminator); + loop->ss = head; +} + + +/* Returns true if the expression is an array pointer. */ + +static bool +is_pointer_array (tree expr) +{ + if (expr == NULL_TREE + || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr)) + || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) + return false; + + if (TREE_CODE (expr) == VAR_DECL + && GFC_DECL_PTR_ARRAY_P (expr)) + return true; + + if (TREE_CODE (expr) == PARM_DECL + && GFC_DECL_PTR_ARRAY_P (expr)) + return true; + + if (TREE_CODE (expr) == INDIRECT_REF + && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) + return true; + + /* The field declaration is marked as an pointer array. */ + if (TREE_CODE (expr) == COMPONENT_REF + && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) + && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) + return true; + + return false; +} + + +/* If the symbol or expression reference a CFI descriptor, return the + pointer to the converted gfc descriptor. If an array reference is + present as the last argument, check that it is the one applied to + the CFI descriptor in the expression. Note that the CFI object is + always the symbol in the expression! */ + +static bool +get_CFI_desc (gfc_symbol *sym, gfc_expr *expr, + tree *desc, gfc_array_ref *ar) +{ + tree tmp; + + if (!is_CFI_desc (sym, expr)) + return false; + + if (expr && ar) + { + if (!(expr->ref && expr->ref->type == REF_ARRAY) + || (&expr->ref->u.ar != ar)) + return false; + } + + if (sym == NULL) + tmp = expr->symtree->n.sym->backend_decl; + else + tmp = sym->backend_decl; + + if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) + tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); + + *desc = tmp; + return true; +} + + +/* Return the span of an array. */ + +tree +gfc_get_array_span (tree desc, gfc_expr *expr) +{ + tree tmp; + + if (is_pointer_array (desc) + || (get_CFI_desc (NULL, expr, &desc, NULL) + && (POINTER_TYPE_P (TREE_TYPE (desc)) + ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc))) + : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))))) + { + if (POINTER_TYPE_P (TREE_TYPE (desc))) + desc = build_fold_indirect_ref_loc (input_location, desc); + + /* This will have the span field set. */ + tmp = gfc_conv_descriptor_span_get (desc); + } + else if (expr->ts.type == BT_ASSUMED) + { + if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc)) + desc = GFC_DECL_SAVED_DESCRIPTOR (desc); + if (POINTER_TYPE_P (TREE_TYPE (desc))) + desc = build_fold_indirect_ref_loc (input_location, desc); + tmp = gfc_conv_descriptor_span_get (desc); + } + else if (TREE_CODE (desc) == COMPONENT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) + { + /* The descriptor is a class _data field and so use the vtable + size for the receiving span field. */ + tmp = gfc_get_vptr_from_expr (desc); + tmp = gfc_vptr_size_get (tmp); + } + else if (expr && expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->ts.type == BT_CLASS + && expr->ref->type == REF_COMPONENT + && expr->ref->next->type == REF_ARRAY + && expr->ref->next->next == NULL + && CLASS_DATA (expr->symtree->n.sym)->attr.dimension) + { + /* Dummys come in sometimes with the descriptor detached from + the class field or declaration. */ + tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl); + tmp = gfc_vptr_size_get (tmp); + } + else + { + /* If none of the fancy stuff works, the span is the element + size of the array. Attempt to deal with unbounded character + types if possible. Otherwise, return NULL_TREE. */ + tmp = gfc_get_element_type (TREE_TYPE (desc)); + if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) + { + gcc_assert (expr->ts.type == BT_CHARACTER); + + tmp = gfc_get_character_len_in_bytes (tmp); + + if (tmp == NULL_TREE || integer_zerop (tmp)) + { + tree bs; + + tmp = gfc_get_expr_charlen (expr); + tmp = fold_convert (gfc_array_index_type, tmp); + bs = build_int_cst (gfc_array_index_type, expr->ts.kind); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, bs); + } + + tmp = (tmp && !integer_zerop (tmp)) + ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); + } + else + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (tmp)); + } + return tmp; +} + + +/* Generate an initializer for a static pointer or allocatable array. */ + +void +gfc_trans_static_array_pointer (gfc_symbol * sym) +{ + tree type; + + gcc_assert (TREE_STATIC (sym->backend_decl)); + /* Just zero the data member. */ + type = TREE_TYPE (sym->backend_decl); + DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type); +} + + +/* If the bounds of SE's loop have not yet been set, see if they can be + determined from array spec AS, which is the array spec of a called + function. MAPPING maps the callee's dummy arguments to the values + that the caller is passing. Add any initialization and finalization + code to SE. */ + +void +gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, + gfc_se * se, gfc_array_spec * as) +{ + int n, dim, total_dim; + gfc_se tmpse; + gfc_ss *ss; + tree lower; + tree upper; + tree tmp; + + total_dim = 0; + + if (!as || as->type != AS_EXPLICIT) + return; + + for (ss = se->ss; ss; ss = ss->parent) + { + total_dim += ss->loop->dimen; + for (n = 0; n < ss->loop->dimen; n++) + { + /* The bound is known, nothing to do. */ + if (ss->loop->to[n] != NULL_TREE) + continue; + + dim = ss->dim[n]; + gcc_assert (dim < as->rank); + gcc_assert (ss->loop->dimen <= as->rank); + + /* Evaluate the lower bound. */ + gfc_init_se (&tmpse, NULL); + gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + gfc_add_block_to_block (&se->post, &tmpse.post); + lower = fold_convert (gfc_array_index_type, tmpse.expr); + + /* ...and the upper bound. */ + gfc_init_se (&tmpse, NULL); + gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + gfc_add_block_to_block (&se->post, &tmpse.post); + upper = fold_convert (gfc_array_index_type, tmpse.expr); + + /* Set the upper bound of the loop to UPPER - LOWER. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + tmp = gfc_evaluate_now (tmp, &se->pre); + ss->loop->to[n] = tmp; + } + } + + gcc_assert (total_dim == as->rank); +} + + +/* Generate code to allocate an array temporary, or create a variable to + hold the data. If size is NULL, zero the descriptor so that the + callee will allocate the array. If DEALLOC is true, also generate code to + free the array afterwards. + + If INITIAL is not NULL, it is packed using internal_pack and the result used + as data instead of allocating a fresh, unitialized area of memory. + + Initialization code is added to PRE and finalization code to POST. + DYNAMIC is true if the caller may want to extend the array later + using realloc. This prevents us from putting the array on the stack. */ + +static void +gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, + gfc_array_info * info, tree size, tree nelem, + tree initial, bool dynamic, bool dealloc) +{ + tree tmp; + tree desc; + bool onstack; + + desc = info->descriptor; + info->offset = gfc_index_zero_node; + if (size == NULL_TREE || integer_zerop (size)) + { + /* A callee allocated array. */ + gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); + onstack = FALSE; + } + else + { + /* Allocate the temporary. */ + onstack = !dynamic && initial == NULL_TREE + && (flag_stack_arrays + || gfc_can_put_var_on_stack (size)); + + if (onstack) + { + /* Make a temporary variable to hold the data. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem), + nelem, gfc_index_one_node); + tmp = gfc_evaluate_now (tmp, pre); + tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, + tmp); + tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), + tmp); + tmp = gfc_create_var (tmp, "A"); + /* If we're here only because of -fstack-arrays we have to + emit a DECL_EXPR to make the gimplifier emit alloca calls. */ + if (!gfc_can_put_var_on_stack (size)) + gfc_add_expr_to_block (pre, + fold_build1_loc (input_location, + DECL_EXPR, TREE_TYPE (tmp), + tmp)); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + gfc_conv_descriptor_data_set (pre, desc, tmp); + } + else + { + /* Allocate memory to hold the data or call internal_pack. */ + if (initial == NULL_TREE) + { + tmp = gfc_call_malloc (pre, NULL, size); + tmp = gfc_evaluate_now (tmp, pre); + } + else + { + tree packed; + tree source_data; + tree was_packed; + stmtblock_t do_copying; + + tmp = TREE_TYPE (initial); /* Pointer to descriptor. */ + gcc_assert (TREE_CODE (tmp) == POINTER_TYPE); + tmp = TREE_TYPE (tmp); /* The descriptor itself. */ + tmp = gfc_get_element_type (tmp); + packed = gfc_create_var (build_pointer_type (tmp), "data"); + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, initial); + tmp = fold_convert (TREE_TYPE (packed), tmp); + gfc_add_modify (pre, packed, tmp); + + tmp = build_fold_indirect_ref_loc (input_location, + initial); + source_data = gfc_conv_descriptor_data_get (tmp); + + /* internal_pack may return source->data without any allocation + or copying if it is already packed. If that's the case, we + need to allocate and copy manually. */ + + gfc_start_block (&do_copying); + tmp = gfc_call_malloc (&do_copying, NULL, size); + tmp = fold_convert (TREE_TYPE (packed), tmp); + gfc_add_modify (&do_copying, packed, tmp); + tmp = gfc_build_memcpy_call (packed, source_data, size); + gfc_add_expr_to_block (&do_copying, tmp); + + was_packed = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, packed, + source_data); + tmp = gfc_finish_block (&do_copying); + tmp = build3_v (COND_EXPR, was_packed, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (pre, tmp); + + tmp = fold_convert (pvoid_type_node, packed); + } + + gfc_conv_descriptor_data_set (pre, desc, tmp); + } + } + info->data = gfc_conv_descriptor_data_get (desc); + + /* The offset is zero because we create temporaries with a zero + lower bound. */ + gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node); + + if (dealloc && !onstack) + { + /* Free the temporary. */ + tmp = gfc_conv_descriptor_data_get (desc); + tmp = gfc_call_free (tmp); + gfc_add_expr_to_block (post, tmp); + } +} + + +/* Get the scalarizer array dimension corresponding to actual array dimension + given by ARRAY_DIM. + + For example, if SS represents the array ref a(1,:,:,1), it is a + bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1, + and 1 for ARRAY_DIM=2. + If SS represents transpose(a(:,1,1,:)), it is again a bidimensional + scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for + ARRAY_DIM=3. + If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer + array. If called on the inner ss, the result would be respectively 0,1,2 for + ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1 + for ARRAY_DIM=1,2. */ + +static int +get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim) +{ + int array_ref_dim; + int n; + + array_ref_dim = 0; + + for (; ss; ss = ss->parent) + for (n = 0; n < ss->dimen; n++) + if (ss->dim[n] < array_dim) + array_ref_dim++; + + return array_ref_dim; +} + + +static gfc_ss * +innermost_ss (gfc_ss *ss) +{ + while (ss->nested_ss != NULL) + ss = ss->nested_ss; + + return ss; +} + + + +/* Get the array reference dimension corresponding to the given loop dimension. + It is different from the true array dimension given by the dim array in + the case of a partial array reference (i.e. a(:,:,1,:) for example) + It is different from the loop dimension in the case of a transposed array. + */ + +static int +get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) +{ + return get_scalarizer_dim_for_array_dim (innermost_ss (ss), + ss->dim[loop_dim]); +} + + +/* Use the information in the ss to obtain the required information about + the type and size of an array temporary, when the lhs in an assignment + is a class expression. */ + +static tree +get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype) +{ + gfc_ss *lhs_ss; + gfc_ss *rhs_ss; + tree tmp; + tree tmp2; + tree vptr; + tree rhs_class_expr = NULL_TREE; + tree lhs_class_expr = NULL_TREE; + bool unlimited_rhs = false; + bool unlimited_lhs = false; + bool rhs_function = false; + gfc_symbol *vtab; + + /* The second element in the loop chain contains the source for the + temporary; ie. the rhs of the assignment. */ + rhs_ss = ss->loop->ss->loop_chain; + + if (rhs_ss != gfc_ss_terminator + && rhs_ss->info + && rhs_ss->info->expr + && rhs_ss->info->expr->ts.type == BT_CLASS + && rhs_ss->info->data.array.descriptor) + { + if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE) + rhs_class_expr + = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor); + else + rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr); + unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr); + if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION) + rhs_function = true; + } + + /* For an assignment the lhs is the next element in the loop chain. + If we have a class rhs, this had better be a class variable + expression! */ + lhs_ss = rhs_ss->loop_chain; + if (lhs_ss != gfc_ss_terminator + && lhs_ss->info + && lhs_ss->info->expr + && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE + && lhs_ss->info->expr->ts.type == BT_CLASS) + { + tmp = lhs_ss->info->data.array.descriptor; + unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr); + } + else + tmp = NULL_TREE; + + /* Get the lhs class expression. */ + if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator) + lhs_class_expr = gfc_get_class_from_expr (tmp); + else + return rhs_class_expr; + + gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr))); + + /* Set the lhs vptr and, if necessary, the _len field. */ + if (rhs_class_expr) + { + /* Both lhs and rhs are class expressions. */ + tmp = gfc_class_vptr_get (lhs_class_expr); + gfc_add_modify (pre, tmp, + fold_convert (TREE_TYPE (tmp), + gfc_class_vptr_get (rhs_class_expr))); + if (unlimited_lhs) + { + tmp = gfc_class_len_get (lhs_class_expr); + if (unlimited_rhs) + tmp2 = gfc_class_len_get (rhs_class_expr); + else + tmp2 = build_int_cst (TREE_TYPE (tmp), 0); + gfc_add_modify (pre, tmp, tmp2); + } + + if (rhs_function) + { + tmp = gfc_class_data_get (rhs_class_expr); + gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); + } + } + else + { + /* lhs is class and rhs is intrinsic or derived type. */ + *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor); + *eltype = gfc_get_element_type (*eltype); + vtab = gfc_find_vtab (&rhs_ss->info->expr->ts); + vptr = vtab->backend_decl; + if (vptr == NULL_TREE) + vptr = gfc_get_symbol_decl (vtab); + vptr = gfc_build_addr_expr (NULL_TREE, vptr); + tmp = gfc_class_vptr_get (lhs_class_expr); + gfc_add_modify (pre, tmp, + fold_convert (TREE_TYPE (tmp), vptr)); + + if (unlimited_lhs) + { + tmp = gfc_class_len_get (lhs_class_expr); + if (rhs_ss->info + && rhs_ss->info->expr + && rhs_ss->info->expr->ts.type == BT_CHARACTER) + tmp2 = build_int_cst (TREE_TYPE (tmp), + rhs_ss->info->expr->ts.kind); + else + tmp2 = build_int_cst (TREE_TYPE (tmp), 0); + gfc_add_modify (pre, tmp, tmp2); + } + } + + return rhs_class_expr; +} + + + +/* Generate code to create and initialize the descriptor for a temporary + array. This is used for both temporaries needed by the scalarizer, and + functions returning arrays. Adjusts the loop variables to be + zero-based, and calculates the loop bounds for callee allocated arrays. + Allocate the array unless it's callee allocated (we have a callee + allocated array if 'callee_alloc' is true, or if loop->to[n] is + NULL_TREE for any n). Also fills in the descriptor, data and offset + fields of info if known. Returns the size of the array, or NULL for a + callee allocated array. + + 'eltype' == NULL signals that the temporary should be a class object. + The 'initial' expression is used to obtain the size of the dynamic + type; otherwise the allocation and initialization proceeds as for any + other expression + + PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for + gfc_trans_allocate_array_storage. */ + +tree +gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, + tree eltype, tree initial, bool dynamic, + bool dealloc, bool callee_alloc, locus * where) +{ + gfc_loopinfo *loop; + gfc_ss *s; + gfc_array_info *info; + tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; + tree type; + tree desc; + tree tmp; + tree size; + tree nelem; + tree cond; + tree or_expr; + tree elemsize; + tree class_expr = NULL_TREE; + int n, dim, tmp_dim; + int total_dim = 0; + + /* This signals a class array for which we need the size of the + dynamic type. Generate an eltype and then the class expression. */ + if (eltype == NULL_TREE && initial) + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial))); + class_expr = build_fold_indirect_ref_loc (input_location, initial); + /* Obtain the structure (class) expression. */ + class_expr = gfc_get_class_from_expr (class_expr); + gcc_assert (class_expr); + } + + /* Otherwise, some expressions, such as class functions, arising from + dependency checking in assignments come here with class element type. + The descriptor can be obtained from the ss->info and then converted + to the class object. */ + if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype)) + class_expr = get_class_info_from_ss (pre, ss, &eltype); + + /* If the dynamic type is not available, use the declared type. */ + if (eltype && GFC_CLASS_TYPE_P (eltype)) + eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype))); + + if (class_expr == NULL_TREE) + elemsize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (eltype)); + else + { + /* Unlimited polymorphic entities are initialised with NULL vptr. They + can be tested for by checking if the len field is present. If so + test the vptr before using the vtable size. */ + tmp = gfc_class_vptr_get (class_expr); + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + elemsize = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, + tmp, + gfc_class_vtab_size_get (class_expr), + gfc_index_zero_node); + elemsize = gfc_evaluate_now (elemsize, pre); + elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize); + /* Casting the data as a character of the dynamic length ensures that + assignment of elements works when needed. */ + eltype = gfc_get_character_type_len (1, elemsize); + } + + memset (from, 0, sizeof (from)); + memset (to, 0, sizeof (to)); + + info = &ss->info->data.array; + + gcc_assert (ss->dimen > 0); + gcc_assert (ss->loop->dimen == ss->dimen); + + if (warn_array_temporaries && where) + gfc_warning (OPT_Warray_temporaries, + "Creating array temporary at %L", where); + + /* Set the lower bound to zero. */ + for (s = ss; s; s = s->parent) + { + loop = s->loop; + + total_dim += loop->dimen; + for (n = 0; n < loop->dimen; n++) + { + dim = s->dim[n]; + + /* Callee allocated arrays may not have a known bound yet. */ + if (loop->to[n]) + loop->to[n] = gfc_evaluate_now ( + fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], loop->from[n]), + pre); + loop->from[n] = gfc_index_zero_node; + + /* We have just changed the loop bounds, we must clear the + corresponding specloop, so that delta calculation is not skipped + later in gfc_set_delta. */ + loop->specloop[n] = NULL; + + /* We are constructing the temporary's descriptor based on the loop + dimensions. As the dimensions may be accessed in arbitrary order + (think of transpose) the size taken from the n'th loop may not map + to the n'th dimension of the array. We need to reconstruct loop + infos in the right order before using it to set the descriptor + bounds. */ + tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim); + from[tmp_dim] = loop->from[n]; + to[tmp_dim] = loop->to[n]; + + info->delta[dim] = gfc_index_zero_node; + info->start[dim] = gfc_index_zero_node; + info->end[dim] = gfc_index_zero_node; + info->stride[dim] = gfc_index_one_node; + } + } + + /* Initialize the descriptor. */ + type = + gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1, + GFC_ARRAY_UNKNOWN, true); + desc = gfc_create_var (type, "atmp"); + GFC_DECL_PACKED_ARRAY (desc) = 1; + + /* Emit a DECL_EXPR for the variable sized array type in + GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type + sizes works correctly. */ + tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type)); + if (! TYPE_NAME (arraytype)) + TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, + NULL_TREE, arraytype); + gfc_add_expr_to_block (pre, build1 (DECL_EXPR, + arraytype, TYPE_NAME (arraytype))); + + if (class_expr != NULL_TREE) + { + tree class_data; + tree dtype; + + /* Create a class temporary. */ + tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp"); + gfc_add_modify (pre, tmp, class_expr); + + /* Assign the new descriptor to the _data field. This allows the + vptr _copy to be used for scalarized assignment since the class + temporary can be found from the descriptor. */ + class_data = gfc_class_data_get (tmp); + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (desc), desc); + gfc_add_modify (pre, class_data, tmp); + + /* Take the dtype from the class expression. */ + dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr)); + tmp = gfc_conv_descriptor_dtype (class_data); + gfc_add_modify (pre, tmp, dtype); + + /* Point desc to the class _data field. */ + desc = class_data; + } + else + { + /* Fill in the array dtype. */ + tmp = gfc_conv_descriptor_dtype (desc); + gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); + } + + info->descriptor = desc; + size = gfc_index_one_node; + + /* + Fill in the bounds and stride. This is a packed array, so: + + size = 1; + for (n = 0; n < rank; n++) + { + stride[n] = size + delta = ubound[n] + 1 - lbound[n]; + size = size * delta; + } + size = size * sizeof(element); + */ + + or_expr = NULL_TREE; + + /* If there is at least one null loop->to[n], it is a callee allocated + array. */ + for (n = 0; n < total_dim; n++) + if (to[n] == NULL_TREE) + { + size = NULL_TREE; + break; + } + + if (size == NULL_TREE) + for (s = ss; s; s = s->parent) + for (n = 0; n < s->loop->dimen; n++) + { + dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]); + + /* For a callee allocated array express the loop bounds in terms + of the descriptor fields. */ + tmp = fold_build2_loc (input_location, + MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), + gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); + s->loop->to[n] = tmp; + } + else + { + for (n = 0; n < total_dim; n++) + { + /* Store the stride and bound components in the descriptor. */ + gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); + + gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], + gfc_index_zero_node); + + gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + to[n], gfc_index_one_node); + + /* Check whether the size for this dimension is negative. */ + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + tmp, gfc_index_zero_node); + cond = gfc_evaluate_now (cond, pre); + + if (n == 0) + or_expr = cond; + else + or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, or_expr, cond); + + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + size = gfc_evaluate_now (size, pre); + } + } + + /* Get the size of the array. */ + if (size && !callee_alloc) + { + /* If or_expr is true, then the extent in at least one + dimension is zero and the size is set to zero. */ + size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, + or_expr, gfc_index_zero_node, size); + + nelem = size; + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, elemsize); + } + else + { + nelem = size; + size = NULL_TREE; + } + + /* Set the span. */ + tmp = fold_convert (gfc_array_index_type, elemsize); + gfc_conv_descriptor_span_set (pre, desc, tmp); + + gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, + dynamic, dealloc); + + while (ss->parent) + ss = ss->parent; + + if (ss->dimen > ss->loop->temp_dim) + ss->loop->temp_dim = ss->dimen; + + return size; +} + + +/* Return the number of iterations in a loop that starts at START, + ends at END, and has step STEP. */ + +static tree +gfc_get_iteration_count (tree start, tree end, tree step) +{ + tree tmp; + tree type; + + type = TREE_TYPE (step); + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, + build_int_cst (type, 1)); + tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp, + build_int_cst (type, 0)); + return fold_convert (gfc_array_index_type, tmp); +} + + +/* Extend the data in array DESC by EXTRA elements. */ + +static void +gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) +{ + tree arg0, arg1; + tree tmp; + tree size; + tree ubound; + + if (integer_zerop (extra)) + return; + + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]); + + /* Add EXTRA to the upper bound. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + ubound, extra); + gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp); + + /* Get the value of the current data pointer. */ + arg0 = gfc_conv_descriptor_data_get (desc); + + /* Calculate the new array size. */ + size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + ubound, gfc_index_one_node); + arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, tmp), + fold_convert (size_type_node, size)); + + /* Call the realloc() function. */ + tmp = gfc_call_realloc (pblock, arg0, arg1); + gfc_conv_descriptor_data_set (pblock, desc, tmp); +} + + +/* Return true if the bounds of iterator I can only be determined + at run time. */ + +static inline bool +gfc_iterator_has_dynamic_bounds (gfc_iterator * i) +{ + return (i->start->expr_type != EXPR_CONSTANT + || i->end->expr_type != EXPR_CONSTANT + || i->step->expr_type != EXPR_CONSTANT); +} + + +/* Split the size of constructor element EXPR into the sum of two terms, + one of which can be determined at compile time and one of which must + be calculated at run time. Set *SIZE to the former and return true + if the latter might be nonzero. */ + +static bool +gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr) +{ + if (expr->expr_type == EXPR_ARRAY) + return gfc_get_array_constructor_size (size, expr->value.constructor); + else if (expr->rank > 0) + { + /* Calculate everything at run time. */ + mpz_set_ui (*size, 0); + return true; + } + else + { + /* A single element. */ + mpz_set_ui (*size, 1); + return false; + } +} + + +/* Like gfc_get_array_constructor_element_size, but applied to the whole + of array constructor C. */ + +static bool +gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base) +{ + gfc_constructor *c; + gfc_iterator *i; + mpz_t val; + mpz_t len; + bool dynamic; + + mpz_set_ui (*size, 0); + mpz_init (len); + mpz_init (val); + + dynamic = false; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + i = c->iterator; + if (i && gfc_iterator_has_dynamic_bounds (i)) + dynamic = true; + else + { + dynamic |= gfc_get_array_constructor_element_size (&len, c->expr); + if (i) + { + /* Multiply the static part of the element size by the + number of iterations. */ + mpz_sub (val, i->end->value.integer, i->start->value.integer); + mpz_fdiv_q (val, val, i->step->value.integer); + mpz_add_ui (val, val, 1); + if (mpz_sgn (val) > 0) + mpz_mul (len, len, val); + else + mpz_set_ui (len, 0); + } + mpz_add (*size, *size, len); + } + } + mpz_clear (len); + mpz_clear (val); + return dynamic; +} + + +/* Make sure offset is a variable. */ + +static void +gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, + tree * offsetvar) +{ + /* We should have already created the offset variable. We cannot + create it here because we may be in an inner scope. */ + gcc_assert (*offsetvar != NULL_TREE); + gfc_add_modify (pblock, *offsetvar, *poffset); + *poffset = *offsetvar; + TREE_USED (*offsetvar) = 1; +} + + +/* Variables needed for bounds-checking. */ +static bool first_len; +static tree first_len_val; +static bool typespec_chararray_ctor; + +static void +gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, + tree offset, gfc_se * se, gfc_expr * expr) +{ + tree tmp; + + gfc_conv_expr (se, expr); + + /* Store the value. */ + tmp = build_fold_indirect_ref_loc (input_location, + gfc_conv_descriptor_data_get (desc)); + tmp = gfc_build_array_ref (tmp, offset, NULL); + + if (expr->ts.type == BT_CHARACTER) + { + int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); + tree esize; + + esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc))); + esize = fold_convert (gfc_charlen_type_node, esize); + esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + TREE_TYPE (esize), esize, + build_int_cst (TREE_TYPE (esize), + gfc_character_kinds[i].bit_size / 8)); + + gfc_conv_string_parameter (se); + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + { + /* The temporary is an array of pointers. */ + se->expr = fold_convert (TREE_TYPE (tmp), se->expr); + gfc_add_modify (&se->pre, tmp, se->expr); + } + else + { + /* The temporary is an array of string values. */ + tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp); + /* We know the temporary and the value will be the same length, + so can use memcpy. */ + gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind, + se->string_length, se->expr, expr->ts.kind); + } + if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor) + { + if (first_len) + { + gfc_add_modify (&se->pre, first_len_val, + fold_convert (TREE_TYPE (first_len_val), + se->string_length)); + first_len = false; + } + else + { + /* Verify that all constructor elements are of the same + length. */ + tree rhs = fold_convert (TREE_TYPE (first_len_val), + se->string_length); + tree cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, first_len_val, + rhs); + gfc_trans_runtime_check + (true, false, cond, &se->pre, &expr->where, + "Different CHARACTER lengths (%ld/%ld) in array constructor", + fold_convert (long_integer_type_node, first_len_val), + fold_convert (long_integer_type_node, se->string_length)); + } + } + } + else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) + && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc)))) + { + /* Assignment of a CLASS array constructor to a derived type array. */ + if (expr->expr_type == EXPR_FUNCTION) + se->expr = gfc_evaluate_now (se->expr, pblock); + se->expr = gfc_class_data_get (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + se->expr = fold_convert (TREE_TYPE (tmp), se->expr); + gfc_add_modify (&se->pre, tmp, se->expr); + } + else + { + /* TODO: Should the frontend already have done this conversion? */ + se->expr = fold_convert (TREE_TYPE (tmp), se->expr); + gfc_add_modify (&se->pre, tmp, se->expr); + } + + gfc_add_block_to_block (pblock, &se->pre); + gfc_add_block_to_block (pblock, &se->post); +} + + +/* Add the contents of an array to the constructor. DYNAMIC is as for + gfc_trans_array_constructor_value. */ + +static void +gfc_trans_array_constructor_subarray (stmtblock_t * pblock, + tree type ATTRIBUTE_UNUSED, + tree desc, gfc_expr * expr, + tree * poffset, tree * offsetvar, + bool dynamic) +{ + gfc_se se; + gfc_ss *ss; + gfc_loopinfo loop; + stmtblock_t body; + tree tmp; + tree size; + int n; + + /* We need this to be a variable so we can increment it. */ + gfc_put_offset_into_var (pblock, poffset, offsetvar); + + gfc_init_se (&se, NULL); + + /* Walk the array expression. */ + ss = gfc_walk_expr (expr); + gcc_assert (ss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + /* Make sure the constructed array has room for the new data. */ + if (dynamic) + { + /* Set SIZE to the total number of elements in the subarray. */ + size = gfc_index_one_node; + for (n = 0; n < loop.dimen; n++) + { + tmp = gfc_get_iteration_count (loop.from[n], loop.to[n], + gfc_index_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + } + + /* Grow the constructed array by SIZE elements. */ + gfc_grow_array (&loop.pre, desc, size); + } + + /* Make the loop body. */ + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + + gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr); + gcc_assert (se.ss == gfc_ss_terminator); + + /* Increment the offset. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + *poffset, gfc_index_one_node); + gfc_add_modify (&body, *poffset, tmp); + + /* Finish the loop. */ + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&loop.pre, &loop.post); + tmp = gfc_finish_block (&loop.pre); + gfc_add_expr_to_block (pblock, tmp); + + gfc_cleanup_loop (&loop); +} + + +/* Assign the values to the elements of an array constructor. DYNAMIC + is true if descriptor DESC only contains enough data for the static + size calculated by gfc_get_array_constructor_size. When true, memory + for the dynamic parts must be allocated using realloc. */ + +static void +gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, + tree desc, gfc_constructor_base base, + tree * poffset, tree * offsetvar, + bool dynamic) +{ + tree tmp; + tree start = NULL_TREE; + tree end = NULL_TREE; + tree step = NULL_TREE; + stmtblock_t body; + gfc_se se; + mpz_t size; + gfc_constructor *c; + + tree shadow_loopvar = NULL_TREE; + gfc_saved_var saved_loopvar; + + mpz_init (size); + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + /* If this is an iterator or an array, the offset must be a variable. */ + if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) + gfc_put_offset_into_var (pblock, poffset, offsetvar); + + /* Shadowing the iterator avoids changing its value and saves us from + keeping track of it. Further, it makes sure that there's always a + backend-decl for the symbol, even if there wasn't one before, + e.g. in the case of an iterator that appears in a specification + expression in an interface mapping. */ + if (c->iterator) + { + gfc_symbol *sym; + tree type; + + /* Evaluate loop bounds before substituting the loop variable + in case they depend on it. Such a case is invalid, but it is + not more expensive to do the right thing here. + See PR 44354. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->start); + gfc_add_block_to_block (pblock, &se.pre); + start = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->end); + gfc_add_block_to_block (pblock, &se.pre); + end = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->step); + gfc_add_block_to_block (pblock, &se.pre); + step = gfc_evaluate_now (se.expr, pblock); + + sym = c->iterator->var->symtree->n.sym; + type = gfc_typenode_for_spec (&sym->ts); + + shadow_loopvar = gfc_create_var (type, "shadow_loopvar"); + gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar); + } + + gfc_start_block (&body); + + if (c->expr->expr_type == EXPR_ARRAY) + { + /* Array constructors can be nested. */ + gfc_trans_array_constructor_value (&body, type, desc, + c->expr->value.constructor, + poffset, offsetvar, dynamic); + } + else if (c->expr->rank > 0) + { + gfc_trans_array_constructor_subarray (&body, type, desc, c->expr, + poffset, offsetvar, dynamic); + } + else + { + /* This code really upsets the gimplifier so don't bother for now. */ + gfc_constructor *p; + HOST_WIDE_INT n; + HOST_WIDE_INT size; + + p = c; + n = 0; + while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) + { + p = gfc_constructor_next (p); + n++; + } + if (n < 4) + { + /* Scalar values. */ + gfc_init_se (&se, NULL); + gfc_trans_array_ctor_element (&body, desc, *poffset, + &se, c->expr); + + *poffset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + *poffset, gfc_index_one_node); + } + else + { + /* Collect multiple scalar constants into a constructor. */ + vec *v = NULL; + tree init; + tree bound; + tree tmptype; + HOST_WIDE_INT idx = 0; + + p = c; + /* Count the number of consecutive scalar constants. */ + while (p && !(p->iterator + || p->expr->expr_type != EXPR_CONSTANT)) + { + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, p->expr); + + if (c->expr->ts.type != BT_CHARACTER) + se.expr = fold_convert (type, se.expr); + /* For constant character array constructors we build + an array of pointers. */ + else if (POINTER_TYPE_P (type)) + se.expr = gfc_build_addr_expr + (gfc_get_pchar_type (p->expr->ts.kind), + se.expr); + + CONSTRUCTOR_APPEND_ELT (v, + build_int_cst (gfc_array_index_type, + idx++), + se.expr); + c = p; + p = gfc_constructor_next (p); + } + + bound = size_int (n - 1); + /* Create an array type to hold them. */ + tmptype = build_range_type (gfc_array_index_type, + gfc_index_zero_node, bound); + tmptype = build_array_type (type, tmptype); + + init = build_constructor (tmptype, v); + TREE_CONSTANT (init) = 1; + TREE_STATIC (init) = 1; + /* Create a static variable to hold the data. */ + tmp = gfc_create_var (tmptype, "data"); + TREE_STATIC (tmp) = 1; + TREE_CONSTANT (tmp) = 1; + TREE_READONLY (tmp) = 1; + DECL_INITIAL (tmp) = init; + init = tmp; + + /* Use BUILTIN_MEMCPY to assign the values. */ + tmp = gfc_conv_descriptor_data_get (desc); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); + tmp = gfc_build_array_ref (tmp, *poffset, NULL); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + init = gfc_build_addr_expr (NULL_TREE, init); + + size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); + bound = build_int_cst (size_type_node, n * size); + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), + 3, tmp, init, bound); + gfc_add_expr_to_block (&body, tmp); + + *poffset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, *poffset, + build_int_cst (gfc_array_index_type, n)); + } + if (!INTEGER_CST_P (*poffset)) + { + gfc_add_modify (&body, *offsetvar, *poffset); + *poffset = *offsetvar; + } + } + + /* The frontend should already have done any expansions + at compile-time. */ + if (!c->iterator) + { + /* Pass the code as is. */ + tmp = gfc_finish_block (&body); + gfc_add_expr_to_block (pblock, tmp); + } + else + { + /* Build the implied do-loop. */ + stmtblock_t implied_do_block; + tree cond; + tree exit_label; + tree loopbody; + tree tmp2; + + loopbody = gfc_finish_block (&body); + + /* Create a new block that holds the implied-do loop. A temporary + loop-variable is used. */ + gfc_start_block(&implied_do_block); + + /* Initialize the loop. */ + gfc_add_modify (&implied_do_block, shadow_loopvar, start); + + /* If this array expands dynamically, and the number of iterations + is not constant, we won't have allocated space for the static + part of C->EXPR's size. Do that now. */ + if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator)) + { + /* Get the number of iterations. */ + tmp = gfc_get_iteration_count (shadow_loopvar, end, step); + + /* Get the static part of C->EXPR's size. */ + gfc_get_array_constructor_element_size (&size, c->expr); + tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); + + /* Grow the array by TMP * TMP2 elements. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, tmp2); + gfc_grow_array (&implied_do_block, desc, tmp); + } + + /* Generate the loop body. */ + exit_label = gfc_build_label_decl (NULL_TREE); + gfc_start_block (&body); + + /* Generate the exit condition. Depending on the sign of + the step variable we have to generate the correct + comparison. */ + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + step, build_int_cst (TREE_TYPE (step), 0)); + cond = fold_build3_loc (input_location, COND_EXPR, + logical_type_node, tmp, + fold_build2_loc (input_location, GT_EXPR, + logical_type_node, shadow_loopvar, end), + fold_build2_loc (input_location, LT_EXPR, + logical_type_node, shadow_loopvar, end)); + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = build3_v (COND_EXPR, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + + /* The main loop body. */ + gfc_add_expr_to_block (&body, loopbody); + + /* Increase loop variable by step. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (shadow_loopvar), shadow_loopvar, + step); + gfc_add_modify (&body, shadow_loopvar, tmp); + + /* Finish the loop. */ + tmp = gfc_finish_block (&body); + tmp = build1_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&implied_do_block, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&implied_do_block, tmp); + + /* Finish the implied-do loop. */ + tmp = gfc_finish_block(&implied_do_block); + gfc_add_expr_to_block(pblock, tmp); + + gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar); + } + } + mpz_clear (size); +} + + +/* The array constructor code can create a string length with an operand + in the form of a temporary variable. This variable will retain its + context (current_function_decl). If we store this length tree in a + gfc_charlen structure which is shared by a variable in another + context, the resulting gfc_charlen structure with a variable in a + different context, we could trip the assertion in expand_expr_real_1 + when it sees that a variable has been created in one context and + referenced in another. + + If this might be the case, we create a new gfc_charlen structure and + link it into the current namespace. */ + +static void +store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl) +{ + if (force_new_cl) + { + gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp); + *clp = new_cl; + } + (*clp)->backend_decl = len; +} + +/* A catch-all to obtain the string length for anything that is not + a substring of non-constant length, a constant, array or variable. */ + +static void +get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) +{ + gfc_se se; + + /* Don't bother if we already know the length is a constant. */ + if (*len && INTEGER_CST_P (*len)) + return; + + if (!e->ref && e->ts.u.cl && e->ts.u.cl->length + && e->ts.u.cl->length->expr_type == EXPR_CONSTANT) + { + /* This is easy. */ + gfc_conv_const_charlen (e->ts.u.cl); + *len = e->ts.u.cl->backend_decl; + } + else + { + /* Otherwise, be brutal even if inefficient. */ + gfc_init_se (&se, NULL); + + /* No function call, in case of side effects. */ + se.no_function_call = 1; + if (e->rank == 0) + gfc_conv_expr (&se, e); + else + gfc_conv_expr_descriptor (&se, e); + + /* Fix the value. */ + *len = gfc_evaluate_now (se.string_length, &se.pre); + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (block, &se.post); + + store_backend_decl (&e->ts.u.cl, *len, true); + } +} + + +/* Figure out the string length of a variable reference expression. + Used by get_array_ctor_strlen. */ + +static void +get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len) +{ + gfc_ref *ref; + gfc_typespec *ts; + mpz_t char_len; + gfc_se se; + + /* Don't bother if we already know the length is a constant. */ + if (*len && INTEGER_CST_P (*len)) + return; + + ts = &expr->symtree->n.sym->ts; + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + /* Array references don't change the string length. */ + if (ts->deferred) + get_array_ctor_all_strlen (block, expr, len); + break; + + case REF_COMPONENT: + /* Use the length of the component. */ + ts = &ref->u.c.component->ts; + break; + + case REF_SUBSTRING: + if (ref->u.ss.end == NULL + || ref->u.ss.start->expr_type != EXPR_CONSTANT + || ref->u.ss.end->expr_type != EXPR_CONSTANT) + { + /* Note that this might evaluate expr. */ + get_array_ctor_all_strlen (block, expr, len); + return; + } + mpz_init_set_ui (char_len, 1); + mpz_add (char_len, char_len, ref->u.ss.end->value.integer); + mpz_sub (char_len, char_len, ref->u.ss.start->value.integer); + *len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node); + mpz_clear (char_len); + return; + + case REF_INQUIRY: + break; + + default: + gcc_unreachable (); + } + } + + /* A last ditch attempt that is sometimes needed for deferred characters. */ + if (!ts->u.cl->backend_decl) + { + gfc_init_se (&se, NULL); + if (expr->rank) + gfc_conv_expr_descriptor (&se, expr); + else + gfc_conv_expr (&se, expr); + gcc_assert (se.string_length != NULL_TREE); + gfc_add_block_to_block (block, &se.pre); + ts->u.cl->backend_decl = se.string_length; + } + + *len = ts->u.cl->backend_decl; +} + + +/* Figure out the string length of a character array constructor. + If len is NULL, don't calculate the length; this happens for recursive calls + when a sub-array-constructor is an element but not at the first position, + so when we're not interested in the length. + Returns TRUE if all elements are character constants. */ + +bool +get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len) +{ + gfc_constructor *c; + bool is_const; + + is_const = TRUE; + + if (gfc_constructor_first (base) == NULL) + { + if (len) + *len = build_int_cstu (gfc_charlen_type_node, 0); + return is_const; + } + + /* Loop over all constructor elements to find out is_const, but in len we + want to store the length of the first, not the last, element. We can + of course exit the loop as soon as is_const is found to be false. */ + for (c = gfc_constructor_first (base); + c && is_const; c = gfc_constructor_next (c)) + { + switch (c->expr->expr_type) + { + case EXPR_CONSTANT: + if (len && !(*len && INTEGER_CST_P (*len))) + *len = build_int_cstu (gfc_charlen_type_node, + c->expr->value.character.length); + break; + + case EXPR_ARRAY: + if (!get_array_ctor_strlen (block, c->expr->value.constructor, len)) + is_const = false; + break; + + case EXPR_VARIABLE: + is_const = false; + if (len) + get_array_ctor_var_strlen (block, c->expr, len); + break; + + default: + is_const = false; + if (len) + get_array_ctor_all_strlen (block, c->expr, len); + break; + } + + /* After the first iteration, we don't want the length modified. */ + len = NULL; + } + + return is_const; +} + +/* Check whether the array constructor C consists entirely of constant + elements, and if so returns the number of those elements, otherwise + return zero. Note, an empty or NULL array constructor returns zero. */ + +unsigned HOST_WIDE_INT +gfc_constant_array_constructor_p (gfc_constructor_base base) +{ + unsigned HOST_WIDE_INT nelem = 0; + + gfc_constructor *c = gfc_constructor_first (base); + while (c) + { + if (c->iterator + || c->expr->rank > 0 + || c->expr->expr_type != EXPR_CONSTANT) + return 0; + c = gfc_constructor_next (c); + nelem++; + } + return nelem; +} + + +/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY, + and the tree type of it's elements, TYPE, return a static constant + variable that is compile-time initialized. */ + +tree +gfc_build_constant_array_constructor (gfc_expr * expr, tree type) +{ + tree tmptype, init, tmp; + HOST_WIDE_INT nelem; + gfc_constructor *c; + gfc_array_spec as; + gfc_se se; + int i; + vec *v = NULL; + + /* First traverse the constructor list, converting the constants + to tree to build an initializer. */ + nelem = 0; + c = gfc_constructor_first (expr->value.constructor); + while (c) + { + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, c->expr); + if (c->expr->ts.type != BT_CHARACTER) + se.expr = fold_convert (type, se.expr); + else if (POINTER_TYPE_P (type)) + se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind), + se.expr); + CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem), + se.expr); + c = gfc_constructor_next (c); + nelem++; + } + + /* Next determine the tree type for the array. We use the gfortran + front-end's gfc_get_nodesc_array_type in order to create a suitable + GFC_ARRAY_TYPE_P that may be used by the scalarizer. */ + + memset (&as, 0, sizeof (gfc_array_spec)); + + as.rank = expr->rank; + as.type = AS_EXPLICIT; + if (!expr->shape) + { + as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, nelem - 1); + } + else + for (i = 0; i < expr->rank; i++) + { + int tmp = (int) mpz_get_si (expr->shape[i]); + as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind, + NULL, tmp - 1); + } + + tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true); + + /* as is not needed anymore. */ + for (i = 0; i < as.rank + as.corank; i++) + { + gfc_free_expr (as.lower[i]); + gfc_free_expr (as.upper[i]); + } + + init = build_constructor (tmptype, v); + + TREE_CONSTANT (init) = 1; + TREE_STATIC (init) = 1; + + tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"), + tmptype); + DECL_ARTIFICIAL (tmp) = 1; + DECL_IGNORED_P (tmp) = 1; + TREE_STATIC (tmp) = 1; + TREE_CONSTANT (tmp) = 1; + TREE_READONLY (tmp) = 1; + DECL_INITIAL (tmp) = init; + pushdecl (tmp); + + return tmp; +} + + +/* Translate a constant EXPR_ARRAY array constructor for the scalarizer. + This mostly initializes the scalarizer state info structure with the + appropriate values to directly use the array created by the function + gfc_build_constant_array_constructor. */ + +static void +trans_constant_array_constructor (gfc_ss * ss, tree type) +{ + gfc_array_info *info; + tree tmp; + int i; + + tmp = gfc_build_constant_array_constructor (ss->info->expr, type); + + info = &ss->info->data.array; + + info->descriptor = tmp; + info->data = gfc_build_addr_expr (NULL_TREE, tmp); + info->offset = gfc_index_zero_node; + + for (i = 0; i < ss->dimen; i++) + { + info->delta[i] = gfc_index_zero_node; + info->start[i] = gfc_index_zero_node; + info->end[i] = gfc_index_zero_node; + info->stride[i] = gfc_index_one_node; + } +} + + +static int +get_rank (gfc_loopinfo *loop) +{ + int rank; + + rank = 0; + for (; loop; loop = loop->parent) + rank += loop->dimen; + + return rank; +} + + +/* Helper routine of gfc_trans_array_constructor to determine if the + bounds of the loop specified by LOOP are constant and simple enough + to use with trans_constant_array_constructor. Returns the + iteration count of the loop if suitable, and NULL_TREE otherwise. */ + +static tree +constant_array_constructor_loop_size (gfc_loopinfo * l) +{ + gfc_loopinfo *loop; + tree size = gfc_index_one_node; + tree tmp; + int i, total_dim; + + total_dim = get_rank (l); + + for (loop = l; loop; loop = loop->parent) + { + for (i = 0; i < loop->dimen; i++) + { + /* If the bounds aren't constant, return NULL_TREE. */ + if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) + return NULL_TREE; + if (!integer_zerop (loop->from[i])) + { + /* Only allow nonzero "from" in one-dimensional arrays. */ + if (total_dim != 1) + return NULL_TREE; + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[i], loop->from[i]); + } + else + tmp = loop->to[i]; + 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); + } + } + + return size; +} + + +static tree * +get_loop_upper_bound_for_array (gfc_ss *array, int array_dim) +{ + gfc_ss *ss; + int n; + + gcc_assert (array->nested_ss == NULL); + + for (ss = array; ss; ss = ss->parent) + for (n = 0; n < ss->loop->dimen; n++) + if (array_dim == get_array_ref_dim_for_loop_dim (ss, n)) + return &(ss->loop->to[n]); + + gcc_unreachable (); +} + + +static gfc_loopinfo * +outermost_loop (gfc_loopinfo * loop) +{ + while (loop->parent != NULL) + loop = loop->parent; + + return loop; +} + + +/* Array constructors are handled by constructing a temporary, then using that + within the scalarization loop. This is not optimal, but seems by far the + simplest method. */ + +static void +trans_array_constructor (gfc_ss * ss, locus * where) +{ + gfc_constructor_base c; + tree offset; + tree offsetvar; + tree desc; + tree type; + tree tmp; + tree *loop_ubound0; + bool dynamic; + bool old_first_len, old_typespec_chararray_ctor; + tree old_first_len_val; + gfc_loopinfo *loop, *outer_loop; + gfc_ss_info *ss_info; + gfc_expr *expr; + gfc_ss *s; + tree neg_len; + char *msg; + + /* Save the old values for nested checking. */ + old_first_len = first_len; + old_first_len_val = first_len_val; + old_typespec_chararray_ctor = typespec_chararray_ctor; + + loop = ss->loop; + outer_loop = outermost_loop (loop); + ss_info = ss->info; + expr = ss_info->expr; + + /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no + typespec was given for the array constructor. */ + typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER + && expr->ts.u.cl + && expr->ts.u.cl->length_from_typespec); + + if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) + { + first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); + first_len = true; + } + + gcc_assert (ss->dimen == ss->loop->dimen); + + c = expr->value.constructor; + if (expr->ts.type == BT_CHARACTER) + { + bool const_string; + bool force_new_cl = false; + + /* get_array_ctor_strlen walks the elements of the constructor, if a + typespec was given, we already know the string length and want the one + specified there. */ + if (typespec_chararray_ctor && expr->ts.u.cl->length + && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) + { + gfc_se length_se; + + const_string = false; + gfc_init_se (&length_se, NULL); + gfc_conv_expr_type (&length_se, expr->ts.u.cl->length, + gfc_charlen_type_node); + ss_info->string_length = length_se.expr; + + /* Check if the character length is negative. If it is, then + set LEN = 0. */ + neg_len = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, ss_info->string_length, + build_zero_cst (TREE_TYPE + (ss_info->string_length))); + /* Print a warning if bounds checking is enabled. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + msg = xasprintf ("Negative character length treated as LEN = 0"); + gfc_trans_runtime_check (false, true, neg_len, &length_se.pre, + where, msg); + free (msg); + } + + ss_info->string_length + = fold_build3_loc (input_location, COND_EXPR, + gfc_charlen_type_node, neg_len, + build_zero_cst + (TREE_TYPE (ss_info->string_length)), + ss_info->string_length); + ss_info->string_length = gfc_evaluate_now (ss_info->string_length, + &length_se.pre); + gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); + gfc_add_block_to_block (&outer_loop->post, &length_se.post); + } + else + { + const_string = get_array_ctor_strlen (&outer_loop->pre, c, + &ss_info->string_length); + force_new_cl = true; + } + + /* Complex character array constructors should have been taken care of + and not end up here. */ + gcc_assert (ss_info->string_length); + + store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl); + + type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length); + if (const_string) + type = build_pointer_type (type); + } + else + type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS + ? &CLASS_DATA (expr)->ts : &expr->ts); + + /* See if the constructor determines the loop bounds. */ + dynamic = false; + + loop_ubound0 = get_loop_upper_bound_for_array (ss, 0); + + if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE) + { + /* We have a multidimensional parameter. */ + for (s = ss; s; s = s->parent) + { + int n; + for (n = 0; n < s->loop->dimen; n++) + { + s->loop->from[n] = gfc_index_zero_node; + s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]], + gfc_index_integer_kind); + s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + s->loop->to[n], + gfc_index_one_node); + } + } + } + + if (*loop_ubound0 == NULL_TREE) + { + mpz_t size; + + /* We should have a 1-dimensional, zero-based loop. */ + gcc_assert (loop->parent == NULL && loop->nested == NULL); + gcc_assert (loop->dimen == 1); + gcc_assert (integer_zerop (loop->from[0])); + + /* Split the constructor size into a static part and a dynamic part. + Allocate the static size up-front and record whether the dynamic + size might be nonzero. */ + mpz_init (size); + dynamic = gfc_get_array_constructor_size (&size, c); + mpz_sub_ui (size, size, 1); + loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind); + mpz_clear (size); + } + + /* Special case constant array constructors. */ + if (!dynamic) + { + unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c); + if (nelem > 0) + { + tree size = constant_array_constructor_loop_size (loop); + if (size && compare_tree_int (size, nelem) == 0) + { + trans_constant_array_constructor (ss, type); + goto finish; + } + } + } + + gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, + NULL_TREE, dynamic, true, false, where); + + desc = ss_info->data.array.descriptor; + offset = gfc_index_zero_node; + offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); + suppress_warning (offsetvar); + TREE_USED (offsetvar) = 0; + gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, + &offset, &offsetvar, dynamic); + + /* If the array grows dynamically, the upper bound of the loop variable + is determined by the array's final upper bound. */ + if (dynamic) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offsetvar, gfc_index_one_node); + tmp = gfc_evaluate_now (tmp, &outer_loop->pre); + gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); + if (*loop_ubound0 && VAR_P (*loop_ubound0)) + gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); + else + *loop_ubound0 = tmp; + } + + if (TREE_USED (offsetvar)) + pushdecl (offsetvar); + else + gcc_assert (INTEGER_CST_P (offset)); + +#if 0 + /* Disable bound checking for now because it's probably broken. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + gcc_unreachable (); + } +#endif + +finish: + /* Restore old values of globals. */ + first_len = old_first_len; + first_len_val = old_first_len_val; + typespec_chararray_ctor = old_typespec_chararray_ctor; +} + + +/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is + called after evaluating all of INFO's vector dimensions. Go through + each such vector dimension and see if we can now fill in any missing + loop bounds. */ + +static void +set_vector_loop_bounds (gfc_ss * ss) +{ + gfc_loopinfo *loop, *outer_loop; + gfc_array_info *info; + gfc_se se; + tree tmp; + tree desc; + tree zero; + int n; + int dim; + + outer_loop = outermost_loop (ss->loop); + + info = &ss->info->data.array; + + for (; ss; ss = ss->parent) + { + loop = ss->loop; + + for (n = 0; n < loop->dimen; n++) + { + dim = ss->dim[n]; + if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR + || loop->to[n] != NULL) + continue; + + /* Loop variable N indexes vector dimension DIM, and we don't + yet know the upper bound of loop variable N. Set it to the + difference between the vector's upper and lower bounds. */ + gcc_assert (loop->from[n] == gfc_index_zero_node); + gcc_assert (info->subscript[dim] + && info->subscript[dim]->info->type == GFC_SS_VECTOR); + + gfc_init_se (&se, NULL); + desc = info->subscript[dim]->info->data.array.descriptor; + zero = gfc_rank_cst[0]; + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, zero), + gfc_conv_descriptor_lbound_get (desc, zero)); + tmp = gfc_evaluate_now (tmp, &outer_loop->pre); + loop->to[n] = tmp; + } + } +} + + +/* Tells whether a scalar argument to an elemental procedure is saved out + of a scalarization loop as a value or as a reference. */ + +bool +gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info) +{ + if (ss_info->type != GFC_SS_REFERENCE) + return false; + + if (ss_info->data.scalar.needs_temporary) + return false; + + /* If the actual argument can be absent (in other words, it can + be a NULL reference), don't try to evaluate it; pass instead + the reference directly. */ + if (ss_info->can_be_null_ref) + return true; + + /* If the expression is of polymorphic type, it's actual size is not known, + so we avoid copying it anywhere. */ + if (ss_info->data.scalar.dummy_arg + && gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type + == BT_CLASS + && ss_info->expr->ts.type == BT_CLASS) + return true; + + /* If the expression is a data reference of aggregate type, + and the data reference is not used on the left hand side, + avoid a copy by saving a reference to the content. */ + if (!ss_info->data.scalar.needs_temporary + && (ss_info->expr->ts.type == BT_DERIVED + || ss_info->expr->ts.type == BT_CLASS) + && gfc_expr_is_variable (ss_info->expr)) + return true; + + /* Otherwise the expression is evaluated to a temporary variable before the + scalarization loop. */ + return false; +} + + +/* Add the pre and post chains for all the scalar expressions in a SS chain + to loop. This is called after the loop parameters have been calculated, + but before the actual scalarizing loops. */ + +static void +gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, + locus * where) +{ + gfc_loopinfo *nested_loop, *outer_loop; + gfc_se se; + gfc_ss_info *ss_info; + gfc_array_info *info; + gfc_expr *expr; + int n; + + /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise, + arguments could get evaluated multiple times. */ + if (ss->is_alloc_lhs) + return; + + outer_loop = outermost_loop (loop); + + /* TODO: This can generate bad code if there are ordering dependencies, + e.g., a callee allocated function and an unknown size constructor. */ + gcc_assert (ss != NULL); + + for (; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + gcc_assert (ss); + + /* Cross loop arrays are handled from within the most nested loop. */ + if (ss->nested_ss != NULL) + continue; + + ss_info = ss->info; + expr = ss_info->expr; + info = &ss_info->data.array; + + switch (ss_info->type) + { + case GFC_SS_SCALAR: + /* Scalar expression. Evaluate this now. This includes elemental + dimension indices, but not array section bounds. */ + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + + if (expr->ts.type != BT_CHARACTER + && !gfc_is_alloc_class_scalar_function (expr)) + { + /* Move the evaluation of scalar expressions outside the + scalarization loop, except for WHERE assignments. */ + if (subscript) + se.expr = convert(gfc_array_index_type, se.expr); + if (!ss_info->where) + se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre); + gfc_add_block_to_block (&outer_loop->pre, &se.post); + } + else + gfc_add_block_to_block (&outer_loop->post, &se.post); + + ss_info->data.scalar.value = se.expr; + ss_info->string_length = se.string_length; + break; + + case GFC_SS_REFERENCE: + /* Scalar argument to elemental procedure. */ + gfc_init_se (&se, NULL); + if (gfc_scalar_elemental_arg_saved_as_reference (ss_info)) + gfc_conv_expr_reference (&se, expr); + else + { + /* Evaluate the argument outside the loop and pass + a reference to the value. */ + gfc_conv_expr (&se, expr); + } + + /* Ensure that a pointer to the string is stored. */ + if (expr->ts.type == BT_CHARACTER) + gfc_conv_string_parameter (&se); + + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); + if (gfc_is_class_scalar_expr (expr)) + /* This is necessary because the dynamic type will always be + large than the declared type. In consequence, assigning + the value to a temporary could segfault. + OOP-TODO: see if this is generally correct or is the value + has to be written to an allocated temporary, whose address + is passed via ss_info. */ + ss_info->data.scalar.value = se.expr; + else + ss_info->data.scalar.value = gfc_evaluate_now (se.expr, + &outer_loop->pre); + + ss_info->string_length = se.string_length; + break; + + case GFC_SS_SECTION: + /* Add the expressions for scalar and vector subscripts. */ + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + if (info->subscript[n]) + gfc_add_loop_ss_code (loop, info->subscript[n], true, where); + + set_vector_loop_bounds (ss); + break; + + case GFC_SS_VECTOR: + /* Get the vector's descriptor and store it in SS. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_descriptor (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); + info->descriptor = se.expr; + break; + + case GFC_SS_INTRINSIC: + gfc_add_intrinsic_ss_code (loop, ss); + break; + + case GFC_SS_FUNCTION: + /* Array function return value. We call the function and save its + result in a temporary for use inside the loop. */ + gfc_init_se (&se, NULL); + se.loop = loop; + se.ss = ss; + if (gfc_is_class_array_function (expr)) + expr->must_finalize = 1; + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); + ss_info->string_length = se.string_length; + break; + + case GFC_SS_CONSTRUCTOR: + if (expr->ts.type == BT_CHARACTER + && ss_info->string_length == NULL + && expr->ts.u.cl + && expr->ts.u.cl->length + && expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, expr->ts.u.cl->length, + gfc_charlen_type_node); + ss_info->string_length = se.expr; + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); + } + trans_array_constructor (ss, where); + break; + + case GFC_SS_TEMP: + case GFC_SS_COMPONENT: + /* Do nothing. These are handled elsewhere. */ + break; + + default: + gcc_unreachable (); + } + } + + if (!subscript) + for (nested_loop = loop->nested; nested_loop; + nested_loop = nested_loop->next) + gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); +} + + +/* Translate expressions for the descriptor and data pointer of a SS. */ +/*GCC ARRAYS*/ + +static void +gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) +{ + gfc_se se; + gfc_ss_info *ss_info; + gfc_array_info *info; + tree tmp; + + ss_info = ss->info; + info = &ss_info->data.array; + + /* Get the descriptor for the array to be scalarized. */ + gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE); + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr_lhs (&se, ss_info->expr); + gfc_add_block_to_block (block, &se.pre); + info->descriptor = se.expr; + ss_info->string_length = se.string_length; + + if (base) + { + if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred + && ss_info->expr->ts.u.cl->length == NULL) + { + /* Emit a DECL_EXPR for the variable sized array type in + GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type + sizes works correctly. */ + tree arraytype = TREE_TYPE ( + GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor))); + if (! TYPE_NAME (arraytype)) + TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL, + NULL_TREE, arraytype); + gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype, + TYPE_NAME (arraytype))); + } + /* Also the data pointer. */ + tmp = gfc_conv_array_data (se.expr); + /* If this is a variable or address or a class array, use it directly. + Otherwise we must evaluate it now to avoid breaking dependency + analysis by pulling the expressions for elemental array indices + inside the loop. */ + if (!(DECL_P (tmp) + || (TREE_CODE (tmp) == ADDR_EXPR + && DECL_P (TREE_OPERAND (tmp, 0))) + || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) + && TREE_CODE (se.expr) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))) + tmp = gfc_evaluate_now (tmp, block); + info->data = tmp; + + tmp = gfc_conv_array_offset (se.expr); + info->offset = gfc_evaluate_now (tmp, block); + + /* Make absolutely sure that the saved_offset is indeed saved + so that the variable is still accessible after the loops + are translated. */ + info->saved_offset = info->offset; + } +} + + +/* Initialize a gfc_loopinfo structure. */ + +void +gfc_init_loopinfo (gfc_loopinfo * loop) +{ + int n; + + memset (loop, 0, sizeof (gfc_loopinfo)); + gfc_init_block (&loop->pre); + gfc_init_block (&loop->post); + + /* Initially scalarize in order and default to no loop reversal. */ + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + { + loop->order[n] = n; + loop->reverse[n] = GFC_INHIBIT_REVERSE; + } + + loop->ss = gfc_ss_terminator; +} + + +/* Copies the loop variable info to a gfc_se structure. Does not copy the SS + chain. */ + +void +gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop) +{ + se->loop = loop; +} + + +/* Return an expression for the data pointer of an array. */ + +tree +gfc_conv_array_data (tree descriptor) +{ + tree type; + + type = TREE_TYPE (descriptor); + if (GFC_ARRAY_TYPE_P (type)) + { + if (TREE_CODE (type) == POINTER_TYPE) + return descriptor; + else + { + /* Descriptorless arrays. */ + return gfc_build_addr_expr (NULL_TREE, descriptor); + } + } + else + return gfc_conv_descriptor_data_get (descriptor); +} + + +/* Return an expression for the base offset of an array. */ + +tree +gfc_conv_array_offset (tree descriptor) +{ + tree type; + + type = TREE_TYPE (descriptor); + if (GFC_ARRAY_TYPE_P (type)) + return GFC_TYPE_ARRAY_OFFSET (type); + else + return gfc_conv_descriptor_offset_get (descriptor); +} + + +/* Get an expression for the array stride. */ + +tree +gfc_conv_array_stride (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + /* For descriptorless arrays use the array size. */ + tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); + if (tmp != NULL_TREE) + return tmp; + + tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + +/* Like gfc_conv_array_stride, but for the lower bound. */ + +tree +gfc_conv_array_lbound (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (tmp != NULL_TREE) + return tmp; + + tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + +/* Like gfc_conv_array_stride, but for the upper bound. */ + +tree +gfc_conv_array_ubound (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + tmp = GFC_TYPE_ARRAY_UBOUND (type, dim); + if (tmp != NULL_TREE) + return tmp; + + /* This should only ever happen when passing an assumed shape array + as an actual parameter. The value will never be used. */ + if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))) + return gfc_index_zero_node; + + tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + +/* Generate code to perform an array index bound check. */ + +static tree +trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, + locus * where, bool check_upper) +{ + tree fault; + tree tmp_lo, tmp_up; + tree descriptor; + char *msg; + const char * name = NULL; + + if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) + return index; + + descriptor = ss->info->data.array.descriptor; + + index = gfc_evaluate_now (index, &se->pre); + + /* We find a name for the error message. */ + name = ss->info->expr->symtree->n.sym->name; + gcc_assert (name != NULL); + + if (VAR_P (descriptor)) + name = IDENTIFIER_POINTER (DECL_NAME (descriptor)); + + /* If upper bound is present, include both bounds in the error message. */ + if (check_upper) + { + tmp_lo = gfc_conv_array_lbound (descriptor, n); + tmp_up = gfc_conv_array_ubound (descriptor, n); + + if (name) + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "outside of expected range (%%ld:%%ld)", n+1, name); + else + msg = xasprintf ("Index '%%ld' of dimension %d " + "outside of expected range (%%ld:%%ld)", n+1); + + fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + index, tmp_lo); + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, + fold_convert (long_integer_type_node, index), + fold_convert (long_integer_type_node, tmp_lo), + fold_convert (long_integer_type_node, tmp_up)); + fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + index, tmp_up); + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, + fold_convert (long_integer_type_node, index), + fold_convert (long_integer_type_node, tmp_lo), + fold_convert (long_integer_type_node, tmp_up)); + free (msg); + } + else + { + tmp_lo = gfc_conv_array_lbound (descriptor, n); + + if (name) + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", n+1, name); + else + msg = xasprintf ("Index '%%ld' of dimension %d " + "below lower bound of %%ld", n+1); + + fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + index, tmp_lo); + gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, + fold_convert (long_integer_type_node, index), + fold_convert (long_integer_type_node, tmp_lo)); + free (msg); + } + + return index; +} + + +/* Return the offset for an index. Performs bound checking for elemental + dimensions. Single element references are processed separately. + DIM is the array dimension, I is the loop dimension. */ + +static tree +conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, + gfc_array_ref * ar, tree stride) +{ + gfc_array_info *info; + tree index; + tree desc; + tree data; + + info = &ss->info->data.array; + + /* Get the index into the array for this dimension. */ + if (ar) + { + gcc_assert (ar->type != AR_ELEMENT); + switch (ar->dimen_type[dim]) + { + case DIMEN_THIS_IMAGE: + gcc_unreachable (); + break; + case DIMEN_ELEMENT: + /* Elemental dimension. */ + gcc_assert (info->subscript[dim] + && info->subscript[dim]->info->type == GFC_SS_SCALAR); + /* We've already translated this value outside the loop. */ + index = info->subscript[dim]->info->data.scalar.value; + + index = trans_array_bound_check (se, ss, index, dim, &ar->where, + ar->as->type != AS_ASSUMED_SIZE + || dim < ar->dimen - 1); + break; + + case DIMEN_VECTOR: + gcc_assert (info && se->loop); + gcc_assert (info->subscript[dim] + && info->subscript[dim]->info->type == GFC_SS_VECTOR); + desc = info->subscript[dim]->info->data.array.descriptor; + + /* Get a zero-based index into the vector. */ + index = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + se->loop->loopvar[i], se->loop->from[i]); + + /* Multiply the index by the stride. */ + index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + index, gfc_conv_array_stride (desc, 0)); + + /* Read the vector to get an index into info->descriptor. */ + data = build_fold_indirect_ref_loc (input_location, + gfc_conv_array_data (desc)); + index = gfc_build_array_ref (data, index, NULL); + index = gfc_evaluate_now (index, &se->pre); + index = fold_convert (gfc_array_index_type, index); + + /* Do any bounds checking on the final info->descriptor index. */ + index = trans_array_bound_check (se, ss, index, dim, &ar->where, + ar->as->type != AS_ASSUMED_SIZE + || dim < ar->dimen - 1); + break; + + case DIMEN_RANGE: + /* Scalarized dimension. */ + gcc_assert (info && se->loop); + + /* Multiply the loop variable by the stride and delta. */ + index = se->loop->loopvar[i]; + if (!integer_onep (info->stride[dim])) + index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, index, + info->stride[dim]); + if (!integer_zerop (info->delta[dim])) + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, index, + info->delta[dim]); + break; + + default: + gcc_unreachable (); + } + } + else + { + /* Temporary array or derived type component. */ + gcc_assert (se->loop); + index = se->loop->loopvar[se->loop->order[i]]; + + /* Pointer functions can have stride[0] different from unity. + Use the stride returned by the function call and stored in + the descriptor for the temporary. */ + if (se->ss && se->ss->info->type == GFC_SS_FUNCTION + && se->ss->info->expr + && se->ss->info->expr->symtree + && se->ss->info->expr->symtree->n.sym->result + && se->ss->info->expr->symtree->n.sym->result->attr.pointer) + stride = gfc_conv_descriptor_stride_get (info->descriptor, + gfc_rank_cst[dim]); + + if (info->delta[dim] && !integer_zerop (info->delta[dim])) + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, index, info->delta[dim]); + } + + /* Multiply by the stride. */ + if (stride != NULL && !integer_onep (stride)) + index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + index, stride); + + return index; +} + + +/* Build a scalarized array reference using the vptr 'size'. */ + +static bool +build_class_array_ref (gfc_se *se, tree base, tree index) +{ + tree size; + tree decl = NULL_TREE; + tree tmp; + gfc_expr *expr = se->ss->info->expr; + gfc_expr *class_expr; + gfc_typespec *ts; + gfc_symbol *sym; + + tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE; + + if (tmp != NULL_TREE) + decl = tmp; + else + { + /* The base expression does not contain a class component, either + because it is a temporary array or array descriptor. Class + array functions are correctly resolved above. */ + if (!expr + || (expr->ts.type != BT_CLASS + && !gfc_is_class_array_ref (expr, NULL))) + return false; + + /* Obtain the expression for the class entity or component that is + followed by an array reference, which is not an element, so that + the span of the array can be obtained. */ + class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts); + + if (!ts) + return false; + + sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL; + if (sym && sym->attr.function + && sym == sym->result + && sym->backend_decl == current_function_decl) + /* The temporary is the data field of the class data component + of the current function. */ + decl = gfc_get_fake_result_decl (sym, 0); + else if (sym) + { + if (decl == NULL_TREE) + decl = expr->symtree->n.sym->backend_decl; + /* For class arrays the tree containing the class is stored in + GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. + For all others it's sym's backend_decl directly. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + } + else + decl = gfc_get_class_from_gfc_expr (class_expr); + + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl))) + return false; + } + + se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre); + + size = gfc_class_vtab_size_get (decl); + /* For unlimited polymorphic entities then _len component needs to be + multiplied with the size. */ + size = gfc_resize_class_size_with_len (&se->pre, decl, size); + size = fold_convert (TREE_TYPE (index), size); + + /* Return the element in the se expression. */ + se->expr = gfc_build_spanned_array_ref (base, index, size); + return true; +} + + +/* Build a scalarized reference to an array. */ + +static void +gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) +{ + gfc_array_info *info; + tree decl = NULL_TREE; + tree index; + tree base; + gfc_ss *ss; + gfc_expr *expr; + int n; + + ss = se->ss; + expr = ss->info->expr; + info = &ss->info->data.array; + if (ar) + n = se->loop->order[0]; + else + n = 0; + + index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0); + /* Add the offset for this dimension to the stored offset for all other + dimensions. */ + if (info->offset && !integer_zerop (info->offset)) + index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + index, info->offset); + + base = build_fold_indirect_ref_loc (input_location, info->data); + + /* Use the vptr 'size' field to access the element of a class array. */ + if (build_class_array_ref (se, base, index)) + return; + + if (get_CFI_desc (NULL, expr, &decl, ar)) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* A pointer array component can be detected from its field decl. Fix + the descriptor, mark the resulting variable decl and pass it to + gfc_build_array_ref. */ + if (is_pointer_array (info->descriptor) + || (expr && expr->ts.deferred && info->descriptor + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))) + { + if (TREE_CODE (info->descriptor) == COMPONENT_REF) + decl = info->descriptor; + else if (TREE_CODE (info->descriptor) == INDIRECT_REF) + decl = TREE_OPERAND (info->descriptor, 0); + + if (decl == NULL_TREE) + decl = info->descriptor; + } + + se->expr = gfc_build_array_ref (base, index, decl); +} + + +/* Translate access of temporary array. */ + +void +gfc_conv_tmp_array_ref (gfc_se * se) +{ + se->string_length = se->ss->info->string_length; + gfc_conv_scalarized_array_ref (se, NULL); + gfc_advance_se_ss_chain (se); +} + +/* Add T to the offset pair *OFFSET, *CST_OFFSET. */ + +static void +add_to_offset (tree *cst_offset, tree *offset, tree t) +{ + if (TREE_CODE (t) == INTEGER_CST) + *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t); + else + { + if (!integer_zerop (*offset)) + *offset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, *offset, t); + else + *offset = t; + } +} + + +static tree +build_array_ref (tree desc, tree offset, tree decl, tree vptr) +{ + tree tmp; + tree type; + tree cdesc; + + /* For class arrays the class declaration is stored in the saved + descriptor. */ + if (INDIRECT_REF_P (desc) + && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0)) + && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0))) + cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( + TREE_OPERAND (desc, 0))); + else + cdesc = desc; + + /* Class container types do not always have the GFC_CLASS_TYPE_P + but the canonical type does. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc)) + && TREE_CODE (cdesc) == COMPONENT_REF) + { + type = TREE_TYPE (TREE_OPERAND (cdesc, 0)); + if (TYPE_CANONICAL (type) + && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) + vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0)); + } + + tmp = gfc_conv_array_data (desc); + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = gfc_build_array_ref (tmp, offset, decl, vptr); + return tmp; +} + + +/* Build an array reference. se->expr already holds the array descriptor. + This should be either a variable, indirect variable reference or component + reference. For arrays which do not have a descriptor, se->expr will be + the data pointer. + a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ + +void +gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, + locus * where) +{ + int n; + tree offset, cst_offset; + tree tmp; + tree stride; + tree decl = NULL_TREE; + gfc_se indexse; + gfc_se tmpse; + gfc_symbol * sym = expr->symtree->n.sym; + char *var_name = NULL; + + if (ar->dimen == 0) + { + gcc_assert (ar->codimen || sym->attr.select_rank_temporary + || (ar->as && ar->as->corank)); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) + se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); + else + { + if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + + /* Use the actual tree type and not the wrapped coarray. */ + if (!se->want_pointer) + se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), + se->expr); + } + + return; + } + + /* Handle scalarized references separately. */ + if (ar->type != AR_ELEMENT) + { + gfc_conv_scalarized_array_ref (se, ar); + gfc_advance_se_ss_chain (se); + return; + } + + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + size_t len; + gfc_ref *ref; + + len = strlen (sym->name) + 1; + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && &ref->u.ar == ar) + break; + if (ref->type == REF_COMPONENT) + len += 2 + strlen (ref->u.c.component->name); + } + + var_name = XALLOCAVEC (char, len); + strcpy (var_name, sym->name); + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && &ref->u.ar == ar) + break; + if (ref->type == REF_COMPONENT) + { + strcat (var_name, "%%"); + strcat (var_name, ref->u.c.component->name); + } + } + } + + decl = se->expr; + if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED) + decl = sym->backend_decl; + + cst_offset = offset = gfc_index_zero_node; + add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl)); + + /* Calculate the offsets from all the dimensions. Make sure to associate + the final offset so that we form a chain of loop invariant summands. */ + for (n = ar->dimen - 1; n >= 0; n--) + { + /* Calculate the index for this dimension. */ + gfc_init_se (&indexse, se); + gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &indexse.pre); + + if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check) + { + /* Check array bounds. */ + tree cond; + char *msg; + + /* Evaluate the indexse.expr only once. */ + indexse.expr = save_expr (indexse.expr); + + /* Lower bound. */ + tmp = gfc_conv_array_lbound (decl, n); + if (sym->attr.temporary) + { + gfc_init_se (&tmpse, se); + gfc_conv_expr_type (&tmpse, ar->as->lower[n], + gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + tmp = tmpse.expr; + } + + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + indexse.expr, tmp); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", n+1, var_name); + gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, + fold_convert (long_integer_type_node, + indexse.expr), + fold_convert (long_integer_type_node, tmp)); + free (msg); + + /* Upper bound, but not for the last dimension of assumed-size + arrays. */ + if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE) + { + tmp = gfc_conv_array_ubound (decl, n); + if (sym->attr.temporary) + { + gfc_init_se (&tmpse, se); + gfc_conv_expr_type (&tmpse, ar->as->upper[n], + gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + tmp = tmpse.expr; + } + + cond = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, indexse.expr, tmp); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "above upper bound of %%ld", n+1, var_name); + gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, + fold_convert (long_integer_type_node, + indexse.expr), + fold_convert (long_integer_type_node, tmp)); + free (msg); + } + } + + /* Multiply the index by the stride. */ + stride = gfc_conv_array_stride (decl, n); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + indexse.expr, stride); + + /* And add it to the total. */ + add_to_offset (&cst_offset, &offset, tmp); + } + + if (!integer_zerop (cst_offset)) + offset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offset, cst_offset); + + /* A pointer array component can be detected from its field decl. Fix + the descriptor, mark the resulting variable decl and pass it to + build_array_ref. */ + decl = NULL_TREE; + if (get_CFI_desc (sym, expr, &decl, ar)) + decl = build_fold_indirect_ref_loc (input_location, decl); + if (!expr->ts.deferred && !sym->attr.codimension + && is_pointer_array (se->expr)) + { + if (TREE_CODE (se->expr) == COMPONENT_REF) + decl = se->expr; + else if (TREE_CODE (se->expr) == INDIRECT_REF) + decl = TREE_OPERAND (se->expr, 0); + else + decl = se->expr; + } + else if (expr->ts.deferred + || (sym->ts.type == BT_CHARACTER + && sym->attr.select_type_temporary)) + { + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) + { + decl = se->expr; + if (TREE_CODE (decl) == INDIRECT_REF) + decl = TREE_OPERAND (decl, 0); + } + else + decl = sym->backend_decl; + } + else if (sym->ts.type == BT_CLASS) + { + if (UNLIMITED_POLY (sym)) + { + gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); + gfc_init_se (&tmpse, NULL); + gfc_conv_expr (&tmpse, class_expr); + if (!se->class_vptr) + se->class_vptr = gfc_class_vptr_get (tmpse.expr); + gfc_free_expr (class_expr); + decl = tmpse.expr; + } + else + decl = NULL_TREE; + } + + se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); +} + + +/* Add the offset corresponding to array's ARRAY_DIM dimension and loop's + LOOP_DIM dimension (if any) to array's offset. */ + +static void +add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss, + gfc_array_ref *ar, int array_dim, int loop_dim) +{ + gfc_se se; + gfc_array_info *info; + tree stride, index; + + info = &ss->info->data.array; + + gfc_init_se (&se, NULL); + se.loop = loop; + se.expr = info->descriptor; + stride = gfc_conv_array_stride (info->descriptor, array_dim); + index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride); + gfc_add_block_to_block (pblock, &se.pre); + + info->offset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + info->offset, index); + info->offset = gfc_evaluate_now (info->offset, pblock); +} + + +/* Generate the code to be executed immediately before entering a + scalarization loop. */ + +static void +gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, + stmtblock_t * pblock) +{ + tree stride; + gfc_ss_info *ss_info; + gfc_array_info *info; + gfc_ss_type ss_type; + gfc_ss *ss, *pss; + gfc_loopinfo *ploop; + gfc_array_ref *ar; + int i; + + /* This code will be executed before entering the scalarization loop + for this dimension. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + ss_info = ss->info; + + if ((ss_info->useflags & flag) == 0) + continue; + + ss_type = ss_info->type; + if (ss_type != GFC_SS_SECTION + && ss_type != GFC_SS_FUNCTION + && ss_type != GFC_SS_CONSTRUCTOR + && ss_type != GFC_SS_COMPONENT) + continue; + + info = &ss_info->data.array; + + gcc_assert (dim < ss->dimen); + gcc_assert (ss->dimen == loop->dimen); + + if (info->ref) + ar = &info->ref->u.ar; + else + ar = NULL; + + if (dim == loop->dimen - 1 && loop->parent != NULL) + { + /* If we are in the outermost dimension of this loop, the previous + dimension shall be in the parent loop. */ + gcc_assert (ss->parent != NULL); + + pss = ss->parent; + ploop = loop->parent; + + /* ss and ss->parent are about the same array. */ + gcc_assert (ss_info == pss->info); + } + else + { + ploop = loop; + pss = ss; + } + + if (dim == loop->dimen - 1) + i = 0; + else + i = dim + 1; + + /* For the time being, there is no loop reordering. */ + gcc_assert (i == ploop->order[i]); + i = ploop->order[i]; + + if (dim == loop->dimen - 1 && loop->parent == NULL) + { + stride = gfc_conv_array_stride (info->descriptor, + innermost_ss (ss)->dim[i]); + + /* Calculate the stride of the innermost loop. Hopefully this will + allow the backend optimizers to do their stuff more effectively. + */ + info->stride0 = gfc_evaluate_now (stride, pblock); + + /* For the outermost loop calculate the offset due to any + elemental dimensions. It will have been initialized with the + base offset of the array. */ + if (info->ref) + { + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT) + continue; + + add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1); + } + } + } + else + /* Add the offset for the previous loop dimension. */ + add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i); + + /* Remember this offset for the second loop. */ + if (dim == loop->temp_dim - 1 && loop->parent == NULL) + info->saved_offset = info->offset; + } +} + + +/* Start a scalarized expression. Creates a scope and declares loop + variables. */ + +void +gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) +{ + int dim; + int n; + int flags; + + gcc_assert (!loop->array_parameter); + + for (dim = loop->dimen - 1; dim >= 0; dim--) + { + n = loop->order[dim]; + + gfc_start_block (&loop->code[n]); + + /* Create the loop variable. */ + loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S"); + + if (dim < loop->temp_dim) + flags = 3; + else + flags = 1; + /* Calculate values that will be constant within this loop. */ + gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]); + } + gfc_start_block (pbody); +} + + +/* Generates the actual loop code for a scalarization loop. */ + +static void +gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, + stmtblock_t * pbody) +{ + stmtblock_t block; + tree cond; + tree tmp; + tree loopbody; + tree exit_label; + tree stmt; + tree init; + tree incr; + + if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS + | OMPWS_SCALARIZER_BODY)) + == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS) + && n == loop->dimen - 1) + { + /* We create an OMP_FOR construct for the outermost scalarized loop. */ + init = make_tree_vec (1); + cond = make_tree_vec (1); + incr = make_tree_vec (1); + + /* Cycle statement is implemented with a goto. Exit statement must not + be present for this loop. */ + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + /* Label for cycle statements (if needed). */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (pbody, tmp); + + stmt = make_node (OMP_FOR); + + TREE_TYPE (stmt) = void_type_node; + OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody); + + OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location, + OMP_CLAUSE_SCHEDULE); + OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt)) + = OMP_CLAUSE_SCHEDULE_STATIC; + if (ompws_flags & OMPWS_NOWAIT) + OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt)) + = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT); + + /* Initialize the loopvar. */ + TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n], + loop->from[n]); + OMP_FOR_INIT (stmt) = init; + /* The exit condition. */ + TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR, + logical_type_node, + loop->loopvar[n], loop->to[n]); + SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location); + OMP_FOR_COND (stmt) = cond; + /* Increment the loopvar. */ + tmp = build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + loop->loopvar[n], gfc_index_one_node); + TREE_VEC_ELT (incr, 0) = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, loop->loopvar[n], tmp); + OMP_FOR_INCR (stmt) = incr; + + ompws_flags &= ~OMPWS_CURR_SINGLEUNIT; + gfc_add_expr_to_block (&loop->code[n], stmt); + } + else + { + bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) + && (loop->temp_ss == NULL); + + loopbody = gfc_finish_block (pbody); + + if (reverse_loop) + std::swap (loop->from[n], loop->to[n]); + + /* Initialize the loopvar. */ + if (loop->loopvar[n] != loop->from[n]) + gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); + + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Generate the loop body. */ + gfc_init_block (&block); + + /* The exit condition. */ + cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR, + logical_type_node, loop->loopvar[n], loop->to[n]); + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + + /* The main body. */ + gfc_add_expr_to_block (&block, loopbody); + + /* Increment the loopvar. */ + tmp = fold_build2_loc (input_location, + reverse_loop ? MINUS_EXPR : PLUS_EXPR, + gfc_array_index_type, loop->loopvar[n], + gfc_index_one_node); + + gfc_add_modify (&block, loop->loopvar[n], tmp); + + /* Build the loop. */ + tmp = gfc_finish_block (&block); + tmp = build1_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&loop->code[n], tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&loop->code[n], tmp); + } + +} + + +/* Finishes and generates the loops for a scalarized expression. */ + +void +gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) +{ + int dim; + int n; + gfc_ss *ss; + stmtblock_t *pblock; + tree tmp; + + pblock = body; + /* Generate the loops. */ + for (dim = 0; dim < loop->dimen; dim++) + { + n = loop->order[dim]; + gfc_trans_scalarized_loop_end (loop, n, pblock); + loop->loopvar[n] = NULL_TREE; + pblock = &loop->code[n]; + } + + tmp = gfc_finish_block (pblock); + gfc_add_expr_to_block (&loop->pre, tmp); + + /* Clear all the used flags. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + if (ss->parent == NULL) + ss->info->useflags = 0; +} + + +/* Finish the main body of a scalarized expression, and start the secondary + copying body. */ + +void +gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) +{ + int dim; + int n; + stmtblock_t *pblock; + gfc_ss *ss; + + pblock = body; + /* We finish as many loops as are used by the temporary. */ + for (dim = 0; dim < loop->temp_dim - 1; dim++) + { + n = loop->order[dim]; + gfc_trans_scalarized_loop_end (loop, n, pblock); + loop->loopvar[n] = NULL_TREE; + pblock = &loop->code[n]; + } + + /* We don't want to finish the outermost loop entirely. */ + n = loop->order[loop->temp_dim - 1]; + gfc_trans_scalarized_loop_end (loop, n, pblock); + + /* Restore the initial offsets. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + gfc_ss_type ss_type; + gfc_ss_info *ss_info; + + ss_info = ss->info; + + if ((ss_info->useflags & 2) == 0) + continue; + + ss_type = ss_info->type; + if (ss_type != GFC_SS_SECTION + && ss_type != GFC_SS_FUNCTION + && ss_type != GFC_SS_CONSTRUCTOR + && ss_type != GFC_SS_COMPONENT) + continue; + + ss_info->data.array.offset = ss_info->data.array.saved_offset; + } + + /* Restart all the inner loops we just finished. */ + for (dim = loop->temp_dim - 2; dim >= 0; dim--) + { + n = loop->order[dim]; + + gfc_start_block (&loop->code[n]); + + loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q"); + + gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]); + } + + /* Start a block for the secondary copying code. */ + gfc_start_block (body); +} + + +/* Precalculate (either lower or upper) bound of an array section. + BLOCK: Block in which the (pre)calculation code will go. + BOUNDS[DIM]: Where the bound value will be stored once evaluated. + VALUES[DIM]: Specified bound (NULL <=> unspecified). + DESC: Array descriptor from which the bound will be picked if unspecified + (either lower or upper bound according to LBOUND). */ + +static void +evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, + tree desc, int dim, bool lbound, bool deferred) +{ + gfc_se se; + gfc_expr * input_val = values[dim]; + tree *output = &bounds[dim]; + + + if (input_val) + { + /* Specified section bound. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, input_val, gfc_array_index_type); + gfc_add_block_to_block (block, &se.pre); + *output = se.expr; + } + else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + { + /* The gfc_conv_array_lbound () routine returns a constant zero for + deferred length arrays, which in the scalarizer wreaks havoc, when + copying to a (newly allocated) one-based array. + Keep returning the actual result in sync for both bounds. */ + *output = lbound ? gfc_conv_descriptor_lbound_get (desc, + gfc_rank_cst[dim]): + gfc_conv_descriptor_ubound_get (desc, + gfc_rank_cst[dim]); + } + else + { + /* No specific bound specified so use the bound of the array. */ + *output = lbound ? gfc_conv_array_lbound (desc, dim) : + gfc_conv_array_ubound (desc, dim); + } + *output = gfc_evaluate_now (*output, block); +} + + +/* Calculate the lower bound of an array section. */ + +static void +gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) +{ + gfc_expr *stride = NULL; + tree desc; + gfc_se se; + gfc_array_info *info; + gfc_array_ref *ar; + + gcc_assert (ss->info->type == GFC_SS_SECTION); + + info = &ss->info->data.array; + ar = &info->ref->u.ar; + + if (ar->dimen_type[dim] == DIMEN_VECTOR) + { + /* We use a zero-based index to access the vector. */ + info->start[dim] = gfc_index_zero_node; + info->end[dim] = NULL; + info->stride[dim] = gfc_index_one_node; + return; + } + + gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE + || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); + desc = info->descriptor; + stride = ar->stride[dim]; + + + /* Calculate the start of the range. For vector subscripts this will + be the range of the vector. */ + evaluate_bound (block, info->start, ar->start, desc, dim, true, + ar->as->type == AS_DEFERRED); + + /* Similarly calculate the end. Although this is not used in the + scalarizer, it is needed when checking bounds and where the end + is an expression with side-effects. */ + evaluate_bound (block, info->end, ar->end, desc, dim, false, + ar->as->type == AS_DEFERRED); + + + /* Calculate the stride. */ + if (stride == NULL) + info->stride[dim] = gfc_index_one_node; + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, stride, gfc_array_index_type); + gfc_add_block_to_block (block, &se.pre); + info->stride[dim] = gfc_evaluate_now (se.expr, block); + } +} + + +/* Calculates the range start and stride for a SS chain. Also gets the + descriptor and data pointer. The range of vector subscripts is the size + of the vector. Array bounds are also checked. */ + +void +gfc_conv_ss_startstride (gfc_loopinfo * loop) +{ + int n; + tree tmp; + gfc_ss *ss; + tree desc; + + gfc_loopinfo * const outer_loop = outermost_loop (loop); + + loop->dimen = 0; + /* Determine the rank of the loop. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + switch (ss->info->type) + { + case GFC_SS_SECTION: + case GFC_SS_CONSTRUCTOR: + case GFC_SS_FUNCTION: + case GFC_SS_COMPONENT: + loop->dimen = ss->dimen; + goto done; + + /* As usual, lbound and ubound are exceptions!. */ + case GFC_SS_INTRINSIC: + switch (ss->info->expr->value.function.isym->id) + { + case GFC_ISYM_LBOUND: + case GFC_ISYM_UBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_SHAPE: + case GFC_ISYM_THIS_IMAGE: + loop->dimen = ss->dimen; + goto done; + + default: + break; + } + + default: + break; + } + } + + /* We should have determined the rank of the expression by now. If + not, that's bad news. */ + gcc_unreachable (); + +done: + /* Loop over all the SS in the chain. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + gfc_ss_info *ss_info; + gfc_array_info *info; + gfc_expr *expr; + + ss_info = ss->info; + expr = ss_info->expr; + info = &ss_info->data.array; + + if (expr && expr->shape && !info->shape) + info->shape = expr->shape; + + switch (ss_info->type) + { + case GFC_SS_SECTION: + /* Get the descriptor for the array. If it is a cross loops array, + we got the descriptor already in the outermost loop. */ + if (ss->parent == NULL) + gfc_conv_ss_descriptor (&outer_loop->pre, ss, + !loop->array_parameter); + + for (n = 0; n < ss->dimen; n++) + gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]); + break; + + case GFC_SS_INTRINSIC: + switch (expr->value.function.isym->id) + { + /* Fall through to supply start and stride. */ + case GFC_ISYM_LBOUND: + case GFC_ISYM_UBOUND: + /* This is the variant without DIM=... */ + gcc_assert (expr->value.function.actual->next->expr == NULL); + /* Fall through. */ + + case GFC_ISYM_SHAPE: + { + gfc_expr *arg; + + arg = expr->value.function.actual->expr; + if (arg->rank == -1) + { + gfc_se se; + tree rank, tmp; + + /* The rank (hence the return value's shape) is unknown, + we have to retrieve it. */ + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr (&se, arg); + /* This is a bare variable, so there is no preliminary + or cleanup code. */ + gcc_assert (se.pre.head == NULL_TREE + && se.post.head == NULL_TREE); + rank = gfc_conv_descriptor_rank (se.expr); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, + rank), + gfc_index_one_node); + info->end[0] = gfc_evaluate_now (tmp, &outer_loop->pre); + info->start[0] = gfc_index_zero_node; + info->stride[0] = gfc_index_one_node; + continue; + } + /* Otherwise fall through GFC_SS_FUNCTION. */ + gcc_fallthrough (); + } + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_THIS_IMAGE: + break; + + default: + continue; + } + + /* FALLTHRU */ + case GFC_SS_CONSTRUCTOR: + case GFC_SS_FUNCTION: + for (n = 0; n < ss->dimen; n++) + { + int dim = ss->dim[n]; + + info->start[dim] = gfc_index_zero_node; + info->end[dim] = gfc_index_zero_node; + info->stride[dim] = gfc_index_one_node; + } + break; + + default: + break; + } + } + + /* The rest is just runtime bounds checking. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + stmtblock_t block; + tree lbound, ubound; + tree end; + tree size[GFC_MAX_DIMENSIONS]; + tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3; + gfc_array_info *info; + char *msg; + int dim; + + gfc_start_block (&block); + + for (n = 0; n < loop->dimen; n++) + size[n] = NULL_TREE; + + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + stmtblock_t inner; + gfc_ss_info *ss_info; + gfc_expr *expr; + locus *expr_loc; + const char *expr_name; + + ss_info = ss->info; + if (ss_info->type != GFC_SS_SECTION) + continue; + + /* Catch allocatable lhs in f2003. */ + if (flag_realloc_lhs && ss->no_bounds_check) + continue; + + expr = ss_info->expr; + expr_loc = &expr->where; + expr_name = expr->symtree->name; + + gfc_start_block (&inner); + + /* TODO: range checking for mapped dimensions. */ + info = &ss_info->data.array; + + /* This code only checks ranges. Elemental and vector + dimensions are checked later. */ + for (n = 0; n < loop->dimen; n++) + { + bool check_upper; + + dim = ss->dim[n]; + if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) + continue; + + if (dim == info->ref->u.ar.dimen - 1 + && info->ref->u.ar.as->type == AS_ASSUMED_SIZE) + check_upper = false; + else + check_upper = true; + + /* Zero stride is not allowed. */ + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + info->stride[dim], gfc_index_zero_node); + msg = xasprintf ("Zero stride is not allowed, for dimension %d " + "of array '%s'", dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp, &inner, + expr_loc, msg); + free (msg); + + desc = info->descriptor; + + /* This is the run-time equivalent of resolve.c's + check_dimension(). The logical is more readable there + than it is here, with all the trees. */ + lbound = gfc_conv_array_lbound (desc, dim); + end = info->end[dim]; + if (check_upper) + ubound = gfc_conv_array_ubound (desc, dim); + else + ubound = NULL; + + /* non_zerosized is true when the selected range is not + empty. */ + stride_pos = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, info->stride[dim], + gfc_index_zero_node); + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + info->start[dim], end); + stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, stride_pos, tmp); + + stride_neg = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + info->start[dim], end); + stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, + stride_neg, tmp); + non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, + stride_pos, stride_neg); + + /* Check the start of the range against the lower and upper + bounds of the array, if the range is not empty. + If upper bound is present, include both bounds in the + error message. */ + if (check_upper) + { + tmp = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, + info->start[dim], lbound); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, + non_zerosized, tmp); + tmp2 = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, + info->start[dim], ubound); + tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, + non_zerosized, tmp2); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "outside of expected range (%%ld:%%ld)", + dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp, &inner, + expr_loc, msg, + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, ubound)); + gfc_trans_runtime_check (true, false, tmp2, &inner, + expr_loc, msg, + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, ubound)); + free (msg); + } + else + { + tmp = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, + info->start[dim], lbound); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, non_zerosized, tmp); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", + dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp, &inner, + expr_loc, msg, + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound)); + free (msg); + } + + /* Compute the last element of the range, which is not + necessarily "end" (think 0:5:3, which doesn't contain 5) + and check it against both lower and upper bounds. */ + + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, end, + info->start[dim]); + tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, + gfc_array_index_type, tmp, + info->stride[dim]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, end, tmp); + tmp2 = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, tmp, lbound); + tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, non_zerosized, tmp2); + if (check_upper) + { + tmp3 = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, tmp, ubound); + tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, non_zerosized, tmp3); + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "outside of expected range (%%ld:%%ld)", + dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp2, &inner, + expr_loc, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, ubound), + fold_convert (long_integer_type_node, lbound)); + gfc_trans_runtime_check (true, false, tmp3, &inner, + expr_loc, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, ubound), + fold_convert (long_integer_type_node, lbound)); + free (msg); + } + else + { + msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " + "below lower bound of %%ld", + dim + 1, expr_name); + gfc_trans_runtime_check (true, false, tmp2, &inner, + expr_loc, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, lbound)); + free (msg); + } + + /* Check the section sizes match. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, end, + info->start[dim]); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, + gfc_array_index_type, tmp, + info->stride[dim]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, tmp); + tmp = fold_build2_loc (input_location, MAX_EXPR, + gfc_array_index_type, tmp, + build_int_cst (gfc_array_index_type, 0)); + /* We remember the size of the first section, and check all the + others against this. */ + if (size[n]) + { + tmp3 = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp, size[n]); + msg = xasprintf ("Array bound mismatch for dimension %d " + "of array '%s' (%%ld/%%ld)", + dim + 1, expr_name); + + gfc_trans_runtime_check (true, false, tmp3, &inner, + expr_loc, msg, + fold_convert (long_integer_type_node, tmp), + fold_convert (long_integer_type_node, size[n])); + + free (msg); + } + else + size[n] = gfc_evaluate_now (tmp, &inner); + } + + tmp = gfc_finish_block (&inner); + + /* For optional arguments, only check bounds if the argument is + present. */ + if ((expr->symtree->n.sym->attr.optional + || expr->symtree->n.sym->attr.not_always_present) + && expr->symtree->n.sym->attr.dummy) + tmp = build3_v (COND_EXPR, + gfc_conv_expr_present (expr->symtree->n.sym), + tmp, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&block, tmp); + + } + + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&outer_loop->pre, tmp); + } + + for (loop = loop->nested; loop; loop = loop->next) + gfc_conv_ss_startstride (loop); +} + +/* Return true if both symbols could refer to the same data object. Does + not take account of aliasing due to equivalence statements. */ + +static int +symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer, + bool lsym_target, bool rsym_pointer, bool rsym_target) +{ + /* Aliasing isn't possible if the symbols have different base types. */ + if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) + return 0; + + /* Pointers can point to other pointers and target objects. */ + + if ((lsym_pointer && (rsym_pointer || rsym_target)) + || (rsym_pointer && (lsym_pointer || lsym_target))) + return 1; + + /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7 + and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already + checked above. */ + if (lsym_target && rsym_target + && ((lsym->attr.dummy && !lsym->attr.contiguous + && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE)) + || (rsym->attr.dummy && !rsym->attr.contiguous + && (!rsym->attr.dimension + || rsym->as->type == AS_ASSUMED_SHAPE)))) + return 1; + + return 0; +} + + +/* Return true if the two SS could be aliased, i.e. both point to the same data + object. */ +/* TODO: resolve aliases based on frontend expressions. */ + +static int +gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) +{ + gfc_ref *lref; + gfc_ref *rref; + gfc_expr *lexpr, *rexpr; + gfc_symbol *lsym; + gfc_symbol *rsym; + bool lsym_pointer, lsym_target, rsym_pointer, rsym_target; + + lexpr = lss->info->expr; + rexpr = rss->info->expr; + + lsym = lexpr->symtree->n.sym; + rsym = rexpr->symtree->n.sym; + + lsym_pointer = lsym->attr.pointer; + lsym_target = lsym->attr.target; + rsym_pointer = rsym->attr.pointer; + rsym_target = rsym->attr.target; + + if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target, + rsym_pointer, rsym_target)) + return 1; + + if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS + && lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS) + return 0; + + /* For derived types we must check all the component types. We can ignore + array references as these will have the same base type as the previous + component ref. */ + for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next) + { + if (lref->type != REF_COMPONENT) + continue; + + lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer; + lsym_target = lsym_target || lref->u.c.sym->attr.target; + + if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target, + rsym_pointer, rsym_target)) + return 1; + + if ((lsym_pointer && (rsym_pointer || rsym_target)) + || (rsym_pointer && (lsym_pointer || lsym_target))) + { + if (gfc_compare_types (&lref->u.c.component->ts, + &rsym->ts)) + return 1; + } + + for (rref = rexpr->ref; rref != rss->info->data.array.ref; + rref = rref->next) + { + if (rref->type != REF_COMPONENT) + continue; + + rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; + rsym_target = lsym_target || rref->u.c.sym->attr.target; + + if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym, + lsym_pointer, lsym_target, + rsym_pointer, rsym_target)) + return 1; + + if ((lsym_pointer && (rsym_pointer || rsym_target)) + || (rsym_pointer && (lsym_pointer || lsym_target))) + { + if (gfc_compare_types (&lref->u.c.component->ts, + &rref->u.c.sym->ts)) + return 1; + if (gfc_compare_types (&lref->u.c.sym->ts, + &rref->u.c.component->ts)) + return 1; + if (gfc_compare_types (&lref->u.c.component->ts, + &rref->u.c.component->ts)) + return 1; + } + } + } + + lsym_pointer = lsym->attr.pointer; + lsym_target = lsym->attr.target; + + for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next) + { + if (rref->type != REF_COMPONENT) + break; + + rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer; + rsym_target = lsym_target || rref->u.c.sym->attr.target; + + if (symbols_could_alias (rref->u.c.sym, lsym, + lsym_pointer, lsym_target, + rsym_pointer, rsym_target)) + return 1; + + if ((lsym_pointer && (rsym_pointer || rsym_target)) + || (rsym_pointer && (lsym_pointer || lsym_target))) + { + if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts)) + return 1; + } + } + + return 0; +} + + +/* Resolve array data dependencies. Creates a temporary if required. */ +/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to + dependency.c. */ + +void +gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, + gfc_ss * rss) +{ + gfc_ss *ss; + gfc_ref *lref; + gfc_ref *rref; + gfc_ss_info *ss_info; + gfc_expr *dest_expr; + gfc_expr *ss_expr; + int nDepend = 0; + int i, j; + + loop->temp_ss = NULL; + dest_expr = dest->info->expr; + + for (ss = rss; ss != gfc_ss_terminator; ss = ss->next) + { + ss_info = ss->info; + ss_expr = ss_info->expr; + + if (ss_info->array_outer_dependency) + { + nDepend = 1; + break; + } + + if (ss_info->type != GFC_SS_SECTION) + { + if (flag_realloc_lhs + && dest_expr != ss_expr + && gfc_is_reallocatable_lhs (dest_expr) + && ss_expr->rank) + nDepend = gfc_check_dependency (dest_expr, ss_expr, true); + + /* Check for cases like c(:)(1:2) = c(2)(2:3) */ + if (!nDepend && dest_expr->rank > 0 + && dest_expr->ts.type == BT_CHARACTER + && ss_expr->expr_type == EXPR_VARIABLE) + + nDepend = gfc_check_dependency (dest_expr, ss_expr, false); + + if (ss_info->type == GFC_SS_REFERENCE + && gfc_check_dependency (dest_expr, ss_expr, false)) + ss_info->data.scalar.needs_temporary = 1; + + if (nDepend) + break; + else + continue; + } + + if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym) + { + if (gfc_could_be_alias (dest, ss) + || gfc_are_equivalenced_arrays (dest_expr, ss_expr)) + { + nDepend = 1; + break; + } + } + else + { + lref = dest_expr->ref; + rref = ss_expr->ref; + + nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); + + if (nDepend == 1) + break; + + for (i = 0; i < dest->dimen; i++) + for (j = 0; j < ss->dimen; j++) + if (i != j + && dest->dim[i] == ss->dim[j]) + { + /* If we don't access array elements in the same order, + there is a dependency. */ + nDepend = 1; + goto temporary; + } +#if 0 + /* TODO : loop shifting. */ + if (nDepend == 1) + { + /* Mark the dimensions for LOOP SHIFTING */ + for (n = 0; n < loop->dimen; n++) + { + int dim = dest->data.info.dim[n]; + + if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + depends[n] = 2; + else if (! gfc_is_same_range (&lref->u.ar, + &rref->u.ar, dim, 0)) + depends[n] = 1; + } + + /* Put all the dimensions with dependencies in the + innermost loops. */ + dim = 0; + for (n = 0; n < loop->dimen; n++) + { + gcc_assert (loop->order[n] == n); + if (depends[n]) + loop->order[dim++] = n; + } + for (n = 0; n < loop->dimen; n++) + { + if (! depends[n]) + loop->order[dim++] = n; + } + + gcc_assert (dim == loop->dimen); + break; + } +#endif + } + } + +temporary: + + if (nDepend == 1) + { + tree base_type = gfc_typenode_for_spec (&dest_expr->ts); + if (GFC_ARRAY_TYPE_P (base_type) + || GFC_DESCRIPTOR_TYPE_P (base_type)) + base_type = gfc_get_element_type (base_type); + loop->temp_ss = gfc_get_temp_ss (base_type, dest->info->string_length, + loop->dimen); + gfc_add_ss_to_loop (loop, loop->temp_ss); + } + else + loop->temp_ss = NULL; +} + + +/* Browse through each array's information from the scalarizer and set the loop + bounds according to the "best" one (per dimension), i.e. the one which + provides the most information (constant bounds, shape, etc.). */ + +static void +set_loop_bounds (gfc_loopinfo *loop) +{ + int n, dim, spec_dim; + gfc_array_info *info; + gfc_array_info *specinfo; + gfc_ss *ss; + tree tmp; + gfc_ss **loopspec; + bool dynamic[GFC_MAX_DIMENSIONS]; + mpz_t *cshape; + mpz_t i; + bool nonoptional_arr; + + gfc_loopinfo * const outer_loop = outermost_loop (loop); + + loopspec = loop->specloop; + + mpz_init (i); + for (n = 0; n < loop->dimen; n++) + { + loopspec[n] = NULL; + dynamic[n] = false; + + /* If there are both optional and nonoptional array arguments, scalarize + over the nonoptional; otherwise, it does not matter as then all + (optional) arrays have to be present per F2008, 125.2.12p3(6). */ + + nonoptional_arr = false; + + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP + && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref) + { + nonoptional_arr = true; + break; + } + + /* We use one SS term, and use that to determine the bounds of the + loop for this dimension. We try to pick the simplest term. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + gfc_ss_type ss_type; + + ss_type = ss->info->type; + if (ss_type == GFC_SS_SCALAR + || ss_type == GFC_SS_TEMP + || ss_type == GFC_SS_REFERENCE + || (ss->info->can_be_null_ref && nonoptional_arr)) + continue; + + info = &ss->info->data.array; + dim = ss->dim[n]; + + if (loopspec[n] != NULL) + { + specinfo = &loopspec[n]->info->data.array; + spec_dim = loopspec[n]->dim[n]; + } + else + { + /* Silence uninitialized warnings. */ + specinfo = NULL; + spec_dim = 0; + } + + if (info->shape) + { + /* The frontend has worked out the size for us. */ + if (!loopspec[n] + || !specinfo->shape + || !integer_zerop (specinfo->start[spec_dim])) + /* Prefer zero-based descriptors if possible. */ + loopspec[n] = ss; + continue; + } + + if (ss_type == GFC_SS_CONSTRUCTOR) + { + gfc_constructor_base base; + /* An unknown size constructor will always be rank one. + Higher rank constructors will either have known shape, + or still be wrapped in a call to reshape. */ + gcc_assert (loop->dimen == 1); + + /* Always prefer to use the constructor bounds if the size + can be determined at compile time. Prefer not to otherwise, + since the general case involves realloc, and it's better to + avoid that overhead if possible. */ + base = ss->info->expr->value.constructor; + dynamic[n] = gfc_get_array_constructor_size (&i, base); + if (!dynamic[n] || !loopspec[n]) + loopspec[n] = ss; + continue; + } + + /* Avoid using an allocatable lhs in an assignment, since + there might be a reallocation coming. */ + if (loopspec[n] && ss->is_alloc_lhs) + continue; + + if (!loopspec[n]) + loopspec[n] = ss; + /* Criteria for choosing a loop specifier (most important first): + doesn't need realloc + stride of one + known stride + known lower bound + known upper bound + */ + else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) + loopspec[n] = ss; + else if (integer_onep (info->stride[dim]) + && !integer_onep (specinfo->stride[spec_dim])) + loopspec[n] = ss; + else if (INTEGER_CST_P (info->stride[dim]) + && !INTEGER_CST_P (specinfo->stride[spec_dim])) + loopspec[n] = ss; + else if (INTEGER_CST_P (info->start[dim]) + && !INTEGER_CST_P (specinfo->start[spec_dim]) + && integer_onep (info->stride[dim]) + == integer_onep (specinfo->stride[spec_dim]) + && INTEGER_CST_P (info->stride[dim]) + == INTEGER_CST_P (specinfo->stride[spec_dim])) + loopspec[n] = ss; + /* We don't work out the upper bound. + else if (INTEGER_CST_P (info->finish[n]) + && ! INTEGER_CST_P (specinfo->finish[n])) + loopspec[n] = ss; */ + } + + /* We should have found the scalarization loop specifier. If not, + that's bad news. */ + gcc_assert (loopspec[n]); + + info = &loopspec[n]->info->data.array; + dim = loopspec[n]->dim[n]; + + /* Set the extents of this range. */ + cshape = info->shape; + if (cshape && INTEGER_CST_P (info->start[dim]) + && INTEGER_CST_P (info->stride[dim])) + { + loop->from[n] = info->start[dim]; + mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]); + mpz_sub_ui (i, i, 1); + /* To = from + (size - 1) * stride. */ + tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); + if (!integer_onep (info->stride[dim])) + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, + info->stride[dim]); + loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + loop->from[n], tmp); + } + else + { + loop->from[n] = info->start[dim]; + switch (loopspec[n]->info->type) + { + case GFC_SS_CONSTRUCTOR: + /* The upper bound is calculated when we expand the + constructor. */ + gcc_assert (loop->to[n] == NULL_TREE); + break; + + case GFC_SS_SECTION: + /* Use the end expression if it exists and is not constant, + so that it is only evaluated once. */ + loop->to[n] = info->end[dim]; + break; + + case GFC_SS_FUNCTION: + /* The loop bound will be set when we generate the call. */ + gcc_assert (loop->to[n] == NULL_TREE); + break; + + case GFC_SS_INTRINSIC: + { + gfc_expr *expr = loopspec[n]->info->expr; + + /* The {l,u}bound of an assumed rank. */ + if (expr->value.function.isym->id == GFC_ISYM_SHAPE) + gcc_assert (expr->value.function.actual->expr->rank == -1); + else + gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND + || expr->value.function.isym->id == GFC_ISYM_UBOUND) + && expr->value.function.actual->next->expr == NULL + && expr->value.function.actual->expr->rank == -1); + + loop->to[n] = info->end[dim]; + break; + } + + case GFC_SS_COMPONENT: + { + if (info->end[dim] != NULL_TREE) + { + loop->to[n] = info->end[dim]; + break; + } + else + gcc_unreachable (); + } + + default: + gcc_unreachable (); + } + } + + /* Transform everything so we have a simple incrementing variable. */ + if (integer_onep (info->stride[dim])) + info->delta[dim] = gfc_index_zero_node; + else + { + /* Set the delta for this section. */ + info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre); + /* Number of iterations is (end - start + step) / step. + with start = 0, this simplifies to + last = end / step; + for (i = 0; i<=last; i++){...}; */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, loop->to[n], + loop->from[n]); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, + gfc_array_index_type, tmp, info->stride[dim]); + tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + tmp, build_int_cst (gfc_array_index_type, -1)); + loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre); + /* Make the loop variable start at 0. */ + loop->from[n] = gfc_index_zero_node; + } + } + mpz_clear (i); + + for (loop = loop->nested; loop; loop = loop->next) + set_loop_bounds (loop); +} + + +/* Initialize the scalarization loop. Creates the loop variables. Determines + the range of the loop variables. Creates a temporary if required. + Also generates code for scalar expressions which have been + moved outside the loop. */ + +void +gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) +{ + gfc_ss *tmp_ss; + tree tmp; + + set_loop_bounds (loop); + + /* Add all the scalar code that can be taken out of the loops. + This may include calculating the loop bounds, so do it before + allocating the temporary. */ + gfc_add_loop_ss_code (loop, loop->ss, false, where); + + tmp_ss = loop->temp_ss; + /* If we want a temporary then create it. */ + if (tmp_ss != NULL) + { + gfc_ss_info *tmp_ss_info; + + tmp_ss_info = tmp_ss->info; + gcc_assert (tmp_ss_info->type == GFC_SS_TEMP); + gcc_assert (loop->parent == NULL); + + /* Make absolutely sure that this is a complete type. */ + if (tmp_ss_info->string_length) + tmp_ss_info->data.temp.type + = gfc_get_character_type_len_for_eltype + (TREE_TYPE (tmp_ss_info->data.temp.type), + tmp_ss_info->string_length); + + tmp = tmp_ss_info->data.temp.type; + memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info)); + tmp_ss_info->type = GFC_SS_SECTION; + + gcc_assert (tmp_ss->dimen != 0); + + gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp, + NULL_TREE, false, true, false, where); + } + + /* For array parameters we don't have loop variables, so don't calculate the + translations. */ + if (!loop->array_parameter) + gfc_set_delta (loop); +} + + +/* Calculates how to transform from loop variables to array indices for each + array: once loop bounds are chosen, sets the difference (DELTA field) between + loop bounds and array reference bounds, for each array info. */ + +void +gfc_set_delta (gfc_loopinfo *loop) +{ + gfc_ss *ss, **loopspec; + gfc_array_info *info; + tree tmp; + int n, dim; + + gfc_loopinfo * const outer_loop = outermost_loop (loop); + + loopspec = loop->specloop; + + /* Calculate the translation from loop variables to array indices. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + gfc_ss_type ss_type; + + ss_type = ss->info->type; + if (ss_type != GFC_SS_SECTION + && ss_type != GFC_SS_COMPONENT + && ss_type != GFC_SS_CONSTRUCTOR) + continue; + + info = &ss->info->data.array; + + for (n = 0; n < ss->dimen; n++) + { + /* If we are specifying the range the delta is already set. */ + if (loopspec[n] != ss) + { + dim = ss->dim[n]; + + /* Calculate the offset relative to the loop variable. + First multiply by the stride. */ + tmp = loop->from[n]; + if (!integer_onep (info->stride[dim])) + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + tmp, info->stride[dim]); + + /* Then subtract this from our starting value. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + info->start[dim], tmp); + + info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); + } + } + } + + for (loop = loop->nested; loop; loop = loop->next) + gfc_set_delta (loop); +} + + +/* Calculate the size of a given array dimension from the bounds. This + is simply (ubound - lbound + 1) if this expression is positive + or 0 if it is negative (pick either one if it is zero). Optionally + (if or_expr is present) OR the (expression != 0) condition to it. */ + +tree +gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) +{ + tree res; + tree cond; + + /* Calculate (ubound - lbound + 1). */ + res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + ubound, lbound); + res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res, + gfc_index_one_node); + + /* Check whether the size for this dimension is negative. */ + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res, + gfc_index_zero_node); + res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, + gfc_index_zero_node, res); + + /* Build OR expression. */ + if (or_expr) + *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, *or_expr, cond); + + return res; +} + + +/* For an array descriptor, get the total number of elements. This is just + the product of the extents along from_dim to to_dim. */ + +static tree +gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim) +{ + tree res; + int dim; + + res = gfc_index_one_node; + + for (dim = from_dim; dim < to_dim; ++dim) + { + tree lbound; + tree ubound; + tree extent; + + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]); + + extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + res, extent); + } + + return res; +} + + +/* Full size of an array. */ + +tree +gfc_conv_descriptor_size (tree desc, int rank) +{ + return gfc_conv_descriptor_size_1 (desc, 0, rank); +} + + +/* Size of a coarray for all dimensions but the last. */ + +tree +gfc_conv_descriptor_cosize (tree desc, int rank, int corank) +{ + return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1); +} + + +/* Fills in an array descriptor, and returns the size of the array. + The size will be a simple_val, ie a variable or a constant. Also + calculates the offset of the base. The pointer argument overflow, + which should be of integer type, will increase in value if overflow + occurs during the size calculation. Returns the size of the array. + { + stride = 1; + offset = 0; + for (n = 0; n < rank; n++) + { + a.lbound[n] = specified_lower_bound; + offset = offset + a.lbond[n] * stride; + size = 1 - lbound; + a.ubound[n] = specified_upper_bound; + a.stride[n] = stride; + size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound + overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); + stride = stride * size; + } + for (n = rank; n < rank+corank; n++) + (Set lcobound/ucobound as above.) + element_size = sizeof (array element); + if (!rank) + return element_size + stride = (size_t) stride; + overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0); + stride = stride * element_size; + return (stride); + } */ +/*GCC ARRAYS*/ + +static tree +gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, + gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, + stmtblock_t * descriptor_block, tree * overflow, + tree expr3_elem_size, tree *nelems, gfc_expr *expr3, + tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr, + tree *element_size) +{ + tree type; + tree tmp; + tree size; + tree offset; + tree stride; + tree or_expr; + tree thencase; + tree elsecase; + tree cond; + tree var; + stmtblock_t thenblock; + stmtblock_t elseblock; + gfc_expr *ubound; + gfc_se se; + int n; + + type = TREE_TYPE (descriptor); + + stride = gfc_index_one_node; + offset = gfc_index_zero_node; + + /* Set the dtype before the alloc, because registration of coarrays needs + it initialized. */ + if (expr->ts.type == BT_CHARACTER + && expr->ts.deferred + && VAR_P (expr->ts.u.cl->backend_decl)) + { + type = gfc_typenode_for_spec (&expr->ts); + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); + } + else if (expr->ts.type == BT_CHARACTER + && expr->ts.deferred + && TREE_CODE (descriptor) == COMPONENT_REF) + { + /* Deferred character components have their string length tucked away + in a hidden field of the derived type. Obtain that and use it to + set the dtype. The charlen backend decl is zero because the field + type is zero length. */ + gfc_ref *ref; + tmp = NULL_TREE; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && gfc_deferred_strlen (ref->u.c.component, &tmp)) + break; + gcc_assert (tmp != NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + TREE_OPERAND (descriptor, 0), tmp, NULL_TREE); + tmp = fold_convert (gfc_charlen_type_node, tmp); + type = gfc_get_character_type_len (expr->ts.kind, tmp); + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type)); + } + else + { + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify (pblock, tmp, gfc_get_dtype (type)); + } + + or_expr = logical_false_node; + + for (n = 0; n < rank; n++) + { + tree conv_lbound; + tree conv_ubound; + + /* We have 3 possibilities for determining the size of the array: + lower == NULL => lbound = 1, ubound = upper[n] + upper[n] = NULL => lbound = 1, ubound = lower[n] + upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ + ubound = upper[n]; + + /* Set lower bound. */ + gfc_init_se (&se, NULL); + if (expr3_desc != NULL_TREE) + { + if (e3_has_nodescriptor) + /* The lbound of nondescriptor arrays like array constructors, + nonallocatable/nonpointer function results/variables, + start at zero, but when allocating it, the standard expects + the array to start at one. */ + se.expr = gfc_index_one_node; + else + se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, + gfc_rank_cst[n]); + } + else if (lower == NULL) + se.expr = gfc_index_one_node; + else + { + gcc_assert (lower[n]); + if (ubound) + { + gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } + else + { + se.expr = gfc_index_one_node; + ubound = lower[n]; + } + } + gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); + conv_lbound = se.expr; + + /* Work out the offset for this component. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + se.expr, stride); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); + + /* Set upper bound. */ + gfc_init_se (&se, NULL); + if (expr3_desc != NULL_TREE) + { + if (e3_has_nodescriptor) + { + /* The lbound of nondescriptor arrays like array constructors, + nonallocatable/nonpointer function results/variables, + start at zero, but when allocating it, the standard expects + the array to start at one. Therefore fix the upper bound to be + (desc.ubound - desc.lbound) + 1. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_ubound_get ( + expr3_desc, gfc_rank_cst[n]), + gfc_conv_descriptor_lbound_get ( + expr3_desc, gfc_rank_cst[n])); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + se.expr = gfc_evaluate_now (tmp, pblock); + } + else + se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, + gfc_rank_cst[n]); + } + else + { + gcc_assert (ubound); + gfc_conv_expr_type (&se, ubound, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + if (ubound->expr_type == EXPR_FUNCTION) + se.expr = gfc_evaluate_now (se.expr, pblock); + } + gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); + conv_ubound = se.expr; + + /* Store the stride. */ + gfc_conv_descriptor_stride_set (descriptor_block, descriptor, + gfc_rank_cst[n], stride); + + /* Calculate size and check whether extent is negative. */ + size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr); + size = gfc_evaluate_now (size, pblock); + + /* Check whether multiplying the stride by the number of + elements in this dimension would overflow. We must also check + whether the current dimension has zero size in order to avoid + division by zero. + */ + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, + TYPE_MAX_VALUE (gfc_array_index_type)), + size); + cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, + logical_type_node, tmp, stride), + PRED_FORTRAN_OVERFLOW); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, + integer_one_node, integer_zero_node); + cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, size, + gfc_index_zero_node), + PRED_FORTRAN_SIZE_ZERO); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, + integer_zero_node, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + *overflow, tmp); + *overflow = gfc_evaluate_now (tmp, pblock); + + /* Multiply the stride by the number of elements in this dimension. */ + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, size); + stride = gfc_evaluate_now (stride, pblock); + } + + for (n = rank; n < rank + corank; n++) + { + ubound = upper[n]; + + /* Set lower bound. */ + gfc_init_se (&se, NULL); + if (lower == NULL || lower[n] == NULL) + { + gcc_assert (n == rank + corank - 1); + se.expr = gfc_index_one_node; + } + else + { + if (ubound || n == rank + corank - 1) + { + gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } + else + { + se.expr = gfc_index_one_node; + ubound = lower[n]; + } + } + gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); + + if (n < rank + corank - 1) + { + gfc_init_se (&se, NULL); + gcc_assert (ubound); + gfc_conv_expr_type (&se, ubound, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); + } + } + + /* The stride is the number of elements in the array, so multiply by the + size of an element to get the total size. Obviously, if there is a + SOURCE expression (expr3) we must use its element size. */ + if (expr3_elem_size != NULL_TREE) + tmp = expr3_elem_size; + else if (expr3 != NULL) + { + if (expr3->ts.type == BT_CLASS) + { + gfc_se se_sz; + gfc_expr *sz = gfc_copy_expr (expr3); + gfc_add_vptr_component (sz); + gfc_add_size_component (sz); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + tmp = se_sz.expr; + } + else + { + tmp = gfc_typenode_for_spec (&expr3->ts); + tmp = TYPE_SIZE_UNIT (tmp); + } + } + else + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + + /* Convert to size_t. */ + *element_size = fold_convert (size_type_node, tmp); + + if (rank == 0) + return *element_size; + + *nelems = gfc_evaluate_now (stride, pblock); + stride = fold_convert (size_type_node, stride); + + /* First check for overflow. Since an array of type character can + have zero element_size, we must check for that before + dividing. */ + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + size_type_node, + TYPE_MAX_VALUE (size_type_node), *element_size); + cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, + logical_type_node, tmp, stride), + PRED_FORTRAN_OVERFLOW); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, + integer_one_node, integer_zero_node); + cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, *element_size, + build_int_cst (size_type_node, 0)), + PRED_FORTRAN_SIZE_ZERO); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, + integer_zero_node, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + *overflow, tmp); + *overflow = gfc_evaluate_now (tmp, pblock); + + size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + stride, *element_size); + + if (poffset != NULL) + { + offset = gfc_evaluate_now (offset, pblock); + *poffset = offset; + } + + if (integer_zerop (or_expr)) + return size; + if (integer_onep (or_expr)) + return build_int_cst (size_type_node, 0); + + var = gfc_create_var (TREE_TYPE (size), "size"); + gfc_start_block (&thenblock); + gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, 0)); + thencase = gfc_finish_block (&thenblock); + + gfc_start_block (&elseblock); + gfc_add_modify (&elseblock, var, size); + elsecase = gfc_finish_block (&elseblock); + + tmp = gfc_evaluate_now (or_expr, pblock); + tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); + gfc_add_expr_to_block (pblock, tmp); + + return var; +} + + +/* Retrieve the last ref from the chain. This routine is specific to + gfc_array_allocate ()'s needs. */ + +bool +retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) +{ + gfc_ref *ref, *prev_ref; + + ref = *ref_in; + /* Prevent warnings for uninitialized variables. */ + prev_ref = *prev_ref_in; + while (ref && ref->next != NULL) + { + gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT + || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); + prev_ref = ref; + ref = ref->next; + } + + if (ref == NULL || ref->type != REF_ARRAY) + return false; + + *ref_in = ref; + *prev_ref_in = prev_ref; + return true; +} + +/* Initializes the descriptor and generates a call to _gfor_allocate. Does + the work for an ALLOCATE statement. */ +/*GCC ARRAYS*/ + +bool +gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, + tree errlen, tree label_finish, tree expr3_elem_size, + tree *nelems, gfc_expr *expr3, tree e3_arr_desc, + bool e3_has_nodescriptor) +{ + tree tmp; + tree pointer; + tree offset = NULL_TREE; + tree token = NULL_TREE; + tree size; + tree msg; + tree error = NULL_TREE; + tree overflow; /* Boolean storing whether size calculation overflows. */ + tree var_overflow = NULL_TREE; + tree cond; + tree set_descriptor; + tree not_prev_allocated = NULL_TREE; + tree element_size = NULL_TREE; + stmtblock_t set_descriptor_block; + stmtblock_t elseblock; + gfc_expr **lower; + gfc_expr **upper; + gfc_ref *ref, *prev_ref = NULL, *coref; + bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false, + non_ulimate_coarray_ptr_comp; + + ref = expr->ref; + + /* Find the last reference in the chain. */ + if (!retrieve_last_ref (&ref, &prev_ref)) + return false; + + /* Take the allocatable and coarray properties solely from the expr-ref's + attributes and not from source=-expression. */ + if (!prev_ref) + { + allocatable = expr->symtree->n.sym->attr.allocatable; + dimension = expr->symtree->n.sym->attr.dimension; + non_ulimate_coarray_ptr_comp = false; + } + else + { + allocatable = prev_ref->u.c.component->attr.allocatable; + /* Pointer components in coarrayed derived types must be treated + specially in that they are registered without a check if the are + already associated. This does not hold for ultimate coarray + pointers. */ + non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer + && !prev_ref->u.c.component->attr.codimension); + dimension = prev_ref->u.c.component->attr.dimension; + } + + /* For allocatable/pointer arrays in derived types, one of the refs has to be + a coarray. In this case it does not matter whether we are on this_image + or not. */ + coarray = false; + for (coref = expr->ref; coref; coref = coref->next) + if (coref->type == REF_ARRAY && coref->u.ar.codimen > 0) + { + coarray = true; + break; + } + + if (!dimension) + gcc_assert (coarray); + + if (ref->u.ar.type == AR_FULL && expr3 != NULL) + { + gfc_ref *old_ref = ref; + /* F08:C633: Array shape from expr3. */ + ref = expr3->ref; + + /* Find the last reference in the chain. */ + if (!retrieve_last_ref (&ref, &prev_ref)) + { + if (expr3->expr_type == EXPR_FUNCTION + && gfc_expr_attr (expr3).dimension) + ref = old_ref; + else + return false; + } + alloc_w_e3_arr_spec = true; + } + + /* Figure out the size of the array. */ + switch (ref->u.ar.type) + { + case AR_ELEMENT: + if (!coarray) + { + lower = NULL; + upper = ref->u.ar.start; + break; + } + /* Fall through. */ + + case AR_SECTION: + lower = ref->u.ar.start; + upper = ref->u.ar.end; + break; + + case AR_FULL: + gcc_assert (ref->u.ar.as->type == AS_EXPLICIT + || alloc_w_e3_arr_spec); + + lower = ref->u.ar.as->lower; + upper = ref->u.ar.as->upper; + break; + + default: + gcc_unreachable (); + break; + } + + overflow = integer_zero_node; + + if (expr->ts.type == BT_CHARACTER + && TREE_CODE (se->string_length) == COMPONENT_REF + && expr->ts.u.cl->backend_decl != se->string_length + && VAR_P (expr->ts.u.cl->backend_decl)) + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, + fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl), + se->string_length)); + + gfc_init_block (&set_descriptor_block); + /* Take the corank only from the actual ref and not from the coref. The + later will mislead the generation of the array dimensions for allocatable/ + pointer components in derived types. */ + size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank + : ref->u.ar.as->rank, + coarray ? ref->u.ar.as->corank : 0, + &offset, lower, upper, + &se->pre, &set_descriptor_block, &overflow, + expr3_elem_size, nelems, expr3, e3_arr_desc, + e3_has_nodescriptor, expr, &element_size); + + if (dimension) + { + var_overflow = gfc_create_var (integer_type_node, "overflow"); + gfc_add_modify (&se->pre, var_overflow, overflow); + + if (status == NULL_TREE) + { + /* Generate the block of code handling overflow. */ + msg = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const + ("Integer overflow when calculating the amount of " + "memory to allocate")); + error = build_call_expr_loc (input_location, + gfor_fndecl_runtime_error, 1, msg); + } + else + { + tree status_type = TREE_TYPE (status); + stmtblock_t set_status_block; + + gfc_start_block (&set_status_block); + gfc_add_modify (&set_status_block, status, + build_int_cst (status_type, LIBERROR_ALLOCATION)); + error = gfc_finish_block (&set_status_block); + } + } + + /* Allocate memory to store the data. */ + if (POINTER_TYPE_P (TREE_TYPE (se->expr))) + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + + if (coarray && flag_coarray == GFC_FCOARRAY_LIB) + { + pointer = non_ulimate_coarray_ptr_comp ? se->expr + : gfc_conv_descriptor_data_get (se->expr); + token = gfc_conv_descriptor_token (se->expr); + token = gfc_build_addr_expr (NULL_TREE, token); + } + else + pointer = gfc_conv_descriptor_data_get (se->expr); + STRIP_NOPS (pointer); + + if (allocatable) + { + not_prev_allocated = gfc_create_var (logical_type_node, + "not_prev_allocated"); + tmp = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), 0)); + + gfc_add_modify (&se->pre, not_prev_allocated, tmp); + } + + gfc_start_block (&elseblock); + + /* The allocatable variant takes the old pointer as first argument. */ + if (allocatable) + gfc_allocate_allocatable (&elseblock, pointer, size, token, + status, errmsg, errlen, label_finish, expr, + coref != NULL ? coref->u.ar.as->corank : 0); + else if (non_ulimate_coarray_ptr_comp && token) + /* The token is set only for GFC_FCOARRAY_LIB mode. */ + gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status, + errmsg, errlen, + GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY); + else + gfc_allocate_using_malloc (&elseblock, pointer, size, status); + + if (dimension) + { + cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, + logical_type_node, var_overflow, integer_zero_node), + PRED_FORTRAN_OVERFLOW); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + error, gfc_finish_block (&elseblock)); + } + else + tmp = gfc_finish_block (&elseblock); + + gfc_add_expr_to_block (&se->pre, tmp); + + /* Update the array descriptor with the offset and the span. */ + if (dimension) + { + gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + tmp = fold_convert (gfc_array_index_type, element_size); + gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); + } + + set_descriptor = gfc_finish_block (&set_descriptor_block); + if (status != NULL_TREE) + { + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, status, + build_int_cst (TREE_TYPE (status), 0)); + + if (not_prev_allocated != NULL_TREE) + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, cond, not_prev_allocated); + + gfc_add_expr_to_block (&se->pre, + fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, + set_descriptor, + build_empty_stmt (input_location))); + } + else + gfc_add_expr_to_block (&se->pre, set_descriptor); + + return true; +} + + +/* Create an array constructor from an initialization expression. + We assume the frontend already did any expansions and conversions. */ + +tree +gfc_conv_array_initializer (tree type, gfc_expr * expr) +{ + gfc_constructor *c; + tree tmp; + gfc_se se; + tree index, range; + vec *v = NULL; + + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->attr.flavor == FL_PARAMETER + && expr->symtree->n.sym->value) + expr = expr->symtree->n.sym->value; + + switch (expr->expr_type) + { + case EXPR_CONSTANT: + case EXPR_STRUCTURE: + /* A single scalar or derived type value. Create an array with all + elements equal to that value. */ + gfc_init_se (&se, NULL); + + if (expr->expr_type == EXPR_CONSTANT) + gfc_conv_constant (&se, expr); + else + gfc_conv_structure (&se, expr, 1); + + CONSTRUCTOR_APPEND_ELT (v, build2 (RANGE_EXPR, gfc_array_index_type, + TYPE_MIN_VALUE (TYPE_DOMAIN (type)), + TYPE_MAX_VALUE (TYPE_DOMAIN (type))), + se.expr); + break; + + case EXPR_ARRAY: + /* Create a vector of all the elements. */ + for (c = gfc_constructor_first (expr->value.constructor); + c && c->expr; c = gfc_constructor_next (c)) + { + if (c->iterator) + { + /* Problems occur when we get something like + integer :: a(lots) = (/(i, i=1, lots)/) */ + gfc_fatal_error ("The number of elements in the array " + "constructor at %L requires an increase of " + "the allowed %d upper limit. See " + "%<-fmax-array-constructor%> option", + &expr->where, flag_max_array_constructor); + return NULL_TREE; + } + if (mpz_cmp_si (c->offset, 0) != 0) + index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); + else + index = NULL_TREE; + + if (mpz_cmp_si (c->repeat, 1) > 0) + { + tree tmp1, tmp2; + mpz_t maxval; + + mpz_init (maxval); + mpz_add (maxval, c->offset, c->repeat); + mpz_sub_ui (maxval, maxval, 1); + tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); + if (mpz_cmp_si (c->offset, 0) != 0) + { + mpz_add_ui (maxval, c->offset, 1); + tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); + } + else + tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); + + range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2); + mpz_clear (maxval); + } + else + range = NULL; + + gfc_init_se (&se, NULL); + switch (c->expr->expr_type) + { + case EXPR_CONSTANT: + gfc_conv_constant (&se, c->expr); + + /* See gfortran.dg/charlen_15.f90 for instance. */ + if (TREE_CODE (se.expr) == STRING_CST + && TREE_CODE (type) == ARRAY_TYPE) + { + tree atype = type; + while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE) + atype = TREE_TYPE (atype); + gcc_checking_assert (TREE_CODE (TREE_TYPE (atype)) + == INTEGER_TYPE); + gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr)) + == TREE_TYPE (atype)); + if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr))) + > tree_to_uhwi (TYPE_SIZE_UNIT (atype))) + { + unsigned HOST_WIDE_INT size + = tree_to_uhwi (TYPE_SIZE_UNIT (atype)); + const char *p = TREE_STRING_POINTER (se.expr); + + se.expr = build_string (size, p); + } + TREE_TYPE (se.expr) = atype; + } + break; + + case EXPR_STRUCTURE: + gfc_conv_structure (&se, c->expr, 1); + break; + + default: + /* Catch those occasional beasts that do not simplify + for one reason or another, assuming that if they are + standard defying the frontend will catch them. */ + gfc_conv_expr (&se, c->expr); + break; + } + + if (range == NULL_TREE) + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); + else + { + if (index != NULL_TREE) + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); + CONSTRUCTOR_APPEND_ELT (v, range, se.expr); + } + } + break; + + case EXPR_NULL: + return gfc_build_null_descriptor (type); + + default: + gcc_unreachable (); + } + + /* Create a constructor from the list of elements. */ + tmp = build_constructor (type, v); + TREE_CONSTANT (tmp) = 1; + return tmp; +} + + +/* Generate code to evaluate non-constant coarray cobounds. */ + +void +gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, + const gfc_symbol *sym) +{ + int dim; + tree ubound; + tree lbound; + gfc_se se; + gfc_array_spec *as; + + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + + for (dim = as->rank; dim < as->rank + as->corank; dim++) + { + /* Evaluate non-constant array bound expressions. */ + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (as->lower[dim] && !INTEGER_CST_P (lbound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, lbound, se.expr); + } + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + if (as->upper[dim] && !INTEGER_CST_P (ubound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, ubound, se.expr); + } + } +} + + +/* Generate code to evaluate non-constant array bounds. Sets *poffset and + returns the size (in elements) of the array. */ + +tree +gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, + stmtblock_t * pblock) +{ + gfc_array_spec *as; + tree size; + tree stride; + tree offset; + tree ubound; + tree lbound; + tree tmp; + gfc_se se; + + int dim; + + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + + size = gfc_index_one_node; + offset = gfc_index_zero_node; + for (dim = 0; dim < as->rank; dim++) + { + /* Evaluate non-constant array bound expressions. */ + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (as->lower[dim] && !INTEGER_CST_P (lbound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, lbound, se.expr); + } + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + if (as->upper[dim] && !INTEGER_CST_P (ubound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, ubound, se.expr); + } + /* The offset of this dimension. offset = offset - lbound * stride. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + lbound, size); + offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + offset, tmp); + + /* The size of this dimension, and the stride of the next. */ + if (dim + 1 < as->rank) + stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1); + else + stride = GFC_TYPE_ARRAY_SIZE (type); + + if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, ubound, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + if (stride) + gfc_add_modify (pblock, stride, tmp); + else + stride = gfc_evaluate_now (tmp, pblock); + + /* Make sure that negative size arrays are translated + to being zero size. */ + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + stride, gfc_index_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, tmp, + stride, gfc_index_zero_node); + gfc_add_modify (pblock, stride, tmp); + } + + size = stride; + } + + gfc_trans_array_cobounds (type, pblock, sym); + gfc_trans_vla_type_sizes (sym, pblock); + + *poffset = offset; + return size; +} + + +/* Generate code to initialize/allocate an array variable. */ + +void +gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, + gfc_wrapped_block * block) +{ + stmtblock_t init; + tree type; + tree tmp = NULL_TREE; + tree size; + tree offset; + tree space; + tree inittree; + bool onstack; + + gcc_assert (!(sym->attr.pointer || sym->attr.allocatable)); + + /* Do nothing for USEd variables. */ + if (sym->attr.use_assoc) + return; + + type = TREE_TYPE (decl); + gcc_assert (GFC_ARRAY_TYPE_P (type)); + onstack = TREE_CODE (type) != POINTER_TYPE; + + gfc_init_block (&init); + + /* Evaluate character string length. */ + if (sym->ts.type == BT_CHARACTER + && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) + { + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + + gfc_trans_vla_type_sizes (sym, &init); + + /* Emit a DECL_EXPR for this variable, which will cause the + gimplifier to allocate storage, and all that good stuff. */ + tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); + gfc_add_expr_to_block (&init, tmp); + } + + if (onstack) + { + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; + } + + type = TREE_TYPE (type); + + gcc_assert (!sym->attr.use_assoc); + gcc_assert (!TREE_STATIC (decl)); + gcc_assert (!sym->module); + + if (sym->ts.type == BT_CHARACTER + && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + + size = gfc_trans_array_bounds (type, sym, &offset, &init); + + /* Don't actually allocate space for Cray Pointees. */ + if (sym->attr.cray_pointee) + { + if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; + } + + if (flag_stack_arrays) + { + gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE); + space = build_decl (gfc_get_location (&sym->declared_at), + VAR_DECL, create_tmp_var_name ("A"), + TREE_TYPE (TREE_TYPE (decl))); + gfc_trans_vla_type_sizes (sym, &init); + } + else + { + /* The size is the number of elements in the array, so multiply by the + size of an element to get the total size. */ + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, fold_convert (gfc_array_index_type, tmp)); + + /* Allocate memory to hold the data. */ + tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); + gfc_add_modify (&init, decl, tmp); + + /* Free the temporary. */ + tmp = gfc_call_free (decl); + space = NULL_TREE; + } + + /* Set offset of the array. */ + if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + /* Automatic arrays should not have initializers. */ + gcc_assert (!sym->value); + + inittree = gfc_finish_block (&init); + + if (space) + { + tree addr; + pushdecl (space); + + /* Don't create new scope, emit the DECL_EXPR in exactly the scope + where also space is located. */ + gfc_init_block (&init); + tmp = fold_build1_loc (input_location, DECL_EXPR, + TREE_TYPE (space), space); + gfc_add_expr_to_block (&init, tmp); + addr = fold_build1_loc (gfc_get_location (&sym->declared_at), + ADDR_EXPR, TREE_TYPE (decl), space); + gfc_add_modify (&init, decl, addr); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + tmp = NULL_TREE; + } + gfc_add_init_cleanup (block, inittree, tmp); +} + + +/* Generate entry and exit code for g77 calling convention arrays. */ + +void +gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) +{ + tree parm; + tree type; + locus loc; + tree offset; + tree tmp; + tree stmt; + stmtblock_t init; + + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + + /* Descriptor type. */ + parm = sym->backend_decl; + type = TREE_TYPE (parm); + gcc_assert (GFC_ARRAY_TYPE_P (type)); + + gfc_start_block (&init); + + if (sym->ts.type == BT_CHARACTER + && VAR_P (sym->ts.u.cl->backend_decl)) + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + + /* Evaluate the bounds of the array. */ + gfc_trans_array_bounds (type, sym, &offset, &init); + + /* Set the offset. */ + if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + /* Set the pointer itself if we aren't using the parameter directly. */ + if (TREE_CODE (parm) != PARM_DECL) + { + tmp = GFC_DECL_SAVED_DESCRIPTOR (parm); + if (sym->ts.type == BT_CLASS) + { + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = gfc_class_data_get (tmp); + tmp = gfc_conv_descriptor_data_get (tmp); + } + tmp = convert (TREE_TYPE (parm), tmp); + gfc_add_modify (&init, parm, tmp); + } + stmt = gfc_finish_block (&init); + + gfc_restore_backend_locus (&loc); + + /* Add the initialization code to the start of the function. */ + + if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) + || sym->attr.optional + || sym->attr.not_always_present) + { + tree nullify; + if (TREE_CODE (parm) != PARM_DECL) + nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + parm, null_pointer_node); + else + nullify = build_empty_stmt (input_location); + tmp = gfc_conv_expr_present (sym, true); + stmt = build3_v (COND_EXPR, tmp, stmt, nullify); + } + + gfc_add_init_cleanup (block, stmt, NULL_TREE); +} + + +/* Modify the descriptor of an array parameter so that it has the + correct lower bound. Also move the upper bound accordingly. + If the array is not packed, it will be copied into a temporary. + For each dimension we set the new lower and upper bounds. Then we copy the + stride and calculate the offset for this dimension. We also work out + what the stride of a packed array would be, and see it the two match. + If the array need repacking, we set the stride to the values we just + calculated, recalculate the offset and copy the array data. + Code is also added to copy the data back at the end of the function. + */ + +void +gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, + gfc_wrapped_block * block) +{ + tree size; + tree type; + tree offset; + locus loc; + stmtblock_t init; + tree stmtInit, stmtCleanup; + tree lbound; + tree ubound; + tree dubound; + tree dlbound; + tree dumdesc; + tree tmp; + tree stride, stride2; + tree stmt_packed; + tree stmt_unpacked; + tree partial; + gfc_se se; + int n; + int checkparm; + int no_repack; + bool optional_arg; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); + + /* Do nothing for pointer and allocatable arrays. */ + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || sym->attr.allocatable + || (is_classarray && CLASS_DATA (sym)->attr.allocatable)) + return; + + if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym)) + { + gfc_trans_g77_array (sym, block); + return; + } + + loc.nextc = NULL; + gfc_save_backend_locus (&loc); + /* loc.nextc is not set by save_backend_locus but the location routines + depend on it. */ + if (loc.nextc == NULL) + loc.nextc = loc.lb->line; + gfc_set_backend_locus (&sym->declared_at); + + /* Descriptor type. */ + type = TREE_TYPE (tmpdesc); + gcc_assert (GFC_ARRAY_TYPE_P (type)); + dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); + if (is_classarray) + /* For a class array the dummy array descriptor is in the _class + component. */ + dumdesc = gfc_class_data_get (dumdesc); + else + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as; + gfc_start_block (&init); + + if (sym->ts.type == BT_CHARACTER + && VAR_P (sym->ts.u.cl->backend_decl)) + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + + /* TODO: Fix the exclusion of class arrays from extent checking. */ + checkparm = (as->type == AS_EXPLICIT && !is_classarray + && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); + + no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) + || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); + + if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) + { + /* For non-constant shape arrays we only check if the first dimension + is contiguous. Repacking higher dimensions wouldn't gain us + anything as we still don't know the array stride. */ + partial = gfc_create_var (logical_type_node, "partial"); + TREE_USED (partial) = 1; + tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, + gfc_index_one_node); + gfc_add_modify (&init, partial, tmp); + } + else + partial = NULL_TREE; + + /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive + here, however I think it does the right thing. */ + if (no_repack) + { + /* Set the first stride. */ + stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); + stride = gfc_evaluate_now (stride, &init); + + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + stride, gfc_index_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node, stride); + stride = GFC_TYPE_ARRAY_STRIDE (type, 0); + gfc_add_modify (&init, stride, tmp); + + /* Allow the user to disable array repacking. */ + stmt_unpacked = NULL_TREE; + } + else + { + gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0))); + /* A library call to repack the array if necessary. */ + tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); + stmt_unpacked = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, tmp); + + stride = gfc_index_one_node; + + if (warn_array_temporaries) + gfc_warning (OPT_Warray_temporaries, + "Creating array temporary at %L", &loc); + } + + /* This is for the case where the array data is used directly without + calling the repack function. */ + if (no_repack || partial != NULL_TREE) + stmt_packed = gfc_conv_descriptor_data_get (dumdesc); + else + stmt_packed = NULL_TREE; + + /* Assign the data pointer. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + { + /* Don't repack unknown shape arrays when the first stride is 1. */ + tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed), + partial, stmt_packed, stmt_unpacked); + } + else + tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; + gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); + + offset = gfc_index_zero_node; + size = gfc_index_one_node; + + /* Evaluate the bounds of the array. */ + for (n = 0; n < as->rank; n++) + { + if (checkparm || !as->upper[n]) + { + /* Get the bounds of the actual parameter. */ + dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); + dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); + } + else + { + dubound = NULL_TREE; + dlbound = NULL_TREE; + } + + lbound = GFC_TYPE_ARRAY_LBOUND (type, n); + if (!INTEGER_CST_P (lbound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[n], + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, lbound, se.expr); + } + + ubound = GFC_TYPE_ARRAY_UBOUND (type, n); + /* Set the desired upper bound. */ + if (as->upper[n]) + { + /* We know what we want the upper bound to be. */ + if (!INTEGER_CST_P (ubound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[n], + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, ubound, se.expr); + } + + /* Check the sizes match. */ + if (checkparm) + { + /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ + char * msg; + tree temp; + + temp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + temp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, temp); + stride2 = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, dubound, + dlbound); + stride2 = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, stride2); + tmp = fold_build2_loc (input_location, NE_EXPR, + gfc_array_index_type, temp, stride2); + msg = xasprintf ("Dimension %d of array '%s' has extent " + "%%ld instead of %%ld", n+1, sym->name); + + gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, + fold_convert (long_integer_type_node, temp), + fold_convert (long_integer_type_node, stride2)); + + free (msg); + } + } + else + { + /* For assumed shape arrays move the upper bound by the same amount + as the lower bound. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, dubound, dlbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, lbound); + gfc_add_modify (&init, ubound, tmp); + } + /* The offset of this dimension. offset = offset - lbound * stride. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + lbound, stride); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); + + /* The size of this dimension, and the stride of the next. */ + if (n + 1 < as->rank) + { + stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); + + if (no_repack || partial != NULL_TREE) + stmt_unpacked = + gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); + + /* Figure out the stride if not a known constant. */ + if (!INTEGER_CST_P (stride)) + { + if (no_repack) + stmt_packed = NULL_TREE; + else + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, ubound, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + stmt_packed = size; + } + + /* Assign the stride. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + tmp = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, partial, + stmt_unpacked, stmt_packed); + else + tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; + gfc_add_modify (&init, stride, tmp); + } + } + else + { + stride = GFC_TYPE_ARRAY_SIZE (type); + + if (stride && !INTEGER_CST_P (stride)) + { + /* Calculate size = stride * (ubound + 1 - lbound). */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + ubound, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + GFC_TYPE_ARRAY_STRIDE (type, n), tmp); + gfc_add_modify (&init, stride, tmp); + } + } + } + + gfc_trans_array_cobounds (type, &init, sym); + + /* Set the offset. */ + if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + gfc_trans_vla_type_sizes (sym, &init); + + stmtInit = gfc_finish_block (&init); + + /* Only do the entry/initialization code if the arg is present. */ + dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); + optional_arg = (sym->attr.optional + || (sym->ns->proc_name->attr.entry_master + && sym->attr.dummy)); + if (optional_arg) + { + tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node); + zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + tmpdesc, zero_init); + tmp = gfc_conv_expr_present (sym, true); + stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init); + } + + /* Cleanup code. */ + if (no_repack) + stmtCleanup = NULL_TREE; + else + { + stmtblock_t cleanup; + gfc_start_block (&cleanup); + + if (sym->attr.intent != INTENT_IN) + { + /* Copy the data back. */ + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc); + gfc_add_expr_to_block (&cleanup, tmp); + } + + /* Free the temporary. */ + tmp = gfc_call_free (tmpdesc); + gfc_add_expr_to_block (&cleanup, tmp); + + stmtCleanup = gfc_finish_block (&cleanup); + + /* Only do the cleanup if the array was repacked. */ + if (is_classarray) + /* For a class array the dummy array descriptor is in the _class + component. */ + tmp = gfc_class_data_get (dumdesc); + else + tmp = build_fold_indirect_ref_loc (input_location, dumdesc); + tmp = gfc_conv_descriptor_data_get (tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tmp, tmpdesc); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); + + if (optional_arg) + { + tmp = gfc_conv_expr_present (sym); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); + } + } + + /* We don't need to free any memory allocated by internal_pack as it will + be freed at the end of the function by pop_context. */ + gfc_add_init_cleanup (block, stmtInit, stmtCleanup); + + gfc_restore_backend_locus (&loc); +} + + +/* Calculate the overall offset, including subreferences. */ +void +gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, + bool subref, gfc_expr *expr) +{ + tree tmp; + tree field; + tree stride; + tree index; + gfc_ref *ref; + gfc_se start; + int n; + + /* If offset is NULL and this is not a subreferenced array, there is + nothing to do. */ + if (offset == NULL_TREE) + { + if (subref) + offset = gfc_index_zero_node; + else + return; + } + + tmp = build_array_ref (desc, offset, NULL, NULL); + + /* Offset the data pointer for pointer assignments from arrays with + subreferences; e.g. my_integer => my_type(:)%integer_component. */ + if (subref) + { + /* Go past the array reference. */ + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && + ref->u.ar.type != AR_ELEMENT) + { + ref = ref->next; + break; + } + + /* Calculate the offset for each subsequent subreference. */ + for (; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + field = ref->u.c.component->backend_decl; + gcc_assert (field && TREE_CODE (field) == FIELD_DECL); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), + tmp, field, NULL_TREE); + break; + + case REF_SUBSTRING: + gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); + gfc_init_se (&start, NULL); + gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); + gfc_add_block_to_block (block, &start.pre); + tmp = gfc_build_array_ref (tmp, start.expr, NULL); + break; + + case REF_ARRAY: + gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE + && ref->u.ar.type == AR_ELEMENT); + + /* TODO - Add bounds checking. */ + stride = gfc_index_one_node; + index = gfc_index_zero_node; + for (n = 0; n < ref->u.ar.dimen; n++) + { + tree itmp; + tree jtmp; + + /* Update the index. */ + gfc_init_se (&start, NULL); + gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type); + itmp = gfc_evaluate_now (start.expr, block); + gfc_init_se (&start, NULL); + gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type); + jtmp = gfc_evaluate_now (start.expr, block); + itmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, itmp, jtmp); + itmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, itmp, stride); + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, itmp, index); + index = gfc_evaluate_now (index, block); + + /* Update the stride. */ + gfc_init_se (&start, NULL); + gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type); + itmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, start.expr, + jtmp); + itmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, itmp); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, itmp); + stride = gfc_evaluate_now (stride, block); + } + + /* Apply the index to obtain the array element. */ + tmp = gfc_build_array_ref (tmp, index, NULL); + break; + + case REF_INQUIRY: + switch (ref->u.i) + { + case INQUIRY_RE: + tmp = fold_build1_loc (input_location, REALPART_EXPR, + TREE_TYPE (TREE_TYPE (tmp)), tmp); + break; + + case INQUIRY_IM: + tmp = fold_build1_loc (input_location, IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (tmp)), tmp); + break; + + default: + break; + } + break; + + default: + gcc_unreachable (); + break; + } + } + } + + /* Set the target data pointer. */ + offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp); + gfc_conv_descriptor_data_set (block, parm, offset); +} + + +/* gfc_conv_expr_descriptor needs the string length an expression + so that the size of the temporary can be obtained. This is done + by adding up the string lengths of all the elements in the + expression. Function with non-constant expressions have their + string lengths mapped onto the actual arguments using the + interface mapping machinery in trans-expr.c. */ +static void +get_array_charlen (gfc_expr *expr, gfc_se *se) +{ + gfc_interface_mapping mapping; + gfc_formal_arglist *formal; + gfc_actual_arglist *arg; + gfc_se tse; + gfc_expr *e; + + if (expr->ts.u.cl->length + && gfc_is_constant_expr (expr->ts.u.cl->length)) + { + if (!expr->ts.u.cl->backend_decl) + gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); + return; + } + + switch (expr->expr_type) + { + case EXPR_ARRAY: + + /* This is somewhat brutal. The expression for the first + element of the array is evaluated and assigned to a + new string length for the original expression. */ + e = gfc_constructor_first (expr->value.constructor)->expr; + + gfc_init_se (&tse, NULL); + + /* Avoid evaluating trailing array references since all we need is + the string length. */ + if (e->rank) + tse.descriptor_only = 1; + if (e->rank && e->expr_type != EXPR_VARIABLE) + gfc_conv_expr_descriptor (&tse, e); + else + gfc_conv_expr (&tse, e); + + gfc_add_block_to_block (&se->pre, &tse.pre); + gfc_add_block_to_block (&se->post, &tse.post); + + if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl)) + { + expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + expr->ts.u.cl->backend_decl = + gfc_create_var (gfc_charlen_type_node, "sln"); + } + + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, + tse.string_length); + + /* Make sure that deferred length components point to the hidden + string_length component. */ + if (TREE_CODE (tse.expr) == COMPONENT_REF + && TREE_CODE (tse.string_length) == COMPONENT_REF + && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0)) + e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl; + + return; + + case EXPR_OP: + get_array_charlen (expr->value.op.op1, se); + + /* For parentheses the expression ts.u.cl should be identical. */ + if (expr->value.op.op == INTRINSIC_PARENTHESES) + { + if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl) + expr->ts.u.cl->backend_decl + = expr->value.op.op1->ts.u.cl->backend_decl; + return; + } + + expr->ts.u.cl->backend_decl = + gfc_create_var (gfc_charlen_type_node, "sln"); + + if (expr->value.op.op2) + { + get_array_charlen (expr->value.op.op2, se); + + gcc_assert (expr->value.op.op == INTRINSIC_CONCAT); + + /* Add the string lengths and assign them to the expression + string length backend declaration. */ + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, + fold_build2_loc (input_location, PLUS_EXPR, + gfc_charlen_type_node, + expr->value.op.op1->ts.u.cl->backend_decl, + expr->value.op.op2->ts.u.cl->backend_decl)); + } + else + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, + expr->value.op.op1->ts.u.cl->backend_decl); + break; + + case EXPR_FUNCTION: + if (expr->value.function.esym == NULL + || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT) + { + gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); + break; + } + + /* Map expressions involving the dummy arguments onto the actual + argument expressions. */ + gfc_init_interface_mapping (&mapping); + formal = gfc_sym_get_dummy_args (expr->symtree->n.sym); + arg = expr->value.function.actual; + + /* Set se = NULL in the calls to the interface mapping, to suppress any + backend stuff. */ + for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + { + if (!arg->expr) + continue; + if (formal->sym) + gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr); + } + + gfc_init_se (&tse, NULL); + + /* Build the expression for the character length and convert it. */ + gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length); + + gfc_add_block_to_block (&se->pre, &tse.pre); + gfc_add_block_to_block (&se->post, &tse.post); + tse.expr = fold_convert (gfc_charlen_type_node, tse.expr); + tse.expr = fold_build2_loc (input_location, MAX_EXPR, + TREE_TYPE (tse.expr), tse.expr, + build_zero_cst (TREE_TYPE (tse.expr))); + expr->ts.u.cl->backend_decl = tse.expr; + gfc_free_interface_mapping (&mapping); + break; + + default: + gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre); + break; + } +} + + +/* Helper function to check dimensions. */ +static bool +transposed_dims (gfc_ss *ss) +{ + int n; + + for (n = 0; n < ss->dimen; n++) + if (ss->dim[n] != n) + return true; + return false; +} + + +/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an + AR_FULL, suitable for the scalarizer. */ + +static gfc_ss * +walk_coarray (gfc_expr *e) +{ + gfc_ss *ss; + + gcc_assert (gfc_get_corank (e) > 0); + + ss = gfc_walk_expr (e); + + /* Fix scalar coarray. */ + if (ss == gfc_ss_terminator) + { + gfc_ref *ref; + + ref = e->ref; + while (ref) + { + if (ref->type == REF_ARRAY + && ref->u.ar.codimen > 0) + break; + + ref = ref->next; + } + + gcc_assert (ref != NULL); + if (ref->u.ar.type == AR_ELEMENT) + ref->u.ar.type = AR_SECTION; + ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref)); + } + + return ss; +} + + +/* Convert an array for passing as an actual argument. Expressions and + vector subscripts are evaluated and stored in a temporary, which is then + passed. For whole arrays the descriptor is passed. For array sections + a modified copy of the descriptor is passed, but using the original data. + + This function is also used for array pointer assignments, and there + are three cases: + + - se->want_pointer && !se->direct_byref + EXPR is an actual argument. On exit, se->expr contains a + pointer to the array descriptor. + + - !se->want_pointer && !se->direct_byref + EXPR is an actual argument to an intrinsic function or the + left-hand side of a pointer assignment. On exit, se->expr + contains the descriptor for EXPR. + + - !se->want_pointer && se->direct_byref + EXPR is the right-hand side of a pointer assignment and + se->expr is the descriptor for the previously-evaluated + left-hand side. The function creates an assignment from + EXPR to se->expr. + + + The se->force_tmp flag disables the non-copying descriptor optimization + that is used for transpose. It may be used in cases where there is an + alias between the transpose argument and another argument in the same + function call. */ + +void +gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) +{ + gfc_ss *ss; + gfc_ss_type ss_type; + gfc_ss_info *ss_info; + gfc_loopinfo loop; + gfc_array_info *info; + int need_tmp; + int n; + tree tmp; + tree desc; + stmtblock_t block; + tree start; + int full; + bool subref_array_target = false; + bool deferred_array_component = false; + gfc_expr *arg, *ss_expr; + + if (se->want_coarray) + ss = walk_coarray (expr); + else + ss = gfc_walk_expr (expr); + + gcc_assert (ss != NULL); + gcc_assert (ss != gfc_ss_terminator); + + ss_info = ss->info; + ss_type = ss_info->type; + ss_expr = ss_info->expr; + + /* Special case: TRANSPOSE which needs no temporary. */ + while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym + && (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL) + { + /* This is a call to transpose which has already been handled by the + scalarizer, so that we just need to get its argument's descriptor. */ + gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); + expr = expr->value.function.actual->expr; + } + + if (!se->direct_byref) + se->unlimited_polymorphic = UNLIMITED_POLY (expr); + + /* Special case things we know we can pass easily. */ + switch (expr->expr_type) + { + case EXPR_VARIABLE: + /* If we have a linear array section, we can pass it directly. + Otherwise we need to copy it into a temporary. */ + + gcc_assert (ss_type == GFC_SS_SECTION); + gcc_assert (ss_expr == expr); + info = &ss_info->data.array; + + /* Get the descriptor for the array. */ + gfc_conv_ss_descriptor (&se->pre, ss, 0); + desc = info->descriptor; + + /* The charlen backend decl for deferred character components cannot + be used because it is fixed at zero. Instead, the hidden string + length component is used. */ + if (expr->ts.type == BT_CHARACTER + && expr->ts.deferred + && TREE_CODE (desc) == COMPONENT_REF) + deferred_array_component = true; + + subref_array_target = (is_subref_array (expr) + && (se->direct_byref + || expr->ts.type == BT_CHARACTER)); + need_tmp = (gfc_ref_needs_temporary_p (expr->ref) + && !subref_array_target); + + if (se->force_tmp) + need_tmp = 1; + else if (se->force_no_tmp) + need_tmp = 0; + + if (need_tmp) + full = 0; + else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + { + /* Create a new descriptor if the array doesn't have one. */ + full = 0; + } + else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only) + full = 1; + else if (se->direct_byref) + full = 0; + else if (info->ref->u.ar.dimen == 0 && !info->ref->next) + full = 1; + else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer) + full = 0; + else + full = gfc_full_array_ref_p (info->ref, NULL); + + if (full && !transposed_dims (ss)) + { + if (se->direct_byref && !se->byref_noassign) + { + /* Copy the descriptor for pointer assignments. */ + gfc_add_modify (&se->pre, se->expr, desc); + + /* Add any offsets from subreferences. */ + gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE, + subref_array_target, expr); + + /* ....and set the span field. */ + tmp = gfc_conv_descriptor_span_get (desc); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); + } + else if (se->want_pointer) + { + /* We pass full arrays directly. This means that pointers and + allocatable arrays should also work. */ + se->expr = gfc_build_addr_expr (NULL_TREE, desc); + } + else + { + se->expr = desc; + } + + if (expr->ts.type == BT_CHARACTER && !deferred_array_component) + se->string_length = gfc_get_expr_charlen (expr); + /* The ss_info string length is returned set to the value of the + hidden string length component. */ + else if (deferred_array_component) + se->string_length = ss_info->string_length; + + gfc_free_ss_chain (ss); + return; + } + break; + + case EXPR_FUNCTION: + /* A transformational function return value will be a temporary + array descriptor. We still need to go through the scalarizer + to create the descriptor. Elemental functions are handled as + arbitrary expressions, i.e. copy to a temporary. */ + + if (se->direct_byref) + { + gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr); + + /* For pointer assignments pass the descriptor directly. */ + if (se->ss == NULL) + se->ss = ss; + else + gcc_assert (se->ss == ss); + + if (!is_pointer_array (se->expr)) + { + tmp = gfc_get_element_type (TREE_TYPE (se->expr)); + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (tmp)); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); + } + + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); + gfc_conv_expr (se, expr); + + gfc_free_ss_chain (ss); + return; + } + + if (ss_expr != expr || ss_type != GFC_SS_FUNCTION) + { + if (ss_expr != expr) + /* Elemental function. */ + gcc_assert ((expr->value.function.esym != NULL + && expr->value.function.esym->attr.elemental) + || (expr->value.function.isym != NULL + && expr->value.function.isym->elemental) + || (gfc_expr_attr (expr).proc_pointer + && gfc_expr_attr (expr).elemental) + || gfc_inline_intrinsic_function_p (expr)); + + need_tmp = 1; + if (expr->ts.type == BT_CHARACTER + && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) + get_array_charlen (expr, se); + + info = NULL; + } + else + { + /* Transformational function. */ + info = &ss_info->data.array; + need_tmp = 0; + } + break; + + case EXPR_ARRAY: + /* Constant array constructors don't need a temporary. */ + if (ss_type == GFC_SS_CONSTRUCTOR + && expr->ts.type != BT_CHARACTER + && gfc_constant_array_constructor_p (expr->value.constructor)) + { + need_tmp = 0; + info = &ss_info->data.array; + } + else + { + need_tmp = 1; + info = NULL; + } + break; + + default: + /* Something complicated. Copy it into a temporary. */ + need_tmp = 1; + info = NULL; + break; + } + + /* If we are creating a temporary, we don't need to bother about aliases + anymore. */ + if (need_tmp) + se->force_tmp = 0; + + gfc_init_loopinfo (&loop); + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, ss); + + /* Tell the scalarizer not to bother creating loop variables, etc. */ + if (!need_tmp) + loop.array_parameter = 1; + else + /* The right-hand side of a pointer assignment mustn't use a temporary. */ + gcc_assert (!se->direct_byref); + + /* Do we need bounds checking or not? */ + ss->no_bounds_check = expr->no_bounds_check; + + /* Setup the scalarizing loops and bounds. */ + gfc_conv_ss_startstride (&loop); + + if (need_tmp) + { + if (expr->ts.type == BT_CHARACTER + && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY)) + get_array_charlen (expr, se); + + /* Tell the scalarizer to make a temporary. */ + loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts), + ((expr->ts.type == BT_CHARACTER) + ? expr->ts.u.cl->backend_decl + : NULL), + loop.dimen); + + se->string_length = loop.temp_ss->info->string_length; + gcc_assert (loop.temp_ss->dimen == loop.dimen); + gfc_add_ss_to_loop (&loop, loop.temp_ss); + } + + gfc_conv_loop_setup (&loop, & expr->where); + + if (need_tmp) + { + /* Copy into a temporary and pass that. We don't need to copy the data + back because expressions and vector subscripts must be INTENT_IN. */ + /* TODO: Optimize passing function return values. */ + gfc_se lse; + gfc_se rse; + bool deep_copy; + + /* Start the copying loops. */ + gfc_mark_ss_chain_used (loop.temp_ss, 1); + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &block); + + /* Copy each data element. */ + gfc_init_se (&lse, NULL); + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_init_se (&rse, NULL); + gfc_copy_loopinfo_to_se (&rse, &loop); + + lse.ss = loop.temp_ss; + rse.ss = ss; + + gfc_conv_scalarized_array_ref (&lse, NULL); + if (expr->ts.type == BT_CHARACTER) + { + gfc_conv_expr (&rse, expr); + if (POINTER_TYPE_P (TREE_TYPE (rse.expr))) + rse.expr = build_fold_indirect_ref_loc (input_location, + rse.expr); + } + else + gfc_conv_expr_val (&rse, expr); + + gfc_add_block_to_block (&block, &rse.pre); + gfc_add_block_to_block (&block, &lse.pre); + + lse.string_length = rse.string_length; + + deep_copy = !se->data_not_needed + && (expr->expr_type == EXPR_VARIABLE + || expr->expr_type == EXPR_ARRAY); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, + deep_copy, false); + gfc_add_expr_to_block (&block, tmp); + + /* Finish the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &block); + + desc = loop.temp_ss->info->data.array.descriptor; + } + else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss)) + { + desc = info->descriptor; + se->string_length = ss_info->string_length; + } + else + { + /* We pass sections without copying to a temporary. Make a new + descriptor and point it at the section we want. The loop variable + limits will be the limits of the section. + A function may decide to repack the array to speed up access, but + we're not bothered about that here. */ + int dim, ndim, codim; + tree parm; + tree parmtype; + tree dtype; + tree stride; + tree from; + tree to; + tree base; + tree offset; + + ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; + + if (se->want_coarray) + { + gfc_array_ref *ar = &info->ref->u.ar; + + codim = gfc_get_corank (expr); + for (n = 0; n < codim - 1; n++) + { + /* Make sure we are not lost somehow. */ + gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE); + + /* Make sure the call to gfc_conv_section_startstride won't + generate unnecessary code to calculate stride. */ + gcc_assert (ar->stride[n + ndim] == NULL); + + gfc_conv_section_startstride (&loop.pre, ss, n + ndim); + loop.from[n + loop.dimen] = info->start[n + ndim]; + loop.to[n + loop.dimen] = info->end[n + ndim]; + } + + gcc_assert (n == codim - 1); + evaluate_bound (&loop.pre, info->start, ar->start, + info->descriptor, n + ndim, true, + ar->as->type == AS_DEFERRED); + loop.from[n + loop.dimen] = info->start[n + ndim]; + } + else + codim = 0; + + /* Set the string_length for a character array. */ + if (expr->ts.type == BT_CHARACTER) + { + if (deferred_array_component) + se->string_length = ss_info->string_length; + else + se->string_length = gfc_get_expr_charlen (expr); + + if (VAR_P (se->string_length) + && expr->ts.u.cl->backend_decl == se->string_length) + tmp = ss_info->string_length; + else + tmp = se->string_length; + + if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl)) + gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); + else + expr->ts.u.cl->backend_decl = tmp; + } + + /* If we have an array section, are assigning or passing an array + section argument make sure that the lower bound is 1. References + to the full array should otherwise keep the original bounds. */ + if (!info->ref || info->ref->u.ar.type != AR_FULL) + for (dim = 0; dim < loop.dimen; dim++) + if (!integer_onep (loop.from[dim])) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, gfc_index_one_node, + loop.from[dim]); + loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + loop.to[dim], tmp); + loop.from[dim] = gfc_index_one_node; + } + + desc = info->descriptor; + if (se->direct_byref && !se->byref_noassign) + { + /* For pointer assignments we fill in the destination. */ + parm = se->expr; + parmtype = TREE_TYPE (parm); + } + else + { + /* Otherwise make a new one. */ + if (expr->ts.type == BT_CHARACTER) + parmtype = gfc_typenode_for_spec (&expr->ts); + else + parmtype = gfc_get_element_type (TREE_TYPE (desc)); + + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, + loop.from, loop.to, 0, + GFC_ARRAY_UNKNOWN, false); + parm = gfc_create_var (parmtype, "parm"); + + /* When expression is a class object, then add the class' handle to + the parm_decl. */ + if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE) + { + gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr); + gfc_se classse; + + /* class_expr can be NULL, when no _class ref is in expr. + We must not fix this here with a gfc_fix_class_ref (). */ + if (class_expr) + { + gfc_init_se (&classse, NULL); + gfc_conv_expr (&classse, class_expr); + gfc_free_expr (class_expr); + + gcc_assert (classse.pre.head == NULL_TREE + && classse.post.head == NULL_TREE); + gfc_allocate_lang_decl (parm); + GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr; + } + } + } + + /* Set the span field. */ + tmp = gfc_get_array_span (desc, expr); + if (tmp) + gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); + + /* The following can be somewhat confusing. We have two + descriptors, a new one and the original array. + {parm, parmtype, dim} refer to the new one. + {desc, type, n, loop} refer to the original, which maybe + a descriptorless array. + The bounds of the scalarization are the bounds of the section. + We don't have to worry about numeric overflows when calculating + the offsets because all elements are within the array data. */ + + /* Set the dtype. */ + tmp = gfc_conv_descriptor_dtype (parm); + if (se->unlimited_polymorphic) + dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen); + else if (expr->ts.type == BT_ASSUMED) + { + tree tmp2 = desc; + if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2)) + tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2); + if (POINTER_TYPE_P (TREE_TYPE (tmp2))) + tmp2 = build_fold_indirect_ref_loc (input_location, tmp2); + dtype = gfc_conv_descriptor_dtype (tmp2); + } + else + dtype = gfc_get_dtype (parmtype); + gfc_add_modify (&loop.pre, tmp, dtype); + + /* The 1st element in the section. */ + base = gfc_index_zero_node; + + /* The offset from the 1st element in the section. */ + offset = gfc_index_zero_node; + + for (n = 0; n < ndim; n++) + { + stride = gfc_conv_array_stride (desc, n); + + /* Work out the 1st element in the section. */ + if (info->ref + && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) + { + gcc_assert (info->subscript[n] + && info->subscript[n]->info->type == GFC_SS_SCALAR); + start = info->subscript[n]->info->data.scalar.value; + } + else + { + /* Evaluate and remember the start of the section. */ + start = info->start[n]; + stride = gfc_evaluate_now (stride, &loop.pre); + } + + tmp = gfc_conv_array_lbound (desc, n); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), + start, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), + tmp, stride); + base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), + base, tmp); + + if (info->ref + && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) + { + /* For elemental dimensions, we only need the 1st + element in the section. */ + continue; + } + + /* Vector subscripts need copying and are handled elsewhere. */ + if (info->ref) + gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE); + + /* look for the corresponding scalarizer dimension: dim. */ + for (dim = 0; dim < ndim; dim++) + if (ss->dim[dim] == n) + break; + + /* loop exited early: the DIM being looked for has been found. */ + gcc_assert (dim < ndim); + + /* Set the new lower bound. */ + from = loop.from[dim]; + to = loop.to[dim]; + + gfc_conv_descriptor_lbound_set (&loop.pre, parm, + gfc_rank_cst[dim], from); + + /* Set the new upper bound. */ + gfc_conv_descriptor_ubound_set (&loop.pre, parm, + gfc_rank_cst[dim], to); + + /* Multiply the stride by the section stride to get the + total stride. */ + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + stride, info->stride[n]); + + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (offset), stride, from); + offset = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (offset), offset, tmp); + + /* Store the new stride. */ + gfc_conv_descriptor_stride_set (&loop.pre, parm, + gfc_rank_cst[dim], stride); + } + + for (n = loop.dimen; n < loop.dimen + codim; n++) + { + from = loop.from[n]; + to = loop.to[n]; + gfc_conv_descriptor_lbound_set (&loop.pre, parm, + gfc_rank_cst[n], from); + if (n < loop.dimen + codim - 1) + gfc_conv_descriptor_ubound_set (&loop.pre, parm, + gfc_rank_cst[n], to); + } + + if (se->data_not_needed) + gfc_conv_descriptor_data_set (&loop.pre, parm, + gfc_index_zero_node); + else + /* Point the data pointer at the 1st element in the section. */ + gfc_get_dataptr_offset (&loop.pre, parm, desc, base, + subref_array_target, expr); + + gfc_conv_descriptor_offset_set (&loop.pre, parm, offset); + + desc = parm; + } + + /* For class arrays add the class tree into the saved descriptor to + enable getting of _vptr and the like. */ + if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) + && IS_CLASS_ARRAY (expr->symtree->n.sym)) + { + gfc_allocate_lang_decl (desc); + GFC_DECL_SAVED_DESCRIPTOR (desc) = + DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ? + GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) + : expr->symtree->n.sym->backend_decl; + } + else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc) + && IS_CLASS_ARRAY (expr)) + { + tree vtype; + gfc_allocate_lang_decl (desc); + tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class"); + GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp; + vtype = gfc_class_vptr_get (tmp); + gfc_add_modify (&se->pre, vtype, + gfc_build_addr_expr (TREE_TYPE (vtype), + gfc_find_vtab (&expr->ts)->backend_decl)); + } + if (!se->direct_byref || se->byref_noassign) + { + /* Get a pointer to the new descriptor. */ + if (se->want_pointer) + se->expr = gfc_build_addr_expr (NULL_TREE, desc); + else + se->expr = desc; + } + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->post, &loop.post); + + /* Cleanup the scalarizer. */ + gfc_cleanup_loop (&loop); +} + + +/* Calculate the array size (number of elements); if dim != NULL_TREE, + return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */ +tree +gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim) +{ + if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + { + gcc_assert (dim == NULL_TREE); + return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); + } + tree size, tmp, rank = NULL_TREE, cond = NULL_TREE; + symbol_attribute attr = gfc_expr_attr (expr); + gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); + if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + || !dim) + { + if (expr->rank < 0) + rank = fold_convert (signed_char_type_node, + gfc_conv_descriptor_rank (desc)); + else + rank = build_int_cst (signed_char_type_node, expr->rank); + } + + if (dim || expr->rank == 1) + { + if (!dim) + dim = gfc_index_zero_node; + tree ubound = gfc_conv_descriptor_ubound_get (desc, dim); + tree lbound = gfc_conv_descriptor_lbound_get (desc, dim); + + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + /* if (!allocatable && !pointer && assumed rank) + size = (idx == rank && ubound[rank-1] == -1 ? -1 : size; + else + size = max (0, size); */ + size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + size, gfc_index_zero_node); + if (!attr.pointer && !attr.allocatable + && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + fold_convert (signed_char_type_node, dim), + tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, dim), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + tmp = build_int_cst (gfc_array_index_type, -1); + size = build3_loc (input_location, COND_EXPR, gfc_array_index_type, + cond, tmp, size); + } + return size; + } + + /* size = 1. */ + size = gfc_create_var (gfc_array_index_type, "size"); + gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1)); + tree extent = gfc_create_var (gfc_array_index_type, "extent"); + + stmtblock_t cond_block, loop_body; + gfc_init_block (&cond_block); + gfc_init_block (&loop_body); + + /* Loop: for (i = 0; i < rank; ++i). */ + tree idx = gfc_create_var (signed_char_type_node, "idx"); + /* Loop body. */ + /* #if (assumed-rank + !allocatable && !pointer) + if (idx == rank - 1 && dim[idx].ubound == -1) + extent = -1; + else + #endif + extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1 + if (extent < 0) + extent = 0 + size *= extent. */ + cond = NULL_TREE; + if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node, + rank, build_int_cst (signed_char_type_node, 1)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + idx, tmp); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_ubound_get (desc, idx), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond, tmp); + } + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, idx), + gfc_conv_descriptor_lbound_get (desc, idx)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + gfc_add_modify (&cond_block, extent, tmp); + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + extent, gfc_index_zero_node); + tmp = build3_v (COND_EXPR, tmp, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, + extent, gfc_index_zero_node), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&cond_block, tmp); + tmp = gfc_finish_block (&cond_block); + if (cond) + tmp = build3_v (COND_EXPR, cond, + fold_build2_loc (input_location, MODIFY_EXPR, + gfc_array_index_type, extent, + build_int_cst (gfc_array_index_type, -1)), + tmp); + gfc_add_expr_to_block (&loop_body, tmp); + /* size *= extent. */ + gfc_add_modify (&loop_body, size, + fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, extent)); + /* Generate loop. */ + gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, + build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + return size; +} + +/* Helper function for gfc_conv_array_parameter if array size needs to be + computed. */ + +static void +array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size) +{ + tree elem; + *size = gfc_tree_array_size (block, desc, expr, NULL); + elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); + *size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + *size, fold_convert (gfc_array_index_type, elem)); +} + +/* Helper function - return true if the argument is a pointer. */ + +static bool +is_pointer (gfc_expr *e) +{ + gfc_symbol *sym; + + if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL) + return false; + + sym = e->symtree->n.sym; + if (sym == NULL) + return false; + + return sym->attr.pointer || sym->attr.proc_pointer; +} + +/* Convert an array for passing as an actual parameter. */ + +void +gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, + const gfc_symbol *fsym, const char *proc_name, + tree *size) +{ + tree ptr; + tree desc; + tree tmp = NULL_TREE; + tree stmt; + tree parent = DECL_CONTEXT (current_function_decl); + bool full_array_var; + bool this_array_result; + bool contiguous; + bool no_pack; + bool array_constructor; + bool good_allocatable; + bool ultimate_ptr_comp; + bool ultimate_alloc_comp; + gfc_symbol *sym; + stmtblock_t block; + gfc_ref *ref; + + ultimate_ptr_comp = false; + ultimate_alloc_comp = false; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->next == NULL) + break; + + if (ref->type == REF_COMPONENT) + { + ultimate_ptr_comp = ref->u.c.component->attr.pointer; + ultimate_alloc_comp = ref->u.c.component->attr.allocatable; + } + } + + full_array_var = false; + contiguous = false; + + if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp) + full_array_var = gfc_full_array_ref_p (ref, &contiguous); + + sym = full_array_var ? expr->symtree->n.sym : NULL; + + /* The symbol should have an array specification. */ + gcc_assert (!sym || sym->as || ref->u.ar.as); + + if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER) + { + get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp); + expr->ts.u.cl->backend_decl = tmp; + se->string_length = tmp; + } + + /* Is this the result of the enclosing procedure? */ + this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); + if (this_array_result + && (sym->backend_decl != current_function_decl) + && (sym->backend_decl != parent)) + this_array_result = false; + + /* Passing address of the array if it is not pointer or assumed-shape. */ + if (full_array_var && g77 && !this_array_result + && sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) + { + tmp = gfc_get_symbol_decl (sym); + + if (sym->ts.type == BT_CHARACTER) + se->string_length = sym->ts.u.cl->backend_decl; + + if (!sym->attr.pointer + && sym->as + && sym->as->type != AS_ASSUMED_SHAPE + && sym->as->type != AS_DEFERRED + && sym->as->type != AS_ASSUMED_RANK + && !sym->attr.allocatable) + { + /* Some variables are declared directly, others are declared as + pointers and allocated on the heap. */ + if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp))) + se->expr = tmp; + else + se->expr = gfc_build_addr_expr (NULL_TREE, tmp); + if (size) + array_parameter_size (&se->pre, tmp, expr, size); + return; + } + + if (sym->attr.allocatable) + { + if (sym->attr.dummy || sym->attr.result) + { + gfc_conv_expr_descriptor (se, expr); + tmp = se->expr; + } + if (size) + array_parameter_size (&se->pre, tmp, expr, size); + se->expr = gfc_conv_array_data (tmp); + return; + } + } + + /* A convenient reduction in scope. */ + contiguous = g77 && !this_array_result && contiguous; + + /* There is no need to pack and unpack the array, if it is contiguous + and not a deferred- or assumed-shape array, or if it is simply + contiguous. */ + no_pack = ((sym && sym->as + && !sym->attr.pointer + && sym->as->type != AS_DEFERRED + && sym->as->type != AS_ASSUMED_RANK + && sym->as->type != AS_ASSUMED_SHAPE) + || + (ref && ref->u.ar.as + && ref->u.ar.as->type != AS_DEFERRED + && ref->u.ar.as->type != AS_ASSUMED_RANK + && ref->u.ar.as->type != AS_ASSUMED_SHAPE) + || + gfc_is_simply_contiguous (expr, false, true)); + + no_pack = contiguous && no_pack; + + /* If we have an EXPR_OP or a function returning an explicit-shaped + or allocatable array, an array temporary will be generated which + does not need to be packed / unpacked if passed to an + explicit-shape dummy array. */ + + if (g77) + { + if (expr->expr_type == EXPR_OP) + no_pack = 1; + else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym) + { + gfc_symbol *result = expr->value.function.esym->result; + if (result->attr.dimension + && (result->as->type == AS_EXPLICIT + || result->attr.allocatable + || result->attr.contiguous)) + no_pack = 1; + } + } + + /* Array constructors are always contiguous and do not need packing. */ + array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY; + + /* Same is true of contiguous sections from allocatable variables. */ + good_allocatable = contiguous + && expr->symtree + && expr->symtree->n.sym->attr.allocatable; + + /* Or ultimate allocatable components. */ + ultimate_alloc_comp = contiguous && ultimate_alloc_comp; + + if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) + { + gfc_conv_expr_descriptor (se, expr); + /* Deallocate the allocatable components of structures that are + not variable. */ + if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && expr->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_VARIABLE) + { + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank); + + /* The components shall be deallocated before their containing entity. */ + gfc_prepend_expr_to_block (&se->post, tmp); + } + if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION) + se->string_length = expr->ts.u.cl->backend_decl; + if (size) + array_parameter_size (&se->pre, se->expr, expr, size); + se->expr = gfc_conv_array_data (se->expr); + return; + } + + if (this_array_result) + { + /* Result of the enclosing function. */ + gfc_conv_expr_descriptor (se, expr); + if (size) + array_parameter_size (&se->pre, se->expr, expr, size); + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); + + if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr)))) + se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location, + se->expr)); + + return; + } + else + { + /* Every other type of array. */ + se->want_pointer = 1; + gfc_conv_expr_descriptor (se, expr); + + if (size) + array_parameter_size (&se->pre, + build_fold_indirect_ref_loc (input_location, + se->expr), + expr, size); + } + + /* Deallocate the allocatable components of structures that are + not variable, for descriptorless arguments. + Arguments with a descriptor are handled in gfc_conv_procedure_call. */ + if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && expr->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_VARIABLE) + { + tmp = build_fold_indirect_ref_loc (input_location, se->expr); + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); + + /* The components shall be deallocated before their containing entity. */ + gfc_prepend_expr_to_block (&se->post, tmp); + } + + if (g77 || (fsym && fsym->attr.contiguous + && !gfc_is_simply_contiguous (expr, false, true))) + { + tree origptr = NULL_TREE; + + desc = se->expr; + + /* For contiguous arrays, save the original value of the descriptor. */ + if (!g77) + { + origptr = gfc_create_var (pvoid_type_node, "origptr"); + tmp = build_fold_indirect_ref_loc (input_location, desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (origptr), origptr, + fold_convert (TREE_TYPE (origptr), tmp)); + gfc_add_expr_to_block (&se->pre, tmp); + } + + /* Repack the array. */ + if (warn_array_temporaries) + { + if (fsym) + gfc_warning (OPT_Warray_temporaries, + "Creating array temporary at %L for argument %qs", + &expr->where, fsym->name); + else + gfc_warning (OPT_Warray_temporaries, + "Creating array temporary at %L", &expr->where); + } + + /* When optmizing, we can use gfc_conv_subref_array_arg for + making the packing and unpacking operation visible to the + optimizers. */ + + if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE + && !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr) + && !(expr->symtree->n.sym->as + && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK) + && (fsym == NULL || fsym->ts.type != BT_ASSUMED)) + { + gfc_conv_subref_array_arg (se, expr, g77, + fsym ? fsym->attr.intent : INTENT_INOUT, + false, fsym, proc_name, sym, true); + return; + } + + ptr = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, desc); + + if (fsym && fsym->attr.optional && sym && sym->attr.optional) + { + tmp = gfc_conv_expr_present (sym); + ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), + tmp, fold_convert (TREE_TYPE (se->expr), ptr), + fold_convert (TREE_TYPE (se->expr), null_pointer_node)); + } + + ptr = gfc_evaluate_now (ptr, &se->pre); + + /* Use the packed data for the actual argument, except for contiguous arrays, + where the descriptor's data component is set. */ + if (g77) + se->expr = ptr; + else + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + + gfc_ss * ss = gfc_walk_expr (expr); + if (!transposed_dims (ss)) + gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); + else + { + tree old_field, new_field; + + /* The original descriptor has transposed dims so we can't reuse + it directly; we have to create a new one. */ + tree old_desc = tmp; + tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc"); + + old_field = gfc_conv_descriptor_dtype (old_desc); + new_field = gfc_conv_descriptor_dtype (new_desc); + gfc_add_modify (&se->pre, new_field, old_field); + + old_field = gfc_conv_descriptor_offset (old_desc); + new_field = gfc_conv_descriptor_offset (new_desc); + gfc_add_modify (&se->pre, new_field, old_field); + + for (int i = 0; i < expr->rank; i++) + { + old_field = gfc_conv_descriptor_dimension (old_desc, + gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]); + new_field = gfc_conv_descriptor_dimension (new_desc, + gfc_rank_cst[i]); + gfc_add_modify (&se->pre, new_field, old_field); + } + + if (flag_coarray == GFC_FCOARRAY_LIB + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc)) + && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc)) + == GFC_ARRAY_ALLOCATABLE) + { + old_field = gfc_conv_descriptor_token (old_desc); + new_field = gfc_conv_descriptor_token (new_desc); + gfc_add_modify (&se->pre, new_field, old_field); + } + + gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr); + se->expr = gfc_build_addr_expr (NULL_TREE, new_desc); + } + gfc_free_ss (ss); + } + + if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) + { + 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_fold_indirect_ref_loc (input_location, + desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + fold_convert (TREE_TYPE (tmp), ptr), tmp); + + if (fsym && fsym->attr.optional && sym && sym->attr.optional) + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, + gfc_conv_expr_present (sym), tmp); + + gfc_trans_runtime_check (false, true, tmp, &se->pre, + &expr->where, msg); + free (msg); + } + + gfc_start_block (&block); + + /* Copy the data back. */ + if (fsym == NULL || fsym->attr.intent != INTENT_IN) + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_unpack, 2, desc, ptr); + gfc_add_expr_to_block (&block, tmp); + } + + /* Free the temporary. */ + tmp = gfc_call_free (ptr); + gfc_add_expr_to_block (&block, tmp); + + stmt = gfc_finish_block (&block); + + gfc_init_block (&block); + /* Only if it was repacked. This code needs to be executed before the + loop cleanup code. */ + tmp = build_fold_indirect_ref_loc (input_location, + desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + fold_convert (TREE_TYPE (tmp), ptr), tmp); + + if (fsym && fsym->attr.optional && sym && sym->attr.optional) + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, + gfc_conv_expr_present (sym), tmp); + + tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se->post); + + gfc_init_block (&se->post); + + /* Reset the descriptor pointer. */ + if (!g77) + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->post, tmp, origptr); + } + + gfc_add_block_to_block (&se->post, &block); + } +} + + +/* This helper function calculates the size in words of a full array. */ + +tree +gfc_full_array_size (stmtblock_t *block, tree decl, int rank) +{ + tree idx; + tree nelems; + tree tmp; + idx = gfc_rank_cst[rank - 1]; + nelems = gfc_conv_descriptor_ubound_get (decl, idx); + tmp = gfc_conv_descriptor_lbound_get (decl, idx); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + nelems, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = gfc_evaluate_now (tmp, block); + + nelems = gfc_conv_descriptor_stride_get (decl, idx); + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + nelems, tmp); + return gfc_evaluate_now (tmp, block); +} + + +/* Allocate dest to the same size as src, and copy src -> dest. + If no_malloc is set, only the copy is done. */ + +static tree +duplicate_allocatable (tree dest, tree src, tree type, int rank, + bool no_malloc, bool no_memcpy, tree str_sz, + tree add_when_allocated) +{ + tree tmp; + tree size; + tree nelems; + tree null_cond; + tree null_data; + stmtblock_t block; + + /* If the source is null, set the destination to null. Then, + allocate memory to the destination. */ + gfc_init_block (&block); + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) + { + gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + if (str_sz != NULL_TREE) + size = str_sz; + else + size = TYPE_SIZE_UNIT (TREE_TYPE (type)); + + if (!no_malloc) + { + tmp = gfc_call_malloc (&block, type, size); + gfc_add_modify (&block, dest, fold_convert (type, tmp)); + } + + if (!no_memcpy) + { + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (&block, tmp); + } + } + else + { + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + if (rank) + nelems = gfc_full_array_size (&block, src, rank); + else + nelems = gfc_index_one_node; + + if (str_sz != NULL_TREE) + tmp = fold_convert (gfc_array_index_type, str_sz); + else + tmp = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + nelems, tmp); + if (!no_malloc) + { + tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src)); + tmp = gfc_call_malloc (&block, tmp, size); + gfc_conv_descriptor_data_set (&block, dest, tmp); + } + + /* We know the temporary and the value will be the same length, + so can use memcpy. */ + if (!no_memcpy) + { + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, + gfc_conv_descriptor_data_get (dest), + gfc_conv_descriptor_data_get (src), + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (&block, tmp); + } + } + + gfc_add_expr_to_block (&block, add_when_allocated); + tmp = gfc_finish_block (&block); + + /* Null the destination if the source is null; otherwise do + the allocate and copy. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) + null_cond = src; + else + null_cond = gfc_conv_descriptor_data_get (src); + + null_cond = convert (pvoid_type_node, null_cond); + null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + null_cond, null_pointer_node); + return build3_v (COND_EXPR, null_cond, tmp, null_data); +} + + +/* Allocate dest to the same size as src, and copy data src -> dest. */ + +tree +gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank, + tree add_when_allocated) +{ + return duplicate_allocatable (dest, src, type, rank, false, false, + NULL_TREE, add_when_allocated); +} + + +/* Copy data src -> dest. */ + +tree +gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) +{ + return duplicate_allocatable (dest, src, type, rank, true, false, + NULL_TREE, NULL_TREE); +} + +/* Allocate dest to the same size as src, but don't copy anything. */ + +tree +gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) +{ + return duplicate_allocatable (dest, src, type, rank, false, true, + NULL_TREE, NULL_TREE); +} + + +static tree +duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, + tree type, int rank) +{ + tree tmp; + tree size; + tree nelems; + tree null_cond; + tree null_data; + stmtblock_t block, globalblock; + + /* If the source is null, set the destination to null. Then, + allocate memory to the destination. */ + gfc_init_block (&block); + gfc_init_block (&globalblock); + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) + { + gfc_se se; + symbol_attribute attr; + tree dummy_desc; + + gfc_init_se (&se, NULL); + gfc_clear_attr (&attr); + attr.allocatable = 1; + dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr); + gfc_add_block_to_block (&globalblock, &se.pre); + size = TYPE_SIZE_UNIT (TREE_TYPE (type)); + + gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node)); + gfc_allocate_using_caf_lib (&block, dummy_desc, size, + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + + gfc_allocate_using_caf_lib (&block, dummy_desc, + fold_convert (size_type_node, size), + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC); + + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + /* Set the rank or unitialized memory access may be reported. */ + tmp = gfc_conv_descriptor_rank (dest); + gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank)); + + if (rank) + nelems = gfc_full_array_size (&block, src, rank); + else + nelems = integer_one_node; + + tmp = fold_convert (size_type_node, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, nelems), tmp); + + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node, + size), + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); + null_data = gfc_finish_block (&block); + + gfc_init_block (&block); + gfc_allocate_using_caf_lib (&block, dest, + fold_convert (size_type_node, size), + gfc_build_addr_expr (NULL_TREE, dest_tok), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC); + + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, + gfc_conv_descriptor_data_get (dest), + gfc_conv_descriptor_data_get (src), + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (&block, tmp); + } + + tmp = gfc_finish_block (&block); + + /* Null the destination if the source is null; otherwise do + the register and copy. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))) + null_cond = src; + else + null_cond = gfc_conv_descriptor_data_get (src); + + null_cond = convert (pvoid_type_node, null_cond); + null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + null_cond, null_pointer_node); + gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp, + null_data)); + return gfc_finish_block (&globalblock); +} + + +/* Helper function to abstract whether coarray processing is enabled. */ + +static bool +caf_enabled (int caf_mode) +{ + return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY) + == GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY; +} + + +/* Helper function to abstract whether coarray processing is enabled + and we are in a derived type coarray. */ + +static bool +caf_in_coarray (int caf_mode) +{ + static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY; + return (caf_mode & pat) == pat; +} + + +/* Helper function to abstract whether coarray is to deallocate only. */ + +bool +gfc_caf_is_dealloc_only (int caf_mode) +{ + return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY) + == GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY; +} + + +/* Recursively traverse an object of derived type, generating code to + deallocate, nullify or copy allocatable components. This is the work horse + function for the functions named in this enum. */ + +enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, + COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP, + ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY, + BCAST_ALLOC_COMP}; + +static gfc_actual_arglist *pdt_param_list; + +static tree +structure_alloc_comps (gfc_symbol * der_type, tree decl, + tree dest, int rank, int purpose, int caf_mode, + gfc_co_subroutines_args *args) +{ + gfc_component *c; + gfc_loopinfo loop; + stmtblock_t fnblock; + stmtblock_t loopbody; + stmtblock_t tmpblock; + tree decl_type; + tree tmp; + tree comp; + tree dcmp; + tree nelems; + tree index; + tree var; + tree cdecl; + tree ctype; + tree vref, dref; + tree null_cond = NULL_TREE; + tree add_when_allocated; + tree dealloc_fndecl; + tree caf_token; + gfc_symbol *vtab; + int caf_dereg_mode; + symbol_attribute *attr; + bool deallocate_called; + + gfc_init_block (&fnblock); + + decl_type = TREE_TYPE (decl); + + if ((POINTER_TYPE_P (decl_type)) + || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) + { + decl = build_fold_indirect_ref_loc (input_location, decl); + /* Deref dest in sync with decl, but only when it is not NULL. */ + if (dest) + dest = build_fold_indirect_ref_loc (input_location, dest); + + /* Update the decl_type because it got dereferenced. */ + decl_type = TREE_TYPE (decl); + } + + /* If this is an array of derived types with allocatable components + build a loop and recursively call this function. */ + if (TREE_CODE (decl_type) == ARRAY_TYPE + || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) + { + tmp = gfc_conv_array_data (decl); + var = build_fold_indirect_ref_loc (input_location, tmp); + + /* Get the number of elements - 1 and set the counter. */ + if (GFC_DESCRIPTOR_TYPE_P (decl_type)) + { + /* Use the descriptor for an allocatable array. Since this + is a full array reference, we only need the descriptor + information from dimension = rank. */ + tmp = gfc_full_array_size (&fnblock, decl, rank); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + + null_cond = gfc_conv_descriptor_data_get (decl); + null_cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, null_cond, + build_int_cst (TREE_TYPE (null_cond), 0)); + } + else + { + /* Otherwise use the TYPE_DOMAIN information. */ + tmp = array_type_nelts (decl_type); + tmp = fold_convert (gfc_array_index_type, tmp); + } + + /* Remember that this is, in fact, the no. of elements - 1. */ + nelems = gfc_evaluate_now (tmp, &fnblock); + index = gfc_create_var (gfc_array_index_type, "S"); + + /* Build the body of the loop. */ + gfc_init_block (&loopbody); + + vref = gfc_build_array_ref (var, index, NULL); + + if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) + { + tmp = build_fold_indirect_ref_loc (input_location, + gfc_conv_array_data (dest)); + dref = gfc_build_array_ref (tmp, index, NULL); + tmp = structure_alloc_comps (der_type, vref, dref, rank, + COPY_ALLOC_COMP, caf_mode, args); + } + else + tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, + caf_mode, args); + + 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_add_block_to_block (&fnblock, &loop.pre); + + tmp = gfc_finish_block (&fnblock); + /* When copying allocateable components, the above implements the + deep copy. Nevertheless is a deep copy only allowed, when the current + component is allocated, for which code will be generated in + gfc_duplicate_allocatable (), where the deep copy code is just added + into the if's body, by adding tmp (the deep copy code) as last + argument to gfc_duplicate_allocatable (). */ + if (purpose == COPY_ALLOC_COMP + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))) + tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank, + tmp); + else if (null_cond != NULL_TREE) + tmp = build3_v (COND_EXPR, null_cond, tmp, + build_empty_stmt (input_location)); + + return tmp; + } + + if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type) + { + tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, + DEALLOCATE_PDT_COMP, 0, args); + gfc_add_expr_to_block (&fnblock, tmp); + } + else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp) + { + tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, + NULLIFY_ALLOC_COMP, 0, args); + gfc_add_expr_to_block (&fnblock, tmp); + } + + /* Otherwise, act on the components or recursively call self to + act on a chain of components. */ + for (c = der_type->components; c; c = c->next) + { + bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED + || c->ts.type == BT_CLASS) + && c->ts.u.derived->attr.alloc_comp; + bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived) + || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived); + + bool is_pdt_type = c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.pdt_type; + + cdecl = c->backend_decl; + ctype = TREE_TYPE (cdecl); + + switch (purpose) + { + + case BCAST_ALLOC_COMP: + + tree ubound; + tree cdesc; + stmtblock_t derived_type_block; + + gfc_init_block (&tmpblock); + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + /* Shortcut to get the attributes of the component. */ + if (c->ts.type == BT_CLASS) + { + attr = &CLASS_DATA (c)->attr; + if (attr->class_pointer) + continue; + } + else + { + attr = &c->attr; + if (attr->pointer) + continue; + } + + add_when_allocated = NULL_TREE; + if (cmp_has_alloc_comps + && !c->attr.pointer && !c->attr.proc_pointer) + { + if (c->ts.type == BT_CLASS) + { + rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; + add_when_allocated + = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, + comp, NULL_TREE, rank, purpose, + caf_mode, args); + } + else + { + rank = c->as ? c->as->rank : 0; + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, NULL_TREE, + rank, purpose, + caf_mode, args); + } + } + + gfc_init_block (&derived_type_block); + if (add_when_allocated) + gfc_add_expr_to_block (&derived_type_block, add_when_allocated); + tmp = gfc_finish_block (&derived_type_block); + gfc_add_expr_to_block (&tmpblock, tmp); + + /* Convert the component into a rank 1 descriptor type. */ + if (attr->dimension) + { + tmp = gfc_get_element_type (TREE_TYPE (comp)); + ubound = gfc_full_array_size (&tmpblock, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); + } + else + { + tmp = TREE_TYPE (comp); + ubound = build_int_cst (gfc_array_index_type, 1); + } + + cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, + &ubound, 1, + GFC_ARRAY_ALLOCATABLE, false); + + cdesc = gfc_create_var (cdesc, "cdesc"); + DECL_ARTIFICIAL (cdesc) = 1; + + gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), + gfc_get_dtype_rank_type (1, tmp)); + gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_stride_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, + gfc_index_zero_node, ubound); + + if (attr->dimension) + comp = gfc_conv_descriptor_data_get (comp); + else + { + gfc_se se; + + gfc_init_se (&se, NULL); + + comp = gfc_conv_scalar_to_descriptor (&se, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->attr + : c->attr); + comp = gfc_build_addr_expr (NULL_TREE, comp); + gfc_add_block_to_block (&tmpblock, &se.pre); + } + + gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); + + tree fndecl; + + fndecl = build_call_expr_loc (input_location, + gfor_fndecl_co_broadcast, 5, + gfc_build_addr_expr (pvoid_type_node,cdesc), + args->image_index, + null_pointer_node, null_pointer_node, + null_pointer_node); + + gfc_add_expr_to_block (&tmpblock, fndecl); + gfc_add_block_to_block (&fnblock, &tmpblock); + + break; + + case DEALLOCATE_ALLOC_COMP: + + gfc_init_block (&tmpblock); + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + /* Shortcut to get the attributes of the component. */ + if (c->ts.type == BT_CLASS) + { + attr = &CLASS_DATA (c)->attr; + if (attr->class_pointer) + continue; + } + else + { + attr = &c->attr; + if (attr->pointer) + continue; + } + + if ((c->ts.type == BT_DERIVED && !c->attr.pointer) + || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) + /* Call the finalizer, which will free the memory and nullify the + pointer of an array. */ + deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, + caf_enabled (caf_mode)) + && attr->dimension; + else + deallocate_called = false; + + /* Add the _class ref for classes. */ + if (c->ts.type == BT_CLASS && attr->allocatable) + comp = gfc_class_data_get (comp); + + add_when_allocated = NULL_TREE; + if (cmp_has_alloc_comps + && !c->attr.pointer && !c->attr.proc_pointer + && !same_type + && !deallocate_called) + { + /* Add checked deallocation of the components. This code is + obviously added because the finalizer is not trusted to free + all memory. */ + if (c->ts.type == BT_CLASS) + { + rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0; + add_when_allocated + = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, + comp, NULL_TREE, rank, purpose, + caf_mode, args); + } + else + { + rank = c->as ? c->as->rank : 0; + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, NULL_TREE, + rank, purpose, + caf_mode, args); + } + } + + if (attr->allocatable && !same_type + && (!attr->codimension || caf_enabled (caf_mode))) + { + /* Handle all types of components besides components of the + same_type as the current one, because those would create an + endless loop. */ + caf_dereg_mode + = (caf_in_coarray (caf_mode) || attr->codimension) + ? (gfc_caf_is_dealloc_only (caf_mode) + ? GFC_CAF_COARRAY_DEALLOCATE_ONLY + : GFC_CAF_COARRAY_DEREGISTER) + : GFC_CAF_COARRAY_NOCOARRAY; + + caf_token = NULL_TREE; + /* Coarray components are handled directly by + deallocate_with_status. */ + if (!attr->codimension + && caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY) + { + if (c->caf_token) + caf_token = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (c->caf_token), + decl, c->caf_token, NULL_TREE); + else if (attr->dimension && !attr->proc_pointer) + caf_token = gfc_conv_descriptor_token (comp); + } + if (attr->dimension && !attr->codimension && !attr->proc_pointer) + /* When this is an array but not in conjunction with a coarray + then add the data-ref. For coarray'ed arrays the data-ref + is added by deallocate_with_status. */ + comp = gfc_conv_descriptor_data_get (comp); + + tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, caf_dereg_mode, + add_when_allocated, caf_token); + + gfc_add_expr_to_block (&tmpblock, tmp); + } + else if (attr->allocatable && !attr->codimension + && !deallocate_called) + { + /* Case of recursive allocatable derived types. */ + tree is_allocated; + tree ubound; + tree cdesc; + stmtblock_t dealloc_block; + + gfc_init_block (&dealloc_block); + if (add_when_allocated) + gfc_add_expr_to_block (&dealloc_block, add_when_allocated); + + /* Convert the component into a rank 1 descriptor type. */ + if (attr->dimension) + { + tmp = gfc_get_element_type (TREE_TYPE (comp)); + ubound = gfc_full_array_size (&dealloc_block, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); + } + else + { + tmp = TREE_TYPE (comp); + ubound = build_int_cst (gfc_array_index_type, 1); + } + + cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, + &ubound, 1, + GFC_ARRAY_ALLOCATABLE, false); + + cdesc = gfc_create_var (cdesc, "cdesc"); + DECL_ARTIFICIAL (cdesc) = 1; + + gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), + gfc_get_dtype_rank_type (1, tmp)); + gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, + gfc_index_zero_node, ubound); + + if (attr->dimension) + comp = gfc_conv_descriptor_data_get (comp); + + gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); + + /* Now call the deallocator. */ + vtab = gfc_find_vtab (&c->ts); + if (vtab->backend_decl == NULL) + gfc_get_symbol_decl (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); + dealloc_fndecl = gfc_vptr_deallocate_get (tmp); + dealloc_fndecl = build_fold_indirect_ref_loc (input_location, + dealloc_fndecl); + tmp = build_int_cst (TREE_TYPE (comp), 0); + is_allocated = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp, + comp); + cdesc = gfc_build_addr_expr (NULL_TREE, cdesc); + + tmp = build_call_expr_loc (input_location, + dealloc_fndecl, 1, + cdesc); + gfc_add_expr_to_block (&dealloc_block, tmp); + + tmp = gfc_finish_block (&dealloc_block); + + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, is_allocated, tmp, + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&tmpblock, tmp); + } + else if (add_when_allocated) + gfc_add_expr_to_block (&tmpblock, add_when_allocated); + + if (c->ts.type == BT_CLASS && attr->allocatable + && (!attr->codimension || !caf_enabled (caf_mode))) + { + /* Finally, reset the vptr to the declared type vtable and, if + necessary reset the _len field. + + First recover the reference to the component and obtain + the vptr. */ + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + tmp = gfc_class_vptr_get (comp); + + if (UNLIMITED_POLY (c)) + { + /* Both vptr and _len field should be nulled. */ + gfc_add_modify (&tmpblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + tmp = gfc_class_len_get (comp); + gfc_add_modify (&tmpblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + } + else + { + /* Build the vtable address and set the vptr with it. */ + tree vtab; + gfc_symbol *vtable; + vtable = gfc_find_derived_vtab (c->ts.u.derived); + vtab = vtable->backend_decl; + if (vtab == NULL_TREE) + vtab = gfc_get_symbol_decl (vtable); + vtab = gfc_build_addr_expr (NULL, vtab); + vtab = fold_convert (TREE_TYPE (tmp), vtab); + gfc_add_modify (&tmpblock, tmp, vtab); + } + } + + /* Now add the deallocation of this component. */ + gfc_add_block_to_block (&fnblock, &tmpblock); + break; + + case NULLIFY_ALLOC_COMP: + /* Nullify + - allocatable components (regular or in class) + - components that have allocatable components + - pointer components when in a coarray. + Skip everything else especially proc_pointers, which may come + coupled with the regular pointer attribute. */ + if (c->attr.proc_pointer + || !(c->attr.allocatable || (c->ts.type == BT_CLASS + && CLASS_DATA (c)->attr.allocatable) + || (cmp_has_alloc_comps + && ((c->ts.type == BT_DERIVED && !c->attr.pointer) + || (c->ts.type == BT_CLASS + && !CLASS_DATA (c)->attr.class_pointer))) + || (caf_in_coarray (caf_mode) && c->attr.pointer))) + continue; + + /* Process class components first, because they always have the + pointer-attribute set which would be caught wrong else. */ + if (c->ts.type == BT_CLASS + && (CLASS_DATA (c)->attr.allocatable + || CLASS_DATA (c)->attr.class_pointer)) + { + tree vptr_decl; + + /* Allocatable CLASS components. */ + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + vptr_decl = gfc_class_vptr_get (comp); + + comp = gfc_class_data_get (comp); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) + gfc_conv_descriptor_data_set (&fnblock, comp, + null_pointer_node); + else + { + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); + gfc_add_expr_to_block (&fnblock, tmp); + } + + /* The dynamic type of a disassociated pointer or unallocated + allocatable variable is its declared type. An unlimited + polymorphic entity has no declared type. */ + if (!UNLIMITED_POLY (c)) + { + vtab = gfc_find_derived_vtab (c->ts.u.derived); + if (!vtab->backend_decl) + gfc_get_symbol_decl (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); + } + else + tmp = build_int_cst (TREE_TYPE (vptr_decl), 0); + + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, vptr_decl, tmp); + gfc_add_expr_to_block (&fnblock, tmp); + + cmp_has_alloc_comps = false; + } + /* Coarrays need the component to be nulled before the api-call + is made. */ + else if (c->attr.pointer || c->attr.allocatable) + { + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + if (c->attr.dimension || c->attr.codimension) + gfc_conv_descriptor_data_set (&fnblock, comp, + null_pointer_node); + else + gfc_add_modify (&fnblock, comp, + build_int_cst (TREE_TYPE (comp), 0)); + if (gfc_deferred_strlen (c, &comp)) + { + comp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (comp), + decl, comp, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (comp), comp, + build_int_cst (TREE_TYPE (comp), 0)); + gfc_add_expr_to_block (&fnblock, tmp); + } + cmp_has_alloc_comps = false; + } + + if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode)) + { + /* Register a component of a derived type coarray with the + coarray library. Do not register ultimate component + coarrays here. They are treated like regular coarrays and + are either allocated on all images or on none. */ + tree token; + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + if (c->attr.dimension) + { + /* Set the dtype, because caf_register needs it. */ + gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp), + gfc_get_dtype (TREE_TYPE (comp))); + tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + token = gfc_conv_descriptor_token (tmp); + } + else + { + gfc_se se; + + gfc_init_se (&se, NULL); + token = fold_build3_loc (input_location, COMPONENT_REF, + pvoid_type_node, decl, c->caf_token, + NULL_TREE); + comp = gfc_conv_scalar_to_descriptor (&se, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->attr + : c->attr); + gfc_add_block_to_block (&fnblock, &se.pre); + } + + gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node, + gfc_build_addr_expr (NULL_TREE, + token), + NULL_TREE, NULL_TREE, NULL_TREE, + GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY); + } + + if (cmp_has_alloc_comps) + { + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + rank = c->as ? c->as->rank : 0; + tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, + rank, purpose, caf_mode, args); + gfc_add_expr_to_block (&fnblock, tmp); + } + break; + + case REASSIGN_CAF_COMP: + if (caf_enabled (caf_mode) + && (c->attr.codimension + || (c->ts.type == BT_CLASS + && (CLASS_DATA (c)->attr.coarray_comp + || caf_in_coarray (caf_mode))) + || (c->ts.type == BT_DERIVED + && (c->ts.u.derived->attr.coarray_comp + || caf_in_coarray (caf_mode)))) + && !same_type) + { + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + dest, cdecl, NULL_TREE); + + if (c->attr.codimension) + { + if (c->ts.type == BT_CLASS) + { + comp = gfc_class_data_get (comp); + dcmp = gfc_class_data_get (dcmp); + } + gfc_conv_descriptor_data_set (&fnblock, dcmp, + gfc_conv_descriptor_data_get (comp)); + } + else + { + tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, + rank, purpose, caf_mode + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY, + args); + gfc_add_expr_to_block (&fnblock, tmp); + } + } + break; + + case COPY_ALLOC_COMP: + if (c->attr.pointer || c->attr.proc_pointer) + continue; + + /* We need source and destination components. */ + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, + cdecl, NULL_TREE); + dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest, + cdecl, NULL_TREE); + dcmp = fold_convert (TREE_TYPE (comp), dcmp); + + if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) + { + tree ftn_tree; + tree size; + tree dst_data; + tree src_data; + tree null_data; + + dst_data = gfc_class_data_get (dcmp); + src_data = gfc_class_data_get (comp); + size = fold_convert (size_type_node, + gfc_class_vtab_size_get (comp)); + + if (CLASS_DATA (c)->attr.dimension) + { + nelems = gfc_conv_descriptor_size (src_data, + CLASS_DATA (c)->as->rank); + size = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, size, + fold_convert (size_type_node, + nelems)); + } + else + nelems = build_int_cst (size_type_node, 1); + + if (CLASS_DATA (c)->attr.dimension + || CLASS_DATA (c)->attr.codimension) + { + src_data = gfc_conv_descriptor_data_get (src_data); + dst_data = gfc_conv_descriptor_data_get (dst_data); + } + + gfc_init_block (&tmpblock); + + gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp), + gfc_class_vptr_get (comp)); + + /* Copy the unlimited '_len' field. If it is greater than zero + (ie. a character(_len)), multiply it by size and use this + for the malloc call. */ + if (UNLIMITED_POLY (c)) + { + gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp), + gfc_class_len_get (comp)); + size = gfc_resize_class_size_with_len (&tmpblock, comp, size); + } + + /* Coarray component have to have the same allocation status and + shape/type-parameter/effective-type on the LHS and RHS of an + intrinsic assignment. Hence, we did not deallocated them - and + do not allocate them here. */ + if (!CLASS_DATA (c)->attr.codimension) + { + ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC); + tmp = build_call_expr_loc (input_location, ftn_tree, 1, size); + gfc_add_modify (&tmpblock, dst_data, + fold_convert (TREE_TYPE (dst_data), tmp)); + } + + tmp = gfc_copy_class_to_class (comp, dcmp, nelems, + UNLIMITED_POLY (c)); + gfc_add_expr_to_block (&tmpblock, tmp); + tmp = gfc_finish_block (&tmpblock); + + gfc_init_block (&tmpblock); + gfc_add_modify (&tmpblock, dst_data, + fold_convert (TREE_TYPE (dst_data), + null_pointer_node)); + null_data = gfc_finish_block (&tmpblock); + + null_cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, src_data, + null_pointer_node); + + gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond, + tmp, null_data)); + continue; + } + + /* To implement guarded deep copy, i.e., deep copy only allocatable + components that are really allocated, the deep copy code has to + be generated first and then added to the if-block in + gfc_duplicate_allocatable (). */ + if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type) + { + rank = c->as ? c->as->rank : 0; + tmp = fold_convert (TREE_TYPE (dcmp), comp); + gfc_add_modify (&fnblock, dcmp, tmp); + add_when_allocated = structure_alloc_comps (c->ts.u.derived, + comp, dcmp, + rank, purpose, + caf_mode, args); + } + else + add_when_allocated = NULL_TREE; + + if (gfc_deferred_strlen (c, &tmp)) + { + tree len, size; + len = tmp; + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (len), + decl, len, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (len), + dest, len, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (len), len, tmp); + gfc_add_expr_to_block (&fnblock, tmp); + size = size_of_string_in_bytes (c->ts.kind, len); + /* This component cannot have allocatable components, + therefore add_when_allocated of duplicate_allocatable () + is always NULL. */ + tmp = duplicate_allocatable (dcmp, comp, ctype, rank, + false, false, size, NULL_TREE); + gfc_add_expr_to_block (&fnblock, tmp); + } + else if (c->attr.pdt_array) + { + tmp = duplicate_allocatable (dcmp, comp, ctype, + c->as ? c->as->rank : 0, + false, false, NULL_TREE, NULL_TREE); + gfc_add_expr_to_block (&fnblock, tmp); + } + else if ((c->attr.allocatable) + && !c->attr.proc_pointer && !same_type + && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension + || caf_in_coarray (caf_mode))) + { + rank = c->as ? c->as->rank : 0; + if (c->attr.codimension) + tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); + else if (flag_coarray == GFC_FCOARRAY_LIB + && caf_in_coarray (caf_mode)) + { + tree dst_tok; + if (c->as) + dst_tok = gfc_conv_descriptor_token (dcmp); + else + { + /* For a scalar allocatable component the caf_token is + the next component. */ + if (!c->caf_token) + c->caf_token = c->next->backend_decl; + dst_tok = fold_build3_loc (input_location, + COMPONENT_REF, + pvoid_type_node, dest, + c->caf_token, + NULL_TREE); + } + tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp, + ctype, rank); + } + else + tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank, + add_when_allocated); + gfc_add_expr_to_block (&fnblock, tmp); + } + else + if (cmp_has_alloc_comps || is_pdt_type) + gfc_add_expr_to_block (&fnblock, add_when_allocated); + + break; + + case ALLOCATE_PDT_COMP: + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + + /* Set the PDT KIND and LEN fields. */ + if (c->attr.pdt_kind || c->attr.pdt_len) + { + gfc_se tse; + gfc_expr *c_expr = NULL; + gfc_actual_arglist *param = pdt_param_list; + gfc_init_se (&tse, NULL); + for (; param; param = param->next) + if (param->name && !strcmp (c->name, param->name)) + c_expr = param->expr; + + if (!c_expr) + c_expr = c->initializer; + + if (c_expr) + { + gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); + gfc_add_modify (&fnblock, comp, tse.expr); + } + } + + if (c->attr.pdt_string) + { + gfc_se tse; + gfc_init_se (&tse, NULL); + tree strlen = NULL_TREE; + gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length); + /* Convert the parameterized string length to its value. The + string length is stored in a hidden field in the same way as + deferred string lengths. */ + gfc_insert_parameter_exprs (e, pdt_param_list); + if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE) + { + gfc_conv_expr_type (&tse, e, + TREE_TYPE (strlen)); + strlen = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (strlen), + decl, strlen, NULL_TREE); + gfc_add_modify (&fnblock, strlen, tse.expr); + c->ts.u.cl->backend_decl = strlen; + } + gfc_free_expr (e); + + /* Scalar parameterized strings can be allocated now. */ + if (!c->as) + { + tmp = fold_convert (gfc_array_index_type, strlen); + tmp = size_of_string_in_bytes (c->ts.kind, tmp); + tmp = gfc_evaluate_now (tmp, &fnblock); + tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp); + gfc_add_modify (&fnblock, comp, tmp); + } + } + + /* Allocate parameterized arrays of parameterized derived types. */ + if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) + && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) + continue; + + if (c->ts.type == BT_CLASS) + comp = gfc_class_data_get (comp); + + if (c->attr.pdt_array) + { + gfc_se tse; + int i; + tree size = gfc_index_one_node; + tree offset = gfc_index_zero_node; + tree lower, upper; + gfc_expr *e; + + /* This chunk takes the expressions for 'lower' and 'upper' + in the arrayspec and substitutes in the expressions for + the parameters from 'pdt_param_list'. The descriptor + fields can then be filled from the values so obtained. */ + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))); + for (i = 0; i < c->as->rank; i++) + { + gfc_init_se (&tse, NULL); + e = gfc_copy_expr (c->as->lower[i]); + gfc_insert_parameter_exprs (e, pdt_param_list); + gfc_conv_expr_type (&tse, e, gfc_array_index_type); + gfc_free_expr (e); + lower = tse.expr; + gfc_conv_descriptor_lbound_set (&fnblock, comp, + gfc_rank_cst[i], + lower); + e = gfc_copy_expr (c->as->upper[i]); + gfc_insert_parameter_exprs (e, pdt_param_list); + gfc_conv_expr_type (&tse, e, gfc_array_index_type); + gfc_free_expr (e); + upper = tse.expr; + gfc_conv_descriptor_ubound_set (&fnblock, comp, + gfc_rank_cst[i], + upper); + gfc_conv_descriptor_stride_set (&fnblock, comp, + gfc_rank_cst[i], + size); + size = gfc_evaluate_now (size, &fnblock); + offset = fold_build2_loc (input_location, + MINUS_EXPR, + gfc_array_index_type, + offset, size); + offset = gfc_evaluate_now (offset, &fnblock); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + upper, lower); + 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 (&fnblock, comp, offset); + if (c->ts.type == BT_CLASS) + { + tmp = gfc_get_vptr_from_expr (comp); + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = gfc_vptr_size_get (tmp); + } + else + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype)); + tmp = fold_convert (gfc_array_index_type, tmp); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + size = gfc_evaluate_now (size, &fnblock); + tmp = gfc_call_malloc (&fnblock, NULL, size); + gfc_conv_descriptor_data_set (&fnblock, comp, tmp); + tmp = gfc_conv_descriptor_dtype (comp); + gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype)); + + if (c->initializer && c->initializer->rank) + { + gfc_init_se (&tse, NULL); + e = gfc_copy_expr (c->initializer); + gfc_insert_parameter_exprs (e, pdt_param_list); + gfc_conv_expr_descriptor (&tse, e); + gfc_add_block_to_block (&fnblock, &tse.pre); + gfc_free_expr (e); + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, + gfc_conv_descriptor_data_get (comp), + gfc_conv_descriptor_data_get (tse.expr), + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_block_to_block (&fnblock, &tse.post); + } + } + + /* Recurse in to PDT components. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && c->ts.u.derived && c->ts.u.derived->attr.pdt_type + && !(c->attr.pointer || c->attr.allocatable)) + { + bool is_deferred = false; + gfc_actual_arglist *tail = c->param_list; + + for (; tail; tail = tail->next) + if (!tail->expr) + is_deferred = true; + + tail = is_deferred ? pdt_param_list : c->param_list; + tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp, + c->as ? c->as->rank : 0, + tail); + gfc_add_expr_to_block (&fnblock, tmp); + } + + break; + + case DEALLOCATE_PDT_COMP: + /* Deallocate array or parameterized string length components + of parameterized derived types. */ + if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT) + && !c->attr.pdt_string + && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type))) + continue; + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + if (c->ts.type == BT_CLASS) + comp = gfc_class_data_get (comp); + + /* Recurse in to PDT components. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && c->ts.u.derived && c->ts.u.derived->attr.pdt_type + && (!c->attr.pointer && !c->attr.allocatable)) + { + tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp, + c->as ? c->as->rank : 0); + gfc_add_expr_to_block (&fnblock, tmp); + } + + if (c->attr.pdt_array) + { + tmp = gfc_conv_descriptor_data_get (comp); + null_cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + tmp = gfc_call_free (tmp); + tmp = build3_v (COND_EXPR, null_cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fnblock, tmp); + gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); + } + else if (c->attr.pdt_string) + { + null_cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, comp, + build_int_cst (TREE_TYPE (comp), 0)); + tmp = gfc_call_free (comp); + tmp = build3_v (COND_EXPR, null_cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fnblock, tmp); + tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); + gfc_add_modify (&fnblock, comp, tmp); + } + + break; + + case CHECK_PDT_DUMMY: + + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + if (c->ts.type == BT_CLASS) + comp = gfc_class_data_get (comp); + + /* Recurse in to PDT components. */ + if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + && c->ts.u.derived && c->ts.u.derived->attr.pdt_type) + { + tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp, + c->as ? c->as->rank : 0, + pdt_param_list); + gfc_add_expr_to_block (&fnblock, tmp); + } + + if (!c->attr.pdt_len) + continue; + else + { + gfc_se tse; + gfc_expr *c_expr = NULL; + gfc_actual_arglist *param = pdt_param_list; + + gfc_init_se (&tse, NULL); + for (; param; param = param->next) + if (!strcmp (c->name, param->name) + && param->spec_type == SPEC_EXPLICIT) + c_expr = param->expr; + + if (c_expr) + { + tree error, cond, cname; + gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + comp, tse.expr); + cname = gfc_build_cstring_const (c->name); + cname = gfc_build_addr_expr (pchar_type_node, cname); + error = gfc_trans_runtime_error (true, NULL, + "The value of the PDT LEN " + "parameter '%s' does not " + "agree with that in the " + "dummy declaration", + cname); + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, cond, error, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fnblock, tmp); + } + } + break; + + default: + gcc_unreachable (); + break; + } + } + + return gfc_finish_block (&fnblock); +} + +/* Recursively traverse an object of derived type, generating code to + nullify allocatable components. */ + +tree +gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, + int caf_mode) +{ + return structure_alloc_comps (der_type, decl, NULL_TREE, rank, + NULLIFY_ALLOC_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); +} + + +/* Recursively traverse an object of derived type, generating code to + deallocate allocatable components. */ + +tree +gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, + int caf_mode) +{ + return structure_alloc_comps (der_type, decl, NULL_TREE, rank, + DEALLOCATE_ALLOC_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); +} + +tree +gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, + tree image_index, tree stat, tree errmsg, + tree errmsg_len) +{ + tree tmp, array; + gfc_se argse; + stmtblock_t block, post_block; + gfc_co_subroutines_args args; + + args.image_index = image_index; + args.stat = stat; + args.errmsg = errmsg; + args.errmsg_len = errmsg_len; + + if (rank == 0) + { + gfc_start_block (&block); + gfc_init_block (&post_block); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + array = argse.expr; + } + else + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, expr); + array = argse.expr; + } + + tmp = structure_alloc_comps (derived, array, NULL_TREE, rank, + BCAST_ALLOC_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args); + return tmp; +} + +/* Recursively traverse an object of derived type, generating code to + deallocate allocatable components. But do not deallocate coarrays. + To be used for intrinsic assignment, which may not change the allocation + status of coarrays. */ + +tree +gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) +{ + return structure_alloc_comps (der_type, decl, NULL_TREE, rank, + DEALLOCATE_ALLOC_COMP, 0, NULL); +} + + +tree +gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) +{ + return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL); +} + + +/* Recursively traverse an object of derived type, generating code to + copy it and its allocatable components. */ + +tree +gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, + int caf_mode) +{ + return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, + caf_mode, NULL); +} + + +/* Recursively traverse an object of derived type, generating code to + copy only its allocatable components. */ + +tree +gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) +{ + return structure_alloc_comps (der_type, decl, dest, rank, + COPY_ONLY_ALLOC_COMP, 0, NULL); +} + + +/* Recursively traverse an object of parameterized derived type, generating + code to allocate parameterized components. */ + +tree +gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank, + gfc_actual_arglist *param_list) +{ + tree res; + gfc_actual_arglist *old_param_list = pdt_param_list; + pdt_param_list = param_list; + res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, + ALLOCATE_PDT_COMP, 0, NULL); + pdt_param_list = old_param_list; + return res; +} + +/* Recursively traverse an object of parameterized derived type, generating + code to deallocate parameterized components. */ + +tree +gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) +{ + return structure_alloc_comps (der_type, decl, NULL_TREE, rank, + DEALLOCATE_PDT_COMP, 0, NULL); +} + + +/* Recursively traverse a dummy of parameterized derived type to check the + values of LEN parameters. */ + +tree +gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank, + gfc_actual_arglist *param_list) +{ + tree res; + gfc_actual_arglist *old_param_list = pdt_param_list; + pdt_param_list = param_list; + res = structure_alloc_comps (der_type, decl, NULL_TREE, rank, + CHECK_PDT_DUMMY, 0, NULL); + pdt_param_list = old_param_list; + return res; +} + + +/* Returns the value of LBOUND for an expression. This could be broken out + from gfc_conv_intrinsic_bound but this seemed to be simpler. This is + called by gfc_alloc_allocatable_for_assignment. */ +static tree +get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) +{ + tree lbound; + tree ubound; + tree stride; + tree cond, cond1, cond3, cond4; + tree tmp; + gfc_ref *ref; + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + { + tmp = gfc_rank_cst[dim]; + lbound = gfc_conv_descriptor_lbound_get (desc, tmp); + ubound = gfc_conv_descriptor_ubound_get (desc, tmp); + stride = gfc_conv_descriptor_stride_get (desc, tmp); + cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + ubound, lbound); + cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + stride, gfc_index_zero_node); + cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, cond3, cond1); + cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + stride, gfc_index_zero_node); + if (assumed_size) + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + tmp, build_int_cst (gfc_array_index_type, + expr->rank - 1)); + else + cond = logical_false_node; + + cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, cond3, cond4); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, cond, cond1); + + return fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + lbound, gfc_index_one_node); + } + + if (expr->expr_type == EXPR_FUNCTION) + { + /* A conversion function, so use the argument. */ + gcc_assert (expr->value.function.isym + && expr->value.function.isym->conversion); + expr = expr->value.function.actual->expr; + } + + if (expr->expr_type == EXPR_VARIABLE) + { + tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl); + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->as + && ref->next + && ref->next->u.ar.type == AR_FULL) + tmp = TREE_TYPE (ref->u.c.component->backend_decl); + } + return GFC_TYPE_ARRAY_LBOUND(tmp, dim); + } + + return gfc_index_one_node; +} + + +/* Returns true if an expression represents an lhs that can be reallocated + on assignment. */ + +bool +gfc_is_reallocatable_lhs (gfc_expr *expr) +{ + gfc_ref * ref; + gfc_symbol *sym; + + if (!expr->ref) + return false; + + sym = expr->symtree->n.sym; + + if (sym->attr.associate_var && !expr->ref) + return false; + + /* An allocatable class variable with no reference. */ + if (sym->ts.type == BT_CLASS + && !sym->attr.associate_var + && CLASS_DATA (sym)->attr.allocatable + && expr->ref + && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL + && expr->ref->next == NULL) + || (expr->ref->type == REF_COMPONENT + && strcmp (expr->ref->u.c.component->name, "_data") == 0 + && (expr->ref->next == NULL + || (expr->ref->next->type == REF_ARRAY + && expr->ref->next->u.ar.type == AR_FULL + && expr->ref->next->next == NULL))))) + return true; + + /* An allocatable variable. */ + if (sym->attr.allocatable + && !sym->attr.associate_var + && expr->ref + && expr->ref->type == REF_ARRAY + && expr->ref->u.ar.type == AR_FULL) + return true; + + /* All that can be left are allocatable components. */ + if ((sym->ts.type != BT_DERIVED + && sym->ts.type != BT_CLASS) + || !sym->ts.u.derived->attr.alloc_comp) + return false; + + /* Find a component ref followed by an array reference. */ + for (ref = expr->ref; ref; ref = ref->next) + if (ref->next + && ref->type == REF_COMPONENT + && ref->next->type == REF_ARRAY + && !ref->next->next) + break; + + if (!ref) + return false; + + /* Return true if valid reallocatable lhs. */ + if (ref->u.c.component->attr.allocatable + && ref->next->u.ar.type == AR_FULL) + return true; + + return false; +} + + +static tree +concat_str_length (gfc_expr* expr) +{ + tree type; + tree len1; + tree len2; + gfc_se se; + + type = gfc_typenode_for_spec (&expr->value.op.op1->ts); + len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + if (len1 == NULL_TREE) + { + if (expr->value.op.op1->expr_type == EXPR_OP) + len1 = concat_str_length (expr->value.op.op1); + else if (expr->value.op.op1->expr_type == EXPR_CONSTANT) + len1 = build_int_cst (gfc_charlen_type_node, + expr->value.op.op1->value.character.length); + else if (expr->value.op.op1->ts.u.cl->length) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length); + len1 = se.expr; + } + else + { + /* Last resort! */ + gfc_init_se (&se, NULL); + se.want_pointer = 1; + se.descriptor_only = 1; + gfc_conv_expr (&se, expr->value.op.op1); + len1 = se.string_length; + } + } + + type = gfc_typenode_for_spec (&expr->value.op.op2->ts); + len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + if (len2 == NULL_TREE) + { + if (expr->value.op.op2->expr_type == EXPR_OP) + len2 = concat_str_length (expr->value.op.op2); + else if (expr->value.op.op2->expr_type == EXPR_CONSTANT) + len2 = build_int_cst (gfc_charlen_type_node, + expr->value.op.op2->value.character.length); + else if (expr->value.op.op2->ts.u.cl->length) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length); + len2 = se.expr; + } + else + { + /* Last resort! */ + gfc_init_se (&se, NULL); + se.want_pointer = 1; + se.descriptor_only = 1; + gfc_conv_expr (&se, expr->value.op.op2); + len2 = se.string_length; + } + } + + gcc_assert(len1 && len2); + len1 = fold_convert (gfc_charlen_type_node, len1); + len2 = fold_convert (gfc_charlen_type_node, len2); + + return fold_build2_loc (input_location, PLUS_EXPR, + gfc_charlen_type_node, len1, len2); +} + + +/* Allocate the lhs of an assignment to an allocatable array, otherwise + reallocate it. */ + +tree +gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, + gfc_expr *expr1, + gfc_expr *expr2) +{ + stmtblock_t realloc_block; + stmtblock_t alloc_block; + stmtblock_t fblock; + gfc_ss *rss; + gfc_ss *lss; + gfc_array_info *linfo; + tree realloc_expr; + tree alloc_expr; + tree size1; + tree size2; + tree elemsize1; + tree elemsize2; + tree array1; + tree cond_null; + tree cond; + tree tmp; + tree tmp2; + tree lbound; + tree ubound; + tree desc; + tree old_desc; + tree desc2; + tree offset; + tree jump_label1; + tree jump_label2; + tree neq_size; + tree lbd; + tree class_expr2 = NULL_TREE; + int n; + int dim; + gfc_array_spec * as; + bool coarray = (flag_coarray == GFC_FCOARRAY_LIB + && gfc_caf_attr (expr1, true).codimension); + tree token; + gfc_se caf_se; + + /* x = f(...) with x allocatable. In this case, expr1 is the rhs. + Find the lhs expression in the loop chain and set expr1 and + expr2 accordingly. */ + if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL) + { + expr2 = expr1; + /* Find the ss for the lhs. */ + lss = loop->ss; + for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) + if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE) + break; + if (lss == gfc_ss_terminator) + return NULL_TREE; + expr1 = lss->info->expr; + } + + /* Bail out if this is not a valid allocate on assignment. */ + if (!gfc_is_reallocatable_lhs (expr1) + || (expr2 && !expr2->rank)) + return NULL_TREE; + + /* Find the ss for the lhs. */ + lss = loop->ss; + for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain) + if (lss->info->expr == expr1) + break; + + if (lss == gfc_ss_terminator) + return NULL_TREE; + + linfo = &lss->info->data.array; + + /* Find an ss for the rhs. For operator expressions, we see the + ss's for the operands. Any one of these will do. */ + rss = loop->ss; + for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain) + if (rss->info->expr != expr1 && rss != loop->temp_ss) + break; + + if (expr2 && rss == gfc_ss_terminator) + return NULL_TREE; + + /* Ensure that the string length from the current scope is used. */ + if (expr2->ts.type == BT_CHARACTER + && expr2->expr_type == EXPR_FUNCTION + && !expr2->value.function.isym) + expr2->ts.u.cl->backend_decl = rss->info->string_length; + + gfc_start_block (&fblock); + + /* Since the lhs is allocatable, this must be a descriptor type. + Get the data and array size. */ + desc = linfo->descriptor; + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); + array1 = gfc_conv_descriptor_data_get (desc); + + if (expr2) + desc2 = rss->info->data.array.descriptor; + else + desc2 = NULL_TREE; + + /* Get the old lhs element size for deferred character and class expr1. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + if (expr1->ts.u.cl->backend_decl + && VAR_P (expr1->ts.u.cl->backend_decl)) + elemsize1 = expr1->ts.u.cl->backend_decl; + else + elemsize1 = lss->info->string_length; + } + else if (expr1->ts.type == BT_CLASS) + { + /* Unfortunately, the lhs vptr is set too early in many cases. + Play it safe by using the descriptor element length. */ + tmp = gfc_conv_descriptor_elem_len (desc); + elemsize1 = fold_convert (gfc_array_index_type, tmp); + } + else + elemsize1 = NULL_TREE; + if (elemsize1 != NULL_TREE) + elemsize1 = gfc_evaluate_now (elemsize1, &fblock); + + /* Get the new lhs size in bytes. */ + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + if (expr2->ts.deferred) + { + if (expr2->ts.u.cl->backend_decl + && VAR_P (expr2->ts.u.cl->backend_decl)) + tmp = expr2->ts.u.cl->backend_decl; + else + tmp = rss->info->string_length; + } + else + { + tmp = expr2->ts.u.cl->backend_decl; + if (!tmp && expr2->expr_type == EXPR_OP + && expr2->value.op.op == INTRINSIC_CONCAT) + { + tmp = concat_str_length (expr2); + expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); + } + else if (!tmp && expr2->ts.u.cl->length) + { + gfc_se tmpse; + gfc_init_se (&tmpse, NULL); + gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length, + gfc_charlen_type_node); + tmp = tmpse.expr; + expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock); + } + tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp); + } + + if (expr1->ts.u.cl->backend_decl + && VAR_P (expr1->ts.u.cl->backend_decl)) + gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp); + else + gfc_add_modify (&fblock, lss->info->string_length, tmp); + + if (expr1->ts.kind > 1) + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + expr1->ts.kind)); + } + else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl) + { + tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts))); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, + expr1->ts.u.cl->backend_decl); + } + else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS) + { + tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE; + if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE) + tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2); + + if (tmp != NULL_TREE) + tmp = gfc_class_vtab_size_get (tmp); + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts)); + } + else + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + elemsize2 = fold_convert (gfc_array_index_type, tmp); + elemsize2 = gfc_evaluate_now (elemsize2, &fblock); + + /* 7.4.1.3 "If variable is an allocated allocatable variable, it is + deallocated if expr is an array of different shape or any of the + corresponding length type parameter values of variable and expr + differ." This assures F95 compatibility. */ + jump_label1 = gfc_build_label_decl (NULL_TREE); + jump_label2 = gfc_build_label_decl (NULL_TREE); + + /* Allocate if data is NULL. */ + cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + array1, build_int_cst (TREE_TYPE (array1), 0)); + + if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + lss->info->string_length, + rss->info->string_length); + cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, tmp, cond_null); + cond_null= gfc_evaluate_now (cond_null, &fblock); + } + else + cond_null= gfc_evaluate_now (cond_null, &fblock); + + tmp = build3_v (COND_EXPR, cond_null, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + + /* Get arrayspec if expr is a full array. */ + if (expr2 && expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym + && expr2->value.function.isym->conversion) + { + /* For conversion functions, take the arg. */ + gfc_expr *arg = expr2->value.function.actual->expr; + as = gfc_get_full_arrayspec_from_expr (arg); + } + else if (expr2) + as = gfc_get_full_arrayspec_from_expr (expr2); + else + as = NULL; + + /* If the lhs shape is not the same as the rhs jump to setting the + bounds and doing the reallocation....... */ + for (n = 0; n < expr1->rank; n++) + { + /* Check the shape. */ + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, lbound); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + tmp, ubound); + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + tmp, gfc_index_zero_node); + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + } + + /* ...else if the element lengths are not the same also go to + setting the bounds and doing the reallocation.... */ + if (elemsize1 != NULL_TREE) + { + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + elemsize1, elemsize2); + tmp = build3_v (COND_EXPR, cond, + build1_v (GOTO_EXPR, jump_label1), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&fblock, tmp); + } + + /* ....else jump past the (re)alloc code. */ + tmp = build1_v (GOTO_EXPR, jump_label2); + gfc_add_expr_to_block (&fblock, tmp); + + /* Add the label to start automatic (re)allocation. */ + tmp = build1_v (LABEL_EXPR, jump_label1); + gfc_add_expr_to_block (&fblock, tmp); + + /* If the lhs has not been allocated, its bounds will not have been + initialized and so its size is set to zero. */ + size1 = gfc_create_var (gfc_array_index_type, NULL); + gfc_init_block (&alloc_block); + gfc_add_modify (&alloc_block, size1, gfc_index_zero_node); + gfc_init_block (&realloc_block); + gfc_add_modify (&realloc_block, size1, + gfc_conv_descriptor_size (desc, expr1->rank)); + tmp = build3_v (COND_EXPR, cond_null, + gfc_finish_block (&alloc_block), + gfc_finish_block (&realloc_block)); + gfc_add_expr_to_block (&fblock, tmp); + + /* Get the rhs size and fix it. */ + size2 = gfc_index_one_node; + for (n = 0; n < expr2->rank; n++) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + size2 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + tmp, size2); + } + size2 = gfc_evaluate_now (size2, &fblock); + + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + size1, size2); + + /* If the lhs is deferred length, assume that the element size + changes and force a reallocation. */ + if (expr1->ts.deferred) + neq_size = gfc_evaluate_now (logical_true_node, &fblock); + else + neq_size = gfc_evaluate_now (cond, &fblock); + + /* Deallocation of allocatable components will have to occur on + reallocation. Fix the old descriptor now. */ + if ((expr1->ts.type == BT_DERIVED) + && expr1->ts.u.derived->attr.alloc_comp) + old_desc = gfc_evaluate_now (desc, &fblock); + else + old_desc = NULL_TREE; + + /* Now modify the lhs descriptor and the associated scalarizer + variables. F2003 7.4.1.3: "If variable is or becomes an + unallocated allocatable variable, then it is allocated with each + deferred type parameter equal to the corresponding type parameters + of expr , with the shape of expr , and with each lower bound equal + to the corresponding element of LBOUND(expr)." + Reuse size1 to keep a dimension-by-dimension track of the + stride of the new array. */ + size1 = gfc_index_one_node; + offset = gfc_index_zero_node; + + for (n = 0; n < expr2->rank; n++) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[n], loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + tmp, gfc_index_one_node); + + lbound = gfc_index_one_node; + ubound = tmp; + + if (as) + { + lbd = get_std_lbound (expr2, desc2, n, + as->type == AS_ASSUMED_SIZE); + ubound = fold_build2_loc (input_location, + MINUS_EXPR, + gfc_array_index_type, + ubound, lbound); + ubound = fold_build2_loc (input_location, + PLUS_EXPR, + gfc_array_index_type, + ubound, lbd); + lbound = lbd; + } + + gfc_conv_descriptor_lbound_set (&fblock, desc, + gfc_rank_cst[n], + lbound); + gfc_conv_descriptor_ubound_set (&fblock, desc, + gfc_rank_cst[n], + ubound); + gfc_conv_descriptor_stride_set (&fblock, desc, + gfc_rank_cst[n], + size1); + lbound = gfc_conv_descriptor_lbound_get (desc, + gfc_rank_cst[n]); + tmp2 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + lbound, size1); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, tmp2); + size1 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + tmp, size1); + } + + /* Set the lhs descriptor and scalarizer offsets. For rank > 1, + the array offset is saved and the info.offset is used for a + running offset. Use the saved_offset instead. */ + tmp = gfc_conv_descriptor_offset (desc); + gfc_add_modify (&fblock, tmp, offset); + if (linfo->saved_offset + && VAR_P (linfo->saved_offset)) + gfc_add_modify (&fblock, linfo->saved_offset, tmp); + + /* Now set the deltas for the lhs. */ + for (n = 0; n < expr1->rank; n++) + { + tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); + dim = lss->dim[n]; + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tmp, + loop->from[dim]); + if (linfo->delta[dim] && VAR_P (linfo->delta[dim])) + gfc_add_modify (&fblock, linfo->delta[dim], tmp); + } + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + gfc_conv_descriptor_span_set (&fblock, desc, elemsize2); + + size2 = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + elemsize2, size2); + size2 = fold_convert (size_type_node, size2); + size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + size2, size_one_node); + size2 = gfc_evaluate_now (size2, &fblock); + + /* For deferred character length, the 'size' field of the dtype might + have changed so set the dtype. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + { + tree type; + tmp = gfc_conv_descriptor_dtype (desc); + if (expr2->ts.u.cl->backend_decl) + type = gfc_typenode_for_spec (&expr2->ts); + else + type = gfc_typenode_for_spec (&expr1->ts); + + gfc_add_modify (&fblock, tmp, + gfc_get_dtype_rank_type (expr1->rank,type)); + } + else if (expr1->ts.type == BT_CLASS) + { + tree type; + tmp = gfc_conv_descriptor_dtype (desc); + + if (expr2->ts.type != BT_CLASS) + type = gfc_typenode_for_spec (&expr2->ts); + else + type = gfc_get_character_type_len (1, elemsize2); + + gfc_add_modify (&fblock, tmp, + gfc_get_dtype_rank_type (expr2->rank,type)); + /* Set the _len field as well... */ + if (UNLIMITED_POLY (expr1)) + { + tmp = gfc_class_len_get (TREE_OPERAND (desc, 0)); + if (expr2->ts.type == BT_CHARACTER) + gfc_add_modify (&fblock, tmp, + fold_convert (TREE_TYPE (tmp), + TYPE_SIZE_UNIT (type))); + else + gfc_add_modify (&fblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + } + /* ...and the vptr. */ + tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0)); + if (expr2->ts.type == BT_CLASS && !VAR_P (desc2) + && TREE_CODE (desc2) == COMPONENT_REF) + { + tmp2 = gfc_get_class_from_expr (desc2); + tmp2 = gfc_class_vptr_get (tmp2); + } + else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE) + tmp2 = gfc_class_vptr_get (class_expr2); + else + { + tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts)); + tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2); + } + + gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); + } + else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + { + gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc), + gfc_get_dtype (TREE_TYPE (desc))); + } + + /* Realloc expression. Note that the scalarizer uses desc.data + in the array reference - (*desc.data)[]. */ + gfc_init_block (&realloc_block); + gfc_init_se (&caf_se, NULL); + + if (coarray) + { + token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1); + if (token == NULL_TREE) + { + tmp = gfc_get_tree_for_caf_expr (expr1); + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref (tmp); + gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE, + expr1); + token = gfc_build_addr_expr (NULL_TREE, token); + } + + gfc_add_block_to_block (&realloc_block, &caf_se.pre); + } + if ((expr1->ts.type == BT_DERIVED) + && expr1->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc, + expr1->rank); + gfc_add_expr_to_block (&realloc_block, tmp); + } + + if (!coarray) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_REALLOC), 2, + fold_convert (pvoid_type_node, array1), + size2); + gfc_conv_descriptor_data_set (&realloc_block, + desc, tmp); + } + else + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 5, token, + build_int_cst (integer_type_node, + GFC_CAF_COARRAY_DEALLOCATE_ONLY), + null_pointer_node, null_pointer_node, + integer_zero_node); + gfc_add_expr_to_block (&realloc_block, tmp); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_register, + 7, size2, + build_int_cst (integer_type_node, + GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY), + token, gfc_build_addr_expr (NULL_TREE, desc), + null_pointer_node, null_pointer_node, + integer_zero_node); + gfc_add_expr_to_block (&realloc_block, tmp); + } + + if ((expr1->ts.type == BT_DERIVED) + && expr1->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, + expr1->rank); + gfc_add_expr_to_block (&realloc_block, tmp); + } + + gfc_add_block_to_block (&realloc_block, &caf_se.post); + realloc_expr = gfc_finish_block (&realloc_block); + + /* Reallocate if sizes or dynamic types are different. */ + if (elemsize1) + { + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + elemsize1, elemsize2); + tmp = gfc_evaluate_now (tmp, &fblock); + neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, neq_size, tmp); + } + tmp = build3_v (COND_EXPR, neq_size, realloc_expr, + build_empty_stmt (input_location)); + + realloc_expr = tmp; + + /* Malloc expression. */ + gfc_init_block (&alloc_block); + if (!coarray) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), + 1, size2); + gfc_conv_descriptor_data_set (&alloc_block, + desc, tmp); + } + else + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_register, + 7, size2, + build_int_cst (integer_type_node, + GFC_CAF_COARRAY_ALLOC), + token, gfc_build_addr_expr (NULL_TREE, desc), + null_pointer_node, null_pointer_node, + integer_zero_node); + gfc_add_expr_to_block (&alloc_block, tmp); + } + + + /* We already set the dtype in the case of deferred character + length arrays and class lvalues. */ + if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) + || coarray)) + && expr1->ts.type != BT_CLASS) + { + tmp = gfc_conv_descriptor_dtype (desc); + gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc))); + } + + if ((expr1->ts.type == BT_DERIVED) + && expr1->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc, + expr1->rank); + gfc_add_expr_to_block (&alloc_block, tmp); + } + alloc_expr = gfc_finish_block (&alloc_block); + + /* Malloc if not allocated; realloc otherwise. */ + tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr); + gfc_add_expr_to_block (&fblock, tmp); + + /* Make sure that the scalarizer data pointer is updated. */ + if (linfo->data && VAR_P (linfo->data)) + { + tmp = gfc_conv_descriptor_data_get (desc); + gfc_add_modify (&fblock, linfo->data, tmp); + } + + /* Add the label for same shape lhs and rhs. */ + tmp = build1_v (LABEL_EXPR, jump_label2); + gfc_add_expr_to_block (&fblock, tmp); + + return gfc_finish_block (&fblock); +} + + +/* NULLIFY an allocatable/pointer array on function entry, free it on exit. + Do likewise, recursively if necessary, with the allocatable components of + derived types. This function is also called for assumed-rank arrays, which + are always dummy arguments. */ + +void +gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) +{ + tree type; + tree tmp; + tree descriptor; + stmtblock_t init; + stmtblock_t cleanup; + locus loc; + int rank; + bool sym_has_alloc_comp, has_finalizer; + + sym_has_alloc_comp = (sym->ts.type == BT_DERIVED + || sym->ts.type == BT_CLASS) + && sym->ts.u.derived->attr.alloc_comp; + has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED + ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; + + /* Make sure the frontend gets these right. */ + gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp + || has_finalizer + || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy)); + + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + gfc_init_block (&init); + + gcc_assert (VAR_P (sym->backend_decl) + || TREE_CODE (sym->backend_decl) == PARM_DECL); + + if (sym->ts.type == BT_CHARACTER + && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) + { + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + gfc_trans_vla_type_sizes (sym, &init); + } + + /* Dummy, use associated and result variables don't need anything special. */ + if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) + { + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + gfc_restore_backend_locus (&loc); + return; + } + + descriptor = sym->backend_decl; + + /* Although static, derived types with default initializers and + allocatable components must not be nulled wholesale; instead they + are treated component by component. */ + if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer) + { + /* SAVEd variables are not freed on exit. */ + gfc_trans_static_array_pointer (sym); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + gfc_restore_backend_locus (&loc); + return; + } + + /* Get the descriptor type. */ + type = TREE_TYPE (sym->backend_decl); + + if ((sym_has_alloc_comp || (has_finalizer && sym->ts.type != BT_CLASS)) + && !(sym->attr.pointer || sym->attr.allocatable)) + { + if (!sym->attr.save + && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program)) + { + if (sym->value == NULL + || !gfc_has_default_initializer (sym->ts.u.derived)) + { + rank = sym->as ? sym->as->rank : 0; + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, + descriptor, rank); + gfc_add_expr_to_block (&init, tmp); + } + else + gfc_init_default_dt (sym, &init, false); + } + } + else if (!GFC_DESCRIPTOR_TYPE_P (type)) + { + /* If the backend_decl is not a descriptor, we must have a pointer + to one. */ + descriptor = build_fold_indirect_ref_loc (input_location, + sym->backend_decl); + type = TREE_TYPE (descriptor); + } + + /* NULLIFY the data pointer, for non-saved allocatables. */ + if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable) + { + gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) + { + /* Declare the variable static so its array descriptor stays present + after leaving the scope. It may still be accessed through another + image. This may happen, for example, with the caf_mpi + implementation. */ + TREE_STATIC (descriptor) = 1; + tmp = gfc_conv_descriptor_token (descriptor); + gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } + } + + /* Set initial TKR for pointers and allocatables */ + if (GFC_DESCRIPTOR_TYPE_P (type) + && (sym->attr.pointer || sym->attr.allocatable)) + { + tree etype; + + gcc_assert (sym->as && sym->as->rank>=0); + tmp = gfc_conv_descriptor_dtype (descriptor); + etype = gfc_get_element_type (type); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (tmp), tmp, + gfc_get_dtype_rank_type (sym->as->rank, etype)); + gfc_add_expr_to_block (&init, tmp); + } + gfc_restore_backend_locus (&loc); + gfc_init_block (&cleanup); + + /* Allocatable arrays need to be freed when they go out of scope. + The allocatable components of pointers must not be touched. */ + if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS + && !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save + && !sym->ns->proc_name->attr.is_main_program) + { + gfc_expr *e; + sym->attr.referenced = 1; + e = gfc_lval_expr_from_sym (sym); + gfc_add_finalizer_call (&cleanup, e); + gfc_free_expr (e); + } + else if ((!sym->attr.allocatable || !has_finalizer) + && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) + && !sym->attr.pointer && !sym->attr.save + && !sym->ns->proc_name->attr.is_main_program) + { + int rank; + rank = sym->as ? sym->as->rank : 0; + tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); + gfc_add_expr_to_block (&cleanup, tmp); + } + + if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) + && !sym->attr.save && !sym->attr.result + && !sym->ns->proc_name->attr.is_main_program) + { + gfc_expr *e; + e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL; + tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, e, + sym->attr.codimension + ? GFC_CAF_COARRAY_DEREGISTER + : GFC_CAF_COARRAY_NOCOARRAY); + if (e) + gfc_free_expr (e); + gfc_add_expr_to_block (&cleanup, tmp); + } + + gfc_add_init_cleanup (block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); +} + +/************ Expression Walking Functions ******************/ + +/* Walk a variable reference. + + Possible extension - multiple component subscripts. + x(:,:) = foo%a(:)%b(:) + Transforms to + forall (i=..., j=...) + x(i,j) = foo%a(j)%b(i) + end forall + This adds a fair amount of complexity because you need to deal with more + than one ref. Maybe handle in a similar manner to vector subscripts. + Maybe not worth the effort. */ + + +static gfc_ss * +gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ref *ref; + + gfc_fix_class_refs (expr); + + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) + break; + + return gfc_walk_array_ref (ss, expr, ref); +} + + +gfc_ss * +gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) +{ + gfc_array_ref *ar; + gfc_ss *newss; + int n; + + for (; ref; ref = ref->next) + { + if (ref->type == REF_SUBSTRING) + { + ss = gfc_get_scalar_ss (ss, ref->u.ss.start); + if (ref->u.ss.end) + ss = gfc_get_scalar_ss (ss, ref->u.ss.end); + } + + /* We're only interested in array sections from now on. */ + if (ref->type != REF_ARRAY) + continue; + + ar = &ref->u.ar; + + switch (ar->type) + { + case AR_ELEMENT: + for (n = ar->dimen - 1; n >= 0; n--) + ss = gfc_get_scalar_ss (ss, ar->start[n]); + break; + + case AR_FULL: + newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); + newss->info->data.array.ref = ref; + + /* Make sure array is the same as array(:,:), this way + we don't need to special case all the time. */ + ar->dimen = ar->as->rank; + for (n = 0; n < ar->dimen; n++) + { + ar->dimen_type[n] = DIMEN_RANGE; + + gcc_assert (ar->start[n] == NULL); + gcc_assert (ar->end[n] == NULL); + gcc_assert (ar->stride[n] == NULL); + } + ss = newss; + break; + + case AR_SECTION: + newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); + newss->info->data.array.ref = ref; + + /* We add SS chains for all the subscripts in the section. */ + for (n = 0; n < ar->dimen; n++) + { + gfc_ss *indexss; + + switch (ar->dimen_type[n]) + { + case DIMEN_ELEMENT: + /* Add SS for elemental (scalar) subscripts. */ + gcc_assert (ar->start[n]); + indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]); + indexss->loop_chain = gfc_ss_terminator; + newss->info->data.array.subscript[n] = indexss; + break; + + case DIMEN_RANGE: + /* We don't add anything for sections, just remember this + dimension for later. */ + newss->dim[newss->dimen] = n; + newss->dimen++; + break; + + case DIMEN_VECTOR: + /* Create a GFC_SS_VECTOR index in which we can store + the vector's descriptor. */ + indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n], + 1, GFC_SS_VECTOR); + indexss->loop_chain = gfc_ss_terminator; + newss->info->data.array.subscript[n] = indexss; + newss->dim[newss->dimen] = n; + newss->dimen++; + break; + + default: + /* We should know what sort of section it is by now. */ + gcc_unreachable (); + } + } + /* We should have at least one non-elemental dimension, + unless we are creating a descriptor for a (scalar) coarray. */ + gcc_assert (newss->dimen > 0 + || newss->info->data.array.ref->u.ar.as->corank > 0); + ss = newss; + break; + + default: + /* We should know what sort of section it is by now. */ + gcc_unreachable (); + } + + } + return ss; +} + + +/* Walk an expression operator. If only one operand of a binary expression is + scalar, we must also add the scalar term to the SS chain. */ + +static gfc_ss * +gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *head; + gfc_ss *head2; + + head = gfc_walk_subexpr (ss, expr->value.op.op1); + if (expr->value.op.op2 == NULL) + head2 = head; + else + head2 = gfc_walk_subexpr (head, expr->value.op.op2); + + /* All operands are scalar. Pass back and let the caller deal with it. */ + if (head2 == ss) + return head2; + + /* All operands require scalarization. */ + if (head != ss && (expr->value.op.op2 == NULL || head2 != head)) + return head2; + + /* One of the operands needs scalarization, the other is scalar. + Create a gfc_ss for the scalar expression. */ + if (head == ss) + { + /* First operand is scalar. We build the chain in reverse order, so + add the scalar SS after the second operand. */ + head = head2; + while (head && head->next != ss) + head = head->next; + /* Check we haven't somehow broken the chain. */ + gcc_assert (head); + head->next = gfc_get_scalar_ss (ss, expr->value.op.op1); + } + else /* head2 == head */ + { + gcc_assert (head2 == head); + /* Second operand is scalar. */ + head2 = gfc_get_scalar_ss (head2, expr->value.op.op2); + } + + return head2; +} + + +/* Reverse a SS chain. */ + +gfc_ss * +gfc_reverse_ss (gfc_ss * ss) +{ + gfc_ss *next; + gfc_ss *head; + + gcc_assert (ss != NULL); + + head = gfc_ss_terminator; + while (ss != gfc_ss_terminator) + { + next = ss->next; + /* Check we didn't somehow break the chain. */ + gcc_assert (next != NULL); + ss->next = head; + head = ss; + ss = next; + } + + return (head); +} + + +/* Given an expression referring to a procedure, return the symbol of its + interface. We can't get the procedure symbol directly as we have to handle + the case of (deferred) type-bound procedures. */ + +gfc_symbol * +gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref) +{ + gfc_symbol *sym; + gfc_ref *ref; + + if (procedure_ref == NULL) + return NULL; + + /* Normal procedure case. */ + if (procedure_ref->expr_type == EXPR_FUNCTION + && procedure_ref->value.function.esym) + sym = procedure_ref->value.function.esym; + else + sym = procedure_ref->symtree->n.sym; + + /* Typebound procedure case. */ + for (ref = procedure_ref->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->attr.proc_pointer) + sym = ref->u.c.component->ts.interface; + else + sym = NULL; + } + + return sym; +} + + +/* Given an expression referring to an intrinsic function call, + return the intrinsic symbol. */ + +gfc_intrinsic_sym * +gfc_get_intrinsic_for_expr (gfc_expr *call) +{ + if (call == NULL) + return NULL; + + /* Normal procedure case. */ + if (call->expr_type == EXPR_FUNCTION) + return call->value.function.isym; + else + return NULL; +} + + +/* Indicates whether an argument to an intrinsic function should be used in + scalarization. It is usually the case, except for some intrinsics + requiring the value to be constant, and using the value at compile time only. + As the value is not used at runtime in those cases, we don’t produce code + for it, and it should not be visible to the scalarizer. + FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual + argument being examined in that call, and ARG_NUM the index number + of ACTUAL_ARG in the list of arguments. + The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is + identified using the name in ACTUAL_ARG if it is present (that is: if it’s + a keyword argument), otherwise using ARG_NUM. */ + +static bool +arg_evaluated_for_scalarization (gfc_intrinsic_sym *function, + gfc_dummy_arg *dummy_arg) +{ + if (function != NULL && dummy_arg != NULL) + { + switch (function->id) + { + case GFC_ISYM_INDEX: + case GFC_ISYM_LEN_TRIM: + case GFC_ISYM_MASKL: + case GFC_ISYM_MASKR: + case GFC_ISYM_SCAN: + case GFC_ISYM_VERIFY: + if (strcmp ("kind", gfc_dummy_arg_get_name (*dummy_arg)) == 0) + return false; + /* Fallthrough. */ + + default: + break; + } + } + + return true; +} + + +/* Walk the arguments of an elemental function. + PROC_EXPR is used to check whether an argument is permitted to be absent. If + it is NULL, we don't do the check and the argument is assumed to be present. +*/ + +gfc_ss * +gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, + gfc_intrinsic_sym *intrinsic_sym, + gfc_ss_type type) +{ + int scalar; + gfc_ss *head; + gfc_ss *tail; + gfc_ss *newss; + + head = gfc_ss_terminator; + tail = NULL; + + scalar = 1; + for (; arg; arg = arg->next) + { + gfc_dummy_arg * const dummy_arg = arg->associated_dummy; + if (!arg->expr + || arg->expr->expr_type == EXPR_NULL + || !arg_evaluated_for_scalarization (intrinsic_sym, dummy_arg)) + continue; + + newss = gfc_walk_subexpr (head, arg->expr); + if (newss == head) + { + /* Scalar argument. */ + gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); + newss = gfc_get_scalar_ss (head, arg->expr); + newss->info->type = type; + if (dummy_arg) + newss->info->data.scalar.dummy_arg = dummy_arg; + } + else + scalar = 0; + + if (dummy_arg != NULL + && gfc_dummy_arg_is_optional (*dummy_arg) + && arg->expr->expr_type == EXPR_VARIABLE + && (gfc_expr_attr (arg->expr).optional + || gfc_expr_attr (arg->expr).allocatable + || gfc_expr_attr (arg->expr).pointer)) + newss->info->can_be_null_ref = true; + + head = newss; + if (!tail) + { + tail = head; + while (tail->next != gfc_ss_terminator) + tail = tail->next; + } + } + + if (scalar) + { + /* If all the arguments are scalar we don't need the argument SS. */ + gfc_free_ss_chain (head); + /* Pass it back. */ + return ss; + } + + /* Add it onto the existing chain. */ + tail->next = ss; + return head; +} + + +/* Walk a function call. Scalar functions are passed back, and taken out of + scalarization loops. For elemental functions we walk their arguments. + The result of functions returning arrays is stored in a temporary outside + the loop, so that the function is only called once. Hence we do not need + to walk their arguments. */ + +static gfc_ss * +gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_intrinsic_sym *isym; + gfc_symbol *sym; + gfc_component *comp = NULL; + + isym = expr->value.function.isym; + + /* Handle intrinsic functions separately. */ + if (isym) + return gfc_walk_intrinsic_function (ss, expr, isym); + + sym = expr->value.function.esym; + if (!sym) + sym = expr->symtree->n.sym; + + if (gfc_is_class_array_function (expr)) + return gfc_get_array_ss (ss, expr, + CLASS_DATA (expr->value.function.esym->result)->as->rank, + GFC_SS_FUNCTION); + + /* A function that returns arrays. */ + comp = gfc_get_proc_ptr_comp (expr); + if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) + || (comp && comp->attr.dimension)) + return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); + + /* Walk the parameters of an elemental function. For now we always pass + by reference. */ + if (sym->attr.elemental || (comp && comp->attr.elemental)) + { + gfc_ss *old_ss = ss; + + ss = gfc_walk_elemental_function_args (old_ss, + expr->value.function.actual, + gfc_get_intrinsic_for_expr (expr), + GFC_SS_REFERENCE); + if (ss != old_ss + && (comp + || sym->attr.proc_pointer + || sym->attr.if_source != IFSRC_DECL + || sym->attr.array_outer_dependency)) + ss->info->array_outer_dependency = 1; + } + + /* Scalar functions are OK as these are evaluated outside the scalarization + loop. Pass back and let the caller deal with it. */ + return ss; +} + + +/* An array temporary is constructed for array constructors. */ + +static gfc_ss * +gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) +{ + return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR); +} + + +/* Walk an expression. Add walked expressions to the head of the SS chain. + A wholly scalar expression will not be added. */ + +gfc_ss * +gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *head; + + switch (expr->expr_type) + { + case EXPR_VARIABLE: + head = gfc_walk_variable_expr (ss, expr); + return head; + + case EXPR_OP: + head = gfc_walk_op_expr (ss, expr); + return head; + + case EXPR_FUNCTION: + head = gfc_walk_function_expr (ss, expr); + return head; + + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_STRUCTURE: + /* Pass back and let the caller deal with it. */ + break; + + case EXPR_ARRAY: + head = gfc_walk_array_constructor (ss, expr); + return head; + + case EXPR_SUBSTRING: + /* Pass back and let the caller deal with it. */ + break; + + default: + gfc_internal_error ("bad expression type during walk (%d)", + expr->expr_type); + } + return ss; +} + + +/* Entry point for expression walking. + A return value equal to the passed chain means this is + a scalar expression. It is up to the caller to take whatever action is + necessary to translate these. */ + +gfc_ss * +gfc_walk_expr (gfc_expr * expr) +{ + gfc_ss *res; + + res = gfc_walk_subexpr (gfc_ss_terminator, expr); + return gfc_reverse_ss (res); +} diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c deleted file mode 100644 index 7b4d198..0000000 --- a/gcc/fortran/trans-common.c +++ /dev/null @@ -1,1392 +0,0 @@ -/* Common block and equivalence list handling - Copyright (C) 2000-2022 Free Software Foundation, Inc. - Contributed by Canqun Yang - -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 -. */ - -/* The core algorithm is based on Andy Vaught's g95 tree. Also the - way to build UNION_TYPE is borrowed from Richard Henderson. - - Transform common blocks. An integral part of this is processing - equivalence variables. Equivalenced variables that are not in a - common block end up in a private block of their own. - - Each common block or local equivalence list is declared as a union. - Variables within the block are represented as a field within the - block with the proper offset. - - So if two variables are equivalenced, they just point to a common - area in memory. - - Mathematically, laying out an equivalence block is equivalent to - solving a linear system of equations. The matrix is usually a - sparse matrix in which each row contains all zero elements except - for a +1 and a -1, a sort of a generalized Vandermonde matrix. The - matrix is usually block diagonal. The system can be - overdetermined, underdetermined or have a unique solution. If the - system is inconsistent, the program is not standard conforming. - The solution vector is integral, since all of the pivots are +1 or -1. - - How we lay out an equivalence block is a little less complicated. - In an equivalence list with n elements, there are n-1 conditions to - be satisfied. The conditions partition the variables into what we - will call segments. If A and B are equivalenced then A and B are - in the same segment. If B and C are equivalenced as well, then A, - B and C are in a segment and so on. Each segment is a block of - memory that has one or more variables equivalenced in some way. A - common block is made up of a series of segments that are joined one - after the other. In the linear system, a segment is a block - diagonal. - - To lay out a segment we first start with some variable and - determine its length. The first variable is assumed to start at - offset one and extends to however long it is. We then traverse the - list of equivalences to find an unused condition that involves at - least one of the variables currently in the segment. - - Each equivalence condition amounts to the condition B+b=C+c where B - and C are the offsets of the B and C variables, and b and c are - constants which are nonzero for array elements, substrings or - structure components. So for - - EQUIVALENCE(B(2), C(3)) - we have - B + 2*size of B's elements = C + 3*size of C's elements. - - If B and C are known we check to see if the condition already - holds. If B is known we can solve for C. Since we know the length - of C, we can see if the minimum and maximum extents of the segment - are affected. Eventually, we make a full pass through the - equivalence list without finding any new conditions and the segment - is fully specified. - - At this point, the segment is added to the current common block. - Since we know the minimum extent of the segment, everything in the - segment is translated to its position in the common block. The - usual case here is that there are no equivalence statements and the - common block is series of segments with one variable each, which is - a diagonal matrix in the matrix formulation. - - Each segment is described by a chain of segment_info structures. Each - segment_info structure describes the extents of a single variable within - the segment. This list is maintained in the order the elements are - positioned within the segment. If two elements have the same starting - offset the smaller will come first. If they also have the same size their - ordering is undefined. - - Once all common blocks have been created, the list of equivalences - is examined for still-unused equivalence conditions. We create a - block for each merged equivalence list. */ - -#include "config.h" -#define INCLUDE_MAP -#include "system.h" -#include "coretypes.h" -#include "tm.h" -#include "tree.h" -#include "gfortran.h" -#include "trans.h" -#include "stringpool.h" -#include "fold-const.h" -#include "stor-layout.h" -#include "varasm.h" -#include "trans-types.h" -#include "trans-const.h" -#include "target-memory.h" - - -/* Holds a single variable in an equivalence set. */ -typedef struct segment_info -{ - gfc_symbol *sym; - HOST_WIDE_INT offset; - HOST_WIDE_INT length; - /* This will contain the field type until the field is created. */ - tree field; - struct segment_info *next; -} segment_info; - -static segment_info * current_segment; - -/* Store decl of all common blocks in this translation unit; the first - tree is the identifier. */ -static std::map gfc_map_of_all_commons; - - -/* Make a segment_info based on a symbol. */ - -static segment_info * -get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset) -{ - segment_info *s; - - /* Make sure we've got the character length. */ - if (sym->ts.type == BT_CHARACTER) - gfc_conv_const_charlen (sym->ts.u.cl); - - /* Create the segment_info and fill it in. */ - s = XCNEW (segment_info); - s->sym = sym; - /* We will use this type when building the segment aggregate type. */ - s->field = gfc_sym_type (sym); - s->length = int_size_in_bytes (s->field); - s->offset = offset; - - return s; -} - - -/* Add a copy of a segment list to the namespace. This is specifically for - equivalence segments, so that dependency checking can be done on - equivalence group members. */ - -static void -copy_equiv_list_to_ns (segment_info *c) -{ - segment_info *f; - gfc_equiv_info *s; - gfc_equiv_list *l; - - l = XCNEW (gfc_equiv_list); - - l->next = c->sym->ns->equiv_lists; - c->sym->ns->equiv_lists = l; - - for (f = c; f; f = f->next) - { - s = XCNEW (gfc_equiv_info); - s->next = l->equiv; - l->equiv = s; - s->sym = f->sym; - s->offset = f->offset; - s->length = f->length; - } -} - - -/* Add combine segment V and segment LIST. */ - -static segment_info * -add_segments (segment_info *list, segment_info *v) -{ - segment_info *s; - segment_info *p; - segment_info *next; - - p = NULL; - s = list; - - while (v) - { - /* Find the location of the new element. */ - while (s) - { - if (v->offset < s->offset) - break; - if (v->offset == s->offset - && v->length <= s->length) - break; - - p = s; - s = s->next; - } - - /* Insert the new element in between p and s. */ - next = v->next; - v->next = s; - if (p == NULL) - list = v; - else - p->next = v; - - p = v; - v = next; - } - - return list; -} - - -/* Construct mangled common block name from symbol name. */ - -/* We need the bind(c) flag to tell us how/if we should mangle the symbol - name. There are few calls to this function, so few places that this - would need to be added. At the moment, there is only one call, in - build_common_decl(). We can't attempt to look up the common block - because we may be building it for the first time and therefore, it won't - be in the common_root. We also need the binding label, if it's bind(c). - Therefore, send in the pointer to the common block, so whatever info we - have so far can be used. All of the necessary info should be available - in the gfc_common_head by now, so it should be accurate to test the - isBindC flag and use the binding label given if it is bind(c). - - We may NOT know yet if it's bind(c) or not, but we can try at least. - Will have to figure out what to do later if it's labeled bind(c) - after this is called. */ - -static tree -gfc_sym_mangled_common_id (gfc_common_head *com) -{ - int has_underscore; - /* Provide sufficient space to hold "symbol.symbol.eq.1234567890__". */ - char mangled_name[2*GFC_MAX_MANGLED_SYMBOL_LEN + 1 + 16 + 1]; - char name[sizeof (mangled_name) - 2]; - - /* Get the name out of the common block pointer. */ - size_t len = strlen (com->name); - gcc_assert (len < sizeof (name)); - strcpy (name, com->name); - - /* If we're suppose to do a bind(c). */ - if (com->is_bind_c == 1 && com->binding_label) - return get_identifier (com->binding_label); - - if (strcmp (name, BLANK_COMMON_NAME) == 0) - return get_identifier (name); - - if (flag_underscoring) - { - has_underscore = strchr (name, '_') != 0; - if (flag_second_underscore && has_underscore) - snprintf (mangled_name, sizeof mangled_name, "%s__", name); - else - snprintf (mangled_name, sizeof mangled_name, "%s_", name); - - return get_identifier (mangled_name); - } - else - return get_identifier (name); -} - - -/* Build a field declaration for a common variable or a local equivalence - object. */ - -static void -build_field (segment_info *h, tree union_type, record_layout_info rli) -{ - tree field; - tree name; - HOST_WIDE_INT offset = h->offset; - unsigned HOST_WIDE_INT desired_align, known_align; - - name = get_identifier (h->sym->name); - field = build_decl (gfc_get_location (&h->sym->declared_at), - FIELD_DECL, name, h->field); - known_align = (offset & -offset) * BITS_PER_UNIT; - if (known_align == 0 || known_align > BIGGEST_ALIGNMENT) - known_align = BIGGEST_ALIGNMENT; - - desired_align = update_alignment_for_field (rli, field, known_align); - if (desired_align > known_align) - DECL_PACKED (field) = 1; - - DECL_FIELD_CONTEXT (field) = union_type; - DECL_FIELD_OFFSET (field) = size_int (offset); - DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; - SET_DECL_OFFSET_ALIGN (field, known_align); - - rli->offset = size_binop (MAX_EXPR, rli->offset, - size_binop (PLUS_EXPR, - DECL_FIELD_OFFSET (field), - DECL_SIZE_UNIT (field))); - /* If this field is assigned to a label, we create another two variables. - One will hold the address of target label or format label. The other will - hold the length of format label string. */ - if (h->sym->attr.assign) - { - tree len; - tree addr; - - gfc_allocate_lang_decl (field); - GFC_DECL_ASSIGN (field) = 1; - len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name); - addr = gfc_create_var_np (pvoid_type_node, h->sym->name); - TREE_STATIC (len) = 1; - TREE_STATIC (addr) = 1; - DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2); - gfc_set_decl_location (len, &h->sym->declared_at); - gfc_set_decl_location (addr, &h->sym->declared_at); - GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len); - GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr); - } - - /* If this field is volatile, mark it. */ - if (h->sym->attr.volatile_) - { - tree new_type; - TREE_THIS_VOLATILE (field) = 1; - TREE_SIDE_EFFECTS (field) = 1; - new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE); - TREE_TYPE (field) = new_type; - } - - h->field = field; -} - - -/* Get storage for local equivalence. */ - -static tree -build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto) -{ - tree decl; - char name[18]; - static int serial = 0; - - if (is_init) - { - decl = gfc_create_var (union_type, "equiv"); - TREE_STATIC (decl) = 1; - GFC_DECL_COMMON_OR_EQUIV (decl) = 1; - return decl; - } - - snprintf (name, sizeof (name), "equiv.%d", serial++); - decl = build_decl (input_location, - VAR_DECL, get_identifier (name), union_type); - DECL_ARTIFICIAL (decl) = 1; - DECL_IGNORED_P (decl) = 1; - - if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) - || is_saved)) - TREE_STATIC (decl) = 1; - - TREE_ADDRESSABLE (decl) = 1; - TREE_USED (decl) = 1; - GFC_DECL_COMMON_OR_EQUIV (decl) = 1; - - /* The source location has been lost, and doesn't really matter. - We need to set it to something though. */ - gfc_set_decl_location (decl, &gfc_current_locus); - - gfc_add_decl_to_function (decl); - - return decl; -} - - -/* Get storage for common block. */ - -static tree -build_common_decl (gfc_common_head *com, tree union_type, bool is_init) -{ - tree decl, identifier; - - identifier = gfc_sym_mangled_common_id (com); - decl = gfc_map_of_all_commons.count(identifier) - ? gfc_map_of_all_commons[identifier] : NULL_TREE; - - /* Update the size of this common block as needed. */ - if (decl != NULL_TREE) - { - tree size = TYPE_SIZE_UNIT (union_type); - - /* Named common blocks of the same name shall be of the same size - in all scoping units of a program in which they appear, but - blank common blocks may be of different sizes. */ - if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size) - && strcmp (com->name, BLANK_COMMON_NAME)) - gfc_warning (0, "Named COMMON block %qs at %L shall be of the " - "same size as elsewhere (%lu vs %lu bytes)", com->name, - &com->where, - (unsigned long) TREE_INT_CST_LOW (size), - (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl))); - - if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) - { - DECL_SIZE (decl) = TYPE_SIZE (union_type); - DECL_SIZE_UNIT (decl) = size; - SET_DECL_MODE (decl, TYPE_MODE (union_type)); - TREE_TYPE (decl) = union_type; - layout_decl (decl, 0); - } - } - - /* If this common block has been declared in a previous program unit, - and either it is already initialized or there is no new initialization - for it, just return. */ - if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) - return decl; - - /* If there is no backend_decl for the common block, build it. */ - if (decl == NULL_TREE) - { - tree omp_clauses = NULL_TREE; - - if (com->is_bind_c == 1 && com->binding_label) - decl = build_decl (input_location, VAR_DECL, identifier, union_type); - else - { - decl = build_decl (input_location, VAR_DECL, get_identifier (com->name), - union_type); - gfc_set_decl_assembler_name (decl, identifier); - } - - TREE_PUBLIC (decl) = 1; - TREE_STATIC (decl) = 1; - DECL_IGNORED_P (decl) = 1; - if (!com->is_bind_c) - SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT); - else - { - /* Do not set the alignment for bind(c) common blocks to - BIGGEST_ALIGNMENT because that won't match what C does. Also, - for common blocks with one element, the alignment must be - that of the field within the common block in order to match - what C will do. */ - tree field = NULL_TREE; - field = TYPE_FIELDS (TREE_TYPE (decl)); - if (DECL_CHAIN (field) == NULL_TREE) - SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field))); - } - DECL_USER_ALIGN (decl) = 0; - GFC_DECL_COMMON_OR_EQUIV (decl) = 1; - - gfc_set_decl_location (decl, &com->where); - - if (com->threadprivate) - set_decl_tls_model (decl, decl_default_tls_model (decl)); - - if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET) - { - tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); - switch (com->omp_device_type) - { - case OMP_DEVICE_TYPE_HOST: - OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST; - break; - case OMP_DEVICE_TYPE_NOHOST: - OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST; - break; - case OMP_DEVICE_TYPE_ANY: - OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY; - break; - default: - gcc_unreachable (); - } - omp_clauses = c; - } - if (com->omp_declare_target_link) - DECL_ATTRIBUTES (decl) - = tree_cons (get_identifier ("omp declare target link"), - omp_clauses, DECL_ATTRIBUTES (decl)); - else if (com->omp_declare_target) - DECL_ATTRIBUTES (decl) - = tree_cons (get_identifier ("omp declare target"), - omp_clauses, DECL_ATTRIBUTES (decl)); - - /* Place the back end declaration for this common block in - GLOBAL_BINDING_LEVEL. */ - gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl); - } - - /* Has no initial values. */ - if (!is_init) - { - DECL_INITIAL (decl) = NULL_TREE; - DECL_COMMON (decl) = 1; - DECL_DEFER_OUTPUT (decl) = 1; - } - else - { - DECL_INITIAL (decl) = error_mark_node; - DECL_COMMON (decl) = 0; - DECL_DEFER_OUTPUT (decl) = 0; - } - return decl; -} - - -/* Return a field that is the size of the union, if an equivalence has - overlapping initializers. Merge the initializers into a single - initializer for this new field, then free the old ones. */ - -static tree -get_init_field (segment_info *head, tree union_type, tree *field_init, - record_layout_info rli) -{ - segment_info *s; - HOST_WIDE_INT length = 0; - HOST_WIDE_INT offset = 0; - unsigned HOST_WIDE_INT known_align, desired_align; - bool overlap = false; - tree tmp, field; - tree init; - unsigned char *data, *chk; - vec *v = NULL; - - tree type = unsigned_char_type_node; - int i; - - /* Obtain the size of the union and check if there are any overlapping - initializers. */ - for (s = head; s; s = s->next) - { - HOST_WIDE_INT slen = s->offset + s->length; - if (s->sym->value) - { - if (s->offset < offset) - overlap = true; - offset = slen; - } - length = length < slen ? slen : length; - } - - if (!overlap) - return NULL_TREE; - - /* Now absorb all the initializer data into a single vector, - whilst checking for overlapping, unequal values. */ - data = XCNEWVEC (unsigned char, (size_t)length); - chk = XCNEWVEC (unsigned char, (size_t)length); - - /* TODO - change this when default initialization is implemented. */ - memset (data, '\0', (size_t)length); - memset (chk, '\0', (size_t)length); - for (s = head; s; s = s->next) - if (s->sym->value) - { - locus *loc = NULL; - if (s->sym->ns->equiv && s->sym->ns->equiv->eq) - loc = &s->sym->ns->equiv->eq->expr->where; - gfc_merge_initializers (s->sym->ts, s->sym->value, loc, - &data[s->offset], - &chk[s->offset], - (size_t)s->length); - } - - for (i = 0; i < length; i++) - CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i])); - - free (data); - free (chk); - - /* Build a char[length] array to hold the initializers. Much of what - follows is borrowed from build_field, above. */ - - tmp = build_int_cst (gfc_array_index_type, length - 1); - tmp = build_range_type (gfc_array_index_type, - gfc_index_zero_node, tmp); - tmp = build_array_type (type, tmp); - field = build_decl (gfc_get_location (&gfc_current_locus), - FIELD_DECL, NULL_TREE, tmp); - - known_align = BIGGEST_ALIGNMENT; - - desired_align = update_alignment_for_field (rli, field, known_align); - if (desired_align > known_align) - DECL_PACKED (field) = 1; - - DECL_FIELD_CONTEXT (field) = union_type; - DECL_FIELD_OFFSET (field) = size_int (0); - DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; - SET_DECL_OFFSET_ALIGN (field, known_align); - - rli->offset = size_binop (MAX_EXPR, rli->offset, - size_binop (PLUS_EXPR, - DECL_FIELD_OFFSET (field), - DECL_SIZE_UNIT (field))); - - init = build_constructor (TREE_TYPE (field), v); - TREE_CONSTANT (init) = 1; - - *field_init = init; - - for (s = head; s; s = s->next) - { - if (s->sym->value == NULL) - continue; - - gfc_free_expr (s->sym->value); - s->sym->value = NULL; - } - - return field; -} - - -/* Declare memory for the common block or local equivalence, and create - backend declarations for all of the elements. */ - -static void -create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) -{ - segment_info *s, *next_s; - tree union_type; - tree *field_link; - tree field; - tree field_init = NULL_TREE; - record_layout_info rli; - tree decl; - bool is_init = false; - bool is_saved = false; - bool is_auto = false; - - /* Declare the variables inside the common block. - If the current common block contains any equivalence object, then - make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the - alias analyzer work well when there is no address overlapping for - common variables in the current common block. */ - if (saw_equiv) - union_type = make_node (UNION_TYPE); - else - union_type = make_node (RECORD_TYPE); - - rli = start_record_layout (union_type); - field_link = &TYPE_FIELDS (union_type); - - /* Check for overlapping initializers and replace them with a single, - artificial field that contains all the data. */ - if (saw_equiv) - field = get_init_field (head, union_type, &field_init, rli); - else - field = NULL_TREE; - - if (field != NULL_TREE) - { - is_init = true; - *field_link = field; - field_link = &DECL_CHAIN (field); - } - - for (s = head; s; s = s->next) - { - build_field (s, union_type, rli); - - /* Link the field into the type. */ - *field_link = s->field; - field_link = &DECL_CHAIN (s->field); - - /* Has initial value. */ - if (s->sym->value) - is_init = true; - - /* Has SAVE attribute. */ - if (s->sym->attr.save) - is_saved = true; - - /* Has AUTOMATIC attribute. */ - if (s->sym->attr.automatic) - is_auto = true; - } - - finish_record_layout (rli, true); - - if (com) - decl = build_common_decl (com, union_type, is_init); - else - decl = build_equiv_decl (union_type, is_init, is_saved, is_auto); - - if (is_init) - { - tree ctor, tmp; - vec *v = NULL; - - if (field != NULL_TREE && field_init != NULL_TREE) - CONSTRUCTOR_APPEND_ELT (v, field, field_init); - else - for (s = head; s; s = s->next) - { - if (s->sym->value) - { - /* Add the initializer for this field. */ - tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, - TREE_TYPE (s->field), - s->sym->attr.dimension, - s->sym->attr.pointer - || s->sym->attr.allocatable, false); - - CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); - } - } - - gcc_assert (!v->is_empty ()); - ctor = build_constructor (union_type, v); - TREE_CONSTANT (ctor) = 1; - TREE_STATIC (ctor) = 1; - DECL_INITIAL (decl) = ctor; - - if (flag_checking) - { - tree field, value; - unsigned HOST_WIDE_INT idx; - FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value) - gcc_assert (TREE_CODE (field) == FIELD_DECL); - } - } - - /* Build component reference for each variable. */ - for (s = head; s; s = next_s) - { - tree var_decl; - - var_decl = build_decl (gfc_get_location (&s->sym->declared_at), - VAR_DECL, DECL_NAME (s->field), - TREE_TYPE (s->field)); - TREE_STATIC (var_decl) = TREE_STATIC (decl); - /* Mark the variable as used in order to avoid warnings about - unused variables. */ - TREE_USED (var_decl) = 1; - if (s->sym->attr.use_assoc) - DECL_IGNORED_P (var_decl) = 1; - if (s->sym->attr.target) - TREE_ADDRESSABLE (var_decl) = 1; - /* Fake variables are not visible from other translation units. */ - TREE_PUBLIC (var_decl) = 0; - gfc_finish_decl_attrs (var_decl, &s->sym->attr); - - /* To preserve identifier names in COMMON, chain to procedure - scope unless at top level in a module definition. */ - if (com - && s->sym->ns->proc_name - && s->sym->ns->proc_name->attr.flavor == FL_MODULE) - var_decl = pushdecl_top_level (var_decl); - else - gfc_add_decl_to_function (var_decl); - - tree comp = build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (s->field), decl, s->field, NULL_TREE); - if (TREE_THIS_VOLATILE (s->field)) - TREE_THIS_VOLATILE (comp) = 1; - SET_DECL_VALUE_EXPR (var_decl, comp); - DECL_HAS_VALUE_EXPR_P (var_decl) = 1; - GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; - - if (s->sym->attr.assign) - { - gfc_allocate_lang_decl (var_decl); - GFC_DECL_ASSIGN (var_decl) = 1; - GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field); - GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field); - } - - s->sym->backend_decl = var_decl; - - next_s = s->next; - free (s); - } -} - - -/* Given a symbol, find it in the current segment list. Returns NULL if - not found. */ - -static segment_info * -find_segment_info (gfc_symbol *symbol) -{ - segment_info *n; - - for (n = current_segment; n; n = n->next) - { - if (n->sym == symbol) - return n; - } - - return NULL; -} - - -/* Given an expression node, make sure it is a constant integer and return - the mpz_t value. */ - -static mpz_t * -get_mpz (gfc_expr *e) -{ - - if (e->expr_type != EXPR_CONSTANT) - gfc_internal_error ("get_mpz(): Not an integer constant"); - - return &e->value.integer; -} - - -/* Given an array specification and an array reference, figure out the - array element number (zero based). Bounds and elements are guaranteed - to be constants. If something goes wrong we generate an error and - return zero. */ - -static HOST_WIDE_INT -element_number (gfc_array_ref *ar) -{ - mpz_t multiplier, offset, extent, n; - gfc_array_spec *as; - HOST_WIDE_INT i, rank; - - as = ar->as; - rank = as->rank; - mpz_init_set_ui (multiplier, 1); - mpz_init_set_ui (offset, 0); - mpz_init (extent); - mpz_init (n); - - for (i = 0; i < rank; i++) - { - if (ar->dimen_type[i] != DIMEN_ELEMENT) - gfc_internal_error ("element_number(): Bad dimension type"); - - if (as && as->lower[i]) - mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i])); - else - mpz_sub_ui (n, *get_mpz (ar->start[i]), 1); - - mpz_mul (n, n, multiplier); - mpz_add (offset, offset, n); - - if (as && as->upper[i] && as->lower[i]) - { - mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i])); - mpz_add_ui (extent, extent, 1); - } - else - mpz_set_ui (extent, 0); - - if (mpz_sgn (extent) < 0) - mpz_set_ui (extent, 0); - - mpz_mul (multiplier, multiplier, extent); - } - - i = mpz_get_ui (offset); - - mpz_clear (multiplier); - mpz_clear (offset); - mpz_clear (extent); - mpz_clear (n); - - return i; -} - - -/* Given a single element of an equivalence list, figure out the offset - from the base symbol. For simple variables or full arrays, this is - simply zero. For an array element we have to calculate the array - element number and multiply by the element size. For a substring we - have to calculate the further reference. */ - -static HOST_WIDE_INT -calculate_offset (gfc_expr *e) -{ - HOST_WIDE_INT n, element_size, offset; - gfc_typespec *element_type; - gfc_ref *reference; - - offset = 0; - element_type = &e->symtree->n.sym->ts; - - for (reference = e->ref; reference; reference = reference->next) - switch (reference->type) - { - case REF_ARRAY: - switch (reference->u.ar.type) - { - case AR_FULL: - break; - - case AR_ELEMENT: - n = element_number (&reference->u.ar); - if (element_type->type == BT_CHARACTER) - gfc_conv_const_charlen (element_type->u.cl); - element_size = - int_size_in_bytes (gfc_typenode_for_spec (element_type)); - offset += n * element_size; - break; - - default: - gfc_error ("Bad array reference at %L", &e->where); - } - break; - case REF_SUBSTRING: - if (reference->u.ss.start != NULL) - offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1; - break; - default: - gfc_error ("Illegal reference type at %L as EQUIVALENCE object", - &e->where); - } - return offset; -} - - -/* Add a new segment_info structure to the current segment. eq1 is already - in the list, eq2 is not. */ - -static void -new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2) -{ - HOST_WIDE_INT offset1, offset2; - segment_info *a; - - offset1 = calculate_offset (eq1->expr); - offset2 = calculate_offset (eq2->expr); - - a = get_segment_info (eq2->expr->symtree->n.sym, - v->offset + offset1 - offset2); - - current_segment = add_segments (current_segment, a); -} - - -/* Given two equivalence structures that are both already in the list, make - sure that this new condition is not violated, generating an error if it - is. */ - -static void -confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, - gfc_equiv *eq2) -{ - HOST_WIDE_INT offset1, offset2; - - offset1 = calculate_offset (eq1->expr); - offset2 = calculate_offset (eq2->expr); - - if (s1->offset + offset1 != s2->offset + offset2) - gfc_error ("Inconsistent equivalence rules involving %qs at %L and " - "%qs at %L", s1->sym->name, &s1->sym->declared_at, - s2->sym->name, &s2->sym->declared_at); -} - - -/* Process a new equivalence condition. eq1 is know to be in segment f. - If eq2 is also present then confirm that the condition holds. - Otherwise add a new variable to the segment list. */ - -static void -add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) -{ - segment_info *n; - - n = find_segment_info (eq2->expr->symtree->n.sym); - - if (n == NULL) - new_condition (f, eq1, eq2); - else - confirm_condition (f, eq1, n, eq2); -} - -static void -accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) -{ - symbol_attribute attr = e->expr->symtree->n.sym->attr; - - dummy_symbol->dummy |= attr.dummy; - dummy_symbol->pointer |= attr.pointer; - dummy_symbol->target |= attr.target; - dummy_symbol->external |= attr.external; - dummy_symbol->intrinsic |= attr.intrinsic; - dummy_symbol->allocatable |= attr.allocatable; - dummy_symbol->elemental |= attr.elemental; - dummy_symbol->recursive |= attr.recursive; - dummy_symbol->in_common |= attr.in_common; - dummy_symbol->result |= attr.result; - dummy_symbol->in_namelist |= attr.in_namelist; - dummy_symbol->optional |= attr.optional; - dummy_symbol->entry |= attr.entry; - dummy_symbol->function |= attr.function; - dummy_symbol->subroutine |= attr.subroutine; - dummy_symbol->dimension |= attr.dimension; - dummy_symbol->in_equivalence |= attr.in_equivalence; - dummy_symbol->use_assoc |= attr.use_assoc; - dummy_symbol->cray_pointer |= attr.cray_pointer; - dummy_symbol->cray_pointee |= attr.cray_pointee; - dummy_symbol->data |= attr.data; - dummy_symbol->value |= attr.value; - dummy_symbol->volatile_ |= attr.volatile_; - dummy_symbol->is_protected |= attr.is_protected; - dummy_symbol->is_bind_c |= attr.is_bind_c; - dummy_symbol->procedure |= attr.procedure; - dummy_symbol->proc_pointer |= attr.proc_pointer; - dummy_symbol->abstract |= attr.abstract; - dummy_symbol->asynchronous |= attr.asynchronous; - dummy_symbol->codimension |= attr.codimension; - dummy_symbol->contiguous |= attr.contiguous; - dummy_symbol->generic |= attr.generic; - dummy_symbol->automatic |= attr.automatic; - dummy_symbol->threadprivate |= attr.threadprivate; - dummy_symbol->omp_declare_target |= attr.omp_declare_target; - dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; - dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; - dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; - dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; - dummy_symbol->oacc_declare_device_resident - |= attr.oacc_declare_device_resident; - - /* Not strictly correct, but probably close enough. */ - if (attr.save > dummy_symbol->save) - dummy_symbol->save = attr.save; - if (attr.access > dummy_symbol->access) - dummy_symbol->access = attr.access; -} - -/* Given a segment element, search through the equivalence lists for unused - conditions that involve the symbol. Add these rules to the segment. */ - -static bool -find_equivalence (segment_info *n) -{ - gfc_equiv *e1, *e2, *eq; - bool found; - - found = FALSE; - - for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) - { - eq = NULL; - - /* Search the equivalence list, including the root (first) element - for the symbol that owns the segment. */ - symbol_attribute dummy_symbol; - memset (&dummy_symbol, 0, sizeof (dummy_symbol)); - for (e2 = e1; e2; e2 = e2->eq) - { - accumulate_equivalence_attributes (&dummy_symbol, e2); - if (!e2->used && e2->expr->symtree->n.sym == n->sym) - { - eq = e2; - break; - } - } - - gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where); - - /* Go to the next root element. */ - if (eq == NULL) - continue; - - eq->used = 1; - - /* Now traverse the equivalence list matching the offsets. */ - for (e2 = e1; e2; e2 = e2->eq) - { - if (!e2->used && e2 != eq) - { - add_condition (n, eq, e2); - e2->used = 1; - found = TRUE; - } - } - } - return found; -} - - -/* Add all symbols equivalenced within a segment. We need to scan the - segment list multiple times to include indirect equivalences. Since - a new segment_info can inserted at the beginning of the segment list, - depending on its offset, we have to force a final pass through the - loop by demanding that completion sees a pass with no matches; i.e., - all symbols with equiv_built set and no new equivalences found. */ - -static void -add_equivalences (bool *saw_equiv) -{ - segment_info *f; - bool more = TRUE; - - while (more) - { - more = FALSE; - for (f = current_segment; f; f = f->next) - { - if (!f->sym->equiv_built) - { - f->sym->equiv_built = 1; - bool seen_one = find_equivalence (f); - if (seen_one) - { - *saw_equiv = true; - more = true; - } - } - } - } - - /* Add a copy of this segment list to the namespace. */ - copy_equiv_list_to_ns (current_segment); -} - - -/* Returns the offset necessary to properly align the current equivalence. - Sets *palign to the required alignment. */ - -static HOST_WIDE_INT -align_segment (unsigned HOST_WIDE_INT *palign) -{ - segment_info *s; - unsigned HOST_WIDE_INT offset; - unsigned HOST_WIDE_INT max_align; - unsigned HOST_WIDE_INT this_align; - unsigned HOST_WIDE_INT this_offset; - - max_align = 1; - offset = 0; - for (s = current_segment; s; s = s->next) - { - this_align = TYPE_ALIGN_UNIT (s->field); - if (s->offset & (this_align - 1)) - { - /* Field is misaligned. */ - this_offset = this_align - ((s->offset + offset) & (this_align - 1)); - if (this_offset & (max_align - 1)) - { - /* Aligning this field would misalign a previous field. */ - gfc_error ("The equivalence set for variable %qs " - "declared at %L violates alignment requirements", - s->sym->name, &s->sym->declared_at); - } - offset += this_offset; - } - max_align = this_align; - } - if (palign) - *palign = max_align; - return offset; -} - - -/* Adjust segment offsets by the given amount. */ - -static void -apply_segment_offset (segment_info *s, HOST_WIDE_INT offset) -{ - for (; s; s = s->next) - s->offset += offset; -} - - -/* Lay out a symbol in a common block. If the symbol has already been seen - then check the location is consistent. Otherwise create segments - for that symbol and all the symbols equivalenced with it. */ - -/* Translate a single common block. */ - -static void -translate_common (gfc_common_head *common, gfc_symbol *var_list) -{ - gfc_symbol *sym; - segment_info *s; - segment_info *common_segment; - HOST_WIDE_INT offset; - HOST_WIDE_INT current_offset; - unsigned HOST_WIDE_INT align; - bool saw_equiv; - - common_segment = NULL; - offset = 0; - current_offset = 0; - align = 1; - saw_equiv = false; - - /* Add symbols to the segment. */ - for (sym = var_list; sym; sym = sym->common_next) - { - current_segment = common_segment; - s = find_segment_info (sym); - - /* Symbol has already been added via an equivalence. Multiple - use associations of the same common block result in equiv_built - being set but no information about the symbol in the segment. */ - if (s && sym->equiv_built) - { - /* Ensure the current location is properly aligned. */ - align = TYPE_ALIGN_UNIT (s->field); - current_offset = (current_offset + align - 1) &~ (align - 1); - - /* Verify that it ended up where we expect it. */ - if (s->offset != current_offset) - { - gfc_error ("Equivalence for %qs does not match ordering of " - "COMMON %qs at %L", sym->name, - common->name, &common->where); - } - } - else - { - /* A symbol we haven't seen before. */ - s = current_segment = get_segment_info (sym, current_offset); - - /* Add all objects directly or indirectly equivalenced with this - symbol. */ - add_equivalences (&saw_equiv); - - if (current_segment->offset < 0) - gfc_error ("The equivalence set for %qs cause an invalid " - "extension to COMMON %qs at %L", sym->name, - common->name, &common->where); - - if (flag_align_commons) - offset = align_segment (&align); - - if (offset) - { - /* The required offset conflicts with previous alignment - requirements. Insert padding immediately before this - segment. */ - if (warn_align_commons) - { - if (strcmp (common->name, BLANK_COMMON_NAME)) - gfc_warning (OPT_Walign_commons, - "Padding of %d bytes required before %qs in " - "COMMON %qs at %L; reorder elements or use " - "%<-fno-align-commons%>", (int)offset, - s->sym->name, common->name, &common->where); - else - gfc_warning (OPT_Walign_commons, - "Padding of %d bytes required before %qs in " - "COMMON at %L; reorder elements or use " - "%<-fno-align-commons%>", (int)offset, - s->sym->name, &common->where); - } - } - - /* Apply the offset to the new segments. */ - apply_segment_offset (current_segment, offset); - current_offset += offset; - - /* Add the new segments to the common block. */ - common_segment = add_segments (common_segment, current_segment); - } - - /* The offset of the next common variable. */ - current_offset += s->length; - } - - if (common_segment == NULL) - { - gfc_error ("COMMON %qs at %L does not exist", - common->name, &common->where); - return; - } - - if (common_segment->offset != 0 && warn_align_commons) - { - if (strcmp (common->name, BLANK_COMMON_NAME)) - gfc_warning (OPT_Walign_commons, - "COMMON %qs at %L requires %d bytes of padding; " - "reorder elements or use %<-fno-align-commons%>", - common->name, &common->where, (int)common_segment->offset); - else - gfc_warning (OPT_Walign_commons, - "COMMON at %L requires %d bytes of padding; " - "reorder elements or use %<-fno-align-commons%>", - &common->where, (int)common_segment->offset); - } - - create_common (common, common_segment, saw_equiv); -} - - -/* Create a new block for each merged equivalence list. */ - -static void -finish_equivalences (gfc_namespace *ns) -{ - gfc_equiv *z, *y; - gfc_symbol *sym; - gfc_common_head * c; - HOST_WIDE_INT offset; - unsigned HOST_WIDE_INT align; - bool dummy; - - for (z = ns->equiv; z; z = z->next) - for (y = z->eq; y; y = y->eq) - { - if (y->used) - continue; - sym = z->expr->symtree->n.sym; - current_segment = get_segment_info (sym, 0); - - /* All objects directly or indirectly equivalenced with this - symbol. */ - add_equivalences (&dummy); - - /* Align the block. */ - offset = align_segment (&align); - - /* Ensure all offsets are positive. */ - offset -= current_segment->offset & ~(align - 1); - - apply_segment_offset (current_segment, offset); - - /* Create the decl. If this is a module equivalence, it has a - unique name, pointed to by z->module. This is written to a - gfc_common_header to push create_common into using - build_common_decl, so that the equivalence appears as an - external symbol. Otherwise, a local declaration is built using - build_equiv_decl. */ - if (z->module) - { - c = gfc_get_common_head (); - /* We've lost the real location, so use the location of the - enclosing procedure. If we're in a BLOCK DATA block, then - use the location in the sym_root. */ - if (ns->proc_name) - c->where = ns->proc_name->declared_at; - else if (ns->is_block_data) - c->where = ns->sym_root->n.sym->declared_at; - - size_t len = strlen (z->module); - gcc_assert (len < sizeof (c->name)); - memcpy (c->name, z->module, len); - c->name[len] = '\0'; - } - else - c = NULL; - - create_common (c, current_segment, true); - break; - } -} - - -/* Work function for translating a named common block. */ - -static void -named_common (gfc_symtree *st) -{ - translate_common (st->n.common, st->n.common->head); -} - - -/* Translate the common blocks in a namespace. Unlike other variables, - these have to be created before code, because the backend_decl depends - on the rest of the common block. */ - -void -gfc_trans_common (gfc_namespace *ns) -{ - gfc_common_head *c; - - /* Translate the blank common block. */ - if (ns->blank_common.head != NULL) - { - c = gfc_get_common_head (); - c->where = ns->blank_common.head->common_head->where; - strcpy (c->name, BLANK_COMMON_NAME); - translate_common (c, ns->blank_common.head); - } - - /* Translate all named common blocks. */ - gfc_traverse_symtree (ns->common_root, named_common); - - /* Translate local equivalence. */ - finish_equivalences (ns); - - /* Commit the newly created symbols for common blocks and module - equivalences. */ - gfc_commit_symbols (); -} diff --git a/gcc/fortran/trans-common.cc b/gcc/fortran/trans-common.cc new file mode 100644 index 0000000..7b4d198 --- /dev/null +++ b/gcc/fortran/trans-common.cc @@ -0,0 +1,1392 @@ +/* Common block and equivalence list handling + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Canqun Yang + +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 +. */ + +/* The core algorithm is based on Andy Vaught's g95 tree. Also the + way to build UNION_TYPE is borrowed from Richard Henderson. + + Transform common blocks. An integral part of this is processing + equivalence variables. Equivalenced variables that are not in a + common block end up in a private block of their own. + + Each common block or local equivalence list is declared as a union. + Variables within the block are represented as a field within the + block with the proper offset. + + So if two variables are equivalenced, they just point to a common + area in memory. + + Mathematically, laying out an equivalence block is equivalent to + solving a linear system of equations. The matrix is usually a + sparse matrix in which each row contains all zero elements except + for a +1 and a -1, a sort of a generalized Vandermonde matrix. The + matrix is usually block diagonal. The system can be + overdetermined, underdetermined or have a unique solution. If the + system is inconsistent, the program is not standard conforming. + The solution vector is integral, since all of the pivots are +1 or -1. + + How we lay out an equivalence block is a little less complicated. + In an equivalence list with n elements, there are n-1 conditions to + be satisfied. The conditions partition the variables into what we + will call segments. If A and B are equivalenced then A and B are + in the same segment. If B and C are equivalenced as well, then A, + B and C are in a segment and so on. Each segment is a block of + memory that has one or more variables equivalenced in some way. A + common block is made up of a series of segments that are joined one + after the other. In the linear system, a segment is a block + diagonal. + + To lay out a segment we first start with some variable and + determine its length. The first variable is assumed to start at + offset one and extends to however long it is. We then traverse the + list of equivalences to find an unused condition that involves at + least one of the variables currently in the segment. + + Each equivalence condition amounts to the condition B+b=C+c where B + and C are the offsets of the B and C variables, and b and c are + constants which are nonzero for array elements, substrings or + structure components. So for + + EQUIVALENCE(B(2), C(3)) + we have + B + 2*size of B's elements = C + 3*size of C's elements. + + If B and C are known we check to see if the condition already + holds. If B is known we can solve for C. Since we know the length + of C, we can see if the minimum and maximum extents of the segment + are affected. Eventually, we make a full pass through the + equivalence list without finding any new conditions and the segment + is fully specified. + + At this point, the segment is added to the current common block. + Since we know the minimum extent of the segment, everything in the + segment is translated to its position in the common block. The + usual case here is that there are no equivalence statements and the + common block is series of segments with one variable each, which is + a diagonal matrix in the matrix formulation. + + Each segment is described by a chain of segment_info structures. Each + segment_info structure describes the extents of a single variable within + the segment. This list is maintained in the order the elements are + positioned within the segment. If two elements have the same starting + offset the smaller will come first. If they also have the same size their + ordering is undefined. + + Once all common blocks have been created, the list of equivalences + is examined for still-unused equivalence conditions. We create a + block for each merged equivalence list. */ + +#include "config.h" +#define INCLUDE_MAP +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "tree.h" +#include "gfortran.h" +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "stor-layout.h" +#include "varasm.h" +#include "trans-types.h" +#include "trans-const.h" +#include "target-memory.h" + + +/* Holds a single variable in an equivalence set. */ +typedef struct segment_info +{ + gfc_symbol *sym; + HOST_WIDE_INT offset; + HOST_WIDE_INT length; + /* This will contain the field type until the field is created. */ + tree field; + struct segment_info *next; +} segment_info; + +static segment_info * current_segment; + +/* Store decl of all common blocks in this translation unit; the first + tree is the identifier. */ +static std::map gfc_map_of_all_commons; + + +/* Make a segment_info based on a symbol. */ + +static segment_info * +get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset) +{ + segment_info *s; + + /* Make sure we've got the character length. */ + if (sym->ts.type == BT_CHARACTER) + gfc_conv_const_charlen (sym->ts.u.cl); + + /* Create the segment_info and fill it in. */ + s = XCNEW (segment_info); + s->sym = sym; + /* We will use this type when building the segment aggregate type. */ + s->field = gfc_sym_type (sym); + s->length = int_size_in_bytes (s->field); + s->offset = offset; + + return s; +} + + +/* Add a copy of a segment list to the namespace. This is specifically for + equivalence segments, so that dependency checking can be done on + equivalence group members. */ + +static void +copy_equiv_list_to_ns (segment_info *c) +{ + segment_info *f; + gfc_equiv_info *s; + gfc_equiv_list *l; + + l = XCNEW (gfc_equiv_list); + + l->next = c->sym->ns->equiv_lists; + c->sym->ns->equiv_lists = l; + + for (f = c; f; f = f->next) + { + s = XCNEW (gfc_equiv_info); + s->next = l->equiv; + l->equiv = s; + s->sym = f->sym; + s->offset = f->offset; + s->length = f->length; + } +} + + +/* Add combine segment V and segment LIST. */ + +static segment_info * +add_segments (segment_info *list, segment_info *v) +{ + segment_info *s; + segment_info *p; + segment_info *next; + + p = NULL; + s = list; + + while (v) + { + /* Find the location of the new element. */ + while (s) + { + if (v->offset < s->offset) + break; + if (v->offset == s->offset + && v->length <= s->length) + break; + + p = s; + s = s->next; + } + + /* Insert the new element in between p and s. */ + next = v->next; + v->next = s; + if (p == NULL) + list = v; + else + p->next = v; + + p = v; + v = next; + } + + return list; +} + + +/* Construct mangled common block name from symbol name. */ + +/* We need the bind(c) flag to tell us how/if we should mangle the symbol + name. There are few calls to this function, so few places that this + would need to be added. At the moment, there is only one call, in + build_common_decl(). We can't attempt to look up the common block + because we may be building it for the first time and therefore, it won't + be in the common_root. We also need the binding label, if it's bind(c). + Therefore, send in the pointer to the common block, so whatever info we + have so far can be used. All of the necessary info should be available + in the gfc_common_head by now, so it should be accurate to test the + isBindC flag and use the binding label given if it is bind(c). + + We may NOT know yet if it's bind(c) or not, but we can try at least. + Will have to figure out what to do later if it's labeled bind(c) + after this is called. */ + +static tree +gfc_sym_mangled_common_id (gfc_common_head *com) +{ + int has_underscore; + /* Provide sufficient space to hold "symbol.symbol.eq.1234567890__". */ + char mangled_name[2*GFC_MAX_MANGLED_SYMBOL_LEN + 1 + 16 + 1]; + char name[sizeof (mangled_name) - 2]; + + /* Get the name out of the common block pointer. */ + size_t len = strlen (com->name); + gcc_assert (len < sizeof (name)); + strcpy (name, com->name); + + /* If we're suppose to do a bind(c). */ + if (com->is_bind_c == 1 && com->binding_label) + return get_identifier (com->binding_label); + + if (strcmp (name, BLANK_COMMON_NAME) == 0) + return get_identifier (name); + + if (flag_underscoring) + { + has_underscore = strchr (name, '_') != 0; + if (flag_second_underscore && has_underscore) + snprintf (mangled_name, sizeof mangled_name, "%s__", name); + else + snprintf (mangled_name, sizeof mangled_name, "%s_", name); + + return get_identifier (mangled_name); + } + else + return get_identifier (name); +} + + +/* Build a field declaration for a common variable or a local equivalence + object. */ + +static void +build_field (segment_info *h, tree union_type, record_layout_info rli) +{ + tree field; + tree name; + HOST_WIDE_INT offset = h->offset; + unsigned HOST_WIDE_INT desired_align, known_align; + + name = get_identifier (h->sym->name); + field = build_decl (gfc_get_location (&h->sym->declared_at), + FIELD_DECL, name, h->field); + known_align = (offset & -offset) * BITS_PER_UNIT; + if (known_align == 0 || known_align > BIGGEST_ALIGNMENT) + known_align = BIGGEST_ALIGNMENT; + + desired_align = update_alignment_for_field (rli, field, known_align); + if (desired_align > known_align) + DECL_PACKED (field) = 1; + + DECL_FIELD_CONTEXT (field) = union_type; + DECL_FIELD_OFFSET (field) = size_int (offset); + DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; + SET_DECL_OFFSET_ALIGN (field, known_align); + + rli->offset = size_binop (MAX_EXPR, rli->offset, + size_binop (PLUS_EXPR, + DECL_FIELD_OFFSET (field), + DECL_SIZE_UNIT (field))); + /* If this field is assigned to a label, we create another two variables. + One will hold the address of target label or format label. The other will + hold the length of format label string. */ + if (h->sym->attr.assign) + { + tree len; + tree addr; + + gfc_allocate_lang_decl (field); + GFC_DECL_ASSIGN (field) = 1; + len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name); + addr = gfc_create_var_np (pvoid_type_node, h->sym->name); + TREE_STATIC (len) = 1; + TREE_STATIC (addr) = 1; + DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2); + gfc_set_decl_location (len, &h->sym->declared_at); + gfc_set_decl_location (addr, &h->sym->declared_at); + GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len); + GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr); + } + + /* If this field is volatile, mark it. */ + if (h->sym->attr.volatile_) + { + tree new_type; + TREE_THIS_VOLATILE (field) = 1; + TREE_SIDE_EFFECTS (field) = 1; + new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE); + TREE_TYPE (field) = new_type; + } + + h->field = field; +} + + +/* Get storage for local equivalence. */ + +static tree +build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto) +{ + tree decl; + char name[18]; + static int serial = 0; + + if (is_init) + { + decl = gfc_create_var (union_type, "equiv"); + TREE_STATIC (decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; + return decl; + } + + snprintf (name, sizeof (name), "equiv.%d", serial++); + decl = build_decl (input_location, + VAR_DECL, get_identifier (name), union_type); + DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; + + if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) + || is_saved)) + TREE_STATIC (decl) = 1; + + TREE_ADDRESSABLE (decl) = 1; + TREE_USED (decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; + + /* The source location has been lost, and doesn't really matter. + We need to set it to something though. */ + gfc_set_decl_location (decl, &gfc_current_locus); + + gfc_add_decl_to_function (decl); + + return decl; +} + + +/* Get storage for common block. */ + +static tree +build_common_decl (gfc_common_head *com, tree union_type, bool is_init) +{ + tree decl, identifier; + + identifier = gfc_sym_mangled_common_id (com); + decl = gfc_map_of_all_commons.count(identifier) + ? gfc_map_of_all_commons[identifier] : NULL_TREE; + + /* Update the size of this common block as needed. */ + if (decl != NULL_TREE) + { + tree size = TYPE_SIZE_UNIT (union_type); + + /* Named common blocks of the same name shall be of the same size + in all scoping units of a program in which they appear, but + blank common blocks may be of different sizes. */ + if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size) + && strcmp (com->name, BLANK_COMMON_NAME)) + gfc_warning (0, "Named COMMON block %qs at %L shall be of the " + "same size as elsewhere (%lu vs %lu bytes)", com->name, + &com->where, + (unsigned long) TREE_INT_CST_LOW (size), + (unsigned long) TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl))); + + if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) + { + DECL_SIZE (decl) = TYPE_SIZE (union_type); + DECL_SIZE_UNIT (decl) = size; + SET_DECL_MODE (decl, TYPE_MODE (union_type)); + TREE_TYPE (decl) = union_type; + layout_decl (decl, 0); + } + } + + /* If this common block has been declared in a previous program unit, + and either it is already initialized or there is no new initialization + for it, just return. */ + if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) + return decl; + + /* If there is no backend_decl for the common block, build it. */ + if (decl == NULL_TREE) + { + tree omp_clauses = NULL_TREE; + + if (com->is_bind_c == 1 && com->binding_label) + decl = build_decl (input_location, VAR_DECL, identifier, union_type); + else + { + decl = build_decl (input_location, VAR_DECL, get_identifier (com->name), + union_type); + gfc_set_decl_assembler_name (decl, identifier); + } + + TREE_PUBLIC (decl) = 1; + TREE_STATIC (decl) = 1; + DECL_IGNORED_P (decl) = 1; + if (!com->is_bind_c) + SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT); + else + { + /* Do not set the alignment for bind(c) common blocks to + BIGGEST_ALIGNMENT because that won't match what C does. Also, + for common blocks with one element, the alignment must be + that of the field within the common block in order to match + what C will do. */ + tree field = NULL_TREE; + field = TYPE_FIELDS (TREE_TYPE (decl)); + if (DECL_CHAIN (field) == NULL_TREE) + SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field))); + } + DECL_USER_ALIGN (decl) = 0; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; + + gfc_set_decl_location (decl, &com->where); + + if (com->threadprivate) + set_decl_tls_model (decl, decl_default_tls_model (decl)); + + if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET) + { + tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); + switch (com->omp_device_type) + { + case OMP_DEVICE_TYPE_HOST: + OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST; + break; + case OMP_DEVICE_TYPE_NOHOST: + OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST; + break; + case OMP_DEVICE_TYPE_ANY: + OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY; + break; + default: + gcc_unreachable (); + } + omp_clauses = c; + } + if (com->omp_declare_target_link) + DECL_ATTRIBUTES (decl) + = tree_cons (get_identifier ("omp declare target link"), + omp_clauses, DECL_ATTRIBUTES (decl)); + else if (com->omp_declare_target) + DECL_ATTRIBUTES (decl) + = tree_cons (get_identifier ("omp declare target"), + omp_clauses, DECL_ATTRIBUTES (decl)); + + /* Place the back end declaration for this common block in + GLOBAL_BINDING_LEVEL. */ + gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl); + } + + /* Has no initial values. */ + if (!is_init) + { + DECL_INITIAL (decl) = NULL_TREE; + DECL_COMMON (decl) = 1; + DECL_DEFER_OUTPUT (decl) = 1; + } + else + { + DECL_INITIAL (decl) = error_mark_node; + DECL_COMMON (decl) = 0; + DECL_DEFER_OUTPUT (decl) = 0; + } + return decl; +} + + +/* Return a field that is the size of the union, if an equivalence has + overlapping initializers. Merge the initializers into a single + initializer for this new field, then free the old ones. */ + +static tree +get_init_field (segment_info *head, tree union_type, tree *field_init, + record_layout_info rli) +{ + segment_info *s; + HOST_WIDE_INT length = 0; + HOST_WIDE_INT offset = 0; + unsigned HOST_WIDE_INT known_align, desired_align; + bool overlap = false; + tree tmp, field; + tree init; + unsigned char *data, *chk; + vec *v = NULL; + + tree type = unsigned_char_type_node; + int i; + + /* Obtain the size of the union and check if there are any overlapping + initializers. */ + for (s = head; s; s = s->next) + { + HOST_WIDE_INT slen = s->offset + s->length; + if (s->sym->value) + { + if (s->offset < offset) + overlap = true; + offset = slen; + } + length = length < slen ? slen : length; + } + + if (!overlap) + return NULL_TREE; + + /* Now absorb all the initializer data into a single vector, + whilst checking for overlapping, unequal values. */ + data = XCNEWVEC (unsigned char, (size_t)length); + chk = XCNEWVEC (unsigned char, (size_t)length); + + /* TODO - change this when default initialization is implemented. */ + memset (data, '\0', (size_t)length); + memset (chk, '\0', (size_t)length); + for (s = head; s; s = s->next) + if (s->sym->value) + { + locus *loc = NULL; + if (s->sym->ns->equiv && s->sym->ns->equiv->eq) + loc = &s->sym->ns->equiv->eq->expr->where; + gfc_merge_initializers (s->sym->ts, s->sym->value, loc, + &data[s->offset], + &chk[s->offset], + (size_t)s->length); + } + + for (i = 0; i < length; i++) + CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i])); + + free (data); + free (chk); + + /* Build a char[length] array to hold the initializers. Much of what + follows is borrowed from build_field, above. */ + + tmp = build_int_cst (gfc_array_index_type, length - 1); + tmp = build_range_type (gfc_array_index_type, + gfc_index_zero_node, tmp); + tmp = build_array_type (type, tmp); + field = build_decl (gfc_get_location (&gfc_current_locus), + FIELD_DECL, NULL_TREE, tmp); + + known_align = BIGGEST_ALIGNMENT; + + desired_align = update_alignment_for_field (rli, field, known_align); + if (desired_align > known_align) + DECL_PACKED (field) = 1; + + DECL_FIELD_CONTEXT (field) = union_type; + DECL_FIELD_OFFSET (field) = size_int (0); + DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; + SET_DECL_OFFSET_ALIGN (field, known_align); + + rli->offset = size_binop (MAX_EXPR, rli->offset, + size_binop (PLUS_EXPR, + DECL_FIELD_OFFSET (field), + DECL_SIZE_UNIT (field))); + + init = build_constructor (TREE_TYPE (field), v); + TREE_CONSTANT (init) = 1; + + *field_init = init; + + for (s = head; s; s = s->next) + { + if (s->sym->value == NULL) + continue; + + gfc_free_expr (s->sym->value); + s->sym->value = NULL; + } + + return field; +} + + +/* Declare memory for the common block or local equivalence, and create + backend declarations for all of the elements. */ + +static void +create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) +{ + segment_info *s, *next_s; + tree union_type; + tree *field_link; + tree field; + tree field_init = NULL_TREE; + record_layout_info rli; + tree decl; + bool is_init = false; + bool is_saved = false; + bool is_auto = false; + + /* Declare the variables inside the common block. + If the current common block contains any equivalence object, then + make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the + alias analyzer work well when there is no address overlapping for + common variables in the current common block. */ + if (saw_equiv) + union_type = make_node (UNION_TYPE); + else + union_type = make_node (RECORD_TYPE); + + rli = start_record_layout (union_type); + field_link = &TYPE_FIELDS (union_type); + + /* Check for overlapping initializers and replace them with a single, + artificial field that contains all the data. */ + if (saw_equiv) + field = get_init_field (head, union_type, &field_init, rli); + else + field = NULL_TREE; + + if (field != NULL_TREE) + { + is_init = true; + *field_link = field; + field_link = &DECL_CHAIN (field); + } + + for (s = head; s; s = s->next) + { + build_field (s, union_type, rli); + + /* Link the field into the type. */ + *field_link = s->field; + field_link = &DECL_CHAIN (s->field); + + /* Has initial value. */ + if (s->sym->value) + is_init = true; + + /* Has SAVE attribute. */ + if (s->sym->attr.save) + is_saved = true; + + /* Has AUTOMATIC attribute. */ + if (s->sym->attr.automatic) + is_auto = true; + } + + finish_record_layout (rli, true); + + if (com) + decl = build_common_decl (com, union_type, is_init); + else + decl = build_equiv_decl (union_type, is_init, is_saved, is_auto); + + if (is_init) + { + tree ctor, tmp; + vec *v = NULL; + + if (field != NULL_TREE && field_init != NULL_TREE) + CONSTRUCTOR_APPEND_ELT (v, field, field_init); + else + for (s = head; s; s = s->next) + { + if (s->sym->value) + { + /* Add the initializer for this field. */ + tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, + TREE_TYPE (s->field), + s->sym->attr.dimension, + s->sym->attr.pointer + || s->sym->attr.allocatable, false); + + CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); + } + } + + gcc_assert (!v->is_empty ()); + ctor = build_constructor (union_type, v); + TREE_CONSTANT (ctor) = 1; + TREE_STATIC (ctor) = 1; + DECL_INITIAL (decl) = ctor; + + if (flag_checking) + { + tree field, value; + unsigned HOST_WIDE_INT idx; + FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value) + gcc_assert (TREE_CODE (field) == FIELD_DECL); + } + } + + /* Build component reference for each variable. */ + for (s = head; s; s = next_s) + { + tree var_decl; + + var_decl = build_decl (gfc_get_location (&s->sym->declared_at), + VAR_DECL, DECL_NAME (s->field), + TREE_TYPE (s->field)); + TREE_STATIC (var_decl) = TREE_STATIC (decl); + /* Mark the variable as used in order to avoid warnings about + unused variables. */ + TREE_USED (var_decl) = 1; + if (s->sym->attr.use_assoc) + DECL_IGNORED_P (var_decl) = 1; + if (s->sym->attr.target) + TREE_ADDRESSABLE (var_decl) = 1; + /* Fake variables are not visible from other translation units. */ + TREE_PUBLIC (var_decl) = 0; + gfc_finish_decl_attrs (var_decl, &s->sym->attr); + + /* To preserve identifier names in COMMON, chain to procedure + scope unless at top level in a module definition. */ + if (com + && s->sym->ns->proc_name + && s->sym->ns->proc_name->attr.flavor == FL_MODULE) + var_decl = pushdecl_top_level (var_decl); + else + gfc_add_decl_to_function (var_decl); + + tree comp = build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (s->field), decl, s->field, NULL_TREE); + if (TREE_THIS_VOLATILE (s->field)) + TREE_THIS_VOLATILE (comp) = 1; + SET_DECL_VALUE_EXPR (var_decl, comp); + DECL_HAS_VALUE_EXPR_P (var_decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; + + if (s->sym->attr.assign) + { + gfc_allocate_lang_decl (var_decl); + GFC_DECL_ASSIGN (var_decl) = 1; + GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field); + GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field); + } + + s->sym->backend_decl = var_decl; + + next_s = s->next; + free (s); + } +} + + +/* Given a symbol, find it in the current segment list. Returns NULL if + not found. */ + +static segment_info * +find_segment_info (gfc_symbol *symbol) +{ + segment_info *n; + + for (n = current_segment; n; n = n->next) + { + if (n->sym == symbol) + return n; + } + + return NULL; +} + + +/* Given an expression node, make sure it is a constant integer and return + the mpz_t value. */ + +static mpz_t * +get_mpz (gfc_expr *e) +{ + + if (e->expr_type != EXPR_CONSTANT) + gfc_internal_error ("get_mpz(): Not an integer constant"); + + return &e->value.integer; +} + + +/* Given an array specification and an array reference, figure out the + array element number (zero based). Bounds and elements are guaranteed + to be constants. If something goes wrong we generate an error and + return zero. */ + +static HOST_WIDE_INT +element_number (gfc_array_ref *ar) +{ + mpz_t multiplier, offset, extent, n; + gfc_array_spec *as; + HOST_WIDE_INT i, rank; + + as = ar->as; + rank = as->rank; + mpz_init_set_ui (multiplier, 1); + mpz_init_set_ui (offset, 0); + mpz_init (extent); + mpz_init (n); + + for (i = 0; i < rank; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT) + gfc_internal_error ("element_number(): Bad dimension type"); + + if (as && as->lower[i]) + mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i])); + else + mpz_sub_ui (n, *get_mpz (ar->start[i]), 1); + + mpz_mul (n, n, multiplier); + mpz_add (offset, offset, n); + + if (as && as->upper[i] && as->lower[i]) + { + mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i])); + mpz_add_ui (extent, extent, 1); + } + else + mpz_set_ui (extent, 0); + + if (mpz_sgn (extent) < 0) + mpz_set_ui (extent, 0); + + mpz_mul (multiplier, multiplier, extent); + } + + i = mpz_get_ui (offset); + + mpz_clear (multiplier); + mpz_clear (offset); + mpz_clear (extent); + mpz_clear (n); + + return i; +} + + +/* Given a single element of an equivalence list, figure out the offset + from the base symbol. For simple variables or full arrays, this is + simply zero. For an array element we have to calculate the array + element number and multiply by the element size. For a substring we + have to calculate the further reference. */ + +static HOST_WIDE_INT +calculate_offset (gfc_expr *e) +{ + HOST_WIDE_INT n, element_size, offset; + gfc_typespec *element_type; + gfc_ref *reference; + + offset = 0; + element_type = &e->symtree->n.sym->ts; + + for (reference = e->ref; reference; reference = reference->next) + switch (reference->type) + { + case REF_ARRAY: + switch (reference->u.ar.type) + { + case AR_FULL: + break; + + case AR_ELEMENT: + n = element_number (&reference->u.ar); + if (element_type->type == BT_CHARACTER) + gfc_conv_const_charlen (element_type->u.cl); + element_size = + int_size_in_bytes (gfc_typenode_for_spec (element_type)); + offset += n * element_size; + break; + + default: + gfc_error ("Bad array reference at %L", &e->where); + } + break; + case REF_SUBSTRING: + if (reference->u.ss.start != NULL) + offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1; + break; + default: + gfc_error ("Illegal reference type at %L as EQUIVALENCE object", + &e->where); + } + return offset; +} + + +/* Add a new segment_info structure to the current segment. eq1 is already + in the list, eq2 is not. */ + +static void +new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2) +{ + HOST_WIDE_INT offset1, offset2; + segment_info *a; + + offset1 = calculate_offset (eq1->expr); + offset2 = calculate_offset (eq2->expr); + + a = get_segment_info (eq2->expr->symtree->n.sym, + v->offset + offset1 - offset2); + + current_segment = add_segments (current_segment, a); +} + + +/* Given two equivalence structures that are both already in the list, make + sure that this new condition is not violated, generating an error if it + is. */ + +static void +confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2, + gfc_equiv *eq2) +{ + HOST_WIDE_INT offset1, offset2; + + offset1 = calculate_offset (eq1->expr); + offset2 = calculate_offset (eq2->expr); + + if (s1->offset + offset1 != s2->offset + offset2) + gfc_error ("Inconsistent equivalence rules involving %qs at %L and " + "%qs at %L", s1->sym->name, &s1->sym->declared_at, + s2->sym->name, &s2->sym->declared_at); +} + + +/* Process a new equivalence condition. eq1 is know to be in segment f. + If eq2 is also present then confirm that the condition holds. + Otherwise add a new variable to the segment list. */ + +static void +add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) +{ + segment_info *n; + + n = find_segment_info (eq2->expr->symtree->n.sym); + + if (n == NULL) + new_condition (f, eq1, eq2); + else + confirm_condition (f, eq1, n, eq2); +} + +static void +accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) +{ + symbol_attribute attr = e->expr->symtree->n.sym->attr; + + dummy_symbol->dummy |= attr.dummy; + dummy_symbol->pointer |= attr.pointer; + dummy_symbol->target |= attr.target; + dummy_symbol->external |= attr.external; + dummy_symbol->intrinsic |= attr.intrinsic; + dummy_symbol->allocatable |= attr.allocatable; + dummy_symbol->elemental |= attr.elemental; + dummy_symbol->recursive |= attr.recursive; + dummy_symbol->in_common |= attr.in_common; + dummy_symbol->result |= attr.result; + dummy_symbol->in_namelist |= attr.in_namelist; + dummy_symbol->optional |= attr.optional; + dummy_symbol->entry |= attr.entry; + dummy_symbol->function |= attr.function; + dummy_symbol->subroutine |= attr.subroutine; + dummy_symbol->dimension |= attr.dimension; + dummy_symbol->in_equivalence |= attr.in_equivalence; + dummy_symbol->use_assoc |= attr.use_assoc; + dummy_symbol->cray_pointer |= attr.cray_pointer; + dummy_symbol->cray_pointee |= attr.cray_pointee; + dummy_symbol->data |= attr.data; + dummy_symbol->value |= attr.value; + dummy_symbol->volatile_ |= attr.volatile_; + dummy_symbol->is_protected |= attr.is_protected; + dummy_symbol->is_bind_c |= attr.is_bind_c; + dummy_symbol->procedure |= attr.procedure; + dummy_symbol->proc_pointer |= attr.proc_pointer; + dummy_symbol->abstract |= attr.abstract; + dummy_symbol->asynchronous |= attr.asynchronous; + dummy_symbol->codimension |= attr.codimension; + dummy_symbol->contiguous |= attr.contiguous; + dummy_symbol->generic |= attr.generic; + dummy_symbol->automatic |= attr.automatic; + dummy_symbol->threadprivate |= attr.threadprivate; + dummy_symbol->omp_declare_target |= attr.omp_declare_target; + dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; + dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; + dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; + dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; + dummy_symbol->oacc_declare_device_resident + |= attr.oacc_declare_device_resident; + + /* Not strictly correct, but probably close enough. */ + if (attr.save > dummy_symbol->save) + dummy_symbol->save = attr.save; + if (attr.access > dummy_symbol->access) + dummy_symbol->access = attr.access; +} + +/* Given a segment element, search through the equivalence lists for unused + conditions that involve the symbol. Add these rules to the segment. */ + +static bool +find_equivalence (segment_info *n) +{ + gfc_equiv *e1, *e2, *eq; + bool found; + + found = FALSE; + + for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) + { + eq = NULL; + + /* Search the equivalence list, including the root (first) element + for the symbol that owns the segment. */ + symbol_attribute dummy_symbol; + memset (&dummy_symbol, 0, sizeof (dummy_symbol)); + for (e2 = e1; e2; e2 = e2->eq) + { + accumulate_equivalence_attributes (&dummy_symbol, e2); + if (!e2->used && e2->expr->symtree->n.sym == n->sym) + { + eq = e2; + break; + } + } + + gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where); + + /* Go to the next root element. */ + if (eq == NULL) + continue; + + eq->used = 1; + + /* Now traverse the equivalence list matching the offsets. */ + for (e2 = e1; e2; e2 = e2->eq) + { + if (!e2->used && e2 != eq) + { + add_condition (n, eq, e2); + e2->used = 1; + found = TRUE; + } + } + } + return found; +} + + +/* Add all symbols equivalenced within a segment. We need to scan the + segment list multiple times to include indirect equivalences. Since + a new segment_info can inserted at the beginning of the segment list, + depending on its offset, we have to force a final pass through the + loop by demanding that completion sees a pass with no matches; i.e., + all symbols with equiv_built set and no new equivalences found. */ + +static void +add_equivalences (bool *saw_equiv) +{ + segment_info *f; + bool more = TRUE; + + while (more) + { + more = FALSE; + for (f = current_segment; f; f = f->next) + { + if (!f->sym->equiv_built) + { + f->sym->equiv_built = 1; + bool seen_one = find_equivalence (f); + if (seen_one) + { + *saw_equiv = true; + more = true; + } + } + } + } + + /* Add a copy of this segment list to the namespace. */ + copy_equiv_list_to_ns (current_segment); +} + + +/* Returns the offset necessary to properly align the current equivalence. + Sets *palign to the required alignment. */ + +static HOST_WIDE_INT +align_segment (unsigned HOST_WIDE_INT *palign) +{ + segment_info *s; + unsigned HOST_WIDE_INT offset; + unsigned HOST_WIDE_INT max_align; + unsigned HOST_WIDE_INT this_align; + unsigned HOST_WIDE_INT this_offset; + + max_align = 1; + offset = 0; + for (s = current_segment; s; s = s->next) + { + this_align = TYPE_ALIGN_UNIT (s->field); + if (s->offset & (this_align - 1)) + { + /* Field is misaligned. */ + this_offset = this_align - ((s->offset + offset) & (this_align - 1)); + if (this_offset & (max_align - 1)) + { + /* Aligning this field would misalign a previous field. */ + gfc_error ("The equivalence set for variable %qs " + "declared at %L violates alignment requirements", + s->sym->name, &s->sym->declared_at); + } + offset += this_offset; + } + max_align = this_align; + } + if (palign) + *palign = max_align; + return offset; +} + + +/* Adjust segment offsets by the given amount. */ + +static void +apply_segment_offset (segment_info *s, HOST_WIDE_INT offset) +{ + for (; s; s = s->next) + s->offset += offset; +} + + +/* Lay out a symbol in a common block. If the symbol has already been seen + then check the location is consistent. Otherwise create segments + for that symbol and all the symbols equivalenced with it. */ + +/* Translate a single common block. */ + +static void +translate_common (gfc_common_head *common, gfc_symbol *var_list) +{ + gfc_symbol *sym; + segment_info *s; + segment_info *common_segment; + HOST_WIDE_INT offset; + HOST_WIDE_INT current_offset; + unsigned HOST_WIDE_INT align; + bool saw_equiv; + + common_segment = NULL; + offset = 0; + current_offset = 0; + align = 1; + saw_equiv = false; + + /* Add symbols to the segment. */ + for (sym = var_list; sym; sym = sym->common_next) + { + current_segment = common_segment; + s = find_segment_info (sym); + + /* Symbol has already been added via an equivalence. Multiple + use associations of the same common block result in equiv_built + being set but no information about the symbol in the segment. */ + if (s && sym->equiv_built) + { + /* Ensure the current location is properly aligned. */ + align = TYPE_ALIGN_UNIT (s->field); + current_offset = (current_offset + align - 1) &~ (align - 1); + + /* Verify that it ended up where we expect it. */ + if (s->offset != current_offset) + { + gfc_error ("Equivalence for %qs does not match ordering of " + "COMMON %qs at %L", sym->name, + common->name, &common->where); + } + } + else + { + /* A symbol we haven't seen before. */ + s = current_segment = get_segment_info (sym, current_offset); + + /* Add all objects directly or indirectly equivalenced with this + symbol. */ + add_equivalences (&saw_equiv); + + if (current_segment->offset < 0) + gfc_error ("The equivalence set for %qs cause an invalid " + "extension to COMMON %qs at %L", sym->name, + common->name, &common->where); + + if (flag_align_commons) + offset = align_segment (&align); + + if (offset) + { + /* The required offset conflicts with previous alignment + requirements. Insert padding immediately before this + segment. */ + if (warn_align_commons) + { + if (strcmp (common->name, BLANK_COMMON_NAME)) + gfc_warning (OPT_Walign_commons, + "Padding of %d bytes required before %qs in " + "COMMON %qs at %L; reorder elements or use " + "%<-fno-align-commons%>", (int)offset, + s->sym->name, common->name, &common->where); + else + gfc_warning (OPT_Walign_commons, + "Padding of %d bytes required before %qs in " + "COMMON at %L; reorder elements or use " + "%<-fno-align-commons%>", (int)offset, + s->sym->name, &common->where); + } + } + + /* Apply the offset to the new segments. */ + apply_segment_offset (current_segment, offset); + current_offset += offset; + + /* Add the new segments to the common block. */ + common_segment = add_segments (common_segment, current_segment); + } + + /* The offset of the next common variable. */ + current_offset += s->length; + } + + if (common_segment == NULL) + { + gfc_error ("COMMON %qs at %L does not exist", + common->name, &common->where); + return; + } + + if (common_segment->offset != 0 && warn_align_commons) + { + if (strcmp (common->name, BLANK_COMMON_NAME)) + gfc_warning (OPT_Walign_commons, + "COMMON %qs at %L requires %d bytes of padding; " + "reorder elements or use %<-fno-align-commons%>", + common->name, &common->where, (int)common_segment->offset); + else + gfc_warning (OPT_Walign_commons, + "COMMON at %L requires %d bytes of padding; " + "reorder elements or use %<-fno-align-commons%>", + &common->where, (int)common_segment->offset); + } + + create_common (common, common_segment, saw_equiv); +} + + +/* Create a new block for each merged equivalence list. */ + +static void +finish_equivalences (gfc_namespace *ns) +{ + gfc_equiv *z, *y; + gfc_symbol *sym; + gfc_common_head * c; + HOST_WIDE_INT offset; + unsigned HOST_WIDE_INT align; + bool dummy; + + for (z = ns->equiv; z; z = z->next) + for (y = z->eq; y; y = y->eq) + { + if (y->used) + continue; + sym = z->expr->symtree->n.sym; + current_segment = get_segment_info (sym, 0); + + /* All objects directly or indirectly equivalenced with this + symbol. */ + add_equivalences (&dummy); + + /* Align the block. */ + offset = align_segment (&align); + + /* Ensure all offsets are positive. */ + offset -= current_segment->offset & ~(align - 1); + + apply_segment_offset (current_segment, offset); + + /* Create the decl. If this is a module equivalence, it has a + unique name, pointed to by z->module. This is written to a + gfc_common_header to push create_common into using + build_common_decl, so that the equivalence appears as an + external symbol. Otherwise, a local declaration is built using + build_equiv_decl. */ + if (z->module) + { + c = gfc_get_common_head (); + /* We've lost the real location, so use the location of the + enclosing procedure. If we're in a BLOCK DATA block, then + use the location in the sym_root. */ + if (ns->proc_name) + c->where = ns->proc_name->declared_at; + else if (ns->is_block_data) + c->where = ns->sym_root->n.sym->declared_at; + + size_t len = strlen (z->module); + gcc_assert (len < sizeof (c->name)); + memcpy (c->name, z->module, len); + c->name[len] = '\0'; + } + else + c = NULL; + + create_common (c, current_segment, true); + break; + } +} + + +/* Work function for translating a named common block. */ + +static void +named_common (gfc_symtree *st) +{ + translate_common (st->n.common, st->n.common->head); +} + + +/* Translate the common blocks in a namespace. Unlike other variables, + these have to be created before code, because the backend_decl depends + on the rest of the common block. */ + +void +gfc_trans_common (gfc_namespace *ns) +{ + gfc_common_head *c; + + /* Translate the blank common block. */ + if (ns->blank_common.head != NULL) + { + c = gfc_get_common_head (); + c->where = ns->blank_common.head->common_head->where; + strcpy (c->name, BLANK_COMMON_NAME); + translate_common (c, ns->blank_common.head); + } + + /* Translate all named common blocks. */ + gfc_traverse_symtree (ns->common_root, named_common); + + /* Translate local equivalence. */ + finish_equivalences (ns); + + /* Commit the newly created symbols for common blocks and module + equivalences. */ + gfc_commit_symbols (); +} diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c deleted file mode 100644 index 35167b4..0000000 --- a/gcc/fortran/trans-const.c +++ /dev/null @@ -1,430 +0,0 @@ -/* Translation of constants - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - -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 -. */ - -/* trans-const.c -- convert constant values */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "gfortran.h" -#include "options.h" -#include "trans.h" -#include "fold-const.h" -#include "stor-layout.h" -#include "realmpfr.h" -#include "trans-const.h" -#include "trans-types.h" -#include "target-memory.h" - -tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; - -/* Build a constant with given type from an int_cst. */ - -tree -gfc_build_const (tree type, tree intval) -{ - tree val; - tree zero; - - switch (TREE_CODE (type)) - { - case INTEGER_TYPE: - val = convert (type, intval); - break; - - case REAL_TYPE: - val = build_real_from_int_cst (type, intval); - break; - - case COMPLEX_TYPE: - val = build_real_from_int_cst (TREE_TYPE (type), intval); - zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); - val = build_complex (type, val, zero); - break; - - default: - gcc_unreachable (); - } - return val; -} - -/* Build a string constant with C char type. */ - -tree -gfc_build_string_const (size_t length, const char *s) -{ - tree str; - tree len; - - str = build_string (length, s); - len = size_int (length); - TREE_TYPE (str) = - build_array_type (gfc_character1_type_node, - build_range_type (gfc_charlen_type_node, - size_one_node, len)); - TYPE_STRING_FLAG (TREE_TYPE (str)) = 1; - return str; -} - - -/* Build a string constant with a type given by its kind; take care of - non-default character kinds. */ - -tree -gfc_build_wide_string_const (int kind, size_t length, const gfc_char_t *string) -{ - int i; - tree str, len; - size_t size; - char *s; - - i = gfc_validate_kind (BT_CHARACTER, kind, false); - size = length * gfc_character_kinds[i].bit_size / 8; - - s = XCNEWVAR (char, size); - gfc_encode_character (kind, length, string, (unsigned char *) s, size); - - str = build_string (size, s); - free (s); - - len = size_int (length); - TREE_TYPE (str) = - build_array_type (gfc_get_char_type (kind), - build_range_type (gfc_charlen_type_node, - size_one_node, len)); - TYPE_STRING_FLAG (TREE_TYPE (str)) = 1; - return str; -} - - -/* Build a Fortran character constant from a zero-terminated string. - There a two version of this function, one that translates the string - and one that doesn't. */ -tree -gfc_build_cstring_const (const char *string) -{ - return gfc_build_string_const (strlen (string) + 1, string); -} - -tree -gfc_build_localized_cstring_const (const char *msgid) -{ - const char *localized = _(msgid); - return gfc_build_string_const (strlen (localized) + 1, localized); -} - - -/* Return a string constant with the given length. Used for static - initializers. The constant will be padded or truncated to match - length. */ - -tree -gfc_conv_string_init (tree length, gfc_expr * expr) -{ - gfc_char_t *s; - HOST_WIDE_INT len; - gfc_charlen_t slen; - tree str; - bool free_s = false; - - gcc_assert (expr->expr_type == EXPR_CONSTANT); - gcc_assert (expr->ts.type == BT_CHARACTER); - gcc_assert (tree_fits_uhwi_p (length)); - - len = TREE_INT_CST_LOW (length); - slen = expr->value.character.length; - - if (len > slen) - { - s = gfc_get_wide_string (len); - memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t)); - gfc_wide_memset (&s[slen], ' ', len - slen); - free_s = true; - } - else - s = expr->value.character.string; - - str = gfc_build_wide_string_const (expr->ts.kind, len, s); - - if (free_s) - free (s); - - return str; -} - - -/* Create a tree node for the string length if it is constant. */ - -void -gfc_conv_const_charlen (gfc_charlen * cl) -{ - if (!cl || cl->backend_decl) - return; - - if (cl->length && cl->length->expr_type == EXPR_CONSTANT) - { - cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer, - cl->length->ts.kind); - cl->backend_decl = fold_convert (gfc_charlen_type_node, - cl->backend_decl); - } -} - -void -gfc_init_constants (void) -{ - int n; - - for (n = 0; n <= GFC_MAX_DIMENSIONS; n++) - gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n); -} - -/* Converts a GMP integer into a backend tree node. */ - -tree -gfc_conv_mpz_to_tree (mpz_t i, int kind) -{ - wide_int val = wi::from_mpz (gfc_get_int_type (kind), i, true); - return wide_int_to_tree (gfc_get_int_type (kind), val); -} - - -/* Convert a GMP integer into a tree node of type given by the type - argument. */ - -tree -gfc_conv_mpz_to_tree_type (mpz_t i, const tree type) -{ - const wide_int val = wi::from_mpz (type, i, true); - return wide_int_to_tree (type, val); -} - - -/* Converts a backend tree into a GMP integer. */ - -void -gfc_conv_tree_to_mpz (mpz_t i, tree source) -{ - wi::to_mpz (wi::to_wide (source), i, TYPE_SIGN (TREE_TYPE (source))); -} - -/* Converts a real constant into backend form. */ - -tree -gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan) -{ - tree type; - int n; - REAL_VALUE_TYPE real; - - n = gfc_validate_kind (BT_REAL, kind, false); - gcc_assert (gfc_real_kinds[n].radix == 2); - - type = gfc_get_real_type (kind); - if (mpfr_nan_p (f) && is_snan) - real_from_string (&real, "SNaN"); - else - real_from_mpfr (&real, f, type, GFC_RND_MODE); - - return build_real (type, real); -} - -/* Returns a real constant that is +Infinity if the target - supports infinities for this floating-point mode, and - +HUGE_VAL otherwise (the largest representable number). */ - -tree -gfc_build_inf_or_huge (tree type, int kind) -{ - if (HONOR_INFINITIES (TYPE_MODE (type))) - { - REAL_VALUE_TYPE real; - real_inf (&real); - return build_real (type, real); - } - else - { - int k = gfc_validate_kind (BT_REAL, kind, false); - return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0); - } -} - -/* Returns a floating-point NaN of a given type. */ - -tree -gfc_build_nan (tree type, const char *str) -{ - REAL_VALUE_TYPE real; - real_nan (&real, str, 1, TYPE_MODE (type)); - return build_real (type, real); -} - -/* Converts a backend tree into a real constant. */ - -void -gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source) -{ - mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE); -} - -/* Translate any literal constant to a tree. Constants never have - pre or post chains. Character literal constants are special - special because they have a value and a length, so they cannot be - returned as a single tree. It is up to the caller to set the - length somewhere if necessary. - - Returns the translated constant, or aborts if it gets a type it - can't handle. */ - -tree -gfc_conv_constant_to_tree (gfc_expr * expr) -{ - tree res; - - gcc_assert (expr->expr_type == EXPR_CONSTANT); - - /* If it is has a prescribed memory representation, we build a string - constant and VIEW_CONVERT to its type. */ - - switch (expr->ts.type) - { - case BT_INTEGER: - if (expr->representation.string) - return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, - gfc_get_int_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); - else - return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); - - case BT_REAL: - if (expr->representation.string) - return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, - gfc_get_real_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); - else - return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan); - - case BT_LOGICAL: - if (expr->representation.string) - { - tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, - gfc_get_int_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); - if (!integer_zerop (tmp) && !integer_onep (tmp)) - gfc_warning (flag_dec_char_conversions ? OPT_Wsurprising : 0, - "Assigning value other than 0 or 1 to LOGICAL has " - "undefined result at %L", &expr->where); - return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp); - } - else - return build_int_cst (gfc_get_logical_type (expr->ts.kind), - expr->value.logical); - - case BT_COMPLEX: - if (expr->representation.string) - return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, - gfc_get_complex_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); - else - { - tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex), - expr->ts.kind, expr->is_snan); - tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex), - expr->ts.kind, expr->is_snan); - - return build_complex (gfc_typenode_for_spec (&expr->ts), - real, imag); - } - - case BT_CHARACTER: - res = gfc_build_wide_string_const (expr->ts.kind, - expr->value.character.length, - expr->value.character.string); - return res; - - case BT_HOLLERITH: - return gfc_build_string_const (expr->representation.length, - expr->representation.string); - - default: - gcc_unreachable (); - } -} - - -/* Like gfc_conv_constant_to_tree, but for a simplified expression. - We can handle character literal constants here as well. */ - -void -gfc_conv_constant (gfc_se * se, gfc_expr * expr) -{ - gfc_ss *ss; - - /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If - so, the expr_type will not yet be an EXPR_CONSTANT. We need to make - it so here. */ - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived - && expr->ts.u.derived->attr.is_iso_c) - { - if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR - || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) - { - /* Create a new EXPR_CONSTANT expression for our local uses. */ - expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - } - } - - if (expr->expr_type != EXPR_CONSTANT) - { - gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - gfc_error ("non-constant initialization expression at %L", &expr->where); - se->expr = gfc_conv_constant_to_tree (e); - return; - } - - ss = se->ss; - if (ss != NULL) - { - gfc_ss_info *ss_info; - - ss_info = ss->info; - gcc_assert (ss != gfc_ss_terminator); - gcc_assert (ss_info->type == GFC_SS_SCALAR); - gcc_assert (ss_info->expr == expr); - - se->expr = ss_info->data.scalar.value; - se->string_length = ss_info->string_length; - gfc_advance_se_ss_chain (se); - return; - } - - /* Translate the constant and put it in the simplifier structure. */ - se->expr = gfc_conv_constant_to_tree (expr); - - /* If this is a CHARACTER string, set its length in the simplifier - structure, too. */ - if (expr->ts.type == BT_CHARACTER) - se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); -} diff --git a/gcc/fortran/trans-const.cc b/gcc/fortran/trans-const.cc new file mode 100644 index 0000000..35167b4 --- /dev/null +++ b/gcc/fortran/trans-const.cc @@ -0,0 +1,430 @@ +/* Translation of constants + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + +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 +. */ + +/* trans-const.c -- convert constant values */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "gfortran.h" +#include "options.h" +#include "trans.h" +#include "fold-const.h" +#include "stor-layout.h" +#include "realmpfr.h" +#include "trans-const.h" +#include "trans-types.h" +#include "target-memory.h" + +tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; + +/* Build a constant with given type from an int_cst. */ + +tree +gfc_build_const (tree type, tree intval) +{ + tree val; + tree zero; + + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + val = convert (type, intval); + break; + + case REAL_TYPE: + val = build_real_from_int_cst (type, intval); + break; + + case COMPLEX_TYPE: + val = build_real_from_int_cst (TREE_TYPE (type), intval); + zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); + val = build_complex (type, val, zero); + break; + + default: + gcc_unreachable (); + } + return val; +} + +/* Build a string constant with C char type. */ + +tree +gfc_build_string_const (size_t length, const char *s) +{ + tree str; + tree len; + + str = build_string (length, s); + len = size_int (length); + TREE_TYPE (str) = + build_array_type (gfc_character1_type_node, + build_range_type (gfc_charlen_type_node, + size_one_node, len)); + TYPE_STRING_FLAG (TREE_TYPE (str)) = 1; + return str; +} + + +/* Build a string constant with a type given by its kind; take care of + non-default character kinds. */ + +tree +gfc_build_wide_string_const (int kind, size_t length, const gfc_char_t *string) +{ + int i; + tree str, len; + size_t size; + char *s; + + i = gfc_validate_kind (BT_CHARACTER, kind, false); + size = length * gfc_character_kinds[i].bit_size / 8; + + s = XCNEWVAR (char, size); + gfc_encode_character (kind, length, string, (unsigned char *) s, size); + + str = build_string (size, s); + free (s); + + len = size_int (length); + TREE_TYPE (str) = + build_array_type (gfc_get_char_type (kind), + build_range_type (gfc_charlen_type_node, + size_one_node, len)); + TYPE_STRING_FLAG (TREE_TYPE (str)) = 1; + return str; +} + + +/* Build a Fortran character constant from a zero-terminated string. + There a two version of this function, one that translates the string + and one that doesn't. */ +tree +gfc_build_cstring_const (const char *string) +{ + return gfc_build_string_const (strlen (string) + 1, string); +} + +tree +gfc_build_localized_cstring_const (const char *msgid) +{ + const char *localized = _(msgid); + return gfc_build_string_const (strlen (localized) + 1, localized); +} + + +/* Return a string constant with the given length. Used for static + initializers. The constant will be padded or truncated to match + length. */ + +tree +gfc_conv_string_init (tree length, gfc_expr * expr) +{ + gfc_char_t *s; + HOST_WIDE_INT len; + gfc_charlen_t slen; + tree str; + bool free_s = false; + + gcc_assert (expr->expr_type == EXPR_CONSTANT); + gcc_assert (expr->ts.type == BT_CHARACTER); + gcc_assert (tree_fits_uhwi_p (length)); + + len = TREE_INT_CST_LOW (length); + slen = expr->value.character.length; + + if (len > slen) + { + s = gfc_get_wide_string (len); + memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t)); + gfc_wide_memset (&s[slen], ' ', len - slen); + free_s = true; + } + else + s = expr->value.character.string; + + str = gfc_build_wide_string_const (expr->ts.kind, len, s); + + if (free_s) + free (s); + + return str; +} + + +/* Create a tree node for the string length if it is constant. */ + +void +gfc_conv_const_charlen (gfc_charlen * cl) +{ + if (!cl || cl->backend_decl) + return; + + if (cl->length && cl->length->expr_type == EXPR_CONSTANT) + { + cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer, + cl->length->ts.kind); + cl->backend_decl = fold_convert (gfc_charlen_type_node, + cl->backend_decl); + } +} + +void +gfc_init_constants (void) +{ + int n; + + for (n = 0; n <= GFC_MAX_DIMENSIONS; n++) + gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n); +} + +/* Converts a GMP integer into a backend tree node. */ + +tree +gfc_conv_mpz_to_tree (mpz_t i, int kind) +{ + wide_int val = wi::from_mpz (gfc_get_int_type (kind), i, true); + return wide_int_to_tree (gfc_get_int_type (kind), val); +} + + +/* Convert a GMP integer into a tree node of type given by the type + argument. */ + +tree +gfc_conv_mpz_to_tree_type (mpz_t i, const tree type) +{ + const wide_int val = wi::from_mpz (type, i, true); + return wide_int_to_tree (type, val); +} + + +/* Converts a backend tree into a GMP integer. */ + +void +gfc_conv_tree_to_mpz (mpz_t i, tree source) +{ + wi::to_mpz (wi::to_wide (source), i, TYPE_SIGN (TREE_TYPE (source))); +} + +/* Converts a real constant into backend form. */ + +tree +gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan) +{ + tree type; + int n; + REAL_VALUE_TYPE real; + + n = gfc_validate_kind (BT_REAL, kind, false); + gcc_assert (gfc_real_kinds[n].radix == 2); + + type = gfc_get_real_type (kind); + if (mpfr_nan_p (f) && is_snan) + real_from_string (&real, "SNaN"); + else + real_from_mpfr (&real, f, type, GFC_RND_MODE); + + return build_real (type, real); +} + +/* Returns a real constant that is +Infinity if the target + supports infinities for this floating-point mode, and + +HUGE_VAL otherwise (the largest representable number). */ + +tree +gfc_build_inf_or_huge (tree type, int kind) +{ + if (HONOR_INFINITIES (TYPE_MODE (type))) + { + REAL_VALUE_TYPE real; + real_inf (&real); + return build_real (type, real); + } + else + { + int k = gfc_validate_kind (BT_REAL, kind, false); + return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0); + } +} + +/* Returns a floating-point NaN of a given type. */ + +tree +gfc_build_nan (tree type, const char *str) +{ + REAL_VALUE_TYPE real; + real_nan (&real, str, 1, TYPE_MODE (type)); + return build_real (type, real); +} + +/* Converts a backend tree into a real constant. */ + +void +gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source) +{ + mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE); +} + +/* Translate any literal constant to a tree. Constants never have + pre or post chains. Character literal constants are special + special because they have a value and a length, so they cannot be + returned as a single tree. It is up to the caller to set the + length somewhere if necessary. + + Returns the translated constant, or aborts if it gets a type it + can't handle. */ + +tree +gfc_conv_constant_to_tree (gfc_expr * expr) +{ + tree res; + + gcc_assert (expr->expr_type == EXPR_CONSTANT); + + /* If it is has a prescribed memory representation, we build a string + constant and VIEW_CONVERT to its type. */ + + switch (expr->ts.type) + { + case BT_INTEGER: + if (expr->representation.string) + return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_int_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); + else + return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); + + case BT_REAL: + if (expr->representation.string) + return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_real_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); + else + return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan); + + case BT_LOGICAL: + if (expr->representation.string) + { + tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_int_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); + if (!integer_zerop (tmp) && !integer_onep (tmp)) + gfc_warning (flag_dec_char_conversions ? OPT_Wsurprising : 0, + "Assigning value other than 0 or 1 to LOGICAL has " + "undefined result at %L", &expr->where); + return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp); + } + else + return build_int_cst (gfc_get_logical_type (expr->ts.kind), + expr->value.logical); + + case BT_COMPLEX: + if (expr->representation.string) + return fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + gfc_get_complex_type (expr->ts.kind), + gfc_build_string_const (expr->representation.length, + expr->representation.string)); + else + { + tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex), + expr->ts.kind, expr->is_snan); + tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex), + expr->ts.kind, expr->is_snan); + + return build_complex (gfc_typenode_for_spec (&expr->ts), + real, imag); + } + + case BT_CHARACTER: + res = gfc_build_wide_string_const (expr->ts.kind, + expr->value.character.length, + expr->value.character.string); + return res; + + case BT_HOLLERITH: + return gfc_build_string_const (expr->representation.length, + expr->representation.string); + + default: + gcc_unreachable (); + } +} + + +/* Like gfc_conv_constant_to_tree, but for a simplified expression. + We can handle character literal constants here as well. */ + +void +gfc_conv_constant (gfc_se * se, gfc_expr * expr) +{ + gfc_ss *ss; + + /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If + so, the expr_type will not yet be an EXPR_CONSTANT. We need to make + it so here. */ + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived + && expr->ts.u.derived->attr.is_iso_c) + { + if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR + || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) + { + /* Create a new EXPR_CONSTANT expression for our local uses. */ + expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + } + } + + if (expr->expr_type != EXPR_CONSTANT) + { + gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + gfc_error ("non-constant initialization expression at %L", &expr->where); + se->expr = gfc_conv_constant_to_tree (e); + return; + } + + ss = se->ss; + if (ss != NULL) + { + gfc_ss_info *ss_info; + + ss_info = ss->info; + gcc_assert (ss != gfc_ss_terminator); + gcc_assert (ss_info->type == GFC_SS_SCALAR); + gcc_assert (ss_info->expr == expr); + + se->expr = ss_info->data.scalar.value; + se->string_length = ss_info->string_length; + gfc_advance_se_ss_chain (se); + return; + } + + /* Translate the constant and put it in the simplifier structure. */ + se->expr = gfc_conv_constant_to_tree (expr); + + /* If this is a CHARACTER string, set its length in the simplifier + structure, too. */ + if (expr->ts.type == BT_CHARACTER) + se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); +} diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c deleted file mode 100644 index 08eaa5a..0000000 --- a/gcc/fortran/trans-decl.c +++ /dev/null @@ -1,7956 +0,0 @@ -/* Backend function setup - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - -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 -. */ - -/* trans-decl.c -- Handling of backend function and variable decls, etc */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "target.h" -#include "function.h" -#include "tree.h" -#include "gfortran.h" -#include "gimple-expr.h" /* For create_tmp_var_raw. */ -#include "trans.h" -#include "stringpool.h" -#include "cgraph.h" -#include "fold-const.h" -#include "stor-layout.h" -#include "varasm.h" -#include "attribs.h" -#include "dumpfile.h" -#include "toplev.h" /* For announce_function. */ -#include "debug.h" -#include "constructor.h" -#include "trans-types.h" -#include "trans-array.h" -#include "trans-const.h" -/* Only for gfc_trans_code. Shouldn't need to include this. */ -#include "trans-stmt.h" -#include "gomp-constants.h" -#include "gimplify.h" -#include "omp-general.h" -#include "attr-fnspec.h" - -#define MAX_LABEL_VALUE 99999 - - -/* Holds the result of the function if no result variable specified. */ - -static GTY(()) tree current_fake_result_decl; -static GTY(()) tree parent_fake_result_decl; - - -/* Holds the variable DECLs for the current function. */ - -static GTY(()) tree saved_function_decls; -static GTY(()) tree saved_parent_function_decls; - -/* Holds the variable DECLs that are locals. */ - -static GTY(()) tree saved_local_decls; - -/* The namespace of the module we're currently generating. Only used while - outputting decls for module variables. Do not rely on this being set. */ - -static gfc_namespace *module_namespace; - -/* The currently processed procedure symbol. */ -static gfc_symbol* current_procedure_symbol = NULL; - -/* The currently processed module. */ -static struct module_htab_entry *cur_module; - -/* With -fcoarray=lib: For generating the registering call - of static coarrays. */ -static bool has_coarray_vars; -static stmtblock_t caf_init_block; - - -/* List of static constructor functions. */ - -tree gfc_static_ctors; - - -/* Whether we've seen a symbol from an IEEE module in the namespace. */ -static int seen_ieee_symbol; - -/* Function declarations for builtin library functions. */ - -tree gfor_fndecl_pause_numeric; -tree gfor_fndecl_pause_string; -tree gfor_fndecl_stop_numeric; -tree gfor_fndecl_stop_string; -tree gfor_fndecl_error_stop_numeric; -tree gfor_fndecl_error_stop_string; -tree gfor_fndecl_runtime_error; -tree gfor_fndecl_runtime_error_at; -tree gfor_fndecl_runtime_warning_at; -tree gfor_fndecl_os_error_at; -tree gfor_fndecl_generate_error; -tree gfor_fndecl_set_args; -tree gfor_fndecl_set_fpe; -tree gfor_fndecl_set_options; -tree gfor_fndecl_set_convert; -tree gfor_fndecl_set_record_marker; -tree gfor_fndecl_set_max_subrecord_length; -tree gfor_fndecl_ctime; -tree gfor_fndecl_fdate; -tree gfor_fndecl_ttynam; -tree gfor_fndecl_in_pack; -tree gfor_fndecl_in_unpack; -tree gfor_fndecl_associated; -tree gfor_fndecl_system_clock4; -tree gfor_fndecl_system_clock8; -tree gfor_fndecl_ieee_procedure_entry; -tree gfor_fndecl_ieee_procedure_exit; - -/* Coarray run-time library function decls. */ -tree gfor_fndecl_caf_init; -tree gfor_fndecl_caf_finalize; -tree gfor_fndecl_caf_this_image; -tree gfor_fndecl_caf_num_images; -tree gfor_fndecl_caf_register; -tree gfor_fndecl_caf_deregister; -tree gfor_fndecl_caf_get; -tree gfor_fndecl_caf_send; -tree gfor_fndecl_caf_sendget; -tree gfor_fndecl_caf_get_by_ref; -tree gfor_fndecl_caf_send_by_ref; -tree gfor_fndecl_caf_sendget_by_ref; -tree gfor_fndecl_caf_sync_all; -tree gfor_fndecl_caf_sync_memory; -tree gfor_fndecl_caf_sync_images; -tree gfor_fndecl_caf_stop_str; -tree gfor_fndecl_caf_stop_numeric; -tree gfor_fndecl_caf_error_stop; -tree gfor_fndecl_caf_error_stop_str; -tree gfor_fndecl_caf_atomic_def; -tree gfor_fndecl_caf_atomic_ref; -tree gfor_fndecl_caf_atomic_cas; -tree gfor_fndecl_caf_atomic_op; -tree gfor_fndecl_caf_lock; -tree gfor_fndecl_caf_unlock; -tree gfor_fndecl_caf_event_post; -tree gfor_fndecl_caf_event_wait; -tree gfor_fndecl_caf_event_query; -tree gfor_fndecl_caf_fail_image; -tree gfor_fndecl_caf_failed_images; -tree gfor_fndecl_caf_image_status; -tree gfor_fndecl_caf_stopped_images; -tree gfor_fndecl_caf_form_team; -tree gfor_fndecl_caf_change_team; -tree gfor_fndecl_caf_end_team; -tree gfor_fndecl_caf_sync_team; -tree gfor_fndecl_caf_get_team; -tree gfor_fndecl_caf_team_number; -tree gfor_fndecl_co_broadcast; -tree gfor_fndecl_co_max; -tree gfor_fndecl_co_min; -tree gfor_fndecl_co_reduce; -tree gfor_fndecl_co_sum; -tree gfor_fndecl_caf_is_present; -tree gfor_fndecl_caf_random_init; - - -/* Math functions. Many other math functions are handled in - trans-intrinsic.c. */ - -gfc_powdecl_list gfor_fndecl_math_powi[4][3]; -tree gfor_fndecl_math_ishftc4; -tree gfor_fndecl_math_ishftc8; -tree gfor_fndecl_math_ishftc16; - - -/* String functions. */ - -tree gfor_fndecl_compare_string; -tree gfor_fndecl_concat_string; -tree gfor_fndecl_string_len_trim; -tree gfor_fndecl_string_index; -tree gfor_fndecl_string_scan; -tree gfor_fndecl_string_verify; -tree gfor_fndecl_string_trim; -tree gfor_fndecl_string_minmax; -tree gfor_fndecl_adjustl; -tree gfor_fndecl_adjustr; -tree gfor_fndecl_select_string; -tree gfor_fndecl_compare_string_char4; -tree gfor_fndecl_concat_string_char4; -tree gfor_fndecl_string_len_trim_char4; -tree gfor_fndecl_string_index_char4; -tree gfor_fndecl_string_scan_char4; -tree gfor_fndecl_string_verify_char4; -tree gfor_fndecl_string_trim_char4; -tree gfor_fndecl_string_minmax_char4; -tree gfor_fndecl_adjustl_char4; -tree gfor_fndecl_adjustr_char4; -tree gfor_fndecl_select_string_char4; - - -/* Conversion between character kinds. */ -tree gfor_fndecl_convert_char1_to_char4; -tree gfor_fndecl_convert_char4_to_char1; - - -/* Other misc. runtime library functions. */ -tree gfor_fndecl_iargc; -tree gfor_fndecl_kill; -tree gfor_fndecl_kill_sub; -tree gfor_fndecl_is_contiguous0; - - -/* Intrinsic functions implemented in Fortran. */ -tree gfor_fndecl_sc_kind; -tree gfor_fndecl_si_kind; -tree gfor_fndecl_sr_kind; - -/* BLAS gemm functions. */ -tree gfor_fndecl_sgemm; -tree gfor_fndecl_dgemm; -tree gfor_fndecl_cgemm; -tree gfor_fndecl_zgemm; - -/* RANDOM_INIT function. */ -tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */ - -static void -gfc_add_decl_to_parent_function (tree decl) -{ - gcc_assert (decl); - DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl); - DECL_NONLOCAL (decl) = 1; - DECL_CHAIN (decl) = saved_parent_function_decls; - saved_parent_function_decls = decl; -} - -void -gfc_add_decl_to_function (tree decl) -{ - gcc_assert (decl); - TREE_USED (decl) = 1; - DECL_CONTEXT (decl) = current_function_decl; - DECL_CHAIN (decl) = saved_function_decls; - saved_function_decls = decl; -} - -static void -add_decl_as_local (tree decl) -{ - gcc_assert (decl); - TREE_USED (decl) = 1; - DECL_CONTEXT (decl) = current_function_decl; - DECL_CHAIN (decl) = saved_local_decls; - saved_local_decls = decl; -} - - -/* Build a backend label declaration. Set TREE_USED for named labels. - The context of the label is always the current_function_decl. All - labels are marked artificial. */ - -tree -gfc_build_label_decl (tree label_id) -{ - /* 2^32 temporaries should be enough. */ - static unsigned int tmp_num = 1; - tree label_decl; - char *label_name; - - if (label_id == NULL_TREE) - { - /* Build an internal label name. */ - ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++); - label_id = get_identifier (label_name); - } - else - label_name = NULL; - - /* Build the LABEL_DECL node. Labels have no type. */ - label_decl = build_decl (input_location, - LABEL_DECL, label_id, void_type_node); - DECL_CONTEXT (label_decl) = current_function_decl; - SET_DECL_MODE (label_decl, VOIDmode); - - /* We always define the label as used, even if the original source - file never references the label. We don't want all kinds of - spurious warnings for old-style Fortran code with too many - labels. */ - TREE_USED (label_decl) = 1; - - DECL_ARTIFICIAL (label_decl) = 1; - return label_decl; -} - - -/* Set the backend source location of a decl. */ - -void -gfc_set_decl_location (tree decl, locus * loc) -{ - DECL_SOURCE_LOCATION (decl) = gfc_get_location (loc); -} - - -/* Return the backend label declaration for a given label structure, - or create it if it doesn't exist yet. */ - -tree -gfc_get_label_decl (gfc_st_label * lp) -{ - if (lp->backend_decl) - return lp->backend_decl; - else - { - char label_name[GFC_MAX_SYMBOL_LEN + 1]; - tree label_decl; - - /* Validate the label declaration from the front end. */ - gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE); - - /* Build a mangled name for the label. */ - sprintf (label_name, "__label_%.6d", lp->value); - - /* Build the LABEL_DECL node. */ - label_decl = gfc_build_label_decl (get_identifier (label_name)); - - /* Tell the debugger where the label came from. */ - if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */ - gfc_set_decl_location (label_decl, &lp->where); - else - DECL_ARTIFICIAL (label_decl) = 1; - - /* Store the label in the label list and return the LABEL_DECL. */ - lp->backend_decl = label_decl; - return label_decl; - } -} - -/* Return the name of an identifier. */ - -static const char * -sym_identifier (gfc_symbol *sym) -{ - if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0) - return "MAIN__"; - else - return sym->name; -} - -/* Convert a gfc_symbol to an identifier of the same name. */ - -static tree -gfc_sym_identifier (gfc_symbol * sym) -{ - return get_identifier (sym_identifier (sym)); -} - -/* Construct mangled name from symbol name. */ - -static const char * -mangled_identifier (gfc_symbol *sym) -{ - gfc_symbol *proc = sym->ns->proc_name; - static char name[3*GFC_MAX_MANGLED_SYMBOL_LEN + 14]; - /* Prevent the mangling of identifiers that have an assigned - binding label (mainly those that are bind(c)). */ - - if (sym->attr.is_bind_c == 1 && sym->binding_label) - return sym->binding_label; - - if (!sym->fn_result_spec - || (sym->module && !(proc && proc->attr.flavor == FL_PROCEDURE))) - { - if (sym->module == NULL) - return sym_identifier (sym); - else - snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); - } - else - { - /* This is an entity that is actually local to a module procedure - that appears in the result specification expression. Since - sym->module will be a zero length string, we use ns->proc_name - to provide the module name instead. */ - if (proc && proc->module) - snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s", - proc->module, proc->name, sym->name); - else - snprintf (name, sizeof name, "__%s_PROC_%s", - proc->name, sym->name); - } - - return name; -} - -/* Get mangled identifier, adding the symbol to the global table if - it is not yet already there. */ - -static tree -gfc_sym_mangled_identifier (gfc_symbol * sym) -{ - tree result; - gfc_gsymbol *gsym; - const char *name; - - name = mangled_identifier (sym); - result = get_identifier (name); - - gsym = gfc_find_gsymbol (gfc_gsym_root, name); - if (gsym == NULL) - { - gsym = gfc_get_gsymbol (name, false); - gsym->ns = sym->ns; - gsym->sym_name = sym->name; - } - - return result; -} - -/* Construct mangled function name from symbol name. */ - -static tree -gfc_sym_mangled_function_id (gfc_symbol * sym) -{ - int has_underscore; - char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; - - /* It may be possible to simply use the binding label if it's - provided, and remove the other checks. Then we could use it - for other things if we wished. */ - if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) && - sym->binding_label) - /* use the binding label rather than the mangled name */ - return get_identifier (sym->binding_label); - - if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL - || (sym->module != NULL && (sym->attr.external - || sym->attr.if_source == IFSRC_IFBODY))) - && !sym->attr.module_procedure) - { - /* Main program is mangled into MAIN__. */ - if (sym->attr.is_main_program) - return get_identifier ("MAIN__"); - - /* Intrinsic procedures are never mangled. */ - if (sym->attr.proc == PROC_INTRINSIC) - return get_identifier (sym->name); - - if (flag_underscoring) - { - has_underscore = strchr (sym->name, '_') != 0; - if (flag_second_underscore && has_underscore) - snprintf (name, sizeof name, "%s__", sym->name); - else - snprintf (name, sizeof name, "%s_", sym->name); - return get_identifier (name); - } - else - return get_identifier (sym->name); - } - else - { - snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); - return get_identifier (name); - } -} - - -void -gfc_set_decl_assembler_name (tree decl, tree name) -{ - tree target_mangled = targetm.mangle_decl_assembler_name (decl, name); - SET_DECL_ASSEMBLER_NAME (decl, target_mangled); -} - - -/* Returns true if a variable of specified size should go on the stack. */ - -int -gfc_can_put_var_on_stack (tree size) -{ - unsigned HOST_WIDE_INT low; - - if (!INTEGER_CST_P (size)) - return 0; - - if (flag_max_stack_var_size < 0) - return 1; - - if (!tree_fits_uhwi_p (size)) - return 0; - - low = TREE_INT_CST_LOW (size); - if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size) - return 0; - -/* TODO: Set a per-function stack size limit. */ - - return 1; -} - - -/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to - an expression involving its corresponding pointer. There are - 2 cases; one for variable size arrays, and one for everything else, - because variable-sized arrays require one fewer level of - indirection. */ - -static void -gfc_finish_cray_pointee (tree decl, gfc_symbol *sym) -{ - tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer); - tree value; - - /* Parameters need to be dereferenced. */ - if (sym->cp_pointer->attr.dummy) - ptr_decl = build_fold_indirect_ref_loc (input_location, - ptr_decl); - - /* Check to see if we're dealing with a variable-sized array. */ - if (sym->attr.dimension - && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) - { - /* These decls will be dereferenced later, so we don't dereference - them here. */ - value = convert (TREE_TYPE (decl), ptr_decl); - } - else - { - ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)), - ptr_decl); - value = build_fold_indirect_ref_loc (input_location, - ptr_decl); - } - - SET_DECL_VALUE_EXPR (decl, value); - DECL_HAS_VALUE_EXPR_P (decl) = 1; - GFC_DECL_CRAY_POINTEE (decl) = 1; -} - - -/* Finish processing of a declaration without an initial value. */ - -static void -gfc_finish_decl (tree decl) -{ - gcc_assert (TREE_CODE (decl) == PARM_DECL - || DECL_INITIAL (decl) == NULL_TREE); - - if (!VAR_P (decl)) - return; - - if (DECL_SIZE (decl) == NULL_TREE - && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) - layout_decl (decl, 0); - - /* A few consistency checks. */ - /* A static variable with an incomplete type is an error if it is - initialized. Also if it is not file scope. Otherwise, let it - through, but if it is not `extern' then it may cause an error - message later. */ - /* An automatic variable with an incomplete type is an error. */ - - /* We should know the storage size. */ - gcc_assert (DECL_SIZE (decl) != NULL_TREE - || (TREE_STATIC (decl) - ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl)) - : DECL_EXTERNAL (decl))); - - /* The storage size should be constant. */ - gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl)) - || !DECL_SIZE (decl) - || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST); -} - - -/* Handle setting of GFC_DECL_SCALAR* on DECL. */ - -void -gfc_finish_decl_attrs (tree decl, symbol_attribute *attr) -{ - if (!attr->dimension && !attr->codimension) - { - /* Handle scalar allocatable variables. */ - if (attr->allocatable) - { - gfc_allocate_lang_decl (decl); - GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1; - } - /* Handle scalar pointer variables. */ - if (attr->pointer) - { - gfc_allocate_lang_decl (decl); - GFC_DECL_SCALAR_POINTER (decl) = 1; - } - if (attr->target) - { - gfc_allocate_lang_decl (decl); - GFC_DECL_SCALAR_TARGET (decl) = 1; - } - } -} - - -/* Apply symbol attributes to a variable, and add it to the function scope. */ - -static void -gfc_finish_var_decl (tree decl, gfc_symbol * sym) -{ - tree new_type; - - /* Set DECL_VALUE_EXPR for Cray Pointees. */ - if (sym->attr.cray_pointee) - gfc_finish_cray_pointee (decl, sym); - - /* TREE_ADDRESSABLE means the address of this variable is actually needed. - This is the equivalent of the TARGET variables. - We also need to set this if the variable is passed by reference in a - CALL statement. */ - if (sym->attr.target) - TREE_ADDRESSABLE (decl) = 1; - - /* If it wasn't used we wouldn't be getting it. */ - TREE_USED (decl) = 1; - - if (sym->attr.flavor == FL_PARAMETER - && (sym->attr.dimension || sym->ts.type == BT_DERIVED)) - TREE_READONLY (decl) = 1; - - /* Chain this decl to the pending declarations. Don't do pushdecl() - because this would add them to the current scope rather than the - function scope. */ - if (current_function_decl != NULL_TREE) - { - if (sym->ns->proc_name - && (sym->ns->proc_name->backend_decl == current_function_decl - || sym->result == sym)) - gfc_add_decl_to_function (decl); - else if (sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_LABEL) - /* This is a BLOCK construct. */ - add_decl_as_local (decl); - else - gfc_add_decl_to_parent_function (decl); - } - - if (sym->attr.cray_pointee) - return; - - if(sym->attr.is_bind_c == 1 && sym->binding_label) - { - /* We need to put variables that are bind(c) into the common - segment of the object file, because this is what C would do. - gfortran would typically put them in either the BSS or - initialized data segments, and only mark them as common if - they were part of common blocks. However, if they are not put - into common space, then C cannot initialize global Fortran - variables that it interoperates with and the draft says that - either Fortran or C should be able to initialize it (but not - both, of course.) (J3/04-007, section 15.3). */ - TREE_PUBLIC(decl) = 1; - DECL_COMMON(decl) = 1; - if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) - { - DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; - DECL_VISIBILITY_SPECIFIED (decl) = true; - } - } - - /* If a variable is USE associated, it's always external. */ - if (sym->attr.use_assoc || sym->attr.used_in_submodule) - { - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - } - else if (sym->fn_result_spec && !sym->ns->proc_name->module) - { - - if (sym->ns->proc_name->attr.if_source != IFSRC_DECL) - DECL_EXTERNAL (decl) = 1; - else - TREE_STATIC (decl) = 1; - - TREE_PUBLIC (decl) = 1; - } - else if (sym->module && !sym->attr.result && !sym->attr.dummy) - { - /* TODO: Don't set sym->module for result or dummy variables. */ - gcc_assert (current_function_decl == NULL_TREE || sym->result == sym); - - TREE_PUBLIC (decl) = 1; - TREE_STATIC (decl) = 1; - if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) - { - DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; - DECL_VISIBILITY_SPECIFIED (decl) = true; - } - } - - /* Derived types are a bit peculiar because of the possibility of - a default initializer; this must be applied each time the variable - comes into scope it therefore need not be static. These variables - are SAVE_NONE but have an initializer. Otherwise explicitly - initialized variables are SAVE_IMPLICIT and explicitly saved are - SAVE_EXPLICIT. */ - if (!sym->attr.use_assoc - && (sym->attr.save != SAVE_NONE || sym->attr.data - || (sym->value && sym->ns->proc_name->attr.is_main_program) - || (flag_coarray == GFC_FCOARRAY_LIB - && sym->attr.codimension && !sym->attr.allocatable))) - TREE_STATIC (decl) = 1; - - /* If derived-type variables with DTIO procedures are not made static - some bits of code referencing them get optimized away. - TODO Understand why this is so and fix it. */ - if (!sym->attr.use_assoc - && ((sym->ts.type == BT_DERIVED - && sym->ts.u.derived->attr.has_dtio_procs) - || (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs))) - TREE_STATIC (decl) = 1; - - /* Treat asynchronous variables the same as volatile, for now. */ - if (sym->attr.volatile_ || sym->attr.asynchronous) - { - TREE_THIS_VOLATILE (decl) = 1; - TREE_SIDE_EFFECTS (decl) = 1; - new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); - TREE_TYPE (decl) = new_type; - } - - /* Keep variables larger than max-stack-var-size off stack. */ - if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive) - && !sym->attr.automatic - && sym->attr.save != SAVE_EXPLICIT - && sym->attr.save != SAVE_IMPLICIT - && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) - && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) - /* Put variable length auto array pointers always into stack. */ - && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE - || sym->attr.dimension == 0 - || sym->as->type != AS_EXPLICIT - || sym->attr.pointer - || sym->attr.allocatable) - && !DECL_ARTIFICIAL (decl)) - { - if (flag_max_stack_var_size > 0 - && !(sym->ns->proc_name - && sym->ns->proc_name->attr.is_main_program)) - gfc_warning (OPT_Wsurprising, - "Array %qs at %L is larger than limit set by " - "%<-fmax-stack-var-size=%>, moved from stack to static " - "storage. This makes the procedure unsafe when called " - "recursively, or concurrently from multiple threads. " - "Consider increasing the %<-fmax-stack-var-size=%> " - "limit (or use %<-frecursive%>, which implies " - "unlimited %<-fmax-stack-var-size%>) - or change the " - "code to use an ALLOCATABLE array. If the variable is " - "never accessed concurrently, this warning can be " - "ignored, and the variable could also be declared with " - "the SAVE attribute.", - sym->name, &sym->declared_at); - - TREE_STATIC (decl) = 1; - - /* Because the size of this variable isn't known until now, we may have - greedily added an initializer to this variable (in build_init_assign) - even though the max-stack-var-size indicates the variable should be - static. Therefore we rip out the automatic initializer here and - replace it with a static one. */ - gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name); - gfc_code *prev = NULL; - gfc_code *code = sym->ns->code; - while (code && code->op == EXEC_INIT_ASSIGN) - { - /* Look for an initializer meant for this symbol. */ - if (code->expr1->symtree == st) - { - if (prev) - prev->next = code->next; - else - sym->ns->code = code->next; - - break; - } - - prev = code; - code = code->next; - } - if (code && code->op == EXEC_INIT_ASSIGN) - { - /* Keep the init expression for a static initializer. */ - sym->value = code->expr2; - /* Cleanup the defunct code object, without freeing the init expr. */ - code->expr2 = NULL; - gfc_free_statement (code); - free (code); - } - } - - /* Handle threadprivate variables. */ - if (sym->attr.threadprivate - && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) - set_decl_tls_model (decl, decl_default_tls_model (decl)); - - gfc_finish_decl_attrs (decl, &sym->attr); -} - - -/* Allocate the lang-specific part of a decl. */ - -void -gfc_allocate_lang_decl (tree decl) -{ - if (DECL_LANG_SPECIFIC (decl) == NULL) - DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc (); -} - -/* Remember a symbol to generate initialization/cleanup code at function - entry/exit. */ - -static void -gfc_defer_symbol_init (gfc_symbol * sym) -{ - gfc_symbol *p; - gfc_symbol *last; - gfc_symbol *head; - - /* Don't add a symbol twice. */ - if (sym->tlink) - return; - - last = head = sym->ns->proc_name; - p = last->tlink; - - /* Make sure that setup code for dummy variables which are used in the - setup of other variables is generated first. */ - if (sym->attr.dummy) - { - /* Find the first dummy arg seen after us, or the first non-dummy arg. - This is a circular list, so don't go past the head. */ - while (p != head - && (!p->attr.dummy || p->dummy_order > sym->dummy_order)) - { - last = p; - p = p->tlink; - } - } - /* Insert in between last and p. */ - last->tlink = sym; - sym->tlink = p; -} - - -/* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the - backend_decl for a module symbol, if it all ready exists. If the - module gsymbol does not exist, it is created. If the symbol does - not exist, it is added to the gsymbol namespace. Returns true if - an existing backend_decl is found. */ - -bool -gfc_get_module_backend_decl (gfc_symbol *sym) -{ - gfc_gsymbol *gsym; - gfc_symbol *s; - gfc_symtree *st; - - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); - - if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE)) - { - st = NULL; - s = NULL; - - /* Check for a symbol with the same name. */ - if (gsym) - gfc_find_symbol (sym->name, gsym->ns, 0, &s); - - if (!s) - { - if (!gsym) - { - gsym = gfc_get_gsymbol (sym->module, false); - gsym->type = GSYM_MODULE; - gsym->ns = gfc_get_namespace (NULL, 0); - } - - st = gfc_new_symtree (&gsym->ns->sym_root, sym->name); - st->n.sym = sym; - sym->refs++; - } - else if (gfc_fl_struct (sym->attr.flavor)) - { - if (s && s->attr.flavor == FL_PROCEDURE) - { - gfc_interface *intr; - gcc_assert (s->attr.generic); - for (intr = s->generic; intr; intr = intr->next) - if (gfc_fl_struct (intr->sym->attr.flavor)) - { - s = intr->sym; - break; - } - } - - /* Normally we can assume that s is a derived-type symbol since it - shares a name with the derived-type sym. However if sym is a - STRUCTURE, it may in fact share a name with any other basic type - variable. If s is in fact of derived type then we can continue - looking for a duplicate type declaration. */ - if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED) - { - s = s->ts.u.derived; - } - - if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl) - { - if (s->attr.flavor == FL_UNION) - s->backend_decl = gfc_get_union_type (s); - else - s->backend_decl = gfc_get_derived_type (s); - } - gfc_copy_dt_decls_ifequal (s, sym, true); - return true; - } - else if (s->backend_decl) - { - if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) - gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, - true); - else if (sym->ts.type == BT_CHARACTER) - sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; - sym->backend_decl = s->backend_decl; - return true; - } - } - return false; -} - - -/* Create an array index type variable with function scope. */ - -static tree -create_index_var (const char * pfx, int nest) -{ - tree decl; - - decl = gfc_create_var_np (gfc_array_index_type, pfx); - if (nest) - gfc_add_decl_to_parent_function (decl); - else - gfc_add_decl_to_function (decl); - return decl; -} - - -/* Create variables to hold all the non-constant bits of info for a - descriptorless array. Remember these in the lang-specific part of the - type. */ - -static void -gfc_build_qualified_array (tree decl, gfc_symbol * sym) -{ - tree type; - int dim; - int nest; - gfc_namespace* procns; - symbol_attribute *array_attr; - gfc_array_spec *as; - bool is_classarray = IS_CLASS_ARRAY (sym); - - type = TREE_TYPE (decl); - array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; - as = is_classarray ? CLASS_DATA (sym)->as : sym->as; - - /* We just use the descriptor, if there is one. */ - if (GFC_DESCRIPTOR_TYPE_P (type)) - return; - - gcc_assert (GFC_ARRAY_TYPE_P (type)); - procns = gfc_find_proc_namespace (sym->ns); - nest = (procns->proc_name->backend_decl != current_function_decl) - && !sym->attr.contained; - - if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB - && as->type != AS_ASSUMED_SHAPE - && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE) - { - tree token; - tree token_type = build_qualified_type (pvoid_type_node, - TYPE_QUAL_RESTRICT); - - if (sym->module && (sym->attr.use_assoc - || sym->ns->proc_name->attr.flavor == FL_MODULE)) - { - tree token_name - = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"), - IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym)))); - token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name, - token_type); - if (sym->attr.use_assoc) - DECL_EXTERNAL (token) = 1; - else - TREE_STATIC (token) = 1; - - TREE_PUBLIC (token) = 1; - - if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) - { - DECL_VISIBILITY (token) = VISIBILITY_HIDDEN; - DECL_VISIBILITY_SPECIFIED (token) = true; - } - } - else - { - token = gfc_create_var_np (token_type, "caf_token"); - TREE_STATIC (token) = 1; - } - - GFC_TYPE_ARRAY_CAF_TOKEN (type) = token; - DECL_ARTIFICIAL (token) = 1; - DECL_NONALIASED (token) = 1; - - if (sym->module && !sym->attr.use_assoc) - { - pushdecl (token); - DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl; - gfc_module_add_decl (cur_module, token); - } - else if (sym->attr.host_assoc - && TREE_CODE (DECL_CONTEXT (current_function_decl)) - != TRANSLATION_UNIT_DECL) - gfc_add_decl_to_parent_function (token); - else - gfc_add_decl_to_function (token); - } - - for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) - { - if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) - { - GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); - suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); - } - /* Don't try to use the unknown bound for assumed shape arrays. */ - if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE - && (as->type != AS_ASSUMED_SIZE - || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) - { - GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); - suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); - } - - if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE) - { - GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest); - suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim)); - } - } - for (dim = GFC_TYPE_ARRAY_RANK (type); - dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++) - { - if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) - { - GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); - suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); - } - /* Don't try to use the unknown ubound for the last coarray dimension. */ - if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE - && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1) - { - GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); - suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); - } - } - if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE) - { - GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type, - "offset"); - suppress_warning (GFC_TYPE_ARRAY_OFFSET (type)); - - if (nest) - gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type)); - else - gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type)); - } - - if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE - && as->type != AS_ASSUMED_SIZE) - { - GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest); - suppress_warning (GFC_TYPE_ARRAY_SIZE (type)); - } - - if (POINTER_TYPE_P (type)) - { - gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type))); - gcc_assert (TYPE_LANG_SPECIFIC (type) - == TYPE_LANG_SPECIFIC (TREE_TYPE (type))); - type = TREE_TYPE (type); - } - - if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type)) - { - tree size, range; - - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node); - range = build_range_type (gfc_array_index_type, gfc_index_zero_node, - size); - TYPE_DOMAIN (type) = range; - layout_type (type); - } - - if (TYPE_NAME (type) != NULL_TREE && as->rank > 0 - && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE - && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1))) - { - tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type)); - - for (dim = 0; dim < as->rank - 1; dim++) - { - gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); - gtype = TREE_TYPE (gtype); - } - gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); - if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL) - TYPE_NAME (type) = NULL_TREE; - } - - if (TYPE_NAME (type) == NULL_TREE) - { - tree gtype = TREE_TYPE (type), rtype, type_decl; - - for (dim = as->rank - 1; dim >= 0; dim--) - { - tree lbound, ubound; - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - rtype = build_range_type (gfc_array_index_type, lbound, ubound); - gtype = build_array_type (gtype, rtype); - /* Ensure the bound variables aren't optimized out at -O0. - For -O1 and above they often will be optimized out, but - can be tracked by VTA. Also set DECL_NAMELESS, so that - the artificial lbound.N or ubound.N DECL_NAME doesn't - end up in debug info. */ - if (lbound - && VAR_P (lbound) - && DECL_ARTIFICIAL (lbound) - && DECL_IGNORED_P (lbound)) - { - if (DECL_NAME (lbound) - && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)), - "lbound") != 0) - DECL_NAMELESS (lbound) = 1; - DECL_IGNORED_P (lbound) = 0; - } - if (ubound - && VAR_P (ubound) - && DECL_ARTIFICIAL (ubound) - && DECL_IGNORED_P (ubound)) - { - if (DECL_NAME (ubound) - && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)), - "ubound") != 0) - DECL_NAMELESS (ubound) = 1; - DECL_IGNORED_P (ubound) = 0; - } - } - TYPE_NAME (type) = type_decl = build_decl (input_location, - TYPE_DECL, NULL, gtype); - DECL_ORIGINAL_TYPE (type_decl) = gtype; - } -} - - -/* For some dummy arguments we don't use the actual argument directly. - Instead we create a local decl and use that. This allows us to perform - initialization, and construct full type information. */ - -static tree -gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) -{ - tree decl; - tree type; - gfc_array_spec *as; - symbol_attribute *array_attr; - char *name; - gfc_packed packed; - int n; - bool known_size; - bool is_classarray = IS_CLASS_ARRAY (sym); - - /* Use the array as and attr. */ - as = is_classarray ? CLASS_DATA (sym)->as : sym->as; - array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; - - /* The dummy is returned for pointer, allocatable or assumed rank arrays. - For class arrays the information if sym is an allocatable or pointer - object needs to be checked explicitly (IS_CLASS_ARRAY can be false for - too many reasons to be of use here). */ - if ((sym->ts.type != BT_CLASS && sym->attr.pointer) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) - || array_attr->allocatable - || (as && as->type == AS_ASSUMED_RANK)) - return dummy; - - /* Add to list of variables if not a fake result variable. - These symbols are set on the symbol only, not on the class component. */ - if (sym->attr.result || sym->attr.dummy) - gfc_defer_symbol_init (sym); - - /* For a class array the array descriptor is in the _data component, while - for a regular array the TREE_TYPE of the dummy is a pointer to the - descriptor. */ - type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy) - : TREE_TYPE (dummy)); - /* type now is the array descriptor w/o any indirection. */ - gcc_assert (TREE_CODE (dummy) == PARM_DECL - && POINTER_TYPE_P (TREE_TYPE (dummy))); - - /* Do we know the element size? */ - known_size = sym->ts.type != BT_CHARACTER - || INTEGER_CST_P (sym->ts.u.cl->backend_decl); - - if (known_size && !GFC_DESCRIPTOR_TYPE_P (type)) - { - /* For descriptorless arrays with known element size the actual - argument is sufficient. */ - gfc_build_qualified_array (dummy, sym); - return dummy; - } - - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - /* Create a descriptorless array pointer. */ - packed = PACKED_NO; - - /* Even when -frepack-arrays is used, symbols with TARGET attribute - are not repacked. */ - if (!flag_repack_arrays || sym->attr.target) - { - if (as->type == AS_ASSUMED_SIZE) - packed = PACKED_FULL; - } - else - { - if (as->type == AS_EXPLICIT) - { - packed = PACKED_FULL; - for (n = 0; n < as->rank; n++) - { - if (!(as->upper[n] - && as->lower[n] - && as->upper[n]->expr_type == EXPR_CONSTANT - && as->lower[n]->expr_type == EXPR_CONSTANT)) - { - packed = PACKED_PARTIAL; - break; - } - } - } - else - packed = PACKED_PARTIAL; - } - - /* For classarrays the element type is required, but - gfc_typenode_for_spec () returns the array descriptor. */ - type = is_classarray ? gfc_get_element_type (type) - : gfc_typenode_for_spec (&sym->ts); - type = gfc_get_nodesc_array_type (type, as, packed, - !sym->attr.target); - } - else - { - /* We now have an expression for the element size, so create a fully - qualified type. Reset sym->backend decl or this will just return the - old type. */ - DECL_ARTIFICIAL (sym->backend_decl) = 1; - sym->backend_decl = NULL_TREE; - type = gfc_sym_type (sym); - packed = PACKED_FULL; - } - - ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0); - decl = build_decl (input_location, - VAR_DECL, get_identifier (name), type); - - DECL_ARTIFICIAL (decl) = 1; - DECL_NAMELESS (decl) = 1; - TREE_PUBLIC (decl) = 0; - TREE_STATIC (decl) = 0; - DECL_EXTERNAL (decl) = 0; - - /* Avoid uninitialized warnings for optional dummy arguments. */ - if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) - || sym->attr.optional) - suppress_warning (decl); - - /* We should never get deferred shape arrays here. We used to because of - frontend bugs. */ - gcc_assert (as->type != AS_DEFERRED); - - if (packed == PACKED_PARTIAL) - GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1; - else if (packed == PACKED_FULL) - GFC_DECL_PACKED_ARRAY (decl) = 1; - - gfc_build_qualified_array (decl, sym); - - if (DECL_LANG_SPECIFIC (dummy)) - DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy); - else - gfc_allocate_lang_decl (decl); - - GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy; - - if (sym->ns->proc_name->backend_decl == current_function_decl - || sym->attr.contained) - gfc_add_decl_to_function (decl); - else - gfc_add_decl_to_parent_function (decl); - - return decl; -} - -/* Return a constant or a variable to use as a string length. Does not - add the decl to the current scope. */ - -static tree -gfc_create_string_length (gfc_symbol * sym) -{ - gcc_assert (sym->ts.u.cl); - gfc_conv_const_charlen (sym->ts.u.cl); - - if (sym->ts.u.cl->backend_decl == NULL_TREE) - { - tree length; - const char *name; - - /* The string length variable shall be in static memory if it is either - explicitly SAVED, a module variable or with -fno-automatic. Only - relevant is "len=:" - otherwise, it is either a constant length or - it is an automatic variable. */ - bool static_length = sym->attr.save - || sym->ns->proc_name->attr.flavor == FL_MODULE - || (flag_max_stack_var_size == 0 - && sym->ts.deferred && !sym->attr.dummy - && !sym->attr.result && !sym->attr.function); - - /* Also prefix the mangled name. We need to call GFC_PREFIX for static - variables as some systems do not support the "." in the assembler name. - For nonstatic variables, the "." does not appear in assembler. */ - if (static_length) - { - if (sym->module) - name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module, - sym->name); - else - name = gfc_get_string (GFC_PREFIX ("%s"), sym->name); - } - else if (sym->module) - name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name); - else - name = gfc_get_string (".%s", sym->name); - - length = build_decl (input_location, - VAR_DECL, get_identifier (name), - gfc_charlen_type_node); - DECL_ARTIFICIAL (length) = 1; - TREE_USED (length) = 1; - if (sym->ns->proc_name->tlink != NULL) - gfc_defer_symbol_init (sym); - - sym->ts.u.cl->backend_decl = length; - - if (static_length) - TREE_STATIC (length) = 1; - - if (sym->ns->proc_name->attr.flavor == FL_MODULE - && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)) - TREE_PUBLIC (length) = 1; - } - - gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE); - return sym->ts.u.cl->backend_decl; -} - -/* If a variable is assigned a label, we add another two auxiliary - variables. */ - -static void -gfc_add_assign_aux_vars (gfc_symbol * sym) -{ - tree addr; - tree length; - tree decl; - - gcc_assert (sym->backend_decl); - - decl = sym->backend_decl; - gfc_allocate_lang_decl (decl); - GFC_DECL_ASSIGN (decl) = 1; - length = build_decl (input_location, - VAR_DECL, create_tmp_var_name (sym->name), - gfc_charlen_type_node); - addr = build_decl (input_location, - VAR_DECL, create_tmp_var_name (sym->name), - pvoid_type_node); - gfc_finish_var_decl (length, sym); - gfc_finish_var_decl (addr, sym); - /* STRING_LENGTH is also used as flag. Less than -1 means that - ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the - target label's address. Otherwise, value is the length of a format string - and ASSIGN_ADDR is its address. */ - if (TREE_STATIC (length)) - DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2); - else - gfc_defer_symbol_init (sym); - - GFC_DECL_STRING_LEN (decl) = length; - GFC_DECL_ASSIGN_ADDR (decl) = addr; -} - - -static tree -add_attributes_to_decl (symbol_attribute sym_attr, tree list) -{ - unsigned id; - tree attr; - - for (id = 0; id < EXT_ATTR_NUM; id++) - if (sym_attr.ext_attr & (1 << id) && ext_attr_list[id].middle_end_name) - { - attr = build_tree_list ( - get_identifier (ext_attr_list[id].middle_end_name), - NULL_TREE); - list = chainon (list, attr); - } - - tree clauses = NULL_TREE; - - if (sym_attr.oacc_routine_lop != OACC_ROUTINE_LOP_NONE) - { - omp_clause_code code; - switch (sym_attr.oacc_routine_lop) - { - case OACC_ROUTINE_LOP_GANG: - code = OMP_CLAUSE_GANG; - break; - case OACC_ROUTINE_LOP_WORKER: - code = OMP_CLAUSE_WORKER; - break; - case OACC_ROUTINE_LOP_VECTOR: - code = OMP_CLAUSE_VECTOR; - break; - case OACC_ROUTINE_LOP_SEQ: - code = OMP_CLAUSE_SEQ; - break; - case OACC_ROUTINE_LOP_NONE: - case OACC_ROUTINE_LOP_ERROR: - default: - gcc_unreachable (); - } - tree c = build_omp_clause (UNKNOWN_LOCATION, code); - OMP_CLAUSE_CHAIN (c) = clauses; - clauses = c; - - tree dims = oacc_build_routine_dims (clauses); - list = oacc_replace_fn_attrib_attr (list, dims); - } - - if (sym_attr.oacc_routine_nohost) - { - tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_NOHOST); - OMP_CLAUSE_CHAIN (c) = clauses; - clauses = c; - } - - if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) - { - tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); - switch (sym_attr.omp_device_type) - { - case OMP_DEVICE_TYPE_HOST: - OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST; - break; - case OMP_DEVICE_TYPE_NOHOST: - OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST; - break; - case OMP_DEVICE_TYPE_ANY: - OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY; - break; - default: - gcc_unreachable (); - } - OMP_CLAUSE_CHAIN (c) = clauses; - clauses = c; - } - - if (sym_attr.omp_declare_target_link - || sym_attr.oacc_declare_link) - list = tree_cons (get_identifier ("omp declare target link"), - clauses, list); - else if (sym_attr.omp_declare_target - || sym_attr.oacc_declare_create - || sym_attr.oacc_declare_copyin - || sym_attr.oacc_declare_deviceptr - || sym_attr.oacc_declare_device_resident) - list = tree_cons (get_identifier ("omp declare target"), - clauses, list); - - return list; -} - - -static void build_function_decl (gfc_symbol * sym, bool global); - - -/* Return the decl for a gfc_symbol, create it if it doesn't already - exist. */ - -tree -gfc_get_symbol_decl (gfc_symbol * sym) -{ - tree decl; - tree length = NULL_TREE; - tree attributes; - int byref; - bool intrinsic_array_parameter = false; - bool fun_or_res; - - gcc_assert (sym->attr.referenced - || sym->attr.flavor == FL_PROCEDURE - || sym->attr.use_assoc - || sym->attr.used_in_submodule - || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY - || (sym->module && sym->attr.if_source != IFSRC_DECL - && sym->backend_decl)); - - if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c - && is_CFI_desc (sym, NULL)) - { - gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER - || sym->ts.u.cl->backend_decl)); - return sym->backend_decl; - } - - if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function) - byref = gfc_return_by_reference (sym->ns->proc_name); - else - byref = 0; - - /* Make sure that the vtab for the declared type is completed. */ - if (sym->ts.type == BT_CLASS) - { - gfc_component *c = CLASS_DATA (sym); - if (!c->ts.u.derived->backend_decl) - { - gfc_find_derived_vtab (c->ts.u.derived); - gfc_get_derived_type (sym->ts.u.derived); - } - } - - /* PDT parameterized array components and string_lengths must have the - 'len' parameters substituted for the expressions appearing in the - declaration of the entity and memory allocated/deallocated. */ - if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) - && sym->param_list != NULL - && gfc_current_ns == sym->ns - && !(sym->attr.use_assoc || sym->attr.dummy)) - gfc_defer_symbol_init (sym); - - /* Dummy PDT 'len' parameters should be checked when they are explicit. */ - if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) - && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - && sym->param_list != NULL - && sym->attr.dummy) - gfc_defer_symbol_init (sym); - - /* All deferred character length procedures need to retain the backend - decl, which is a pointer to the character length in the caller's - namespace and to declare a local character length. */ - if (!byref && sym->attr.function - && sym->ts.type == BT_CHARACTER - && sym->ts.deferred - && sym->ts.u.cl->passed_length == NULL - && sym->ts.u.cl->backend_decl - && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) - { - sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; - gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))); - sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); - } - - fun_or_res = byref && (sym->attr.result - || (sym->attr.function && sym->ts.deferred)); - if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res) - { - /* Return via extra parameter. */ - if (sym->attr.result && byref - && !sym->backend_decl) - { - sym->backend_decl = - DECL_ARGUMENTS (sym->ns->proc_name->backend_decl); - /* For entry master function skip over the __entry - argument. */ - if (sym->ns->proc_name->attr.entry_master) - sym->backend_decl = DECL_CHAIN (sym->backend_decl); - } - - /* Dummy variables should already have been created. */ - gcc_assert (sym->backend_decl); - - /* However, the string length of deferred arrays must be set. */ - if (sym->ts.type == BT_CHARACTER - && sym->ts.deferred - && sym->attr.dimension - && sym->attr.allocatable) - gfc_defer_symbol_init (sym); - - if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) - GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; - - /* Create a character length variable. */ - if (sym->ts.type == BT_CHARACTER) - { - /* For a deferred dummy, make a new string length variable. */ - if (sym->ts.deferred - && - (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl)) - sym->ts.u.cl->backend_decl = NULL_TREE; - - if (sym->ts.deferred && byref) - { - /* The string length of a deferred char array is stored in the - parameter at sym->ts.u.cl->backend_decl as a reference and - marked as a result. Exempt this variable from generating a - temporary for it. */ - if (sym->attr.result) - { - /* We need to insert a indirect ref for param decls. */ - if (sym->ts.u.cl->backend_decl - && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) - { - sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; - sym->ts.u.cl->backend_decl = - build_fold_indirect_ref (sym->ts.u.cl->backend_decl); - } - } - /* For all other parameters make sure, that they are copied so - that the value and any modifications are local to the routine - by generating a temporary variable. */ - else if (sym->attr.function - && sym->ts.u.cl->passed_length == NULL - && sym->ts.u.cl->backend_decl) - { - sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; - if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))) - sym->ts.u.cl->backend_decl - = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); - else - sym->ts.u.cl->backend_decl = NULL_TREE; - } - } - - if (sym->ts.u.cl->backend_decl == NULL_TREE) - length = gfc_create_string_length (sym); - else - length = sym->ts.u.cl->backend_decl; - if (VAR_P (length) && DECL_FILE_SCOPE_P (length)) - { - /* Add the string length to the same context as the symbol. */ - if (DECL_CONTEXT (length) == NULL_TREE) - { - if (sym->backend_decl == current_function_decl - || (DECL_CONTEXT (sym->backend_decl) - == current_function_decl)) - gfc_add_decl_to_function (length); - else - gfc_add_decl_to_parent_function (length); - } - - gcc_assert (sym->backend_decl == current_function_decl - ? DECL_CONTEXT (length) == current_function_decl - : (DECL_CONTEXT (sym->backend_decl) - == DECL_CONTEXT (length))); - - gfc_defer_symbol_init (sym); - } - } - - /* Use a copy of the descriptor for dummy arrays. */ - if ((sym->attr.dimension || sym->attr.codimension) - && !TREE_USED (sym->backend_decl)) - { - decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); - /* Prevent the dummy from being detected as unused if it is copied. */ - if (sym->backend_decl != NULL && decl != sym->backend_decl) - DECL_ARTIFICIAL (sym->backend_decl) = 1; - sym->backend_decl = decl; - } - - /* Returning the descriptor for dummy class arrays is hazardous, because - some caller is expecting an expression to apply the component refs to. - Therefore the descriptor is only created and stored in - sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then - responsible to extract it from there, when the descriptor is - desired. */ - if (IS_CLASS_ARRAY (sym) - && (!DECL_LANG_SPECIFIC (sym->backend_decl) - || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) - { - decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); - /* Prevent the dummy from being detected as unused if it is copied. */ - if (sym->backend_decl != NULL && decl != sym->backend_decl) - DECL_ARTIFICIAL (sym->backend_decl) = 1; - sym->backend_decl = decl; - } - - TREE_USED (sym->backend_decl) = 1; - if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) - gfc_add_assign_aux_vars (sym); - - if (sym->ts.type == BT_CLASS && sym->backend_decl) - GFC_DECL_CLASS(sym->backend_decl) = 1; - - return sym->backend_decl; - } - - if (sym->result == sym && sym->attr.assign - && GFC_DECL_ASSIGN (sym->backend_decl) == 0) - gfc_add_assign_aux_vars (sym); - - if (sym->backend_decl) - return sym->backend_decl; - - /* Special case for array-valued named constants from intrinsic - procedures; those are inlined. */ - if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER - && (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV - || sym->from_intmod == INTMOD_ISO_C_BINDING)) - intrinsic_array_parameter = true; - - /* If use associated compilation, use the module - declaration. */ - if ((sym->attr.flavor == FL_VARIABLE - || sym->attr.flavor == FL_PARAMETER) - && (sym->attr.use_assoc || sym->attr.used_in_submodule) - && !intrinsic_array_parameter - && sym->module - && gfc_get_module_backend_decl (sym)) - { - if (sym->ts.type == BT_CLASS && sym->backend_decl) - GFC_DECL_CLASS(sym->backend_decl) = 1; - return sym->backend_decl; - } - - if (sym->attr.flavor == FL_PROCEDURE) - { - /* Catch functions. Only used for actual parameters, - procedure pointers and procptr initialization targets. */ - if (sym->attr.use_assoc - || sym->attr.used_in_submodule - || sym->attr.intrinsic - || sym->attr.if_source != IFSRC_DECL) - { - decl = gfc_get_extern_function_decl (sym); - } - else - { - if (!sym->backend_decl) - build_function_decl (sym, false); - decl = sym->backend_decl; - } - return decl; - } - - if (sym->attr.intrinsic) - gfc_internal_error ("intrinsic variable which isn't a procedure"); - - /* Create string length decl first so that they can be used in the - type declaration. For associate names, the target character - length is used. Set 'length' to a constant so that if the - string length is a variable, it is not finished a second time. */ - if (sym->ts.type == BT_CHARACTER) - { - if (sym->attr.associate_var - && sym->ts.deferred - && sym->assoc && sym->assoc->target - && ((sym->assoc->target->expr_type == EXPR_VARIABLE - && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER) - || sym->assoc->target->expr_type != EXPR_VARIABLE)) - sym->ts.u.cl->backend_decl = NULL_TREE; - - if (sym->attr.associate_var - && sym->ts.u.cl->backend_decl - && (VAR_P (sym->ts.u.cl->backend_decl) - || TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)) - length = gfc_index_zero_node; - else - length = gfc_create_string_length (sym); - } - - /* Create the decl for the variable. */ - decl = build_decl (gfc_get_location (&sym->declared_at), - VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym)); - - /* Add attributes to variables. Functions are handled elsewhere. */ - attributes = add_attributes_to_decl (sym->attr, NULL_TREE); - decl_attributes (&decl, attributes, 0); - - /* Symbols from modules should have their assembler names mangled. - This is done here rather than in gfc_finish_var_decl because it - is different for string length variables. */ - if (sym->module || sym->fn_result_spec) - { - gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); - if (sym->attr.use_assoc && !intrinsic_array_parameter) - DECL_IGNORED_P (decl) = 1; - } - - if (sym->attr.select_type_temporary) - { - DECL_ARTIFICIAL (decl) = 1; - DECL_IGNORED_P (decl) = 1; - } - - if (sym->attr.dimension || sym->attr.codimension) - { - /* Create variables to hold the non-constant bits of array info. */ - gfc_build_qualified_array (decl, sym); - - if (sym->attr.contiguous - || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)) - GFC_DECL_PACKED_ARRAY (decl) = 1; - } - - /* Remember this variable for allocation/cleanup. */ - if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension - || (sym->ts.type == BT_CLASS && - (CLASS_DATA (sym)->attr.dimension - || CLASS_DATA (sym)->attr.allocatable)) - || (sym->ts.type == BT_DERIVED - && (sym->ts.u.derived->attr.alloc_comp - || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save - && !sym->ns->proc_name->attr.is_main_program - && gfc_is_finalizable (sym->ts.u.derived, NULL)))) - /* This applies a derived type default initializer. */ - || (sym->ts.type == BT_DERIVED - && sym->attr.save == SAVE_NONE - && !sym->attr.data - && !sym->attr.allocatable - && (sym->value && !sym->ns->proc_name->attr.is_main_program) - && !(sym->attr.use_assoc && !intrinsic_array_parameter))) - gfc_defer_symbol_init (sym); - - if (sym->ts.type == BT_CHARACTER - && sym->attr.allocatable - && !sym->attr.dimension - && sym->ts.u.cl && sym->ts.u.cl->length - && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE) - gfc_defer_symbol_init (sym); - - /* Associate names can use the hidden string length variable - of their associated target. */ - if (sym->ts.type == BT_CHARACTER - && TREE_CODE (length) != INTEGER_CST - && TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF) - { - length = fold_convert (gfc_charlen_type_node, length); - gfc_finish_var_decl (length, sym); - if (!sym->attr.associate_var - && TREE_CODE (length) == VAR_DECL - && sym->value && sym->value->expr_type != EXPR_NULL - && sym->value->ts.u.cl->length) - { - gfc_expr *len = sym->value->ts.u.cl->length; - DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts, - TREE_TYPE (length), - false, false, false); - DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node, - DECL_INITIAL (length)); - } - else - gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL); - } - - gfc_finish_var_decl (decl, sym); - - if (sym->ts.type == BT_CHARACTER) - /* Character variables need special handling. */ - gfc_allocate_lang_decl (decl); - - if (sym->assoc && sym->attr.subref_array_pointer) - sym->attr.pointer = 1; - - if (sym->attr.pointer && sym->attr.dimension - && !sym->ts.deferred - && !(sym->attr.select_type_temporary - && !sym->attr.subref_array_pointer)) - GFC_DECL_PTR_ARRAY_P (decl) = 1; - - if (sym->ts.type == BT_CLASS) - GFC_DECL_CLASS(decl) = 1; - - sym->backend_decl = decl; - - if (sym->attr.assign) - gfc_add_assign_aux_vars (sym); - - if (intrinsic_array_parameter) - { - TREE_STATIC (decl) = 1; - DECL_EXTERNAL (decl) = 0; - } - - if (TREE_STATIC (decl) - && !(sym->attr.use_assoc && !intrinsic_array_parameter) - && (sym->attr.save || sym->ns->proc_name->attr.is_main_program - || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) - || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE) - && (flag_coarray != GFC_FCOARRAY_LIB - || !sym->attr.codimension || sym->attr.allocatable) - && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) - && !(sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)) - { - /* Add static initializer. For procedures, it is only needed if - SAVE is specified otherwise they need to be reinitialized - every time the procedure is entered. The TREE_STATIC is - in this case due to -fmax-stack-var-size=. */ - - DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, - TREE_TYPE (decl), sym->attr.dimension - || (sym->attr.codimension - && sym->attr.allocatable), - sym->attr.pointer || sym->attr.allocatable - || sym->ts.type == BT_CLASS, - sym->attr.proc_pointer); - } - - if (!TREE_STATIC (decl) - && POINTER_TYPE_P (TREE_TYPE (decl)) - && !sym->attr.pointer - && !sym->attr.allocatable - && !sym->attr.proc_pointer - && !sym->attr.select_type_temporary) - DECL_BY_REFERENCE (decl) = 1; - - if (sym->attr.associate_var) - GFC_DECL_ASSOCIATE_VAR_P (decl) = 1; - - /* We only longer mark __def_init as read-only if it actually has an - initializer, it does not needlessly take up space in the - read-only section and can go into the BSS instead, see PR 84487. - Marking this as artificial means that OpenMP will treat this as - predetermined shared. */ - - bool def_init = startswith (sym->name, "__def_init"); - - if (sym->attr.vtab || def_init) - { - DECL_ARTIFICIAL (decl) = 1; - if (def_init && sym->value) - TREE_READONLY (decl) = 1; - } - - return decl; -} - - -/* Substitute a temporary variable in place of the real one. */ - -void -gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save) -{ - save->attr = sym->attr; - save->decl = sym->backend_decl; - - gfc_clear_attr (&sym->attr); - sym->attr.referenced = 1; - sym->attr.flavor = FL_VARIABLE; - - sym->backend_decl = decl; -} - - -/* Restore the original variable. */ - -void -gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save) -{ - sym->attr = save->attr; - sym->backend_decl = save->decl; -} - - -/* Declare a procedure pointer. */ - -static tree -get_proc_pointer_decl (gfc_symbol *sym) -{ - tree decl; - tree attributes; - - if (sym->module || sym->fn_result_spec) - { - const char *name; - gfc_gsymbol *gsym; - - name = mangled_identifier (sym); - gsym = gfc_find_gsymbol (gfc_gsym_root, name); - if (gsym != NULL) - { - gfc_symbol *s; - gfc_find_symbol (sym->name, gsym->ns, 0, &s); - if (s && s->backend_decl) - return s->backend_decl; - } - } - - decl = sym->backend_decl; - if (decl) - return decl; - - decl = build_decl (input_location, - VAR_DECL, get_identifier (sym->name), - build_pointer_type (gfc_get_function_type (sym))); - - if (sym->module) - { - /* Apply name mangling. */ - gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); - if (sym->attr.use_assoc) - DECL_IGNORED_P (decl) = 1; - } - - if ((sym->ns->proc_name - && sym->ns->proc_name->backend_decl == current_function_decl) - || sym->attr.contained) - gfc_add_decl_to_function (decl); - else if (sym->ns->proc_name->attr.flavor != FL_MODULE) - gfc_add_decl_to_parent_function (decl); - - sym->backend_decl = decl; - - /* If a variable is USE associated, it's always external. */ - if (sym->attr.use_assoc) - { - DECL_EXTERNAL (decl) = 1; - TREE_PUBLIC (decl) = 1; - } - else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE) - { - /* This is the declaration of a module variable. */ - TREE_PUBLIC (decl) = 1; - if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) - { - DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; - DECL_VISIBILITY_SPECIFIED (decl) = true; - } - TREE_STATIC (decl) = 1; - } - - if (!sym->attr.use_assoc - && (sym->attr.save != SAVE_NONE || sym->attr.data - || (sym->value && sym->ns->proc_name->attr.is_main_program))) - TREE_STATIC (decl) = 1; - - if (TREE_STATIC (decl) && sym->value) - { - /* Add static initializer. */ - DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, - TREE_TYPE (decl), - sym->attr.dimension, - false, true); - } - - /* Handle threadprivate procedure pointers. */ - if (sym->attr.threadprivate - && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) - set_decl_tls_model (decl, decl_default_tls_model (decl)); - - attributes = add_attributes_to_decl (sym->attr, NULL_TREE); - decl_attributes (&decl, attributes, 0); - - return decl; -} - - -/* Get a basic decl for an external function. */ - -tree -gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args, - const char *fnspec) -{ - tree type; - tree fndecl; - tree attributes; - gfc_expr e; - gfc_intrinsic_sym *isym; - gfc_expr argexpr; - char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */ - tree name; - tree mangled_name; - gfc_gsymbol *gsym; - - if (sym->backend_decl) - return sym->backend_decl; - - /* We should never be creating external decls for alternate entry points. - The procedure may be an alternate entry point, but we don't want/need - to know that. */ - gcc_assert (!(sym->attr.entry || sym->attr.entry_master)); - - if (sym->attr.proc_pointer) - return get_proc_pointer_decl (sym); - - /* See if this is an external procedure from the same file. If so, - return the backend_decl. If we are looking at a BIND(C) - procedure and the symbol is not BIND(C), or vice versa, we - haven't found the right procedure. */ - - if (sym->binding_label) - { - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label); - if (gsym && !gsym->bind_c) - gsym = NULL; - } - else if (sym->module == NULL) - { - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); - if (gsym && gsym->bind_c) - gsym = NULL; - } - else - { - /* Procedure from a different module. */ - gsym = NULL; - } - - if (gsym && !gsym->defined) - gsym = NULL; - - /* This can happen because of C binding. */ - if (gsym && gsym->ns && gsym->ns->proc_name - && gsym->ns->proc_name->attr.flavor == FL_MODULE) - goto module_sym; - - if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL) - && !sym->backend_decl - && gsym && gsym->ns - && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) - && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic)) - { - if (!gsym->ns->proc_name->backend_decl) - { - /* By construction, the external function cannot be - a contained procedure. */ - locus old_loc; - - gfc_save_backend_locus (&old_loc); - push_cfun (NULL); - - gfc_create_function_decl (gsym->ns, true); - - pop_cfun (); - gfc_restore_backend_locus (&old_loc); - } - - /* If the namespace has entries, the proc_name is the - entry master. Find the entry and use its backend_decl. - otherwise, use the proc_name backend_decl. */ - if (gsym->ns->entries) - { - gfc_entry_list *entry = gsym->ns->entries; - - for (; entry; entry = entry->next) - { - if (strcmp (gsym->name, entry->sym->name) == 0) - { - sym->backend_decl = entry->sym->backend_decl; - break; - } - } - } - else - sym->backend_decl = gsym->ns->proc_name->backend_decl; - - if (sym->backend_decl) - { - /* Avoid problems of double deallocation of the backend declaration - later in gfc_trans_use_stmts; cf. PR 45087. */ - if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc) - sym->attr.use_assoc = 0; - - return sym->backend_decl; - } - } - - /* See if this is a module procedure from the same file. If so, - return the backend_decl. */ - if (sym->module) - gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); - -module_sym: - if (gsym && gsym->ns - && (gsym->type == GSYM_MODULE - || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE))) - { - gfc_symbol *s; - - s = NULL; - if (gsym->type == GSYM_MODULE) - gfc_find_symbol (sym->name, gsym->ns, 0, &s); - else - gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s); - - if (s && s->backend_decl) - { - if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) - gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, - true); - else if (sym->ts.type == BT_CHARACTER) - sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; - sym->backend_decl = s->backend_decl; - return sym->backend_decl; - } - } - - if (sym->attr.intrinsic) - { - /* Call the resolution function to get the actual name. This is - a nasty hack which relies on the resolution functions only looking - at the first argument. We pass NULL for the second argument - otherwise things like AINT get confused. */ - isym = gfc_find_function (sym->name); - gcc_assert (isym->resolve.f0 != NULL); - - memset (&e, 0, sizeof (e)); - e.expr_type = EXPR_FUNCTION; - - memset (&argexpr, 0, sizeof (argexpr)); - gcc_assert (isym->formal); - argexpr.ts = isym->formal->ts; - - if (isym->formal->next == NULL) - isym->resolve.f1 (&e, &argexpr); - else - { - if (isym->formal->next->next == NULL) - isym->resolve.f2 (&e, &argexpr, NULL); - else - { - if (isym->formal->next->next->next == NULL) - isym->resolve.f3 (&e, &argexpr, NULL, NULL); - else - { - /* All specific intrinsics take less than 5 arguments. */ - gcc_assert (isym->formal->next->next->next->next == NULL); - isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); - } - } - } - - if (flag_f2c - && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind) - || e.ts.type == BT_COMPLEX)) - { - /* Specific which needs a different implementation if f2c - calling conventions are used. */ - sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name); - } - else - sprintf (s, "_gfortran_specific%s", e.value.function.name); - - name = get_identifier (s); - mangled_name = name; - } - else - { - name = gfc_sym_identifier (sym); - mangled_name = gfc_sym_mangled_function_id (sym); - } - - type = gfc_get_function_type (sym, actual_args, fnspec); - - fndecl = build_decl (input_location, - FUNCTION_DECL, name, type); - - /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes; - TREE_PUBLIC specifies whether a function is globally addressable (i.e. - the opposite of declaring a function as static in C). */ - DECL_EXTERNAL (fndecl) = 1; - TREE_PUBLIC (fndecl) = 1; - - attributes = add_attributes_to_decl (sym->attr, NULL_TREE); - decl_attributes (&fndecl, attributes, 0); - - gfc_set_decl_assembler_name (fndecl, mangled_name); - - /* Set the context of this decl. */ - if (0 && sym->ns && sym->ns->proc_name) - { - /* TODO: Add external decls to the appropriate scope. */ - DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl; - } - else - { - /* Global declaration, e.g. intrinsic subroutine. */ - DECL_CONTEXT (fndecl) = NULL_TREE; - } - - /* Set attributes for PURE functions. A call to PURE function in the - Fortran 95 sense is both pure and without side effects in the C - sense. */ - if (sym->attr.pure || sym->attr.implicit_pure) - { - if (sym->attr.function && !gfc_return_by_reference (sym)) - DECL_PURE_P (fndecl) = 1; - /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT) - parameters and don't use alternate returns (is this - allowed?). In that case, calls to them are meaningless, and - can be optimized away. See also in build_function_decl(). */ - TREE_SIDE_EFFECTS (fndecl) = 0; - } - - /* Mark non-returning functions. */ - if (sym->attr.noreturn) - TREE_THIS_VOLATILE(fndecl) = 1; - - sym->backend_decl = fndecl; - - if (DECL_CONTEXT (fndecl) == NULL_TREE) - pushdecl_top_level (fndecl); - - if (sym->formal_ns - && sym->formal_ns->proc_name == sym) - { - if (sym->formal_ns->omp_declare_simd) - gfc_trans_omp_declare_simd (sym->formal_ns); - if (flag_openmp) - gfc_trans_omp_declare_variant (sym->formal_ns); - } - - return fndecl; -} - - -/* Create a declaration for a procedure. For external functions (in the C - sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is - a master function with alternate entry points. */ - -static void -build_function_decl (gfc_symbol * sym, bool global) -{ - tree fndecl, type, attributes; - symbol_attribute attr; - tree result_decl; - gfc_formal_arglist *f; - - bool module_procedure = sym->attr.module_procedure - && sym->ns - && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE; - - gcc_assert (!sym->attr.external || module_procedure); - - if (sym->backend_decl) - return; - - /* Set the line and filename. sym->declared_at seems to point to the - last statement for subroutines, but it'll do for now. */ - gfc_set_backend_locus (&sym->declared_at); - - /* Allow only one nesting level. Allow public declarations. */ - gcc_assert (current_function_decl == NULL_TREE - || DECL_FILE_SCOPE_P (current_function_decl) - || (TREE_CODE (DECL_CONTEXT (current_function_decl)) - == NAMESPACE_DECL)); - - type = gfc_get_function_type (sym); - fndecl = build_decl (input_location, - FUNCTION_DECL, gfc_sym_identifier (sym), type); - - attr = sym->attr; - - /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes; - TREE_PUBLIC specifies whether a function is globally addressable (i.e. - the opposite of declaring a function as static in C). */ - DECL_EXTERNAL (fndecl) = 0; - - if (sym->attr.access == ACCESS_UNKNOWN && sym->module - && (sym->ns->default_access == ACCESS_PRIVATE - || (sym->ns->default_access == ACCESS_UNKNOWN - && flag_module_private))) - sym->attr.access = ACCESS_PRIVATE; - - if (!current_function_decl - && !sym->attr.entry_master && !sym->attr.is_main_program - && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label - || sym->attr.public_used)) - TREE_PUBLIC (fndecl) = 1; - - if (sym->attr.referenced || sym->attr.entry_master) - TREE_USED (fndecl) = 1; - - attributes = add_attributes_to_decl (attr, NULL_TREE); - decl_attributes (&fndecl, attributes, 0); - - /* Figure out the return type of the declared function, and build a - RESULT_DECL for it. If this is a subroutine with alternate - returns, build a RESULT_DECL for it. */ - result_decl = NULL_TREE; - /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */ - if (attr.function) - { - if (gfc_return_by_reference (sym)) - type = void_type_node; - else - { - if (sym->result != sym) - result_decl = gfc_sym_identifier (sym->result); - - type = TREE_TYPE (TREE_TYPE (fndecl)); - } - } - else - { - /* Look for alternate return placeholders. */ - int has_alternate_returns = 0; - for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) - { - if (f->sym == NULL) - { - has_alternate_returns = 1; - break; - } - } - - if (has_alternate_returns) - type = integer_type_node; - else - type = void_type_node; - } - - result_decl = build_decl (input_location, - RESULT_DECL, result_decl, type); - DECL_ARTIFICIAL (result_decl) = 1; - DECL_IGNORED_P (result_decl) = 1; - DECL_CONTEXT (result_decl) = fndecl; - DECL_RESULT (fndecl) = result_decl; - - /* Don't call layout_decl for a RESULT_DECL. - layout_decl (result_decl, 0); */ - - /* TREE_STATIC means the function body is defined here. */ - TREE_STATIC (fndecl) = 1; - - /* Set attributes for PURE functions. A call to a PURE function in the - Fortran 95 sense is both pure and without side effects in the C - sense. */ - if (attr.pure || attr.implicit_pure) - { - /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments - including an alternate return. In that case it can also be - marked as PURE. See also in gfc_get_extern_function_decl(). */ - if (attr.function && !gfc_return_by_reference (sym)) - DECL_PURE_P (fndecl) = 1; - TREE_SIDE_EFFECTS (fndecl) = 0; - } - - - /* Layout the function declaration and put it in the binding level - of the current function. */ - - if (global) - pushdecl_top_level (fndecl); - else - pushdecl (fndecl); - - /* Perform name mangling if this is a top level or module procedure. */ - if (current_function_decl == NULL_TREE) - gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym)); - - sym->backend_decl = fndecl; -} - - -/* Create the DECL_ARGUMENTS for a procedure. - NOTE: The arguments added here must match the argument type created by - gfc_get_function_type (). */ - -static void -create_function_arglist (gfc_symbol * sym) -{ - tree fndecl; - gfc_formal_arglist *f; - tree typelist, hidden_typelist; - tree arglist, hidden_arglist; - tree type; - tree parm; - - fndecl = sym->backend_decl; - - /* Build formal argument list. Make sure that their TREE_CONTEXT is - the new FUNCTION_DECL node. */ - arglist = NULL_TREE; - hidden_arglist = NULL_TREE; - typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl)); - - if (sym->attr.entry_master) - { - type = TREE_VALUE (typelist); - parm = build_decl (input_location, - PARM_DECL, get_identifier ("__entry"), type); - - DECL_CONTEXT (parm) = fndecl; - DECL_ARG_TYPE (parm) = type; - TREE_READONLY (parm) = 1; - gfc_finish_decl (parm); - DECL_ARTIFICIAL (parm) = 1; - - arglist = chainon (arglist, parm); - typelist = TREE_CHAIN (typelist); - } - - if (gfc_return_by_reference (sym)) - { - tree type = TREE_VALUE (typelist), length = NULL; - - if (sym->ts.type == BT_CHARACTER) - { - /* Length of character result. */ - tree len_type = TREE_VALUE (TREE_CHAIN (typelist)); - - length = build_decl (input_location, - PARM_DECL, - get_identifier (".__result"), - len_type); - if (POINTER_TYPE_P (len_type)) - { - sym->ts.u.cl->passed_length = length; - TREE_USED (length) = 1; - } - else if (!sym->ts.u.cl->length) - { - sym->ts.u.cl->backend_decl = length; - TREE_USED (length) = 1; - } - gcc_assert (TREE_CODE (length) == PARM_DECL); - DECL_CONTEXT (length) = fndecl; - DECL_ARG_TYPE (length) = len_type; - TREE_READONLY (length) = 1; - DECL_ARTIFICIAL (length) = 1; - gfc_finish_decl (length); - if (sym->ts.u.cl->backend_decl == NULL - || sym->ts.u.cl->backend_decl == length) - { - gfc_symbol *arg; - tree backend_decl; - - if (sym->ts.u.cl->backend_decl == NULL) - { - tree len = build_decl (input_location, - VAR_DECL, - get_identifier ("..__result"), - gfc_charlen_type_node); - DECL_ARTIFICIAL (len) = 1; - TREE_USED (len) = 1; - sym->ts.u.cl->backend_decl = len; - } - - /* Make sure PARM_DECL type doesn't point to incomplete type. */ - arg = sym->result ? sym->result : sym; - backend_decl = arg->backend_decl; - /* Temporary clear it, so that gfc_sym_type creates complete - type. */ - arg->backend_decl = NULL; - type = gfc_sym_type (arg); - arg->backend_decl = backend_decl; - type = build_reference_type (type); - } - } - - parm = build_decl (input_location, - PARM_DECL, get_identifier ("__result"), type); - - DECL_CONTEXT (parm) = fndecl; - DECL_ARG_TYPE (parm) = TREE_VALUE (typelist); - TREE_READONLY (parm) = 1; - DECL_ARTIFICIAL (parm) = 1; - gfc_finish_decl (parm); - - arglist = chainon (arglist, parm); - typelist = TREE_CHAIN (typelist); - - if (sym->ts.type == BT_CHARACTER) - { - gfc_allocate_lang_decl (parm); - arglist = chainon (arglist, length); - typelist = TREE_CHAIN (typelist); - } - } - - hidden_typelist = typelist; - for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) - if (f->sym != NULL) /* Ignore alternate returns. */ - hidden_typelist = TREE_CHAIN (hidden_typelist); - - for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) - { - char name[GFC_MAX_SYMBOL_LEN + 2]; - - /* Ignore alternate returns. */ - if (f->sym == NULL) - continue; - - type = TREE_VALUE (typelist); - - if (f->sym->ts.type == BT_CHARACTER - && (!sym->attr.is_bind_c || sym->attr.entry_master)) - { - tree len_type = TREE_VALUE (hidden_typelist); - tree length = NULL_TREE; - if (!f->sym->ts.deferred) - gcc_assert (len_type == gfc_charlen_type_node); - else - gcc_assert (POINTER_TYPE_P (len_type)); - - strcpy (&name[1], f->sym->name); - name[0] = '_'; - length = build_decl (input_location, - PARM_DECL, get_identifier (name), len_type); - - hidden_arglist = chainon (hidden_arglist, length); - DECL_CONTEXT (length) = fndecl; - DECL_ARTIFICIAL (length) = 1; - DECL_ARG_TYPE (length) = len_type; - TREE_READONLY (length) = 1; - gfc_finish_decl (length); - - /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead - to tail calls being disabled. Only do that if we - potentially have broken callers. */ - if (flag_tail_call_workaround - && f->sym->ts.u.cl - && f->sym->ts.u.cl->length - && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT - && (flag_tail_call_workaround == 2 - || f->sym->ns->implicit_interface_calls)) - DECL_HIDDEN_STRING_LENGTH (length) = 1; - - /* Remember the passed value. */ - if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length) - { - /* This can happen if the same type is used for multiple - arguments. We need to copy cl as otherwise - cl->passed_length gets overwritten. */ - f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl); - } - f->sym->ts.u.cl->passed_length = length; - - /* Use the passed value for assumed length variables. */ - if (!f->sym->ts.u.cl->length) - { - TREE_USED (length) = 1; - gcc_assert (!f->sym->ts.u.cl->backend_decl); - f->sym->ts.u.cl->backend_decl = length; - } - - hidden_typelist = TREE_CHAIN (hidden_typelist); - - if (f->sym->ts.u.cl->backend_decl == NULL - || f->sym->ts.u.cl->backend_decl == length) - { - if (POINTER_TYPE_P (len_type)) - f->sym->ts.u.cl->backend_decl - = build_fold_indirect_ref_loc (input_location, length); - else if (f->sym->ts.u.cl->backend_decl == NULL) - gfc_create_string_length (f->sym); - - /* Make sure PARM_DECL type doesn't point to incomplete type. */ - if (f->sym->attr.flavor == FL_PROCEDURE) - type = build_pointer_type (gfc_get_function_type (f->sym)); - else - type = gfc_sym_type (f->sym); - } - } - /* For noncharacter scalar intrinsic types, VALUE passes the value, - hence, the optional status cannot be transferred via a NULL pointer. - Thus, we will use a hidden argument in that case. */ - else if (f->sym->attr.optional && f->sym->attr.value - && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS - && !gfc_bt_struct (f->sym->ts.type)) - { - tree tmp; - strcpy (&name[1], f->sym->name); - name[0] = '_'; - tmp = build_decl (input_location, - PARM_DECL, get_identifier (name), - boolean_type_node); - - hidden_arglist = chainon (hidden_arglist, tmp); - DECL_CONTEXT (tmp) = fndecl; - DECL_ARTIFICIAL (tmp) = 1; - DECL_ARG_TYPE (tmp) = boolean_type_node; - TREE_READONLY (tmp) = 1; - gfc_finish_decl (tmp); - - hidden_typelist = TREE_CHAIN (hidden_typelist); - } - - /* For non-constant length array arguments, make sure they use - a different type node from TYPE_ARG_TYPES type. */ - if (f->sym->attr.dimension - && type == TREE_VALUE (typelist) - && TREE_CODE (type) == POINTER_TYPE - && GFC_ARRAY_TYPE_P (type) - && f->sym->as->type != AS_ASSUMED_SIZE - && ! COMPLETE_TYPE_P (TREE_TYPE (type))) - { - if (f->sym->attr.flavor == FL_PROCEDURE) - type = build_pointer_type (gfc_get_function_type (f->sym)); - else - type = gfc_sym_type (f->sym); - } - - if (f->sym->attr.proc_pointer) - type = build_pointer_type (type); - - if (f->sym->attr.volatile_) - type = build_qualified_type (type, TYPE_QUAL_VOLATILE); - - /* Build the argument declaration. For C descriptors, we use a - '_'-prefixed name for the parm_decl and inside the proc the - sym->name. */ - tree parm_name; - if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL)) - { - strcpy (&name[1], f->sym->name); - name[0] = '_'; - parm_name = get_identifier (name); - } - else - parm_name = gfc_sym_identifier (f->sym); - parm = build_decl (input_location, PARM_DECL, parm_name, type); - - if (f->sym->attr.volatile_) - { - TREE_THIS_VOLATILE (parm) = 1; - TREE_SIDE_EFFECTS (parm) = 1; - } - - /* Fill in arg stuff. */ - DECL_CONTEXT (parm) = fndecl; - DECL_ARG_TYPE (parm) = TREE_VALUE (typelist); - /* All implementation args except for VALUE are read-only. */ - if (!f->sym->attr.value) - TREE_READONLY (parm) = 1; - if (POINTER_TYPE_P (type) - && (!f->sym->attr.proc_pointer - && f->sym->attr.flavor != FL_PROCEDURE)) - DECL_BY_REFERENCE (parm) = 1; - if (f->sym->attr.optional) - { - gfc_allocate_lang_decl (parm); - GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1; - } - - gfc_finish_decl (parm); - gfc_finish_decl_attrs (parm, &f->sym->attr); - - f->sym->backend_decl = parm; - - /* Coarrays which are descriptorless or assumed-shape pass with - -fcoarray=lib the token and the offset as hidden arguments. */ - if (flag_coarray == GFC_FCOARRAY_LIB - && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension - && !f->sym->attr.allocatable) - || (f->sym->ts.type == BT_CLASS - && CLASS_DATA (f->sym)->attr.codimension - && !CLASS_DATA (f->sym)->attr.allocatable))) - { - tree caf_type; - tree token; - tree offset; - - gcc_assert (f->sym->backend_decl != NULL_TREE - && !sym->attr.is_bind_c); - caf_type = f->sym->ts.type == BT_CLASS - ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl) - : TREE_TYPE (f->sym->backend_decl); - - token = build_decl (input_location, PARM_DECL, - create_tmp_var_name ("caf_token"), - build_qualified_type (pvoid_type_node, - TYPE_QUAL_RESTRICT)); - if ((f->sym->ts.type != BT_CLASS - && f->sym->as->type != AS_DEFERRED) - || (f->sym->ts.type == BT_CLASS - && CLASS_DATA (f->sym)->as->type != AS_DEFERRED)) - { - gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL - || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE); - if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL) - gfc_allocate_lang_decl (f->sym->backend_decl); - GFC_DECL_TOKEN (f->sym->backend_decl) = token; - } - else - { - gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE); - GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token; - } - - DECL_CONTEXT (token) = fndecl; - DECL_ARTIFICIAL (token) = 1; - DECL_ARG_TYPE (token) = TREE_VALUE (typelist); - TREE_READONLY (token) = 1; - hidden_arglist = chainon (hidden_arglist, token); - hidden_typelist = TREE_CHAIN (hidden_typelist); - gfc_finish_decl (token); - - offset = build_decl (input_location, PARM_DECL, - create_tmp_var_name ("caf_offset"), - gfc_array_index_type); - - if ((f->sym->ts.type != BT_CLASS - && f->sym->as->type != AS_DEFERRED) - || (f->sym->ts.type == BT_CLASS - && CLASS_DATA (f->sym)->as->type != AS_DEFERRED)) - { - gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl) - == NULL_TREE); - GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset; - } - else - { - gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE); - GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset; - } - DECL_CONTEXT (offset) = fndecl; - DECL_ARTIFICIAL (offset) = 1; - DECL_ARG_TYPE (offset) = TREE_VALUE (typelist); - TREE_READONLY (offset) = 1; - hidden_arglist = chainon (hidden_arglist, offset); - hidden_typelist = TREE_CHAIN (hidden_typelist); - gfc_finish_decl (offset); - } - - arglist = chainon (arglist, parm); - typelist = TREE_CHAIN (typelist); - } - - /* Add the hidden string length parameters, unless the procedure - is bind(C). */ - if (!sym->attr.is_bind_c) - arglist = chainon (arglist, hidden_arglist); - - gcc_assert (hidden_typelist == NULL_TREE - || TREE_VALUE (hidden_typelist) == void_type_node); - DECL_ARGUMENTS (fndecl) = arglist; -} - -/* Do the setup necessary before generating the body of a function. */ - -static void -trans_function_start (gfc_symbol * sym) -{ - tree fndecl; - - fndecl = sym->backend_decl; - - /* Let GCC know the current scope is this function. */ - current_function_decl = fndecl; - - /* Let the world know what we're about to do. */ - announce_function (fndecl); - - if (DECL_FILE_SCOPE_P (fndecl)) - { - /* Create RTL for function declaration. */ - rest_of_decl_compilation (fndecl, 1, 0); - } - - /* Create RTL for function definition. */ - make_decl_rtl (fndecl); - - allocate_struct_function (fndecl, false); - - /* function.c requires a push at the start of the function. */ - pushlevel (); -} - -/* Create thunks for alternate entry points. */ - -static void -build_entry_thunks (gfc_namespace * ns, bool global) -{ - gfc_formal_arglist *formal; - gfc_formal_arglist *thunk_formal; - gfc_entry_list *el; - gfc_symbol *thunk_sym; - stmtblock_t body; - tree thunk_fndecl; - tree tmp; - locus old_loc; - - /* This should always be a toplevel function. */ - gcc_assert (current_function_decl == NULL_TREE); - - gfc_save_backend_locus (&old_loc); - for (el = ns->entries; el; el = el->next) - { - vec *args = NULL; - vec *string_args = NULL; - - thunk_sym = el->sym; - - build_function_decl (thunk_sym, global); - create_function_arglist (thunk_sym); - - trans_function_start (thunk_sym); - - thunk_fndecl = thunk_sym->backend_decl; - - gfc_init_block (&body); - - /* Pass extra parameter identifying this entry point. */ - tmp = build_int_cst (gfc_array_index_type, el->id); - vec_safe_push (args, tmp); - - if (thunk_sym->attr.function) - { - if (gfc_return_by_reference (ns->proc_name)) - { - tree ref = DECL_ARGUMENTS (current_function_decl); - vec_safe_push (args, ref); - if (ns->proc_name->ts.type == BT_CHARACTER) - vec_safe_push (args, DECL_CHAIN (ref)); - } - } - - for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal; - formal = formal->next) - { - /* Ignore alternate returns. */ - if (formal->sym == NULL) - continue; - - /* We don't have a clever way of identifying arguments, so resort to - a brute-force search. */ - for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym); - thunk_formal; - thunk_formal = thunk_formal->next) - { - if (thunk_formal->sym == formal->sym) - break; - } - - if (thunk_formal) - { - /* Pass the argument. */ - DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1; - vec_safe_push (args, thunk_formal->sym->backend_decl); - if (formal->sym->ts.type == BT_CHARACTER) - { - tmp = thunk_formal->sym->ts.u.cl->backend_decl; - vec_safe_push (string_args, tmp); - } - } - else - { - /* Pass NULL for a missing argument. */ - vec_safe_push (args, null_pointer_node); - if (formal->sym->ts.type == BT_CHARACTER) - { - tmp = build_int_cst (gfc_charlen_type_node, 0); - vec_safe_push (string_args, tmp); - } - } - } - - /* Call the master function. */ - vec_safe_splice (args, string_args); - tmp = ns->proc_name->backend_decl; - tmp = build_call_expr_loc_vec (input_location, tmp, args); - if (ns->proc_name->attr.mixed_entry_master) - { - tree union_decl, field; - tree master_type = TREE_TYPE (ns->proc_name->backend_decl); - - union_decl = build_decl (input_location, - VAR_DECL, get_identifier ("__result"), - TREE_TYPE (master_type)); - DECL_ARTIFICIAL (union_decl) = 1; - DECL_EXTERNAL (union_decl) = 0; - TREE_PUBLIC (union_decl) = 0; - TREE_USED (union_decl) = 1; - layout_decl (union_decl, 0); - pushdecl (union_decl); - - DECL_CONTEXT (union_decl) = current_function_decl; - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (union_decl), union_decl, tmp); - gfc_add_expr_to_block (&body, tmp); - - for (field = TYPE_FIELDS (TREE_TYPE (union_decl)); - field; field = DECL_CHAIN (field)) - if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), - thunk_sym->result->name) == 0) - break; - gcc_assert (field != NULL_TREE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), union_decl, field, - NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (DECL_RESULT (current_function_decl)), - DECL_RESULT (current_function_decl), tmp); - tmp = build1_v (RETURN_EXPR, tmp); - } - else if (TREE_TYPE (DECL_RESULT (current_function_decl)) - != void_type_node) - { - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (DECL_RESULT (current_function_decl)), - DECL_RESULT (current_function_decl), tmp); - tmp = build1_v (RETURN_EXPR, tmp); - } - gfc_add_expr_to_block (&body, tmp); - - /* Finish off this function and send it for code generation. */ - DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body); - tmp = getdecls (); - poplevel (1, 1); - BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl; - DECL_SAVED_TREE (thunk_fndecl) - = fold_build3_loc (DECL_SOURCE_LOCATION (thunk_fndecl), BIND_EXPR, - void_type_node, tmp, DECL_SAVED_TREE (thunk_fndecl), - DECL_INITIAL (thunk_fndecl)); - - /* Output the GENERIC tree. */ - dump_function (TDI_original, thunk_fndecl); - - /* Store the end of the function, so that we get good line number - info for the epilogue. */ - cfun->function_end_locus = input_location; - - /* We're leaving the context of this function, so zap cfun. - It's still in DECL_STRUCT_FUNCTION, and we'll restore it in - tree_rest_of_compilation. */ - set_cfun (NULL); - - current_function_decl = NULL_TREE; - - cgraph_node::finalize_function (thunk_fndecl, true); - - /* We share the symbols in the formal argument list with other entry - points and the master function. Clear them so that they are - recreated for each function. */ - for (formal = gfc_sym_get_dummy_args (thunk_sym); formal; - formal = formal->next) - if (formal->sym != NULL) /* Ignore alternate returns. */ - { - formal->sym->backend_decl = NULL_TREE; - if (formal->sym->ts.type == BT_CHARACTER) - formal->sym->ts.u.cl->backend_decl = NULL_TREE; - } - - if (thunk_sym->attr.function) - { - if (thunk_sym->ts.type == BT_CHARACTER) - thunk_sym->ts.u.cl->backend_decl = NULL_TREE; - if (thunk_sym->result->ts.type == BT_CHARACTER) - thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE; - } - } - - gfc_restore_backend_locus (&old_loc); -} - - -/* Create a decl for a function, and create any thunks for alternate entry - points. If global is true, generate the function in the global binding - level, otherwise in the current binding level (which can be global). */ - -void -gfc_create_function_decl (gfc_namespace * ns, bool global) -{ - /* Create a declaration for the master function. */ - build_function_decl (ns->proc_name, global); - - /* Compile the entry thunks. */ - if (ns->entries) - build_entry_thunks (ns, global); - - /* Now create the read argument list. */ - create_function_arglist (ns->proc_name); - - if (ns->omp_declare_simd) - gfc_trans_omp_declare_simd (ns); - - /* Handle 'declare variant' directives. The applicable directives might - be declared in a parent namespace, so this needs to be called even if - there are no local directives. */ - if (flag_openmp) - gfc_trans_omp_declare_variant (ns); -} - -/* Return the decl used to hold the function return value. If - parent_flag is set, the context is the parent_scope. */ - -tree -gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) -{ - tree decl; - tree length; - tree this_fake_result_decl; - tree this_function_decl; - - char name[GFC_MAX_SYMBOL_LEN + 10]; - - if (parent_flag) - { - this_fake_result_decl = parent_fake_result_decl; - this_function_decl = DECL_CONTEXT (current_function_decl); - } - else - { - this_fake_result_decl = current_fake_result_decl; - this_function_decl = current_function_decl; - } - - if (sym - && sym->ns->proc_name->backend_decl == this_function_decl - && sym->ns->proc_name->attr.entry_master - && sym != sym->ns->proc_name) - { - tree t = NULL, var; - if (this_fake_result_decl != NULL) - for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t)) - if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0) - break; - if (t) - return TREE_VALUE (t); - decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag); - - if (parent_flag) - this_fake_result_decl = parent_fake_result_decl; - else - this_fake_result_decl = current_fake_result_decl; - - if (decl && sym->ns->proc_name->attr.mixed_entry_master) - { - tree field; - - for (field = TYPE_FIELDS (TREE_TYPE (decl)); - field; field = DECL_CHAIN (field)) - if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), - sym->name) == 0) - break; - - gcc_assert (field != NULL_TREE); - decl = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), decl, field, NULL_TREE); - } - - var = create_tmp_var_raw (TREE_TYPE (decl), sym->name); - if (parent_flag) - gfc_add_decl_to_parent_function (var); - else - gfc_add_decl_to_function (var); - - SET_DECL_VALUE_EXPR (var, decl); - DECL_HAS_VALUE_EXPR_P (var) = 1; - GFC_DECL_RESULT (var) = 1; - - TREE_CHAIN (this_fake_result_decl) - = tree_cons (get_identifier (sym->name), var, - TREE_CHAIN (this_fake_result_decl)); - return var; - } - - if (this_fake_result_decl != NULL_TREE) - return TREE_VALUE (this_fake_result_decl); - - /* Only when gfc_get_fake_result_decl is called by gfc_trans_return, - sym is NULL. */ - if (!sym) - return NULL_TREE; - - if (sym->ts.type == BT_CHARACTER) - { - if (sym->ts.u.cl->backend_decl == NULL_TREE) - length = gfc_create_string_length (sym); - else - length = sym->ts.u.cl->backend_decl; - if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE) - gfc_add_decl_to_function (length); - } - - if (gfc_return_by_reference (sym)) - { - decl = DECL_ARGUMENTS (this_function_decl); - - if (sym->ns->proc_name->backend_decl == this_function_decl - && sym->ns->proc_name->attr.entry_master) - decl = DECL_CHAIN (decl); - - TREE_USED (decl) = 1; - if (sym->as) - decl = gfc_build_dummy_array_decl (sym, decl); - } - else - { - sprintf (name, "__result_%.20s", - IDENTIFIER_POINTER (DECL_NAME (this_function_decl))); - - if (!sym->attr.mixed_entry_master && sym->attr.function) - decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), - VAR_DECL, get_identifier (name), - gfc_sym_type (sym)); - else - decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), - VAR_DECL, get_identifier (name), - TREE_TYPE (TREE_TYPE (this_function_decl))); - DECL_ARTIFICIAL (decl) = 1; - DECL_EXTERNAL (decl) = 0; - TREE_PUBLIC (decl) = 0; - TREE_USED (decl) = 1; - GFC_DECL_RESULT (decl) = 1; - TREE_ADDRESSABLE (decl) = 1; - - layout_decl (decl, 0); - gfc_finish_decl_attrs (decl, &sym->attr); - - if (parent_flag) - gfc_add_decl_to_parent_function (decl); - else - gfc_add_decl_to_function (decl); - } - - if (parent_flag) - parent_fake_result_decl = build_tree_list (NULL, decl); - else - current_fake_result_decl = build_tree_list (NULL, decl); - - if (sym->attr.assign) - DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl); - - return decl; -} - - -/* Builds a function decl. The remaining parameters are the types of the - function arguments. Negative nargs indicates a varargs function. */ - -static tree -build_library_function_decl_1 (tree name, const char *spec, - tree rettype, int nargs, va_list p) -{ - vec *arglist; - tree fntype; - tree fndecl; - int n; - - /* Library functions must be declared with global scope. */ - gcc_assert (current_function_decl == NULL_TREE); - - /* Create a list of the argument types. */ - vec_alloc (arglist, abs (nargs)); - for (n = abs (nargs); n > 0; n--) - { - tree argtype = va_arg (p, tree); - arglist->quick_push (argtype); - } - - /* Build the function type and decl. */ - if (nargs >= 0) - fntype = build_function_type_vec (rettype, arglist); - else - fntype = build_varargs_function_type_vec (rettype, arglist); - if (spec) - { - tree attr_args = build_tree_list (NULL_TREE, - build_string (strlen (spec), spec)); - tree attrs = tree_cons (get_identifier ("fn spec"), - attr_args, TYPE_ATTRIBUTES (fntype)); - fntype = build_type_attribute_variant (fntype, attrs); - } - fndecl = build_decl (input_location, - FUNCTION_DECL, name, fntype); - - /* Mark this decl as external. */ - DECL_EXTERNAL (fndecl) = 1; - TREE_PUBLIC (fndecl) = 1; - - pushdecl (fndecl); - - rest_of_decl_compilation (fndecl, 1, 0); - - return fndecl; -} - -/* Builds a function decl. The remaining parameters are the types of the - function arguments. Negative nargs indicates a varargs function. */ - -tree -gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) -{ - tree ret; - va_list args; - va_start (args, nargs); - ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args); - va_end (args); - return ret; -} - -/* Builds a function decl. The remaining parameters are the types of the - function arguments. Negative nargs indicates a varargs function. - The SPEC parameter specifies the function argument and return type - specification according to the fnspec function type attribute. */ - -tree -gfc_build_library_function_decl_with_spec (tree name, const char *spec, - tree rettype, int nargs, ...) -{ - tree ret; - va_list args; - va_start (args, nargs); - if (flag_checking) - { - attr_fnspec fnspec (spec, strlen (spec)); - fnspec.verify (); - } - ret = build_library_function_decl_1 (name, spec, rettype, nargs, args); - va_end (args); - return ret; -} - -static void -gfc_build_intrinsic_function_decls (void) -{ - tree gfc_int4_type_node = gfc_get_int_type (4); - tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); - tree gfc_int8_type_node = gfc_get_int_type (8); - tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node); - tree gfc_int16_type_node = gfc_get_int_type (16); - tree gfc_logical4_type_node = gfc_get_logical_type (4); - tree pchar1_type_node = gfc_get_pchar_type (1); - tree pchar4_type_node = gfc_get_pchar_type (4); - - /* String functions. */ - gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("compare_string")), ". . R . R ", - integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - DECL_PURE_P (gfor_fndecl_compare_string) = 1; - TREE_NOTHROW (gfor_fndecl_compare_string) = 1; - - gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("concat_string")), ". . W . R . R ", - void_type_node, 6, gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node); - TREE_NOTHROW (gfor_fndecl_concat_string) = 1; - - gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_len_trim")), ". . R ", - gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node); - DECL_PURE_P (gfor_fndecl_string_len_trim) = 1; - TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1; - - gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_index")), ". . R . R . ", - gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); - DECL_PURE_P (gfor_fndecl_string_index) = 1; - TREE_NOTHROW (gfor_fndecl_string_index) = 1; - - gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_scan")), ". . R . R . ", - gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); - DECL_PURE_P (gfor_fndecl_string_scan) = 1; - TREE_NOTHROW (gfor_fndecl_string_scan) = 1; - - gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_verify")), ". . R . R . ", - gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, - gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); - DECL_PURE_P (gfor_fndecl_string_verify) = 1; - TREE_NOTHROW (gfor_fndecl_string_verify) = 1; - - gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_trim")), ". W w . R ", - void_type_node, 4, build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar1_type_node), gfc_charlen_type_node, - pchar1_type_node); - - gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_minmax")), ". W w . R ", - void_type_node, -4, build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar1_type_node), integer_type_node, - integer_type_node); - - gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("adjustl")), ". W . R ", - void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, - pchar1_type_node); - TREE_NOTHROW (gfor_fndecl_adjustl) = 1; - - gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("adjustr")), ". W . R ", - void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, - pchar1_type_node); - TREE_NOTHROW (gfor_fndecl_adjustr) = 1; - - gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("select_string")), ". R . R . ", - integer_type_node, 4, pvoid_type_node, integer_type_node, - pchar1_type_node, gfc_charlen_type_node); - DECL_PURE_P (gfor_fndecl_select_string) = 1; - TREE_NOTHROW (gfor_fndecl_select_string) = 1; - - gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("compare_string_char4")), ". . R . R ", - integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node); - DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1; - TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1; - - gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("concat_string_char4")), ". . W . R . R ", - void_type_node, 6, gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node, - pchar4_type_node); - TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1; - - gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_len_trim_char4")), ". . R ", - gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node); - DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1; - TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1; - - gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_index_char4")), ". . R . R . ", - gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); - DECL_PURE_P (gfor_fndecl_string_index_char4) = 1; - TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1; - - gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_scan_char4")), ". . R . R . ", - gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); - DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1; - TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1; - - gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_verify_char4")), ". . R . R . ", - gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, - gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); - DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1; - TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1; - - gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_trim_char4")), ". W w . R ", - void_type_node, 4, build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar4_type_node), gfc_charlen_type_node, - pchar4_type_node); - - gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("string_minmax_char4")), ". W w . R ", - void_type_node, -4, build_pointer_type (gfc_charlen_type_node), - build_pointer_type (pchar4_type_node), integer_type_node, - integer_type_node); - - gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("adjustl_char4")), ". W . R ", - void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, - pchar4_type_node); - TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1; - - gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("adjustr_char4")), ". W . R ", - void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, - pchar4_type_node); - TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1; - - gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("select_string_char4")), ". R . R . ", - integer_type_node, 4, pvoid_type_node, integer_type_node, - pvoid_type_node, gfc_charlen_type_node); - DECL_PURE_P (gfor_fndecl_select_string_char4) = 1; - TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1; - - - /* Conversion between character kinds. */ - - gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("convert_char1_to_char4")), ". w . R ", - void_type_node, 3, build_pointer_type (pchar4_type_node), - gfc_charlen_type_node, pchar1_type_node); - - gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("convert_char4_to_char1")), ". w . R ", - void_type_node, 3, build_pointer_type (pchar1_type_node), - gfc_charlen_type_node, pchar4_type_node); - - /* Misc. functions. */ - - gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("ttynam")), ". W . . ", - void_type_node, 3, pchar_type_node, gfc_charlen_type_node, - integer_type_node); - - gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("fdate")), ". W . ", - void_type_node, 2, pchar_type_node, gfc_charlen_type_node); - - gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("ctime")), ". W . . ", - void_type_node, 3, pchar_type_node, gfc_charlen_type_node, - gfc_int8_type_node); - - gfor_fndecl_random_init = gfc_build_library_function_decl ( - get_identifier (PREFIX("random_init")), - void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node, - gfc_int4_type_node); - - // gfor_fndecl_caf_rand_init is defined in the lib-coarray section below. - - gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("selected_char_kind")), ". . R ", - gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node); - DECL_PURE_P (gfor_fndecl_sc_kind) = 1; - TREE_NOTHROW (gfor_fndecl_sc_kind) = 1; - - gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("selected_int_kind")), ". R ", - gfc_int4_type_node, 1, pvoid_type_node); - DECL_PURE_P (gfor_fndecl_si_kind) = 1; - TREE_NOTHROW (gfor_fndecl_si_kind) = 1; - - gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("selected_real_kind2008")), ". R R ", - gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node, - pvoid_type_node); - DECL_PURE_P (gfor_fndecl_sr_kind) = 1; - TREE_NOTHROW (gfor_fndecl_sr_kind) = 1; - - gfor_fndecl_system_clock4 = gfc_build_library_function_decl ( - get_identifier (PREFIX("system_clock_4")), - void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node, - gfc_pint4_type_node); - - gfor_fndecl_system_clock8 = gfc_build_library_function_decl ( - get_identifier (PREFIX("system_clock_8")), - void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node, - gfc_pint8_type_node); - - /* Power functions. */ - { - tree ctype, rtype, itype, jtype; - int rkind, ikind, jkind; -#define NIKINDS 3 -#define NRKINDS 4 - static int ikinds[NIKINDS] = {4, 8, 16}; - static int rkinds[NRKINDS] = {4, 8, 10, 16}; - char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */ - - for (ikind=0; ikind < NIKINDS; ikind++) - { - itype = gfc_get_int_type (ikinds[ikind]); - - for (jkind=0; jkind < NIKINDS; jkind++) - { - jtype = gfc_get_int_type (ikinds[jkind]); - if (itype && jtype) - { - sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind], - ikinds[jkind]); - gfor_fndecl_math_powi[jkind][ikind].integer = - gfc_build_library_function_decl (get_identifier (name), - jtype, 2, jtype, itype); - TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; - TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; - } - } - - for (rkind = 0; rkind < NRKINDS; rkind ++) - { - rtype = gfc_get_real_type (rkinds[rkind]); - if (rtype && itype) - { - sprintf (name, PREFIX("pow_r%d_i%d"), - gfc_type_abi_kind (BT_REAL, rkinds[rkind]), - ikinds[ikind]); - gfor_fndecl_math_powi[rkind][ikind].real = - gfc_build_library_function_decl (get_identifier (name), - rtype, 2, rtype, itype); - TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1; - TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1; - } - - ctype = gfc_get_complex_type (rkinds[rkind]); - if (ctype && itype) - { - sprintf (name, PREFIX("pow_c%d_i%d"), - gfc_type_abi_kind (BT_REAL, rkinds[rkind]), - ikinds[ikind]); - gfor_fndecl_math_powi[rkind][ikind].cmplx = - gfc_build_library_function_decl (get_identifier (name), - ctype, 2,ctype, itype); - TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; - TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; - } - } - } -#undef NIKINDS -#undef NRKINDS - } - - gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl ( - get_identifier (PREFIX("ishftc4")), - gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node, - gfc_int4_type_node); - TREE_READONLY (gfor_fndecl_math_ishftc4) = 1; - TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1; - - gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl ( - get_identifier (PREFIX("ishftc8")), - gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node, - gfc_int4_type_node); - TREE_READONLY (gfor_fndecl_math_ishftc8) = 1; - TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1; - - if (gfc_int16_type_node) - { - gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl ( - get_identifier (PREFIX("ishftc16")), - gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node, - gfc_int4_type_node); - TREE_READONLY (gfor_fndecl_math_ishftc16) = 1; - TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1; - } - - /* BLAS functions. */ - { - tree pint = build_pointer_type (integer_type_node); - tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind)); - tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind)); - tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind)); - tree pz = build_pointer_type - (gfc_get_complex_type (gfc_default_double_kind)); - - gfor_fndecl_sgemm = gfc_build_library_function_decl - (get_identifier - (flag_underscoring ? "sgemm_" : "sgemm"), - void_type_node, 15, pchar_type_node, - pchar_type_node, pint, pint, pint, ps, ps, pint, - ps, pint, ps, ps, pint, integer_type_node, - integer_type_node); - gfor_fndecl_dgemm = gfc_build_library_function_decl - (get_identifier - (flag_underscoring ? "dgemm_" : "dgemm"), - void_type_node, 15, pchar_type_node, - pchar_type_node, pint, pint, pint, pd, pd, pint, - pd, pint, pd, pd, pint, integer_type_node, - integer_type_node); - gfor_fndecl_cgemm = gfc_build_library_function_decl - (get_identifier - (flag_underscoring ? "cgemm_" : "cgemm"), - void_type_node, 15, pchar_type_node, - pchar_type_node, pint, pint, pint, pc, pc, pint, - pc, pint, pc, pc, pint, integer_type_node, - integer_type_node); - gfor_fndecl_zgemm = gfc_build_library_function_decl - (get_identifier - (flag_underscoring ? "zgemm_" : "zgemm"), - void_type_node, 15, pchar_type_node, - pchar_type_node, pint, pint, pint, pz, pz, pint, - pz, pint, pz, pz, pint, integer_type_node, - integer_type_node); - } - - /* Other functions. */ - gfor_fndecl_iargc = gfc_build_library_function_decl ( - get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); - TREE_NOTHROW (gfor_fndecl_iargc) = 1; - - gfor_fndecl_kill_sub = gfc_build_library_function_decl ( - get_identifier (PREFIX ("kill_sub")), void_type_node, - 3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node); - - gfor_fndecl_kill = gfc_build_library_function_decl ( - get_identifier (PREFIX ("kill")), gfc_int4_type_node, - 2, gfc_int4_type_node, gfc_int4_type_node); - - gfor_fndecl_is_contiguous0 = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("is_contiguous0")), ". R ", - gfc_int4_type_node, 1, pvoid_type_node); - DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1; - TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1; -} - - -/* Make prototypes for runtime library functions. */ - -void -gfc_build_builtin_function_decls (void) -{ - tree gfc_int8_type_node = gfc_get_int_type (8); - - gfor_fndecl_stop_numeric = gfc_build_library_function_decl ( - get_identifier (PREFIX("stop_numeric")), - void_type_node, 2, integer_type_node, boolean_type_node); - /* STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; - - gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("stop_string")), ". R . . ", - void_type_node, 3, pchar_type_node, size_type_node, - boolean_type_node); - /* STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; - - gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl ( - get_identifier (PREFIX("error_stop_numeric")), - void_type_node, 2, integer_type_node, boolean_type_node); - /* ERROR STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1; - - gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("error_stop_string")), ". R . . ", - void_type_node, 3, pchar_type_node, size_type_node, - boolean_type_node); - /* ERROR STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; - - gfor_fndecl_pause_numeric = gfc_build_library_function_decl ( - get_identifier (PREFIX("pause_numeric")), - void_type_node, 1, gfc_int8_type_node); - - gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("pause_string")), ". R . ", - void_type_node, 2, pchar_type_node, size_type_node); - - gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("runtime_error")), ". R ", - void_type_node, -1, pchar_type_node); - /* The runtime_error function does not return. */ - TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; - - gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("runtime_error_at")), ". R R ", - void_type_node, -2, pchar_type_node, pchar_type_node); - /* The runtime_error_at function does not return. */ - TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; - - gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("runtime_warning_at")), ". R R ", - void_type_node, -2, pchar_type_node, pchar_type_node); - - gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("generate_error")), ". R . R ", - void_type_node, 3, pvoid_type_node, integer_type_node, - pchar_type_node); - - gfor_fndecl_os_error_at = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("os_error_at")), ". R R ", - void_type_node, -2, pchar_type_node, pchar_type_node); - /* The os_error_at function does not return. */ - TREE_THIS_VOLATILE (gfor_fndecl_os_error_at) = 1; - - gfor_fndecl_set_args = gfc_build_library_function_decl ( - get_identifier (PREFIX("set_args")), - void_type_node, 2, integer_type_node, - build_pointer_type (pchar_type_node)); - - gfor_fndecl_set_fpe = gfc_build_library_function_decl ( - get_identifier (PREFIX("set_fpe")), - void_type_node, 1, integer_type_node); - - gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl ( - get_identifier (PREFIX("ieee_procedure_entry")), - void_type_node, 1, pvoid_type_node); - - gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl ( - get_identifier (PREFIX("ieee_procedure_exit")), - void_type_node, 1, pvoid_type_node); - - /* Keep the array dimension in sync with the call, later in this file. */ - gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("set_options")), ". . R ", - void_type_node, 2, integer_type_node, - build_pointer_type (integer_type_node)); - - gfor_fndecl_set_convert = gfc_build_library_function_decl ( - get_identifier (PREFIX("set_convert")), - void_type_node, 1, integer_type_node); - - gfor_fndecl_set_record_marker = gfc_build_library_function_decl ( - get_identifier (PREFIX("set_record_marker")), - void_type_node, 1, integer_type_node); - - gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl ( - get_identifier (PREFIX("set_max_subrecord_length")), - void_type_node, 1, integer_type_node); - - gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("internal_pack")), ". r ", - pvoid_type_node, 1, pvoid_type_node); - - gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("internal_unpack")), ". w R ", - void_type_node, 2, pvoid_type_node, pvoid_type_node); - - gfor_fndecl_associated = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("associated")), ". R R ", - integer_type_node, 2, ppvoid_type_node, ppvoid_type_node); - DECL_PURE_P (gfor_fndecl_associated) = 1; - TREE_NOTHROW (gfor_fndecl_associated) = 1; - - /* Coarray library calls. */ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree pint_type, pppchar_type; - - pint_type = build_pointer_type (integer_type_node); - pppchar_type - = build_pointer_type (build_pointer_type (pchar_type_node)); - - gfor_fndecl_caf_init = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_init")), ". W W ", - void_type_node, 2, pint_type, pppchar_type); - - gfor_fndecl_caf_finalize = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_finalize")), void_type_node, 0); - - gfor_fndecl_caf_this_image = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_this_image")), integer_type_node, - 1, integer_type_node); - - gfor_fndecl_caf_num_images = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_num_images")), integer_type_node, - 2, integer_type_node, integer_type_node); - - gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_register")), ". . . W w w w . ", - void_type_node, 7, - size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node, - pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_deregister")), ". W . w w . ", - void_type_node, 5, - ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, - size_type_node); - - gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ", - void_type_node, 10, - pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type); - - gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send")), ". r . . w r r . . . w ", - void_type_node, 11, - pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type, pvoid_type_node); - - gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sendget")), ". r . . w r r . . r r . . . w ", - void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node, - pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node, - integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, - integer_type_node, boolean_type_node, integer_type_node); - - gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get_by_ref")), ". r . w r . . . . w . ", - void_type_node, - 10, pvoid_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, boolean_type_node, pint_type, integer_type_node); - - gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send_by_ref")), ". r . r r . . . . w . ", - void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node, - pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, boolean_type_node, pint_type, integer_type_node); - - gfor_fndecl_caf_sendget_by_ref - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sendget_by_ref")), - ". r . r r . r . . . w w . . ", - void_type_node, 13, pvoid_type_node, integer_type_node, - pvoid_type_node, pvoid_type_node, integer_type_node, - pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type, pint_type, integer_type_node, - integer_type_node); - - gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sync_all")), ". w w . ", void_type_node, - 3, pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sync_memory")), ". w w . ", void_type_node, - 3, pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sync_images")), ". . r w w . ", void_type_node, - 5, integer_type_node, pint_type, pint_type, - pchar_type_node, size_type_node); - - gfor_fndecl_caf_error_stop = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_error_stop")), - void_type_node, 1, integer_type_node); - /* CAF's ERROR STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1; - - gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_error_stop_str")), ". r . ", - void_type_node, 2, pchar_type_node, size_type_node); - /* CAF's ERROR STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1; - - gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_stop_numeric")), - void_type_node, 1, integer_type_node); - /* CAF's STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1; - - gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_stop_str")), ". r . ", - void_type_node, 2, pchar_type_node, size_type_node); - /* CAF's STOP doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1; - - gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_atomic_define")), ". r . . w w . . ", - void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, - pvoid_type_node, pint_type, integer_type_node, integer_type_node); - - gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_atomic_ref")), ". r . . w w . . ", - void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, - pvoid_type_node, pint_type, integer_type_node, integer_type_node); - - gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_atomic_cas")), ". r . . w r r w . . ", - void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node, - pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type, - integer_type_node, integer_type_node); - - gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_atomic_op")), ". . r . . r w w . . ", - void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node, - integer_type_node, pvoid_type_node, pvoid_type_node, pint_type, - integer_type_node, integer_type_node); - - gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_lock")), ". r . . w w w . ", - void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_unlock")), ". r . . w w . ", - void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_event_post")), ". r . . w w . ", - void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_event_wait")), ". r . . w w . ", - void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_event_query")), ". r . . w w ", - void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node, - pint_type, pint_type); - - gfor_fndecl_caf_fail_image = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_fail_image")), void_type_node, 0); - /* CAF's FAIL doesn't return. */ - TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1; - - gfor_fndecl_caf_failed_images - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_failed_images")), ". w . r ", - void_type_node, 3, pvoid_type_node, ppvoid_type_node, - integer_type_node); - - gfor_fndecl_caf_form_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_form_team")), ". . W . ", - void_type_node, 3, integer_type_node, ppvoid_type_node, - integer_type_node); - - gfor_fndecl_caf_change_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_change_team")), ". w . ", - void_type_node, 2, ppvoid_type_node, - integer_type_node); - - gfor_fndecl_caf_end_team - = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_end_team")), void_type_node, 0); - - gfor_fndecl_caf_get_team - = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_get_team")), - void_type_node, 1, integer_type_node); - - gfor_fndecl_caf_sync_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sync_team")), ". r . ", - void_type_node, 2, ppvoid_type_node, - integer_type_node); - - gfor_fndecl_caf_team_number - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_team_number")), ". r ", - integer_type_node, 1, integer_type_node); - - gfor_fndecl_caf_image_status - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_image_status")), ". . r ", - integer_type_node, 2, integer_type_node, ppvoid_type_node); - - gfor_fndecl_caf_stopped_images - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_stopped_images")), ". w r r ", - void_type_node, 3, pvoid_type_node, ppvoid_type_node, - integer_type_node); - - gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_co_broadcast")), ". w . w w . ", - void_type_node, 5, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_co_max")), ". w . w w . . ", - void_type_node, 6, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node, size_type_node); - - gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_co_min")), ". w . w w . . ", - void_type_node, 6, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, integer_type_node, size_type_node); - - gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_co_reduce")), ". w r . . w w . . ", - void_type_node, 8, pvoid_type_node, - build_pointer_type (build_varargs_function_type_list (void_type_node, - NULL_TREE)), - integer_type_node, integer_type_node, pint_type, pchar_type_node, - integer_type_node, size_type_node); - - gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_co_sum")), ". w . w w . ", - void_type_node, 5, pvoid_type_node, integer_type_node, - pint_type, pchar_type_node, size_type_node); - - gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_is_present")), ". r . r ", - integer_type_node, 3, pvoid_type_node, integer_type_node, - pvoid_type_node); - - gfor_fndecl_caf_random_init = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_random_init")), - void_type_node, 2, logical_type_node, logical_type_node); - } - - gfc_build_intrinsic_function_decls (); - gfc_build_intrinsic_lib_fndecls (); - gfc_build_io_library_fndecls (); -} - - -/* Evaluate the length of dummy character variables. */ - -static void -gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, - gfc_wrapped_block *block) -{ - stmtblock_t init; - - gfc_finish_decl (cl->backend_decl); - - gfc_start_block (&init); - - /* Evaluate the string length expression. */ - gfc_conv_string_length (cl, NULL, &init); - - gfc_trans_vla_type_sizes (sym, &init); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); -} - - -/* Allocate and cleanup an automatic character variable. */ - -static void -gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block) -{ - stmtblock_t init; - tree decl; - tree tmp; - - gcc_assert (sym->backend_decl); - gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length); - - gfc_init_block (&init); - - /* Evaluate the string length expression. */ - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - gfc_trans_vla_type_sizes (sym, &init); - - decl = sym->backend_decl; - - /* Emit a DECL_EXPR for this variable, which will cause the - gimplifier to allocate storage, and all that good stuff. */ - tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&init, tmp); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); -} - -/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */ - -static void -gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block) -{ - stmtblock_t init; - - gcc_assert (sym->backend_decl); - gfc_start_block (&init); - - /* Set the initial value to length. See the comments in - function gfc_add_assign_aux_vars in this file. */ - gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl), - build_int_cst (gfc_charlen_type_node, -2)); - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); -} - -static void -gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body) -{ - tree t = *tp, var, val; - - if (t == NULL || t == error_mark_node) - return; - if (TREE_CONSTANT (t) || DECL_P (t)) - return; - - if (TREE_CODE (t) == SAVE_EXPR) - { - if (SAVE_EXPR_RESOLVED_P (t)) - { - *tp = TREE_OPERAND (t, 0); - return; - } - val = TREE_OPERAND (t, 0); - } - else - val = t; - - var = gfc_create_var_np (TREE_TYPE (t), NULL); - gfc_add_decl_to_function (var); - gfc_add_modify (body, var, unshare_expr (val)); - if (TREE_CODE (t) == SAVE_EXPR) - TREE_OPERAND (t, 0) = var; - *tp = var; -} - -static void -gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body) -{ - tree t; - - if (type == NULL || type == error_mark_node) - return; - - type = TYPE_MAIN_VARIANT (type); - - if (TREE_CODE (type) == INTEGER_TYPE) - { - gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body); - gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body); - - for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t)) - { - TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type); - TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type); - } - } - else if (TREE_CODE (type) == ARRAY_TYPE) - { - gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body); - gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body); - gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body); - gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body); - - for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t)) - { - TYPE_SIZE (t) = TYPE_SIZE (type); - TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type); - } - } -} - -/* Make sure all type sizes and array domains are either constant, - or variable or parameter decls. This is a simplified variant - of gimplify_type_sizes, but we can't use it here, as none of the - variables in the expressions have been gimplified yet. - As type sizes and domains for various variable length arrays - contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars - time, without this routine gimplify_type_sizes in the middle-end - could result in the type sizes being gimplified earlier than where - those variables are initialized. */ - -void -gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) -{ - tree type = TREE_TYPE (sym->backend_decl); - - if (TREE_CODE (type) == FUNCTION_TYPE - && (sym->attr.function || sym->attr.result || sym->attr.entry)) - { - if (! current_fake_result_decl) - return; - - type = TREE_TYPE (TREE_VALUE (current_fake_result_decl)); - } - - while (POINTER_TYPE_P (type)) - type = TREE_TYPE (type); - - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); - - while (POINTER_TYPE_P (etype)) - etype = TREE_TYPE (etype); - - gfc_trans_vla_type_sizes_1 (etype, body); - } - - gfc_trans_vla_type_sizes_1 (type, body); -} - - -/* Initialize a derived type by building an lvalue from the symbol - and using trans_assignment to do the work. Set dealloc to false - if no deallocation prior the assignment is needed. */ -void -gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) -{ - gfc_expr *e; - tree tmp; - tree present; - - gcc_assert (block); - - /* Initialization of PDTs is done elsewhere. */ - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) - return; - - gcc_assert (!sym->attr.allocatable); - gfc_set_sym_referenced (sym); - e = gfc_lval_expr_from_sym (sym); - tmp = gfc_trans_assignment (e, sym->value, false, dealloc); - if (sym->attr.dummy && (sym->attr.optional - || sym->ns->proc_name->attr.entry_master)) - { - present = gfc_conv_expr_present (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); - gfc_free_expr (e); -} - - -/* Initialize INTENT(OUT) derived type dummies. As well as giving - them their default initializer, if they do not have allocatable - components, they have their allocatable components deallocated. */ - -static void -init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) -{ - stmtblock_t init; - gfc_formal_arglist *f; - tree tmp; - tree present; - - gfc_init_block (&init); - for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) - if (f->sym && f->sym->attr.intent == INTENT_OUT - && !f->sym->attr.pointer - && f->sym->ts.type == BT_DERIVED) - { - tmp = NULL_TREE; - - /* Note: Allocatables are excluded as they are already handled - by the caller. */ - if (!f->sym->attr.allocatable - && gfc_is_finalizable (f->sym->ts.u.derived, NULL)) - { - stmtblock_t block; - gfc_expr *e; - - gfc_init_block (&block); - f->sym->attr.referenced = 1; - e = gfc_lval_expr_from_sym (f->sym); - gfc_add_finalizer_call (&block, e); - gfc_free_expr (e); - tmp = gfc_finish_block (&block); - } - - if (tmp == NULL_TREE && !f->sym->attr.allocatable - && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) - tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, - f->sym->backend_decl, - f->sym->as ? f->sym->as->rank : 0); - - if (tmp != NULL_TREE && (f->sym->attr.optional - || f->sym->ns->proc_name->attr.entry_master)) - { - present = gfc_conv_expr_present (f->sym); - tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), - present, tmp, build_empty_stmt (input_location)); - } - - if (tmp != NULL_TREE) - gfc_add_expr_to_block (&init, tmp); - else if (f->sym->value && !f->sym->attr.allocatable) - gfc_init_default_dt (f->sym, &init, true); - } - else if (f->sym && f->sym->attr.intent == INTENT_OUT - && f->sym->ts.type == BT_CLASS - && !CLASS_DATA (f->sym)->attr.class_pointer - && !CLASS_DATA (f->sym)->attr.allocatable) - { - stmtblock_t block; - gfc_expr *e; - - gfc_init_block (&block); - f->sym->attr.referenced = 1; - e = gfc_lval_expr_from_sym (f->sym); - gfc_add_finalizer_call (&block, e); - gfc_free_expr (e); - tmp = gfc_finish_block (&block); - - if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master) - { - present = gfc_conv_expr_present (f->sym); - tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), - present, tmp, - build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&init, tmp); - } - - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); -} - - -/* Helper function to manage deferred string lengths. */ - -static tree -gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init, - locus *loc) -{ - tree tmp; - - /* Character length passed by reference. */ - tmp = sym->ts.u.cl->passed_length; - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = fold_convert (gfc_charlen_type_node, tmp); - - if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) - /* Zero the string length when entering the scope. */ - gfc_add_modify (init, sym->ts.u.cl->backend_decl, - build_int_cst (gfc_charlen_type_node, 0)); - else - { - tree tmp2; - - tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, - gfc_charlen_type_node, - sym->ts.u.cl->backend_decl, tmp); - if (sym->attr.optional) - { - tree present = gfc_conv_expr_present (sym); - tmp2 = build3_loc (input_location, COND_EXPR, - void_type_node, present, tmp2, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (init, tmp2); - } - - gfc_restore_backend_locus (loc); - - /* Pass the final character length back. */ - if (sym->attr.intent != INTENT_IN) - { - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - gfc_charlen_type_node, tmp, - sym->ts.u.cl->backend_decl); - if (sym->attr.optional) - { - tree present = gfc_conv_expr_present (sym); - tmp = build3_loc (input_location, COND_EXPR, - void_type_node, present, tmp, - build_empty_stmt (input_location)); - } - } - else - tmp = NULL_TREE; - - return tmp; -} - - -/* Get the result expression for a procedure. */ - -static tree -get_proc_result (gfc_symbol* sym) -{ - if (sym->attr.subroutine || sym == sym->result) - { - if (current_fake_result_decl != NULL) - return TREE_VALUE (current_fake_result_decl); - - return NULL_TREE; - } - - return sym->result->backend_decl; -} - - -/* Generate function entry and exit code, and add it to the function body. - This includes: - Allocation and initialization of array variables. - Allocation of character string variables. - Initialization and possibly repacking of dummy arrays. - Initialization of ASSIGN statement auxiliary variable. - Initialization of ASSOCIATE names. - Automatic deallocation. */ - -void -gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) -{ - locus loc; - gfc_symbol *sym; - gfc_formal_arglist *f; - stmtblock_t tmpblock; - bool seen_trans_deferred_array = false; - bool is_pdt_type = false; - tree tmp = NULL; - gfc_expr *e; - gfc_se se; - stmtblock_t init; - - /* Deal with implicit return variables. Explicit return variables will - already have been added. */ - if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym) - { - if (!current_fake_result_decl) - { - gfc_entry_list *el = NULL; - if (proc_sym->attr.entry_master) - { - for (el = proc_sym->ns->entries; el; el = el->next) - if (el->sym != el->sym->result) - break; - } - /* TODO: move to the appropriate place in resolve.c. */ - if (warn_return_type > 0 && el == NULL) - gfc_warning (OPT_Wreturn_type, - "Return value of function %qs at %L not set", - proc_sym->name, &proc_sym->declared_at); - } - else if (proc_sym->as) - { - tree result = TREE_VALUE (current_fake_result_decl); - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&proc_sym->declared_at); - gfc_trans_dummy_array_bias (proc_sym, result, block); - - /* An automatic character length, pointer array result. */ - if (proc_sym->ts.type == BT_CHARACTER - && VAR_P (proc_sym->ts.u.cl->backend_decl)) - { - tmp = NULL; - if (proc_sym->ts.deferred) - { - gfc_start_block (&init); - tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc); - gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); - } - else - gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); - } - } - else if (proc_sym->ts.type == BT_CHARACTER) - { - if (proc_sym->ts.deferred) - { - tmp = NULL; - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&proc_sym->declared_at); - gfc_start_block (&init); - /* Zero the string length on entry. */ - gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl, - build_int_cst (gfc_charlen_type_node, 0)); - /* Null the pointer. */ - e = gfc_lval_expr_from_sym (proc_sym); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, e); - gfc_free_expr (e); - tmp = se.expr; - gfc_add_modify (&init, tmp, - fold_convert (TREE_TYPE (se.expr), - null_pointer_node)); - gfc_restore_backend_locus (&loc); - - /* Pass back the string length on exit. */ - tmp = proc_sym->ts.u.cl->backend_decl; - if (TREE_CODE (tmp) != INDIRECT_REF - && proc_sym->ts.u.cl->passed_length) - { - tmp = proc_sym->ts.u.cl->passed_length; - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (tmp), tmp, - fold_convert - (TREE_TYPE (tmp), - proc_sym->ts.u.cl->backend_decl)); - } - else - tmp = NULL_TREE; - - gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); - } - else if (VAR_P (proc_sym->ts.u.cl->backend_decl)) - gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); - } - else - gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX); - } - else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym)) - { - /* Nullify explicit return class arrays on entry. */ - tree type; - tmp = get_proc_result (proc_sym); - if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) - { - gfc_start_block (&init); - tmp = gfc_class_data_get (tmp); - type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); - gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - } - } - - - /* Initialize the INTENT(OUT) derived type dummy arguments. This - should be done here so that the offsets and lbounds of arrays - are available. */ - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&proc_sym->declared_at); - init_intent_out_dt (proc_sym, block); - gfc_restore_backend_locus (&loc); - - for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) - { - bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED) - && (sym->ts.u.derived->attr.alloc_comp - || gfc_is_finalizable (sym->ts.u.derived, - NULL)); - if (sym->assoc) - continue; - - if (sym->ts.type == BT_DERIVED - && sym->ts.u.derived - && sym->ts.u.derived->attr.pdt_type) - { - is_pdt_type = true; - gfc_init_block (&tmpblock); - if (!(sym->attr.dummy - || sym->attr.pointer - || sym->attr.allocatable)) - { - tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, - sym->backend_decl, - sym->as ? sym->as->rank : 0, - sym->param_list); - gfc_add_expr_to_block (&tmpblock, tmp); - if (!sym->attr.result) - tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, - sym->backend_decl, - sym->as ? sym->as->rank : 0); - else - tmp = NULL_TREE; - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); - } - else if (sym->attr.dummy) - { - tmp = gfc_check_pdt_dummy (sym->ts.u.derived, - sym->backend_decl, - sym->as ? sym->as->rank : 0, - sym->param_list); - gfc_add_expr_to_block (&tmpblock, tmp); - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); - } - } - else if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->ts.u.derived - && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) - { - gfc_component *data = CLASS_DATA (sym); - is_pdt_type = true; - gfc_init_block (&tmpblock); - if (!(sym->attr.dummy - || CLASS_DATA (sym)->attr.pointer - || CLASS_DATA (sym)->attr.allocatable)) - { - tmp = gfc_class_data_get (sym->backend_decl); - tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp, - data->as ? data->as->rank : 0, - sym->param_list); - gfc_add_expr_to_block (&tmpblock, tmp); - tmp = gfc_class_data_get (sym->backend_decl); - if (!sym->attr.result) - tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp, - data->as ? data->as->rank : 0); - else - tmp = NULL_TREE; - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); - } - else if (sym->attr.dummy) - { - tmp = gfc_class_data_get (sym->backend_decl); - tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp, - data->as ? data->as->rank : 0, - sym->param_list); - gfc_add_expr_to_block (&tmpblock, tmp); - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); - } - } - - if (sym->attr.pointer && sym->attr.dimension - && sym->attr.save == SAVE_NONE - && !sym->attr.use_assoc - && !sym->attr.host_assoc - && !sym->attr.dummy - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))) - { - gfc_init_block (&tmpblock); - gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl, - build_int_cst (gfc_array_index_type, 0)); - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), - NULL_TREE); - } - - if (sym->ts.type == BT_CLASS - && (sym->attr.save || flag_max_stack_var_size == 0) - && CLASS_DATA (sym)->attr.allocatable) - { - tree vptr; - - if (UNLIMITED_POLY (sym)) - vptr = null_pointer_node; - else - { - gfc_symbol *vsym; - vsym = gfc_find_derived_vtab (sym->ts.u.derived); - vptr = gfc_get_symbol_decl (vsym); - vptr = gfc_build_addr_expr (NULL, vptr); - } - - if (CLASS_DATA (sym)->attr.dimension - || (CLASS_DATA (sym)->attr.codimension - && flag_coarray != GFC_FCOARRAY_LIB)) - { - tmp = gfc_class_data_get (sym->backend_decl); - tmp = gfc_build_null_descriptor (TREE_TYPE (tmp)); - } - else - tmp = null_pointer_node; - - DECL_INITIAL (sym->backend_decl) - = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp); - TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1; - } - else if ((sym->attr.dimension || sym->attr.codimension - || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))) - { - bool is_classarray = IS_CLASS_ARRAY (sym); - symbol_attribute *array_attr; - gfc_array_spec *as; - array_type type_of_array; - - array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; - as = is_classarray ? CLASS_DATA (sym)->as : sym->as; - /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ - type_of_array = as->type; - if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed) - type_of_array = AS_EXPLICIT; - switch (type_of_array) - { - case AS_EXPLICIT: - if (sym->attr.dummy || sym->attr.result) - gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); - /* Allocatable and pointer arrays need to processed - explicitly. */ - else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) - || (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.class_pointer) - || array_attr->allocatable) - { - if (TREE_STATIC (sym->backend_decl)) - { - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - gfc_trans_static_array_pointer (sym); - gfc_restore_backend_locus (&loc); - } - else - { - seen_trans_deferred_array = true; - gfc_trans_deferred_array (sym, block); - } - } - else if (sym->attr.codimension - && TREE_STATIC (sym->backend_decl)) - { - gfc_init_block (&tmpblock); - gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl), - &tmpblock, sym); - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), - NULL_TREE); - continue; - } - else - { - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - - if (alloc_comp_or_fini) - { - seen_trans_deferred_array = true; - gfc_trans_deferred_array (sym, block); - } - else if (sym->ts.type == BT_DERIVED - && sym->value - && !sym->attr.data - && sym->attr.save == SAVE_NONE) - { - gfc_start_block (&tmpblock); - gfc_init_default_dt (sym, &tmpblock, false); - gfc_add_init_cleanup (block, - gfc_finish_block (&tmpblock), - NULL_TREE); - } - - gfc_trans_auto_array_allocation (sym->backend_decl, - sym, block); - gfc_restore_backend_locus (&loc); - } - break; - - case AS_ASSUMED_SIZE: - /* Must be a dummy parameter. */ - gcc_assert (sym->attr.dummy || as->cp_was_assumed); - - /* We should always pass assumed size arrays the g77 way. */ - if (sym->attr.dummy) - gfc_trans_g77_array (sym, block); - break; - - case AS_ASSUMED_SHAPE: - /* Must be a dummy parameter. */ - gcc_assert (sym->attr.dummy); - - gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); - break; - - case AS_ASSUMED_RANK: - case AS_DEFERRED: - seen_trans_deferred_array = true; - gfc_trans_deferred_array (sym, block); - if (sym->ts.type == BT_CHARACTER && sym->ts.deferred - && sym->attr.result) - { - gfc_start_block (&init); - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); - gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); - } - break; - - default: - gcc_unreachable (); - } - if (alloc_comp_or_fini && !seen_trans_deferred_array) - gfc_trans_deferred_array (sym, block); - } - else if ((!sym->attr.dummy || sym->ts.deferred) - && (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.class_pointer)) - continue; - else if ((!sym->attr.dummy || sym->ts.deferred) - && (sym->attr.allocatable - || (sym->attr.pointer && sym->attr.result) - || (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.allocatable))) - { - if (!sym->attr.save && flag_max_stack_var_size != 0) - { - tree descriptor = NULL_TREE; - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - gfc_start_block (&init); - - if (sym->ts.type == BT_CHARACTER - && sym->attr.allocatable - && !sym->attr.dimension - && sym->ts.u.cl && sym->ts.u.cl->length - && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE) - gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - - if (!sym->attr.pointer) - { - /* Nullify and automatic deallocation of allocatable - scalars. */ - e = gfc_lval_expr_from_sym (sym); - if (sym->ts.type == BT_CLASS) - gfc_add_data_component (e); - - gfc_init_se (&se, NULL); - if (sym->ts.type != BT_CLASS - || sym->ts.u.derived->attr.dimension - || sym->ts.u.derived->attr.codimension) - { - se.want_pointer = 1; - gfc_conv_expr (&se, e); - } - else if (sym->ts.type == BT_CLASS - && !CLASS_DATA (sym)->attr.dimension - && !CLASS_DATA (sym)->attr.codimension) - { - se.want_pointer = 1; - gfc_conv_expr (&se, e); - } - else - { - se.descriptor_only = 1; - gfc_conv_expr (&se, e); - descriptor = se.expr; - se.expr = gfc_conv_descriptor_data_addr (se.expr); - se.expr = build_fold_indirect_ref_loc (input_location, se.expr); - } - gfc_free_expr (e); - - if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) - { - /* Nullify when entering the scope. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (se.expr), se.expr, - fold_convert (TREE_TYPE (se.expr), - null_pointer_node)); - if (sym->attr.optional) - { - tree present = gfc_conv_expr_present (sym); - tmp = build3_loc (input_location, COND_EXPR, - void_type_node, present, tmp, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&init, tmp); - } - } - - if ((sym->attr.dummy || sym->attr.result) - && sym->ts.type == BT_CHARACTER - && sym->ts.deferred - && sym->ts.u.cl->passed_length) - tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); - else - { - gfc_restore_backend_locus (&loc); - tmp = NULL_TREE; - } - - /* Deallocate when leaving the scope. Nullifying is not - needed. */ - if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer - && !sym->ns->proc_name->attr.is_main_program) - { - if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.codimension) - tmp = gfc_deallocate_with_status (descriptor, NULL_TREE, - NULL_TREE, NULL_TREE, - NULL_TREE, true, NULL, - GFC_CAF_COARRAY_ANALYZE); - else - { - gfc_expr *expr = gfc_lval_expr_from_sym (sym); - tmp = gfc_deallocate_scalar_with_status (se.expr, - NULL_TREE, - NULL_TREE, - true, expr, - sym->ts); - gfc_free_expr (expr); - } - } - - if (sym->ts.type == BT_CLASS) - { - /* Initialize _vptr to declared type. */ - gfc_symbol *vtab; - tree rhs; - - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - e = gfc_lval_expr_from_sym (sym); - gfc_add_vptr_component (e); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, e); - gfc_free_expr (e); - if (UNLIMITED_POLY (sym)) - rhs = build_int_cst (TREE_TYPE (se.expr), 0); - else - { - vtab = gfc_find_derived_vtab (sym->ts.u.derived); - rhs = gfc_build_addr_expr (TREE_TYPE (se.expr), - gfc_get_symbol_decl (vtab)); - } - gfc_add_modify (&init, se.expr, rhs); - gfc_restore_backend_locus (&loc); - } - - gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); - } - } - else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred) - { - tree tmp = NULL; - stmtblock_t init; - - /* If we get to here, all that should be left are pointers. */ - gcc_assert (sym->attr.pointer); - - if (sym->attr.dummy) - { - gfc_start_block (&init); - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); - gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); - } - } - else if (sym->ts.deferred) - gfc_fatal_error ("Deferred type parameter not yet supported"); - else if (alloc_comp_or_fini) - gfc_trans_deferred_array (sym, block); - else if (sym->ts.type == BT_CHARACTER) - { - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - if (sym->attr.dummy || sym->attr.result) - gfc_trans_dummy_character (sym, sym->ts.u.cl, block); - else - gfc_trans_auto_character_variable (sym, block); - gfc_restore_backend_locus (&loc); - } - else if (sym->attr.assign) - { - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&sym->declared_at); - gfc_trans_assign_aux_var (sym, block); - gfc_restore_backend_locus (&loc); - } - else if (sym->ts.type == BT_DERIVED - && sym->value - && !sym->attr.data - && sym->attr.save == SAVE_NONE) - { - gfc_start_block (&tmpblock); - gfc_init_default_dt (sym, &tmpblock, false); - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), - NULL_TREE); - } - else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type) - gcc_unreachable (); - } - - gfc_init_block (&tmpblock); - - for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) - { - if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER - && f->sym->ts.u.cl->backend_decl) - { - if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL) - gfc_trans_vla_type_sizes (f->sym, &tmpblock); - } - } - - if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER - && current_fake_result_decl != NULL) - { - gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL); - if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL) - gfc_trans_vla_type_sizes (proc_sym, &tmpblock); - } - - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); -} - - -struct module_hasher : ggc_ptr_hash -{ - typedef const char *compare_type; - - static hashval_t hash (module_htab_entry *s) - { - return htab_hash_string (s->name); - } - - static bool - equal (module_htab_entry *a, const char *b) - { - return !strcmp (a->name, b); - } -}; - -static GTY (()) hash_table *module_htab; - -/* Hash and equality functions for module_htab's decls. */ - -hashval_t -module_decl_hasher::hash (tree t) -{ - const_tree n = DECL_NAME (t); - if (n == NULL_TREE) - n = TYPE_NAME (TREE_TYPE (t)); - return htab_hash_string (IDENTIFIER_POINTER (n)); -} - -bool -module_decl_hasher::equal (tree t1, const char *x2) -{ - const_tree n1 = DECL_NAME (t1); - if (n1 == NULL_TREE) - n1 = TYPE_NAME (TREE_TYPE (t1)); - return strcmp (IDENTIFIER_POINTER (n1), x2) == 0; -} - -struct module_htab_entry * -gfc_find_module (const char *name) -{ - if (! module_htab) - module_htab = hash_table::create_ggc (10); - - module_htab_entry **slot - = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT); - if (*slot == NULL) - { - module_htab_entry *entry = ggc_cleared_alloc (); - - entry->name = gfc_get_string ("%s", name); - entry->decls = hash_table::create_ggc (10); - *slot = entry; - } - return *slot; -} - -void -gfc_module_add_decl (struct module_htab_entry *entry, tree decl) -{ - const char *name; - - if (DECL_NAME (decl)) - name = IDENTIFIER_POINTER (DECL_NAME (decl)); - else - { - gcc_assert (TREE_CODE (decl) == TYPE_DECL); - name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl))); - } - tree *slot - = entry->decls->find_slot_with_hash (name, htab_hash_string (name), - INSERT); - if (*slot == NULL) - *slot = decl; -} - - -/* Generate debugging symbols for namelists. This function must come after - generate_local_decl to ensure that the variables in the namelist are - already declared. */ - -static tree -generate_namelist_decl (gfc_symbol * sym) -{ - gfc_namelist *nml; - tree decl; - vec *nml_decls = NULL; - - gcc_assert (sym->attr.flavor == FL_NAMELIST); - for (nml = sym->namelist; nml; nml = nml->next) - { - if (nml->sym->backend_decl == NULL_TREE) - { - nml->sym->attr.referenced = 1; - nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym); - } - DECL_IGNORED_P (nml->sym->backend_decl) = 0; - CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl); - } - - decl = make_node (NAMELIST_DECL); - TREE_TYPE (decl) = void_type_node; - NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls); - DECL_NAME (decl) = get_identifier (sym->name); - return decl; -} - - -/* Output an initialized decl for a module variable. */ - -static void -gfc_create_module_variable (gfc_symbol * sym) -{ - tree decl; - - /* Module functions with alternate entries are dealt with later and - would get caught by the next condition. */ - if (sym->attr.entry) - return; - - /* Make sure we convert the types of the derived types from iso_c_binding - into (void *). */ - if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c - && sym->ts.type == BT_DERIVED) - sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); - - if (gfc_fl_struct (sym->attr.flavor) - && sym->backend_decl - && TREE_CODE (sym->backend_decl) == RECORD_TYPE) - { - decl = sym->backend_decl; - gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); - - if (!sym->attr.use_assoc && !sym->attr.used_in_submodule) - { - gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE - || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl); - gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE - || DECL_CONTEXT (TYPE_STUB_DECL (decl)) - == sym->ns->proc_name->backend_decl); - } - TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl; - DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl; - gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl)); - } - - /* Only output variables, procedure pointers and array valued, - or derived type, parameters. */ - if (sym->attr.flavor != FL_VARIABLE - && !(sym->attr.flavor == FL_PARAMETER - && (sym->attr.dimension || sym->ts.type == BT_DERIVED)) - && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) - return; - - if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl) - { - decl = sym->backend_decl; - gcc_assert (DECL_FILE_SCOPE_P (decl)); - gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); - DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; - gfc_module_add_decl (cur_module, decl); - } - - /* Don't generate variables from other modules. Variables from - COMMONs and Cray pointees will already have been generated. */ - if (sym->attr.use_assoc || sym->attr.used_in_submodule - || sym->attr.in_common || sym->attr.cray_pointee) - return; - - /* Equivalenced variables arrive here after creation. */ - if (sym->backend_decl - && (sym->equiv_built || sym->attr.in_equivalence)) - return; - - if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target) - gfc_internal_error ("backend decl for module variable %qs already exists", - sym->name); - - if (sym->module && !sym->attr.result && !sym->attr.dummy - && (sym->attr.access == ACCESS_UNKNOWN - && (sym->ns->default_access == ACCESS_PRIVATE - || (sym->ns->default_access == ACCESS_UNKNOWN - && flag_module_private)))) - sym->attr.access = ACCESS_PRIVATE; - - if (warn_unused_variable && !sym->attr.referenced - && sym->attr.access == ACCESS_PRIVATE) - gfc_warning (OPT_Wunused_value, - "Unused PRIVATE module variable %qs declared at %L", - sym->name, &sym->declared_at); - - /* We always want module variables to be created. */ - sym->attr.referenced = 1; - /* Create the decl. */ - decl = gfc_get_symbol_decl (sym); - - /* Create the variable. */ - pushdecl (decl); - gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE - || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE - && sym->fn_result_spec)); - DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; - rest_of_decl_compilation (decl, 1, 0); - gfc_module_add_decl (cur_module, decl); - - /* Also add length of strings. */ - if (sym->ts.type == BT_CHARACTER) - { - tree length; - - length = sym->ts.u.cl->backend_decl; - gcc_assert (length || sym->attr.proc_pointer); - if (length && !INTEGER_CST_P (length)) - { - pushdecl (length); - rest_of_decl_compilation (length, 1, 0); - } - } - - if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable - && sym->attr.referenced && !sym->attr.use_assoc) - has_coarray_vars = true; -} - -/* Emit debug information for USE statements. */ - -static void -gfc_trans_use_stmts (gfc_namespace * ns) -{ - gfc_use_list *use_stmt; - for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next) - { - struct module_htab_entry *entry - = gfc_find_module (use_stmt->module_name); - gfc_use_rename *rent; - - if (entry->namespace_decl == NULL) - { - entry->namespace_decl - = build_decl (input_location, - NAMESPACE_DECL, - get_identifier (use_stmt->module_name), - void_type_node); - DECL_EXTERNAL (entry->namespace_decl) = 1; - } - gfc_set_backend_locus (&use_stmt->where); - if (!use_stmt->only_flag) - (*debug_hooks->imported_module_or_decl) (entry->namespace_decl, - NULL_TREE, - ns->proc_name->backend_decl, - false, false); - for (rent = use_stmt->rename; rent; rent = rent->next) - { - tree decl, local_name; - - if (rent->op != INTRINSIC_NONE) - continue; - - hashval_t hash = htab_hash_string (rent->use_name); - tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash, - INSERT); - if (*slot == NULL) - { - gfc_symtree *st; - - st = gfc_find_symtree (ns->sym_root, - rent->local_name[0] - ? rent->local_name : rent->use_name); - - /* The following can happen if a derived type is renamed. */ - if (!st) - { - char *name; - name = xstrdup (rent->local_name[0] - ? rent->local_name : rent->use_name); - name[0] = (char) TOUPPER ((unsigned char) name[0]); - st = gfc_find_symtree (ns->sym_root, name); - free (name); - gcc_assert (st); - } - - /* Sometimes, generic interfaces wind up being over-ruled by a - local symbol (see PR41062). */ - if (!st->n.sym->attr.use_assoc) - continue; - - if (st->n.sym->backend_decl - && DECL_P (st->n.sym->backend_decl) - && st->n.sym->module - && strcmp (st->n.sym->module, use_stmt->module_name) == 0) - { - gcc_assert (DECL_EXTERNAL (entry->namespace_decl) - || !VAR_P (st->n.sym->backend_decl)); - decl = copy_node (st->n.sym->backend_decl); - DECL_CONTEXT (decl) = entry->namespace_decl; - DECL_EXTERNAL (decl) = 1; - DECL_IGNORED_P (decl) = 0; - DECL_INITIAL (decl) = NULL_TREE; - } - else if (st->n.sym->attr.flavor == FL_NAMELIST - && st->n.sym->attr.use_only - && st->n.sym->module - && strcmp (st->n.sym->module, use_stmt->module_name) - == 0) - { - decl = generate_namelist_decl (st->n.sym); - DECL_CONTEXT (decl) = entry->namespace_decl; - DECL_EXTERNAL (decl) = 1; - DECL_IGNORED_P (decl) = 0; - DECL_INITIAL (decl) = NULL_TREE; - } - else - { - *slot = error_mark_node; - entry->decls->clear_slot (slot); - continue; - } - *slot = decl; - } - decl = (tree) *slot; - if (rent->local_name[0]) - local_name = get_identifier (rent->local_name); - else - local_name = NULL_TREE; - gfc_set_backend_locus (&rent->where); - (*debug_hooks->imported_module_or_decl) (decl, local_name, - ns->proc_name->backend_decl, - !use_stmt->only_flag, - false); - } - } -} - - -/* Return true if expr is a constant initializer that gfc_conv_initializer - will handle. */ - -static bool -check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, - bool pointer) -{ - gfc_constructor *c; - gfc_component *cm; - - if (pointer) - return true; - else if (array) - { - if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL) - return true; - else if (expr->expr_type == EXPR_STRUCTURE) - return check_constant_initializer (expr, ts, false, false); - else if (expr->expr_type != EXPR_ARRAY) - return false; - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c)) - { - if (c->iterator) - return false; - if (c->expr->expr_type == EXPR_STRUCTURE) - { - if (!check_constant_initializer (c->expr, ts, false, false)) - return false; - } - else if (c->expr->expr_type != EXPR_CONSTANT) - return false; - } - return true; - } - else switch (ts->type) - { - case_bt_struct: - if (expr->expr_type != EXPR_STRUCTURE) - return false; - cm = expr->ts.u.derived->components; - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c), cm = cm->next) - { - if (!c->expr || cm->attr.allocatable) - continue; - if (!check_constant_initializer (c->expr, &cm->ts, - cm->attr.dimension, - cm->attr.pointer)) - return false; - } - return true; - default: - return expr->expr_type == EXPR_CONSTANT; - } -} - -/* Emit debug info for parameters and unreferenced variables with - initializers. */ - -static void -gfc_emit_parameter_debug_info (gfc_symbol *sym) -{ - tree decl; - - if (sym->attr.flavor != FL_PARAMETER - && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced)) - return; - - if (sym->backend_decl != NULL - || sym->value == NULL - || sym->attr.use_assoc - || sym->attr.dummy - || sym->attr.result - || sym->attr.function - || sym->attr.intrinsic - || sym->attr.pointer - || sym->attr.allocatable - || sym->attr.cray_pointee - || sym->attr.threadprivate - || sym->attr.is_bind_c - || sym->attr.subref_array_pointer - || sym->attr.assign) - return; - - if (sym->ts.type == BT_CHARACTER) - { - gfc_conv_const_charlen (sym->ts.u.cl); - if (sym->ts.u.cl->backend_decl == NULL - || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST) - return; - } - else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) - return; - - if (sym->as) - { - int n; - - if (sym->as->type != AS_EXPLICIT) - return; - for (n = 0; n < sym->as->rank; n++) - if (sym->as->lower[n]->expr_type != EXPR_CONSTANT - || sym->as->upper[n] == NULL - || sym->as->upper[n]->expr_type != EXPR_CONSTANT) - return; - } - - if (!check_constant_initializer (sym->value, &sym->ts, - sym->attr.dimension, false)) - return; - - if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) - return; - - /* Create the decl for the variable or constant. */ - decl = build_decl (input_location, - sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL, - gfc_sym_identifier (sym), gfc_sym_type (sym)); - if (sym->attr.flavor == FL_PARAMETER) - TREE_READONLY (decl) = 1; - gfc_set_decl_location (decl, &sym->declared_at); - if (sym->attr.dimension) - GFC_DECL_PACKED_ARRAY (decl) = 1; - DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; - TREE_STATIC (decl) = 1; - TREE_USED (decl) = 1; - if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL) - TREE_PUBLIC (decl) = 1; - DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, - TREE_TYPE (decl), - sym->attr.dimension, - false, false); - debug_hooks->early_global_decl (decl); -} - - -static void -generate_coarray_sym_init (gfc_symbol *sym) -{ - tree tmp, size, decl, token, desc; - bool is_lock_type, is_event_type; - int reg_type; - gfc_se se; - symbol_attribute attr; - - if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension - || sym->attr.use_assoc || !sym->attr.referenced - || sym->attr.select_type_temporary) - return; - - decl = sym->backend_decl; - TREE_USED(decl) = 1; - gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); - - is_lock_type = sym->ts.type == BT_DERIVED - && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE; - - is_event_type = sym->ts.type == BT_DERIVED - && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE; - - /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108 - to make sure the variable is not optimized away. */ - DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1; - - /* For lock types, we pass the array size as only the library knows the - size of the variable. */ - if (is_lock_type || is_event_type) - size = gfc_index_one_node; - else - size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl))); - - /* Ensure that we do not have size=0 for zero-sized arrays. */ - size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, - fold_convert (size_type_node, size), - build_int_cst (size_type_node, 1)); - - if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl))) - { - tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl)); - size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - fold_convert (size_type_node, tmp), size); - } - - gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE); - token = gfc_build_addr_expr (ppvoid_type_node, - GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl))); - if (is_lock_type) - reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC; - else if (is_event_type) - reg_type = GFC_CAF_EVENT_STATIC; - else - reg_type = GFC_CAF_COARRAY_STATIC; - - /* Compile the symbol attribute. */ - if (sym->ts.type == BT_CLASS) - { - attr = CLASS_DATA (sym)->attr; - /* The pointer attribute is always set on classes, overwrite it with the - class_pointer attribute, which denotes the pointer for classes. */ - attr.pointer = attr.class_pointer; - } - else - attr = sym->attr; - gfc_init_se (&se, NULL); - desc = gfc_conv_scalar_to_descriptor (&se, decl, attr); - gfc_add_block_to_block (&caf_init_block, &se.pre); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size, - build_int_cst (integer_type_node, reg_type), - token, gfc_build_addr_expr (pvoid_type_node, desc), - null_pointer_node, /* stat. */ - null_pointer_node, /* errgmsg. */ - build_zero_cst (size_type_node)); /* errmsg_len. */ - gfc_add_expr_to_block (&caf_init_block, tmp); - gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), - gfc_conv_descriptor_data_get (desc))); - - /* Handle "static" initializer. */ - if (sym->value) - { - if (sym->value->expr_type == EXPR_ARRAY) - { - gfc_constructor *c, *cnext; - - /* Test if the array has more than one element. */ - c = gfc_constructor_first (sym->value->value.constructor); - gcc_assert (c); /* Empty constructor should not happen here. */ - cnext = gfc_constructor_next (c); - - if (cnext) - { - /* An EXPR_ARRAY with a rank > 1 here has to come from a - DATA statement. Set its rank here as not to confuse - the following steps. */ - sym->value->rank = 1; - } - else - { - /* There is only a single value in the constructor, use - it directly for the assignment. */ - gfc_expr *new_expr; - new_expr = gfc_copy_expr (c->expr); - gfc_free_expr (sym->value); - sym->value = new_expr; - } - } - - sym->attr.pointer = 1; - tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value, - true, false); - sym->attr.pointer = 0; - gfc_add_expr_to_block (&caf_init_block, tmp); - } - else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp) - { - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as - ? sym->as->rank : 0, - GFC_STRUCTURE_CAF_MODE_IN_COARRAY); - gfc_add_expr_to_block (&caf_init_block, tmp); - } -} - - -/* Generate constructor function to initialize static, nonallocatable - coarrays. */ - -static void -generate_coarray_init (gfc_namespace * ns __attribute((unused))) -{ - tree fndecl, tmp, decl, save_fn_decl; - - save_fn_decl = current_function_decl; - push_function_context (); - - tmp = build_function_type_list (void_type_node, NULL_TREE); - fndecl = build_decl (input_location, FUNCTION_DECL, - create_tmp_var_name ("_caf_init"), tmp); - - DECL_STATIC_CONSTRUCTOR (fndecl) = 1; - SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY); - - decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node); - DECL_ARTIFICIAL (decl) = 1; - DECL_IGNORED_P (decl) = 1; - DECL_CONTEXT (decl) = fndecl; - DECL_RESULT (fndecl) = decl; - - pushdecl (fndecl); - current_function_decl = fndecl; - announce_function (fndecl); - - rest_of_decl_compilation (fndecl, 0, 0); - make_decl_rtl (fndecl); - allocate_struct_function (fndecl, false); - - pushlevel (); - gfc_init_block (&caf_init_block); - - gfc_traverse_ns (ns, generate_coarray_sym_init); - - DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block); - decl = getdecls (); - - poplevel (1, 1); - BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; - - DECL_SAVED_TREE (fndecl) - = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node, - decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl)); - dump_function (TDI_original, fndecl); - - cfun->function_end_locus = input_location; - set_cfun (NULL); - - if (decl_function_context (fndecl)) - (void) cgraph_node::create (fndecl); - else - cgraph_node::finalize_function (fndecl, true); - - pop_function_context (); - current_function_decl = save_fn_decl; -} - - -static void -create_module_nml_decl (gfc_symbol *sym) -{ - if (sym->attr.flavor == FL_NAMELIST) - { - tree decl = generate_namelist_decl (sym); - pushdecl (decl); - gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); - DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; - rest_of_decl_compilation (decl, 1, 0); - gfc_module_add_decl (cur_module, decl); - } -} - - -/* Generate all the required code for module variables. */ - -void -gfc_generate_module_vars (gfc_namespace * ns) -{ - module_namespace = ns; - cur_module = gfc_find_module (ns->proc_name->name); - - /* Check if the frontend left the namespace in a reasonable state. */ - gcc_assert (ns->proc_name && !ns->proc_name->tlink); - - /* Generate COMMON blocks. */ - gfc_trans_common (ns); - - has_coarray_vars = false; - - /* Create decls for all the module variables. */ - gfc_traverse_ns (ns, gfc_create_module_variable); - gfc_traverse_ns (ns, create_module_nml_decl); - - if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) - generate_coarray_init (ns); - - cur_module = NULL; - - gfc_trans_use_stmts (ns); - gfc_traverse_ns (ns, gfc_emit_parameter_debug_info); -} - - -static void -gfc_generate_contained_functions (gfc_namespace * parent) -{ - gfc_namespace *ns; - - /* We create all the prototypes before generating any code. */ - for (ns = parent->contained; ns; ns = ns->sibling) - { - /* Skip namespaces from used modules. */ - if (ns->parent != parent) - continue; - - gfc_create_function_decl (ns, false); - } - - for (ns = parent->contained; ns; ns = ns->sibling) - { - /* Skip namespaces from used modules. */ - if (ns->parent != parent) - continue; - - gfc_generate_function_code (ns); - } -} - - -/* Drill down through expressions for the array specification bounds and - character length calling generate_local_decl for all those variables - that have not already been declared. */ - -static void -generate_local_decl (gfc_symbol *); - -/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ - -static bool -expr_decls (gfc_expr *e, gfc_symbol *sym, - int *f ATTRIBUTE_UNUSED) -{ - if (e->expr_type != EXPR_VARIABLE - || sym == e->symtree->n.sym - || e->symtree->n.sym->mark - || e->symtree->n.sym->ns != sym->ns) - return false; - - generate_local_decl (e->symtree->n.sym); - return false; -} - -static void -generate_expr_decls (gfc_symbol *sym, gfc_expr *e) -{ - gfc_traverse_expr (e, sym, expr_decls, 0); -} - - -/* Check for dependencies in the character length and array spec. */ - -static void -generate_dependency_declarations (gfc_symbol *sym) -{ - int i; - - if (sym->ts.type == BT_CHARACTER - && sym->ts.u.cl - && sym->ts.u.cl->length - && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) - generate_expr_decls (sym, sym->ts.u.cl->length); - - if (sym->as && sym->as->rank) - { - for (i = 0; i < sym->as->rank; i++) - { - generate_expr_decls (sym, sym->as->lower[i]); - generate_expr_decls (sym, sym->as->upper[i]); - } - } -} - - -/* Generate decls for all local variables. We do this to ensure correct - handling of expressions which only appear in the specification of - other functions. */ - -static void -generate_local_decl (gfc_symbol * sym) -{ - if (sym->attr.flavor == FL_VARIABLE) - { - if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable - && sym->attr.referenced && !sym->attr.use_assoc) - has_coarray_vars = true; - - if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master) - generate_dependency_declarations (sym); - - if (sym->attr.referenced) - gfc_get_symbol_decl (sym); - - /* Warnings for unused dummy arguments. */ - else if (sym->attr.dummy && !sym->attr.in_namelist) - { - /* INTENT(out) dummy arguments are likely meant to be set. */ - if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT) - { - if (sym->ts.type != BT_DERIVED) - gfc_warning (OPT_Wunused_dummy_argument, - "Dummy argument %qs at %L was declared " - "INTENT(OUT) but was not set", sym->name, - &sym->declared_at); - else if (!gfc_has_default_initializer (sym->ts.u.derived) - && !sym->ts.u.derived->attr.zero_comp) - gfc_warning (OPT_Wunused_dummy_argument, - "Derived-type dummy argument %qs at %L was " - "declared INTENT(OUT) but was not set and " - "does not have a default initializer", - sym->name, &sym->declared_at); - if (sym->backend_decl != NULL_TREE) - suppress_warning (sym->backend_decl); - } - else if (warn_unused_dummy_argument) - { - if (!sym->attr.artificial) - gfc_warning (OPT_Wunused_dummy_argument, - "Unused dummy argument %qs at %L", sym->name, - &sym->declared_at); - - if (sym->backend_decl != NULL_TREE) - suppress_warning (sym->backend_decl); - } - } - - /* Warn for unused variables, but not if they're inside a common - block or a namelist. */ - else if (warn_unused_variable - && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist)) - { - if (sym->attr.use_only) - { - gfc_warning (OPT_Wunused_variable, - "Unused module variable %qs which has been " - "explicitly imported at %L", sym->name, - &sym->declared_at); - if (sym->backend_decl != NULL_TREE) - suppress_warning (sym->backend_decl); - } - else if (!sym->attr.use_assoc) - { - /* Corner case: the symbol may be an entry point. At this point, - it may appear to be an unused variable. Suppress warning. */ - bool enter = false; - gfc_entry_list *el; - - for (el = sym->ns->entries; el; el=el->next) - if (strcmp(sym->name, el->sym->name) == 0) - enter = true; - - if (!enter) - gfc_warning (OPT_Wunused_variable, - "Unused variable %qs declared at %L", - sym->name, &sym->declared_at); - if (sym->backend_decl != NULL_TREE) - suppress_warning (sym->backend_decl); - } - } - - /* For variable length CHARACTER parameters, the PARM_DECL already - references the length variable, so force gfc_get_symbol_decl - even when not referenced. If optimize > 0, it will be optimized - away anyway. But do this only after emitting -Wunused-parameter - warning if requested. */ - if (sym->attr.dummy && !sym->attr.referenced - && sym->ts.type == BT_CHARACTER - && sym->ts.u.cl->backend_decl != NULL - && VAR_P (sym->ts.u.cl->backend_decl)) - { - sym->attr.referenced = 1; - gfc_get_symbol_decl (sym); - } - - /* INTENT(out) dummy arguments and result variables with allocatable - components are reset by default and need to be set referenced to - generate the code for nullification and automatic lengths. */ - if (!sym->attr.referenced - && sym->ts.type == BT_DERIVED - && sym->ts.u.derived->attr.alloc_comp - && !sym->attr.pointer - && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT) - || - (sym->attr.result && sym != sym->result))) - { - sym->attr.referenced = 1; - gfc_get_symbol_decl (sym); - } - - /* Check for dependencies in the array specification and string - length, adding the necessary declarations to the function. We - mark the symbol now, as well as in traverse_ns, to prevent - getting stuck in a circular dependency. */ - sym->mark = 1; - } - else if (sym->attr.flavor == FL_PARAMETER) - { - if (warn_unused_parameter - && !sym->attr.referenced) - { - if (!sym->attr.use_assoc) - gfc_warning (OPT_Wunused_parameter, - "Unused parameter %qs declared at %L", sym->name, - &sym->declared_at); - else if (sym->attr.use_only) - gfc_warning (OPT_Wunused_parameter, - "Unused parameter %qs which has been explicitly " - "imported at %L", sym->name, &sym->declared_at); - } - - if (sym->ns && sym->ns->construct_entities) - { - /* Construction of the intrinsic modules within a BLOCK - construct, where ONLY and RENAMED entities are included, - seems to be bogus. This is a workaround that can be removed - if someone ever takes on the task to creating full-fledge - modules. See PR 69455. */ - if (sym->attr.referenced - && sym->from_intmod != INTMOD_ISO_C_BINDING - && sym->from_intmod != INTMOD_ISO_FORTRAN_ENV) - gfc_get_symbol_decl (sym); - sym->mark = 1; - } - } - else if (sym->attr.flavor == FL_PROCEDURE) - { - /* TODO: move to the appropriate place in resolve.c. */ - if (warn_return_type > 0 - && sym->attr.function - && sym->result - && sym != sym->result - && !sym->result->attr.referenced - && !sym->attr.use_assoc - && sym->attr.if_source != IFSRC_IFBODY) - { - gfc_warning (OPT_Wreturn_type, - "Return value %qs of function %qs declared at " - "%L not set", sym->result->name, sym->name, - &sym->result->declared_at); - - /* Prevents "Unused variable" warning for RESULT variables. */ - sym->result->mark = 1; - } - } - - if (sym->attr.dummy == 1) - { - /* The tree type for scalar character dummy arguments of BIND(C) - procedures, if they are passed by value, should be unsigned char. - The value attribute implies the dummy is a scalar. */ - if (sym->attr.value == 1 && sym->backend_decl != NULL - && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop - && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c) - { - /* 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. */ - 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); - } - - /* Unused procedure passed as dummy argument. */ - if (sym->attr.flavor == FL_PROCEDURE) - { - if (!sym->attr.referenced && !sym->attr.artificial) - { - if (warn_unused_dummy_argument) - gfc_warning (OPT_Wunused_dummy_argument, - "Unused dummy argument %qs at %L", sym->name, - &sym->declared_at); - } - - /* Silence bogus "unused parameter" warnings from the - middle end. */ - if (sym->backend_decl != NULL_TREE) - suppress_warning (sym->backend_decl); - } - } - - /* Make sure we convert the types of the derived types from iso_c_binding - into (void *). */ - if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c - && sym->ts.type == BT_DERIVED) - sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); -} - - -static void -generate_local_nml_decl (gfc_symbol * sym) -{ - if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc) - { - tree decl = generate_namelist_decl (sym); - pushdecl (decl); - } -} - - -static void -generate_local_vars (gfc_namespace * ns) -{ - gfc_traverse_ns (ns, generate_local_decl); - gfc_traverse_ns (ns, generate_local_nml_decl); -} - - -/* Generate a switch statement to jump to the correct entry point. Also - creates the label decls for the entry points. */ - -static tree -gfc_trans_entry_master_switch (gfc_entry_list * el) -{ - stmtblock_t block; - tree label; - tree tmp; - tree val; - - gfc_init_block (&block); - for (; el; el = el->next) - { - /* Add the case label. */ - label = gfc_build_label_decl (NULL_TREE); - val = build_int_cst (gfc_array_index_type, el->id); - tmp = build_case_label (val, NULL_TREE, label); - gfc_add_expr_to_block (&block, tmp); - - /* And jump to the actual entry point. */ - label = gfc_build_label_decl (NULL_TREE); - tmp = build1_v (GOTO_EXPR, label); - gfc_add_expr_to_block (&block, tmp); - - /* Save the label decl. */ - el->label = label; - } - tmp = gfc_finish_block (&block); - /* The first argument selects the entry point. */ - val = DECL_ARGUMENTS (current_function_decl); - tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp); - return tmp; -} - - -/* Add code to string lengths of actual arguments passed to a function against - the expected lengths of the dummy arguments. */ - -static void -add_argument_checking (stmtblock_t *block, gfc_symbol *sym) -{ - gfc_formal_arglist *formal; - - for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next) - if (formal->sym && formal->sym->ts.type == BT_CHARACTER - && !formal->sym->ts.deferred) - { - enum tree_code comparison; - tree cond; - tree argname; - gfc_symbol *fsym; - gfc_charlen *cl; - const char *message; - - fsym = formal->sym; - cl = fsym->ts.u.cl; - - gcc_assert (cl); - gcc_assert (cl->passed_length != NULL_TREE); - gcc_assert (cl->backend_decl != NULL_TREE); - - /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the - string lengths must match exactly. Otherwise, it is only required - that the actual string length is *at least* the expected one. - Sequence association allows for a mismatch of the string length - if the actual argument is (part of) an array, but only if the - dummy argument is an array. (See "Sequence association" in - Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */ - if (fsym->attr.pointer || fsym->attr.allocatable - || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE - || fsym->as->type == AS_ASSUMED_RANK))) - { - comparison = NE_EXPR; - message = _("Actual string length does not match the declared one" - " for dummy argument '%s' (%ld/%ld)"); - } - else if (fsym->as && fsym->as->rank != 0) - continue; - else - { - comparison = LT_EXPR; - message = _("Actual string length is shorter than the declared one" - " for dummy argument '%s' (%ld/%ld)"); - } - - /* Build the condition. For optional arguments, an actual length - of 0 is also acceptable if the associated string is NULL, which - means the argument was not passed. */ - cond = fold_build2_loc (input_location, comparison, logical_type_node, - cl->passed_length, cl->backend_decl); - if (fsym->attr.optional) - { - tree not_absent; - tree not_0length; - tree absent_failed; - - not_0length = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - cl->passed_length, - build_zero_cst - (TREE_TYPE (cl->passed_length))); - /* The symbol needs to be referenced for gfc_get_symbol_decl. */ - fsym->attr.referenced = 1; - not_absent = gfc_conv_expr_present (fsym); - - absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, not_0length, - not_absent); - - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, cond, absent_failed); - } - - /* Build the runtime check. */ - argname = gfc_build_cstring_const (fsym->name); - argname = gfc_build_addr_expr (pchar_type_node, argname); - gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at, - message, argname, - fold_convert (long_integer_type_node, - cl->passed_length), - fold_convert (long_integer_type_node, - cl->backend_decl)); - } -} - - -static void -create_main_function (tree fndecl) -{ - tree old_context; - tree ftn_main; - tree tmp, decl, result_decl, argc, argv, typelist, arglist; - stmtblock_t body; - - old_context = current_function_decl; - - if (old_context) - { - push_function_context (); - saved_parent_function_decls = saved_function_decls; - saved_function_decls = NULL_TREE; - } - - /* main() function must be declared with global scope. */ - gcc_assert (current_function_decl == NULL_TREE); - - /* Declare the function. */ - tmp = build_function_type_list (integer_type_node, integer_type_node, - build_pointer_type (pchar_type_node), - NULL_TREE); - main_identifier_node = get_identifier ("main"); - ftn_main = build_decl (input_location, FUNCTION_DECL, - main_identifier_node, tmp); - DECL_EXTERNAL (ftn_main) = 0; - TREE_PUBLIC (ftn_main) = 1; - TREE_STATIC (ftn_main) = 1; - DECL_ATTRIBUTES (ftn_main) - = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE); - - /* Setup the result declaration (for "return 0"). */ - result_decl = build_decl (input_location, - RESULT_DECL, NULL_TREE, integer_type_node); - DECL_ARTIFICIAL (result_decl) = 1; - DECL_IGNORED_P (result_decl) = 1; - DECL_CONTEXT (result_decl) = ftn_main; - DECL_RESULT (ftn_main) = result_decl; - - pushdecl (ftn_main); - - /* Get the arguments. */ - - arglist = NULL_TREE; - typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main)); - - tmp = TREE_VALUE (typelist); - argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp); - DECL_CONTEXT (argc) = ftn_main; - DECL_ARG_TYPE (argc) = TREE_VALUE (typelist); - TREE_READONLY (argc) = 1; - gfc_finish_decl (argc); - arglist = chainon (arglist, argc); - - typelist = TREE_CHAIN (typelist); - tmp = TREE_VALUE (typelist); - argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp); - DECL_CONTEXT (argv) = ftn_main; - DECL_ARG_TYPE (argv) = TREE_VALUE (typelist); - TREE_READONLY (argv) = 1; - DECL_BY_REFERENCE (argv) = 1; - gfc_finish_decl (argv); - arglist = chainon (arglist, argv); - - DECL_ARGUMENTS (ftn_main) = arglist; - current_function_decl = ftn_main; - announce_function (ftn_main); - - rest_of_decl_compilation (ftn_main, 1, 0); - make_decl_rtl (ftn_main); - allocate_struct_function (ftn_main, false); - pushlevel (); - - gfc_init_block (&body); - - /* Call some libgfortran initialization routines, call then MAIN__(). */ - - /* Call _gfortran_caf_init (*argc, ***argv). */ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree pint_type, pppchar_type; - pint_type = build_pointer_type (integer_type_node); - pppchar_type - = build_pointer_type (build_pointer_type (pchar_type_node)); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2, - gfc_build_addr_expr (pint_type, argc), - gfc_build_addr_expr (pppchar_type, argv)); - gfc_add_expr_to_block (&body, tmp); - } - - /* Call _gfortran_set_args (argc, argv). */ - TREE_USED (argc) = 1; - TREE_USED (argv) = 1; - tmp = build_call_expr_loc (input_location, - gfor_fndecl_set_args, 2, argc, argv); - gfc_add_expr_to_block (&body, tmp); - - /* Add a call to set_options to set up the runtime library Fortran - language standard parameters. */ - { - tree array_type, array, var; - vec *v = NULL; - static const int noptions = 7; - - /* Passing a new option to the library requires three modifications: - + add it to the tree_cons list below - + change the noptions variable above - + modify the library (runtime/compile_options.c)! */ - - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, - build_int_cst (integer_type_node, - gfc_option.warn_std)); - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, - build_int_cst (integer_type_node, - gfc_option.allow_std)); - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, - build_int_cst (integer_type_node, pedantic)); - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, - build_int_cst (integer_type_node, flag_backtrace)); - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, - build_int_cst (integer_type_node, flag_sign_zero)); - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, - build_int_cst (integer_type_node, - (gfc_option.rtcheck - & GFC_RTCHECK_BOUNDS))); - CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, - build_int_cst (integer_type_node, - gfc_option.fpe_summary)); - - array_type = build_array_type_nelts (integer_type_node, noptions); - array = build_constructor (array_type, v); - TREE_CONSTANT (array) = 1; - TREE_STATIC (array) = 1; - - /* Create a static variable to hold the jump table. */ - var = build_decl (input_location, VAR_DECL, - create_tmp_var_name ("options"), array_type); - DECL_ARTIFICIAL (var) = 1; - DECL_IGNORED_P (var) = 1; - TREE_CONSTANT (var) = 1; - TREE_STATIC (var) = 1; - TREE_READONLY (var) = 1; - DECL_INITIAL (var) = array; - pushdecl (var); - var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var); - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_set_options, 2, - build_int_cst (integer_type_node, noptions), var); - gfc_add_expr_to_block (&body, tmp); - } - - /* If -ffpe-trap option was provided, add a call to set_fpe so that - the library will raise a FPE when needed. */ - if (gfc_option.fpe != 0) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_set_fpe, 1, - build_int_cst (integer_type_node, - gfc_option.fpe)); - gfc_add_expr_to_block (&body, tmp); - } - - /* If this is the main program and an -fconvert option was provided, - add a call to set_convert. */ - - if (flag_convert != GFC_FLAG_CONVERT_NATIVE) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_set_convert, 1, - build_int_cst (integer_type_node, flag_convert)); - gfc_add_expr_to_block (&body, tmp); - } - - /* If this is the main program and an -frecord-marker option was provided, - add a call to set_record_marker. */ - - if (flag_record_marker != 0) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_set_record_marker, 1, - build_int_cst (integer_type_node, - flag_record_marker)); - gfc_add_expr_to_block (&body, tmp); - } - - if (flag_max_subrecord_length != 0) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_set_max_subrecord_length, 1, - build_int_cst (integer_type_node, - flag_max_subrecord_length)); - gfc_add_expr_to_block (&body, tmp); - } - - /* Call MAIN__(). */ - tmp = build_call_expr_loc (input_location, - fndecl, 0); - gfc_add_expr_to_block (&body, tmp); - - /* Mark MAIN__ as used. */ - TREE_USED (fndecl) = 1; - - /* Coarray: Call _gfortran_caf_finalize(void). */ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0); - gfc_add_expr_to_block (&body, tmp); - } - - /* "return 0". */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node, - DECL_RESULT (ftn_main), - build_int_cst (integer_type_node, 0)); - tmp = build1_v (RETURN_EXPR, tmp); - gfc_add_expr_to_block (&body, tmp); - - - DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body); - decl = getdecls (); - - /* Finish off this function and send it for code generation. */ - poplevel (1, 1); - BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main; - - DECL_SAVED_TREE (ftn_main) - = fold_build3_loc (DECL_SOURCE_LOCATION (ftn_main), BIND_EXPR, - void_type_node, decl, DECL_SAVED_TREE (ftn_main), - DECL_INITIAL (ftn_main)); - - /* Output the GENERIC tree. */ - dump_function (TDI_original, ftn_main); - - cgraph_node::finalize_function (ftn_main, true); - - if (old_context) - { - pop_function_context (); - saved_function_decls = saved_parent_function_decls; - } - current_function_decl = old_context; -} - - -/* Generate an appropriate return-statement for a procedure. */ - -tree -gfc_generate_return (void) -{ - gfc_symbol* sym; - tree result; - tree fndecl; - - sym = current_procedure_symbol; - fndecl = sym->backend_decl; - - if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node) - result = NULL_TREE; - else - { - result = get_proc_result (sym); - - /* Set the return value to the dummy result variable. The - types may be different for scalar default REAL functions - with -ff2c, therefore we have to convert. */ - if (result != NULL_TREE) - { - result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result); - result = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (result), DECL_RESULT (fndecl), - result); - } - else - { - /* If the function does not have a result variable, result is - NULL_TREE, and a 'return' is generated without a variable. - The following generates a 'return __result_XXX' where XXX is - the function name. */ - if (sym == sym->result && sym->attr.function) - { - result = gfc_get_fake_result_decl (sym, 0); - result = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (result), - DECL_RESULT (fndecl), result); - } - } - } - - return build1_v (RETURN_EXPR, result); -} - - -static void -is_from_ieee_module (gfc_symbol *sym) -{ - if (sym->from_intmod == INTMOD_IEEE_FEATURES - || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS - || sym->from_intmod == INTMOD_IEEE_ARITHMETIC) - seen_ieee_symbol = 1; -} - - -static int -is_ieee_module_used (gfc_namespace *ns) -{ - seen_ieee_symbol = 0; - gfc_traverse_ns (ns, is_from_ieee_module); - return seen_ieee_symbol; -} - - -static gfc_omp_clauses *module_oacc_clauses; - - -static void -add_clause (gfc_symbol *sym, gfc_omp_map_op map_op) -{ - gfc_omp_namelist *n; - - n = gfc_get_omp_namelist (); - n->sym = sym; - n->u.map_op = map_op; - - if (!module_oacc_clauses) - module_oacc_clauses = gfc_get_omp_clauses (); - - if (module_oacc_clauses->lists[OMP_LIST_MAP]) - n->next = module_oacc_clauses->lists[OMP_LIST_MAP]; - - module_oacc_clauses->lists[OMP_LIST_MAP] = n; -} - - -static void -find_module_oacc_declare_clauses (gfc_symbol *sym) -{ - if (sym->attr.use_assoc) - { - gfc_omp_map_op map_op; - - if (sym->attr.oacc_declare_create) - map_op = OMP_MAP_FORCE_ALLOC; - - if (sym->attr.oacc_declare_copyin) - map_op = OMP_MAP_FORCE_TO; - - if (sym->attr.oacc_declare_deviceptr) - map_op = OMP_MAP_FORCE_DEVICEPTR; - - if (sym->attr.oacc_declare_device_resident) - map_op = OMP_MAP_DEVICE_RESIDENT; - - if (sym->attr.oacc_declare_create - || sym->attr.oacc_declare_copyin - || sym->attr.oacc_declare_deviceptr - || sym->attr.oacc_declare_device_resident) - { - sym->attr.referenced = 1; - add_clause (sym, map_op); - } - } -} - - -void -finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block) -{ - gfc_code *code; - gfc_oacc_declare *oc; - locus where = gfc_current_locus; - gfc_omp_clauses *omp_clauses = NULL; - gfc_omp_namelist *n, *p; - - module_oacc_clauses = NULL; - gfc_traverse_ns (ns, find_module_oacc_declare_clauses); - - if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM) - { - gfc_oacc_declare *new_oc; - - new_oc = gfc_get_oacc_declare (); - new_oc->next = ns->oacc_declare; - new_oc->clauses = module_oacc_clauses; - - ns->oacc_declare = new_oc; - } - - if (!ns->oacc_declare) - return; - - for (oc = ns->oacc_declare; oc; oc = oc->next) - { - if (oc->module_var) - continue; - - if (block) - gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed " - "in BLOCK construct", &oc->loc); - - - if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP]) - { - if (omp_clauses == NULL) - { - omp_clauses = oc->clauses; - continue; - } - - for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next) - ; - - gcc_assert (p->next == NULL); - - p->next = omp_clauses->lists[OMP_LIST_MAP]; - omp_clauses = oc->clauses; - } - } - - if (!omp_clauses) - return; - - for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next) - { - switch (n->u.map_op) - { - case OMP_MAP_DEVICE_RESIDENT: - n->u.map_op = OMP_MAP_FORCE_ALLOC; - break; - - default: - break; - } - } - - code = XCNEW (gfc_code); - code->op = EXEC_OACC_DECLARE; - code->loc = where; - - code->ext.oacc_declare = gfc_get_oacc_declare (); - code->ext.oacc_declare->clauses = omp_clauses; - - code->block = XCNEW (gfc_code); - code->block->op = EXEC_OACC_DECLARE; - code->block->loc = where; - - if (ns->code) - code->block->next = ns->code; - - ns->code = code; - - return; -} - -static void -gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, - tree cfi_desc, tree gfc_desc, gfc_symbol *sym) -{ - stmtblock_t block; - gfc_init_block (&block); - tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc); - tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE; - bool do_copy_inout = false; - - /* When allocatable + intent out, free the cfi descriptor. */ - if (sym->attr.allocatable && sym->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)); - } - - /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - char *msg; - tree tmp3; - msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor " - "passed to dummy argument %s", CFI_VERSION, sym->name); - tmp2 = gfc_get_cfi_desc_version (cfi); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2, - build_int_cst (TREE_TYPE (tmp2), CFI_VERSION)); - gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, - msg, tmp2); - free (msg); - - /* Rank check; however, for character(len=*), assumed/explicit-size arrays - are permitted to differ in rank according to the Fortran rules. */ - if (sym->as && sym->as->type != AS_ASSUMED_SIZE - && sym->as->type != AS_EXPLICIT) - { - if (sym->as->rank != -1) - msg = xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor " - "passed to dummy argument %s", sym->as->rank, - sym->name); - else - msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI " - "descriptor passed to dummy argument %s", - CFI_MAX_RANK, sym->name); - - tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi); - if (sym->as->rank != -1) - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - tmp, build_int_cst (signed_char_type_node, - sym->as->rank)); - else - { - tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, - tmp, build_zero_cst (TREE_TYPE (tmp))); - tmp2 = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, tmp2, - build_int_cst (TREE_TYPE (tmp2), - CFI_MAX_RANK)); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, tmp, tmp2); - } - gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, - msg, tmp3); - free (msg); - } - - tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi); - if (sym->attr.allocatable || sym->attr.pointer) - { - int attr = (sym->attr.pointer ? CFI_attribute_pointer - : CFI_attribute_allocatable); - msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI " - "descriptor passed to dummy argument %s with %s " - "attribute", attr, sym->name, - sym->attr.pointer ? "pointer" : "allocatable"); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), attr)); - } - else - { - int amin = MIN (CFI_attribute_pointer, - MIN (CFI_attribute_allocatable, CFI_attribute_other)); - int amax = MAX (CFI_attribute_pointer, - MAX (CFI_attribute_allocatable, CFI_attribute_other)); - msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI " - "descriptor passed to nonallocatable, nonpointer " - "dummy argument %s", amin, amax, sym->name); - tmp2 = tmp; - tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), amin)); - tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2, - build_int_cst (TREE_TYPE (tmp2), amax)); - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, tmp, tmp2); - gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, - msg, tmp3); - free (msg); - msg = xasprintf ("Invalid unallocatated/unassociated CFI " - "descriptor passed to nonallocatable, nonpointer " - "dummy argument %s", sym->name); - tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi), - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - tmp, null_pointer_node); - } - gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, - msg, tmp3); - free (msg); - - if (sym->ts.type != BT_ASSUMED) - { - int type = CFI_type_other; - if (sym->ts.f90_type == BT_VOID) - { - type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR - ? CFI_type_cfunptr : CFI_type_cptr); - } - else - switch (sym->ts.type) - { - case BT_INTEGER: - case BT_LOGICAL: - case BT_REAL: - case BT_COMPLEX: - type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind); - break; - case BT_CHARACTER: - type = CFI_type_from_type_kind (CFI_type_Character, - sym->ts.kind); - break; - case BT_DERIVED: - type = CFI_type_struct; - break; - case BT_VOID: - type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR - ? CFI_type_cfunptr : CFI_type_cptr); - break; - case BT_ASSUMED: - case BT_CLASS: - case BT_PROCEDURE: - case BT_HOLLERITH: - case BT_UNION: - case BT_BOZ: - case BT_UNKNOWN: - gcc_unreachable (); - } - msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor" - " passed to dummy argument %s", type, sym->name); - tmp2 = tmp = gfc_get_cfi_desc_type (cfi); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), type)); - gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, - msg, tmp2); - free (msg); - } - } - - if (!sym->attr.referenced) - goto done; - - /* Set string length for len=* and len=:, otherwise, it is already set. */ - if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length) - { - tmp = fold_convert (gfc_array_index_type, - gfc_get_cfi_desc_elem_len (cfi)); - if (sym->ts.kind != 1) - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_array_index_type, tmp, - build_int_cst (gfc_charlen_type_node, - sym->ts.kind)); - gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp); - } - - if (sym->ts.type == BT_CHARACTER - && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - { - gfc_conv_string_length (sym->ts.u.cl, NULL, init); - gfc_trans_vla_type_sizes (sym, init); - } - - /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr. - assumed-size/explicit-size arrays end up here for character(len=*) - only. */ - if (!sym->attr.dimension || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - { - tmp = gfc_get_cfi_desc_base_addr (cfi); - gfc_add_modify (&block, gfc_desc, - fold_convert (TREE_TYPE (gfc_desc), tmp)); - if (!sym->attr.dimension) - goto done; - } - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - { - /* gfc->dtype = ... (from declaration, not from cfi). */ - etype = gfc_get_element_type (TREE_TYPE (gfc_desc)); - gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc), - gfc_get_dtype_rank_type (sym->as->rank, etype)); - /* gfc->data = cfi->base_addr. */ - gfc_conv_descriptor_data_set (&block, gfc_desc, - gfc_get_cfi_desc_base_addr (cfi)); - } - - if (sym->ts.type == BT_ASSUMED) - { - /* For type(*), take elem_len + dtype.type from the actual argument. */ - gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc), - gfc_get_cfi_desc_elem_len (cfi)); - tree cond; - tree ctype = gfc_get_cfi_desc_type (cfi); - ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype), - ctype, build_int_cst (TREE_TYPE (ctype), - CFI_type_mask)); - tree type = gfc_conv_descriptor_type (gfc_desc); - - /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */ - /* 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, ctype, - build_int_cst (TREE_TYPE (ctype), CFI_type_cptr)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, - build_int_cst (TREE_TYPE (type), BT_VOID)); - tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - type, - build_int_cst (TREE_TYPE (type), BT_UNKNOWN)); - tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - tmp, tmp2); - /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, - build_int_cst (TREE_TYPE (ctype), - CFI_type_struct)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, - build_int_cst (TREE_TYPE (type), BT_DERIVED)); - tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - tmp, tmp2); - /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */ - /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if' - before (see below, as generated bottom up). */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, - build_int_cst (TREE_TYPE (ctype), - CFI_type_Character)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, - build_int_cst (TREE_TYPE (type), BT_CHARACTER)); - tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - tmp, tmp2); - /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */ - /* Note: gfc->elem_len = cfi->elem_len/4. */ - /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave - gfc->elem_len == cfi->elem_len, which helps with operations which use - sizeof() in Fortran and cfi->elem_len in C. */ - tmp = gfc_get_cfi_desc_type (cfi); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), - CFI_type_ucs4_char)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, - build_int_cst (TREE_TYPE (type), BT_CHARACTER)); - tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - tmp, tmp2); - /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, - build_int_cst (TREE_TYPE (ctype), - CFI_type_Complex)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, - build_int_cst (TREE_TYPE (type), BT_COMPLEX)); - tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - tmp, tmp2); - /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real) - ctype else */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, - build_int_cst (TREE_TYPE (ctype), - CFI_type_Integer)); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, - build_int_cst (TREE_TYPE (ctype), - CFI_type_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, ctype, - build_int_cst (TREE_TYPE (ctype), - CFI_type_Real)); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, - cond, tmp); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - type, fold_convert (TREE_TYPE (type), ctype)); - tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - tmp, tmp2); - gfc_add_expr_to_block (&block, tmp2); - } - - if (sym->as->rank < 0) - { - /* Set gfc->dtype.rank, if assumed-rank. */ - rank = gfc_get_cfi_desc_rank (cfi); - gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank); - } - else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - /* In that case, the CFI rank and the declared rank can differ. */ - rank = gfc_get_cfi_desc_rank (cfi); - else - rank = build_int_cst (signed_char_type_node, sym->as->rank); - - /* With bind(C), the standard requires that both Fortran callers and callees - handle noncontiguous arrays passed to an dummy with 'contiguous' attribute - and with character(len=*) + assumed-size/explicit-size arrays. - cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */ - if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length - && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT)) - || sym->attr.contiguous) - { - do_copy_inout = true; - gcc_assert (!sym->attr.pointer); - stmtblock_t block2; - tree data; - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - data = gfc_conv_descriptor_data_get (gfc_desc); - else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc))) - data = gfc_build_addr_expr (NULL, gfc_desc); - else - data = gfc_desc; - - /* Is copy-in/out needed? */ - /* do_copyin = rank != 0 && !assumed-size */ - tree cond_var = gfc_create_var (boolean_type_node, "do_copyin"); - tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - rank, build_zero_cst (TREE_TYPE (rank))); - /* dim[rank-1].extent != -1 -> assumed size*/ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (rank), - rank, build_int_cst (TREE_TYPE (rank), 1)); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - gfc_get_cfi_dim_extent (cfi, tmp), - build_int_cst (gfc_array_index_type, -1)); - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, cond, tmp); - gfc_add_modify (&block, cond_var, cond); - /* if (do_copyin) do_copyin = ... || ... || ... */ - gfc_init_block (&block2); - /* dim[0].sm != elem_len */ - tmp = fold_convert (gfc_array_index_type, - gfc_get_cfi_desc_elem_len (cfi)); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - gfc_get_cfi_dim_sm (cfi, gfc_index_zero_node), - tmp); - gfc_add_modify (&block2, cond_var, cond); - - /* for (i = 1; i < rank; ++i) - cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */ - idx = gfc_create_var (TREE_TYPE (rank), "idx"); - stmtblock_t loop_body; - gfc_init_block (&loop_body); - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx), - idx, build_int_cst (TREE_TYPE (idx), 1)); - tree tmp2 = gfc_get_cfi_dim_sm (cfi, tmp); - tmp = gfc_get_cfi_dim_extent (cfi, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp2, tmp); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - gfc_get_cfi_dim_sm (cfi, idx), tmp); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, - cond_var, cond); - gfc_add_modify (&loop_body, cond_var, cond); - gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1), - rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - - /* Copy-in body. */ - gfc_init_block (&block2); - /* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */ - size_var = gfc_create_var (size_type_node, "size"); - tmp = fold_convert (size_type_node, - gfc_get_cfi_dim_extent (cfi, gfc_index_zero_node)); - gfc_add_modify (&block2, size_var, tmp); - - gfc_init_block (&loop_body); - tmp = fold_convert (size_type_node, - gfc_get_cfi_dim_extent (cfi, idx)); - tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - size_var, fold_convert (size_type_node, tmp)); - gfc_add_modify (&loop_body, size_var, tmp); - gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1), - rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - /* data = malloc (size * elem_len) */ - tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - size_var, gfc_get_cfi_desc_elem_len (cfi)); - tree call = builtin_decl_explicit (BUILT_IN_MALLOC); - call = build_call_expr_loc (input_location, call, 1, tmp); - gfc_add_modify (&block2, data, fold_convert (TREE_TYPE (data), call)); - - /* Copy the data: - for (idx = 0; idx < size; ++idx) - { - shift = 0; - tmpidx = idx - for (dim = 0; dim < rank; ++dim) - { - shift += (tmpidx % extent[d]) * sm[d] - tmpidx = tmpidx / extend[d] - } - memcpy (lhs + idx*elem_len, rhs + shift, elem_len) - } .*/ - idx = gfc_create_var (size_type_node, "arrayidx"); - gfc_init_block (&loop_body); - tree shift = gfc_create_var (size_type_node, "shift"); - tree tmpidx = gfc_create_var (size_type_node, "tmpidx"); - gfc_add_modify (&loop_body, shift, build_zero_cst (TREE_TYPE (shift))); - gfc_add_modify (&loop_body, tmpidx, idx); - stmtblock_t inner_loop; - gfc_init_block (&inner_loop); - tree dim = gfc_create_var (TREE_TYPE (rank), "dim"); - /* shift += (tmpidx % extent[d]) * sm[d] */ - tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, - size_type_node, tmpidx, - fold_convert (size_type_node, - gfc_get_cfi_dim_extent (cfi, dim))); - tmp = fold_build2_loc (input_location, MULT_EXPR, - size_type_node, tmp, - fold_convert (size_type_node, - gfc_get_cfi_dim_sm (cfi, dim))); - gfc_add_modify (&inner_loop, shift, - fold_build2_loc (input_location, PLUS_EXPR, - size_type_node, shift, tmp)); - /* tmpidx = tmpidx / extend[d] */ - tmp = fold_convert (size_type_node, gfc_get_cfi_dim_extent (cfi, dim)); - gfc_add_modify (&inner_loop, tmpidx, - fold_build2_loc (input_location, TRUNC_DIV_EXPR, - size_type_node, tmpidx, tmp)); - gfc_simple_for_loop (&loop_body, dim, build_zero_cst (TREE_TYPE (rank)), - rank, LT_EXPR, build_int_cst (TREE_TYPE (dim), 1), - gfc_finish_block (&inner_loop)); - /* Assign. */ - tmp = fold_convert (pchar_type_node, gfc_get_cfi_desc_base_addr (cfi)); - tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift); - tree lhs; - /* memcpy (lhs + idx*elem_len, rhs + shift, elem_len) */ - tree elem_len; - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - elem_len = gfc_conv_descriptor_elem_len (gfc_desc); - else - elem_len = gfc_get_cfi_desc_elem_len (cfi); - lhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - elem_len, idx); - lhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pchar_type_node, - fold_convert (pchar_type_node, data), lhs); - tmp = fold_convert (pvoid_type_node, tmp); - lhs = fold_convert (pvoid_type_node, lhs); - call = builtin_decl_explicit (BUILT_IN_MEMCPY); - call = build_call_expr_loc (input_location, call, 3, lhs, tmp, elem_len); - gfc_add_expr_to_block (&loop_body, fold_convert (void_type_node, call)); - gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), - size_var, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - /* if (cond) { block2 } */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - data, fold_convert (TREE_TYPE (data), - null_pointer_node)); - tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - { - tree offset, type; - type = TREE_TYPE (gfc_desc); - gfc_trans_array_bounds (type, sym, &offset, &block); - if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - goto done; - } - - /* If cfi->data != NULL. */ - stmtblock_t block2; - gfc_init_block (&block2); - - /* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len - We use gfc instead of cfi on the RHS as this might be a constant. */ - tmp = fold_convert (gfc_array_index_type, - gfc_conv_descriptor_elem_len (gfc_desc)); - if (!do_copy_inout) - { - /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len) - ? cfi->dim[0].sm : gfc->elem_len). */ - tree cond; - tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]); - cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR, - gfc_array_index_type, tmp2, tmp); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - cond, gfc_index_zero_node); - tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - tmp2, tmp); - } - gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp); - - /* Calculate offset + set lbound, ubound and stride. */ - gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node); - if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable) - for (int i = 0; i < sym->as->rank; ++i) - { - gfc_se se; - gfc_init_se (&se, NULL ); - if (sym->as->lower[i]) - { - gfc_conv_expr (&se, sym->as->lower[i]); - tmp = se.expr; - } - else - tmp = gfc_index_one_node; - gfc_add_block_to_block (&block2, &se.pre); - gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i], - tmp); - gfc_add_block_to_block (&block2, &se.post); - } - - /* Loop: for (i = 0; i < rank; ++i). */ - idx = gfc_create_var (TREE_TYPE (rank), "idx"); - - /* Loop body. */ - stmtblock_t loop_body; - gfc_init_block (&loop_body); - /* gfc->dim[i].lbound = ... */ - if (sym->attr.pointer || sym->attr.allocatable) - { - tmp = gfc_get_cfi_dim_lbound (cfi, idx); - gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp); - } - else if (sym->as->rank < 0) - gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, - gfc_index_one_node); - - /* 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_desc, 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_desc, idx, tmp); - - if (do_copy_inout) - { - /* gfc->dim[i].stride - = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */ - tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - idx, build_zero_cst (TREE_TYPE (idx))); - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx), - idx, build_int_cst (TREE_TYPE (idx), 1)); - tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp); - tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2), - tmp2, tmp); - tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - gfc_index_one_node, tmp); - } - else - { - /* 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_desc, 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_desc, idx), - gfc_conv_descriptor_lbound_get (gfc_desc, idx)); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_offset_get (gfc_desc), tmp); - gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp); - - /* Generate loop. */ - gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), - rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - if (sym->attr.allocatable || sym->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 optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */ - if (sym->attr.optional) - { - tree present = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, cfi_desc, - null_pointer_node); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - sym->backend_decl, - fold_convert (TREE_TYPE (sym->backend_decl), - null_pointer_node)); - tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp); - gfc_add_expr_to_block (init, tmp); - } - else - gfc_add_block_to_block (init, &block); - - if (!sym->attr.referenced) - return; - - /* If pointer not changed, nothing to be done (except copy out) */ - if (!do_copy_inout && ((!sym->attr.pointer && !sym->attr.allocatable) - || sym->attr.intent == INTENT_IN)) - return; - - gfc_init_block (&block); - - /* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or - len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain - unchanged. */ - if (do_copy_inout) - { - tree data, call; - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - data = gfc_conv_descriptor_data_get (gfc_desc); - else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc))) - data = gfc_build_addr_expr (NULL, gfc_desc); - else - data = gfc_desc; - gfc_init_block (&block2); - if (sym->attr.intent != INTENT_IN) - { - /* First, create the inner copy-out loop. - for (idx = 0; idx < size; ++idx) - { - shift = 0; - tmpidx = idx - for (dim = 0; dim < rank; ++dim) - { - shift += (tmpidx % extent[d]) * sm[d] - tmpidx = tmpidx / extend[d] - } - memcpy (lhs + shift, rhs + idx*elem_len, elem_len) - } .*/ - stmtblock_t loop_body; - idx = gfc_create_var (size_type_node, "arrayidx"); - gfc_init_block (&loop_body); - tree shift = gfc_create_var (size_type_node, "shift"); - tree tmpidx = gfc_create_var (size_type_node, "tmpidx"); - gfc_add_modify (&loop_body, shift, - build_zero_cst (TREE_TYPE (shift))); - gfc_add_modify (&loop_body, tmpidx, idx); - stmtblock_t inner_loop; - gfc_init_block (&inner_loop); - tree dim = gfc_create_var (TREE_TYPE (rank), "dim"); - /* shift += (tmpidx % extent[d]) * sm[d] */ - tmp = fold_convert (size_type_node, - gfc_get_cfi_dim_extent (cfi, dim)); - tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, - size_type_node, tmpidx, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, - size_type_node, tmp, - fold_convert (size_type_node, - gfc_get_cfi_dim_sm (cfi, dim))); - gfc_add_modify (&inner_loop, shift, - fold_build2_loc (input_location, PLUS_EXPR, - size_type_node, shift, tmp)); - /* tmpidx = tmpidx / extend[d] */ - tmp = fold_convert (size_type_node, - gfc_get_cfi_dim_extent (cfi, dim)); - gfc_add_modify (&inner_loop, tmpidx, - fold_build2_loc (input_location, TRUNC_DIV_EXPR, - size_type_node, tmpidx, tmp)); - gfc_simple_for_loop (&loop_body, dim, - build_zero_cst (TREE_TYPE (rank)), rank, LT_EXPR, - build_int_cst (TREE_TYPE (dim), 1), - gfc_finish_block (&inner_loop)); - /* Assign. */ - tree rhs; - tmp = fold_convert (pchar_type_node, - gfc_get_cfi_desc_base_addr (cfi)); - tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift); - /* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */ - tree elem_len; - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) - elem_len = gfc_conv_descriptor_elem_len (gfc_desc); - else - elem_len = gfc_get_cfi_desc_elem_len (cfi); - rhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - elem_len, idx); - rhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, - pchar_type_node, - fold_convert (pchar_type_node, data), rhs); - tmp = fold_convert (pvoid_type_node, tmp); - rhs = fold_convert (pvoid_type_node, rhs); - call = builtin_decl_explicit (BUILT_IN_MEMCPY); - call = build_call_expr_loc (input_location, call, 3, tmp, rhs, - elem_len); - gfc_add_expr_to_block (&loop_body, - fold_convert (void_type_node, call)); - gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), - size_var, LT_EXPR, - build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - } - call = builtin_decl_explicit (BUILT_IN_FREE); - call = build_call_expr_loc (input_location, call, 1, data); - gfc_add_expr_to_block (&block2, call); - - /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */ - tree tmp2 = gfc_get_cfi_desc_base_addr (cfi); - tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - tmp2, fold_convert (TREE_TYPE (tmp2), data)); - tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - goto done_finally; - } - - /* Update pointer + array data data on exit. */ - tmp = gfc_get_cfi_desc_base_addr (cfi); - tmp2 = (!sym->attr.dimension - ? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc)); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); - - /* Set string length for len=:, only. */ - if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length) - { - tmp = sym->ts.u.cl->backend_decl; - if (sym->ts.kind != 1) - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - sym->ts.u.cl->backend_decl, tmp); - tmp2 = gfc_get_cfi_desc_elem_len (cfi); - gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); - } - - if (!sym->attr.dimension) - goto done_finally; - - gfc_init_block (&block2); - - /* Loop: for (i = 0; i < rank; ++i). */ - idx = gfc_create_var (TREE_TYPE (rank), "idx"); - - /* Loop body. */ - gfc_init_block (&loop_body); - /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */ - gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), - gfc_conv_descriptor_lbound_get (gfc_desc, idx)); - /* 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_desc, idx), - gfc_conv_descriptor_lbound_get (gfc_desc, 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_desc, idx), - gfc_conv_descriptor_span_get (gfc_desc)); - gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp); - - /* Generate loop. */ - gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), - rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), - gfc_finish_block (&loop_body)); - /* if (gfc->data != NULL) { block2 }. */ - 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); - -done_finally: - /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */ - if (sym->attr.optional) - { - tree present = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, cfi_desc, - null_pointer_node); - tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (finally, tmp); - } - else - gfc_add_block_to_block (finally, &block); -} - -/* Generate code for a function. */ - -void -gfc_generate_function_code (gfc_namespace * ns) -{ - tree fndecl; - tree old_context; - tree decl; - tree tmp; - tree fpstate = NULL_TREE; - stmtblock_t init, cleanup, outer_block; - stmtblock_t body; - gfc_wrapped_block try_block; - tree recurcheckvar = NULL_TREE; - gfc_symbol *sym; - gfc_symbol *previous_procedure_symbol; - int rank, ieee; - bool is_recursive; - - sym = ns->proc_name; - previous_procedure_symbol = current_procedure_symbol; - current_procedure_symbol = sym; - - /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get - lost or worse. */ - sym->tlink = sym; - - /* Create the declaration for functions with global scope. */ - if (!sym->backend_decl) - gfc_create_function_decl (ns, false); - - fndecl = sym->backend_decl; - old_context = current_function_decl; - - if (old_context) - { - push_function_context (); - saved_parent_function_decls = saved_function_decls; - saved_function_decls = NULL_TREE; - } - - trans_function_start (sym); - - gfc_init_block (&init); - gfc_init_block (&cleanup); - gfc_init_block (&outer_block); - - if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) - { - /* Copy length backend_decls to all entry point result - symbols. */ - gfc_entry_list *el; - tree backend_decl; - - gfc_conv_const_charlen (ns->proc_name->ts.u.cl); - backend_decl = ns->proc_name->result->ts.u.cl->backend_decl; - for (el = ns->entries; el; el = el->next) - el->sym->result->ts.u.cl->backend_decl = backend_decl; - } - - /* Translate COMMON blocks. */ - gfc_trans_common (ns); - - /* Null the parent fake result declaration if this namespace is - a module function or an external procedures. */ - if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) - || ns->parent == NULL) - parent_fake_result_decl = NULL_TREE; - - /* For BIND(C): - - deallocate intent-out allocatable dummy arguments. - - Create GFC variable which will later be populated by convert_CFI_desc */ - if (sym->attr.is_bind_c) - for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym); - formal; formal = formal->next) - { - gfc_symbol *fsym = formal->sym; - if (!is_CFI_desc (fsym, NULL)) - continue; - if (!fsym->attr.referenced) - { - gfc_conv_cfi_to_gfc (&init, &cleanup, fsym->backend_decl, - NULL_TREE, fsym); - continue; - } - /* Let's now create a local GFI descriptor. Afterwards: - desc is the local descriptor, - desc_p is a pointer to it - and stored in sym->backend_decl - GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor - -> PARM_DECL and before sym->backend_decl. - For scalars, decl == decl_p is a pointer variable. */ - tree desc_p, desc; - location_t loc = gfc_get_location (&sym->declared_at); - if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length) - fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type, - fsym->name); - else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl) - { - gfc_se se; - gfc_init_se (&se, NULL ); - gfc_conv_expr (&se, fsym->ts.u.cl->length); - gfc_add_block_to_block (&init, &se.pre); - fsym->ts.u.cl->backend_decl = se.expr; - gcc_assert(se.post.head == NULL_TREE); - } - /* Nullify, otherwise gfc_sym_type will return the CFI type. */ - tree tmp = fsym->backend_decl; - fsym->backend_decl = NULL; - tree type = gfc_sym_type (fsym); - gcc_assert (POINTER_TYPE_P (type)); - if (POINTER_TYPE_P (TREE_TYPE (type))) - /* For instance, allocatable scalars. */ - type = TREE_TYPE (type); - if (TREE_CODE (type) == REFERENCE_TYPE) - type = build_pointer_type (TREE_TYPE (type)); - desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type); - if (!fsym->attr.dimension) - desc = desc_p; - else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p)))) - { - /* Character(len=*) explict-size/assumed-size array. */ - desc = desc_p; - gfc_build_qualified_array (desc, fsym); - } - else - { - tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p))); - tree call = builtin_decl_explicit (BUILT_IN_ALLOCA); - call = build_call_expr_loc (input_location, call, 1, size); - gfc_add_modify (&outer_block, desc_p, - fold_convert (TREE_TYPE(desc_p), call)); - desc = build_fold_indirect_ref_loc (input_location, desc_p); - } - pushdecl (desc_p); - if (fsym->attr.optional) - { - gfc_allocate_lang_decl (desc_p); - GFC_DECL_OPTIONAL_ARGUMENT (desc_p) = 1; - } - fsym->backend_decl = desc_p; - gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym); - } - - gfc_generate_contained_functions (ns); - - has_coarray_vars = false; - generate_local_vars (ns); - - if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) - generate_coarray_init (ns); - - /* Keep the parent fake result declaration in module functions - or external procedures. */ - if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) - || ns->parent == NULL) - current_fake_result_decl = parent_fake_result_decl; - else - current_fake_result_decl = NULL_TREE; - - is_recursive = sym->attr.recursive - || (sym->attr.entry_master - && sym->ns->entries->sym->attr.recursive); - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive && !flag_recursive && !sym->attr.artificial) - { - char * msg; - - msg = xasprintf ("Recursive call to nonrecursive procedure '%s'", - sym->name); - recurcheckvar = gfc_create_var (logical_type_node, "is_recursive"); - TREE_STATIC (recurcheckvar) = 1; - DECL_INITIAL (recurcheckvar) = logical_false_node; - gfc_add_expr_to_block (&init, recurcheckvar); - gfc_trans_runtime_check (true, false, recurcheckvar, &init, - &sym->declared_at, msg); - gfc_add_modify (&init, recurcheckvar, logical_true_node); - free (msg); - } - - /* Check if an IEEE module is used in the procedure. If so, save - the floating point state. */ - ieee = is_ieee_module_used (ns); - if (ieee) - fpstate = gfc_save_fp_state (&init); - - /* Now generate the code for the body of this function. */ - gfc_init_block (&body); - - if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node - && sym->attr.subroutine) - { - tree alternate_return; - alternate_return = gfc_get_fake_result_decl (sym, 0); - gfc_add_modify (&body, alternate_return, integer_zero_node); - } - - if (ns->entries) - { - /* Jump to the correct entry point. */ - tmp = gfc_trans_entry_master_switch (ns->entries); - gfc_add_expr_to_block (&body, tmp); - } - - /* If bounds-checking is enabled, generate code to check passed in actual - arguments against the expected dummy argument attributes (e.g. string - lengths). */ - if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c) - add_argument_checking (&body, sym); - - finish_oacc_declare (ns, sym, false); - - tmp = gfc_trans_code (ns->code); - gfc_add_expr_to_block (&body, tmp); - - if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node - || (sym->result && sym->result != sym - && sym->result->ts.type == BT_DERIVED - && sym->result->ts.u.derived->attr.alloc_comp)) - { - bool artificial_result_decl = false; - tree result = get_proc_result (sym); - gfc_symbol *rsym = sym == sym->result ? sym : sym->result; - - /* Make sure that a function returning an object with - alloc/pointer_components always has a result, where at least - the allocatable/pointer components are set to zero. */ - if (result == NULL_TREE && sym->attr.function - && ((sym->result->ts.type == BT_DERIVED - && (sym->attr.allocatable - || sym->attr.pointer - || sym->result->ts.u.derived->attr.alloc_comp - || sym->result->ts.u.derived->attr.pointer_comp)) - || (sym->result->ts.type == BT_CLASS - && (CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.class_pointer - || CLASS_DATA (sym->result)->attr.alloc_comp - || CLASS_DATA (sym->result)->attr.pointer_comp)))) - { - artificial_result_decl = true; - result = gfc_get_fake_result_decl (sym, 0); - } - - if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer) - { - if (sym->attr.allocatable && sym->attr.dimension == 0 - && sym->result == sym) - gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result), - null_pointer_node)); - else if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.allocatable - && CLASS_DATA (sym)->attr.dimension == 0 - && sym->result == sym) - { - tmp = CLASS_DATA (sym)->backend_decl; - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (tmp), result, tmp, NULL_TREE); - gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - } - else if (sym->ts.type == BT_DERIVED - && !sym->attr.allocatable) - { - gfc_expr *init_exp; - /* Arrays are not initialized using the default initializer of - their elements. Therefore only check if a default - initializer is available when the result is scalar. */ - init_exp = rsym->as ? NULL - : gfc_generate_initializer (&rsym->ts, true); - if (init_exp) - { - tmp = gfc_trans_structure_assign (result, init_exp, 0); - gfc_free_expr (init_exp); - gfc_add_expr_to_block (&init, tmp); - } - else if (rsym->ts.u.derived->attr.alloc_comp) - { - rank = rsym->as ? rsym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result, - rank); - gfc_prepend_expr_to_block (&body, tmp); - } - } - } - - if (result == NULL_TREE || artificial_result_decl) - { - /* TODO: move to the appropriate place in resolve.c. */ - if (warn_return_type > 0 && sym == sym->result) - gfc_warning (OPT_Wreturn_type, - "Return value of function %qs at %L not set", - sym->name, &sym->declared_at); - if (warn_return_type > 0) - suppress_warning (sym->backend_decl); - } - if (result != NULL_TREE) - gfc_add_expr_to_block (&body, gfc_generate_return ()); - } - - /* Reset recursion-check variable. */ - if (recurcheckvar != NULL_TREE) - { - gfc_add_modify (&cleanup, recurcheckvar, logical_false_node); - recurcheckvar = NULL; - } - - /* If IEEE modules are loaded, restore the floating-point state. */ - if (ieee) - gfc_restore_fp_state (&cleanup, fpstate); - - /* Finish the function body and add init and cleanup code. */ - tmp = gfc_finish_block (&body); - /* Add code to create and cleanup arrays. */ - gfc_start_wrapped_block (&try_block, tmp); - gfc_trans_deferred_vars (sym, &try_block); - gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), - gfc_finish_block (&cleanup)); - - /* Add all the decls we created during processing. */ - decl = nreverse (saved_function_decls); - while (decl) - { - tree next; - - next = DECL_CHAIN (decl); - DECL_CHAIN (decl) = NULL_TREE; - pushdecl (decl); - decl = next; - } - saved_function_decls = NULL_TREE; - - gfc_add_expr_to_block (&outer_block, gfc_finish_wrapped_block (&try_block)); - DECL_SAVED_TREE (fndecl) = gfc_finish_block (&outer_block); - decl = getdecls (); - - /* Finish off this function and send it for code generation. */ - poplevel (1, 1); - BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; - - DECL_SAVED_TREE (fndecl) - = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node, - decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl)); - - /* Output the GENERIC tree. */ - dump_function (TDI_original, fndecl); - - /* Store the end of the function, so that we get good line number - info for the epilogue. */ - cfun->function_end_locus = input_location; - - /* We're leaving the context of this function, so zap cfun. - It's still in DECL_STRUCT_FUNCTION, and we'll restore it in - tree_rest_of_compilation. */ - set_cfun (NULL); - - if (old_context) - { - pop_function_context (); - saved_function_decls = saved_parent_function_decls; - } - current_function_decl = old_context; - - if (decl_function_context (fndecl)) - { - /* Register this function with cgraph just far enough to get it - added to our parent's nested function list. - If there are static coarrays in this function, the nested _caf_init - function has already called cgraph_create_node, which also created - the cgraph node for this function. */ - if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB) - (void) cgraph_node::get_create (fndecl); - } - else - cgraph_node::finalize_function (fndecl, true); - - gfc_trans_use_stmts (ns); - gfc_traverse_ns (ns, gfc_emit_parameter_debug_info); - - if (sym->attr.is_main_program) - create_main_function (fndecl); - - current_procedure_symbol = previous_procedure_symbol; -} - - -void -gfc_generate_constructors (void) -{ - gcc_assert (gfc_static_ctors == NULL_TREE); -#if 0 - tree fnname; - tree type; - tree fndecl; - tree decl; - tree tmp; - - if (gfc_static_ctors == NULL_TREE) - return; - - fnname = get_file_function_name ("I"); - type = build_function_type_list (void_type_node, NULL_TREE); - - fndecl = build_decl (input_location, - FUNCTION_DECL, fnname, type); - TREE_PUBLIC (fndecl) = 1; - - decl = build_decl (input_location, - RESULT_DECL, NULL_TREE, void_type_node); - DECL_ARTIFICIAL (decl) = 1; - DECL_IGNORED_P (decl) = 1; - DECL_CONTEXT (decl) = fndecl; - DECL_RESULT (fndecl) = decl; - - pushdecl (fndecl); - - current_function_decl = fndecl; - - rest_of_decl_compilation (fndecl, 1, 0); - - make_decl_rtl (fndecl); - - allocate_struct_function (fndecl, false); - - pushlevel (); - - for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors)) - { - tmp = build_call_expr_loc (input_location, - TREE_VALUE (gfc_static_ctors), 0); - DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp); - } - - decl = getdecls (); - poplevel (1, 1); - - BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; - DECL_SAVED_TREE (fndecl) - = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl), - DECL_INITIAL (fndecl)); - - free_after_parsing (cfun); - free_after_compilation (cfun); - - tree_rest_of_compilation (fndecl); - - current_function_decl = NULL_TREE; -#endif -} - -/* Translates a BLOCK DATA program unit. This means emitting the - commons contained therein plus their initializations. We also emit - a globally visible symbol to make sure that each BLOCK DATA program - unit remains unique. */ - -void -gfc_generate_block_data (gfc_namespace * ns) -{ - tree decl; - tree id; - - /* Tell the backend the source location of the block data. */ - if (ns->proc_name) - gfc_set_backend_locus (&ns->proc_name->declared_at); - else - gfc_set_backend_locus (&gfc_current_locus); - - /* Process the DATA statements. */ - gfc_trans_common (ns); - - /* Create a global symbol with the mane of the block data. This is to - generate linker errors if the same name is used twice. It is never - really used. */ - if (ns->proc_name) - id = gfc_sym_mangled_function_id (ns->proc_name); - else - id = get_identifier ("__BLOCK_DATA__"); - - decl = build_decl (input_location, - VAR_DECL, id, gfc_array_index_type); - TREE_PUBLIC (decl) = 1; - TREE_STATIC (decl) = 1; - DECL_IGNORED_P (decl) = 1; - - pushdecl (decl); - rest_of_decl_compilation (decl, 1, 0); -} - - -/* Process the local variables of a BLOCK construct. */ - -void -gfc_process_block_locals (gfc_namespace* ns) -{ - tree decl; - - saved_local_decls = NULL_TREE; - has_coarray_vars = false; - - generate_local_vars (ns); - - if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) - generate_coarray_init (ns); - - decl = nreverse (saved_local_decls); - while (decl) - { - tree next; - - next = DECL_CHAIN (decl); - DECL_CHAIN (decl) = NULL_TREE; - pushdecl (decl); - decl = next; - } - saved_local_decls = NULL_TREE; -} - - -#include "gt-fortran-trans-decl.h" diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc new file mode 100644 index 0000000..08eaa5a --- /dev/null +++ b/gcc/fortran/trans-decl.cc @@ -0,0 +1,7956 @@ +/* Backend function setup + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + +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 +. */ + +/* trans-decl.c -- Handling of backend function and variable decls, etc */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "target.h" +#include "function.h" +#include "tree.h" +#include "gfortran.h" +#include "gimple-expr.h" /* For create_tmp_var_raw. */ +#include "trans.h" +#include "stringpool.h" +#include "cgraph.h" +#include "fold-const.h" +#include "stor-layout.h" +#include "varasm.h" +#include "attribs.h" +#include "dumpfile.h" +#include "toplev.h" /* For announce_function. */ +#include "debug.h" +#include "constructor.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +/* Only for gfc_trans_code. Shouldn't need to include this. */ +#include "trans-stmt.h" +#include "gomp-constants.h" +#include "gimplify.h" +#include "omp-general.h" +#include "attr-fnspec.h" + +#define MAX_LABEL_VALUE 99999 + + +/* Holds the result of the function if no result variable specified. */ + +static GTY(()) tree current_fake_result_decl; +static GTY(()) tree parent_fake_result_decl; + + +/* Holds the variable DECLs for the current function. */ + +static GTY(()) tree saved_function_decls; +static GTY(()) tree saved_parent_function_decls; + +/* Holds the variable DECLs that are locals. */ + +static GTY(()) tree saved_local_decls; + +/* The namespace of the module we're currently generating. Only used while + outputting decls for module variables. Do not rely on this being set. */ + +static gfc_namespace *module_namespace; + +/* The currently processed procedure symbol. */ +static gfc_symbol* current_procedure_symbol = NULL; + +/* The currently processed module. */ +static struct module_htab_entry *cur_module; + +/* With -fcoarray=lib: For generating the registering call + of static coarrays. */ +static bool has_coarray_vars; +static stmtblock_t caf_init_block; + + +/* List of static constructor functions. */ + +tree gfc_static_ctors; + + +/* Whether we've seen a symbol from an IEEE module in the namespace. */ +static int seen_ieee_symbol; + +/* Function declarations for builtin library functions. */ + +tree gfor_fndecl_pause_numeric; +tree gfor_fndecl_pause_string; +tree gfor_fndecl_stop_numeric; +tree gfor_fndecl_stop_string; +tree gfor_fndecl_error_stop_numeric; +tree gfor_fndecl_error_stop_string; +tree gfor_fndecl_runtime_error; +tree gfor_fndecl_runtime_error_at; +tree gfor_fndecl_runtime_warning_at; +tree gfor_fndecl_os_error_at; +tree gfor_fndecl_generate_error; +tree gfor_fndecl_set_args; +tree gfor_fndecl_set_fpe; +tree gfor_fndecl_set_options; +tree gfor_fndecl_set_convert; +tree gfor_fndecl_set_record_marker; +tree gfor_fndecl_set_max_subrecord_length; +tree gfor_fndecl_ctime; +tree gfor_fndecl_fdate; +tree gfor_fndecl_ttynam; +tree gfor_fndecl_in_pack; +tree gfor_fndecl_in_unpack; +tree gfor_fndecl_associated; +tree gfor_fndecl_system_clock4; +tree gfor_fndecl_system_clock8; +tree gfor_fndecl_ieee_procedure_entry; +tree gfor_fndecl_ieee_procedure_exit; + +/* Coarray run-time library function decls. */ +tree gfor_fndecl_caf_init; +tree gfor_fndecl_caf_finalize; +tree gfor_fndecl_caf_this_image; +tree gfor_fndecl_caf_num_images; +tree gfor_fndecl_caf_register; +tree gfor_fndecl_caf_deregister; +tree gfor_fndecl_caf_get; +tree gfor_fndecl_caf_send; +tree gfor_fndecl_caf_sendget; +tree gfor_fndecl_caf_get_by_ref; +tree gfor_fndecl_caf_send_by_ref; +tree gfor_fndecl_caf_sendget_by_ref; +tree gfor_fndecl_caf_sync_all; +tree gfor_fndecl_caf_sync_memory; +tree gfor_fndecl_caf_sync_images; +tree gfor_fndecl_caf_stop_str; +tree gfor_fndecl_caf_stop_numeric; +tree gfor_fndecl_caf_error_stop; +tree gfor_fndecl_caf_error_stop_str; +tree gfor_fndecl_caf_atomic_def; +tree gfor_fndecl_caf_atomic_ref; +tree gfor_fndecl_caf_atomic_cas; +tree gfor_fndecl_caf_atomic_op; +tree gfor_fndecl_caf_lock; +tree gfor_fndecl_caf_unlock; +tree gfor_fndecl_caf_event_post; +tree gfor_fndecl_caf_event_wait; +tree gfor_fndecl_caf_event_query; +tree gfor_fndecl_caf_fail_image; +tree gfor_fndecl_caf_failed_images; +tree gfor_fndecl_caf_image_status; +tree gfor_fndecl_caf_stopped_images; +tree gfor_fndecl_caf_form_team; +tree gfor_fndecl_caf_change_team; +tree gfor_fndecl_caf_end_team; +tree gfor_fndecl_caf_sync_team; +tree gfor_fndecl_caf_get_team; +tree gfor_fndecl_caf_team_number; +tree gfor_fndecl_co_broadcast; +tree gfor_fndecl_co_max; +tree gfor_fndecl_co_min; +tree gfor_fndecl_co_reduce; +tree gfor_fndecl_co_sum; +tree gfor_fndecl_caf_is_present; +tree gfor_fndecl_caf_random_init; + + +/* Math functions. Many other math functions are handled in + trans-intrinsic.c. */ + +gfc_powdecl_list gfor_fndecl_math_powi[4][3]; +tree gfor_fndecl_math_ishftc4; +tree gfor_fndecl_math_ishftc8; +tree gfor_fndecl_math_ishftc16; + + +/* String functions. */ + +tree gfor_fndecl_compare_string; +tree gfor_fndecl_concat_string; +tree gfor_fndecl_string_len_trim; +tree gfor_fndecl_string_index; +tree gfor_fndecl_string_scan; +tree gfor_fndecl_string_verify; +tree gfor_fndecl_string_trim; +tree gfor_fndecl_string_minmax; +tree gfor_fndecl_adjustl; +tree gfor_fndecl_adjustr; +tree gfor_fndecl_select_string; +tree gfor_fndecl_compare_string_char4; +tree gfor_fndecl_concat_string_char4; +tree gfor_fndecl_string_len_trim_char4; +tree gfor_fndecl_string_index_char4; +tree gfor_fndecl_string_scan_char4; +tree gfor_fndecl_string_verify_char4; +tree gfor_fndecl_string_trim_char4; +tree gfor_fndecl_string_minmax_char4; +tree gfor_fndecl_adjustl_char4; +tree gfor_fndecl_adjustr_char4; +tree gfor_fndecl_select_string_char4; + + +/* Conversion between character kinds. */ +tree gfor_fndecl_convert_char1_to_char4; +tree gfor_fndecl_convert_char4_to_char1; + + +/* Other misc. runtime library functions. */ +tree gfor_fndecl_iargc; +tree gfor_fndecl_kill; +tree gfor_fndecl_kill_sub; +tree gfor_fndecl_is_contiguous0; + + +/* Intrinsic functions implemented in Fortran. */ +tree gfor_fndecl_sc_kind; +tree gfor_fndecl_si_kind; +tree gfor_fndecl_sr_kind; + +/* BLAS gemm functions. */ +tree gfor_fndecl_sgemm; +tree gfor_fndecl_dgemm; +tree gfor_fndecl_cgemm; +tree gfor_fndecl_zgemm; + +/* RANDOM_INIT function. */ +tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */ + +static void +gfc_add_decl_to_parent_function (tree decl) +{ + gcc_assert (decl); + DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl); + DECL_NONLOCAL (decl) = 1; + DECL_CHAIN (decl) = saved_parent_function_decls; + saved_parent_function_decls = decl; +} + +void +gfc_add_decl_to_function (tree decl) +{ + gcc_assert (decl); + TREE_USED (decl) = 1; + DECL_CONTEXT (decl) = current_function_decl; + DECL_CHAIN (decl) = saved_function_decls; + saved_function_decls = decl; +} + +static void +add_decl_as_local (tree decl) +{ + gcc_assert (decl); + TREE_USED (decl) = 1; + DECL_CONTEXT (decl) = current_function_decl; + DECL_CHAIN (decl) = saved_local_decls; + saved_local_decls = decl; +} + + +/* Build a backend label declaration. Set TREE_USED for named labels. + The context of the label is always the current_function_decl. All + labels are marked artificial. */ + +tree +gfc_build_label_decl (tree label_id) +{ + /* 2^32 temporaries should be enough. */ + static unsigned int tmp_num = 1; + tree label_decl; + char *label_name; + + if (label_id == NULL_TREE) + { + /* Build an internal label name. */ + ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++); + label_id = get_identifier (label_name); + } + else + label_name = NULL; + + /* Build the LABEL_DECL node. Labels have no type. */ + label_decl = build_decl (input_location, + LABEL_DECL, label_id, void_type_node); + DECL_CONTEXT (label_decl) = current_function_decl; + SET_DECL_MODE (label_decl, VOIDmode); + + /* We always define the label as used, even if the original source + file never references the label. We don't want all kinds of + spurious warnings for old-style Fortran code with too many + labels. */ + TREE_USED (label_decl) = 1; + + DECL_ARTIFICIAL (label_decl) = 1; + return label_decl; +} + + +/* Set the backend source location of a decl. */ + +void +gfc_set_decl_location (tree decl, locus * loc) +{ + DECL_SOURCE_LOCATION (decl) = gfc_get_location (loc); +} + + +/* Return the backend label declaration for a given label structure, + or create it if it doesn't exist yet. */ + +tree +gfc_get_label_decl (gfc_st_label * lp) +{ + if (lp->backend_decl) + return lp->backend_decl; + else + { + char label_name[GFC_MAX_SYMBOL_LEN + 1]; + tree label_decl; + + /* Validate the label declaration from the front end. */ + gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE); + + /* Build a mangled name for the label. */ + sprintf (label_name, "__label_%.6d", lp->value); + + /* Build the LABEL_DECL node. */ + label_decl = gfc_build_label_decl (get_identifier (label_name)); + + /* Tell the debugger where the label came from. */ + if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */ + gfc_set_decl_location (label_decl, &lp->where); + else + DECL_ARTIFICIAL (label_decl) = 1; + + /* Store the label in the label list and return the LABEL_DECL. */ + lp->backend_decl = label_decl; + return label_decl; + } +} + +/* Return the name of an identifier. */ + +static const char * +sym_identifier (gfc_symbol *sym) +{ + if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0) + return "MAIN__"; + else + return sym->name; +} + +/* Convert a gfc_symbol to an identifier of the same name. */ + +static tree +gfc_sym_identifier (gfc_symbol * sym) +{ + return get_identifier (sym_identifier (sym)); +} + +/* Construct mangled name from symbol name. */ + +static const char * +mangled_identifier (gfc_symbol *sym) +{ + gfc_symbol *proc = sym->ns->proc_name; + static char name[3*GFC_MAX_MANGLED_SYMBOL_LEN + 14]; + /* Prevent the mangling of identifiers that have an assigned + binding label (mainly those that are bind(c)). */ + + if (sym->attr.is_bind_c == 1 && sym->binding_label) + return sym->binding_label; + + if (!sym->fn_result_spec + || (sym->module && !(proc && proc->attr.flavor == FL_PROCEDURE))) + { + if (sym->module == NULL) + return sym_identifier (sym); + else + snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); + } + else + { + /* This is an entity that is actually local to a module procedure + that appears in the result specification expression. Since + sym->module will be a zero length string, we use ns->proc_name + to provide the module name instead. */ + if (proc && proc->module) + snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s", + proc->module, proc->name, sym->name); + else + snprintf (name, sizeof name, "__%s_PROC_%s", + proc->name, sym->name); + } + + return name; +} + +/* Get mangled identifier, adding the symbol to the global table if + it is not yet already there. */ + +static tree +gfc_sym_mangled_identifier (gfc_symbol * sym) +{ + tree result; + gfc_gsymbol *gsym; + const char *name; + + name = mangled_identifier (sym); + result = get_identifier (name); + + gsym = gfc_find_gsymbol (gfc_gsym_root, name); + if (gsym == NULL) + { + gsym = gfc_get_gsymbol (name, false); + gsym->ns = sym->ns; + gsym->sym_name = sym->name; + } + + return result; +} + +/* Construct mangled function name from symbol name. */ + +static tree +gfc_sym_mangled_function_id (gfc_symbol * sym) +{ + int has_underscore; + char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; + + /* It may be possible to simply use the binding label if it's + provided, and remove the other checks. Then we could use it + for other things if we wished. */ + if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) && + sym->binding_label) + /* use the binding label rather than the mangled name */ + return get_identifier (sym->binding_label); + + if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL + || (sym->module != NULL && (sym->attr.external + || sym->attr.if_source == IFSRC_IFBODY))) + && !sym->attr.module_procedure) + { + /* Main program is mangled into MAIN__. */ + if (sym->attr.is_main_program) + return get_identifier ("MAIN__"); + + /* Intrinsic procedures are never mangled. */ + if (sym->attr.proc == PROC_INTRINSIC) + return get_identifier (sym->name); + + if (flag_underscoring) + { + has_underscore = strchr (sym->name, '_') != 0; + if (flag_second_underscore && has_underscore) + snprintf (name, sizeof name, "%s__", sym->name); + else + snprintf (name, sizeof name, "%s_", sym->name); + return get_identifier (name); + } + else + return get_identifier (sym->name); + } + else + { + snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); + return get_identifier (name); + } +} + + +void +gfc_set_decl_assembler_name (tree decl, tree name) +{ + tree target_mangled = targetm.mangle_decl_assembler_name (decl, name); + SET_DECL_ASSEMBLER_NAME (decl, target_mangled); +} + + +/* Returns true if a variable of specified size should go on the stack. */ + +int +gfc_can_put_var_on_stack (tree size) +{ + unsigned HOST_WIDE_INT low; + + if (!INTEGER_CST_P (size)) + return 0; + + if (flag_max_stack_var_size < 0) + return 1; + + if (!tree_fits_uhwi_p (size)) + return 0; + + low = TREE_INT_CST_LOW (size); + if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size) + return 0; + +/* TODO: Set a per-function stack size limit. */ + + return 1; +} + + +/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to + an expression involving its corresponding pointer. There are + 2 cases; one for variable size arrays, and one for everything else, + because variable-sized arrays require one fewer level of + indirection. */ + +static void +gfc_finish_cray_pointee (tree decl, gfc_symbol *sym) +{ + tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer); + tree value; + + /* Parameters need to be dereferenced. */ + if (sym->cp_pointer->attr.dummy) + ptr_decl = build_fold_indirect_ref_loc (input_location, + ptr_decl); + + /* Check to see if we're dealing with a variable-sized array. */ + if (sym->attr.dimension + && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) + { + /* These decls will be dereferenced later, so we don't dereference + them here. */ + value = convert (TREE_TYPE (decl), ptr_decl); + } + else + { + ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)), + ptr_decl); + value = build_fold_indirect_ref_loc (input_location, + ptr_decl); + } + + SET_DECL_VALUE_EXPR (decl, value); + DECL_HAS_VALUE_EXPR_P (decl) = 1; + GFC_DECL_CRAY_POINTEE (decl) = 1; +} + + +/* Finish processing of a declaration without an initial value. */ + +static void +gfc_finish_decl (tree decl) +{ + gcc_assert (TREE_CODE (decl) == PARM_DECL + || DECL_INITIAL (decl) == NULL_TREE); + + if (!VAR_P (decl)) + return; + + if (DECL_SIZE (decl) == NULL_TREE + && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) + layout_decl (decl, 0); + + /* A few consistency checks. */ + /* A static variable with an incomplete type is an error if it is + initialized. Also if it is not file scope. Otherwise, let it + through, but if it is not `extern' then it may cause an error + message later. */ + /* An automatic variable with an incomplete type is an error. */ + + /* We should know the storage size. */ + gcc_assert (DECL_SIZE (decl) != NULL_TREE + || (TREE_STATIC (decl) + ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl)) + : DECL_EXTERNAL (decl))); + + /* The storage size should be constant. */ + gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl)) + || !DECL_SIZE (decl) + || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST); +} + + +/* Handle setting of GFC_DECL_SCALAR* on DECL. */ + +void +gfc_finish_decl_attrs (tree decl, symbol_attribute *attr) +{ + if (!attr->dimension && !attr->codimension) + { + /* Handle scalar allocatable variables. */ + if (attr->allocatable) + { + gfc_allocate_lang_decl (decl); + GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1; + } + /* Handle scalar pointer variables. */ + if (attr->pointer) + { + gfc_allocate_lang_decl (decl); + GFC_DECL_SCALAR_POINTER (decl) = 1; + } + if (attr->target) + { + gfc_allocate_lang_decl (decl); + GFC_DECL_SCALAR_TARGET (decl) = 1; + } + } +} + + +/* Apply symbol attributes to a variable, and add it to the function scope. */ + +static void +gfc_finish_var_decl (tree decl, gfc_symbol * sym) +{ + tree new_type; + + /* Set DECL_VALUE_EXPR for Cray Pointees. */ + if (sym->attr.cray_pointee) + gfc_finish_cray_pointee (decl, sym); + + /* TREE_ADDRESSABLE means the address of this variable is actually needed. + This is the equivalent of the TARGET variables. + We also need to set this if the variable is passed by reference in a + CALL statement. */ + if (sym->attr.target) + TREE_ADDRESSABLE (decl) = 1; + + /* If it wasn't used we wouldn't be getting it. */ + TREE_USED (decl) = 1; + + if (sym->attr.flavor == FL_PARAMETER + && (sym->attr.dimension || sym->ts.type == BT_DERIVED)) + TREE_READONLY (decl) = 1; + + /* Chain this decl to the pending declarations. Don't do pushdecl() + because this would add them to the current scope rather than the + function scope. */ + if (current_function_decl != NULL_TREE) + { + if (sym->ns->proc_name + && (sym->ns->proc_name->backend_decl == current_function_decl + || sym->result == sym)) + gfc_add_decl_to_function (decl); + else if (sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_LABEL) + /* This is a BLOCK construct. */ + add_decl_as_local (decl); + else + gfc_add_decl_to_parent_function (decl); + } + + if (sym->attr.cray_pointee) + return; + + if(sym->attr.is_bind_c == 1 && sym->binding_label) + { + /* We need to put variables that are bind(c) into the common + segment of the object file, because this is what C would do. + gfortran would typically put them in either the BSS or + initialized data segments, and only mark them as common if + they were part of common blocks. However, if they are not put + into common space, then C cannot initialize global Fortran + variables that it interoperates with and the draft says that + either Fortran or C should be able to initialize it (but not + both, of course.) (J3/04-007, section 15.3). */ + TREE_PUBLIC(decl) = 1; + DECL_COMMON(decl) = 1; + if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) + { + DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; + DECL_VISIBILITY_SPECIFIED (decl) = true; + } + } + + /* If a variable is USE associated, it's always external. */ + if (sym->attr.use_assoc || sym->attr.used_in_submodule) + { + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + } + else if (sym->fn_result_spec && !sym->ns->proc_name->module) + { + + if (sym->ns->proc_name->attr.if_source != IFSRC_DECL) + DECL_EXTERNAL (decl) = 1; + else + TREE_STATIC (decl) = 1; + + TREE_PUBLIC (decl) = 1; + } + else if (sym->module && !sym->attr.result && !sym->attr.dummy) + { + /* TODO: Don't set sym->module for result or dummy variables. */ + gcc_assert (current_function_decl == NULL_TREE || sym->result == sym); + + TREE_PUBLIC (decl) = 1; + TREE_STATIC (decl) = 1; + if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) + { + DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; + DECL_VISIBILITY_SPECIFIED (decl) = true; + } + } + + /* Derived types are a bit peculiar because of the possibility of + a default initializer; this must be applied each time the variable + comes into scope it therefore need not be static. These variables + are SAVE_NONE but have an initializer. Otherwise explicitly + initialized variables are SAVE_IMPLICIT and explicitly saved are + SAVE_EXPLICIT. */ + if (!sym->attr.use_assoc + && (sym->attr.save != SAVE_NONE || sym->attr.data + || (sym->value && sym->ns->proc_name->attr.is_main_program) + || (flag_coarray == GFC_FCOARRAY_LIB + && sym->attr.codimension && !sym->attr.allocatable))) + TREE_STATIC (decl) = 1; + + /* If derived-type variables with DTIO procedures are not made static + some bits of code referencing them get optimized away. + TODO Understand why this is so and fix it. */ + if (!sym->attr.use_assoc + && ((sym->ts.type == BT_DERIVED + && sym->ts.u.derived->attr.has_dtio_procs) + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs))) + TREE_STATIC (decl) = 1; + + /* Treat asynchronous variables the same as volatile, for now. */ + if (sym->attr.volatile_ || sym->attr.asynchronous) + { + TREE_THIS_VOLATILE (decl) = 1; + TREE_SIDE_EFFECTS (decl) = 1; + new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); + TREE_TYPE (decl) = new_type; + } + + /* Keep variables larger than max-stack-var-size off stack. */ + if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive) + && !sym->attr.automatic + && sym->attr.save != SAVE_EXPLICIT + && sym->attr.save != SAVE_IMPLICIT + && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) + && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) + /* Put variable length auto array pointers always into stack. */ + && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE + || sym->attr.dimension == 0 + || sym->as->type != AS_EXPLICIT + || sym->attr.pointer + || sym->attr.allocatable) + && !DECL_ARTIFICIAL (decl)) + { + if (flag_max_stack_var_size > 0 + && !(sym->ns->proc_name + && sym->ns->proc_name->attr.is_main_program)) + gfc_warning (OPT_Wsurprising, + "Array %qs at %L is larger than limit set by " + "%<-fmax-stack-var-size=%>, moved from stack to static " + "storage. This makes the procedure unsafe when called " + "recursively, or concurrently from multiple threads. " + "Consider increasing the %<-fmax-stack-var-size=%> " + "limit (or use %<-frecursive%>, which implies " + "unlimited %<-fmax-stack-var-size%>) - or change the " + "code to use an ALLOCATABLE array. If the variable is " + "never accessed concurrently, this warning can be " + "ignored, and the variable could also be declared with " + "the SAVE attribute.", + sym->name, &sym->declared_at); + + TREE_STATIC (decl) = 1; + + /* Because the size of this variable isn't known until now, we may have + greedily added an initializer to this variable (in build_init_assign) + even though the max-stack-var-size indicates the variable should be + static. Therefore we rip out the automatic initializer here and + replace it with a static one. */ + gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name); + gfc_code *prev = NULL; + gfc_code *code = sym->ns->code; + while (code && code->op == EXEC_INIT_ASSIGN) + { + /* Look for an initializer meant for this symbol. */ + if (code->expr1->symtree == st) + { + if (prev) + prev->next = code->next; + else + sym->ns->code = code->next; + + break; + } + + prev = code; + code = code->next; + } + if (code && code->op == EXEC_INIT_ASSIGN) + { + /* Keep the init expression for a static initializer. */ + sym->value = code->expr2; + /* Cleanup the defunct code object, without freeing the init expr. */ + code->expr2 = NULL; + gfc_free_statement (code); + free (code); + } + } + + /* Handle threadprivate variables. */ + if (sym->attr.threadprivate + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + set_decl_tls_model (decl, decl_default_tls_model (decl)); + + gfc_finish_decl_attrs (decl, &sym->attr); +} + + +/* Allocate the lang-specific part of a decl. */ + +void +gfc_allocate_lang_decl (tree decl) +{ + if (DECL_LANG_SPECIFIC (decl) == NULL) + DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc (); +} + +/* Remember a symbol to generate initialization/cleanup code at function + entry/exit. */ + +static void +gfc_defer_symbol_init (gfc_symbol * sym) +{ + gfc_symbol *p; + gfc_symbol *last; + gfc_symbol *head; + + /* Don't add a symbol twice. */ + if (sym->tlink) + return; + + last = head = sym->ns->proc_name; + p = last->tlink; + + /* Make sure that setup code for dummy variables which are used in the + setup of other variables is generated first. */ + if (sym->attr.dummy) + { + /* Find the first dummy arg seen after us, or the first non-dummy arg. + This is a circular list, so don't go past the head. */ + while (p != head + && (!p->attr.dummy || p->dummy_order > sym->dummy_order)) + { + last = p; + p = p->tlink; + } + } + /* Insert in between last and p. */ + last->tlink = sym; + sym->tlink = p; +} + + +/* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the + backend_decl for a module symbol, if it all ready exists. If the + module gsymbol does not exist, it is created. If the symbol does + not exist, it is added to the gsymbol namespace. Returns true if + an existing backend_decl is found. */ + +bool +gfc_get_module_backend_decl (gfc_symbol *sym) +{ + gfc_gsymbol *gsym; + gfc_symbol *s; + gfc_symtree *st; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); + + if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE)) + { + st = NULL; + s = NULL; + + /* Check for a symbol with the same name. */ + if (gsym) + gfc_find_symbol (sym->name, gsym->ns, 0, &s); + + if (!s) + { + if (!gsym) + { + gsym = gfc_get_gsymbol (sym->module, false); + gsym->type = GSYM_MODULE; + gsym->ns = gfc_get_namespace (NULL, 0); + } + + st = gfc_new_symtree (&gsym->ns->sym_root, sym->name); + st->n.sym = sym; + sym->refs++; + } + else if (gfc_fl_struct (sym->attr.flavor)) + { + if (s && s->attr.flavor == FL_PROCEDURE) + { + gfc_interface *intr; + gcc_assert (s->attr.generic); + for (intr = s->generic; intr; intr = intr->next) + if (gfc_fl_struct (intr->sym->attr.flavor)) + { + s = intr->sym; + break; + } + } + + /* Normally we can assume that s is a derived-type symbol since it + shares a name with the derived-type sym. However if sym is a + STRUCTURE, it may in fact share a name with any other basic type + variable. If s is in fact of derived type then we can continue + looking for a duplicate type declaration. */ + if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED) + { + s = s->ts.u.derived; + } + + if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl) + { + if (s->attr.flavor == FL_UNION) + s->backend_decl = gfc_get_union_type (s); + else + s->backend_decl = gfc_get_derived_type (s); + } + gfc_copy_dt_decls_ifequal (s, sym, true); + return true; + } + else if (s->backend_decl) + { + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, + true); + else if (sym->ts.type == BT_CHARACTER) + sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; + sym->backend_decl = s->backend_decl; + return true; + } + } + return false; +} + + +/* Create an array index type variable with function scope. */ + +static tree +create_index_var (const char * pfx, int nest) +{ + tree decl; + + decl = gfc_create_var_np (gfc_array_index_type, pfx); + if (nest) + gfc_add_decl_to_parent_function (decl); + else + gfc_add_decl_to_function (decl); + return decl; +} + + +/* Create variables to hold all the non-constant bits of info for a + descriptorless array. Remember these in the lang-specific part of the + type. */ + +static void +gfc_build_qualified_array (tree decl, gfc_symbol * sym) +{ + tree type; + int dim; + int nest; + gfc_namespace* procns; + symbol_attribute *array_attr; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); + + type = TREE_TYPE (decl); + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + + /* We just use the descriptor, if there is one. */ + if (GFC_DESCRIPTOR_TYPE_P (type)) + return; + + gcc_assert (GFC_ARRAY_TYPE_P (type)); + procns = gfc_find_proc_namespace (sym->ns); + nest = (procns->proc_name->backend_decl != current_function_decl) + && !sym->attr.contained; + + if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB + && as->type != AS_ASSUMED_SHAPE + && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE) + { + tree token; + tree token_type = build_qualified_type (pvoid_type_node, + TYPE_QUAL_RESTRICT); + + if (sym->module && (sym->attr.use_assoc + || sym->ns->proc_name->attr.flavor == FL_MODULE)) + { + tree token_name + = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"), + IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym)))); + token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name, + token_type); + if (sym->attr.use_assoc) + DECL_EXTERNAL (token) = 1; + else + TREE_STATIC (token) = 1; + + TREE_PUBLIC (token) = 1; + + if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) + { + DECL_VISIBILITY (token) = VISIBILITY_HIDDEN; + DECL_VISIBILITY_SPECIFIED (token) = true; + } + } + else + { + token = gfc_create_var_np (token_type, "caf_token"); + TREE_STATIC (token) = 1; + } + + GFC_TYPE_ARRAY_CAF_TOKEN (type) = token; + DECL_ARTIFICIAL (token) = 1; + DECL_NONALIASED (token) = 1; + + if (sym->module && !sym->attr.use_assoc) + { + pushdecl (token); + DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl; + gfc_module_add_decl (cur_module, token); + } + else if (sym->attr.host_assoc + && TREE_CODE (DECL_CONTEXT (current_function_decl)) + != TRANSLATION_UNIT_DECL) + gfc_add_decl_to_parent_function (token); + else + gfc_add_decl_to_function (token); + } + + for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) + { + if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) + { + GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); + suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); + } + /* Don't try to use the unknown bound for assumed shape arrays. */ + if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE + && (as->type != AS_ASSUMED_SIZE + || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) + { + GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); + suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); + } + + if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE) + { + GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest); + suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim)); + } + } + for (dim = GFC_TYPE_ARRAY_RANK (type); + dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++) + { + if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) + { + GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); + suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); + } + /* Don't try to use the unknown ubound for the last coarray dimension. */ + if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE + && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1) + { + GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); + suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); + } + } + if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE) + { + GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type, + "offset"); + suppress_warning (GFC_TYPE_ARRAY_OFFSET (type)); + + if (nest) + gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type)); + else + gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type)); + } + + if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE + && as->type != AS_ASSUMED_SIZE) + { + GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest); + suppress_warning (GFC_TYPE_ARRAY_SIZE (type)); + } + + if (POINTER_TYPE_P (type)) + { + gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type))); + gcc_assert (TYPE_LANG_SPECIFIC (type) + == TYPE_LANG_SPECIFIC (TREE_TYPE (type))); + type = TREE_TYPE (type); + } + + if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type)) + { + tree size, range; + + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node); + range = build_range_type (gfc_array_index_type, gfc_index_zero_node, + size); + TYPE_DOMAIN (type) = range; + layout_type (type); + } + + if (TYPE_NAME (type) != NULL_TREE && as->rank > 0 + && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE + && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1))) + { + tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type)); + + for (dim = 0; dim < as->rank - 1; dim++) + { + gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); + gtype = TREE_TYPE (gtype); + } + gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); + if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL) + TYPE_NAME (type) = NULL_TREE; + } + + if (TYPE_NAME (type) == NULL_TREE) + { + tree gtype = TREE_TYPE (type), rtype, type_decl; + + for (dim = as->rank - 1; dim >= 0; dim--) + { + tree lbound, ubound; + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + rtype = build_range_type (gfc_array_index_type, lbound, ubound); + gtype = build_array_type (gtype, rtype); + /* Ensure the bound variables aren't optimized out at -O0. + For -O1 and above they often will be optimized out, but + can be tracked by VTA. Also set DECL_NAMELESS, so that + the artificial lbound.N or ubound.N DECL_NAME doesn't + end up in debug info. */ + if (lbound + && VAR_P (lbound) + && DECL_ARTIFICIAL (lbound) + && DECL_IGNORED_P (lbound)) + { + if (DECL_NAME (lbound) + && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)), + "lbound") != 0) + DECL_NAMELESS (lbound) = 1; + DECL_IGNORED_P (lbound) = 0; + } + if (ubound + && VAR_P (ubound) + && DECL_ARTIFICIAL (ubound) + && DECL_IGNORED_P (ubound)) + { + if (DECL_NAME (ubound) + && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)), + "ubound") != 0) + DECL_NAMELESS (ubound) = 1; + DECL_IGNORED_P (ubound) = 0; + } + } + TYPE_NAME (type) = type_decl = build_decl (input_location, + TYPE_DECL, NULL, gtype); + DECL_ORIGINAL_TYPE (type_decl) = gtype; + } +} + + +/* For some dummy arguments we don't use the actual argument directly. + Instead we create a local decl and use that. This allows us to perform + initialization, and construct full type information. */ + +static tree +gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) +{ + tree decl; + tree type; + gfc_array_spec *as; + symbol_attribute *array_attr; + char *name; + gfc_packed packed; + int n; + bool known_size; + bool is_classarray = IS_CLASS_ARRAY (sym); + + /* Use the array as and attr. */ + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + + /* The dummy is returned for pointer, allocatable or assumed rank arrays. + For class arrays the information if sym is an allocatable or pointer + object needs to be checked explicitly (IS_CLASS_ARRAY can be false for + too many reasons to be of use here). */ + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable + || (as && as->type == AS_ASSUMED_RANK)) + return dummy; + + /* Add to list of variables if not a fake result variable. + These symbols are set on the symbol only, not on the class component. */ + if (sym->attr.result || sym->attr.dummy) + gfc_defer_symbol_init (sym); + + /* For a class array the array descriptor is in the _data component, while + for a regular array the TREE_TYPE of the dummy is a pointer to the + descriptor. */ + type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy) + : TREE_TYPE (dummy)); + /* type now is the array descriptor w/o any indirection. */ + gcc_assert (TREE_CODE (dummy) == PARM_DECL + && POINTER_TYPE_P (TREE_TYPE (dummy))); + + /* Do we know the element size? */ + known_size = sym->ts.type != BT_CHARACTER + || INTEGER_CST_P (sym->ts.u.cl->backend_decl); + + if (known_size && !GFC_DESCRIPTOR_TYPE_P (type)) + { + /* For descriptorless arrays with known element size the actual + argument is sufficient. */ + gfc_build_qualified_array (dummy, sym); + return dummy; + } + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + /* Create a descriptorless array pointer. */ + packed = PACKED_NO; + + /* Even when -frepack-arrays is used, symbols with TARGET attribute + are not repacked. */ + if (!flag_repack_arrays || sym->attr.target) + { + if (as->type == AS_ASSUMED_SIZE) + packed = PACKED_FULL; + } + else + { + if (as->type == AS_EXPLICIT) + { + packed = PACKED_FULL; + for (n = 0; n < as->rank; n++) + { + if (!(as->upper[n] + && as->lower[n] + && as->upper[n]->expr_type == EXPR_CONSTANT + && as->lower[n]->expr_type == EXPR_CONSTANT)) + { + packed = PACKED_PARTIAL; + break; + } + } + } + else + packed = PACKED_PARTIAL; + } + + /* For classarrays the element type is required, but + gfc_typenode_for_spec () returns the array descriptor. */ + type = is_classarray ? gfc_get_element_type (type) + : gfc_typenode_for_spec (&sym->ts); + type = gfc_get_nodesc_array_type (type, as, packed, + !sym->attr.target); + } + else + { + /* We now have an expression for the element size, so create a fully + qualified type. Reset sym->backend decl or this will just return the + old type. */ + DECL_ARTIFICIAL (sym->backend_decl) = 1; + sym->backend_decl = NULL_TREE; + type = gfc_sym_type (sym); + packed = PACKED_FULL; + } + + ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0); + decl = build_decl (input_location, + VAR_DECL, get_identifier (name), type); + + DECL_ARTIFICIAL (decl) = 1; + DECL_NAMELESS (decl) = 1; + TREE_PUBLIC (decl) = 0; + TREE_STATIC (decl) = 0; + DECL_EXTERNAL (decl) = 0; + + /* Avoid uninitialized warnings for optional dummy arguments. */ + if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) + || sym->attr.optional) + suppress_warning (decl); + + /* We should never get deferred shape arrays here. We used to because of + frontend bugs. */ + gcc_assert (as->type != AS_DEFERRED); + + if (packed == PACKED_PARTIAL) + GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1; + else if (packed == PACKED_FULL) + GFC_DECL_PACKED_ARRAY (decl) = 1; + + gfc_build_qualified_array (decl, sym); + + if (DECL_LANG_SPECIFIC (dummy)) + DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy); + else + gfc_allocate_lang_decl (decl); + + GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy; + + if (sym->ns->proc_name->backend_decl == current_function_decl + || sym->attr.contained) + gfc_add_decl_to_function (decl); + else + gfc_add_decl_to_parent_function (decl); + + return decl; +} + +/* Return a constant or a variable to use as a string length. Does not + add the decl to the current scope. */ + +static tree +gfc_create_string_length (gfc_symbol * sym) +{ + gcc_assert (sym->ts.u.cl); + gfc_conv_const_charlen (sym->ts.u.cl); + + if (sym->ts.u.cl->backend_decl == NULL_TREE) + { + tree length; + const char *name; + + /* The string length variable shall be in static memory if it is either + explicitly SAVED, a module variable or with -fno-automatic. Only + relevant is "len=:" - otherwise, it is either a constant length or + it is an automatic variable. */ + bool static_length = sym->attr.save + || sym->ns->proc_name->attr.flavor == FL_MODULE + || (flag_max_stack_var_size == 0 + && sym->ts.deferred && !sym->attr.dummy + && !sym->attr.result && !sym->attr.function); + + /* Also prefix the mangled name. We need to call GFC_PREFIX for static + variables as some systems do not support the "." in the assembler name. + For nonstatic variables, the "." does not appear in assembler. */ + if (static_length) + { + if (sym->module) + name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module, + sym->name); + else + name = gfc_get_string (GFC_PREFIX ("%s"), sym->name); + } + else if (sym->module) + name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name); + else + name = gfc_get_string (".%s", sym->name); + + length = build_decl (input_location, + VAR_DECL, get_identifier (name), + gfc_charlen_type_node); + DECL_ARTIFICIAL (length) = 1; + TREE_USED (length) = 1; + if (sym->ns->proc_name->tlink != NULL) + gfc_defer_symbol_init (sym); + + sym->ts.u.cl->backend_decl = length; + + if (static_length) + TREE_STATIC (length) = 1; + + if (sym->ns->proc_name->attr.flavor == FL_MODULE + && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)) + TREE_PUBLIC (length) = 1; + } + + gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE); + return sym->ts.u.cl->backend_decl; +} + +/* If a variable is assigned a label, we add another two auxiliary + variables. */ + +static void +gfc_add_assign_aux_vars (gfc_symbol * sym) +{ + tree addr; + tree length; + tree decl; + + gcc_assert (sym->backend_decl); + + decl = sym->backend_decl; + gfc_allocate_lang_decl (decl); + GFC_DECL_ASSIGN (decl) = 1; + length = build_decl (input_location, + VAR_DECL, create_tmp_var_name (sym->name), + gfc_charlen_type_node); + addr = build_decl (input_location, + VAR_DECL, create_tmp_var_name (sym->name), + pvoid_type_node); + gfc_finish_var_decl (length, sym); + gfc_finish_var_decl (addr, sym); + /* STRING_LENGTH is also used as flag. Less than -1 means that + ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the + target label's address. Otherwise, value is the length of a format string + and ASSIGN_ADDR is its address. */ + if (TREE_STATIC (length)) + DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2); + else + gfc_defer_symbol_init (sym); + + GFC_DECL_STRING_LEN (decl) = length; + GFC_DECL_ASSIGN_ADDR (decl) = addr; +} + + +static tree +add_attributes_to_decl (symbol_attribute sym_attr, tree list) +{ + unsigned id; + tree attr; + + for (id = 0; id < EXT_ATTR_NUM; id++) + if (sym_attr.ext_attr & (1 << id) && ext_attr_list[id].middle_end_name) + { + attr = build_tree_list ( + get_identifier (ext_attr_list[id].middle_end_name), + NULL_TREE); + list = chainon (list, attr); + } + + tree clauses = NULL_TREE; + + if (sym_attr.oacc_routine_lop != OACC_ROUTINE_LOP_NONE) + { + omp_clause_code code; + switch (sym_attr.oacc_routine_lop) + { + case OACC_ROUTINE_LOP_GANG: + code = OMP_CLAUSE_GANG; + break; + case OACC_ROUTINE_LOP_WORKER: + code = OMP_CLAUSE_WORKER; + break; + case OACC_ROUTINE_LOP_VECTOR: + code = OMP_CLAUSE_VECTOR; + break; + case OACC_ROUTINE_LOP_SEQ: + code = OMP_CLAUSE_SEQ; + break; + case OACC_ROUTINE_LOP_NONE: + case OACC_ROUTINE_LOP_ERROR: + default: + gcc_unreachable (); + } + tree c = build_omp_clause (UNKNOWN_LOCATION, code); + OMP_CLAUSE_CHAIN (c) = clauses; + clauses = c; + + tree dims = oacc_build_routine_dims (clauses); + list = oacc_replace_fn_attrib_attr (list, dims); + } + + if (sym_attr.oacc_routine_nohost) + { + tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_NOHOST); + OMP_CLAUSE_CHAIN (c) = clauses; + clauses = c; + } + + if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) + { + tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); + switch (sym_attr.omp_device_type) + { + case OMP_DEVICE_TYPE_HOST: + OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST; + break; + case OMP_DEVICE_TYPE_NOHOST: + OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST; + break; + case OMP_DEVICE_TYPE_ANY: + OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY; + break; + default: + gcc_unreachable (); + } + OMP_CLAUSE_CHAIN (c) = clauses; + clauses = c; + } + + if (sym_attr.omp_declare_target_link + || sym_attr.oacc_declare_link) + list = tree_cons (get_identifier ("omp declare target link"), + clauses, list); + else if (sym_attr.omp_declare_target + || sym_attr.oacc_declare_create + || sym_attr.oacc_declare_copyin + || sym_attr.oacc_declare_deviceptr + || sym_attr.oacc_declare_device_resident) + list = tree_cons (get_identifier ("omp declare target"), + clauses, list); + + return list; +} + + +static void build_function_decl (gfc_symbol * sym, bool global); + + +/* Return the decl for a gfc_symbol, create it if it doesn't already + exist. */ + +tree +gfc_get_symbol_decl (gfc_symbol * sym) +{ + tree decl; + tree length = NULL_TREE; + tree attributes; + int byref; + bool intrinsic_array_parameter = false; + bool fun_or_res; + + gcc_assert (sym->attr.referenced + || sym->attr.flavor == FL_PROCEDURE + || sym->attr.use_assoc + || sym->attr.used_in_submodule + || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY + || (sym->module && sym->attr.if_source != IFSRC_DECL + && sym->backend_decl)); + + if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c + && is_CFI_desc (sym, NULL)) + { + gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER + || sym->ts.u.cl->backend_decl)); + return sym->backend_decl; + } + + if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function) + byref = gfc_return_by_reference (sym->ns->proc_name); + else + byref = 0; + + /* Make sure that the vtab for the declared type is completed. */ + if (sym->ts.type == BT_CLASS) + { + gfc_component *c = CLASS_DATA (sym); + if (!c->ts.u.derived->backend_decl) + { + gfc_find_derived_vtab (c->ts.u.derived); + gfc_get_derived_type (sym->ts.u.derived); + } + } + + /* PDT parameterized array components and string_lengths must have the + 'len' parameters substituted for the expressions appearing in the + declaration of the entity and memory allocated/deallocated. */ + if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + && sym->param_list != NULL + && gfc_current_ns == sym->ns + && !(sym->attr.use_assoc || sym->attr.dummy)) + gfc_defer_symbol_init (sym); + + /* Dummy PDT 'len' parameters should be checked when they are explicit. */ + if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && sym->param_list != NULL + && sym->attr.dummy) + gfc_defer_symbol_init (sym); + + /* All deferred character length procedures need to retain the backend + decl, which is a pointer to the character length in the caller's + namespace and to declare a local character length. */ + if (!byref && sym->attr.function + && sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && sym->ts.u.cl->passed_length == NULL + && sym->ts.u.cl->backend_decl + && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) + { + sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; + gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))); + sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); + } + + fun_or_res = byref && (sym->attr.result + || (sym->attr.function && sym->ts.deferred)); + if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res) + { + /* Return via extra parameter. */ + if (sym->attr.result && byref + && !sym->backend_decl) + { + sym->backend_decl = + DECL_ARGUMENTS (sym->ns->proc_name->backend_decl); + /* For entry master function skip over the __entry + argument. */ + if (sym->ns->proc_name->attr.entry_master) + sym->backend_decl = DECL_CHAIN (sym->backend_decl); + } + + /* Dummy variables should already have been created. */ + gcc_assert (sym->backend_decl); + + /* However, the string length of deferred arrays must be set. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && sym->attr.dimension + && sym->attr.allocatable) + gfc_defer_symbol_init (sym); + + if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) + GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; + + /* Create a character length variable. */ + if (sym->ts.type == BT_CHARACTER) + { + /* For a deferred dummy, make a new string length variable. */ + if (sym->ts.deferred + && + (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl)) + sym->ts.u.cl->backend_decl = NULL_TREE; + + if (sym->ts.deferred && byref) + { + /* The string length of a deferred char array is stored in the + parameter at sym->ts.u.cl->backend_decl as a reference and + marked as a result. Exempt this variable from generating a + temporary for it. */ + if (sym->attr.result) + { + /* We need to insert a indirect ref for param decls. */ + if (sym->ts.u.cl->backend_decl + && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) + { + sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; + sym->ts.u.cl->backend_decl = + build_fold_indirect_ref (sym->ts.u.cl->backend_decl); + } + } + /* For all other parameters make sure, that they are copied so + that the value and any modifications are local to the routine + by generating a temporary variable. */ + else if (sym->attr.function + && sym->ts.u.cl->passed_length == NULL + && sym->ts.u.cl->backend_decl) + { + sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; + if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))) + sym->ts.u.cl->backend_decl + = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); + else + sym->ts.u.cl->backend_decl = NULL_TREE; + } + } + + if (sym->ts.u.cl->backend_decl == NULL_TREE) + length = gfc_create_string_length (sym); + else + length = sym->ts.u.cl->backend_decl; + if (VAR_P (length) && DECL_FILE_SCOPE_P (length)) + { + /* Add the string length to the same context as the symbol. */ + if (DECL_CONTEXT (length) == NULL_TREE) + { + if (sym->backend_decl == current_function_decl + || (DECL_CONTEXT (sym->backend_decl) + == current_function_decl)) + gfc_add_decl_to_function (length); + else + gfc_add_decl_to_parent_function (length); + } + + gcc_assert (sym->backend_decl == current_function_decl + ? DECL_CONTEXT (length) == current_function_decl + : (DECL_CONTEXT (sym->backend_decl) + == DECL_CONTEXT (length))); + + gfc_defer_symbol_init (sym); + } + } + + /* Use a copy of the descriptor for dummy arrays. */ + if ((sym->attr.dimension || sym->attr.codimension) + && !TREE_USED (sym->backend_decl)) + { + decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); + /* Prevent the dummy from being detected as unused if it is copied. */ + if (sym->backend_decl != NULL && decl != sym->backend_decl) + DECL_ARTIFICIAL (sym->backend_decl) = 1; + sym->backend_decl = decl; + } + + /* Returning the descriptor for dummy class arrays is hazardous, because + some caller is expecting an expression to apply the component refs to. + Therefore the descriptor is only created and stored in + sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then + responsible to extract it from there, when the descriptor is + desired. */ + if (IS_CLASS_ARRAY (sym) + && (!DECL_LANG_SPECIFIC (sym->backend_decl) + || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) + { + decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); + /* Prevent the dummy from being detected as unused if it is copied. */ + if (sym->backend_decl != NULL && decl != sym->backend_decl) + DECL_ARTIFICIAL (sym->backend_decl) = 1; + sym->backend_decl = decl; + } + + TREE_USED (sym->backend_decl) = 1; + if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) + gfc_add_assign_aux_vars (sym); + + if (sym->ts.type == BT_CLASS && sym->backend_decl) + GFC_DECL_CLASS(sym->backend_decl) = 1; + + return sym->backend_decl; + } + + if (sym->result == sym && sym->attr.assign + && GFC_DECL_ASSIGN (sym->backend_decl) == 0) + gfc_add_assign_aux_vars (sym); + + if (sym->backend_decl) + return sym->backend_decl; + + /* Special case for array-valued named constants from intrinsic + procedures; those are inlined. */ + if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER + && (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV + || sym->from_intmod == INTMOD_ISO_C_BINDING)) + intrinsic_array_parameter = true; + + /* If use associated compilation, use the module + declaration. */ + if ((sym->attr.flavor == FL_VARIABLE + || sym->attr.flavor == FL_PARAMETER) + && (sym->attr.use_assoc || sym->attr.used_in_submodule) + && !intrinsic_array_parameter + && sym->module + && gfc_get_module_backend_decl (sym)) + { + if (sym->ts.type == BT_CLASS && sym->backend_decl) + GFC_DECL_CLASS(sym->backend_decl) = 1; + return sym->backend_decl; + } + + if (sym->attr.flavor == FL_PROCEDURE) + { + /* Catch functions. Only used for actual parameters, + procedure pointers and procptr initialization targets. */ + if (sym->attr.use_assoc + || sym->attr.used_in_submodule + || sym->attr.intrinsic + || sym->attr.if_source != IFSRC_DECL) + { + decl = gfc_get_extern_function_decl (sym); + } + else + { + if (!sym->backend_decl) + build_function_decl (sym, false); + decl = sym->backend_decl; + } + return decl; + } + + if (sym->attr.intrinsic) + gfc_internal_error ("intrinsic variable which isn't a procedure"); + + /* Create string length decl first so that they can be used in the + type declaration. For associate names, the target character + length is used. Set 'length' to a constant so that if the + string length is a variable, it is not finished a second time. */ + if (sym->ts.type == BT_CHARACTER) + { + if (sym->attr.associate_var + && sym->ts.deferred + && sym->assoc && sym->assoc->target + && ((sym->assoc->target->expr_type == EXPR_VARIABLE + && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER) + || sym->assoc->target->expr_type != EXPR_VARIABLE)) + sym->ts.u.cl->backend_decl = NULL_TREE; + + if (sym->attr.associate_var + && sym->ts.u.cl->backend_decl + && (VAR_P (sym->ts.u.cl->backend_decl) + || TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)) + length = gfc_index_zero_node; + else + length = gfc_create_string_length (sym); + } + + /* Create the decl for the variable. */ + decl = build_decl (gfc_get_location (&sym->declared_at), + VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym)); + + /* Add attributes to variables. Functions are handled elsewhere. */ + attributes = add_attributes_to_decl (sym->attr, NULL_TREE); + decl_attributes (&decl, attributes, 0); + + /* Symbols from modules should have their assembler names mangled. + This is done here rather than in gfc_finish_var_decl because it + is different for string length variables. */ + if (sym->module || sym->fn_result_spec) + { + gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); + if (sym->attr.use_assoc && !intrinsic_array_parameter) + DECL_IGNORED_P (decl) = 1; + } + + if (sym->attr.select_type_temporary) + { + DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; + } + + if (sym->attr.dimension || sym->attr.codimension) + { + /* Create variables to hold the non-constant bits of array info. */ + gfc_build_qualified_array (decl, sym); + + if (sym->attr.contiguous + || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)) + GFC_DECL_PACKED_ARRAY (decl) = 1; + } + + /* Remember this variable for allocation/cleanup. */ + if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension + || (sym->ts.type == BT_CLASS && + (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.allocatable)) + || (sym->ts.type == BT_DERIVED + && (sym->ts.u.derived->attr.alloc_comp + || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save + && !sym->ns->proc_name->attr.is_main_program + && gfc_is_finalizable (sym->ts.u.derived, NULL)))) + /* This applies a derived type default initializer. */ + || (sym->ts.type == BT_DERIVED + && sym->attr.save == SAVE_NONE + && !sym->attr.data + && !sym->attr.allocatable + && (sym->value && !sym->ns->proc_name->attr.is_main_program) + && !(sym->attr.use_assoc && !intrinsic_array_parameter))) + gfc_defer_symbol_init (sym); + + if (sym->ts.type == BT_CHARACTER + && sym->attr.allocatable + && !sym->attr.dimension + && sym->ts.u.cl && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE) + gfc_defer_symbol_init (sym); + + /* Associate names can use the hidden string length variable + of their associated target. */ + if (sym->ts.type == BT_CHARACTER + && TREE_CODE (length) != INTEGER_CST + && TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF) + { + length = fold_convert (gfc_charlen_type_node, length); + gfc_finish_var_decl (length, sym); + if (!sym->attr.associate_var + && TREE_CODE (length) == VAR_DECL + && sym->value && sym->value->expr_type != EXPR_NULL + && sym->value->ts.u.cl->length) + { + gfc_expr *len = sym->value->ts.u.cl->length; + DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts, + TREE_TYPE (length), + false, false, false); + DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node, + DECL_INITIAL (length)); + } + else + gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL); + } + + gfc_finish_var_decl (decl, sym); + + if (sym->ts.type == BT_CHARACTER) + /* Character variables need special handling. */ + gfc_allocate_lang_decl (decl); + + if (sym->assoc && sym->attr.subref_array_pointer) + sym->attr.pointer = 1; + + if (sym->attr.pointer && sym->attr.dimension + && !sym->ts.deferred + && !(sym->attr.select_type_temporary + && !sym->attr.subref_array_pointer)) + GFC_DECL_PTR_ARRAY_P (decl) = 1; + + if (sym->ts.type == BT_CLASS) + GFC_DECL_CLASS(decl) = 1; + + sym->backend_decl = decl; + + if (sym->attr.assign) + gfc_add_assign_aux_vars (sym); + + if (intrinsic_array_parameter) + { + TREE_STATIC (decl) = 1; + DECL_EXTERNAL (decl) = 0; + } + + if (TREE_STATIC (decl) + && !(sym->attr.use_assoc && !intrinsic_array_parameter) + && (sym->attr.save || sym->ns->proc_name->attr.is_main_program + || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) + || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE) + && (flag_coarray != GFC_FCOARRAY_LIB + || !sym->attr.codimension || sym->attr.allocatable) + && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + && !(sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)) + { + /* Add static initializer. For procedures, it is only needed if + SAVE is specified otherwise they need to be reinitialized + every time the procedure is entered. The TREE_STATIC is + in this case due to -fmax-stack-var-size=. */ + + DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, + TREE_TYPE (decl), sym->attr.dimension + || (sym->attr.codimension + && sym->attr.allocatable), + sym->attr.pointer || sym->attr.allocatable + || sym->ts.type == BT_CLASS, + sym->attr.proc_pointer); + } + + if (!TREE_STATIC (decl) + && POINTER_TYPE_P (TREE_TYPE (decl)) + && !sym->attr.pointer + && !sym->attr.allocatable + && !sym->attr.proc_pointer + && !sym->attr.select_type_temporary) + DECL_BY_REFERENCE (decl) = 1; + + if (sym->attr.associate_var) + GFC_DECL_ASSOCIATE_VAR_P (decl) = 1; + + /* We only longer mark __def_init as read-only if it actually has an + initializer, it does not needlessly take up space in the + read-only section and can go into the BSS instead, see PR 84487. + Marking this as artificial means that OpenMP will treat this as + predetermined shared. */ + + bool def_init = startswith (sym->name, "__def_init"); + + if (sym->attr.vtab || def_init) + { + DECL_ARTIFICIAL (decl) = 1; + if (def_init && sym->value) + TREE_READONLY (decl) = 1; + } + + return decl; +} + + +/* Substitute a temporary variable in place of the real one. */ + +void +gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save) +{ + save->attr = sym->attr; + save->decl = sym->backend_decl; + + gfc_clear_attr (&sym->attr); + sym->attr.referenced = 1; + sym->attr.flavor = FL_VARIABLE; + + sym->backend_decl = decl; +} + + +/* Restore the original variable. */ + +void +gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save) +{ + sym->attr = save->attr; + sym->backend_decl = save->decl; +} + + +/* Declare a procedure pointer. */ + +static tree +get_proc_pointer_decl (gfc_symbol *sym) +{ + tree decl; + tree attributes; + + if (sym->module || sym->fn_result_spec) + { + const char *name; + gfc_gsymbol *gsym; + + name = mangled_identifier (sym); + gsym = gfc_find_gsymbol (gfc_gsym_root, name); + if (gsym != NULL) + { + gfc_symbol *s; + gfc_find_symbol (sym->name, gsym->ns, 0, &s); + if (s && s->backend_decl) + return s->backend_decl; + } + } + + decl = sym->backend_decl; + if (decl) + return decl; + + decl = build_decl (input_location, + VAR_DECL, get_identifier (sym->name), + build_pointer_type (gfc_get_function_type (sym))); + + if (sym->module) + { + /* Apply name mangling. */ + gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); + if (sym->attr.use_assoc) + DECL_IGNORED_P (decl) = 1; + } + + if ((sym->ns->proc_name + && sym->ns->proc_name->backend_decl == current_function_decl) + || sym->attr.contained) + gfc_add_decl_to_function (decl); + else if (sym->ns->proc_name->attr.flavor != FL_MODULE) + gfc_add_decl_to_parent_function (decl); + + sym->backend_decl = decl; + + /* If a variable is USE associated, it's always external. */ + if (sym->attr.use_assoc) + { + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + } + else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE) + { + /* This is the declaration of a module variable. */ + TREE_PUBLIC (decl) = 1; + if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) + { + DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; + DECL_VISIBILITY_SPECIFIED (decl) = true; + } + TREE_STATIC (decl) = 1; + } + + if (!sym->attr.use_assoc + && (sym->attr.save != SAVE_NONE || sym->attr.data + || (sym->value && sym->ns->proc_name->attr.is_main_program))) + TREE_STATIC (decl) = 1; + + if (TREE_STATIC (decl) && sym->value) + { + /* Add static initializer. */ + DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, + TREE_TYPE (decl), + sym->attr.dimension, + false, true); + } + + /* Handle threadprivate procedure pointers. */ + if (sym->attr.threadprivate + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + set_decl_tls_model (decl, decl_default_tls_model (decl)); + + attributes = add_attributes_to_decl (sym->attr, NULL_TREE); + decl_attributes (&decl, attributes, 0); + + return decl; +} + + +/* Get a basic decl for an external function. */ + +tree +gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) +{ + tree type; + tree fndecl; + tree attributes; + gfc_expr e; + gfc_intrinsic_sym *isym; + gfc_expr argexpr; + char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */ + tree name; + tree mangled_name; + gfc_gsymbol *gsym; + + if (sym->backend_decl) + return sym->backend_decl; + + /* We should never be creating external decls for alternate entry points. + The procedure may be an alternate entry point, but we don't want/need + to know that. */ + gcc_assert (!(sym->attr.entry || sym->attr.entry_master)); + + if (sym->attr.proc_pointer) + return get_proc_pointer_decl (sym); + + /* See if this is an external procedure from the same file. If so, + return the backend_decl. If we are looking at a BIND(C) + procedure and the symbol is not BIND(C), or vice versa, we + haven't found the right procedure. */ + + if (sym->binding_label) + { + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label); + if (gsym && !gsym->bind_c) + gsym = NULL; + } + else if (sym->module == NULL) + { + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); + if (gsym && gsym->bind_c) + gsym = NULL; + } + else + { + /* Procedure from a different module. */ + gsym = NULL; + } + + if (gsym && !gsym->defined) + gsym = NULL; + + /* This can happen because of C binding. */ + if (gsym && gsym->ns && gsym->ns->proc_name + && gsym->ns->proc_name->attr.flavor == FL_MODULE) + goto module_sym; + + if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL) + && !sym->backend_decl + && gsym && gsym->ns + && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) + && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic)) + { + if (!gsym->ns->proc_name->backend_decl) + { + /* By construction, the external function cannot be + a contained procedure. */ + locus old_loc; + + gfc_save_backend_locus (&old_loc); + push_cfun (NULL); + + gfc_create_function_decl (gsym->ns, true); + + pop_cfun (); + gfc_restore_backend_locus (&old_loc); + } + + /* If the namespace has entries, the proc_name is the + entry master. Find the entry and use its backend_decl. + otherwise, use the proc_name backend_decl. */ + if (gsym->ns->entries) + { + gfc_entry_list *entry = gsym->ns->entries; + + for (; entry; entry = entry->next) + { + if (strcmp (gsym->name, entry->sym->name) == 0) + { + sym->backend_decl = entry->sym->backend_decl; + break; + } + } + } + else + sym->backend_decl = gsym->ns->proc_name->backend_decl; + + if (sym->backend_decl) + { + /* Avoid problems of double deallocation of the backend declaration + later in gfc_trans_use_stmts; cf. PR 45087. */ + if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc) + sym->attr.use_assoc = 0; + + return sym->backend_decl; + } + } + + /* See if this is a module procedure from the same file. If so, + return the backend_decl. */ + if (sym->module) + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); + +module_sym: + if (gsym && gsym->ns + && (gsym->type == GSYM_MODULE + || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE))) + { + gfc_symbol *s; + + s = NULL; + if (gsym->type == GSYM_MODULE) + gfc_find_symbol (sym->name, gsym->ns, 0, &s); + else + gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s); + + if (s && s->backend_decl) + { + if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) + gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, + true); + else if (sym->ts.type == BT_CHARACTER) + sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; + sym->backend_decl = s->backend_decl; + return sym->backend_decl; + } + } + + if (sym->attr.intrinsic) + { + /* Call the resolution function to get the actual name. This is + a nasty hack which relies on the resolution functions only looking + at the first argument. We pass NULL for the second argument + otherwise things like AINT get confused. */ + isym = gfc_find_function (sym->name); + gcc_assert (isym->resolve.f0 != NULL); + + memset (&e, 0, sizeof (e)); + e.expr_type = EXPR_FUNCTION; + + memset (&argexpr, 0, sizeof (argexpr)); + gcc_assert (isym->formal); + argexpr.ts = isym->formal->ts; + + if (isym->formal->next == NULL) + isym->resolve.f1 (&e, &argexpr); + else + { + if (isym->formal->next->next == NULL) + isym->resolve.f2 (&e, &argexpr, NULL); + else + { + if (isym->formal->next->next->next == NULL) + isym->resolve.f3 (&e, &argexpr, NULL, NULL); + else + { + /* All specific intrinsics take less than 5 arguments. */ + gcc_assert (isym->formal->next->next->next->next == NULL); + isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); + } + } + } + + if (flag_f2c + && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind) + || e.ts.type == BT_COMPLEX)) + { + /* Specific which needs a different implementation if f2c + calling conventions are used. */ + sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name); + } + else + sprintf (s, "_gfortran_specific%s", e.value.function.name); + + name = get_identifier (s); + mangled_name = name; + } + else + { + name = gfc_sym_identifier (sym); + mangled_name = gfc_sym_mangled_function_id (sym); + } + + type = gfc_get_function_type (sym, actual_args, fnspec); + + fndecl = build_decl (input_location, + FUNCTION_DECL, name, type); + + /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes; + TREE_PUBLIC specifies whether a function is globally addressable (i.e. + the opposite of declaring a function as static in C). */ + DECL_EXTERNAL (fndecl) = 1; + TREE_PUBLIC (fndecl) = 1; + + attributes = add_attributes_to_decl (sym->attr, NULL_TREE); + decl_attributes (&fndecl, attributes, 0); + + gfc_set_decl_assembler_name (fndecl, mangled_name); + + /* Set the context of this decl. */ + if (0 && sym->ns && sym->ns->proc_name) + { + /* TODO: Add external decls to the appropriate scope. */ + DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl; + } + else + { + /* Global declaration, e.g. intrinsic subroutine. */ + DECL_CONTEXT (fndecl) = NULL_TREE; + } + + /* Set attributes for PURE functions. A call to PURE function in the + Fortran 95 sense is both pure and without side effects in the C + sense. */ + if (sym->attr.pure || sym->attr.implicit_pure) + { + if (sym->attr.function && !gfc_return_by_reference (sym)) + DECL_PURE_P (fndecl) = 1; + /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT) + parameters and don't use alternate returns (is this + allowed?). In that case, calls to them are meaningless, and + can be optimized away. See also in build_function_decl(). */ + TREE_SIDE_EFFECTS (fndecl) = 0; + } + + /* Mark non-returning functions. */ + if (sym->attr.noreturn) + TREE_THIS_VOLATILE(fndecl) = 1; + + sym->backend_decl = fndecl; + + if (DECL_CONTEXT (fndecl) == NULL_TREE) + pushdecl_top_level (fndecl); + + if (sym->formal_ns + && sym->formal_ns->proc_name == sym) + { + if (sym->formal_ns->omp_declare_simd) + gfc_trans_omp_declare_simd (sym->formal_ns); + if (flag_openmp) + gfc_trans_omp_declare_variant (sym->formal_ns); + } + + return fndecl; +} + + +/* Create a declaration for a procedure. For external functions (in the C + sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is + a master function with alternate entry points. */ + +static void +build_function_decl (gfc_symbol * sym, bool global) +{ + tree fndecl, type, attributes; + symbol_attribute attr; + tree result_decl; + gfc_formal_arglist *f; + + bool module_procedure = sym->attr.module_procedure + && sym->ns + && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE; + + gcc_assert (!sym->attr.external || module_procedure); + + if (sym->backend_decl) + return; + + /* Set the line and filename. sym->declared_at seems to point to the + last statement for subroutines, but it'll do for now. */ + gfc_set_backend_locus (&sym->declared_at); + + /* Allow only one nesting level. Allow public declarations. */ + gcc_assert (current_function_decl == NULL_TREE + || DECL_FILE_SCOPE_P (current_function_decl) + || (TREE_CODE (DECL_CONTEXT (current_function_decl)) + == NAMESPACE_DECL)); + + type = gfc_get_function_type (sym); + fndecl = build_decl (input_location, + FUNCTION_DECL, gfc_sym_identifier (sym), type); + + attr = sym->attr; + + /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes; + TREE_PUBLIC specifies whether a function is globally addressable (i.e. + the opposite of declaring a function as static in C). */ + DECL_EXTERNAL (fndecl) = 0; + + if (sym->attr.access == ACCESS_UNKNOWN && sym->module + && (sym->ns->default_access == ACCESS_PRIVATE + || (sym->ns->default_access == ACCESS_UNKNOWN + && flag_module_private))) + sym->attr.access = ACCESS_PRIVATE; + + if (!current_function_decl + && !sym->attr.entry_master && !sym->attr.is_main_program + && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label + || sym->attr.public_used)) + TREE_PUBLIC (fndecl) = 1; + + if (sym->attr.referenced || sym->attr.entry_master) + TREE_USED (fndecl) = 1; + + attributes = add_attributes_to_decl (attr, NULL_TREE); + decl_attributes (&fndecl, attributes, 0); + + /* Figure out the return type of the declared function, and build a + RESULT_DECL for it. If this is a subroutine with alternate + returns, build a RESULT_DECL for it. */ + result_decl = NULL_TREE; + /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */ + if (attr.function) + { + if (gfc_return_by_reference (sym)) + type = void_type_node; + else + { + if (sym->result != sym) + result_decl = gfc_sym_identifier (sym->result); + + type = TREE_TYPE (TREE_TYPE (fndecl)); + } + } + else + { + /* Look for alternate return placeholders. */ + int has_alternate_returns = 0; + for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) + { + if (f->sym == NULL) + { + has_alternate_returns = 1; + break; + } + } + + if (has_alternate_returns) + type = integer_type_node; + else + type = void_type_node; + } + + result_decl = build_decl (input_location, + RESULT_DECL, result_decl, type); + DECL_ARTIFICIAL (result_decl) = 1; + DECL_IGNORED_P (result_decl) = 1; + DECL_CONTEXT (result_decl) = fndecl; + DECL_RESULT (fndecl) = result_decl; + + /* Don't call layout_decl for a RESULT_DECL. + layout_decl (result_decl, 0); */ + + /* TREE_STATIC means the function body is defined here. */ + TREE_STATIC (fndecl) = 1; + + /* Set attributes for PURE functions. A call to a PURE function in the + Fortran 95 sense is both pure and without side effects in the C + sense. */ + if (attr.pure || attr.implicit_pure) + { + /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments + including an alternate return. In that case it can also be + marked as PURE. See also in gfc_get_extern_function_decl(). */ + if (attr.function && !gfc_return_by_reference (sym)) + DECL_PURE_P (fndecl) = 1; + TREE_SIDE_EFFECTS (fndecl) = 0; + } + + + /* Layout the function declaration and put it in the binding level + of the current function. */ + + if (global) + pushdecl_top_level (fndecl); + else + pushdecl (fndecl); + + /* Perform name mangling if this is a top level or module procedure. */ + if (current_function_decl == NULL_TREE) + gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym)); + + sym->backend_decl = fndecl; +} + + +/* Create the DECL_ARGUMENTS for a procedure. + NOTE: The arguments added here must match the argument type created by + gfc_get_function_type (). */ + +static void +create_function_arglist (gfc_symbol * sym) +{ + tree fndecl; + gfc_formal_arglist *f; + tree typelist, hidden_typelist; + tree arglist, hidden_arglist; + tree type; + tree parm; + + fndecl = sym->backend_decl; + + /* Build formal argument list. Make sure that their TREE_CONTEXT is + the new FUNCTION_DECL node. */ + arglist = NULL_TREE; + hidden_arglist = NULL_TREE; + typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl)); + + if (sym->attr.entry_master) + { + type = TREE_VALUE (typelist); + parm = build_decl (input_location, + PARM_DECL, get_identifier ("__entry"), type); + + DECL_CONTEXT (parm) = fndecl; + DECL_ARG_TYPE (parm) = type; + TREE_READONLY (parm) = 1; + gfc_finish_decl (parm); + DECL_ARTIFICIAL (parm) = 1; + + arglist = chainon (arglist, parm); + typelist = TREE_CHAIN (typelist); + } + + if (gfc_return_by_reference (sym)) + { + tree type = TREE_VALUE (typelist), length = NULL; + + if (sym->ts.type == BT_CHARACTER) + { + /* Length of character result. */ + tree len_type = TREE_VALUE (TREE_CHAIN (typelist)); + + length = build_decl (input_location, + PARM_DECL, + get_identifier (".__result"), + len_type); + if (POINTER_TYPE_P (len_type)) + { + sym->ts.u.cl->passed_length = length; + TREE_USED (length) = 1; + } + else if (!sym->ts.u.cl->length) + { + sym->ts.u.cl->backend_decl = length; + TREE_USED (length) = 1; + } + gcc_assert (TREE_CODE (length) == PARM_DECL); + DECL_CONTEXT (length) = fndecl; + DECL_ARG_TYPE (length) = len_type; + TREE_READONLY (length) = 1; + DECL_ARTIFICIAL (length) = 1; + gfc_finish_decl (length); + if (sym->ts.u.cl->backend_decl == NULL + || sym->ts.u.cl->backend_decl == length) + { + gfc_symbol *arg; + tree backend_decl; + + if (sym->ts.u.cl->backend_decl == NULL) + { + tree len = build_decl (input_location, + VAR_DECL, + get_identifier ("..__result"), + gfc_charlen_type_node); + DECL_ARTIFICIAL (len) = 1; + TREE_USED (len) = 1; + sym->ts.u.cl->backend_decl = len; + } + + /* Make sure PARM_DECL type doesn't point to incomplete type. */ + arg = sym->result ? sym->result : sym; + backend_decl = arg->backend_decl; + /* Temporary clear it, so that gfc_sym_type creates complete + type. */ + arg->backend_decl = NULL; + type = gfc_sym_type (arg); + arg->backend_decl = backend_decl; + type = build_reference_type (type); + } + } + + parm = build_decl (input_location, + PARM_DECL, get_identifier ("__result"), type); + + DECL_CONTEXT (parm) = fndecl; + DECL_ARG_TYPE (parm) = TREE_VALUE (typelist); + TREE_READONLY (parm) = 1; + DECL_ARTIFICIAL (parm) = 1; + gfc_finish_decl (parm); + + arglist = chainon (arglist, parm); + typelist = TREE_CHAIN (typelist); + + if (sym->ts.type == BT_CHARACTER) + { + gfc_allocate_lang_decl (parm); + arglist = chainon (arglist, length); + typelist = TREE_CHAIN (typelist); + } + } + + hidden_typelist = typelist; + for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) + if (f->sym != NULL) /* Ignore alternate returns. */ + hidden_typelist = TREE_CHAIN (hidden_typelist); + + for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) + { + char name[GFC_MAX_SYMBOL_LEN + 2]; + + /* Ignore alternate returns. */ + if (f->sym == NULL) + continue; + + type = TREE_VALUE (typelist); + + if (f->sym->ts.type == BT_CHARACTER + && (!sym->attr.is_bind_c || sym->attr.entry_master)) + { + tree len_type = TREE_VALUE (hidden_typelist); + tree length = NULL_TREE; + if (!f->sym->ts.deferred) + gcc_assert (len_type == gfc_charlen_type_node); + else + gcc_assert (POINTER_TYPE_P (len_type)); + + strcpy (&name[1], f->sym->name); + name[0] = '_'; + length = build_decl (input_location, + PARM_DECL, get_identifier (name), len_type); + + hidden_arglist = chainon (hidden_arglist, length); + DECL_CONTEXT (length) = fndecl; + DECL_ARTIFICIAL (length) = 1; + DECL_ARG_TYPE (length) = len_type; + TREE_READONLY (length) = 1; + gfc_finish_decl (length); + + /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead + to tail calls being disabled. Only do that if we + potentially have broken callers. */ + if (flag_tail_call_workaround + && f->sym->ts.u.cl + && f->sym->ts.u.cl->length + && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT + && (flag_tail_call_workaround == 2 + || f->sym->ns->implicit_interface_calls)) + DECL_HIDDEN_STRING_LENGTH (length) = 1; + + /* Remember the passed value. */ + if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length) + { + /* This can happen if the same type is used for multiple + arguments. We need to copy cl as otherwise + cl->passed_length gets overwritten. */ + f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl); + } + f->sym->ts.u.cl->passed_length = length; + + /* Use the passed value for assumed length variables. */ + if (!f->sym->ts.u.cl->length) + { + TREE_USED (length) = 1; + gcc_assert (!f->sym->ts.u.cl->backend_decl); + f->sym->ts.u.cl->backend_decl = length; + } + + hidden_typelist = TREE_CHAIN (hidden_typelist); + + if (f->sym->ts.u.cl->backend_decl == NULL + || f->sym->ts.u.cl->backend_decl == length) + { + if (POINTER_TYPE_P (len_type)) + f->sym->ts.u.cl->backend_decl + = build_fold_indirect_ref_loc (input_location, length); + else if (f->sym->ts.u.cl->backend_decl == NULL) + gfc_create_string_length (f->sym); + + /* Make sure PARM_DECL type doesn't point to incomplete type. */ + if (f->sym->attr.flavor == FL_PROCEDURE) + type = build_pointer_type (gfc_get_function_type (f->sym)); + else + type = gfc_sym_type (f->sym); + } + } + /* For noncharacter scalar intrinsic types, VALUE passes the value, + hence, the optional status cannot be transferred via a NULL pointer. + Thus, we will use a hidden argument in that case. */ + else if (f->sym->attr.optional && f->sym->attr.value + && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS + && !gfc_bt_struct (f->sym->ts.type)) + { + tree tmp; + strcpy (&name[1], f->sym->name); + name[0] = '_'; + tmp = build_decl (input_location, + PARM_DECL, get_identifier (name), + boolean_type_node); + + hidden_arglist = chainon (hidden_arglist, tmp); + DECL_CONTEXT (tmp) = fndecl; + DECL_ARTIFICIAL (tmp) = 1; + DECL_ARG_TYPE (tmp) = boolean_type_node; + TREE_READONLY (tmp) = 1; + gfc_finish_decl (tmp); + + hidden_typelist = TREE_CHAIN (hidden_typelist); + } + + /* For non-constant length array arguments, make sure they use + a different type node from TYPE_ARG_TYPES type. */ + if (f->sym->attr.dimension + && type == TREE_VALUE (typelist) + && TREE_CODE (type) == POINTER_TYPE + && GFC_ARRAY_TYPE_P (type) + && f->sym->as->type != AS_ASSUMED_SIZE + && ! COMPLETE_TYPE_P (TREE_TYPE (type))) + { + if (f->sym->attr.flavor == FL_PROCEDURE) + type = build_pointer_type (gfc_get_function_type (f->sym)); + else + type = gfc_sym_type (f->sym); + } + + if (f->sym->attr.proc_pointer) + type = build_pointer_type (type); + + if (f->sym->attr.volatile_) + type = build_qualified_type (type, TYPE_QUAL_VOLATILE); + + /* Build the argument declaration. For C descriptors, we use a + '_'-prefixed name for the parm_decl and inside the proc the + sym->name. */ + tree parm_name; + if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL)) + { + strcpy (&name[1], f->sym->name); + name[0] = '_'; + parm_name = get_identifier (name); + } + else + parm_name = gfc_sym_identifier (f->sym); + parm = build_decl (input_location, PARM_DECL, parm_name, type); + + if (f->sym->attr.volatile_) + { + TREE_THIS_VOLATILE (parm) = 1; + TREE_SIDE_EFFECTS (parm) = 1; + } + + /* Fill in arg stuff. */ + DECL_CONTEXT (parm) = fndecl; + DECL_ARG_TYPE (parm) = TREE_VALUE (typelist); + /* All implementation args except for VALUE are read-only. */ + if (!f->sym->attr.value) + TREE_READONLY (parm) = 1; + if (POINTER_TYPE_P (type) + && (!f->sym->attr.proc_pointer + && f->sym->attr.flavor != FL_PROCEDURE)) + DECL_BY_REFERENCE (parm) = 1; + if (f->sym->attr.optional) + { + gfc_allocate_lang_decl (parm); + GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1; + } + + gfc_finish_decl (parm); + gfc_finish_decl_attrs (parm, &f->sym->attr); + + f->sym->backend_decl = parm; + + /* Coarrays which are descriptorless or assumed-shape pass with + -fcoarray=lib the token and the offset as hidden arguments. */ + if (flag_coarray == GFC_FCOARRAY_LIB + && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension + && !f->sym->attr.allocatable) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.codimension + && !CLASS_DATA (f->sym)->attr.allocatable))) + { + tree caf_type; + tree token; + tree offset; + + gcc_assert (f->sym->backend_decl != NULL_TREE + && !sym->attr.is_bind_c); + caf_type = f->sym->ts.type == BT_CLASS + ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl) + : TREE_TYPE (f->sym->backend_decl); + + token = build_decl (input_location, PARM_DECL, + create_tmp_var_name ("caf_token"), + build_qualified_type (pvoid_type_node, + TYPE_QUAL_RESTRICT)); + if ((f->sym->ts.type != BT_CLASS + && f->sym->as->type != AS_DEFERRED) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->as->type != AS_DEFERRED)) + { + gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL + || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE); + if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL) + gfc_allocate_lang_decl (f->sym->backend_decl); + GFC_DECL_TOKEN (f->sym->backend_decl) = token; + } + else + { + gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE); + GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token; + } + + DECL_CONTEXT (token) = fndecl; + DECL_ARTIFICIAL (token) = 1; + DECL_ARG_TYPE (token) = TREE_VALUE (typelist); + TREE_READONLY (token) = 1; + hidden_arglist = chainon (hidden_arglist, token); + hidden_typelist = TREE_CHAIN (hidden_typelist); + gfc_finish_decl (token); + + offset = build_decl (input_location, PARM_DECL, + create_tmp_var_name ("caf_offset"), + gfc_array_index_type); + + if ((f->sym->ts.type != BT_CLASS + && f->sym->as->type != AS_DEFERRED) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->as->type != AS_DEFERRED)) + { + gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl) + == NULL_TREE); + GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset; + } + else + { + gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE); + GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset; + } + DECL_CONTEXT (offset) = fndecl; + DECL_ARTIFICIAL (offset) = 1; + DECL_ARG_TYPE (offset) = TREE_VALUE (typelist); + TREE_READONLY (offset) = 1; + hidden_arglist = chainon (hidden_arglist, offset); + hidden_typelist = TREE_CHAIN (hidden_typelist); + gfc_finish_decl (offset); + } + + arglist = chainon (arglist, parm); + typelist = TREE_CHAIN (typelist); + } + + /* Add the hidden string length parameters, unless the procedure + is bind(C). */ + if (!sym->attr.is_bind_c) + arglist = chainon (arglist, hidden_arglist); + + gcc_assert (hidden_typelist == NULL_TREE + || TREE_VALUE (hidden_typelist) == void_type_node); + DECL_ARGUMENTS (fndecl) = arglist; +} + +/* Do the setup necessary before generating the body of a function. */ + +static void +trans_function_start (gfc_symbol * sym) +{ + tree fndecl; + + fndecl = sym->backend_decl; + + /* Let GCC know the current scope is this function. */ + current_function_decl = fndecl; + + /* Let the world know what we're about to do. */ + announce_function (fndecl); + + if (DECL_FILE_SCOPE_P (fndecl)) + { + /* Create RTL for function declaration. */ + rest_of_decl_compilation (fndecl, 1, 0); + } + + /* Create RTL for function definition. */ + make_decl_rtl (fndecl); + + allocate_struct_function (fndecl, false); + + /* function.c requires a push at the start of the function. */ + pushlevel (); +} + +/* Create thunks for alternate entry points. */ + +static void +build_entry_thunks (gfc_namespace * ns, bool global) +{ + gfc_formal_arglist *formal; + gfc_formal_arglist *thunk_formal; + gfc_entry_list *el; + gfc_symbol *thunk_sym; + stmtblock_t body; + tree thunk_fndecl; + tree tmp; + locus old_loc; + + /* This should always be a toplevel function. */ + gcc_assert (current_function_decl == NULL_TREE); + + gfc_save_backend_locus (&old_loc); + for (el = ns->entries; el; el = el->next) + { + vec *args = NULL; + vec *string_args = NULL; + + thunk_sym = el->sym; + + build_function_decl (thunk_sym, global); + create_function_arglist (thunk_sym); + + trans_function_start (thunk_sym); + + thunk_fndecl = thunk_sym->backend_decl; + + gfc_init_block (&body); + + /* Pass extra parameter identifying this entry point. */ + tmp = build_int_cst (gfc_array_index_type, el->id); + vec_safe_push (args, tmp); + + if (thunk_sym->attr.function) + { + if (gfc_return_by_reference (ns->proc_name)) + { + tree ref = DECL_ARGUMENTS (current_function_decl); + vec_safe_push (args, ref); + if (ns->proc_name->ts.type == BT_CHARACTER) + vec_safe_push (args, DECL_CHAIN (ref)); + } + } + + for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal; + formal = formal->next) + { + /* Ignore alternate returns. */ + if (formal->sym == NULL) + continue; + + /* We don't have a clever way of identifying arguments, so resort to + a brute-force search. */ + for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym); + thunk_formal; + thunk_formal = thunk_formal->next) + { + if (thunk_formal->sym == formal->sym) + break; + } + + if (thunk_formal) + { + /* Pass the argument. */ + DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1; + vec_safe_push (args, thunk_formal->sym->backend_decl); + if (formal->sym->ts.type == BT_CHARACTER) + { + tmp = thunk_formal->sym->ts.u.cl->backend_decl; + vec_safe_push (string_args, tmp); + } + } + else + { + /* Pass NULL for a missing argument. */ + vec_safe_push (args, null_pointer_node); + if (formal->sym->ts.type == BT_CHARACTER) + { + tmp = build_int_cst (gfc_charlen_type_node, 0); + vec_safe_push (string_args, tmp); + } + } + } + + /* Call the master function. */ + vec_safe_splice (args, string_args); + tmp = ns->proc_name->backend_decl; + tmp = build_call_expr_loc_vec (input_location, tmp, args); + if (ns->proc_name->attr.mixed_entry_master) + { + tree union_decl, field; + tree master_type = TREE_TYPE (ns->proc_name->backend_decl); + + union_decl = build_decl (input_location, + VAR_DECL, get_identifier ("__result"), + TREE_TYPE (master_type)); + DECL_ARTIFICIAL (union_decl) = 1; + DECL_EXTERNAL (union_decl) = 0; + TREE_PUBLIC (union_decl) = 0; + TREE_USED (union_decl) = 1; + layout_decl (union_decl, 0); + pushdecl (union_decl); + + DECL_CONTEXT (union_decl) = current_function_decl; + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (union_decl), union_decl, tmp); + gfc_add_expr_to_block (&body, tmp); + + for (field = TYPE_FIELDS (TREE_TYPE (union_decl)); + field; field = DECL_CHAIN (field)) + if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), + thunk_sym->result->name) == 0) + break; + gcc_assert (field != NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), union_decl, field, + NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (DECL_RESULT (current_function_decl)), + DECL_RESULT (current_function_decl), tmp); + tmp = build1_v (RETURN_EXPR, tmp); + } + else if (TREE_TYPE (DECL_RESULT (current_function_decl)) + != void_type_node) + { + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (DECL_RESULT (current_function_decl)), + DECL_RESULT (current_function_decl), tmp); + tmp = build1_v (RETURN_EXPR, tmp); + } + gfc_add_expr_to_block (&body, tmp); + + /* Finish off this function and send it for code generation. */ + DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body); + tmp = getdecls (); + poplevel (1, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl; + DECL_SAVED_TREE (thunk_fndecl) + = fold_build3_loc (DECL_SOURCE_LOCATION (thunk_fndecl), BIND_EXPR, + void_type_node, tmp, DECL_SAVED_TREE (thunk_fndecl), + DECL_INITIAL (thunk_fndecl)); + + /* Output the GENERIC tree. */ + dump_function (TDI_original, thunk_fndecl); + + /* Store the end of the function, so that we get good line number + info for the epilogue. */ + cfun->function_end_locus = input_location; + + /* We're leaving the context of this function, so zap cfun. + It's still in DECL_STRUCT_FUNCTION, and we'll restore it in + tree_rest_of_compilation. */ + set_cfun (NULL); + + current_function_decl = NULL_TREE; + + cgraph_node::finalize_function (thunk_fndecl, true); + + /* We share the symbols in the formal argument list with other entry + points and the master function. Clear them so that they are + recreated for each function. */ + for (formal = gfc_sym_get_dummy_args (thunk_sym); formal; + formal = formal->next) + if (formal->sym != NULL) /* Ignore alternate returns. */ + { + formal->sym->backend_decl = NULL_TREE; + if (formal->sym->ts.type == BT_CHARACTER) + formal->sym->ts.u.cl->backend_decl = NULL_TREE; + } + + if (thunk_sym->attr.function) + { + if (thunk_sym->ts.type == BT_CHARACTER) + thunk_sym->ts.u.cl->backend_decl = NULL_TREE; + if (thunk_sym->result->ts.type == BT_CHARACTER) + thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE; + } + } + + gfc_restore_backend_locus (&old_loc); +} + + +/* Create a decl for a function, and create any thunks for alternate entry + points. If global is true, generate the function in the global binding + level, otherwise in the current binding level (which can be global). */ + +void +gfc_create_function_decl (gfc_namespace * ns, bool global) +{ + /* Create a declaration for the master function. */ + build_function_decl (ns->proc_name, global); + + /* Compile the entry thunks. */ + if (ns->entries) + build_entry_thunks (ns, global); + + /* Now create the read argument list. */ + create_function_arglist (ns->proc_name); + + if (ns->omp_declare_simd) + gfc_trans_omp_declare_simd (ns); + + /* Handle 'declare variant' directives. The applicable directives might + be declared in a parent namespace, so this needs to be called even if + there are no local directives. */ + if (flag_openmp) + gfc_trans_omp_declare_variant (ns); +} + +/* Return the decl used to hold the function return value. If + parent_flag is set, the context is the parent_scope. */ + +tree +gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) +{ + tree decl; + tree length; + tree this_fake_result_decl; + tree this_function_decl; + + char name[GFC_MAX_SYMBOL_LEN + 10]; + + if (parent_flag) + { + this_fake_result_decl = parent_fake_result_decl; + this_function_decl = DECL_CONTEXT (current_function_decl); + } + else + { + this_fake_result_decl = current_fake_result_decl; + this_function_decl = current_function_decl; + } + + if (sym + && sym->ns->proc_name->backend_decl == this_function_decl + && sym->ns->proc_name->attr.entry_master + && sym != sym->ns->proc_name) + { + tree t = NULL, var; + if (this_fake_result_decl != NULL) + for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t)) + if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0) + break; + if (t) + return TREE_VALUE (t); + decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag); + + if (parent_flag) + this_fake_result_decl = parent_fake_result_decl; + else + this_fake_result_decl = current_fake_result_decl; + + if (decl && sym->ns->proc_name->attr.mixed_entry_master) + { + tree field; + + for (field = TYPE_FIELDS (TREE_TYPE (decl)); + field; field = DECL_CHAIN (field)) + if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), + sym->name) == 0) + break; + + gcc_assert (field != NULL_TREE); + decl = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), decl, field, NULL_TREE); + } + + var = create_tmp_var_raw (TREE_TYPE (decl), sym->name); + if (parent_flag) + gfc_add_decl_to_parent_function (var); + else + gfc_add_decl_to_function (var); + + SET_DECL_VALUE_EXPR (var, decl); + DECL_HAS_VALUE_EXPR_P (var) = 1; + GFC_DECL_RESULT (var) = 1; + + TREE_CHAIN (this_fake_result_decl) + = tree_cons (get_identifier (sym->name), var, + TREE_CHAIN (this_fake_result_decl)); + return var; + } + + if (this_fake_result_decl != NULL_TREE) + return TREE_VALUE (this_fake_result_decl); + + /* Only when gfc_get_fake_result_decl is called by gfc_trans_return, + sym is NULL. */ + if (!sym) + return NULL_TREE; + + if (sym->ts.type == BT_CHARACTER) + { + if (sym->ts.u.cl->backend_decl == NULL_TREE) + length = gfc_create_string_length (sym); + else + length = sym->ts.u.cl->backend_decl; + if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE) + gfc_add_decl_to_function (length); + } + + if (gfc_return_by_reference (sym)) + { + decl = DECL_ARGUMENTS (this_function_decl); + + if (sym->ns->proc_name->backend_decl == this_function_decl + && sym->ns->proc_name->attr.entry_master) + decl = DECL_CHAIN (decl); + + TREE_USED (decl) = 1; + if (sym->as) + decl = gfc_build_dummy_array_decl (sym, decl); + } + else + { + sprintf (name, "__result_%.20s", + IDENTIFIER_POINTER (DECL_NAME (this_function_decl))); + + if (!sym->attr.mixed_entry_master && sym->attr.function) + decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), + VAR_DECL, get_identifier (name), + gfc_sym_type (sym)); + else + decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), + VAR_DECL, get_identifier (name), + TREE_TYPE (TREE_TYPE (this_function_decl))); + DECL_ARTIFICIAL (decl) = 1; + DECL_EXTERNAL (decl) = 0; + TREE_PUBLIC (decl) = 0; + TREE_USED (decl) = 1; + GFC_DECL_RESULT (decl) = 1; + TREE_ADDRESSABLE (decl) = 1; + + layout_decl (decl, 0); + gfc_finish_decl_attrs (decl, &sym->attr); + + if (parent_flag) + gfc_add_decl_to_parent_function (decl); + else + gfc_add_decl_to_function (decl); + } + + if (parent_flag) + parent_fake_result_decl = build_tree_list (NULL, decl); + else + current_fake_result_decl = build_tree_list (NULL, decl); + + if (sym->attr.assign) + DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl); + + return decl; +} + + +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. */ + +static tree +build_library_function_decl_1 (tree name, const char *spec, + tree rettype, int nargs, va_list p) +{ + vec *arglist; + tree fntype; + tree fndecl; + int n; + + /* Library functions must be declared with global scope. */ + gcc_assert (current_function_decl == NULL_TREE); + + /* Create a list of the argument types. */ + vec_alloc (arglist, abs (nargs)); + for (n = abs (nargs); n > 0; n--) + { + tree argtype = va_arg (p, tree); + arglist->quick_push (argtype); + } + + /* Build the function type and decl. */ + if (nargs >= 0) + fntype = build_function_type_vec (rettype, arglist); + else + fntype = build_varargs_function_type_vec (rettype, arglist); + if (spec) + { + tree attr_args = build_tree_list (NULL_TREE, + build_string (strlen (spec), spec)); + tree attrs = tree_cons (get_identifier ("fn spec"), + attr_args, TYPE_ATTRIBUTES (fntype)); + fntype = build_type_attribute_variant (fntype, attrs); + } + fndecl = build_decl (input_location, + FUNCTION_DECL, name, fntype); + + /* Mark this decl as external. */ + DECL_EXTERNAL (fndecl) = 1; + TREE_PUBLIC (fndecl) = 1; + + pushdecl (fndecl); + + rest_of_decl_compilation (fndecl, 1, 0); + + return fndecl; +} + +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. */ + +tree +gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) +{ + tree ret; + va_list args; + va_start (args, nargs); + ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args); + va_end (args); + return ret; +} + +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. + The SPEC parameter specifies the function argument and return type + specification according to the fnspec function type attribute. */ + +tree +gfc_build_library_function_decl_with_spec (tree name, const char *spec, + tree rettype, int nargs, ...) +{ + tree ret; + va_list args; + va_start (args, nargs); + if (flag_checking) + { + attr_fnspec fnspec (spec, strlen (spec)); + fnspec.verify (); + } + ret = build_library_function_decl_1 (name, spec, rettype, nargs, args); + va_end (args); + return ret; +} + +static void +gfc_build_intrinsic_function_decls (void) +{ + tree gfc_int4_type_node = gfc_get_int_type (4); + tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); + tree gfc_int8_type_node = gfc_get_int_type (8); + tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node); + tree gfc_int16_type_node = gfc_get_int_type (16); + tree gfc_logical4_type_node = gfc_get_logical_type (4); + tree pchar1_type_node = gfc_get_pchar_type (1); + tree pchar4_type_node = gfc_get_pchar_type (4); + + /* String functions. */ + gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("compare_string")), ". . R . R ", + integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + DECL_PURE_P (gfor_fndecl_compare_string) = 1; + TREE_NOTHROW (gfor_fndecl_compare_string) = 1; + + gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("concat_string")), ". . W . R . R ", + void_type_node, 6, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node); + TREE_NOTHROW (gfor_fndecl_concat_string) = 1; + + gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_len_trim")), ". . R ", + gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node); + DECL_PURE_P (gfor_fndecl_string_len_trim) = 1; + TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1; + + gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_index")), ". . R . R . ", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_index) = 1; + TREE_NOTHROW (gfor_fndecl_string_index) = 1; + + gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_scan")), ". . R . R . ", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_scan) = 1; + TREE_NOTHROW (gfor_fndecl_string_scan) = 1; + + gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_verify")), ". . R . R . ", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_verify) = 1; + TREE_NOTHROW (gfor_fndecl_string_verify) = 1; + + gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_trim")), ". W w . R ", + void_type_node, 4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), gfc_charlen_type_node, + pchar1_type_node); + + gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_minmax")), ". W w . R ", + void_type_node, -4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar1_type_node), integer_type_node, + integer_type_node); + + gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustl")), ". W . R ", + void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, + pchar1_type_node); + TREE_NOTHROW (gfor_fndecl_adjustl) = 1; + + gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustr")), ". W . R ", + void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, + pchar1_type_node); + TREE_NOTHROW (gfor_fndecl_adjustr) = 1; + + gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("select_string")), ". R . R . ", + integer_type_node, 4, pvoid_type_node, integer_type_node, + pchar1_type_node, gfc_charlen_type_node); + DECL_PURE_P (gfor_fndecl_select_string) = 1; + TREE_NOTHROW (gfor_fndecl_select_string) = 1; + + gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("compare_string_char4")), ". . R . R ", + integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node); + DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1; + TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1; + + gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("concat_string_char4")), ". . W . R . R ", + void_type_node, 6, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1; + + gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_len_trim_char4")), ". . R ", + gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node); + DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1; + + gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_index_char4")), ". . R . R . ", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_index_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1; + + gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_scan_char4")), ". . R . R . ", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1; + + gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_verify_char4")), ". . R . R . ", + gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); + DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1; + TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1; + + gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_trim_char4")), ". W w . R ", + void_type_node, 4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), gfc_charlen_type_node, + pchar4_type_node); + + gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("string_minmax_char4")), ". W w . R ", + void_type_node, -4, build_pointer_type (gfc_charlen_type_node), + build_pointer_type (pchar4_type_node), integer_type_node, + integer_type_node); + + gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustl_char4")), ". W . R ", + void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1; + + gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("adjustr_char4")), ". W . R ", + void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, + pchar4_type_node); + TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1; + + gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("select_string_char4")), ". R . R . ", + integer_type_node, 4, pvoid_type_node, integer_type_node, + pvoid_type_node, gfc_charlen_type_node); + DECL_PURE_P (gfor_fndecl_select_string_char4) = 1; + TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1; + + + /* Conversion between character kinds. */ + + gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("convert_char1_to_char4")), ". w . R ", + void_type_node, 3, build_pointer_type (pchar4_type_node), + gfc_charlen_type_node, pchar1_type_node); + + gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("convert_char4_to_char1")), ". w . R ", + void_type_node, 3, build_pointer_type (pchar1_type_node), + gfc_charlen_type_node, pchar4_type_node); + + /* Misc. functions. */ + + gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("ttynam")), ". W . . ", + void_type_node, 3, pchar_type_node, gfc_charlen_type_node, + integer_type_node); + + gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("fdate")), ". W . ", + void_type_node, 2, pchar_type_node, gfc_charlen_type_node); + + gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("ctime")), ". W . . ", + void_type_node, 3, pchar_type_node, gfc_charlen_type_node, + gfc_int8_type_node); + + gfor_fndecl_random_init = gfc_build_library_function_decl ( + get_identifier (PREFIX("random_init")), + void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node, + gfc_int4_type_node); + + // gfor_fndecl_caf_rand_init is defined in the lib-coarray section below. + + gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_char_kind")), ". . R ", + gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node); + DECL_PURE_P (gfor_fndecl_sc_kind) = 1; + TREE_NOTHROW (gfor_fndecl_sc_kind) = 1; + + gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_int_kind")), ". R ", + gfc_int4_type_node, 1, pvoid_type_node); + DECL_PURE_P (gfor_fndecl_si_kind) = 1; + TREE_NOTHROW (gfor_fndecl_si_kind) = 1; + + gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("selected_real_kind2008")), ". R R ", + gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node, + pvoid_type_node); + DECL_PURE_P (gfor_fndecl_sr_kind) = 1; + TREE_NOTHROW (gfor_fndecl_sr_kind) = 1; + + gfor_fndecl_system_clock4 = gfc_build_library_function_decl ( + get_identifier (PREFIX("system_clock_4")), + void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node, + gfc_pint4_type_node); + + gfor_fndecl_system_clock8 = gfc_build_library_function_decl ( + get_identifier (PREFIX("system_clock_8")), + void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node, + gfc_pint8_type_node); + + /* Power functions. */ + { + tree ctype, rtype, itype, jtype; + int rkind, ikind, jkind; +#define NIKINDS 3 +#define NRKINDS 4 + static int ikinds[NIKINDS] = {4, 8, 16}; + static int rkinds[NRKINDS] = {4, 8, 10, 16}; + char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */ + + for (ikind=0; ikind < NIKINDS; ikind++) + { + itype = gfc_get_int_type (ikinds[ikind]); + + for (jkind=0; jkind < NIKINDS; jkind++) + { + jtype = gfc_get_int_type (ikinds[jkind]); + if (itype && jtype) + { + sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind], + ikinds[jkind]); + gfor_fndecl_math_powi[jkind][ikind].integer = + gfc_build_library_function_decl (get_identifier (name), + jtype, 2, jtype, itype); + TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; + } + } + + for (rkind = 0; rkind < NRKINDS; rkind ++) + { + rtype = gfc_get_real_type (rkinds[rkind]); + if (rtype && itype) + { + sprintf (name, PREFIX("pow_r%d_i%d"), + gfc_type_abi_kind (BT_REAL, rkinds[rkind]), + ikinds[ikind]); + gfor_fndecl_math_powi[rkind][ikind].real = + gfc_build_library_function_decl (get_identifier (name), + rtype, 2, rtype, itype); + TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1; + } + + ctype = gfc_get_complex_type (rkinds[rkind]); + if (ctype && itype) + { + sprintf (name, PREFIX("pow_c%d_i%d"), + gfc_type_abi_kind (BT_REAL, rkinds[rkind]), + ikinds[ikind]); + gfor_fndecl_math_powi[rkind][ikind].cmplx = + gfc_build_library_function_decl (get_identifier (name), + ctype, 2,ctype, itype); + TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; + TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; + } + } + } +#undef NIKINDS +#undef NRKINDS + } + + gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc4")), + gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node, + gfc_int4_type_node); + TREE_READONLY (gfor_fndecl_math_ishftc4) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1; + + gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc8")), + gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node, + gfc_int4_type_node); + TREE_READONLY (gfor_fndecl_math_ishftc8) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1; + + if (gfc_int16_type_node) + { + gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl ( + get_identifier (PREFIX("ishftc16")), + gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node, + gfc_int4_type_node); + TREE_READONLY (gfor_fndecl_math_ishftc16) = 1; + TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1; + } + + /* BLAS functions. */ + { + tree pint = build_pointer_type (integer_type_node); + tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind)); + tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind)); + tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind)); + tree pz = build_pointer_type + (gfc_get_complex_type (gfc_default_double_kind)); + + gfor_fndecl_sgemm = gfc_build_library_function_decl + (get_identifier + (flag_underscoring ? "sgemm_" : "sgemm"), + void_type_node, 15, pchar_type_node, + pchar_type_node, pint, pint, pint, ps, ps, pint, + ps, pint, ps, ps, pint, integer_type_node, + integer_type_node); + gfor_fndecl_dgemm = gfc_build_library_function_decl + (get_identifier + (flag_underscoring ? "dgemm_" : "dgemm"), + void_type_node, 15, pchar_type_node, + pchar_type_node, pint, pint, pint, pd, pd, pint, + pd, pint, pd, pd, pint, integer_type_node, + integer_type_node); + gfor_fndecl_cgemm = gfc_build_library_function_decl + (get_identifier + (flag_underscoring ? "cgemm_" : "cgemm"), + void_type_node, 15, pchar_type_node, + pchar_type_node, pint, pint, pint, pc, pc, pint, + pc, pint, pc, pc, pint, integer_type_node, + integer_type_node); + gfor_fndecl_zgemm = gfc_build_library_function_decl + (get_identifier + (flag_underscoring ? "zgemm_" : "zgemm"), + void_type_node, 15, pchar_type_node, + pchar_type_node, pint, pint, pint, pz, pz, pint, + pz, pint, pz, pz, pint, integer_type_node, + integer_type_node); + } + + /* Other functions. */ + gfor_fndecl_iargc = gfc_build_library_function_decl ( + get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); + TREE_NOTHROW (gfor_fndecl_iargc) = 1; + + gfor_fndecl_kill_sub = gfc_build_library_function_decl ( + get_identifier (PREFIX ("kill_sub")), void_type_node, + 3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node); + + gfor_fndecl_kill = gfc_build_library_function_decl ( + get_identifier (PREFIX ("kill")), gfc_int4_type_node, + 2, gfc_int4_type_node, gfc_int4_type_node); + + gfor_fndecl_is_contiguous0 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("is_contiguous0")), ". R ", + gfc_int4_type_node, 1, pvoid_type_node); + DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1; + TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1; +} + + +/* Make prototypes for runtime library functions. */ + +void +gfc_build_builtin_function_decls (void) +{ + tree gfc_int8_type_node = gfc_get_int_type (8); + + gfor_fndecl_stop_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("stop_numeric")), + void_type_node, 2, integer_type_node, boolean_type_node); + /* STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; + + gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("stop_string")), ". R . . ", + void_type_node, 3, pchar_type_node, size_type_node, + boolean_type_node); + /* STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; + + gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("error_stop_numeric")), + void_type_node, 2, integer_type_node, boolean_type_node); + /* ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1; + + gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("error_stop_string")), ". R . . ", + void_type_node, 3, pchar_type_node, size_type_node, + boolean_type_node); + /* ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; + + gfor_fndecl_pause_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("pause_numeric")), + void_type_node, 1, gfc_int8_type_node); + + gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("pause_string")), ". R . ", + void_type_node, 2, pchar_type_node, size_type_node); + + gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_error")), ". R ", + void_type_node, -1, pchar_type_node); + /* The runtime_error function does not return. */ + TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; + + gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_error_at")), ". R R ", + void_type_node, -2, pchar_type_node, pchar_type_node); + /* The runtime_error_at function does not return. */ + TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; + + gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("runtime_warning_at")), ". R R ", + void_type_node, -2, pchar_type_node, pchar_type_node); + + gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("generate_error")), ". R . R ", + void_type_node, 3, pvoid_type_node, integer_type_node, + pchar_type_node); + + gfor_fndecl_os_error_at = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("os_error_at")), ". R R ", + void_type_node, -2, pchar_type_node, pchar_type_node); + /* The os_error_at function does not return. */ + TREE_THIS_VOLATILE (gfor_fndecl_os_error_at) = 1; + + gfor_fndecl_set_args = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_args")), + void_type_node, 2, integer_type_node, + build_pointer_type (pchar_type_node)); + + gfor_fndecl_set_fpe = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_fpe")), + void_type_node, 1, integer_type_node); + + gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl ( + get_identifier (PREFIX("ieee_procedure_entry")), + void_type_node, 1, pvoid_type_node); + + gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl ( + get_identifier (PREFIX("ieee_procedure_exit")), + void_type_node, 1, pvoid_type_node); + + /* Keep the array dimension in sync with the call, later in this file. */ + gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("set_options")), ". . R ", + void_type_node, 2, integer_type_node, + build_pointer_type (integer_type_node)); + + gfor_fndecl_set_convert = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_convert")), + void_type_node, 1, integer_type_node); + + gfor_fndecl_set_record_marker = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_record_marker")), + void_type_node, 1, integer_type_node); + + gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl ( + get_identifier (PREFIX("set_max_subrecord_length")), + void_type_node, 1, integer_type_node); + + gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("internal_pack")), ". r ", + pvoid_type_node, 1, pvoid_type_node); + + gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("internal_unpack")), ". w R ", + void_type_node, 2, pvoid_type_node, pvoid_type_node); + + gfor_fndecl_associated = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("associated")), ". R R ", + integer_type_node, 2, ppvoid_type_node, ppvoid_type_node); + DECL_PURE_P (gfor_fndecl_associated) = 1; + TREE_NOTHROW (gfor_fndecl_associated) = 1; + + /* Coarray library calls. */ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree pint_type, pppchar_type; + + pint_type = build_pointer_type (integer_type_node); + pppchar_type + = build_pointer_type (build_pointer_type (pchar_type_node)); + + gfor_fndecl_caf_init = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_init")), ". W W ", + void_type_node, 2, pint_type, pppchar_type); + + gfor_fndecl_caf_finalize = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_finalize")), void_type_node, 0); + + gfor_fndecl_caf_this_image = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_this_image")), integer_type_node, + 1, integer_type_node); + + gfor_fndecl_caf_num_images = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_num_images")), integer_type_node, + 2, integer_type_node, integer_type_node); + + gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_register")), ". . . W w w w . ", + void_type_node, 7, + size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node, + pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_deregister")), ". W . w w . ", + void_type_node, 5, + ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, + size_type_node); + + gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ", + void_type_node, 10, + pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, pint_type); + + gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_send")), ". r . . w r r . . . w ", + void_type_node, 11, + pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, pint_type, pvoid_type_node); + + gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sendget")), ". r . . w r r . . r r . . . w ", + void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node, + pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node, + integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, + integer_type_node, boolean_type_node, integer_type_node); + + gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_get_by_ref")), ". r . w r . . . . w . ", + void_type_node, + 10, pvoid_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, boolean_type_node, pint_type, integer_type_node); + + gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_send_by_ref")), ". r . r r . . . . w . ", + void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, boolean_type_node, pint_type, integer_type_node); + + gfor_fndecl_caf_sendget_by_ref + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sendget_by_ref")), + ". r . r r . r . . . w w . . ", + void_type_node, 13, pvoid_type_node, integer_type_node, + pvoid_type_node, pvoid_type_node, integer_type_node, + pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, pint_type, pint_type, integer_type_node, + integer_type_node); + + gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sync_all")), ". w w . ", void_type_node, + 3, pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sync_memory")), ". w w . ", void_type_node, + 3, pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sync_images")), ". . r w w . ", void_type_node, + 5, integer_type_node, pint_type, pint_type, + pchar_type_node, size_type_node); + + gfor_fndecl_caf_error_stop = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_error_stop")), + void_type_node, 1, integer_type_node); + /* CAF's ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1; + + gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_error_stop_str")), ". r . ", + void_type_node, 2, pchar_type_node, size_type_node); + /* CAF's ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1; + + gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_stop_numeric")), + void_type_node, 1, integer_type_node); + /* CAF's STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1; + + gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_stop_str")), ". r . ", + void_type_node, 2, pchar_type_node, size_type_node); + /* CAF's STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1; + + gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_atomic_define")), ". r . . w w . . ", + void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, + pvoid_type_node, pint_type, integer_type_node, integer_type_node); + + gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_atomic_ref")), ". r . . w w . . ", + void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, + pvoid_type_node, pint_type, integer_type_node, integer_type_node); + + gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_atomic_cas")), ". r . . w r r w . . ", + void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node, + pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type, + integer_type_node, integer_type_node); + + gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_atomic_op")), ". . r . . r w w . . ", + void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node, + integer_type_node, pvoid_type_node, pvoid_type_node, pint_type, + integer_type_node, integer_type_node); + + gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_lock")), ". r . . w w w . ", + void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, + pint_type, pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_unlock")), ". r . . w w . ", + void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, + pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_event_post")), ". r . . w w . ", + void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, + pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_event_wait")), ". r . . w w . ", + void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, + pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_event_query")), ". r . . w w ", + void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node, + pint_type, pint_type); + + gfor_fndecl_caf_fail_image = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_fail_image")), void_type_node, 0); + /* CAF's FAIL doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1; + + gfor_fndecl_caf_failed_images + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_failed_images")), ". w . r ", + void_type_node, 3, pvoid_type_node, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_caf_form_team + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_form_team")), ". . W . ", + void_type_node, 3, integer_type_node, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_caf_change_team + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_change_team")), ". w . ", + void_type_node, 2, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_caf_end_team + = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_end_team")), void_type_node, 0); + + gfor_fndecl_caf_get_team + = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_get_team")), + void_type_node, 1, integer_type_node); + + gfor_fndecl_caf_sync_team + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_sync_team")), ". r . ", + void_type_node, 2, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_caf_team_number + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_team_number")), ". r ", + integer_type_node, 1, integer_type_node); + + gfor_fndecl_caf_image_status + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_image_status")), ". . r ", + integer_type_node, 2, integer_type_node, ppvoid_type_node); + + gfor_fndecl_caf_stopped_images + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_stopped_images")), ". w r r ", + void_type_node, 3, pvoid_type_node, ppvoid_type_node, + integer_type_node); + + gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_co_broadcast")), ". w . w w . ", + void_type_node, 5, pvoid_type_node, integer_type_node, + pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_co_max")), ". w . w w . . ", + void_type_node, 6, pvoid_type_node, integer_type_node, + pint_type, pchar_type_node, integer_type_node, size_type_node); + + gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_co_min")), ". w . w w . . ", + void_type_node, 6, pvoid_type_node, integer_type_node, + pint_type, pchar_type_node, integer_type_node, size_type_node); + + gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_co_reduce")), ". w r . . w w . . ", + void_type_node, 8, pvoid_type_node, + build_pointer_type (build_varargs_function_type_list (void_type_node, + NULL_TREE)), + integer_type_node, integer_type_node, pint_type, pchar_type_node, + integer_type_node, size_type_node); + + gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_co_sum")), ". w . w w . ", + void_type_node, 5, pvoid_type_node, integer_type_node, + pint_type, pchar_type_node, size_type_node); + + gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_is_present")), ". r . r ", + integer_type_node, 3, pvoid_type_node, integer_type_node, + pvoid_type_node); + + gfor_fndecl_caf_random_init = gfc_build_library_function_decl ( + get_identifier (PREFIX("caf_random_init")), + void_type_node, 2, logical_type_node, logical_type_node); + } + + gfc_build_intrinsic_function_decls (); + gfc_build_intrinsic_lib_fndecls (); + gfc_build_io_library_fndecls (); +} + + +/* Evaluate the length of dummy character variables. */ + +static void +gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, + gfc_wrapped_block *block) +{ + stmtblock_t init; + + gfc_finish_decl (cl->backend_decl); + + gfc_start_block (&init); + + /* Evaluate the string length expression. */ + gfc_conv_string_length (cl, NULL, &init); + + gfc_trans_vla_type_sizes (sym, &init); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); +} + + +/* Allocate and cleanup an automatic character variable. */ + +static void +gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block) +{ + stmtblock_t init; + tree decl; + tree tmp; + + gcc_assert (sym->backend_decl); + gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length); + + gfc_init_block (&init); + + /* Evaluate the string length expression. */ + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + + gfc_trans_vla_type_sizes (sym, &init); + + decl = sym->backend_decl; + + /* Emit a DECL_EXPR for this variable, which will cause the + gimplifier to allocate storage, and all that good stuff. */ + tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); + gfc_add_expr_to_block (&init, tmp); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); +} + +/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */ + +static void +gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block) +{ + stmtblock_t init; + + gcc_assert (sym->backend_decl); + gfc_start_block (&init); + + /* Set the initial value to length. See the comments in + function gfc_add_assign_aux_vars in this file. */ + gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl), + build_int_cst (gfc_charlen_type_node, -2)); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); +} + +static void +gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body) +{ + tree t = *tp, var, val; + + if (t == NULL || t == error_mark_node) + return; + if (TREE_CONSTANT (t) || DECL_P (t)) + return; + + if (TREE_CODE (t) == SAVE_EXPR) + { + if (SAVE_EXPR_RESOLVED_P (t)) + { + *tp = TREE_OPERAND (t, 0); + return; + } + val = TREE_OPERAND (t, 0); + } + else + val = t; + + var = gfc_create_var_np (TREE_TYPE (t), NULL); + gfc_add_decl_to_function (var); + gfc_add_modify (body, var, unshare_expr (val)); + if (TREE_CODE (t) == SAVE_EXPR) + TREE_OPERAND (t, 0) = var; + *tp = var; +} + +static void +gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body) +{ + tree t; + + if (type == NULL || type == error_mark_node) + return; + + type = TYPE_MAIN_VARIANT (type); + + if (TREE_CODE (type) == INTEGER_TYPE) + { + gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body); + gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body); + + for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t)) + { + TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type); + TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type); + } + } + else if (TREE_CODE (type) == ARRAY_TYPE) + { + gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body); + gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body); + gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body); + gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body); + + for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t)) + { + TYPE_SIZE (t) = TYPE_SIZE (type); + TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type); + } + } +} + +/* Make sure all type sizes and array domains are either constant, + or variable or parameter decls. This is a simplified variant + of gimplify_type_sizes, but we can't use it here, as none of the + variables in the expressions have been gimplified yet. + As type sizes and domains for various variable length arrays + contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars + time, without this routine gimplify_type_sizes in the middle-end + could result in the type sizes being gimplified earlier than where + those variables are initialized. */ + +void +gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) +{ + tree type = TREE_TYPE (sym->backend_decl); + + if (TREE_CODE (type) == FUNCTION_TYPE + && (sym->attr.function || sym->attr.result || sym->attr.entry)) + { + if (! current_fake_result_decl) + return; + + type = TREE_TYPE (TREE_VALUE (current_fake_result_decl)); + } + + while (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); + + while (POINTER_TYPE_P (etype)) + etype = TREE_TYPE (etype); + + gfc_trans_vla_type_sizes_1 (etype, body); + } + + gfc_trans_vla_type_sizes_1 (type, body); +} + + +/* Initialize a derived type by building an lvalue from the symbol + and using trans_assignment to do the work. Set dealloc to false + if no deallocation prior the assignment is needed. */ +void +gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) +{ + gfc_expr *e; + tree tmp; + tree present; + + gcc_assert (block); + + /* Initialization of PDTs is done elsewhere. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + return; + + gcc_assert (!sym->attr.allocatable); + gfc_set_sym_referenced (sym); + e = gfc_lval_expr_from_sym (sym); + tmp = gfc_trans_assignment (e, sym->value, false, dealloc); + if (sym->attr.dummy && (sym->attr.optional + || sym->ns->proc_name->attr.entry_master)) + { + present = gfc_conv_expr_present (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); + gfc_free_expr (e); +} + + +/* Initialize INTENT(OUT) derived type dummies. As well as giving + them their default initializer, if they do not have allocatable + components, they have their allocatable components deallocated. */ + +static void +init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) +{ + stmtblock_t init; + gfc_formal_arglist *f; + tree tmp; + tree present; + + gfc_init_block (&init); + for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) + if (f->sym && f->sym->attr.intent == INTENT_OUT + && !f->sym->attr.pointer + && f->sym->ts.type == BT_DERIVED) + { + tmp = NULL_TREE; + + /* Note: Allocatables are excluded as they are already handled + by the caller. */ + if (!f->sym->attr.allocatable + && gfc_is_finalizable (f->sym->ts.u.derived, NULL)) + { + stmtblock_t block; + gfc_expr *e; + + gfc_init_block (&block); + f->sym->attr.referenced = 1; + e = gfc_lval_expr_from_sym (f->sym); + gfc_add_finalizer_call (&block, e); + gfc_free_expr (e); + tmp = gfc_finish_block (&block); + } + + if (tmp == NULL_TREE && !f->sym->attr.allocatable + && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) + tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, + f->sym->backend_decl, + f->sym->as ? f->sym->as->rank : 0); + + if (tmp != NULL_TREE && (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master)) + { + present = gfc_conv_expr_present (f->sym); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, build_empty_stmt (input_location)); + } + + if (tmp != NULL_TREE) + gfc_add_expr_to_block (&init, tmp); + else if (f->sym->value && !f->sym->attr.allocatable) + gfc_init_default_dt (f->sym, &init, true); + } + else if (f->sym && f->sym->attr.intent == INTENT_OUT + && f->sym->ts.type == BT_CLASS + && !CLASS_DATA (f->sym)->attr.class_pointer + && !CLASS_DATA (f->sym)->attr.allocatable) + { + stmtblock_t block; + gfc_expr *e; + + gfc_init_block (&block); + f->sym->attr.referenced = 1; + e = gfc_lval_expr_from_sym (f->sym); + gfc_add_finalizer_call (&block, e); + gfc_free_expr (e); + tmp = gfc_finish_block (&block); + + if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master) + { + present = gfc_conv_expr_present (f->sym); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&init, tmp); + } + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); +} + + +/* Helper function to manage deferred string lengths. */ + +static tree +gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init, + locus *loc) +{ + tree tmp; + + /* Character length passed by reference. */ + tmp = sym->ts.u.cl->passed_length; + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = fold_convert (gfc_charlen_type_node, tmp); + + if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) + /* Zero the string length when entering the scope. */ + gfc_add_modify (init, sym->ts.u.cl->backend_decl, + build_int_cst (gfc_charlen_type_node, 0)); + else + { + tree tmp2; + + tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, + gfc_charlen_type_node, + sym->ts.u.cl->backend_decl, tmp); + if (sym->attr.optional) + { + tree present = gfc_conv_expr_present (sym); + tmp2 = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp2, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (init, tmp2); + } + + gfc_restore_backend_locus (loc); + + /* Pass the final character length back. */ + if (sym->attr.intent != INTENT_IN) + { + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + gfc_charlen_type_node, tmp, + sym->ts.u.cl->backend_decl); + if (sym->attr.optional) + { + tree present = gfc_conv_expr_present (sym); + tmp = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp, + build_empty_stmt (input_location)); + } + } + else + tmp = NULL_TREE; + + return tmp; +} + + +/* Get the result expression for a procedure. */ + +static tree +get_proc_result (gfc_symbol* sym) +{ + if (sym->attr.subroutine || sym == sym->result) + { + if (current_fake_result_decl != NULL) + return TREE_VALUE (current_fake_result_decl); + + return NULL_TREE; + } + + return sym->result->backend_decl; +} + + +/* Generate function entry and exit code, and add it to the function body. + This includes: + Allocation and initialization of array variables. + Allocation of character string variables. + Initialization and possibly repacking of dummy arrays. + Initialization of ASSIGN statement auxiliary variable. + Initialization of ASSOCIATE names. + Automatic deallocation. */ + +void +gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) +{ + locus loc; + gfc_symbol *sym; + gfc_formal_arglist *f; + stmtblock_t tmpblock; + bool seen_trans_deferred_array = false; + bool is_pdt_type = false; + tree tmp = NULL; + gfc_expr *e; + gfc_se se; + stmtblock_t init; + + /* Deal with implicit return variables. Explicit return variables will + already have been added. */ + if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym) + { + if (!current_fake_result_decl) + { + gfc_entry_list *el = NULL; + if (proc_sym->attr.entry_master) + { + for (el = proc_sym->ns->entries; el; el = el->next) + if (el->sym != el->sym->result) + break; + } + /* TODO: move to the appropriate place in resolve.c. */ + if (warn_return_type > 0 && el == NULL) + gfc_warning (OPT_Wreturn_type, + "Return value of function %qs at %L not set", + proc_sym->name, &proc_sym->declared_at); + } + else if (proc_sym->as) + { + tree result = TREE_VALUE (current_fake_result_decl); + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&proc_sym->declared_at); + gfc_trans_dummy_array_bias (proc_sym, result, block); + + /* An automatic character length, pointer array result. */ + if (proc_sym->ts.type == BT_CHARACTER + && VAR_P (proc_sym->ts.u.cl->backend_decl)) + { + tmp = NULL; + if (proc_sym->ts.deferred) + { + gfc_start_block (&init); + tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); + } + else + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); + } + } + else if (proc_sym->ts.type == BT_CHARACTER) + { + if (proc_sym->ts.deferred) + { + tmp = NULL; + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&proc_sym->declared_at); + gfc_start_block (&init); + /* Zero the string length on entry. */ + gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl, + build_int_cst (gfc_charlen_type_node, 0)); + /* Null the pointer. */ + e = gfc_lval_expr_from_sym (proc_sym); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, e); + gfc_free_expr (e); + tmp = se.expr; + gfc_add_modify (&init, tmp, + fold_convert (TREE_TYPE (se.expr), + null_pointer_node)); + gfc_restore_backend_locus (&loc); + + /* Pass back the string length on exit. */ + tmp = proc_sym->ts.u.cl->backend_decl; + if (TREE_CODE (tmp) != INDIRECT_REF + && proc_sym->ts.u.cl->passed_length) + { + tmp = proc_sym->ts.u.cl->passed_length; + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert + (TREE_TYPE (tmp), + proc_sym->ts.u.cl->backend_decl)); + } + else + tmp = NULL_TREE; + + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); + } + else if (VAR_P (proc_sym->ts.u.cl->backend_decl)) + gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); + } + else + gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX); + } + else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym)) + { + /* Nullify explicit return class arrays on entry. */ + tree type; + tmp = get_proc_result (proc_sym); + if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + { + gfc_start_block (&init); + tmp = gfc_class_data_get (tmp); + type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); + gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + } + } + + + /* Initialize the INTENT(OUT) derived type dummy arguments. This + should be done here so that the offsets and lbounds of arrays + are available. */ + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&proc_sym->declared_at); + init_intent_out_dt (proc_sym, block); + gfc_restore_backend_locus (&loc); + + for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) + { + bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED) + && (sym->ts.u.derived->attr.alloc_comp + || gfc_is_finalizable (sym->ts.u.derived, + NULL)); + if (sym->assoc) + continue; + + if (sym->ts.type == BT_DERIVED + && sym->ts.u.derived + && sym->ts.u.derived->attr.pdt_type) + { + is_pdt_type = true; + gfc_init_block (&tmpblock); + if (!(sym->attr.dummy + || sym->attr.pointer + || sym->attr.allocatable)) + { + tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + if (!sym->attr.result) + tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0); + else + tmp = NULL_TREE; + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); + } + else if (sym->attr.dummy) + { + tmp = gfc_check_pdt_dummy (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + } + } + else if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived + && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) + { + gfc_component *data = CLASS_DATA (sym); + is_pdt_type = true; + gfc_init_block (&tmpblock); + if (!(sym->attr.dummy + || CLASS_DATA (sym)->attr.pointer + || CLASS_DATA (sym)->attr.allocatable)) + { + tmp = gfc_class_data_get (sym->backend_decl); + tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp, + data->as ? data->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + tmp = gfc_class_data_get (sym->backend_decl); + if (!sym->attr.result) + tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp, + data->as ? data->as->rank : 0); + else + tmp = NULL_TREE; + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); + } + else if (sym->attr.dummy) + { + tmp = gfc_class_data_get (sym->backend_decl); + tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp, + data->as ? data->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + } + } + + if (sym->attr.pointer && sym->attr.dimension + && sym->attr.save == SAVE_NONE + && !sym->attr.use_assoc + && !sym->attr.host_assoc + && !sym->attr.dummy + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))) + { + gfc_init_block (&tmpblock); + gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl, + build_int_cst (gfc_array_index_type, 0)); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), + NULL_TREE); + } + + if (sym->ts.type == BT_CLASS + && (sym->attr.save || flag_max_stack_var_size == 0) + && CLASS_DATA (sym)->attr.allocatable) + { + tree vptr; + + if (UNLIMITED_POLY (sym)) + vptr = null_pointer_node; + else + { + gfc_symbol *vsym; + vsym = gfc_find_derived_vtab (sym->ts.u.derived); + vptr = gfc_get_symbol_decl (vsym); + vptr = gfc_build_addr_expr (NULL, vptr); + } + + if (CLASS_DATA (sym)->attr.dimension + || (CLASS_DATA (sym)->attr.codimension + && flag_coarray != GFC_FCOARRAY_LIB)) + { + tmp = gfc_class_data_get (sym->backend_decl); + tmp = gfc_build_null_descriptor (TREE_TYPE (tmp)); + } + else + tmp = null_pointer_node; + + DECL_INITIAL (sym->backend_decl) + = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp); + TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1; + } + else if ((sym->attr.dimension || sym->attr.codimension + || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))) + { + bool is_classarray = IS_CLASS_ARRAY (sym); + symbol_attribute *array_attr; + gfc_array_spec *as; + array_type type_of_array; + + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ + type_of_array = as->type; + if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed) + type_of_array = AS_EXPLICIT; + switch (type_of_array) + { + case AS_EXPLICIT: + if (sym->attr.dummy || sym->attr.result) + gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); + /* Allocatable and pointer arrays need to processed + explicitly. */ + else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable) + { + if (TREE_STATIC (sym->backend_decl)) + { + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + gfc_trans_static_array_pointer (sym); + gfc_restore_backend_locus (&loc); + } + else + { + seen_trans_deferred_array = true; + gfc_trans_deferred_array (sym, block); + } + } + else if (sym->attr.codimension + && TREE_STATIC (sym->backend_decl)) + { + gfc_init_block (&tmpblock); + gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl), + &tmpblock, sym); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), + NULL_TREE); + continue; + } + else + { + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + + if (alloc_comp_or_fini) + { + seen_trans_deferred_array = true; + gfc_trans_deferred_array (sym, block); + } + else if (sym->ts.type == BT_DERIVED + && sym->value + && !sym->attr.data + && sym->attr.save == SAVE_NONE) + { + gfc_start_block (&tmpblock); + gfc_init_default_dt (sym, &tmpblock, false); + gfc_add_init_cleanup (block, + gfc_finish_block (&tmpblock), + NULL_TREE); + } + + gfc_trans_auto_array_allocation (sym->backend_decl, + sym, block); + gfc_restore_backend_locus (&loc); + } + break; + + case AS_ASSUMED_SIZE: + /* Must be a dummy parameter. */ + gcc_assert (sym->attr.dummy || as->cp_was_assumed); + + /* We should always pass assumed size arrays the g77 way. */ + if (sym->attr.dummy) + gfc_trans_g77_array (sym, block); + break; + + case AS_ASSUMED_SHAPE: + /* Must be a dummy parameter. */ + gcc_assert (sym->attr.dummy); + + gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); + break; + + case AS_ASSUMED_RANK: + case AS_DEFERRED: + seen_trans_deferred_array = true; + gfc_trans_deferred_array (sym, block); + if (sym->ts.type == BT_CHARACTER && sym->ts.deferred + && sym->attr.result) + { + gfc_start_block (&init); + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); + } + break; + + default: + gcc_unreachable (); + } + if (alloc_comp_or_fini && !seen_trans_deferred_array) + gfc_trans_deferred_array (sym, block); + } + else if ((!sym->attr.dummy || sym->ts.deferred) + && (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.class_pointer)) + continue; + else if ((!sym->attr.dummy || sym->ts.deferred) + && (sym->attr.allocatable + || (sym->attr.pointer && sym->attr.result) + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.allocatable))) + { + if (!sym->attr.save && flag_max_stack_var_size != 0) + { + tree descriptor = NULL_TREE; + + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + gfc_start_block (&init); + + if (sym->ts.type == BT_CHARACTER + && sym->attr.allocatable + && !sym->attr.dimension + && sym->ts.u.cl && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE) + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + + if (!sym->attr.pointer) + { + /* Nullify and automatic deallocation of allocatable + scalars. */ + e = gfc_lval_expr_from_sym (sym); + if (sym->ts.type == BT_CLASS) + gfc_add_data_component (e); + + gfc_init_se (&se, NULL); + if (sym->ts.type != BT_CLASS + || sym->ts.u.derived->attr.dimension + || sym->ts.u.derived->attr.codimension) + { + se.want_pointer = 1; + gfc_conv_expr (&se, e); + } + else if (sym->ts.type == BT_CLASS + && !CLASS_DATA (sym)->attr.dimension + && !CLASS_DATA (sym)->attr.codimension) + { + se.want_pointer = 1; + gfc_conv_expr (&se, e); + } + else + { + se.descriptor_only = 1; + gfc_conv_expr (&se, e); + descriptor = se.expr; + se.expr = gfc_conv_descriptor_data_addr (se.expr); + se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + } + gfc_free_expr (e); + + if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) + { + /* Nullify when entering the scope. */ + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (se.expr), se.expr, + fold_convert (TREE_TYPE (se.expr), + null_pointer_node)); + if (sym->attr.optional) + { + tree present = gfc_conv_expr_present (sym); + tmp = build3_loc (input_location, COND_EXPR, + void_type_node, present, tmp, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&init, tmp); + } + } + + if ((sym->attr.dummy || sym->attr.result) + && sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && sym->ts.u.cl->passed_length) + tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); + else + { + gfc_restore_backend_locus (&loc); + tmp = NULL_TREE; + } + + /* Deallocate when leaving the scope. Nullifying is not + needed. */ + if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer + && !sym->ns->proc_name->attr.is_main_program) + { + if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.codimension) + tmp = gfc_deallocate_with_status (descriptor, NULL_TREE, + NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + GFC_CAF_COARRAY_ANALYZE); + else + { + gfc_expr *expr = gfc_lval_expr_from_sym (sym); + tmp = gfc_deallocate_scalar_with_status (se.expr, + NULL_TREE, + NULL_TREE, + true, expr, + sym->ts); + gfc_free_expr (expr); + } + } + + if (sym->ts.type == BT_CLASS) + { + /* Initialize _vptr to declared type. */ + gfc_symbol *vtab; + tree rhs; + + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + e = gfc_lval_expr_from_sym (sym); + gfc_add_vptr_component (e); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, e); + gfc_free_expr (e); + if (UNLIMITED_POLY (sym)) + rhs = build_int_cst (TREE_TYPE (se.expr), 0); + else + { + vtab = gfc_find_derived_vtab (sym->ts.u.derived); + rhs = gfc_build_addr_expr (TREE_TYPE (se.expr), + gfc_get_symbol_decl (vtab)); + } + gfc_add_modify (&init, se.expr, rhs); + gfc_restore_backend_locus (&loc); + } + + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); + } + } + else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred) + { + tree tmp = NULL; + stmtblock_t init; + + /* If we get to here, all that should be left are pointers. */ + gcc_assert (sym->attr.pointer); + + if (sym->attr.dummy) + { + gfc_start_block (&init); + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); + } + } + else if (sym->ts.deferred) + gfc_fatal_error ("Deferred type parameter not yet supported"); + else if (alloc_comp_or_fini) + gfc_trans_deferred_array (sym, block); + else if (sym->ts.type == BT_CHARACTER) + { + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + if (sym->attr.dummy || sym->attr.result) + gfc_trans_dummy_character (sym, sym->ts.u.cl, block); + else + gfc_trans_auto_character_variable (sym, block); + gfc_restore_backend_locus (&loc); + } + else if (sym->attr.assign) + { + gfc_save_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + gfc_trans_assign_aux_var (sym, block); + gfc_restore_backend_locus (&loc); + } + else if (sym->ts.type == BT_DERIVED + && sym->value + && !sym->attr.data + && sym->attr.save == SAVE_NONE) + { + gfc_start_block (&tmpblock); + gfc_init_default_dt (sym, &tmpblock, false); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), + NULL_TREE); + } + else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type) + gcc_unreachable (); + } + + gfc_init_block (&tmpblock); + + for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) + { + if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER + && f->sym->ts.u.cl->backend_decl) + { + if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL) + gfc_trans_vla_type_sizes (f->sym, &tmpblock); + } + } + + if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER + && current_fake_result_decl != NULL) + { + gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL); + if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL) + gfc_trans_vla_type_sizes (proc_sym, &tmpblock); + } + + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); +} + + +struct module_hasher : ggc_ptr_hash +{ + typedef const char *compare_type; + + static hashval_t hash (module_htab_entry *s) + { + return htab_hash_string (s->name); + } + + static bool + equal (module_htab_entry *a, const char *b) + { + return !strcmp (a->name, b); + } +}; + +static GTY (()) hash_table *module_htab; + +/* Hash and equality functions for module_htab's decls. */ + +hashval_t +module_decl_hasher::hash (tree t) +{ + const_tree n = DECL_NAME (t); + if (n == NULL_TREE) + n = TYPE_NAME (TREE_TYPE (t)); + return htab_hash_string (IDENTIFIER_POINTER (n)); +} + +bool +module_decl_hasher::equal (tree t1, const char *x2) +{ + const_tree n1 = DECL_NAME (t1); + if (n1 == NULL_TREE) + n1 = TYPE_NAME (TREE_TYPE (t1)); + return strcmp (IDENTIFIER_POINTER (n1), x2) == 0; +} + +struct module_htab_entry * +gfc_find_module (const char *name) +{ + if (! module_htab) + module_htab = hash_table::create_ggc (10); + + module_htab_entry **slot + = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT); + if (*slot == NULL) + { + module_htab_entry *entry = ggc_cleared_alloc (); + + entry->name = gfc_get_string ("%s", name); + entry->decls = hash_table::create_ggc (10); + *slot = entry; + } + return *slot; +} + +void +gfc_module_add_decl (struct module_htab_entry *entry, tree decl) +{ + const char *name; + + if (DECL_NAME (decl)) + name = IDENTIFIER_POINTER (DECL_NAME (decl)); + else + { + gcc_assert (TREE_CODE (decl) == TYPE_DECL); + name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl))); + } + tree *slot + = entry->decls->find_slot_with_hash (name, htab_hash_string (name), + INSERT); + if (*slot == NULL) + *slot = decl; +} + + +/* Generate debugging symbols for namelists. This function must come after + generate_local_decl to ensure that the variables in the namelist are + already declared. */ + +static tree +generate_namelist_decl (gfc_symbol * sym) +{ + gfc_namelist *nml; + tree decl; + vec *nml_decls = NULL; + + gcc_assert (sym->attr.flavor == FL_NAMELIST); + for (nml = sym->namelist; nml; nml = nml->next) + { + if (nml->sym->backend_decl == NULL_TREE) + { + nml->sym->attr.referenced = 1; + nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym); + } + DECL_IGNORED_P (nml->sym->backend_decl) = 0; + CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl); + } + + decl = make_node (NAMELIST_DECL); + TREE_TYPE (decl) = void_type_node; + NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls); + DECL_NAME (decl) = get_identifier (sym->name); + return decl; +} + + +/* Output an initialized decl for a module variable. */ + +static void +gfc_create_module_variable (gfc_symbol * sym) +{ + tree decl; + + /* Module functions with alternate entries are dealt with later and + would get caught by the next condition. */ + if (sym->attr.entry) + return; + + /* Make sure we convert the types of the derived types from iso_c_binding + into (void *). */ + if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c + && sym->ts.type == BT_DERIVED) + sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); + + if (gfc_fl_struct (sym->attr.flavor) + && sym->backend_decl + && TREE_CODE (sym->backend_decl) == RECORD_TYPE) + { + decl = sym->backend_decl; + gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); + + if (!sym->attr.use_assoc && !sym->attr.used_in_submodule) + { + gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE + || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl); + gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE + || DECL_CONTEXT (TYPE_STUB_DECL (decl)) + == sym->ns->proc_name->backend_decl); + } + TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl; + DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl; + gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl)); + } + + /* Only output variables, procedure pointers and array valued, + or derived type, parameters. */ + if (sym->attr.flavor != FL_VARIABLE + && !(sym->attr.flavor == FL_PARAMETER + && (sym->attr.dimension || sym->ts.type == BT_DERIVED)) + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) + return; + + if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl) + { + decl = sym->backend_decl; + gcc_assert (DECL_FILE_SCOPE_P (decl)); + gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); + DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; + gfc_module_add_decl (cur_module, decl); + } + + /* Don't generate variables from other modules. Variables from + COMMONs and Cray pointees will already have been generated. */ + if (sym->attr.use_assoc || sym->attr.used_in_submodule + || sym->attr.in_common || sym->attr.cray_pointee) + return; + + /* Equivalenced variables arrive here after creation. */ + if (sym->backend_decl + && (sym->equiv_built || sym->attr.in_equivalence)) + return; + + if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target) + gfc_internal_error ("backend decl for module variable %qs already exists", + sym->name); + + if (sym->module && !sym->attr.result && !sym->attr.dummy + && (sym->attr.access == ACCESS_UNKNOWN + && (sym->ns->default_access == ACCESS_PRIVATE + || (sym->ns->default_access == ACCESS_UNKNOWN + && flag_module_private)))) + sym->attr.access = ACCESS_PRIVATE; + + if (warn_unused_variable && !sym->attr.referenced + && sym->attr.access == ACCESS_PRIVATE) + gfc_warning (OPT_Wunused_value, + "Unused PRIVATE module variable %qs declared at %L", + sym->name, &sym->declared_at); + + /* We always want module variables to be created. */ + sym->attr.referenced = 1; + /* Create the decl. */ + decl = gfc_get_symbol_decl (sym); + + /* Create the variable. */ + pushdecl (decl); + gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE + || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE + && sym->fn_result_spec)); + DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; + rest_of_decl_compilation (decl, 1, 0); + gfc_module_add_decl (cur_module, decl); + + /* Also add length of strings. */ + if (sym->ts.type == BT_CHARACTER) + { + tree length; + + length = sym->ts.u.cl->backend_decl; + gcc_assert (length || sym->attr.proc_pointer); + if (length && !INTEGER_CST_P (length)) + { + pushdecl (length); + rest_of_decl_compilation (length, 1, 0); + } + } + + if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable + && sym->attr.referenced && !sym->attr.use_assoc) + has_coarray_vars = true; +} + +/* Emit debug information for USE statements. */ + +static void +gfc_trans_use_stmts (gfc_namespace * ns) +{ + gfc_use_list *use_stmt; + for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next) + { + struct module_htab_entry *entry + = gfc_find_module (use_stmt->module_name); + gfc_use_rename *rent; + + if (entry->namespace_decl == NULL) + { + entry->namespace_decl + = build_decl (input_location, + NAMESPACE_DECL, + get_identifier (use_stmt->module_name), + void_type_node); + DECL_EXTERNAL (entry->namespace_decl) = 1; + } + gfc_set_backend_locus (&use_stmt->where); + if (!use_stmt->only_flag) + (*debug_hooks->imported_module_or_decl) (entry->namespace_decl, + NULL_TREE, + ns->proc_name->backend_decl, + false, false); + for (rent = use_stmt->rename; rent; rent = rent->next) + { + tree decl, local_name; + + if (rent->op != INTRINSIC_NONE) + continue; + + hashval_t hash = htab_hash_string (rent->use_name); + tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash, + INSERT); + if (*slot == NULL) + { + gfc_symtree *st; + + st = gfc_find_symtree (ns->sym_root, + rent->local_name[0] + ? rent->local_name : rent->use_name); + + /* The following can happen if a derived type is renamed. */ + if (!st) + { + char *name; + name = xstrdup (rent->local_name[0] + ? rent->local_name : rent->use_name); + name[0] = (char) TOUPPER ((unsigned char) name[0]); + st = gfc_find_symtree (ns->sym_root, name); + free (name); + gcc_assert (st); + } + + /* Sometimes, generic interfaces wind up being over-ruled by a + local symbol (see PR41062). */ + if (!st->n.sym->attr.use_assoc) + continue; + + if (st->n.sym->backend_decl + && DECL_P (st->n.sym->backend_decl) + && st->n.sym->module + && strcmp (st->n.sym->module, use_stmt->module_name) == 0) + { + gcc_assert (DECL_EXTERNAL (entry->namespace_decl) + || !VAR_P (st->n.sym->backend_decl)); + decl = copy_node (st->n.sym->backend_decl); + DECL_CONTEXT (decl) = entry->namespace_decl; + DECL_EXTERNAL (decl) = 1; + DECL_IGNORED_P (decl) = 0; + DECL_INITIAL (decl) = NULL_TREE; + } + else if (st->n.sym->attr.flavor == FL_NAMELIST + && st->n.sym->attr.use_only + && st->n.sym->module + && strcmp (st->n.sym->module, use_stmt->module_name) + == 0) + { + decl = generate_namelist_decl (st->n.sym); + DECL_CONTEXT (decl) = entry->namespace_decl; + DECL_EXTERNAL (decl) = 1; + DECL_IGNORED_P (decl) = 0; + DECL_INITIAL (decl) = NULL_TREE; + } + else + { + *slot = error_mark_node; + entry->decls->clear_slot (slot); + continue; + } + *slot = decl; + } + decl = (tree) *slot; + if (rent->local_name[0]) + local_name = get_identifier (rent->local_name); + else + local_name = NULL_TREE; + gfc_set_backend_locus (&rent->where); + (*debug_hooks->imported_module_or_decl) (decl, local_name, + ns->proc_name->backend_decl, + !use_stmt->only_flag, + false); + } + } +} + + +/* Return true if expr is a constant initializer that gfc_conv_initializer + will handle. */ + +static bool +check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, + bool pointer) +{ + gfc_constructor *c; + gfc_component *cm; + + if (pointer) + return true; + else if (array) + { + if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL) + return true; + else if (expr->expr_type == EXPR_STRUCTURE) + return check_constant_initializer (expr, ts, false, false); + else if (expr->expr_type != EXPR_ARRAY) + return false; + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + { + if (c->iterator) + return false; + if (c->expr->expr_type == EXPR_STRUCTURE) + { + if (!check_constant_initializer (c->expr, ts, false, false)) + return false; + } + else if (c->expr->expr_type != EXPR_CONSTANT) + return false; + } + return true; + } + else switch (ts->type) + { + case_bt_struct: + if (expr->expr_type != EXPR_STRUCTURE) + return false; + cm = expr->ts.u.derived->components; + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c), cm = cm->next) + { + if (!c->expr || cm->attr.allocatable) + continue; + if (!check_constant_initializer (c->expr, &cm->ts, + cm->attr.dimension, + cm->attr.pointer)) + return false; + } + return true; + default: + return expr->expr_type == EXPR_CONSTANT; + } +} + +/* Emit debug info for parameters and unreferenced variables with + initializers. */ + +static void +gfc_emit_parameter_debug_info (gfc_symbol *sym) +{ + tree decl; + + if (sym->attr.flavor != FL_PARAMETER + && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced)) + return; + + if (sym->backend_decl != NULL + || sym->value == NULL + || sym->attr.use_assoc + || sym->attr.dummy + || sym->attr.result + || sym->attr.function + || sym->attr.intrinsic + || sym->attr.pointer + || sym->attr.allocatable + || sym->attr.cray_pointee + || sym->attr.threadprivate + || sym->attr.is_bind_c + || sym->attr.subref_array_pointer + || sym->attr.assign) + return; + + if (sym->ts.type == BT_CHARACTER) + { + gfc_conv_const_charlen (sym->ts.u.cl); + if (sym->ts.u.cl->backend_decl == NULL + || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST) + return; + } + else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) + return; + + if (sym->as) + { + int n; + + if (sym->as->type != AS_EXPLICIT) + return; + for (n = 0; n < sym->as->rank; n++) + if (sym->as->lower[n]->expr_type != EXPR_CONSTANT + || sym->as->upper[n] == NULL + || sym->as->upper[n]->expr_type != EXPR_CONSTANT) + return; + } + + if (!check_constant_initializer (sym->value, &sym->ts, + sym->attr.dimension, false)) + return; + + if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) + return; + + /* Create the decl for the variable or constant. */ + decl = build_decl (input_location, + sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL, + gfc_sym_identifier (sym), gfc_sym_type (sym)); + if (sym->attr.flavor == FL_PARAMETER) + TREE_READONLY (decl) = 1; + gfc_set_decl_location (decl, &sym->declared_at); + if (sym->attr.dimension) + GFC_DECL_PACKED_ARRAY (decl) = 1; + DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; + TREE_STATIC (decl) = 1; + TREE_USED (decl) = 1; + if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL) + TREE_PUBLIC (decl) = 1; + DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, + TREE_TYPE (decl), + sym->attr.dimension, + false, false); + debug_hooks->early_global_decl (decl); +} + + +static void +generate_coarray_sym_init (gfc_symbol *sym) +{ + tree tmp, size, decl, token, desc; + bool is_lock_type, is_event_type; + int reg_type; + gfc_se se; + symbol_attribute attr; + + if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension + || sym->attr.use_assoc || !sym->attr.referenced + || sym->attr.select_type_temporary) + return; + + decl = sym->backend_decl; + TREE_USED(decl) = 1; + gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); + + is_lock_type = sym->ts.type == BT_DERIVED + && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE; + + is_event_type = sym->ts.type == BT_DERIVED + && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE; + + /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108 + to make sure the variable is not optimized away. */ + DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1; + + /* For lock types, we pass the array size as only the library knows the + size of the variable. */ + if (is_lock_type || is_event_type) + size = gfc_index_one_node; + else + size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl))); + + /* Ensure that we do not have size=0 for zero-sized arrays. */ + size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + fold_convert (size_type_node, size), + build_int_cst (size_type_node, 1)); + + if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl))) + { + tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl)); + size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + fold_convert (size_type_node, tmp), size); + } + + gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE); + token = gfc_build_addr_expr (ppvoid_type_node, + GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl))); + if (is_lock_type) + reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC; + else if (is_event_type) + reg_type = GFC_CAF_EVENT_STATIC; + else + reg_type = GFC_CAF_COARRAY_STATIC; + + /* Compile the symbol attribute. */ + if (sym->ts.type == BT_CLASS) + { + attr = CLASS_DATA (sym)->attr; + /* The pointer attribute is always set on classes, overwrite it with the + class_pointer attribute, which denotes the pointer for classes. */ + attr.pointer = attr.class_pointer; + } + else + attr = sym->attr; + gfc_init_se (&se, NULL); + desc = gfc_conv_scalar_to_descriptor (&se, decl, attr); + gfc_add_block_to_block (&caf_init_block, &se.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size, + build_int_cst (integer_type_node, reg_type), + token, gfc_build_addr_expr (pvoid_type_node, desc), + null_pointer_node, /* stat. */ + null_pointer_node, /* errgmsg. */ + build_zero_cst (size_type_node)); /* errmsg_len. */ + gfc_add_expr_to_block (&caf_init_block, tmp); + gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), + gfc_conv_descriptor_data_get (desc))); + + /* Handle "static" initializer. */ + if (sym->value) + { + if (sym->value->expr_type == EXPR_ARRAY) + { + gfc_constructor *c, *cnext; + + /* Test if the array has more than one element. */ + c = gfc_constructor_first (sym->value->value.constructor); + gcc_assert (c); /* Empty constructor should not happen here. */ + cnext = gfc_constructor_next (c); + + if (cnext) + { + /* An EXPR_ARRAY with a rank > 1 here has to come from a + DATA statement. Set its rank here as not to confuse + the following steps. */ + sym->value->rank = 1; + } + else + { + /* There is only a single value in the constructor, use + it directly for the assignment. */ + gfc_expr *new_expr; + new_expr = gfc_copy_expr (c->expr); + gfc_free_expr (sym->value); + sym->value = new_expr; + } + } + + sym->attr.pointer = 1; + tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value, + true, false); + sym->attr.pointer = 0; + gfc_add_expr_to_block (&caf_init_block, tmp); + } + else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp) + { + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as + ? sym->as->rank : 0, + GFC_STRUCTURE_CAF_MODE_IN_COARRAY); + gfc_add_expr_to_block (&caf_init_block, tmp); + } +} + + +/* Generate constructor function to initialize static, nonallocatable + coarrays. */ + +static void +generate_coarray_init (gfc_namespace * ns __attribute((unused))) +{ + tree fndecl, tmp, decl, save_fn_decl; + + save_fn_decl = current_function_decl; + push_function_context (); + + tmp = build_function_type_list (void_type_node, NULL_TREE); + fndecl = build_decl (input_location, FUNCTION_DECL, + create_tmp_var_name ("_caf_init"), tmp); + + DECL_STATIC_CONSTRUCTOR (fndecl) = 1; + SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY); + + decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node); + DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; + DECL_CONTEXT (decl) = fndecl; + DECL_RESULT (fndecl) = decl; + + pushdecl (fndecl); + current_function_decl = fndecl; + announce_function (fndecl); + + rest_of_decl_compilation (fndecl, 0, 0); + make_decl_rtl (fndecl); + allocate_struct_function (fndecl, false); + + pushlevel (); + gfc_init_block (&caf_init_block); + + gfc_traverse_ns (ns, generate_coarray_sym_init); + + DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block); + decl = getdecls (); + + poplevel (1, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + DECL_SAVED_TREE (fndecl) + = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node, + decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl)); + dump_function (TDI_original, fndecl); + + cfun->function_end_locus = input_location; + set_cfun (NULL); + + if (decl_function_context (fndecl)) + (void) cgraph_node::create (fndecl); + else + cgraph_node::finalize_function (fndecl, true); + + pop_function_context (); + current_function_decl = save_fn_decl; +} + + +static void +create_module_nml_decl (gfc_symbol *sym) +{ + if (sym->attr.flavor == FL_NAMELIST) + { + tree decl = generate_namelist_decl (sym); + pushdecl (decl); + gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); + DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; + rest_of_decl_compilation (decl, 1, 0); + gfc_module_add_decl (cur_module, decl); + } +} + + +/* Generate all the required code for module variables. */ + +void +gfc_generate_module_vars (gfc_namespace * ns) +{ + module_namespace = ns; + cur_module = gfc_find_module (ns->proc_name->name); + + /* Check if the frontend left the namespace in a reasonable state. */ + gcc_assert (ns->proc_name && !ns->proc_name->tlink); + + /* Generate COMMON blocks. */ + gfc_trans_common (ns); + + has_coarray_vars = false; + + /* Create decls for all the module variables. */ + gfc_traverse_ns (ns, gfc_create_module_variable); + gfc_traverse_ns (ns, create_module_nml_decl); + + if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) + generate_coarray_init (ns); + + cur_module = NULL; + + gfc_trans_use_stmts (ns); + gfc_traverse_ns (ns, gfc_emit_parameter_debug_info); +} + + +static void +gfc_generate_contained_functions (gfc_namespace * parent) +{ + gfc_namespace *ns; + + /* We create all the prototypes before generating any code. */ + for (ns = parent->contained; ns; ns = ns->sibling) + { + /* Skip namespaces from used modules. */ + if (ns->parent != parent) + continue; + + gfc_create_function_decl (ns, false); + } + + for (ns = parent->contained; ns; ns = ns->sibling) + { + /* Skip namespaces from used modules. */ + if (ns->parent != parent) + continue; + + gfc_generate_function_code (ns); + } +} + + +/* Drill down through expressions for the array specification bounds and + character length calling generate_local_decl for all those variables + that have not already been declared. */ + +static void +generate_local_decl (gfc_symbol *); + +/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ + +static bool +expr_decls (gfc_expr *e, gfc_symbol *sym, + int *f ATTRIBUTE_UNUSED) +{ + if (e->expr_type != EXPR_VARIABLE + || sym == e->symtree->n.sym + || e->symtree->n.sym->mark + || e->symtree->n.sym->ns != sym->ns) + return false; + + generate_local_decl (e->symtree->n.sym); + return false; +} + +static void +generate_expr_decls (gfc_symbol *sym, gfc_expr *e) +{ + gfc_traverse_expr (e, sym, expr_decls, 0); +} + + +/* Check for dependencies in the character length and array spec. */ + +static void +generate_dependency_declarations (gfc_symbol *sym) +{ + int i; + + if (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl + && sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) + generate_expr_decls (sym, sym->ts.u.cl->length); + + if (sym->as && sym->as->rank) + { + for (i = 0; i < sym->as->rank; i++) + { + generate_expr_decls (sym, sym->as->lower[i]); + generate_expr_decls (sym, sym->as->upper[i]); + } + } +} + + +/* Generate decls for all local variables. We do this to ensure correct + handling of expressions which only appear in the specification of + other functions. */ + +static void +generate_local_decl (gfc_symbol * sym) +{ + if (sym->attr.flavor == FL_VARIABLE) + { + if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable + && sym->attr.referenced && !sym->attr.use_assoc) + has_coarray_vars = true; + + if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master) + generate_dependency_declarations (sym); + + if (sym->attr.referenced) + gfc_get_symbol_decl (sym); + + /* Warnings for unused dummy arguments. */ + else if (sym->attr.dummy && !sym->attr.in_namelist) + { + /* INTENT(out) dummy arguments are likely meant to be set. */ + if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT) + { + if (sym->ts.type != BT_DERIVED) + gfc_warning (OPT_Wunused_dummy_argument, + "Dummy argument %qs at %L was declared " + "INTENT(OUT) but was not set", sym->name, + &sym->declared_at); + else if (!gfc_has_default_initializer (sym->ts.u.derived) + && !sym->ts.u.derived->attr.zero_comp) + gfc_warning (OPT_Wunused_dummy_argument, + "Derived-type dummy argument %qs at %L was " + "declared INTENT(OUT) but was not set and " + "does not have a default initializer", + sym->name, &sym->declared_at); + if (sym->backend_decl != NULL_TREE) + suppress_warning (sym->backend_decl); + } + else if (warn_unused_dummy_argument) + { + if (!sym->attr.artificial) + gfc_warning (OPT_Wunused_dummy_argument, + "Unused dummy argument %qs at %L", sym->name, + &sym->declared_at); + + if (sym->backend_decl != NULL_TREE) + suppress_warning (sym->backend_decl); + } + } + + /* Warn for unused variables, but not if they're inside a common + block or a namelist. */ + else if (warn_unused_variable + && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist)) + { + if (sym->attr.use_only) + { + gfc_warning (OPT_Wunused_variable, + "Unused module variable %qs which has been " + "explicitly imported at %L", sym->name, + &sym->declared_at); + if (sym->backend_decl != NULL_TREE) + suppress_warning (sym->backend_decl); + } + else if (!sym->attr.use_assoc) + { + /* Corner case: the symbol may be an entry point. At this point, + it may appear to be an unused variable. Suppress warning. */ + bool enter = false; + gfc_entry_list *el; + + for (el = sym->ns->entries; el; el=el->next) + if (strcmp(sym->name, el->sym->name) == 0) + enter = true; + + if (!enter) + gfc_warning (OPT_Wunused_variable, + "Unused variable %qs declared at %L", + sym->name, &sym->declared_at); + if (sym->backend_decl != NULL_TREE) + suppress_warning (sym->backend_decl); + } + } + + /* For variable length CHARACTER parameters, the PARM_DECL already + references the length variable, so force gfc_get_symbol_decl + even when not referenced. If optimize > 0, it will be optimized + away anyway. But do this only after emitting -Wunused-parameter + warning if requested. */ + if (sym->attr.dummy && !sym->attr.referenced + && sym->ts.type == BT_CHARACTER + && sym->ts.u.cl->backend_decl != NULL + && VAR_P (sym->ts.u.cl->backend_decl)) + { + sym->attr.referenced = 1; + gfc_get_symbol_decl (sym); + } + + /* INTENT(out) dummy arguments and result variables with allocatable + components are reset by default and need to be set referenced to + generate the code for nullification and automatic lengths. */ + if (!sym->attr.referenced + && sym->ts.type == BT_DERIVED + && sym->ts.u.derived->attr.alloc_comp + && !sym->attr.pointer + && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT) + || + (sym->attr.result && sym != sym->result))) + { + sym->attr.referenced = 1; + gfc_get_symbol_decl (sym); + } + + /* Check for dependencies in the array specification and string + length, adding the necessary declarations to the function. We + mark the symbol now, as well as in traverse_ns, to prevent + getting stuck in a circular dependency. */ + sym->mark = 1; + } + else if (sym->attr.flavor == FL_PARAMETER) + { + if (warn_unused_parameter + && !sym->attr.referenced) + { + if (!sym->attr.use_assoc) + gfc_warning (OPT_Wunused_parameter, + "Unused parameter %qs declared at %L", sym->name, + &sym->declared_at); + else if (sym->attr.use_only) + gfc_warning (OPT_Wunused_parameter, + "Unused parameter %qs which has been explicitly " + "imported at %L", sym->name, &sym->declared_at); + } + + if (sym->ns && sym->ns->construct_entities) + { + /* Construction of the intrinsic modules within a BLOCK + construct, where ONLY and RENAMED entities are included, + seems to be bogus. This is a workaround that can be removed + if someone ever takes on the task to creating full-fledge + modules. See PR 69455. */ + if (sym->attr.referenced + && sym->from_intmod != INTMOD_ISO_C_BINDING + && sym->from_intmod != INTMOD_ISO_FORTRAN_ENV) + gfc_get_symbol_decl (sym); + sym->mark = 1; + } + } + else if (sym->attr.flavor == FL_PROCEDURE) + { + /* TODO: move to the appropriate place in resolve.c. */ + if (warn_return_type > 0 + && sym->attr.function + && sym->result + && sym != sym->result + && !sym->result->attr.referenced + && !sym->attr.use_assoc + && sym->attr.if_source != IFSRC_IFBODY) + { + gfc_warning (OPT_Wreturn_type, + "Return value %qs of function %qs declared at " + "%L not set", sym->result->name, sym->name, + &sym->result->declared_at); + + /* Prevents "Unused variable" warning for RESULT variables. */ + sym->result->mark = 1; + } + } + + if (sym->attr.dummy == 1) + { + /* The tree type for scalar character dummy arguments of BIND(C) + procedures, if they are passed by value, should be unsigned char. + The value attribute implies the dummy is a scalar. */ + if (sym->attr.value == 1 && sym->backend_decl != NULL + && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop + && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c) + { + /* 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. */ + 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); + } + + /* Unused procedure passed as dummy argument. */ + if (sym->attr.flavor == FL_PROCEDURE) + { + if (!sym->attr.referenced && !sym->attr.artificial) + { + if (warn_unused_dummy_argument) + gfc_warning (OPT_Wunused_dummy_argument, + "Unused dummy argument %qs at %L", sym->name, + &sym->declared_at); + } + + /* Silence bogus "unused parameter" warnings from the + middle end. */ + if (sym->backend_decl != NULL_TREE) + suppress_warning (sym->backend_decl); + } + } + + /* Make sure we convert the types of the derived types from iso_c_binding + into (void *). */ + if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c + && sym->ts.type == BT_DERIVED) + sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); +} + + +static void +generate_local_nml_decl (gfc_symbol * sym) +{ + if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc) + { + tree decl = generate_namelist_decl (sym); + pushdecl (decl); + } +} + + +static void +generate_local_vars (gfc_namespace * ns) +{ + gfc_traverse_ns (ns, generate_local_decl); + gfc_traverse_ns (ns, generate_local_nml_decl); +} + + +/* Generate a switch statement to jump to the correct entry point. Also + creates the label decls for the entry points. */ + +static tree +gfc_trans_entry_master_switch (gfc_entry_list * el) +{ + stmtblock_t block; + tree label; + tree tmp; + tree val; + + gfc_init_block (&block); + for (; el; el = el->next) + { + /* Add the case label. */ + label = gfc_build_label_decl (NULL_TREE); + val = build_int_cst (gfc_array_index_type, el->id); + tmp = build_case_label (val, NULL_TREE, label); + gfc_add_expr_to_block (&block, tmp); + + /* And jump to the actual entry point. */ + label = gfc_build_label_decl (NULL_TREE); + tmp = build1_v (GOTO_EXPR, label); + gfc_add_expr_to_block (&block, tmp); + + /* Save the label decl. */ + el->label = label; + } + tmp = gfc_finish_block (&block); + /* The first argument selects the entry point. */ + val = DECL_ARGUMENTS (current_function_decl); + tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp); + return tmp; +} + + +/* Add code to string lengths of actual arguments passed to a function against + the expected lengths of the dummy arguments. */ + +static void +add_argument_checking (stmtblock_t *block, gfc_symbol *sym) +{ + gfc_formal_arglist *formal; + + for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next) + if (formal->sym && formal->sym->ts.type == BT_CHARACTER + && !formal->sym->ts.deferred) + { + enum tree_code comparison; + tree cond; + tree argname; + gfc_symbol *fsym; + gfc_charlen *cl; + const char *message; + + fsym = formal->sym; + cl = fsym->ts.u.cl; + + gcc_assert (cl); + gcc_assert (cl->passed_length != NULL_TREE); + gcc_assert (cl->backend_decl != NULL_TREE); + + /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the + string lengths must match exactly. Otherwise, it is only required + that the actual string length is *at least* the expected one. + Sequence association allows for a mismatch of the string length + if the actual argument is (part of) an array, but only if the + dummy argument is an array. (See "Sequence association" in + Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */ + if (fsym->attr.pointer || fsym->attr.allocatable + || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_ASSUMED_RANK))) + { + comparison = NE_EXPR; + message = _("Actual string length does not match the declared one" + " for dummy argument '%s' (%ld/%ld)"); + } + else if (fsym->as && fsym->as->rank != 0) + continue; + else + { + comparison = LT_EXPR; + message = _("Actual string length is shorter than the declared one" + " for dummy argument '%s' (%ld/%ld)"); + } + + /* Build the condition. For optional arguments, an actual length + of 0 is also acceptable if the associated string is NULL, which + means the argument was not passed. */ + cond = fold_build2_loc (input_location, comparison, logical_type_node, + cl->passed_length, cl->backend_decl); + if (fsym->attr.optional) + { + tree not_absent; + tree not_0length; + tree absent_failed; + + not_0length = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + cl->passed_length, + build_zero_cst + (TREE_TYPE (cl->passed_length))); + /* The symbol needs to be referenced for gfc_get_symbol_decl. */ + fsym->attr.referenced = 1; + not_absent = gfc_conv_expr_present (fsym); + + absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, not_0length, + not_absent); + + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, cond, absent_failed); + } + + /* Build the runtime check. */ + argname = gfc_build_cstring_const (fsym->name); + argname = gfc_build_addr_expr (pchar_type_node, argname); + gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at, + message, argname, + fold_convert (long_integer_type_node, + cl->passed_length), + fold_convert (long_integer_type_node, + cl->backend_decl)); + } +} + + +static void +create_main_function (tree fndecl) +{ + tree old_context; + tree ftn_main; + tree tmp, decl, result_decl, argc, argv, typelist, arglist; + stmtblock_t body; + + old_context = current_function_decl; + + if (old_context) + { + push_function_context (); + saved_parent_function_decls = saved_function_decls; + saved_function_decls = NULL_TREE; + } + + /* main() function must be declared with global scope. */ + gcc_assert (current_function_decl == NULL_TREE); + + /* Declare the function. */ + tmp = build_function_type_list (integer_type_node, integer_type_node, + build_pointer_type (pchar_type_node), + NULL_TREE); + main_identifier_node = get_identifier ("main"); + ftn_main = build_decl (input_location, FUNCTION_DECL, + main_identifier_node, tmp); + DECL_EXTERNAL (ftn_main) = 0; + TREE_PUBLIC (ftn_main) = 1; + TREE_STATIC (ftn_main) = 1; + DECL_ATTRIBUTES (ftn_main) + = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE); + + /* Setup the result declaration (for "return 0"). */ + result_decl = build_decl (input_location, + RESULT_DECL, NULL_TREE, integer_type_node); + DECL_ARTIFICIAL (result_decl) = 1; + DECL_IGNORED_P (result_decl) = 1; + DECL_CONTEXT (result_decl) = ftn_main; + DECL_RESULT (ftn_main) = result_decl; + + pushdecl (ftn_main); + + /* Get the arguments. */ + + arglist = NULL_TREE; + typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main)); + + tmp = TREE_VALUE (typelist); + argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp); + DECL_CONTEXT (argc) = ftn_main; + DECL_ARG_TYPE (argc) = TREE_VALUE (typelist); + TREE_READONLY (argc) = 1; + gfc_finish_decl (argc); + arglist = chainon (arglist, argc); + + typelist = TREE_CHAIN (typelist); + tmp = TREE_VALUE (typelist); + argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp); + DECL_CONTEXT (argv) = ftn_main; + DECL_ARG_TYPE (argv) = TREE_VALUE (typelist); + TREE_READONLY (argv) = 1; + DECL_BY_REFERENCE (argv) = 1; + gfc_finish_decl (argv); + arglist = chainon (arglist, argv); + + DECL_ARGUMENTS (ftn_main) = arglist; + current_function_decl = ftn_main; + announce_function (ftn_main); + + rest_of_decl_compilation (ftn_main, 1, 0); + make_decl_rtl (ftn_main); + allocate_struct_function (ftn_main, false); + pushlevel (); + + gfc_init_block (&body); + + /* Call some libgfortran initialization routines, call then MAIN__(). */ + + /* Call _gfortran_caf_init (*argc, ***argv). */ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree pint_type, pppchar_type; + pint_type = build_pointer_type (integer_type_node); + pppchar_type + = build_pointer_type (build_pointer_type (pchar_type_node)); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2, + gfc_build_addr_expr (pint_type, argc), + gfc_build_addr_expr (pppchar_type, argv)); + gfc_add_expr_to_block (&body, tmp); + } + + /* Call _gfortran_set_args (argc, argv). */ + TREE_USED (argc) = 1; + TREE_USED (argv) = 1; + tmp = build_call_expr_loc (input_location, + gfor_fndecl_set_args, 2, argc, argv); + gfc_add_expr_to_block (&body, tmp); + + /* Add a call to set_options to set up the runtime library Fortran + language standard parameters. */ + { + tree array_type, array, var; + vec *v = NULL; + static const int noptions = 7; + + /* Passing a new option to the library requires three modifications: + + add it to the tree_cons list below + + change the noptions variable above + + modify the library (runtime/compile_options.c)! */ + + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.warn_std)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.allow_std)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, pedantic)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, flag_backtrace)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, flag_sign_zero)); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + (gfc_option.rtcheck + & GFC_RTCHECK_BOUNDS))); + CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, + build_int_cst (integer_type_node, + gfc_option.fpe_summary)); + + array_type = build_array_type_nelts (integer_type_node, noptions); + array = build_constructor (array_type, v); + TREE_CONSTANT (array) = 1; + TREE_STATIC (array) = 1; + + /* Create a static variable to hold the jump table. */ + var = build_decl (input_location, VAR_DECL, + create_tmp_var_name ("options"), array_type); + DECL_ARTIFICIAL (var) = 1; + DECL_IGNORED_P (var) = 1; + TREE_CONSTANT (var) = 1; + TREE_STATIC (var) = 1; + TREE_READONLY (var) = 1; + DECL_INITIAL (var) = array; + pushdecl (var); + var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var); + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_set_options, 2, + build_int_cst (integer_type_node, noptions), var); + gfc_add_expr_to_block (&body, tmp); + } + + /* If -ffpe-trap option was provided, add a call to set_fpe so that + the library will raise a FPE when needed. */ + if (gfc_option.fpe != 0) + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_set_fpe, 1, + build_int_cst (integer_type_node, + gfc_option.fpe)); + gfc_add_expr_to_block (&body, tmp); + } + + /* If this is the main program and an -fconvert option was provided, + add a call to set_convert. */ + + if (flag_convert != GFC_FLAG_CONVERT_NATIVE) + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_set_convert, 1, + build_int_cst (integer_type_node, flag_convert)); + gfc_add_expr_to_block (&body, tmp); + } + + /* If this is the main program and an -frecord-marker option was provided, + add a call to set_record_marker. */ + + if (flag_record_marker != 0) + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_set_record_marker, 1, + build_int_cst (integer_type_node, + flag_record_marker)); + gfc_add_expr_to_block (&body, tmp); + } + + if (flag_max_subrecord_length != 0) + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_set_max_subrecord_length, 1, + build_int_cst (integer_type_node, + flag_max_subrecord_length)); + gfc_add_expr_to_block (&body, tmp); + } + + /* Call MAIN__(). */ + tmp = build_call_expr_loc (input_location, + fndecl, 0); + gfc_add_expr_to_block (&body, tmp); + + /* Mark MAIN__ as used. */ + TREE_USED (fndecl) = 1; + + /* Coarray: Call _gfortran_caf_finalize(void). */ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0); + gfc_add_expr_to_block (&body, tmp); + } + + /* "return 0". */ + tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node, + DECL_RESULT (ftn_main), + build_int_cst (integer_type_node, 0)); + tmp = build1_v (RETURN_EXPR, tmp); + gfc_add_expr_to_block (&body, tmp); + + + DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body); + decl = getdecls (); + + /* Finish off this function and send it for code generation. */ + poplevel (1, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main; + + DECL_SAVED_TREE (ftn_main) + = fold_build3_loc (DECL_SOURCE_LOCATION (ftn_main), BIND_EXPR, + void_type_node, decl, DECL_SAVED_TREE (ftn_main), + DECL_INITIAL (ftn_main)); + + /* Output the GENERIC tree. */ + dump_function (TDI_original, ftn_main); + + cgraph_node::finalize_function (ftn_main, true); + + if (old_context) + { + pop_function_context (); + saved_function_decls = saved_parent_function_decls; + } + current_function_decl = old_context; +} + + +/* Generate an appropriate return-statement for a procedure. */ + +tree +gfc_generate_return (void) +{ + gfc_symbol* sym; + tree result; + tree fndecl; + + sym = current_procedure_symbol; + fndecl = sym->backend_decl; + + if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node) + result = NULL_TREE; + else + { + result = get_proc_result (sym); + + /* Set the return value to the dummy result variable. The + types may be different for scalar default REAL functions + with -ff2c, therefore we have to convert. */ + if (result != NULL_TREE) + { + result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result); + result = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (result), DECL_RESULT (fndecl), + result); + } + else + { + /* If the function does not have a result variable, result is + NULL_TREE, and a 'return' is generated without a variable. + The following generates a 'return __result_XXX' where XXX is + the function name. */ + if (sym == sym->result && sym->attr.function) + { + result = gfc_get_fake_result_decl (sym, 0); + result = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (result), + DECL_RESULT (fndecl), result); + } + } + } + + return build1_v (RETURN_EXPR, result); +} + + +static void +is_from_ieee_module (gfc_symbol *sym) +{ + if (sym->from_intmod == INTMOD_IEEE_FEATURES + || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS + || sym->from_intmod == INTMOD_IEEE_ARITHMETIC) + seen_ieee_symbol = 1; +} + + +static int +is_ieee_module_used (gfc_namespace *ns) +{ + seen_ieee_symbol = 0; + gfc_traverse_ns (ns, is_from_ieee_module); + return seen_ieee_symbol; +} + + +static gfc_omp_clauses *module_oacc_clauses; + + +static void +add_clause (gfc_symbol *sym, gfc_omp_map_op map_op) +{ + gfc_omp_namelist *n; + + n = gfc_get_omp_namelist (); + n->sym = sym; + n->u.map_op = map_op; + + if (!module_oacc_clauses) + module_oacc_clauses = gfc_get_omp_clauses (); + + if (module_oacc_clauses->lists[OMP_LIST_MAP]) + n->next = module_oacc_clauses->lists[OMP_LIST_MAP]; + + module_oacc_clauses->lists[OMP_LIST_MAP] = n; +} + + +static void +find_module_oacc_declare_clauses (gfc_symbol *sym) +{ + if (sym->attr.use_assoc) + { + gfc_omp_map_op map_op; + + if (sym->attr.oacc_declare_create) + map_op = OMP_MAP_FORCE_ALLOC; + + if (sym->attr.oacc_declare_copyin) + map_op = OMP_MAP_FORCE_TO; + + if (sym->attr.oacc_declare_deviceptr) + map_op = OMP_MAP_FORCE_DEVICEPTR; + + if (sym->attr.oacc_declare_device_resident) + map_op = OMP_MAP_DEVICE_RESIDENT; + + if (sym->attr.oacc_declare_create + || sym->attr.oacc_declare_copyin + || sym->attr.oacc_declare_deviceptr + || sym->attr.oacc_declare_device_resident) + { + sym->attr.referenced = 1; + add_clause (sym, map_op); + } + } +} + + +void +finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block) +{ + gfc_code *code; + gfc_oacc_declare *oc; + locus where = gfc_current_locus; + gfc_omp_clauses *omp_clauses = NULL; + gfc_omp_namelist *n, *p; + + module_oacc_clauses = NULL; + gfc_traverse_ns (ns, find_module_oacc_declare_clauses); + + if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM) + { + gfc_oacc_declare *new_oc; + + new_oc = gfc_get_oacc_declare (); + new_oc->next = ns->oacc_declare; + new_oc->clauses = module_oacc_clauses; + + ns->oacc_declare = new_oc; + } + + if (!ns->oacc_declare) + return; + + for (oc = ns->oacc_declare; oc; oc = oc->next) + { + if (oc->module_var) + continue; + + if (block) + gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed " + "in BLOCK construct", &oc->loc); + + + if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP]) + { + if (omp_clauses == NULL) + { + omp_clauses = oc->clauses; + continue; + } + + for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next) + ; + + gcc_assert (p->next == NULL); + + p->next = omp_clauses->lists[OMP_LIST_MAP]; + omp_clauses = oc->clauses; + } + } + + if (!omp_clauses) + return; + + for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next) + { + switch (n->u.map_op) + { + case OMP_MAP_DEVICE_RESIDENT: + n->u.map_op = OMP_MAP_FORCE_ALLOC; + break; + + default: + break; + } + } + + code = XCNEW (gfc_code); + code->op = EXEC_OACC_DECLARE; + code->loc = where; + + code->ext.oacc_declare = gfc_get_oacc_declare (); + code->ext.oacc_declare->clauses = omp_clauses; + + code->block = XCNEW (gfc_code); + code->block->op = EXEC_OACC_DECLARE; + code->block->loc = where; + + if (ns->code) + code->block->next = ns->code; + + ns->code = code; + + return; +} + +static void +gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, + tree cfi_desc, tree gfc_desc, gfc_symbol *sym) +{ + stmtblock_t block; + gfc_init_block (&block); + tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc); + tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE; + bool do_copy_inout = false; + + /* When allocatable + intent out, free the cfi descriptor. */ + if (sym->attr.allocatable && sym->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)); + } + + /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + char *msg; + tree tmp3; + msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor " + "passed to dummy argument %s", CFI_VERSION, sym->name); + tmp2 = gfc_get_cfi_desc_version (cfi); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2, + build_int_cst (TREE_TYPE (tmp2), CFI_VERSION)); + gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, + msg, tmp2); + free (msg); + + /* Rank check; however, for character(len=*), assumed/explicit-size arrays + are permitted to differ in rank according to the Fortran rules. */ + if (sym->as && sym->as->type != AS_ASSUMED_SIZE + && sym->as->type != AS_EXPLICIT) + { + if (sym->as->rank != -1) + msg = xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor " + "passed to dummy argument %s", sym->as->rank, + sym->name); + else + msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI " + "descriptor passed to dummy argument %s", + CFI_MAX_RANK, sym->name); + + tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi); + if (sym->as->rank != -1) + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, build_int_cst (signed_char_type_node, + sym->as->rank)); + else + { + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + tmp, build_zero_cst (TREE_TYPE (tmp))); + tmp2 = fold_build2_loc (input_location, GT_EXPR, + boolean_type_node, tmp2, + build_int_cst (TREE_TYPE (tmp2), + CFI_MAX_RANK)); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, tmp, tmp2); + } + gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, + msg, tmp3); + free (msg); + } + + tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi); + if (sym->attr.allocatable || sym->attr.pointer) + { + int attr = (sym->attr.pointer ? CFI_attribute_pointer + : CFI_attribute_allocatable); + msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI " + "descriptor passed to dummy argument %s with %s " + "attribute", attr, sym->name, + sym->attr.pointer ? "pointer" : "allocatable"); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), attr)); + } + else + { + int amin = MIN (CFI_attribute_pointer, + MIN (CFI_attribute_allocatable, CFI_attribute_other)); + int amax = MAX (CFI_attribute_pointer, + MAX (CFI_attribute_allocatable, CFI_attribute_other)); + msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI " + "descriptor passed to nonallocatable, nonpointer " + "dummy argument %s", amin, amax, sym->name); + tmp2 = tmp; + tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), amin)); + tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2, + build_int_cst (TREE_TYPE (tmp2), amax)); + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, tmp, tmp2); + gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, + msg, tmp3); + free (msg); + msg = xasprintf ("Invalid unallocatated/unassociated CFI " + "descriptor passed to nonallocatable, nonpointer " + "dummy argument %s", sym->name); + tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi), + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp, null_pointer_node); + } + gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, + msg, tmp3); + free (msg); + + if (sym->ts.type != BT_ASSUMED) + { + int type = CFI_type_other; + if (sym->ts.f90_type == BT_VOID) + { + type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR + ? CFI_type_cfunptr : CFI_type_cptr); + } + else + switch (sym->ts.type) + { + case BT_INTEGER: + case BT_LOGICAL: + case BT_REAL: + case BT_COMPLEX: + type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind); + break; + case BT_CHARACTER: + type = CFI_type_from_type_kind (CFI_type_Character, + sym->ts.kind); + break; + case BT_DERIVED: + type = CFI_type_struct; + break; + case BT_VOID: + type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR + ? CFI_type_cfunptr : CFI_type_cptr); + break; + case BT_ASSUMED: + case BT_CLASS: + case BT_PROCEDURE: + case BT_HOLLERITH: + case BT_UNION: + case BT_BOZ: + case BT_UNKNOWN: + gcc_unreachable (); + } + msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor" + " passed to dummy argument %s", type, sym->name); + tmp2 = tmp = gfc_get_cfi_desc_type (cfi); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), type)); + gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, + msg, tmp2); + free (msg); + } + } + + if (!sym->attr.referenced) + goto done; + + /* Set string length for len=* and len=:, otherwise, it is already set. */ + if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length) + { + tmp = fold_convert (gfc_array_index_type, + gfc_get_cfi_desc_elem_len (cfi)); + if (sym->ts.kind != 1) + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, tmp, + build_int_cst (gfc_charlen_type_node, + sym->ts.kind)); + gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp); + } + + if (sym->ts.type == BT_CHARACTER + && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) + { + gfc_conv_string_length (sym->ts.u.cl, NULL, init); + gfc_trans_vla_type_sizes (sym, init); + } + + /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr. + assumed-size/explicit-size arrays end up here for character(len=*) + only. */ + if (!sym->attr.dimension || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + { + tmp = gfc_get_cfi_desc_base_addr (cfi); + gfc_add_modify (&block, gfc_desc, + fold_convert (TREE_TYPE (gfc_desc), tmp)); + if (!sym->attr.dimension) + goto done; + } + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + { + /* gfc->dtype = ... (from declaration, not from cfi). */ + etype = gfc_get_element_type (TREE_TYPE (gfc_desc)); + gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc), + gfc_get_dtype_rank_type (sym->as->rank, etype)); + /* gfc->data = cfi->base_addr. */ + gfc_conv_descriptor_data_set (&block, gfc_desc, + gfc_get_cfi_desc_base_addr (cfi)); + } + + if (sym->ts.type == BT_ASSUMED) + { + /* For type(*), take elem_len + dtype.type from the actual argument. */ + gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc), + gfc_get_cfi_desc_elem_len (cfi)); + tree cond; + tree ctype = gfc_get_cfi_desc_type (cfi); + ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype), + ctype, build_int_cst (TREE_TYPE (ctype), + CFI_type_mask)); + tree type = gfc_conv_descriptor_type (gfc_desc); + + /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */ + /* 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, ctype, + build_int_cst (TREE_TYPE (ctype), CFI_type_cptr)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, + build_int_cst (TREE_TYPE (type), BT_VOID)); + tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + type, + build_int_cst (TREE_TYPE (type), BT_UNKNOWN)); + tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + tmp, tmp2); + /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, + build_int_cst (TREE_TYPE (ctype), + CFI_type_struct)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, + build_int_cst (TREE_TYPE (type), BT_DERIVED)); + tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + tmp, tmp2); + /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */ + /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if' + before (see below, as generated bottom up). */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, + build_int_cst (TREE_TYPE (ctype), + CFI_type_Character)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, + build_int_cst (TREE_TYPE (type), BT_CHARACTER)); + tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + tmp, tmp2); + /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */ + /* Note: gfc->elem_len = cfi->elem_len/4. */ + /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave + gfc->elem_len == cfi->elem_len, which helps with operations which use + sizeof() in Fortran and cfi->elem_len in C. */ + tmp = gfc_get_cfi_desc_type (cfi); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), + CFI_type_ucs4_char)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, + build_int_cst (TREE_TYPE (type), BT_CHARACTER)); + tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + tmp, tmp2); + /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, + build_int_cst (TREE_TYPE (ctype), + CFI_type_Complex)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, + build_int_cst (TREE_TYPE (type), BT_COMPLEX)); + tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + tmp, tmp2); + /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real) + ctype else */ + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, + build_int_cst (TREE_TYPE (ctype), + CFI_type_Integer)); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, + build_int_cst (TREE_TYPE (ctype), + CFI_type_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, ctype, + build_int_cst (TREE_TYPE (ctype), + CFI_type_Real)); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, + cond, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + type, fold_convert (TREE_TYPE (type), ctype)); + tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + tmp, tmp2); + gfc_add_expr_to_block (&block, tmp2); + } + + if (sym->as->rank < 0) + { + /* Set gfc->dtype.rank, if assumed-rank. */ + rank = gfc_get_cfi_desc_rank (cfi); + gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank); + } + else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + /* In that case, the CFI rank and the declared rank can differ. */ + rank = gfc_get_cfi_desc_rank (cfi); + else + rank = build_int_cst (signed_char_type_node, sym->as->rank); + + /* With bind(C), the standard requires that both Fortran callers and callees + handle noncontiguous arrays passed to an dummy with 'contiguous' attribute + and with character(len=*) + assumed-size/explicit-size arrays. + cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */ + if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length + && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT)) + || sym->attr.contiguous) + { + do_copy_inout = true; + gcc_assert (!sym->attr.pointer); + stmtblock_t block2; + tree data; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + data = gfc_conv_descriptor_data_get (gfc_desc); + else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc))) + data = gfc_build_addr_expr (NULL, gfc_desc); + else + data = gfc_desc; + + /* Is copy-in/out needed? */ + /* do_copyin = rank != 0 && !assumed-size */ + tree cond_var = gfc_create_var (boolean_type_node, "do_copyin"); + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + rank, build_zero_cst (TREE_TYPE (rank))); + /* dim[rank-1].extent != -1 -> assumed size*/ + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (rank), + rank, build_int_cst (TREE_TYPE (rank), 1)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + gfc_get_cfi_dim_extent (cfi, tmp), + build_int_cst (gfc_array_index_type, -1)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, tmp); + gfc_add_modify (&block, cond_var, cond); + /* if (do_copyin) do_copyin = ... || ... || ... */ + gfc_init_block (&block2); + /* dim[0].sm != elem_len */ + tmp = fold_convert (gfc_array_index_type, + gfc_get_cfi_desc_elem_len (cfi)); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + gfc_get_cfi_dim_sm (cfi, gfc_index_zero_node), + tmp); + gfc_add_modify (&block2, cond_var, cond); + + /* for (i = 1; i < rank; ++i) + cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */ + idx = gfc_create_var (TREE_TYPE (rank), "idx"); + stmtblock_t loop_body; + gfc_init_block (&loop_body); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx), + idx, build_int_cst (TREE_TYPE (idx), 1)); + tree tmp2 = gfc_get_cfi_dim_sm (cfi, tmp); + tmp = gfc_get_cfi_dim_extent (cfi, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), + tmp2, tmp); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + gfc_get_cfi_dim_sm (cfi, idx), tmp); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, + cond_var, cond); + gfc_add_modify (&loop_body, cond_var, cond); + gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1), + rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + + /* Copy-in body. */ + gfc_init_block (&block2); + /* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */ + size_var = gfc_create_var (size_type_node, "size"); + tmp = fold_convert (size_type_node, + gfc_get_cfi_dim_extent (cfi, gfc_index_zero_node)); + gfc_add_modify (&block2, size_var, tmp); + + gfc_init_block (&loop_body); + tmp = fold_convert (size_type_node, + gfc_get_cfi_dim_extent (cfi, idx)); + tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + size_var, fold_convert (size_type_node, tmp)); + gfc_add_modify (&loop_body, size_var, tmp); + gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1), + rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + /* data = malloc (size * elem_len) */ + tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + size_var, gfc_get_cfi_desc_elem_len (cfi)); + tree call = builtin_decl_explicit (BUILT_IN_MALLOC); + call = build_call_expr_loc (input_location, call, 1, tmp); + gfc_add_modify (&block2, data, fold_convert (TREE_TYPE (data), call)); + + /* Copy the data: + for (idx = 0; idx < size; ++idx) + { + shift = 0; + tmpidx = idx + for (dim = 0; dim < rank; ++dim) + { + shift += (tmpidx % extent[d]) * sm[d] + tmpidx = tmpidx / extend[d] + } + memcpy (lhs + idx*elem_len, rhs + shift, elem_len) + } .*/ + idx = gfc_create_var (size_type_node, "arrayidx"); + gfc_init_block (&loop_body); + tree shift = gfc_create_var (size_type_node, "shift"); + tree tmpidx = gfc_create_var (size_type_node, "tmpidx"); + gfc_add_modify (&loop_body, shift, build_zero_cst (TREE_TYPE (shift))); + gfc_add_modify (&loop_body, tmpidx, idx); + stmtblock_t inner_loop; + gfc_init_block (&inner_loop); + tree dim = gfc_create_var (TREE_TYPE (rank), "dim"); + /* shift += (tmpidx % extent[d]) * sm[d] */ + tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, + size_type_node, tmpidx, + fold_convert (size_type_node, + gfc_get_cfi_dim_extent (cfi, dim))); + tmp = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, tmp, + fold_convert (size_type_node, + gfc_get_cfi_dim_sm (cfi, dim))); + gfc_add_modify (&inner_loop, shift, + fold_build2_loc (input_location, PLUS_EXPR, + size_type_node, shift, tmp)); + /* tmpidx = tmpidx / extend[d] */ + tmp = fold_convert (size_type_node, gfc_get_cfi_dim_extent (cfi, dim)); + gfc_add_modify (&inner_loop, tmpidx, + fold_build2_loc (input_location, TRUNC_DIV_EXPR, + size_type_node, tmpidx, tmp)); + gfc_simple_for_loop (&loop_body, dim, build_zero_cst (TREE_TYPE (rank)), + rank, LT_EXPR, build_int_cst (TREE_TYPE (dim), 1), + gfc_finish_block (&inner_loop)); + /* Assign. */ + tmp = fold_convert (pchar_type_node, gfc_get_cfi_desc_base_addr (cfi)); + tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift); + tree lhs; + /* memcpy (lhs + idx*elem_len, rhs + shift, elem_len) */ + tree elem_len; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + elem_len = gfc_conv_descriptor_elem_len (gfc_desc); + else + elem_len = gfc_get_cfi_desc_elem_len (cfi); + lhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + elem_len, idx); + lhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pchar_type_node, + fold_convert (pchar_type_node, data), lhs); + tmp = fold_convert (pvoid_type_node, tmp); + lhs = fold_convert (pvoid_type_node, lhs); + call = builtin_decl_explicit (BUILT_IN_MEMCPY); + call = build_call_expr_loc (input_location, call, 3, lhs, tmp, elem_len); + gfc_add_expr_to_block (&loop_body, fold_convert (void_type_node, call)); + gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), + size_var, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + /* if (cond) { block2 } */ + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + data, fold_convert (TREE_TYPE (data), + null_pointer_node)); + tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + { + tree offset, type; + type = TREE_TYPE (gfc_desc); + gfc_trans_array_bounds (type, sym, &offset, &block); + if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) + gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + goto done; + } + + /* If cfi->data != NULL. */ + stmtblock_t block2; + gfc_init_block (&block2); + + /* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len + We use gfc instead of cfi on the RHS as this might be a constant. */ + tmp = fold_convert (gfc_array_index_type, + gfc_conv_descriptor_elem_len (gfc_desc)); + if (!do_copy_inout) + { + /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len) + ? cfi->dim[0].sm : gfc->elem_len). */ + tree cond; + tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]); + cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR, + gfc_array_index_type, tmp2, tmp); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond, gfc_index_zero_node); + tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, + tmp2, tmp); + } + gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp); + + /* Calculate offset + set lbound, ubound and stride. */ + gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node); + if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable) + for (int i = 0; i < sym->as->rank; ++i) + { + gfc_se se; + gfc_init_se (&se, NULL ); + if (sym->as->lower[i]) + { + gfc_conv_expr (&se, sym->as->lower[i]); + tmp = se.expr; + } + else + tmp = gfc_index_one_node; + gfc_add_block_to_block (&block2, &se.pre); + gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i], + tmp); + gfc_add_block_to_block (&block2, &se.post); + } + + /* Loop: for (i = 0; i < rank; ++i). */ + idx = gfc_create_var (TREE_TYPE (rank), "idx"); + + /* Loop body. */ + stmtblock_t loop_body; + gfc_init_block (&loop_body); + /* gfc->dim[i].lbound = ... */ + if (sym->attr.pointer || sym->attr.allocatable) + { + tmp = gfc_get_cfi_dim_lbound (cfi, idx); + gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp); + } + else if (sym->as->rank < 0) + gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, + gfc_index_one_node); + + /* 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_desc, 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_desc, idx, tmp); + + if (do_copy_inout) + { + /* gfc->dim[i].stride + = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */ + tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + idx, build_zero_cst (TREE_TYPE (idx))); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx), + idx, build_int_cst (TREE_TYPE (idx), 1)); + tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp); + tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2), + tmp2, tmp); + tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, + gfc_index_one_node, tmp); + } + else + { + /* 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_desc, 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_desc, idx), + gfc_conv_descriptor_lbound_get (gfc_desc, idx)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_offset_get (gfc_desc), tmp); + gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp); + + /* Generate loop. */ + gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), + rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + if (sym->attr.allocatable || sym->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 optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */ + if (sym->attr.optional) + { + tree present = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, cfi_desc, + null_pointer_node); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + sym->backend_decl, + fold_convert (TREE_TYPE (sym->backend_decl), + null_pointer_node)); + tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp); + gfc_add_expr_to_block (init, tmp); + } + else + gfc_add_block_to_block (init, &block); + + if (!sym->attr.referenced) + return; + + /* If pointer not changed, nothing to be done (except copy out) */ + if (!do_copy_inout && ((!sym->attr.pointer && !sym->attr.allocatable) + || sym->attr.intent == INTENT_IN)) + return; + + gfc_init_block (&block); + + /* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or + len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain + unchanged. */ + if (do_copy_inout) + { + tree data, call; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + data = gfc_conv_descriptor_data_get (gfc_desc); + else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc))) + data = gfc_build_addr_expr (NULL, gfc_desc); + else + data = gfc_desc; + gfc_init_block (&block2); + if (sym->attr.intent != INTENT_IN) + { + /* First, create the inner copy-out loop. + for (idx = 0; idx < size; ++idx) + { + shift = 0; + tmpidx = idx + for (dim = 0; dim < rank; ++dim) + { + shift += (tmpidx % extent[d]) * sm[d] + tmpidx = tmpidx / extend[d] + } + memcpy (lhs + shift, rhs + idx*elem_len, elem_len) + } .*/ + stmtblock_t loop_body; + idx = gfc_create_var (size_type_node, "arrayidx"); + gfc_init_block (&loop_body); + tree shift = gfc_create_var (size_type_node, "shift"); + tree tmpidx = gfc_create_var (size_type_node, "tmpidx"); + gfc_add_modify (&loop_body, shift, + build_zero_cst (TREE_TYPE (shift))); + gfc_add_modify (&loop_body, tmpidx, idx); + stmtblock_t inner_loop; + gfc_init_block (&inner_loop); + tree dim = gfc_create_var (TREE_TYPE (rank), "dim"); + /* shift += (tmpidx % extent[d]) * sm[d] */ + tmp = fold_convert (size_type_node, + gfc_get_cfi_dim_extent (cfi, dim)); + tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, + size_type_node, tmpidx, tmp); + tmp = fold_build2_loc (input_location, MULT_EXPR, + size_type_node, tmp, + fold_convert (size_type_node, + gfc_get_cfi_dim_sm (cfi, dim))); + gfc_add_modify (&inner_loop, shift, + fold_build2_loc (input_location, PLUS_EXPR, + size_type_node, shift, tmp)); + /* tmpidx = tmpidx / extend[d] */ + tmp = fold_convert (size_type_node, + gfc_get_cfi_dim_extent (cfi, dim)); + gfc_add_modify (&inner_loop, tmpidx, + fold_build2_loc (input_location, TRUNC_DIV_EXPR, + size_type_node, tmpidx, tmp)); + gfc_simple_for_loop (&loop_body, dim, + build_zero_cst (TREE_TYPE (rank)), rank, LT_EXPR, + build_int_cst (TREE_TYPE (dim), 1), + gfc_finish_block (&inner_loop)); + /* Assign. */ + tree rhs; + tmp = fold_convert (pchar_type_node, + gfc_get_cfi_desc_base_addr (cfi)); + tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift); + /* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */ + tree elem_len; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + elem_len = gfc_conv_descriptor_elem_len (gfc_desc); + else + elem_len = gfc_get_cfi_desc_elem_len (cfi); + rhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + elem_len, idx); + rhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, + pchar_type_node, + fold_convert (pchar_type_node, data), rhs); + tmp = fold_convert (pvoid_type_node, tmp); + rhs = fold_convert (pvoid_type_node, rhs); + call = builtin_decl_explicit (BUILT_IN_MEMCPY); + call = build_call_expr_loc (input_location, call, 3, tmp, rhs, + elem_len); + gfc_add_expr_to_block (&loop_body, + fold_convert (void_type_node, call)); + gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), + size_var, LT_EXPR, + build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + } + call = builtin_decl_explicit (BUILT_IN_FREE); + call = build_call_expr_loc (input_location, call, 1, data); + gfc_add_expr_to_block (&block2, call); + + /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */ + tree tmp2 = gfc_get_cfi_desc_base_addr (cfi); + tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp2, fold_convert (TREE_TYPE (tmp2), data)); + tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + goto done_finally; + } + + /* Update pointer + array data data on exit. */ + tmp = gfc_get_cfi_desc_base_addr (cfi); + tmp2 = (!sym->attr.dimension + ? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc)); + gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); + + /* Set string length for len=:, only. */ + if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length) + { + tmp = sym->ts.u.cl->backend_decl; + if (sym->ts.kind != 1) + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + sym->ts.u.cl->backend_decl, tmp); + tmp2 = gfc_get_cfi_desc_elem_len (cfi); + gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); + } + + if (!sym->attr.dimension) + goto done_finally; + + gfc_init_block (&block2); + + /* Loop: for (i = 0; i < rank; ++i). */ + idx = gfc_create_var (TREE_TYPE (rank), "idx"); + + /* Loop body. */ + gfc_init_block (&loop_body); + /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */ + gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), + gfc_conv_descriptor_lbound_get (gfc_desc, idx)); + /* 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_desc, idx), + gfc_conv_descriptor_lbound_get (gfc_desc, 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_desc, idx), + gfc_conv_descriptor_span_get (gfc_desc)); + gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp); + + /* Generate loop. */ + gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), + rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), + gfc_finish_block (&loop_body)); + /* if (gfc->data != NULL) { block2 }. */ + 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); + +done_finally: + /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */ + if (sym->attr.optional) + { + tree present = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, cfi_desc, + null_pointer_node); + tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (finally, tmp); + } + else + gfc_add_block_to_block (finally, &block); +} + +/* Generate code for a function. */ + +void +gfc_generate_function_code (gfc_namespace * ns) +{ + tree fndecl; + tree old_context; + tree decl; + tree tmp; + tree fpstate = NULL_TREE; + stmtblock_t init, cleanup, outer_block; + stmtblock_t body; + gfc_wrapped_block try_block; + tree recurcheckvar = NULL_TREE; + gfc_symbol *sym; + gfc_symbol *previous_procedure_symbol; + int rank, ieee; + bool is_recursive; + + sym = ns->proc_name; + previous_procedure_symbol = current_procedure_symbol; + current_procedure_symbol = sym; + + /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get + lost or worse. */ + sym->tlink = sym; + + /* Create the declaration for functions with global scope. */ + if (!sym->backend_decl) + gfc_create_function_decl (ns, false); + + fndecl = sym->backend_decl; + old_context = current_function_decl; + + if (old_context) + { + push_function_context (); + saved_parent_function_decls = saved_function_decls; + saved_function_decls = NULL_TREE; + } + + trans_function_start (sym); + + gfc_init_block (&init); + gfc_init_block (&cleanup); + gfc_init_block (&outer_block); + + if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) + { + /* Copy length backend_decls to all entry point result + symbols. */ + gfc_entry_list *el; + tree backend_decl; + + gfc_conv_const_charlen (ns->proc_name->ts.u.cl); + backend_decl = ns->proc_name->result->ts.u.cl->backend_decl; + for (el = ns->entries; el; el = el->next) + el->sym->result->ts.u.cl->backend_decl = backend_decl; + } + + /* Translate COMMON blocks. */ + gfc_trans_common (ns); + + /* Null the parent fake result declaration if this namespace is + a module function or an external procedures. */ + if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) + || ns->parent == NULL) + parent_fake_result_decl = NULL_TREE; + + /* For BIND(C): + - deallocate intent-out allocatable dummy arguments. + - Create GFC variable which will later be populated by convert_CFI_desc */ + if (sym->attr.is_bind_c) + for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym); + formal; formal = formal->next) + { + gfc_symbol *fsym = formal->sym; + if (!is_CFI_desc (fsym, NULL)) + continue; + if (!fsym->attr.referenced) + { + gfc_conv_cfi_to_gfc (&init, &cleanup, fsym->backend_decl, + NULL_TREE, fsym); + continue; + } + /* Let's now create a local GFI descriptor. Afterwards: + desc is the local descriptor, + desc_p is a pointer to it + and stored in sym->backend_decl + GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor + -> PARM_DECL and before sym->backend_decl. + For scalars, decl == decl_p is a pointer variable. */ + tree desc_p, desc; + location_t loc = gfc_get_location (&sym->declared_at); + if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length) + fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type, + fsym->name); + else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl) + { + gfc_se se; + gfc_init_se (&se, NULL ); + gfc_conv_expr (&se, fsym->ts.u.cl->length); + gfc_add_block_to_block (&init, &se.pre); + fsym->ts.u.cl->backend_decl = se.expr; + gcc_assert(se.post.head == NULL_TREE); + } + /* Nullify, otherwise gfc_sym_type will return the CFI type. */ + tree tmp = fsym->backend_decl; + fsym->backend_decl = NULL; + tree type = gfc_sym_type (fsym); + gcc_assert (POINTER_TYPE_P (type)); + if (POINTER_TYPE_P (TREE_TYPE (type))) + /* For instance, allocatable scalars. */ + type = TREE_TYPE (type); + if (TREE_CODE (type) == REFERENCE_TYPE) + type = build_pointer_type (TREE_TYPE (type)); + desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type); + if (!fsym->attr.dimension) + desc = desc_p; + else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p)))) + { + /* Character(len=*) explict-size/assumed-size array. */ + desc = desc_p; + gfc_build_qualified_array (desc, fsym); + } + else + { + tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p))); + tree call = builtin_decl_explicit (BUILT_IN_ALLOCA); + call = build_call_expr_loc (input_location, call, 1, size); + gfc_add_modify (&outer_block, desc_p, + fold_convert (TREE_TYPE(desc_p), call)); + desc = build_fold_indirect_ref_loc (input_location, desc_p); + } + pushdecl (desc_p); + if (fsym->attr.optional) + { + gfc_allocate_lang_decl (desc_p); + GFC_DECL_OPTIONAL_ARGUMENT (desc_p) = 1; + } + fsym->backend_decl = desc_p; + gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym); + } + + gfc_generate_contained_functions (ns); + + has_coarray_vars = false; + generate_local_vars (ns); + + if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) + generate_coarray_init (ns); + + /* Keep the parent fake result declaration in module functions + or external procedures. */ + if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) + || ns->parent == NULL) + current_fake_result_decl = parent_fake_result_decl; + else + current_fake_result_decl = NULL_TREE; + + is_recursive = sym->attr.recursive + || (sym->attr.entry_master + && sym->ns->entries->sym->attr.recursive); + if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) + && !is_recursive && !flag_recursive && !sym->attr.artificial) + { + char * msg; + + msg = xasprintf ("Recursive call to nonrecursive procedure '%s'", + sym->name); + recurcheckvar = gfc_create_var (logical_type_node, "is_recursive"); + TREE_STATIC (recurcheckvar) = 1; + DECL_INITIAL (recurcheckvar) = logical_false_node; + gfc_add_expr_to_block (&init, recurcheckvar); + gfc_trans_runtime_check (true, false, recurcheckvar, &init, + &sym->declared_at, msg); + gfc_add_modify (&init, recurcheckvar, logical_true_node); + free (msg); + } + + /* Check if an IEEE module is used in the procedure. If so, save + the floating point state. */ + ieee = is_ieee_module_used (ns); + if (ieee) + fpstate = gfc_save_fp_state (&init); + + /* Now generate the code for the body of this function. */ + gfc_init_block (&body); + + if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node + && sym->attr.subroutine) + { + tree alternate_return; + alternate_return = gfc_get_fake_result_decl (sym, 0); + gfc_add_modify (&body, alternate_return, integer_zero_node); + } + + if (ns->entries) + { + /* Jump to the correct entry point. */ + tmp = gfc_trans_entry_master_switch (ns->entries); + gfc_add_expr_to_block (&body, tmp); + } + + /* If bounds-checking is enabled, generate code to check passed in actual + arguments against the expected dummy argument attributes (e.g. string + lengths). */ + if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c) + add_argument_checking (&body, sym); + + finish_oacc_declare (ns, sym, false); + + tmp = gfc_trans_code (ns->code); + gfc_add_expr_to_block (&body, tmp); + + if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node + || (sym->result && sym->result != sym + && sym->result->ts.type == BT_DERIVED + && sym->result->ts.u.derived->attr.alloc_comp)) + { + bool artificial_result_decl = false; + tree result = get_proc_result (sym); + gfc_symbol *rsym = sym == sym->result ? sym : sym->result; + + /* Make sure that a function returning an object with + alloc/pointer_components always has a result, where at least + the allocatable/pointer components are set to zero. */ + if (result == NULL_TREE && sym->attr.function + && ((sym->result->ts.type == BT_DERIVED + && (sym->attr.allocatable + || sym->attr.pointer + || sym->result->ts.u.derived->attr.alloc_comp + || sym->result->ts.u.derived->attr.pointer_comp)) + || (sym->result->ts.type == BT_CLASS + && (CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym->result)->attr.alloc_comp + || CLASS_DATA (sym->result)->attr.pointer_comp)))) + { + artificial_result_decl = true; + result = gfc_get_fake_result_decl (sym, 0); + } + + if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer) + { + if (sym->attr.allocatable && sym->attr.dimension == 0 + && sym->result == sym) + gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result), + null_pointer_node)); + else if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.allocatable + && CLASS_DATA (sym)->attr.dimension == 0 + && sym->result == sym) + { + tmp = CLASS_DATA (sym)->backend_decl; + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (tmp), result, tmp, NULL_TREE); + gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } + else if (sym->ts.type == BT_DERIVED + && !sym->attr.allocatable) + { + gfc_expr *init_exp; + /* Arrays are not initialized using the default initializer of + their elements. Therefore only check if a default + initializer is available when the result is scalar. */ + init_exp = rsym->as ? NULL + : gfc_generate_initializer (&rsym->ts, true); + if (init_exp) + { + tmp = gfc_trans_structure_assign (result, init_exp, 0); + gfc_free_expr (init_exp); + gfc_add_expr_to_block (&init, tmp); + } + else if (rsym->ts.u.derived->attr.alloc_comp) + { + rank = rsym->as ? rsym->as->rank : 0; + tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result, + rank); + gfc_prepend_expr_to_block (&body, tmp); + } + } + } + + if (result == NULL_TREE || artificial_result_decl) + { + /* TODO: move to the appropriate place in resolve.c. */ + if (warn_return_type > 0 && sym == sym->result) + gfc_warning (OPT_Wreturn_type, + "Return value of function %qs at %L not set", + sym->name, &sym->declared_at); + if (warn_return_type > 0) + suppress_warning (sym->backend_decl); + } + if (result != NULL_TREE) + gfc_add_expr_to_block (&body, gfc_generate_return ()); + } + + /* Reset recursion-check variable. */ + if (recurcheckvar != NULL_TREE) + { + gfc_add_modify (&cleanup, recurcheckvar, logical_false_node); + recurcheckvar = NULL; + } + + /* If IEEE modules are loaded, restore the floating-point state. */ + if (ieee) + gfc_restore_fp_state (&cleanup, fpstate); + + /* Finish the function body and add init and cleanup code. */ + tmp = gfc_finish_block (&body); + /* Add code to create and cleanup arrays. */ + gfc_start_wrapped_block (&try_block, tmp); + gfc_trans_deferred_vars (sym, &try_block); + gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); + + /* Add all the decls we created during processing. */ + decl = nreverse (saved_function_decls); + while (decl) + { + tree next; + + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; + pushdecl (decl); + decl = next; + } + saved_function_decls = NULL_TREE; + + gfc_add_expr_to_block (&outer_block, gfc_finish_wrapped_block (&try_block)); + DECL_SAVED_TREE (fndecl) = gfc_finish_block (&outer_block); + decl = getdecls (); + + /* Finish off this function and send it for code generation. */ + poplevel (1, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + DECL_SAVED_TREE (fndecl) + = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node, + decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl)); + + /* Output the GENERIC tree. */ + dump_function (TDI_original, fndecl); + + /* Store the end of the function, so that we get good line number + info for the epilogue. */ + cfun->function_end_locus = input_location; + + /* We're leaving the context of this function, so zap cfun. + It's still in DECL_STRUCT_FUNCTION, and we'll restore it in + tree_rest_of_compilation. */ + set_cfun (NULL); + + if (old_context) + { + pop_function_context (); + saved_function_decls = saved_parent_function_decls; + } + current_function_decl = old_context; + + if (decl_function_context (fndecl)) + { + /* Register this function with cgraph just far enough to get it + added to our parent's nested function list. + If there are static coarrays in this function, the nested _caf_init + function has already called cgraph_create_node, which also created + the cgraph node for this function. */ + if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB) + (void) cgraph_node::get_create (fndecl); + } + else + cgraph_node::finalize_function (fndecl, true); + + gfc_trans_use_stmts (ns); + gfc_traverse_ns (ns, gfc_emit_parameter_debug_info); + + if (sym->attr.is_main_program) + create_main_function (fndecl); + + current_procedure_symbol = previous_procedure_symbol; +} + + +void +gfc_generate_constructors (void) +{ + gcc_assert (gfc_static_ctors == NULL_TREE); +#if 0 + tree fnname; + tree type; + tree fndecl; + tree decl; + tree tmp; + + if (gfc_static_ctors == NULL_TREE) + return; + + fnname = get_file_function_name ("I"); + type = build_function_type_list (void_type_node, NULL_TREE); + + fndecl = build_decl (input_location, + FUNCTION_DECL, fnname, type); + TREE_PUBLIC (fndecl) = 1; + + decl = build_decl (input_location, + RESULT_DECL, NULL_TREE, void_type_node); + DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; + DECL_CONTEXT (decl) = fndecl; + DECL_RESULT (fndecl) = decl; + + pushdecl (fndecl); + + current_function_decl = fndecl; + + rest_of_decl_compilation (fndecl, 1, 0); + + make_decl_rtl (fndecl); + + allocate_struct_function (fndecl, false); + + pushlevel (); + + for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors)) + { + tmp = build_call_expr_loc (input_location, + TREE_VALUE (gfc_static_ctors), 0); + DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp); + } + + decl = getdecls (); + poplevel (1, 1); + + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + DECL_SAVED_TREE (fndecl) + = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl), + DECL_INITIAL (fndecl)); + + free_after_parsing (cfun); + free_after_compilation (cfun); + + tree_rest_of_compilation (fndecl); + + current_function_decl = NULL_TREE; +#endif +} + +/* Translates a BLOCK DATA program unit. This means emitting the + commons contained therein plus their initializations. We also emit + a globally visible symbol to make sure that each BLOCK DATA program + unit remains unique. */ + +void +gfc_generate_block_data (gfc_namespace * ns) +{ + tree decl; + tree id; + + /* Tell the backend the source location of the block data. */ + if (ns->proc_name) + gfc_set_backend_locus (&ns->proc_name->declared_at); + else + gfc_set_backend_locus (&gfc_current_locus); + + /* Process the DATA statements. */ + gfc_trans_common (ns); + + /* Create a global symbol with the mane of the block data. This is to + generate linker errors if the same name is used twice. It is never + really used. */ + if (ns->proc_name) + id = gfc_sym_mangled_function_id (ns->proc_name); + else + id = get_identifier ("__BLOCK_DATA__"); + + decl = build_decl (input_location, + VAR_DECL, id, gfc_array_index_type); + TREE_PUBLIC (decl) = 1; + TREE_STATIC (decl) = 1; + DECL_IGNORED_P (decl) = 1; + + pushdecl (decl); + rest_of_decl_compilation (decl, 1, 0); +} + + +/* Process the local variables of a BLOCK construct. */ + +void +gfc_process_block_locals (gfc_namespace* ns) +{ + tree decl; + + saved_local_decls = NULL_TREE; + has_coarray_vars = false; + + generate_local_vars (ns); + + if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) + generate_coarray_init (ns); + + decl = nreverse (saved_local_decls); + while (decl) + { + tree next; + + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; + pushdecl (decl); + decl = next; + } + saved_local_decls = NULL_TREE; +} + + +#include "gt-fortran-trans-decl.h" 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 - and Steven Bosscher - -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 -. */ - -/* 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 *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 *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 = "<>"; - 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< 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 */ - 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 *append_args) -{ - gfc_interface_mapping mapping; - vec *arglist; - vec *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 *stringargs; - vec *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 *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 *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 *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 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 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); -} diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc new file mode 100644 index 0000000..2e15a7e --- /dev/null +++ b/gcc/fortran/trans-expr.cc @@ -0,0 +1,12125 @@ +/* Expression translation + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + and Steven Bosscher + +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 +. */ + +/* 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 *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 *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 = "<>"; + 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< 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 */ + 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 *append_args) +{ + gfc_interface_mapping mapping; + vec *arglist; + vec *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 *stringargs; + vec *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 *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 *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 *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 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 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); +} diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c deleted file mode 100644 index a7cbbeb..0000000 --- a/gcc/fortran/trans-intrinsic.c +++ /dev/null @@ -1,12457 +0,0 @@ -/* Intrinsic translation - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - and Steven Bosscher - -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 -. */ - -/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "memmodel.h" -#include "tm.h" /* For UNITS_PER_WORD. */ -#include "tree.h" -#include "gfortran.h" -#include "trans.h" -#include "stringpool.h" -#include "fold-const.h" -#include "internal-fn.h" -#include "tree-nested.h" -#include "stor-layout.h" -#include "toplev.h" /* For rest_of_decl_compilation. */ -#include "arith.h" -#include "trans-const.h" -#include "trans-types.h" -#include "trans-array.h" -#include "dependency.h" /* For CAF array alias analysis. */ -#include "attribs.h" - -/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ - -/* This maps Fortran intrinsic math functions to external library or GCC - builtin functions. */ -typedef struct GTY(()) gfc_intrinsic_map_t { - /* The explicit enum is required to work around inadequacies in the - garbage collection/gengtype parsing mechanism. */ - enum gfc_isym_id id; - - /* Enum value from the "language-independent", aka C-centric, part - of gcc, or END_BUILTINS of no such value set. */ - enum built_in_function float_built_in; - enum built_in_function double_built_in; - enum built_in_function long_double_built_in; - enum built_in_function complex_float_built_in; - enum built_in_function complex_double_built_in; - enum built_in_function complex_long_double_built_in; - - /* True if the naming pattern is to prepend "c" for complex and - append "f" for kind=4. False if the naming pattern is to - prepend "_gfortran_" and append "[rc](4|8|10|16)". */ - bool libm_name; - - /* True if a complex version of the function exists. */ - bool complex_available; - - /* True if the function should be marked const. */ - bool is_constant; - - /* The base library name of this function. */ - const char *name; - - /* Cache decls created for the various operand types. */ - tree real4_decl; - tree real8_decl; - tree real10_decl; - tree real16_decl; - tree complex4_decl; - tree complex8_decl; - tree complex10_decl; - tree complex16_decl; -} -gfc_intrinsic_map_t; - -/* ??? The NARGS==1 hack here is based on the fact that (c99 at least) - defines complex variants of all of the entries in mathbuiltins.def - except for atan2. */ -#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ - { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ - true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, - -#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ - { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \ - BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, - -#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \ - { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ - END_BUILTINS, END_BUILTINS, END_BUILTINS, \ - false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } - -#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ - { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ - true, false, CONST, NAME, NULL_TREE, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, - -static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = -{ - /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and - DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond - to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */ -#include "mathbuiltins.def" - - /* Functions in libgfortran. */ - LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false), - LIB_FUNCTION (SIND, "sind", false), - LIB_FUNCTION (COSD, "cosd", false), - LIB_FUNCTION (TAND, "tand", false), - - /* End the list. */ - LIB_FUNCTION (NONE, NULL, false) - -}; -#undef OTHER_BUILTIN -#undef LIB_FUNCTION -#undef DEFINE_MATH_BUILTIN -#undef DEFINE_MATH_BUILTIN_C - - -enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; - - -/* Find the correct variant of a given builtin from its argument. */ -static tree -builtin_decl_for_precision (enum built_in_function base_built_in, - int precision) -{ - enum built_in_function i = END_BUILTINS; - - gfc_intrinsic_map_t *m; - for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++) - ; - - if (precision == TYPE_PRECISION (float_type_node)) - i = m->float_built_in; - else if (precision == TYPE_PRECISION (double_type_node)) - i = m->double_built_in; - else if (precision == TYPE_PRECISION (long_double_type_node) - && (!gfc_real16_is_float128 - || long_double_type_node != gfc_float128_type_node)) - i = m->long_double_built_in; - else if (precision == TYPE_PRECISION (gfc_float128_type_node)) - { - /* Special treatment, because it is not exactly a built-in, but - a library function. */ - return m->real16_decl; - } - - return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i)); -} - - -tree -gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in, - int kind) -{ - int i = gfc_validate_kind (BT_REAL, kind, false); - - if (gfc_real_kinds[i].c_float128) - { - /* For _Float128, the story is a bit different, because we return - a decl to a library function rather than a built-in. */ - gfc_intrinsic_map_t *m; - for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++) - ; - - return m->real16_decl; - } - - return builtin_decl_for_precision (double_built_in, - gfc_real_kinds[i].mode_precision); -} - - -/* Evaluate the arguments to an intrinsic function. The value - of NARGS may be less than the actual number of arguments in EXPR - to allow optional "KIND" arguments that are not included in the - generated code to be ignored. */ - -static void -gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr, - tree *argarray, int nargs) -{ - gfc_actual_arglist *actual; - gfc_expr *e; - gfc_intrinsic_arg *formal; - gfc_se argse; - int curr_arg; - - formal = expr->value.function.isym->formal; - actual = expr->value.function.actual; - - for (curr_arg = 0; curr_arg < nargs; curr_arg++, - actual = actual->next, - formal = formal ? formal->next : NULL) - { - gcc_assert (actual); - e = actual->expr; - /* Skip omitted optional arguments. */ - if (!e) - { - --curr_arg; - continue; - } - - /* Evaluate the parameter. This will substitute scalarized - references automatically. */ - gfc_init_se (&argse, se); - - if (e->ts.type == BT_CHARACTER) - { - gfc_conv_expr (&argse, e); - gfc_conv_string_parameter (&argse); - argarray[curr_arg++] = argse.string_length; - gcc_assert (curr_arg < nargs); - } - else - gfc_conv_expr_val (&argse, e); - - /* If an optional argument is itself an optional dummy argument, - check its presence and substitute a null if absent. */ - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->attr.optional - && formal - && formal->optional) - gfc_conv_missing_dummy (&argse, e, formal->ts, 0); - - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - argarray[curr_arg] = argse.expr; - } -} - -/* Count the number of actual arguments to the intrinsic function EXPR - including any "hidden" string length arguments. */ - -static unsigned int -gfc_intrinsic_argument_list_length (gfc_expr *expr) -{ - int n = 0; - gfc_actual_arglist *actual; - - for (actual = expr->value.function.actual; actual; actual = actual->next) - { - if (!actual->expr) - continue; - - if (actual->expr->ts.type == BT_CHARACTER) - n += 2; - else - n++; - } - - return n; -} - - -/* Conversions between different types are output by the frontend as - intrinsic functions. We implement these directly with inline code. */ - -static void -gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) -{ - tree type; - tree *args; - int nargs; - - nargs = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, nargs); - - /* Evaluate all the arguments passed. Whilst we're only interested in the - first one here, there are other parts of the front-end that assume this - and will trigger an ICE if it's not the case. */ - type = gfc_typenode_for_spec (&expr->ts); - gcc_assert (expr->value.function.actual->expr); - gfc_conv_intrinsic_function_args (se, expr, args, nargs); - - /* Conversion between character kinds involves a call to a library - function. */ - if (expr->ts.type == BT_CHARACTER) - { - tree fndecl, var, addr, tmp; - - if (expr->ts.kind == 1 - && expr->value.function.actual->expr->ts.kind == 4) - fndecl = gfor_fndecl_convert_char4_to_char1; - else if (expr->ts.kind == 4 - && expr->value.function.actual->expr->ts.kind == 1) - fndecl = gfor_fndecl_convert_char1_to_char4; - else - gcc_unreachable (); - - /* Create the variable storing the converted value. */ - type = gfc_get_pchar_type (expr->ts.kind); - var = gfc_create_var (type, "str"); - addr = gfc_build_addr_expr (build_pointer_type (type), var); - - /* Call the library function that will perform the conversion. */ - gcc_assert (nargs >= 2); - tmp = build_call_expr_loc (input_location, - fndecl, 3, addr, args[0], args[1]); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Free the temporary afterwards. */ - tmp = gfc_call_free (var); - gfc_add_expr_to_block (&se->post, tmp); - - se->expr = var; - se->string_length = args[0]; - - return; - } - - /* Conversion from complex to non-complex involves taking the real - component of the value. */ - if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE - && expr->ts.type != BT_COMPLEX) - { - tree artype; - - artype = TREE_TYPE (TREE_TYPE (args[0])); - args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, - args[0]); - } - - se->expr = convert (type, args[0]); -} - -/* This is needed because the gcc backend only implements - FIX_TRUNC_EXPR, which is the same as INT() in Fortran. - FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1 - Similarly for CEILING. */ - -static tree -build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) -{ - tree tmp; - tree cond; - tree argtype; - tree intval; - - argtype = TREE_TYPE (arg); - arg = gfc_evaluate_now (arg, pblock); - - intval = convert (type, arg); - intval = gfc_evaluate_now (intval, pblock); - - tmp = convert (argtype, intval); - cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR, - logical_type_node, tmp, arg); - - tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type, - intval, build_int_cst (type, 1)); - tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp); - return tmp; -} - - -/* Round to nearest integer, away from zero. */ - -static tree -build_round_expr (tree arg, tree restype) -{ - tree argtype; - tree fn; - int argprec, resprec; - - argtype = TREE_TYPE (arg); - argprec = TYPE_PRECISION (argtype); - resprec = TYPE_PRECISION (restype); - - /* Depending on the type of the result, choose the int intrinsic (iround, - available only as a builtin, therefore cannot use it for _Float128), long - int intrinsic (lround family) or long long intrinsic (llround). If we - don't have an appropriate function that converts directly to the integer - type (such as kind == 16), just use ROUND, and then convert the result to - an integer. We might also need to convert the result afterwards. */ - if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE) - fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec); - else if (resprec <= LONG_TYPE_SIZE) - fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec); - else if (resprec <= LONG_LONG_TYPE_SIZE) - fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec); - else if (resprec >= argprec) - fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec); - else - gcc_unreachable (); - - return convert (restype, build_call_expr_loc (input_location, - fn, 1, arg)); -} - - -/* Convert a real to an integer using a specific rounding mode. - Ideally we would just build the corresponding GENERIC node, - however the RTL expander only actually supports FIX_TRUNC_EXPR. */ - -static tree -build_fix_expr (stmtblock_t * pblock, tree arg, tree type, - enum rounding_mode op) -{ - switch (op) - { - case RND_FLOOR: - return build_fixbound_expr (pblock, arg, type, 0); - - case RND_CEIL: - return build_fixbound_expr (pblock, arg, type, 1); - - case RND_ROUND: - return build_round_expr (arg, type); - - case RND_TRUNC: - return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg); - - default: - gcc_unreachable (); - } -} - - -/* Round a real value using the specified rounding mode. - We use a temporary integer of that same kind size as the result. - Values larger than those that can be represented by this kind are - unchanged, as they will not be accurate enough to represent the - rounding. - huge = HUGE (KIND (a)) - aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a - */ - -static void -gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) -{ - tree type; - tree itype; - tree arg[2]; - tree tmp; - tree cond; - tree decl; - mpfr_t huge; - int n, nargs; - int kind; - - kind = expr->ts.kind; - nargs = gfc_intrinsic_argument_list_length (expr); - - decl = NULL_TREE; - /* We have builtin functions for some cases. */ - switch (op) - { - case RND_ROUND: - decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind); - break; - - case RND_TRUNC: - decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind); - break; - - default: - gcc_unreachable (); - } - - /* Evaluate the argument. */ - gcc_assert (expr->value.function.actual->expr); - gfc_conv_intrinsic_function_args (se, expr, arg, nargs); - - /* Use a builtin function if one exists. */ - if (decl != NULL_TREE) - { - se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]); - return; - } - - /* This code is probably redundant, but we'll keep it lying around just - in case. */ - type = gfc_typenode_for_spec (&expr->ts); - arg[0] = gfc_evaluate_now (arg[0], &se->pre); - - /* Test if the value is too large to handle sensibly. */ - gfc_set_model_kind (kind); - mpfr_init (huge); - n = gfc_validate_kind (BT_INTEGER, kind, false); - mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); - tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0], - tmp); - - mpfr_neg (huge, huge, GFC_RND_MODE); - tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); - tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0], - tmp); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, - cond, tmp); - itype = gfc_get_int_type (kind); - - tmp = build_fix_expr (&se->pre, arg[0], itype, op); - tmp = convert (type, tmp); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp, - arg[0]); - mpfr_clear (huge); -} - - -/* Convert to an integer using the specified rounding mode. */ - -static void -gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) -{ - tree type; - tree *args; - int nargs; - - nargs = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, nargs); - - /* Evaluate the argument, we process all arguments even though we only - use the first one for code generation purposes. */ - type = gfc_typenode_for_spec (&expr->ts); - gcc_assert (expr->value.function.actual->expr); - gfc_conv_intrinsic_function_args (se, expr, args, nargs); - - if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE) - { - /* Conversion to a different integer kind. */ - se->expr = convert (type, args[0]); - } - else - { - /* Conversion from complex to non-complex involves taking the real - component of the value. */ - if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE - && expr->ts.type != BT_COMPLEX) - { - tree artype; - - artype = TREE_TYPE (TREE_TYPE (args[0])); - args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, - args[0]); - } - - se->expr = build_fix_expr (&se->pre, args[0], type, op); - } -} - - -/* Get the imaginary component of a value. */ - -static void -gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) -{ - tree arg; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build1_loc (input_location, IMAGPART_EXPR, - TREE_TYPE (TREE_TYPE (arg)), arg); -} - - -/* Get the complex conjugate of a value. */ - -static void -gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) -{ - tree arg; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg); -} - - - -static tree -define_quad_builtin (const char *name, tree type, bool is_const) -{ - tree fndecl; - fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name), - type); - - /* Mark the decl as external. */ - DECL_EXTERNAL (fndecl) = 1; - TREE_PUBLIC (fndecl) = 1; - - /* Mark it __attribute__((const)). */ - TREE_READONLY (fndecl) = is_const; - - rest_of_decl_compilation (fndecl, 1, 0); - - return fndecl; -} - -/* Add SIMD attribute for FNDECL built-in if the built-in - name is in VECTORIZED_BUILTINS. */ - -static void -add_simd_flag_for_built_in (tree fndecl) -{ - if (gfc_vectorized_builtins == NULL - || fndecl == NULL_TREE) - return; - - const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl)); - int *clauses = gfc_vectorized_builtins->get (name); - if (clauses) - { - for (unsigned i = 0; i < 3; i++) - if (*clauses & (1 << i)) - { - gfc_simd_clause simd_type = (gfc_simd_clause)*clauses; - tree omp_clause = NULL_TREE; - if (simd_type == SIMD_NONE) - ; /* No SIMD clause. */ - else - { - omp_clause_code code - = (simd_type == SIMD_INBRANCH - ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH); - omp_clause = build_omp_clause (UNKNOWN_LOCATION, code); - omp_clause = build_tree_list (NULL_TREE, omp_clause); - } - - DECL_ATTRIBUTES (fndecl) - = tree_cons (get_identifier ("omp declare simd"), omp_clause, - DECL_ATTRIBUTES (fndecl)); - } - } -} - - /* Set SIMD attribute to all built-in functions that are mentioned - in gfc_vectorized_builtins vector. */ - -void -gfc_adjust_builtins (void) -{ - gfc_intrinsic_map_t *m; - for (m = gfc_intrinsic_map; - m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) - { - add_simd_flag_for_built_in (m->real4_decl); - add_simd_flag_for_built_in (m->complex4_decl); - add_simd_flag_for_built_in (m->real8_decl); - add_simd_flag_for_built_in (m->complex8_decl); - add_simd_flag_for_built_in (m->real10_decl); - add_simd_flag_for_built_in (m->complex10_decl); - add_simd_flag_for_built_in (m->real16_decl); - add_simd_flag_for_built_in (m->complex16_decl); - add_simd_flag_for_built_in (m->real16_decl); - add_simd_flag_for_built_in (m->complex16_decl); - } - - /* Release all strings. */ - if (gfc_vectorized_builtins != NULL) - { - for (hash_map::iterator it - = gfc_vectorized_builtins->begin (); - it != gfc_vectorized_builtins->end (); ++it) - free (CONST_CAST (char *, (*it).first)); - - delete gfc_vectorized_builtins; - gfc_vectorized_builtins = NULL; - } -} - -/* Initialize function decls for library functions. The external functions - are created as required. Builtin functions are added here. */ - -void -gfc_build_intrinsic_lib_fndecls (void) -{ - gfc_intrinsic_map_t *m; - tree quad_decls[END_BUILTINS + 1]; - - if (gfc_real16_is_float128) - { - /* If we have soft-float types, we create the decls for their - C99-like library functions. For now, we only handle _Float128 - q-suffixed functions. */ - - tree type, complex_type, func_1, func_2, func_cabs, func_frexp; - tree func_iround, func_lround, func_llround, func_scalbn, func_cpow; - - memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1)); - - type = gfc_float128_type_node; - complex_type = gfc_complex_float128_type_node; - /* type (*) (type) */ - func_1 = build_function_type_list (type, type, NULL_TREE); - /* int (*) (type) */ - func_iround = build_function_type_list (integer_type_node, - type, NULL_TREE); - /* long (*) (type) */ - func_lround = build_function_type_list (long_integer_type_node, - type, NULL_TREE); - /* long long (*) (type) */ - func_llround = build_function_type_list (long_long_integer_type_node, - type, NULL_TREE); - /* type (*) (type, type) */ - func_2 = build_function_type_list (type, type, type, NULL_TREE); - /* type (*) (type, &int) */ - func_frexp - = build_function_type_list (type, - type, - build_pointer_type (integer_type_node), - NULL_TREE); - /* type (*) (type, int) */ - func_scalbn = build_function_type_list (type, - type, integer_type_node, NULL_TREE); - /* type (*) (complex type) */ - func_cabs = build_function_type_list (type, complex_type, NULL_TREE); - /* complex type (*) (complex type, complex type) */ - func_cpow - = build_function_type_list (complex_type, - complex_type, complex_type, NULL_TREE); - -#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) -#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) -#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) - - /* Only these built-ins are actually needed here. These are used directly - from the code, when calling builtin_decl_for_precision() or - builtin_decl_for_float_type(). The others are all constructed by - gfc_get_intrinsic_lib_fndecl(). */ -#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ - quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST); - -#include "mathbuiltins.def" - -#undef OTHER_BUILTIN -#undef LIB_FUNCTION -#undef DEFINE_MATH_BUILTIN -#undef DEFINE_MATH_BUILTIN_C - - /* There is one built-in we defined manually, because it gets called - with builtin_decl_for_precision() or builtin_decl_for_float_type() - even though it is not an OTHER_BUILTIN: it is SQRT. */ - quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true); - - } - - /* Add GCC builtin functions. */ - for (m = gfc_intrinsic_map; - m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) - { - if (m->float_built_in != END_BUILTINS) - m->real4_decl = builtin_decl_explicit (m->float_built_in); - if (m->complex_float_built_in != END_BUILTINS) - m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in); - if (m->double_built_in != END_BUILTINS) - m->real8_decl = builtin_decl_explicit (m->double_built_in); - if (m->complex_double_built_in != END_BUILTINS) - m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in); - - /* If real(kind=10) exists, it is always long double. */ - if (m->long_double_built_in != END_BUILTINS) - m->real10_decl = builtin_decl_explicit (m->long_double_built_in); - if (m->complex_long_double_built_in != END_BUILTINS) - m->complex10_decl - = builtin_decl_explicit (m->complex_long_double_built_in); - - if (!gfc_real16_is_float128) - { - if (m->long_double_built_in != END_BUILTINS) - m->real16_decl = builtin_decl_explicit (m->long_double_built_in); - if (m->complex_long_double_built_in != END_BUILTINS) - m->complex16_decl - = builtin_decl_explicit (m->complex_long_double_built_in); - } - else if (quad_decls[m->double_built_in] != NULL_TREE) - { - /* Quad-precision function calls are constructed when first - needed by builtin_decl_for_precision(), except for those - that will be used directly (define by OTHER_BUILTIN). */ - m->real16_decl = quad_decls[m->double_built_in]; - } - else if (quad_decls[m->complex_double_built_in] != NULL_TREE) - { - /* Same thing for the complex ones. */ - m->complex16_decl = quad_decls[m->double_built_in]; - } - } -} - - -/* Create a fndecl for a simple intrinsic library function. */ - -static tree -gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) -{ - tree type; - vec *argtypes; - tree fndecl; - gfc_actual_arglist *actual; - tree *pdecl; - gfc_typespec *ts; - char name[GFC_MAX_SYMBOL_LEN + 3]; - - ts = &expr->ts; - if (ts->type == BT_REAL) - { - switch (ts->kind) - { - case 4: - pdecl = &m->real4_decl; - break; - case 8: - pdecl = &m->real8_decl; - break; - case 10: - pdecl = &m->real10_decl; - break; - case 16: - pdecl = &m->real16_decl; - break; - default: - gcc_unreachable (); - } - } - else if (ts->type == BT_COMPLEX) - { - gcc_assert (m->complex_available); - - switch (ts->kind) - { - case 4: - pdecl = &m->complex4_decl; - break; - case 8: - pdecl = &m->complex8_decl; - break; - case 10: - pdecl = &m->complex10_decl; - break; - case 16: - pdecl = &m->complex16_decl; - break; - default: - gcc_unreachable (); - } - } - else - gcc_unreachable (); - - if (*pdecl) - return *pdecl; - - if (m->libm_name) - { - int n = gfc_validate_kind (BT_REAL, ts->kind, false); - if (gfc_real_kinds[n].c_float) - snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); - else if (gfc_real_kinds[n].c_double) - snprintf (name, sizeof (name), "%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name); - else if (gfc_real_kinds[n].c_long_double) - snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); - else if (gfc_real_kinds[n].c_float128) - snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "q"); - else - gcc_unreachable (); - } - else - { - snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name, - ts->type == BT_COMPLEX ? 'c' : 'r', - gfc_type_abi_kind (ts)); - } - - argtypes = NULL; - for (actual = expr->value.function.actual; actual; actual = actual->next) - { - type = gfc_typenode_for_spec (&actual->expr->ts); - vec_safe_push (argtypes, type); - } - type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes); - fndecl = build_decl (input_location, - FUNCTION_DECL, get_identifier (name), type); - - /* Mark the decl as external. */ - DECL_EXTERNAL (fndecl) = 1; - TREE_PUBLIC (fndecl) = 1; - - /* Mark it __attribute__((const)), if possible. */ - TREE_READONLY (fndecl) = m->is_constant; - - rest_of_decl_compilation (fndecl, 1, 0); - - (*pdecl) = fndecl; - return fndecl; -} - - -/* Convert an intrinsic function into an external or builtin call. */ - -static void -gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) -{ - gfc_intrinsic_map_t *m; - tree fndecl; - tree rettype; - tree *args; - unsigned int num_args; - gfc_isym_id id; - - id = expr->value.function.isym->id; - /* Find the entry for this function. */ - for (m = gfc_intrinsic_map; - m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) - { - if (id == m->id) - break; - } - - if (m->id == GFC_ISYM_NONE) - { - gfc_internal_error ("Intrinsic function %qs (%d) not recognized", - expr->value.function.name, id); - } - - /* Get the decl and generate the call. */ - num_args = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, num_args); - - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); - rettype = TREE_TYPE (TREE_TYPE (fndecl)); - - fndecl = build_addr (fndecl); - se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args); -} - - -/* If bounds-checking is enabled, create code to verify at runtime that the - string lengths for both expressions are the same (needed for e.g. MERGE). - If bounds-checking is not enabled, does nothing. */ - -void -gfc_trans_same_strlen_check (const char* intr_name, locus* where, - tree a, tree b, stmtblock_t* target) -{ - tree cond; - tree name; - - /* If bounds-checking is disabled, do nothing. */ - if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) - return; - - /* Compare the two string lengths. */ - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b); - - /* Output the runtime-check. */ - name = gfc_build_cstring_const (intr_name); - name = gfc_build_addr_expr (pchar_type_node, name); - gfc_trans_runtime_check (true, false, cond, target, where, - "Unequal character lengths (%ld/%ld) in %s", - fold_convert (long_integer_type_node, a), - fold_convert (long_integer_type_node, b), name); -} - - -/* The EXPONENT(X) intrinsic function is translated into - int ret; - return isfinite(X) ? (frexp (X, &ret) , ret) : huge - so that if X is a NaN or infinity, the result is HUGE(0). - */ - -static void -gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) -{ - tree arg, type, res, tmp, frexp, cond, huge; - int i; - - frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, - expr->value.function.actual->expr->ts.kind); - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - arg = gfc_evaluate_now (arg, &se->pre); - - i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false); - huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind); - cond = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISFINITE), - 1, arg); - - res = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr_loc (input_location, frexp, 2, arg, - gfc_build_addr_expr (NULL_TREE, res)); - tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node, - tmp, res); - se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node, - cond, tmp, huge); - - type = gfc_typenode_for_spec (&expr->ts); - se->expr = fold_convert (type, se->expr); -} - - -/* Fill in the following structure - struct caf_vector_t { - size_t nvec; // size of the vector - union { - struct { - void *vector; - int kind; - } v; - struct { - ptrdiff_t lower_bound; - ptrdiff_t upper_bound; - ptrdiff_t stride; - } triplet; - } u; - } */ - -static void -conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc, - tree lower, tree upper, tree stride, - tree vector, int kind, tree nvec) -{ - tree field, type, tmp; - - desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE); - type = TREE_TYPE (desc); - - field = gfc_advance_chain (TYPE_FIELDS (type), 0); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec)); - - /* Access union. */ - field = gfc_advance_chain (TYPE_FIELDS (type), 1); - desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - type = TREE_TYPE (desc); - - /* Access the inner struct. */ - field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1); - desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - type = TREE_TYPE (desc); - - if (vector != NULL_TREE) - { - /* Set vector and kind. */ - field = gfc_advance_chain (TYPE_FIELDS (type), 0); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector)); - field = gfc_advance_chain (TYPE_FIELDS (type), 1); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind)); - } - else - { - /* Set dim.lower/upper/stride. */ - field = gfc_advance_chain (TYPE_FIELDS (type), 0); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower)); - - field = gfc_advance_chain (TYPE_FIELDS (type), 1); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper)); - - field = gfc_advance_chain (TYPE_FIELDS (type), 2); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride)); - } -} - - -static tree -conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar) -{ - gfc_se argse; - tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec; - tree lbound, ubound, tmp; - int i; - - var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector"); - - for (i = 0; i < ar->dimen; i++) - switch (ar->dimen_type[i]) - { - case DIMEN_RANGE: - if (ar->end[i]) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, ar->end[i]); - gfc_add_block_to_block (block, &argse.pre); - upper = gfc_evaluate_now (argse.expr, block); - } - else - upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); - if (ar->stride[i]) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, ar->stride[i]); - gfc_add_block_to_block (block, &argse.pre); - stride = gfc_evaluate_now (argse.expr, block); - } - else - stride = gfc_index_one_node; - - /* Fall through. */ - case DIMEN_ELEMENT: - if (ar->start[i]) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, ar->start[i]); - gfc_add_block_to_block (block, &argse.pre); - lower = gfc_evaluate_now (argse.expr, block); - } - else - lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); - if (ar->dimen_type[i] == DIMEN_ELEMENT) - { - upper = lower; - stride = gfc_index_one_node; - } - vector = NULL_TREE; - nvec = size_zero_node; - conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, - vector, 0, nvec); - break; - - case DIMEN_VECTOR: - gfc_init_se (&argse, NULL); - argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, ar->start[i]); - gfc_add_block_to_block (block, &argse.pre); - vector = argse.expr; - lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]); - ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]); - nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL); - tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]); - nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - TREE_TYPE (nvec), nvec, tmp); - lower = gfc_index_zero_node; - upper = gfc_index_zero_node; - stride = gfc_index_zero_node; - vector = gfc_conv_descriptor_data_get (vector); - conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, - vector, ar->start[i]->ts.kind, nvec); - break; - default: - gcc_unreachable(); - } - return gfc_build_addr_expr (NULL_TREE, var); -} - - -static tree -compute_component_offset (tree field, tree type) -{ - tree tmp; - if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE - && !integer_zerop (DECL_FIELD_BIT_OFFSET (field))) - { - tmp = fold_build2 (TRUNC_DIV_EXPR, type, - DECL_FIELD_BIT_OFFSET (field), - bitsize_unit_node); - return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp); - } - else - return DECL_FIELD_OFFSET (field); -} - - -static tree -conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr) -{ - gfc_ref *ref = expr->ref, *last_comp_ref; - tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2, - field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type, - start, end, stride, vector, nvec; - gfc_se se; - bool ref_static_array = false; - tree last_component_ref_tree = NULL_TREE; - int i, last_type_n; - - if (expr->symtree) - { - last_component_ref_tree = expr->symtree->n.sym->backend_decl; - ref_static_array = !expr->symtree->n.sym->attr.allocatable - && !expr->symtree->n.sym->attr.pointer; - } - - /* Prevent uninit-warning. */ - reference_type = NULL_TREE; - - /* Skip refs upto the first coarray-ref. */ - last_comp_ref = NULL; - while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0)) - { - /* Remember the type of components skipped. */ - if (ref->type == REF_COMPONENT) - last_comp_ref = ref; - ref = ref->next; - } - /* When a component was skipped, get the type information of the last - component ref, else get the type from the symbol. */ - if (last_comp_ref) - { - last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts); - last_type_n = last_comp_ref->u.c.component->ts.type; - } - else - { - last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts); - last_type_n = expr->symtree->n.sym->ts.type; - } - - while (ref) - { - if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0 - && ref->u.ar.dimen == 0) - { - /* Skip pure coindexes. */ - ref = ref->next; - continue; - } - tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref"); - reference_type = TREE_TYPE (tmp); - - if (caf_ref == NULL_TREE) - caf_ref = tmp; - - /* Construct the chain of refs. */ - if (prev_caf_ref != NULL_TREE) - { - field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0); - tmp2 = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), prev_caf_ref, field, - NULL_TREE); - gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field), - tmp)); - } - prev_caf_ref = tmp; - - switch (ref->type) - { - case REF_COMPONENT: - last_type = gfc_typenode_for_spec (&ref->u.c.component->ts); - last_type_n = ref->u.c.component->ts.type; - /* Set the type of the ref. */ - field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), prev_caf_ref, field, - NULL_TREE); - gfc_add_modify (block, tmp, build_int_cst (integer_type_node, - GFC_CAF_REF_COMPONENT)); - - /* Ref the c in union u. */ - field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), prev_caf_ref, field, - NULL_TREE); - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0); - inner_struct = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - - /* Set the offset. */ - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), inner_struct, field, - NULL_TREE); - /* Computing the offset is somewhat harder. The bit_offset has to be - taken into account. When the bit_offset in the field_decl is non- - null, divide it by the bitsize_unit and add it to the regular - offset. */ - tmp2 = compute_component_offset (ref->u.c.component->backend_decl, - TREE_TYPE (tmp)); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); - - /* Set caf_token_offset. */ - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), inner_struct, field, - NULL_TREE); - if ((ref->u.c.component->attr.allocatable - || ref->u.c.component->attr.pointer) - && ref->u.c.component->attr.dimension) - { - tree arr_desc_token_offset; - /* Get the token field from the descriptor. */ - arr_desc_token_offset = TREE_OPERAND ( - gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1); - arr_desc_token_offset - = compute_component_offset (arr_desc_token_offset, - TREE_TYPE (tmp)); - tmp2 = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (tmp2), tmp2, - arr_desc_token_offset); - } - else if (ref->u.c.component->caf_token) - tmp2 = compute_component_offset (ref->u.c.component->caf_token, - TREE_TYPE (tmp)); - else - tmp2 = integer_zero_node; - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); - - /* Remember whether this ref was to a non-allocatable/non-pointer - component so the next array ref can be tailored correctly. */ - ref_static_array = !ref->u.c.component->attr.allocatable - && !ref->u.c.component->attr.pointer; - last_component_ref_tree = ref_static_array - ? ref->u.c.component->backend_decl : NULL_TREE; - break; - case REF_ARRAY: - if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED) - ref_static_array = false; - /* Set the type of the ref. */ - field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), prev_caf_ref, field, - NULL_TREE); - gfc_add_modify (block, tmp, build_int_cst (integer_type_node, - ref_static_array - ? GFC_CAF_REF_STATIC_ARRAY - : GFC_CAF_REF_ARRAY)); - - /* Ref the a in union u. */ - field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), prev_caf_ref, field, - NULL_TREE); - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1); - inner_struct = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - - /* Set the static_array_type in a for static arrays. */ - if (ref_static_array) - { - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), - 1); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), inner_struct, field, - NULL_TREE); - gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp), - last_type_n)); - } - /* Ref the mode in the inner_struct. */ - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0); - mode = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), inner_struct, field, - NULL_TREE); - /* Ref the dim in the inner_struct. */ - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2); - dim_array = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), inner_struct, field, - NULL_TREE); - for (i = 0; i < ref->u.ar.dimen; ++i) - { - /* Ref dim i. */ - dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE); - dim_type = TREE_TYPE (dim); - mode_rhs = start = end = stride = NULL_TREE; - switch (ref->u.ar.dimen_type[i]) - { - case DIMEN_RANGE: - if (ref->u.ar.end[i]) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, ref->u.ar.end[i]); - gfc_add_block_to_block (block, &se.pre); - if (ref_static_array) - { - /* Make the index zero-based, when reffing a static - array. */ - end = se.expr; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, ref->u.ar.as->lower[i]); - gfc_add_block_to_block (block, &se.pre); - se.expr = fold_build2 (MINUS_EXPR, - gfc_array_index_type, - end, fold_convert ( - gfc_array_index_type, - se.expr)); - } - end = gfc_evaluate_now (fold_convert ( - gfc_array_index_type, - se.expr), - block); - } - else if (ref_static_array) - end = fold_build2 (MINUS_EXPR, - gfc_array_index_type, - gfc_conv_array_ubound ( - last_component_ref_tree, i), - gfc_conv_array_lbound ( - last_component_ref_tree, i)); - else - { - end = NULL_TREE; - mode_rhs = build_int_cst (unsigned_char_type_node, - GFC_CAF_ARR_REF_OPEN_END); - } - if (ref->u.ar.stride[i]) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, ref->u.ar.stride[i]); - gfc_add_block_to_block (block, &se.pre); - stride = gfc_evaluate_now (fold_convert ( - gfc_array_index_type, - se.expr), - block); - if (ref_static_array) - { - /* Make the index zero-based, when reffing a static - array. */ - stride = fold_build2 (MULT_EXPR, - gfc_array_index_type, - gfc_conv_array_stride ( - last_component_ref_tree, - i), - stride); - gcc_assert (end != NULL_TREE); - /* Multiply with the product of array's stride and - the step of the ref to a virtual upper bound. - We cannot compute the actual upper bound here or - the caflib would compute the extend - incorrectly. */ - end = fold_build2 (MULT_EXPR, gfc_array_index_type, - end, gfc_conv_array_stride ( - last_component_ref_tree, - i)); - end = gfc_evaluate_now (end, block); - stride = gfc_evaluate_now (stride, block); - } - } - else if (ref_static_array) - { - stride = gfc_conv_array_stride (last_component_ref_tree, - i); - end = fold_build2 (MULT_EXPR, gfc_array_index_type, - end, stride); - end = gfc_evaluate_now (end, block); - } - else - /* Always set a ref stride of one to make caflib's - handling easier. */ - stride = gfc_index_one_node; - - /* Fall through. */ - case DIMEN_ELEMENT: - if (ref->u.ar.start[i]) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, ref->u.ar.start[i]); - gfc_add_block_to_block (block, &se.pre); - if (ref_static_array) - { - /* Make the index zero-based, when reffing a static - array. */ - start = fold_convert (gfc_array_index_type, se.expr); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, ref->u.ar.as->lower[i]); - gfc_add_block_to_block (block, &se.pre); - se.expr = fold_build2 (MINUS_EXPR, - gfc_array_index_type, - start, fold_convert ( - gfc_array_index_type, - se.expr)); - /* Multiply with the stride. */ - se.expr = fold_build2 (MULT_EXPR, - gfc_array_index_type, - se.expr, - gfc_conv_array_stride ( - last_component_ref_tree, - i)); - } - start = gfc_evaluate_now (fold_convert ( - gfc_array_index_type, - se.expr), - block); - if (mode_rhs == NULL_TREE) - mode_rhs = build_int_cst (unsigned_char_type_node, - ref->u.ar.dimen_type[i] - == DIMEN_ELEMENT - ? GFC_CAF_ARR_REF_SINGLE - : GFC_CAF_ARR_REF_RANGE); - } - else if (ref_static_array) - { - start = integer_zero_node; - mode_rhs = build_int_cst (unsigned_char_type_node, - ref->u.ar.start[i] == NULL - ? GFC_CAF_ARR_REF_FULL - : GFC_CAF_ARR_REF_RANGE); - } - else if (end == NULL_TREE) - mode_rhs = build_int_cst (unsigned_char_type_node, - GFC_CAF_ARR_REF_FULL); - else - mode_rhs = build_int_cst (unsigned_char_type_node, - GFC_CAF_ARR_REF_OPEN_START); - - /* Ref the s in dim. */ - field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), dim, field, - NULL_TREE); - - /* Set start in s. */ - if (start != NULL_TREE) - { - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), - 0); - tmp2 = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - gfc_add_modify (block, tmp2, - fold_convert (TREE_TYPE (tmp2), start)); - } - - /* Set end in s. */ - if (end != NULL_TREE) - { - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), - 1); - tmp2 = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - gfc_add_modify (block, tmp2, - fold_convert (TREE_TYPE (tmp2), end)); - } - - /* Set end in s. */ - if (stride != NULL_TREE) - { - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), - 2); - tmp2 = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - gfc_add_modify (block, tmp2, - fold_convert (TREE_TYPE (tmp2), stride)); - } - break; - case DIMEN_VECTOR: - /* TODO: In case of static array. */ - gcc_assert (!ref_static_array); - mode_rhs = build_int_cst (unsigned_char_type_node, - GFC_CAF_ARR_REF_VECTOR); - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]); - gfc_add_block_to_block (block, &se.pre); - vector = se.expr; - tmp = gfc_conv_descriptor_lbound_get (vector, - gfc_rank_cst[0]); - tmp2 = gfc_conv_descriptor_ubound_get (vector, - gfc_rank_cst[0]); - nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL); - tmp = gfc_conv_descriptor_stride_get (vector, - gfc_rank_cst[0]); - nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - TREE_TYPE (nvec), nvec, tmp); - vector = gfc_conv_descriptor_data_get (vector); - - /* Ref the v in dim. */ - field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), dim, field, - NULL_TREE); - - /* Set vector in v. */ - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0); - tmp2 = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2), - vector)); - - /* Set nvec in v. */ - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1); - tmp2 = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2), - nvec)); - - /* Set kind in v. */ - field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2); - tmp2 = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (field), tmp, field, - NULL_TREE); - gfc_add_modify (block, tmp2, build_int_cst (integer_type_node, - ref->u.ar.start[i]->ts.kind)); - break; - default: - gcc_unreachable (); - } - /* Set the mode for dim i. */ - tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), - mode_rhs)); - } - - /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */ - if (i < GFC_MAX_DIMENSIONS) - { - tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE); - gfc_add_modify (block, tmp, - build_int_cst (unsigned_char_type_node, - GFC_CAF_ARR_REF_NONE)); - } - break; - default: - gcc_unreachable (); - } - - /* Set the size of the current type. */ - field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - prev_caf_ref, field, NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), - TYPE_SIZE_UNIT (last_type))); - - ref = ref->next; - } - - if (prev_caf_ref != NULL_TREE) - { - field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - prev_caf_ref, field, NULL_TREE); - gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), - null_pointer_node)); - } - return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref) - : NULL_TREE; -} - -/* Get data from a remote coarray. */ - -static void -gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, - tree may_require_tmp, bool may_realloc, - symbol_attribute *caf_attr) -{ - gfc_expr *array_expr, *tmp_stat; - gfc_se argse; - tree caf_decl, token, offset, image_index, tmp; - tree res_var, dst_var, type, kind, vec, stat; - tree caf_reference; - symbol_attribute caf_attr_store; - - gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); - - if (se->ss && se->ss->info->useflags) - { - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - return; - } - - /* If lhs is set, the CAF_GET intrinsic has already been stripped. */ - array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr; - type = gfc_typenode_for_spec (&array_expr->ts); - - if (caf_attr == NULL) - { - caf_attr_store = gfc_caf_attr (array_expr); - caf_attr = &caf_attr_store; - } - - res_var = lhs; - dst_var = lhs; - - vec = null_pointer_node; - tmp_stat = gfc_find_stat_co (expr); - - if (tmp_stat) - { - gfc_se stat_se; - gfc_init_se (&stat_se, NULL); - gfc_conv_expr_reference (&stat_se, tmp_stat); - stat = stat_se.expr; - gfc_add_block_to_block (&se->pre, &stat_se.pre); - gfc_add_block_to_block (&se->post, &stat_se.post); - } - else - stat = null_pointer_node; - - /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs - is reallocatable or the right-hand side has allocatable components. */ - if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc) - { - /* Get using caf_get_by_ref. */ - caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr); - - if (caf_reference != NULL_TREE) - { - if (lhs == NULL_TREE) - { - if (array_expr->ts.type == BT_CHARACTER) - gfc_init_se (&argse, NULL); - if (array_expr->rank == 0) - { - symbol_attribute attr; - gfc_clear_attr (&attr); - if (array_expr->ts.type == BT_CHARACTER) - { - res_var = gfc_conv_string_tmp (se, - build_pointer_type (type), - array_expr->ts.u.cl->backend_decl); - argse.string_length = array_expr->ts.u.cl->backend_decl; - } - else - res_var = gfc_create_var (type, "caf_res"); - dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr); - dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); - } - else - { - /* Create temporary. */ - if (array_expr->ts.type == BT_CHARACTER) - gfc_conv_expr_descriptor (&argse, array_expr); - may_realloc = gfc_trans_create_temp_array (&se->pre, - &se->post, - se->ss, type, - NULL_TREE, false, - false, false, - &array_expr->where) - == NULL_TREE; - res_var = se->ss->info->data.array.descriptor; - dst_var = gfc_build_addr_expr (NULL_TREE, res_var); - if (may_realloc) - { - tmp = gfc_conv_descriptor_data_get (res_var); - 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->post, tmp); - } - } - } - - kind = build_int_cst (integer_type_node, expr->ts.kind); - if (lhs_kind == NULL_TREE) - lhs_kind = kind; - - caf_decl = gfc_get_tree_for_caf_expr (array_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - image_index = gfc_caf_get_image_index (&se->pre, array_expr, - caf_decl); - gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, - array_expr); - - /* No overlap possible as we have generated a temporary. */ - if (lhs == NULL_TREE) - may_require_tmp = boolean_false_node; - - /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, - NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&se->pre, tmp); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref, - 10, token, image_index, dst_var, - caf_reference, lhs_kind, kind, - may_require_tmp, - may_realloc ? boolean_true_node : - boolean_false_node, - stat, build_int_cst (integer_type_node, - array_expr->ts.type)); - - gfc_add_expr_to_block (&se->pre, tmp); - - if (se->ss) - gfc_advance_se_ss_chain (se); - - se->expr = res_var; - if (array_expr->ts.type == BT_CHARACTER) - se->string_length = argse.string_length; - - return; - } - } - - gfc_init_se (&argse, NULL); - if (array_expr->rank == 0) - { - symbol_attribute attr; - - gfc_clear_attr (&attr); - gfc_conv_expr (&argse, array_expr); - - if (lhs == NULL_TREE) - { - gfc_clear_attr (&attr); - if (array_expr->ts.type == BT_CHARACTER) - res_var = gfc_conv_string_tmp (se, build_pointer_type (type), - argse.string_length); - else - res_var = gfc_create_var (type, "caf_res"); - dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr); - dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); - } - argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); - argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); - } - else - { - /* If has_vector, pass descriptor for whole array and the - vector bounds separately. */ - gfc_array_ref *ar, ar2; - bool has_vector = false; - - if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr)) - { - has_vector = true; - ar = gfc_find_array_ref (expr); - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; - } - // TODO: Check whether argse.want_coarray = 1 can help with the below. - gfc_conv_expr_descriptor (&argse, array_expr); - /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that - has the wrong type if component references are done. */ - gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : array_expr->rank, - type)); - if (has_vector) - { - vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2); - *ar = ar2; - } - - if (lhs == NULL_TREE) - { - /* Create temporary. */ - for (int n = 0; n < se->ss->loop->dimen; n++) - if (se->loop->to[n] == NULL_TREE) - { - se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr, - gfc_rank_cst[n]); - se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr, - gfc_rank_cst[n]); - } - gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type, - NULL_TREE, false, true, false, - &array_expr->where); - res_var = se->ss->info->data.array.descriptor; - dst_var = gfc_build_addr_expr (NULL_TREE, res_var); - } - argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); - } - - kind = build_int_cst (integer_type_node, expr->ts.kind); - if (lhs_kind == NULL_TREE) - lhs_kind = kind; - - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - - caf_decl = gfc_get_tree_for_caf_expr (array_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl); - gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr, - array_expr); - - /* No overlap possible as we have generated a temporary. */ - if (lhs == NULL_TREE) - may_require_tmp = boolean_false_node; - - /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&se->pre, tmp); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10, - token, offset, image_index, argse.expr, vec, - dst_var, kind, lhs_kind, may_require_tmp, stat); - - gfc_add_expr_to_block (&se->pre, tmp); - - if (se->ss) - gfc_advance_se_ss_chain (se); - - se->expr = res_var; - if (array_expr->ts.type == BT_CHARACTER) - se->string_length = argse.string_length; -} - - -/* Send data to a remote coarray. */ - -static tree -conv_caf_send (gfc_code *code) { - gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team; - gfc_se lhs_se, rhs_se; - stmtblock_t block; - tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; - tree may_require_tmp, src_stat, dst_stat, dst_team; - tree lhs_type = NULL_TREE; - tree vec = null_pointer_node, rhs_vec = null_pointer_node; - symbol_attribute lhs_caf_attr, rhs_caf_attr; - - gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); - - lhs_expr = code->ext.actual->expr; - rhs_expr = code->ext.actual->next->expr; - may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0 - ? boolean_false_node : boolean_true_node; - gfc_init_block (&block); - - lhs_caf_attr = gfc_caf_attr (lhs_expr); - rhs_caf_attr = gfc_caf_attr (rhs_expr); - src_stat = dst_stat = null_pointer_node; - dst_team = null_pointer_node; - - /* LHS. */ - gfc_init_se (&lhs_se, NULL); - if (lhs_expr->rank == 0) - { - if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred) - { - lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr); - lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); - } - else - { - symbol_attribute attr; - gfc_clear_attr (&attr); - gfc_conv_expr (&lhs_se, lhs_expr); - lhs_type = TREE_TYPE (lhs_se.expr); - lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, - attr); - lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); - } - } - else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp) - && lhs_caf_attr.codimension) - { - lhs_se.want_pointer = 1; - gfc_conv_expr_descriptor (&lhs_se, lhs_expr); - /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that - has the wrong type if component references are done. */ - lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); - tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); - gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), - gfc_get_dtype_rank_type ( - gfc_has_vector_subscript (lhs_expr) - ? gfc_find_array_ref (lhs_expr)->dimen - : lhs_expr->rank, - lhs_type)); - } - else - { - bool has_vector = gfc_has_vector_subscript (lhs_expr); - - if (gfc_is_coindexed (lhs_expr) || !has_vector) - { - /* If has_vector, pass descriptor for whole array and the - vector bounds separately. */ - gfc_array_ref *ar, ar2; - bool has_tmp_lhs_array = false; - if (has_vector) - { - has_tmp_lhs_array = true; - ar = gfc_find_array_ref (lhs_expr); - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; - } - lhs_se.want_pointer = 1; - gfc_conv_expr_descriptor (&lhs_se, lhs_expr); - /* Using gfc_conv_expr_descriptor, we only get the descriptor, but - that has the wrong type if component references are done. */ - lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); - tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); - gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : lhs_expr->rank, - lhs_type)); - if (has_tmp_lhs_array) - { - vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2); - *ar = ar2; - } - } - else - { - /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to - indexed array expression. This is rewritten to: - - tmp_array = arr2[...] - arr1 ([...]) = tmp_array - - because using the standard gfc_conv_expr (lhs_expr) did the - assignment with lhs and rhs exchanged. */ - - gfc_ss *lss_for_tmparray, *lss_real; - gfc_loopinfo loop; - gfc_se se; - stmtblock_t body; - tree tmparr_desc, src; - tree index = gfc_index_zero_node; - tree stride = gfc_index_zero_node; - int n; - - /* Walk both sides of the assignment, once to get the shape of the - temporary array to create right. */ - lss_for_tmparray = gfc_walk_expr (lhs_expr); - /* And a second time to be able to create an assignment of the - temporary to the lhs_expr. gfc_trans_create_temp_array replaces - the tree in the descriptor with the one for the temporary - array. */ - lss_real = gfc_walk_expr (lhs_expr); - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, lss_for_tmparray); - gfc_add_ss_to_loop (&loop, lss_real); - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &lhs_expr->where); - lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); - gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post, - lss_for_tmparray, lhs_type, NULL_TREE, - false, true, false, - &lhs_expr->where); - tmparr_desc = lss_for_tmparray->info->data.array.descriptor; - gfc_start_scalarized_body (&loop, &body); - gfc_init_se (&se, NULL); - gfc_copy_loopinfo_to_se (&se, &loop); - se.ss = lss_real; - gfc_conv_expr (&se, lhs_expr); - gfc_add_block_to_block (&body, &se.pre); - - /* Walk over all indexes of the loop. */ - for (n = loop.dimen - 1; n > 0; --n) - { - tmp = loop.loopvar[n]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, loop.from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, index); - - stride = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop.to[n - 1], loop.from[n - 1]); - stride = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - stride, gfc_index_one_node); - - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, stride); - } - - index = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - index, loop.from[0]); - - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - loop.loopvar[0], index); - - src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc)); - src = gfc_build_array_ref (src, index, NULL); - /* Now create the assignment of lhs_expr = tmp_array. */ - gfc_add_modify (&body, se.expr, src); - gfc_add_block_to_block (&body, &se.post); - lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc); - gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&loop.pre, &loop.post); - gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre)); - gfc_free_ss (lss_for_tmparray); - gfc_free_ss (lss_real); - } - } - - lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind); - - /* Special case: RHS is a coarray but LHS is not; this code path avoids a - temporary and a loop. */ - if (!gfc_is_coindexed (lhs_expr) - && (!lhs_caf_attr.codimension - || !(lhs_expr->rank > 0 - && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer)))) - { - bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable; - gcc_assert (gfc_is_coindexed (rhs_expr)); - gfc_init_se (&rhs_se, NULL); - if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable) - { - gfc_se scal_se; - gfc_init_se (&scal_se, NULL); - scal_se.want_pointer = 1; - gfc_conv_expr (&scal_se, lhs_expr); - /* Ensure scalar on lhs is allocated. */ - gfc_add_block_to_block (&block, &scal_se.pre); - - gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr, - TYPE_SIZE_UNIT ( - gfc_typenode_for_spec (&lhs_expr->ts)), - NULL_TREE); - tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr, - null_pointer_node); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - tmp, gfc_finish_block (&scal_se.pre), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - else - lhs_may_realloc = lhs_may_realloc - && gfc_full_array_ref_p (lhs_expr->ref, NULL); - gfc_add_block_to_block (&block, &lhs_se.pre); - gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind, - may_require_tmp, lhs_may_realloc, - &rhs_caf_attr); - gfc_add_block_to_block (&block, &rhs_se.pre); - gfc_add_block_to_block (&block, &rhs_se.post); - gfc_add_block_to_block (&block, &lhs_se.post); - return gfc_finish_block (&block); - } - - gfc_add_block_to_block (&block, &lhs_se.pre); - - /* Obtain token, offset and image index for the LHS. */ - caf_decl = gfc_get_tree_for_caf_expr (lhs_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl); - tmp = lhs_se.expr; - if (lhs_caf_attr.alloc_comp) - gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE, - NULL); - else - gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp, - lhs_expr); - lhs_se.expr = tmp; - - /* RHS. */ - gfc_init_se (&rhs_se, NULL); - if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym - && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION) - rhs_expr = rhs_expr->value.function.actual->expr; - if (rhs_expr->rank == 0) - { - symbol_attribute attr; - gfc_clear_attr (&attr); - gfc_conv_expr (&rhs_se, rhs_expr); - rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr); - rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr); - } - else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp) - && rhs_caf_attr.codimension) - { - tree tmp2; - rhs_se.want_pointer = 1; - gfc_conv_expr_descriptor (&rhs_se, rhs_expr); - /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that - has the wrong type if component references are done. */ - tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); - tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); - gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), - gfc_get_dtype_rank_type ( - gfc_has_vector_subscript (rhs_expr) - ? gfc_find_array_ref (rhs_expr)->dimen - : rhs_expr->rank, - tmp2)); - } - else - { - /* If has_vector, pass descriptor for whole array and the - vector bounds separately. */ - gfc_array_ref *ar, ar2; - bool has_vector = false; - tree tmp2; - - if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr)) - { - has_vector = true; - ar = gfc_find_array_ref (rhs_expr); - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; - } - rhs_se.want_pointer = 1; - gfc_conv_expr_descriptor (&rhs_se, rhs_expr); - /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that - has the wrong type if component references are done. */ - tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); - tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); - gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : rhs_expr->rank, - tmp2)); - if (has_vector) - { - rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2); - *ar = ar2; - } - } - - gfc_add_block_to_block (&block, &rhs_se.pre); - - rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind); - - tmp_stat = gfc_find_stat_co (lhs_expr); - - if (tmp_stat) - { - gfc_se stat_se; - gfc_init_se (&stat_se, NULL); - gfc_conv_expr_reference (&stat_se, tmp_stat); - dst_stat = stat_se.expr; - gfc_add_block_to_block (&block, &stat_se.pre); - gfc_add_block_to_block (&block, &stat_se.post); - } - - tmp_team = gfc_find_team_co (lhs_expr); - - if (tmp_team) - { - gfc_se team_se; - gfc_init_se (&team_se, NULL); - gfc_conv_expr_reference (&team_se, tmp_team); - dst_team = team_se.expr; - gfc_add_block_to_block (&block, &team_se.pre); - gfc_add_block_to_block (&block, &team_se.post); - } - - if (!gfc_is_coindexed (rhs_expr)) - { - if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp) - { - tree reference, dst_realloc; - reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); - dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node - : boolean_false_node; - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_send_by_ref, - 10, token, image_index, rhs_se.expr, - reference, lhs_kind, rhs_kind, - may_require_tmp, dst_realloc, src_stat, - build_int_cst (integer_type_node, - lhs_expr->ts.type)); - } - else - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11, - token, offset, image_index, lhs_se.expr, vec, - rhs_se.expr, lhs_kind, rhs_kind, - may_require_tmp, src_stat, dst_team); - } - else - { - tree rhs_token, rhs_offset, rhs_image_index; - - /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&block, tmp); - - caf_decl = gfc_get_tree_for_caf_expr (rhs_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl); - tmp = rhs_se.expr; - if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp) - { - tmp_stat = gfc_find_stat_co (lhs_expr); - - if (tmp_stat) - { - gfc_se stat_se; - gfc_init_se (&stat_se, NULL); - gfc_conv_expr_reference (&stat_se, tmp_stat); - src_stat = stat_se.expr; - gfc_add_block_to_block (&block, &stat_se.pre); - gfc_add_block_to_block (&block, &stat_se.post); - } - - gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl, - NULL_TREE, NULL); - tree lhs_reference, rhs_reference; - lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); - rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sendget_by_ref, 13, - token, image_index, lhs_reference, - rhs_token, rhs_image_index, rhs_reference, - lhs_kind, rhs_kind, may_require_tmp, - dst_stat, src_stat, - build_int_cst (integer_type_node, - lhs_expr->ts.type), - build_int_cst (integer_type_node, - rhs_expr->ts.type)); - } - else - { - gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl, - tmp, rhs_expr); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, - 14, token, offset, image_index, - lhs_se.expr, vec, rhs_token, rhs_offset, - rhs_image_index, tmp, rhs_vec, lhs_kind, - rhs_kind, may_require_tmp, src_stat); - } - } - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &lhs_se.post); - gfc_add_block_to_block (&block, &rhs_se.post); - - /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -static void -trans_this_image (gfc_se * se, gfc_expr *expr) -{ - stmtblock_t loop; - tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, - lbound, ubound, extent, ml; - gfc_se argse; - int rank, corank; - gfc_expr *distance = expr->value.function.actual->next->next->expr; - - if (expr->value.function.actual->expr - && !gfc_is_coarray (expr->value.function.actual->expr)) - distance = expr->value.function.actual->expr; - - /* The case -fcoarray=single is handled elsewhere. */ - gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE); - - /* Argument-free version: THIS_IMAGE(). */ - if (distance || expr->value.function.actual->expr == NULL) - { - if (distance) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, distance); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - tmp = fold_convert (integer_type_node, argse.expr); - } - else - tmp = integer_zero_node; - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - tmp); - se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), - tmp); - return; - } - - /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */ - - type = gfc_get_int_type (gfc_default_integer_kind); - corank = gfc_get_corank (expr->value.function.actual->expr); - rank = expr->value.function.actual->expr->rank; - - /* Obtain the descriptor of the COARRAY. */ - gfc_init_se (&argse, NULL); - argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - desc = argse.expr; - - if (se->ss) - { - /* Create an implicit second parameter from the loop variable. */ - gcc_assert (!expr->value.function.actual->next->expr); - gcc_assert (corank > 0); - gcc_assert (se->loop->dimen == 1); - gcc_assert (se->ss->info->expr == expr); - - dim_arg = se->loop->loopvar[0]; - dim_arg = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, dim_arg, - build_int_cst (TREE_TYPE (dim_arg), 1)); - gfc_advance_se_ss_chain (se); - } - else - { - /* Use the passed DIM= argument. */ - gcc_assert (expr->value.function.actual->next->expr); - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr, - gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &argse.pre); - dim_arg = argse.expr; - - if (INTEGER_CST_P (dim_arg)) - { - if (wi::ltu_p (wi::to_wide (dim_arg), 1) - || wi::gtu_p (wi::to_wide (dim_arg), - GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))) - gfc_error ("% argument of %s intrinsic at %L is not a valid " - "dimension index", expr->value.function.isym->name, - &expr->where); - } - else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - dim_arg = gfc_evaluate_now (dim_arg, &se->pre); - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - dim_arg, - build_int_cst (TREE_TYPE (dim_arg), 1)); - tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; - tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - dim_arg, tmp); - cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, cond, tmp); - gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, - gfc_msg_fault); - } - } - - /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer, - one always has a dim_arg argument. - - m = this_image() - 1 - if (corank == 1) - { - sub(1) = m + lcobound(corank) - return; - } - i = rank - min_var = min (rank + corank - 2, rank + dim_arg - 1) - for (;;) - { - extent = gfc_extent(i) - ml = m - m = m/extent - if (i >= min_var) - goto exit_label - i++ - } - exit_label: - sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg) - : m + lcobound(corank) - */ - - /* this_image () - 1. */ - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - integer_zero_node); - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, - fold_convert (type, tmp), build_int_cst (type, 1)); - if (corank == 1) - { - /* sub(1) = m + lcobound(corank). */ - lbound = gfc_conv_descriptor_lbound_get (desc, - build_int_cst (TREE_TYPE (gfc_array_index_type), - corank+rank-1)); - lbound = fold_convert (type, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound); - - se->expr = tmp; - return; - } - - m = gfc_create_var (type, NULL); - ml = gfc_create_var (type, NULL); - loop_var = gfc_create_var (integer_type_node, NULL); - min_var = gfc_create_var (integer_type_node, NULL); - - /* m = this_image () - 1. */ - gfc_add_modify (&se->pre, m, tmp); - - /* min_var = min (rank + corank-2, rank + dim_arg - 1). */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - fold_convert (integer_type_node, dim_arg), - build_int_cst (integer_type_node, rank - 1)); - tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node, - build_int_cst (integer_type_node, rank + corank - 2), - tmp); - gfc_add_modify (&se->pre, min_var, tmp); - - /* i = rank. */ - tmp = build_int_cst (integer_type_node, rank); - gfc_add_modify (&se->pre, loop_var, tmp); - - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - - /* Loop body. */ - gfc_init_block (&loop); - - /* ml = m. */ - gfc_add_modify (&loop, ml, m); - - /* extent = ... */ - lbound = gfc_conv_descriptor_lbound_get (desc, loop_var); - ubound = gfc_conv_descriptor_ubound_get (desc, loop_var); - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); - extent = fold_convert (type, extent); - - /* m = m/extent. */ - gfc_add_modify (&loop, m, - fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, - m, extent)); - - /* Exit condition: if (i >= min_var) goto exit_label. */ - cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var, - min_var); - 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); - - /* Increment loop variable: i++. */ - gfc_add_modify (&loop, loop_var, - fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, - loop_var, - build_int_cst (integer_type_node, 1))); - - /* Making the loop... actually loop! */ - tmp = gfc_finish_block (&loop); - tmp = build1_v (LOOP_EXPR, tmp); - gfc_add_expr_to_block (&se->pre, tmp); - - /* The exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&se->pre, tmp); - - /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg) - : m + lcobound(corank) */ - - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg, - build_int_cst (TREE_TYPE (dim_arg), corank)); - - lbound = gfc_conv_descriptor_lbound_get (desc, - fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, dim_arg, - build_int_cst (TREE_TYPE (dim_arg), rank-1))); - lbound = fold_convert (type, lbound); - - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml, - fold_build2_loc (input_location, MULT_EXPR, type, - m, extent)); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound); - - se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp, - fold_build2_loc (input_location, PLUS_EXPR, type, - m, lbound)); -} - - -/* Convert a call to image_status. */ - -static void -conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) -{ - unsigned int num_args; - tree *args, tmp; - - num_args = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, num_args); - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - /* In args[0] the number of the image the status is desired for has to be - given. */ - - if (flag_coarray == GFC_FCOARRAY_SINGLE) - { - tree arg; - arg = gfc_evaluate_now (args[0], &se->pre); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - fold_convert (integer_type_node, arg), - integer_one_node); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, - tmp, integer_zero_node, - build_int_cst (integer_type_node, - GFC_STAT_STOPPED_IMAGE)); - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2, - args[0], build_int_cst (integer_type_node, -1)); - else - gcc_unreachable (); - - se->expr = tmp; -} - -static void -conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) -{ - unsigned int num_args; - - tree *args, tmp; - - num_args = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, num_args); - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - - if (flag_coarray == - GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr) - { - tree arg; - - arg = gfc_evaluate_now (args[0], &se->pre); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - fold_convert (integer_type_node, arg), - integer_one_node); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, - tmp, integer_zero_node, - build_int_cst (integer_type_node, - GFC_STAT_STOPPED_IMAGE)); - } - else if (flag_coarray == GFC_FCOARRAY_SINGLE) - { - // the value -1 represents that no team has been created yet - tmp = build_int_cst (integer_type_node, -1); - } - else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - args[0], build_int_cst (integer_type_node, -1)); - else if (flag_coarray == GFC_FCOARRAY_LIB) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - integer_zero_node, build_int_cst (integer_type_node, -1)); - else - gcc_unreachable (); - - se->expr = tmp; -} - - -static void -trans_image_index (gfc_se * se, gfc_expr *expr) -{ - tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, - tmp, invalid_bound; - gfc_se argse, subse; - int rank, corank, codim; - - type = gfc_get_int_type (gfc_default_integer_kind); - corank = gfc_get_corank (expr->value.function.actual->expr); - rank = expr->value.function.actual->expr->rank; - - /* Obtain the descriptor of the COARRAY. */ - gfc_init_se (&argse, NULL); - argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - desc = argse.expr; - - /* Obtain a handle to the SUB argument. */ - gfc_init_se (&subse, NULL); - gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr); - gfc_add_block_to_block (&se->pre, &subse.pre); - gfc_add_block_to_block (&se->post, &subse.post); - subdesc = build_fold_indirect_ref_loc (input_location, - gfc_conv_descriptor_data_get (subse.expr)); - - /* Fortran 2008 does not require that the values remain in the cobounds, - thus we need explicitly check this - and return 0 if they are exceeded. */ - - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); - tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL); - invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - fold_convert (gfc_array_index_type, tmp), - lbound); - - for (codim = corank + rank - 2; codim >= rank; codim--) - { - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); - tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - fold_convert (gfc_array_index_type, tmp), - lbound); - invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, invalid_bound, cond); - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - fold_convert (gfc_array_index_type, tmp), - ubound); - invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, invalid_bound, cond); - } - - invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND); - - /* See Fortran 2008, C.10 for the following algorithm. */ - - /* coindex = sub(corank) - lcobound(n). */ - coindex = fold_convert (gfc_array_index_type, - gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], - NULL)); - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); - coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - fold_convert (gfc_array_index_type, coindex), - lbound); - - for (codim = corank + rank - 2; codim >= rank; codim--) - { - tree extent, ubound; - - /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */ - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); - ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); - extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); - - /* coindex *= extent. */ - coindex = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, coindex, extent); - - /* coindex += sub(codim). */ - tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); - coindex = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, coindex, - fold_convert (gfc_array_index_type, tmp)); - - /* coindex -= lbound(codim). */ - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); - coindex = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, coindex, lbound); - } - - coindex = fold_build2_loc (input_location, PLUS_EXPR, type, - fold_convert(type, coindex), - build_int_cst (type, 1)); - - /* Return 0 if "coindex" exceeds num_images(). */ - - if (flag_coarray == GFC_FCOARRAY_SINGLE) - num_images = build_int_cst (type, 1); - else - { - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - integer_zero_node, - build_int_cst (integer_type_node, -1)); - num_images = fold_convert (type, tmp); - } - - tmp = gfc_create_var (type, NULL); - gfc_add_modify (&se->pre, tmp, coindex); - - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp, - num_images); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, - cond, - fold_convert (logical_type_node, invalid_bound)); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, - build_int_cst (type, 0), tmp); -} - -static void -trans_num_images (gfc_se * se, gfc_expr *expr) -{ - tree tmp, distance, failed; - gfc_se argse; - - if (expr->value.function.actual->expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, expr->value.function.actual->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - distance = fold_convert (integer_type_node, argse.expr); - } - else - distance = integer_zero_node; - - if (expr->value.function.actual->next->expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - failed = fold_convert (integer_type_node, argse.expr); - } - else - failed = build_int_cst (integer_type_node, -1); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - distance, failed); - se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); -} - - -static void -gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) -{ - gfc_se argse; - - gfc_init_se (&argse, NULL); - argse.data_not_needed = 1; - argse.descriptor_only = 1; - - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - - se->expr = gfc_conv_descriptor_rank (argse.expr); - se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), - se->expr); -} - - -static void -gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr) -{ - gfc_expr *arg; - arg = expr->value.function.actual->expr; - gfc_conv_is_contiguous_expr (se, arg); - se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - -/* This function does the work for gfc_conv_intrinsic_is_contiguous, - plus it can be called directly. */ - -void -gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) -{ - gfc_ss *ss; - gfc_se argse; - tree desc, tmp, stride, extent, cond; - int i; - tree fncall0; - gfc_array_spec *as; - - if (arg->ts.type == BT_CLASS) - gfc_add_class_array_ref (arg); - - ss = gfc_walk_expr (arg); - gcc_assert (ss != gfc_ss_terminator); - gfc_init_se (&argse, NULL); - argse.data_not_needed = 1; - gfc_conv_expr_descriptor (&argse, arg); - - as = gfc_get_full_arrayspec_from_expr (arg); - - /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ... - Note in addition that zero-sized arrays don't count as contiguous. */ - - if (as && as->type == AS_ASSUMED_RANK) - { - /* Build the call to is_contiguous0. */ - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, arg); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - desc = gfc_evaluate_now (argse.expr, &se->pre); - fncall0 = build_call_expr_loc (input_location, - gfor_fndecl_is_contiguous0, 1, desc); - se->expr = fncall0; - se->expr = convert (logical_type_node, se->expr); - } - else - { - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - desc = gfc_evaluate_now (argse.expr, &se->pre); - - stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - stride, build_int_cst (TREE_TYPE (stride), 1)); - - for (i = 0; i < arg->rank - 1; i++) - { - tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); - extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); - extent = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, extent, tmp); - extent = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, extent, - gfc_index_one_node); - tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp, extent); - stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - stride, tmp); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond, tmp); - } - se->expr = cond; - } -} - - -/* Evaluate a single upper or lower bound. */ -/* TODO: bound intrinsic generates way too much unnecessary code. */ - -static void -gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op) -{ - gfc_actual_arglist *arg; - gfc_actual_arglist *arg2; - tree desc; - tree type; - tree bound; - tree tmp; - tree cond, cond1; - tree ubound; - tree lbound; - tree size; - gfc_se argse; - gfc_array_spec * as; - bool assumed_rank_lb_one; - - arg = expr->value.function.actual; - arg2 = arg->next; - - if (se->ss) - { - /* Create an implicit second parameter from the loop variable. */ - gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE); - gcc_assert (se->loop->dimen == 1); - gcc_assert (se->ss->info->expr == expr); - gfc_advance_se_ss_chain (se); - bound = se->loop->loopvar[0]; - bound = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, bound, - se->loop->from[0]); - } - else - { - /* use the passed argument. */ - gcc_assert (arg2->expr); - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &argse.pre); - bound = argse.expr; - /* Convert from one based to zero based. */ - bound = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, bound, - gfc_index_one_node); - } - - /* TODO: don't re-evaluate the descriptor on each iteration. */ - /* Get a descriptor for the first parameter. */ - gfc_init_se (&argse, NULL); - gfc_conv_expr_descriptor (&argse, arg->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - - desc = argse.expr; - - as = gfc_get_full_arrayspec_from_expr (arg->expr); - - if (INTEGER_CST_P (bound)) - { - gcc_assert (op != GFC_ISYM_SHAPE); - if (((!as || as->type != AS_ASSUMED_RANK) - && wi::geu_p (wi::to_wide (bound), - GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))) - || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS)) - gfc_error ("% argument of %s intrinsic at %L is not a valid " - "dimension index", - (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND", - &expr->where); - } - - if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK)) - { - if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - bound = gfc_evaluate_now (bound, &se->pre); - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - bound, build_int_cst (TREE_TYPE (bound), 0)); - if (as && as->type == AS_ASSUMED_RANK) - tmp = gfc_conv_descriptor_rank (desc); - else - tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; - tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - bound, fold_convert(TREE_TYPE (bound), tmp)); - cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, cond, tmp); - gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, - gfc_msg_fault); - } - } - - /* Take care of the lbound shift for assumed-rank arrays that are - nonallocatable and nonpointers. Those have a lbound of 1. */ - assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK - && ((arg->expr->ts.type != BT_CLASS - && !arg->expr->symtree->n.sym->attr.allocatable - && !arg->expr->symtree->n.sym->attr.pointer) - || (arg->expr->ts.type == BT_CLASS - && !CLASS_DATA (arg->expr)->attr.allocatable - && !CLASS_DATA (arg->expr)->attr.class_pointer)); - - ubound = gfc_conv_descriptor_ubound_get (desc, bound); - lbound = gfc_conv_descriptor_lbound_get (desc, bound); - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - size = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, size, gfc_index_one_node); - - /* 13.14.53: Result value for LBOUND - - Case (i): For an array section or for an array expression other than a - whole array or array structure component, LBOUND(ARRAY, DIM) - has the value 1. For a whole array or array structure - component, LBOUND(ARRAY, DIM) has the value: - (a) equal to the lower bound for subscript DIM of ARRAY if - dimension DIM of ARRAY does not have extent zero - or if ARRAY is an assumed-size array of rank DIM, - or (b) 1 otherwise. - - 13.14.113: Result value for UBOUND - - Case (i): For an array section or for an array expression other than a - whole array or array structure component, UBOUND(ARRAY, DIM) - has the value equal to the number of elements in the given - dimension; otherwise, it has a value equal to the upper bound - for subscript DIM of ARRAY if dimension DIM of ARRAY does - not have size zero and has value zero if dimension DIM has - size zero. */ - - if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one) - se->expr = gfc_index_one_node; - else if (as) - { - if (op == GFC_ISYM_UBOUND) - { - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - size, gfc_index_zero_node); - se->expr = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - (assumed_rank_lb_one ? size : ubound), - gfc_index_zero_node); - } - else if (op == GFC_ISYM_LBOUND) - { - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - size, gfc_index_zero_node); - if (as->type == AS_ASSUMED_SIZE) - { - cond1 = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, bound, - build_int_cst (TREE_TYPE (bound), - arg->expr->rank - 1)); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, cond1); - } - se->expr = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - lbound, gfc_index_one_node); - } - else if (op == GFC_ISYM_SHAPE) - se->expr = size; - else - gcc_unreachable (); - - /* According to F2018 16.9.172, para 5, an assumed rank object, - argument associated with and assumed size array, has the ubound - of the final dimension set to -1 and UBOUND must return this. - Similarly for the SHAPE intrinsic. */ - if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one) - { - tree minus_one = build_int_cst (gfc_array_index_type, -1); - tree rank = fold_convert (gfc_array_index_type, - gfc_conv_descriptor_rank (desc)); - rank = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, rank, minus_one); - - /* Fix the expression to stop it from becoming even more - complicated. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); - - /* Descriptors for assumed-size arrays have ubound = -1 - in the last dimension. */ - cond1 = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, ubound, minus_one); - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, bound, rank); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, cond, cond1); - se->expr = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - minus_one, se->expr); - } - } - else /* as is null; this is an old-fashioned 1-based array. */ - { - if (op != GFC_ISYM_LBOUND) - { - se->expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, size, - gfc_index_zero_node); - } - else - se->expr = gfc_index_one_node; - } - - - type = gfc_typenode_for_spec (&expr->ts); - se->expr = convert (type, se->expr); -} - - -static void -conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) -{ - gfc_actual_arglist *arg; - gfc_actual_arglist *arg2; - gfc_se argse; - tree bound, resbound, resbound2, desc, cond, tmp; - tree type; - int corank; - - gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND - || expr->value.function.isym->id == GFC_ISYM_UCOBOUND - || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE); - - arg = expr->value.function.actual; - arg2 = arg->next; - - gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); - corank = gfc_get_corank (arg->expr); - - gfc_init_se (&argse, NULL); - argse.want_coarray = 1; - - gfc_conv_expr_descriptor (&argse, arg->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - desc = argse.expr; - - if (se->ss) - { - /* Create an implicit second parameter from the loop variable. */ - gcc_assert (!arg2->expr); - gcc_assert (corank > 0); - gcc_assert (se->loop->dimen == 1); - gcc_assert (se->ss->info->expr == expr); - - bound = se->loop->loopvar[0]; - bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - bound, gfc_rank_cst[arg->expr->rank]); - gfc_advance_se_ss_chain (se); - } - else - { - /* use the passed argument. */ - gcc_assert (arg2->expr); - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &argse.pre); - bound = argse.expr; - - if (INTEGER_CST_P (bound)) - { - if (wi::ltu_p (wi::to_wide (bound), 1) - || wi::gtu_p (wi::to_wide (bound), - GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))) - gfc_error ("% argument of %s intrinsic at %L is not a valid " - "dimension index", expr->value.function.isym->name, - &expr->where); - } - else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - { - bound = gfc_evaluate_now (bound, &se->pre); - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - bound, build_int_cst (TREE_TYPE (bound), 1)); - tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; - tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - bound, tmp); - cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, cond, tmp); - gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, - gfc_msg_fault); - } - - - /* Subtract 1 to get to zero based and add dimensions. */ - switch (arg->expr->rank) - { - case 0: - bound = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, bound, - gfc_index_one_node); - case 1: - break; - default: - bound = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, bound, - gfc_rank_cst[arg->expr->rank - 1]); - } - } - - resbound = gfc_conv_descriptor_lbound_get (desc, bound); - - /* Handle UCOBOUND with special handling of the last codimension. */ - if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) - { - /* Last codimension: For -fcoarray=single just return - the lcobound - otherwise add - ceiling (real (num_images ()) / real (size)) - 1 - = (num_images () + size - 1) / size - 1 - = (num_images - 1) / size(), - where size is the product of the extent of all but the last - codimension. */ - - if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1) - { - tree cosize; - - cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, tmp), - build_int_cst (gfc_array_index_type, 1)); - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_array_index_type, tmp, - fold_convert (gfc_array_index_type, cosize)); - resbound = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, resbound, tmp); - } - else if (flag_coarray != GFC_FCOARRAY_SINGLE) - { - /* ubound = lbound + num_images() - 1. */ - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, tmp), - build_int_cst (gfc_array_index_type, 1)); - resbound = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, resbound, tmp); - } - - if (corank > 1) - { - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - bound, - build_int_cst (TREE_TYPE (bound), - arg->expr->rank + corank - 1)); - - resbound2 = gfc_conv_descriptor_ubound_get (desc, bound); - se->expr = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - resbound, resbound2); - } - else - se->expr = resbound; - } - else - se->expr = resbound; - - type = gfc_typenode_for_spec (&expr->ts); - se->expr = convert (type, se->expr); -} - - -static void -conv_intrinsic_stride (gfc_se * se, gfc_expr * expr) -{ - gfc_actual_arglist *array_arg; - gfc_actual_arglist *dim_arg; - gfc_se argse; - tree desc, tmp; - - array_arg = expr->value.function.actual; - dim_arg = array_arg->next; - - gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE); - - gfc_init_se (&argse, NULL); - gfc_conv_expr_descriptor (&argse, array_arg->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - desc = argse.expr; - - gcc_assert (dim_arg->expr); - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type); - gfc_add_block_to_block (&se->pre, &argse.pre); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - argse.expr, gfc_index_one_node); - se->expr = gfc_conv_descriptor_stride_get (desc, tmp); -} - -static void -gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) -{ - tree arg, cabs; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - - switch (expr->value.function.actual->expr->ts.type) - { - case BT_INTEGER: - case BT_REAL: - se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg), - arg); - break; - - case BT_COMPLEX: - cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind); - se->expr = build_call_expr_loc (input_location, cabs, 1, arg); - break; - - default: - gcc_unreachable (); - } -} - - -/* Create a complex value from one or two real components. */ - -static void -gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) -{ - tree real; - tree imag; - tree type; - tree *args; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, num_args); - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - real = convert (TREE_TYPE (type), args[0]); - if (both) - imag = convert (TREE_TYPE (type), args[1]); - else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE) - { - imag = fold_build1_loc (input_location, IMAGPART_EXPR, - TREE_TYPE (TREE_TYPE (args[0])), args[0]); - imag = convert (TREE_TYPE (type), imag); - } - else - imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); - - se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag); -} - - -/* Remainder function MOD(A, P) = A - INT(A / P) * P - MODULO(A, P) = A - FLOOR (A / P) * P - - The obvious algorithms above are numerically instable for large - arguments, hence these intrinsics are instead implemented via calls - to the fmod family of functions. It is the responsibility of the - user to ensure that the second argument is non-zero. */ - -static void -gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) -{ - tree type; - tree tmp; - tree test; - tree test2; - tree fmod; - tree zero; - tree args[2]; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - - switch (expr->ts.type) - { - case BT_INTEGER: - /* Integer case is easy, we've got a builtin op. */ - type = TREE_TYPE (args[0]); - - if (modulo) - se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type, - args[0], args[1]); - else - se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type, - args[0], args[1]); - break; - - case BT_REAL: - fmod = NULL_TREE; - /* Check if we have a builtin fmod. */ - fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind); - - /* The builtin should always be available. */ - gcc_assert (fmod != NULL_TREE); - - tmp = build_addr (fmod); - se->expr = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (fmod)), - tmp, 2, args); - if (modulo == 0) - return; - - type = TREE_TYPE (args[0]); - - args[0] = gfc_evaluate_now (args[0], &se->pre); - args[1] = gfc_evaluate_now (args[1], &se->pre); - - /* Definition: - modulo = arg - floor (arg/arg2) * arg2 - - In order to calculate the result accurately, we use the fmod - function as follows. - - res = fmod (arg, arg2); - if (res) - { - if ((arg < 0) xor (arg2 < 0)) - res += arg2; - } - else - res = copysign (0., arg2); - - => As two nested ternary exprs: - - res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res) - : copysign (0., arg2); - - */ - - zero = gfc_build_const (type, integer_zero_node); - tmp = gfc_evaluate_now (se->expr, &se->pre); - if (!flag_signed_zeros) - { - test = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - args[0], zero); - test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - args[1], zero); - test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, - logical_type_node, test, test2); - test = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, zero); - test = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, test, test2); - test = gfc_evaluate_now (test, &se->pre); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, - fold_build2_loc (input_location, - PLUS_EXPR, - type, tmp, args[1]), - tmp); - } - else - { - tree expr1, copysign, cscall; - copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, - expr->ts.kind); - test = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - args[0], zero); - test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - args[1], zero); - test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, - logical_type_node, test, test2); - expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2, - fold_build2_loc (input_location, - PLUS_EXPR, - type, tmp, args[1]), - tmp); - test = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, zero); - cscall = build_call_expr_loc (input_location, copysign, 2, zero, - args[1]); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, - expr1, cscall); - } - return; - - default: - gcc_unreachable (); - } -} - -/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S)) - DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S) - where the right shifts are logical (i.e. 0's are shifted in). - Because SHIFT_EXPR's want shifts strictly smaller than the integral - type width, we have to special-case both S == 0 and S == BITSIZE(J): - DSHIFTL(I,J,0) = I - DSHIFTL(I,J,BITSIZE) = J - DSHIFTR(I,J,0) = J - DSHIFTR(I,J,BITSIZE) = I. */ - -static void -gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl) -{ - tree type, utype, stype, arg1, arg2, shift, res, left, right; - tree args[3], cond, tmp; - int bitsize; - - gfc_conv_intrinsic_function_args (se, expr, args, 3); - - gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1])); - type = TREE_TYPE (args[0]); - bitsize = TYPE_PRECISION (type); - utype = unsigned_type_for (type); - stype = TREE_TYPE (args[2]); - - arg1 = gfc_evaluate_now (args[0], &se->pre); - arg2 = gfc_evaluate_now (args[1], &se->pre); - shift = gfc_evaluate_now (args[2], &se->pre); - - /* The generic case. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, stype, - build_int_cst (stype, bitsize), shift); - left = fold_build2_loc (input_location, LSHIFT_EXPR, type, - arg1, dshiftl ? shift : tmp); - - right = fold_build2_loc (input_location, RSHIFT_EXPR, utype, - fold_convert (utype, arg2), dshiftl ? tmp : shift); - right = fold_convert (type, right); - - res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right); - - /* Special cases. */ - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift, - build_int_cst (stype, 0)); - res = fold_build3_loc (input_location, COND_EXPR, type, cond, - dshiftl ? arg1 : arg2, res); - - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift, - build_int_cst (stype, bitsize)); - res = fold_build3_loc (input_location, COND_EXPR, type, cond, - dshiftl ? arg2 : arg1, res); - - se->expr = res; -} - - -/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */ - -static void -gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) -{ - tree val; - tree tmp; - tree type; - tree zero; - tree args[2]; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - type = TREE_TYPE (args[0]); - - val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]); - val = gfc_evaluate_now (val, &se->pre); - - zero = gfc_build_const (type, integer_zero_node); - tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val); -} - - -/* SIGN(A, B) is absolute value of A times sign of B. - The real value versions use library functions to ensure the correct - handling of negative zero. Integer case implemented as: - SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp } - */ - -static void -gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) -{ - tree tmp; - tree type; - tree args[2]; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - if (expr->ts.type == BT_REAL) - { - tree abs; - - tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); - abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); - - /* We explicitly have to ignore the minus sign. We do so by using - result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */ - if (!flag_sign_zero - && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1])))) - { - tree cond, zero; - zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node); - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - args[1], zero); - se->expr = fold_build3_loc (input_location, COND_EXPR, - TREE_TYPE (args[0]), cond, - build_call_expr_loc (input_location, abs, 1, - args[0]), - build_call_expr_loc (input_location, tmp, 2, - args[0], args[1])); - } - else - se->expr = build_call_expr_loc (input_location, tmp, 2, - args[0], args[1]); - return; - } - - /* Having excluded floating point types, we know we are now dealing - with signed integer types. */ - type = TREE_TYPE (args[0]); - - /* Args[0] is used multiple times below. */ - args[0] = gfc_evaluate_now (args[0], &se->pre); - - /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if - the signs of A and B are the same, and of all ones if they differ. */ - tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]); - tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp, - build_int_cst (type, TYPE_PRECISION (type) - 1)); - tmp = gfc_evaluate_now (tmp, &se->pre); - - /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp] - is all ones (i.e. -1). */ - se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type, - fold_build2_loc (input_location, PLUS_EXPR, - type, args[0], tmp), tmp); -} - - -/* Test for the presence of an optional argument. */ - -static void -gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) -{ - gfc_expr *arg; - - arg = expr->value.function.actual->expr; - gcc_assert (arg->expr_type == EXPR_VARIABLE); - se->expr = gfc_conv_expr_present (arg->symtree->n.sym); - se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - - -/* Calculate the double precision product of two single precision values. */ - -static void -gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) -{ - tree type; - tree args[2]; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - - /* Convert the args to double precision before multiplying. */ - type = gfc_typenode_for_spec (&expr->ts); - args[0] = convert (type, args[0]); - args[1] = convert (type, args[1]); - se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0], - args[1]); -} - - -/* Return a length one character string containing an ascii character. */ - -static void -gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) -{ - tree arg[2]; - tree var; - tree type; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr); - gfc_conv_intrinsic_function_args (se, expr, arg, num_args); - - type = gfc_get_char_type (expr->ts.kind); - var = gfc_create_var (type, "char"); - - arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]); - gfc_add_modify (&se->pre, var, arg[0]); - se->expr = gfc_build_addr_expr (build_pointer_type (type), var); - se->string_length = build_int_cst (gfc_charlen_type_node, 1); -} - - -static void -gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) -{ - tree var; - tree len; - tree tmp; - tree cond; - tree fndecl; - tree *args; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = XALLOCAVEC (tree, num_args); - - var = gfc_create_var (pchar_type_node, "pstr"); - len = gfc_create_var (gfc_charlen_type_node, "len"); - - gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = gfc_build_addr_expr (NULL_TREE, var); - args[1] = gfc_build_addr_expr (NULL_TREE, len); - - fndecl = build_addr (gfor_fndecl_ctime); - tmp = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)), - fndecl, num_args, args); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); - tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->post, tmp); - - se->expr = var; - se->string_length = len; -} - - -static void -gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) -{ - tree var; - tree len; - tree tmp; - tree cond; - tree fndecl; - tree *args; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = XALLOCAVEC (tree, num_args); - - var = gfc_create_var (pchar_type_node, "pstr"); - len = gfc_create_var (gfc_charlen_type_node, "len"); - - gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = gfc_build_addr_expr (NULL_TREE, var); - args[1] = gfc_build_addr_expr (NULL_TREE, len); - - fndecl = build_addr (gfor_fndecl_fdate); - tmp = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)), - fndecl, num_args, args); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); - tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->post, tmp); - - se->expr = var; - se->string_length = len; -} - - -/* Generate a direct call to free() for the FREE subroutine. */ - -static tree -conv_intrinsic_free (gfc_code *code) -{ - stmtblock_t block; - gfc_se argse; - tree arg, call; - - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, code->ext.actual->expr); - arg = fold_convert (ptr_type_node, argse.expr); - - gfc_init_block (&block); - call = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_FREE), 1, arg); - gfc_add_expr_to_block (&block, call); - return gfc_finish_block (&block); -} - - -/* Call the RANDOM_INIT library subroutine with a hidden argument for - handling seeding on coarray images. */ - -static tree -conv_intrinsic_random_init (gfc_code *code) -{ - stmtblock_t block; - gfc_se se; - tree arg1, arg2, tmp; - /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */ - tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB - ? logical_type_node - : gfc_get_logical_type (4); - - /* Make the function call. */ - gfc_init_block (&block); - gfc_init_se (&se, NULL); - - /* Convert REPEATABLE to the desired LOGICAL entity. */ - gfc_conv_expr (&se, code->ext.actual->expr); - gfc_add_block_to_block (&block, &se.pre); - arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block)); - gfc_add_block_to_block (&block, &se.post); - - /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */ - gfc_conv_expr (&se, code->ext.actual->next->expr); - gfc_add_block_to_block (&block, &se.pre); - arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block)); - gfc_add_block_to_block (&block, &se.post); - - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init, - 2, arg1, arg2); - } - else - { - /* The ABI for libgfortran needs to be maintained, so a hidden - argument must be include if code is compiled with -fcoarray=single - or without the option. Set to 0. */ - tree arg3 = build_int_cst (gfc_get_int_type (4), 0); - tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, - 3, arg1, arg2, arg3); - } - - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -/* Call the SYSTEM_CLOCK library functions, handling the type and kind - conversions. */ - -static tree -conv_intrinsic_system_clock (gfc_code *code) -{ - stmtblock_t block; - gfc_se count_se, count_rate_se, count_max_se; - tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE; - tree tmp; - int least; - - gfc_expr *count = code->ext.actual->expr; - gfc_expr *count_rate = code->ext.actual->next->expr; - gfc_expr *count_max = code->ext.actual->next->next->expr; - - /* Evaluate our arguments. */ - if (count) - { - gfc_init_se (&count_se, NULL); - gfc_conv_expr (&count_se, count); - } - - if (count_rate) - { - gfc_init_se (&count_rate_se, NULL); - gfc_conv_expr (&count_rate_se, count_rate); - } - - if (count_max) - { - gfc_init_se (&count_max_se, NULL); - gfc_conv_expr (&count_max_se, count_max); - } - - /* Find the smallest kind found of the arguments. */ - least = 16; - least = (count && count->ts.kind < least) ? count->ts.kind : least; - least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind - : least; - least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind - : least; - - /* Prepare temporary variables. */ - - if (count) - { - if (least >= 8) - arg1 = gfc_create_var (gfc_get_int_type (8), "count"); - else if (least == 4) - arg1 = gfc_create_var (gfc_get_int_type (4), "count"); - else if (count->ts.kind == 1) - arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int, - count->ts.kind); - else - arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int, - count->ts.kind); - } - - if (count_rate) - { - if (least >= 8) - arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate"); - else if (least == 4) - arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate"); - else - arg2 = integer_zero_node; - } - - if (count_max) - { - if (least >= 8) - arg3 = gfc_create_var (gfc_get_int_type (8), "count_max"); - else if (least == 4) - arg3 = gfc_create_var (gfc_get_int_type (4), "count_max"); - else - arg3 = integer_zero_node; - } - - /* Make the function call. */ - gfc_init_block (&block); - -if (least <= 2) - { - if (least == 1) - { - arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) - : null_pointer_node; - arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) - : null_pointer_node; - arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) - : null_pointer_node; - } - - if (least == 2) - { - arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) - : null_pointer_node; - arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) - : null_pointer_node; - arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) - : null_pointer_node; - } - } -else - { - if (least == 4) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_system_clock4, 3, - arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) - : null_pointer_node, - arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) - : null_pointer_node, - arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) - : null_pointer_node); - gfc_add_expr_to_block (&block, tmp); - } - /* Handle kind>=8, 10, or 16 arguments */ - if (least >= 8) - { - tmp = build_call_expr_loc (input_location, - gfor_fndecl_system_clock8, 3, - arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) - : null_pointer_node, - arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) - : null_pointer_node, - arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) - : null_pointer_node); - gfc_add_expr_to_block (&block, tmp); - } - } - - /* And store values back if needed. */ - if (arg1 && arg1 != count_se.expr) - gfc_add_modify (&block, count_se.expr, - fold_convert (TREE_TYPE (count_se.expr), arg1)); - if (arg2 && arg2 != count_rate_se.expr) - gfc_add_modify (&block, count_rate_se.expr, - fold_convert (TREE_TYPE (count_rate_se.expr), arg2)); - if (arg3 && arg3 != count_max_se.expr) - gfc_add_modify (&block, count_max_se.expr, - fold_convert (TREE_TYPE (count_max_se.expr), arg3)); - - return gfc_finish_block (&block); -} - - -/* Return a character string containing the tty name. */ - -static void -gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) -{ - tree var; - tree len; - tree tmp; - tree cond; - tree fndecl; - tree *args; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = XALLOCAVEC (tree, num_args); - - var = gfc_create_var (pchar_type_node, "pstr"); - len = gfc_create_var (gfc_charlen_type_node, "len"); - - gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = gfc_build_addr_expr (NULL_TREE, var); - args[1] = gfc_build_addr_expr (NULL_TREE, len); - - fndecl = build_addr (gfor_fndecl_ttynam); - tmp = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)), - fndecl, num_args, args); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); - tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->post, tmp); - - se->expr = var; - se->string_length = len; -} - - -/* Get the minimum/maximum value of all the parameters. - minmax (a1, a2, a3, ...) - { - mvar = a1; - mvar = COMP (mvar, a2) - mvar = COMP (mvar, a3) - ... - return mvar; - } - Where COMP is MIN/MAX_EXPR for integral types or when we don't - care about NaNs, or IFN_FMIN/MAX when the target has support for - fast NaN-honouring min/max. When neither holds expand a sequence - of explicit comparisons. */ - -/* TODO: Mismatching types can occur when specific names are used. - These should be handled during resolution. */ -static void -gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) -{ - tree tmp; - tree mvar; - tree val; - tree *args; - tree type; - tree argtype; - gfc_actual_arglist *argexpr; - unsigned int i, nargs; - - nargs = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, nargs); - - gfc_conv_intrinsic_function_args (se, expr, args, nargs); - type = gfc_typenode_for_spec (&expr->ts); - - /* Only evaluate the argument once. */ - if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0])) - args[0] = gfc_evaluate_now (args[0], &se->pre); - - /* Determine suitable type of temporary, as a GNU extension allows - different argument kinds. */ - argtype = TREE_TYPE (args[0]); - argexpr = expr->value.function.actual; - for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next) - { - tree tmptype = TREE_TYPE (args[i]); - if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype)) - argtype = tmptype; - } - mvar = gfc_create_var (argtype, "M"); - gfc_add_modify (&se->pre, mvar, convert (argtype, args[0])); - - argexpr = expr->value.function.actual; - for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next) - { - tree cond = NULL_TREE; - val = args[i]; - - /* Handle absent optional arguments by ignoring the comparison. */ - if (argexpr->expr->expr_type == EXPR_VARIABLE - && argexpr->expr->symtree->n.sym->attr.optional - && TREE_CODE (val) == INDIRECT_REF) - { - cond = fold_build2_loc (input_location, - NE_EXPR, logical_type_node, - TREE_OPERAND (val, 0), - build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); - } - else if (!VAR_P (val) && !TREE_CONSTANT (val)) - /* Only evaluate the argument once. */ - val = gfc_evaluate_now (val, &se->pre); - - tree calc; - /* For floating point types, the question is what MAX(a, NaN) or - MIN(a, NaN) should return (where "a" is a normal number). - There are valid usecase for returning either one, but the - Fortran standard doesn't specify which one should be chosen. - Also, there is no consensus among other tested compilers. In - short, it's a mess. So lets just do whatever is fastest. */ - tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR; - calc = fold_build2_loc (input_location, code, argtype, - convert (argtype, val), mvar); - tmp = build2_v (MODIFY_EXPR, mvar, calc); - - if (cond != NULL_TREE) - tmp = build3_v (COND_EXPR, cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->pre, tmp); - } - se->expr = convert (type, mvar); -} - - -/* Generate library calls for MIN and MAX intrinsics for character - variables. */ -static void -gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) -{ - tree *args; - tree var, len, fndecl, tmp, cond, function; - unsigned int nargs; - - nargs = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, nargs + 4); - gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs); - - /* Create the result variables. */ - len = gfc_create_var (gfc_charlen_type_node, "len"); - args[0] = gfc_build_addr_expr (NULL_TREE, len); - var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); - args[1] = gfc_build_addr_expr (ppvoid_type_node, var); - args[2] = build_int_cst (integer_type_node, op); - args[3] = build_int_cst (integer_type_node, nargs / 2); - - if (expr->ts.kind == 1) - function = gfor_fndecl_string_minmax; - else if (expr->ts.kind == 4) - function = gfor_fndecl_string_minmax_char4; - else - gcc_unreachable (); - - /* Make the function call. */ - fndecl = build_addr (function); - tmp = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (function)), fndecl, - nargs + 4, args); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); - tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->post, tmp); - - se->expr = var; - se->string_length = len; -} - - -/* Create a symbol node for this intrinsic. The symbol from the frontend - has the generic name. */ - -static gfc_symbol * -gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional) -{ - gfc_symbol *sym; - - /* TODO: Add symbols for intrinsic function to the global namespace. */ - gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); - sym = gfc_new_symbol (expr->value.function.name, NULL); - - sym->ts = expr->ts; - sym->attr.external = 1; - sym->attr.function = 1; - sym->attr.always_explicit = 1; - sym->attr.proc = PROC_INTRINSIC; - sym->attr.flavor = FL_PROCEDURE; - sym->result = sym; - if (expr->rank > 0) - { - sym->attr.dimension = 1; - sym->as = gfc_get_array_spec (); - sym->as->type = AS_ASSUMED_SHAPE; - sym->as->rank = expr->rank; - } - - gfc_copy_formal_args_intr (sym, expr->value.function.isym, - ignore_optional ? expr->value.function.actual - : NULL); - - return sym; -} - -/* Remove empty actual arguments. */ - -static void -remove_empty_actual_arguments (gfc_actual_arglist **ap) -{ - while (*ap) - { - if ((*ap)->expr == NULL) - { - gfc_actual_arglist *r = *ap; - *ap = r->next; - r->next = NULL; - gfc_free_actual_arglist (r); - } - else - ap = &((*ap)->next); - } -} - -#define MAX_SPEC_ARG 12 - -/* Make up an fn spec that's right for intrinsic functions that we - want to call. */ - -static char * -intrinsic_fnspec (gfc_expr *expr) -{ - static char fnspec_buf[MAX_SPEC_ARG*2+1]; - char *fp; - int i; - int num_char_args; - -#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) - - /* Set the fndecl. */ - fp = fnspec_buf; - /* Function return value. FIXME: Check if the second letter could - be something other than a space, for further optimization. */ - ADD_CHAR ('.'); - if (expr->rank == 0) - { - if (expr->ts.type == BT_CHARACTER) - { - ADD_CHAR ('w'); /* Address of character. */ - ADD_CHAR ('.'); /* Length of character. */ - } - } - else - ADD_CHAR ('w'); /* Return value is a descriptor. */ - - num_char_args = 0; - for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) - { - if (a->expr == NULL) - continue; - - if (a->name && strcmp (a->name,"%VAL") == 0) - ADD_CHAR ('.'); - else - { - if (a->expr->rank > 0) - ADD_CHAR ('r'); - else - ADD_CHAR ('R'); - } - num_char_args += a->expr->ts.type == BT_CHARACTER; - gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2); - } - - for (i = 0; i < num_char_args; i++) - ADD_CHAR ('.'); - - *fp = '\0'; - return fnspec_buf; -} - -#undef MAX_SPEC_ARG -#undef ADD_CHAR - -/* Generate the right symbol for the specific intrinsic function and - modify the expr accordingly. This assumes that absent optional - arguments should be removed. */ - -gfc_symbol * -specific_intrinsic_symbol (gfc_expr *expr) -{ - gfc_symbol *sym; - - sym = gfc_find_intrinsic_symbol (expr); - if (sym == NULL) - { - sym = gfc_get_intrinsic_function_symbol (expr); - sym->ts = expr->ts; - if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl) - sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); - - gfc_copy_formal_args_intr (sym, expr->value.function.isym, - expr->value.function.actual, true); - sym->backend_decl - = gfc_get_extern_function_decl (sym, expr->value.function.actual, - intrinsic_fnspec (expr)); - } - - remove_empty_actual_arguments (&(expr->value.function.actual)); - - return sym; -} - -/* Generate a call to an external intrinsic function. FIXME: So far, - this only works for functions which are called with well-defined - types; CSHIFT and friends will come later. */ - -static void -gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) -{ - gfc_symbol *sym; - vec *append_args; - bool specific_symbol; - - gcc_assert (!se->ss || se->ss->info->expr == expr); - - if (se->ss) - gcc_assert (expr->rank > 0); - else - gcc_assert (expr->rank == 0); - - switch (expr->value.function.isym->id) - { - case GFC_ISYM_ANY: - case GFC_ISYM_ALL: - case GFC_ISYM_FINDLOC: - case GFC_ISYM_MAXLOC: - case GFC_ISYM_MINLOC: - case GFC_ISYM_MAXVAL: - case GFC_ISYM_MINVAL: - case GFC_ISYM_NORM2: - case GFC_ISYM_PRODUCT: - case GFC_ISYM_SUM: - specific_symbol = true; - break; - default: - specific_symbol = false; - } - - if (specific_symbol) - { - /* Need to copy here because specific_intrinsic_symbol modifies - expr to omit the absent optional arguments. */ - expr = gfc_copy_expr (expr); - sym = specific_intrinsic_symbol (expr); - } - else - sym = gfc_get_symbol_for_expr (expr, se->ignore_optional); - - /* Calls to libgfortran_matmul need to be appended special arguments, - to be able to call the BLAS ?gemm functions if required and possible. */ - append_args = NULL; - if (expr->value.function.isym->id == GFC_ISYM_MATMUL - && !expr->external_blas - && sym->ts.type != BT_LOGICAL) - { - tree cint = gfc_get_int_type (gfc_c_int_kind); - - if (flag_external_blas - && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX) - && (sym->ts.kind == 4 || sym->ts.kind == 8)) - { - tree gemm_fndecl; - - if (sym->ts.type == BT_REAL) - { - if (sym->ts.kind == 4) - gemm_fndecl = gfor_fndecl_sgemm; - else - gemm_fndecl = gfor_fndecl_dgemm; - } - else - { - if (sym->ts.kind == 4) - gemm_fndecl = gfor_fndecl_cgemm; - else - gemm_fndecl = gfor_fndecl_zgemm; - } - - vec_alloc (append_args, 3); - append_args->quick_push (build_int_cst (cint, 1)); - append_args->quick_push (build_int_cst (cint, - flag_blas_matmul_limit)); - append_args->quick_push (gfc_build_addr_expr (NULL_TREE, - gemm_fndecl)); - } - else - { - vec_alloc (append_args, 3); - append_args->quick_push (build_int_cst (cint, 0)); - append_args->quick_push (build_int_cst (cint, 0)); - append_args->quick_push (null_pointer_node); - } - } - - gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, - append_args); - - if (specific_symbol) - gfc_free_expr (expr); - else - gfc_free_symbol (sym); -} - -/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR. - Implemented as - any(a) - { - forall (i=...) - if (a[i] != 0) - return 1 - end forall - return 0 - } - all(a) - { - forall (i=...) - if (a[i] == 0) - return 0 - end forall - return 1 - } - */ -static void -gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op) -{ - tree resvar; - stmtblock_t block; - stmtblock_t body; - tree type; - tree tmp; - tree found; - gfc_loopinfo loop; - gfc_actual_arglist *actual; - gfc_ss *arrayss; - gfc_se arrayse; - tree exit_label; - - if (se->ss) - { - gfc_conv_intrinsic_funcall (se, expr); - return; - } - - actual = expr->value.function.actual; - type = gfc_typenode_for_spec (&expr->ts); - /* Initialize the result. */ - resvar = gfc_create_var (type, "test"); - if (op == EQ_EXPR) - tmp = convert (type, boolean_true_node); - else - tmp = convert (type, boolean_false_node); - gfc_add_modify (&se->pre, resvar, tmp); - - /* Walk the arguments. */ - arrayss = gfc_walk_expr (actual->expr); - gcc_assert (arrayss != gfc_ss_terminator); - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - gfc_add_ss_to_loop (&loop, arrayss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - gfc_mark_ss_chain_used (arrayss, 1); - /* Generate the loop body. */ - gfc_start_scalarized_body (&loop, &body); - - /* If the condition matches then set the return value. */ - gfc_start_block (&block); - if (op == EQ_EXPR) - tmp = convert (type, boolean_false_node); - else - tmp = convert (type, boolean_true_node); - gfc_add_modify (&block, resvar, tmp); - - /* And break out of the loop. */ - tmp = build1_v (GOTO_EXPR, exit_label); - gfc_add_expr_to_block (&block, tmp); - - found = gfc_finish_block (&block); - - /* Check this element. */ - gfc_init_se (&arrayse, NULL); - gfc_copy_loopinfo_to_se (&arrayse, &loop); - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, actual->expr); - - gfc_add_block_to_block (&body, &arrayse.pre); - tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, - build_int_cst (TREE_TYPE (arrayse.expr), 0)); - tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&body, tmp); - gfc_add_block_to_block (&body, &arrayse.post); - - gfc_trans_scalarizing_loops (&loop, &body); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&loop.pre, tmp); - - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->pre, &loop.post); - gfc_cleanup_loop (&loop); - - se->expr = resvar; -} - - -/* Generate the constant 180 / pi, which is used in the conversion - of acosd(), asind(), atand(), atan2d(). */ - -static tree -rad2deg (int kind) -{ - tree retval; - mpfr_t pi, t0; - - gfc_set_model_kind (kind); - mpfr_init (pi); - mpfr_init (t0); - mpfr_set_si (t0, 180, GFC_RND_MODE); - mpfr_const_pi (pi, GFC_RND_MODE); - mpfr_div (t0, t0, pi, GFC_RND_MODE); - retval = gfc_conv_mpfr_to_tree (t0, kind, 0); - mpfr_clear (t0); - mpfr_clear (pi); - return retval; -} - - -static gfc_intrinsic_map_t * -gfc_lookup_intrinsic (gfc_isym_id id) -{ - gfc_intrinsic_map_t *m = gfc_intrinsic_map; - for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) - if (id == m->id) - break; - gcc_assert (id == m->id); - return m; -} - - -/* ACOSD(x) is translated into ACOS(x) * 180 / pi. - ASIND(x) is translated into ASIN(x) * 180 / pi. - ATAND(x) is translated into ATAN(x) * 180 / pi. */ - -static void -gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id) -{ - tree arg; - tree atrigd; - tree type; - gfc_intrinsic_map_t *m; - - type = gfc_typenode_for_spec (&expr->ts); - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - - switch (id) - { - case GFC_ISYM_ACOSD: - m = gfc_lookup_intrinsic (GFC_ISYM_ACOS); - break; - case GFC_ISYM_ASIND: - m = gfc_lookup_intrinsic (GFC_ISYM_ASIN); - break; - case GFC_ISYM_ATAND: - m = gfc_lookup_intrinsic (GFC_ISYM_ATAN); - break; - default: - gcc_unreachable (); - } - atrigd = gfc_get_intrinsic_lib_fndecl (m, expr); - atrigd = build_call_expr_loc (input_location, atrigd, 1, arg); - - se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd, - fold_convert (type, rad2deg (expr->ts.kind))); -} - - -/* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and - COS(X) / SIN(X) for COMPLEX argument. */ - -static void -gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr) -{ - gfc_intrinsic_map_t *m; - tree arg; - tree type; - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - - if (expr->ts.type == BT_REAL) - { - tree tan; - tree tmp; - mpfr_t pio2; - - /* Create pi/2. */ - gfc_set_model_kind (expr->ts.kind); - mpfr_init (pio2); - mpfr_const_pi (pio2, GFC_RND_MODE); - mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE); - tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0); - mpfr_clear (pio2); - - /* Find tan builtin function. */ - m = gfc_lookup_intrinsic (GFC_ISYM_TAN); - tan = gfc_get_intrinsic_lib_fndecl (m, expr); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp); - tan = build_call_expr_loc (input_location, tan, 1, tmp); - se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan); - } - else - { - tree sin; - tree cos; - - /* Find cos builtin function. */ - m = gfc_lookup_intrinsic (GFC_ISYM_COS); - cos = gfc_get_intrinsic_lib_fndecl (m, expr); - cos = build_call_expr_loc (input_location, cos, 1, arg); - - /* Find sin builtin function. */ - m = gfc_lookup_intrinsic (GFC_ISYM_SIN); - sin = gfc_get_intrinsic_lib_fndecl (m, expr); - sin = build_call_expr_loc (input_location, sin, 1, arg); - - /* Divide cos by sin. */ - se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin); - } -} - - -/* COTAND(X) is translated into -TAND(X+90) for REAL argument. */ - -static void -gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr) -{ - tree arg; - tree type; - tree ninety_tree; - mpfr_t ninety; - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - - gfc_set_model_kind (expr->ts.kind); - - /* Build the tree for x + 90. */ - mpfr_init_set_ui (ninety, 90, GFC_RND_MODE); - ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0); - arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree); - mpfr_clear (ninety); - - /* Find tand. */ - gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND); - tree tand = gfc_get_intrinsic_lib_fndecl (m, expr); - tand = build_call_expr_loc (input_location, tand, 1, arg); - - se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand); -} - - -/* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */ - -static void -gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr) -{ - tree args[2]; - tree atan2d; - tree type; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - type = TREE_TYPE (args[0]); - - gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2); - atan2d = gfc_get_intrinsic_lib_fndecl (m, expr); - atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]); - - se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d, - rad2deg (expr->ts.kind)); -} - - -/* COUNT(A) = Number of true elements in A. */ -static void -gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) -{ - tree resvar; - tree type; - stmtblock_t body; - tree tmp; - gfc_loopinfo loop; - gfc_actual_arglist *actual; - gfc_ss *arrayss; - gfc_se arrayse; - - if (se->ss) - { - gfc_conv_intrinsic_funcall (se, expr); - return; - } - - actual = expr->value.function.actual; - - type = gfc_typenode_for_spec (&expr->ts); - /* Initialize the result. */ - resvar = gfc_create_var (type, "count"); - gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0)); - - /* Walk the arguments. */ - arrayss = gfc_walk_expr (actual->expr); - gcc_assert (arrayss != gfc_ss_terminator); - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - gfc_mark_ss_chain_used (arrayss, 1); - /* Generate the loop body. */ - gfc_start_scalarized_body (&loop, &body); - - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar), - resvar, build_int_cst (TREE_TYPE (resvar), 1)); - tmp = build2_v (MODIFY_EXPR, resvar, tmp); - - gfc_init_se (&arrayse, NULL); - gfc_copy_loopinfo_to_se (&arrayse, &loop); - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, actual->expr); - tmp = build3_v (COND_EXPR, arrayse.expr, tmp, - build_empty_stmt (input_location)); - - gfc_add_block_to_block (&body, &arrayse.pre); - gfc_add_expr_to_block (&body, tmp); - gfc_add_block_to_block (&body, &arrayse.post); - - gfc_trans_scalarizing_loops (&loop, &body); - - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->pre, &loop.post); - gfc_cleanup_loop (&loop); - - se->expr = resvar; -} - - -/* Update given gfc_se to have ss component pointing to the nested gfc_ss - struct and return the corresponding loopinfo. */ - -static gfc_loopinfo * -enter_nested_loop (gfc_se *se) -{ - se->ss = se->ss->nested_ss; - gcc_assert (se->ss == se->ss->loop->ss); - - return se->ss->loop; -} - -/* Build the condition for a mask, which may be optional. */ - -static tree -conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr, - bool optional_mask) -{ - tree present; - tree type; - - if (optional_mask) - { - type = TREE_TYPE (maskse->expr); - present = gfc_conv_expr_present (maskexpr->symtree->n.sym); - present = convert (type, present); - present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type, - present); - return fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - type, present, maskse->expr); - } - else - return maskse->expr; -} - -/* Inline implementation of the sum and product intrinsics. */ -static void -gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, - bool norm2) -{ - tree resvar; - tree scale = NULL_TREE; - tree type; - stmtblock_t body; - stmtblock_t block; - tree tmp; - gfc_loopinfo loop, *ploop; - gfc_actual_arglist *arg_array, *arg_mask; - gfc_ss *arrayss = NULL; - gfc_ss *maskss = NULL; - gfc_se arrayse; - gfc_se maskse; - gfc_se *parent_se; - gfc_expr *arrayexpr; - gfc_expr *maskexpr; - bool optional_mask; - - if (expr->rank > 0) - { - gcc_assert (gfc_inline_intrinsic_function_p (expr)); - parent_se = se; - } - else - parent_se = NULL; - - type = gfc_typenode_for_spec (&expr->ts); - /* Initialize the result. */ - resvar = gfc_create_var (type, "val"); - if (norm2) - { - /* result = 0.0; - scale = 1.0. */ - scale = gfc_create_var (type, "scale"); - gfc_add_modify (&se->pre, scale, - gfc_build_const (type, integer_one_node)); - tmp = gfc_build_const (type, integer_zero_node); - } - else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR) - tmp = gfc_build_const (type, integer_zero_node); - else if (op == NE_EXPR) - /* PARITY. */ - tmp = convert (type, boolean_false_node); - else if (op == BIT_AND_EXPR) - tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR, - type, integer_one_node)); - else - tmp = gfc_build_const (type, integer_one_node); - - gfc_add_modify (&se->pre, resvar, tmp); - - arg_array = expr->value.function.actual; - - arrayexpr = arg_array->expr; - - if (op == NE_EXPR || norm2) - { - /* PARITY and NORM2. */ - maskexpr = NULL; - optional_mask = false; - } - else - { - arg_mask = arg_array->next->next; - gcc_assert (arg_mask != NULL); - maskexpr = arg_mask->expr; - optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE - && maskexpr->symtree->n.sym->attr.dummy - && maskexpr->symtree->n.sym->attr.optional; - } - - if (expr->rank == 0) - { - /* Walk the arguments. */ - arrayss = gfc_walk_expr (arrayexpr); - gcc_assert (arrayss != gfc_ss_terminator); - - if (maskexpr && maskexpr->rank > 0) - { - maskss = gfc_walk_expr (maskexpr); - gcc_assert (maskss != gfc_ss_terminator); - } - else - maskss = NULL; - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - - /* We add the mask first because the number of iterations is - taken from the last ss, and this breaks if an absent - optional argument is used for mask. */ - - if (maskexpr && maskexpr->rank > 0) - gfc_add_ss_to_loop (&loop, maskss); - gfc_add_ss_to_loop (&loop, arrayss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - if (maskexpr && maskexpr->rank > 0) - gfc_mark_ss_chain_used (maskss, 1); - gfc_mark_ss_chain_used (arrayss, 1); - - ploop = &loop; - } - else - /* All the work has been done in the parent loops. */ - ploop = enter_nested_loop (se); - - gcc_assert (ploop); - - /* Generate the loop body. */ - gfc_start_scalarized_body (ploop, &body); - - /* If we have a mask, only add this element if the mask is set. */ - if (maskexpr && maskexpr->rank > 0) - { - gfc_init_se (&maskse, parent_se); - gfc_copy_loopinfo_to_se (&maskse, ploop); - if (expr->rank == 0) - maskse.ss = maskss; - gfc_conv_expr_val (&maskse, maskexpr); - gfc_add_block_to_block (&body, &maskse.pre); - - gfc_start_block (&block); - } - else - gfc_init_block (&block); - - /* Do the actual summation/product. */ - gfc_init_se (&arrayse, parent_se); - gfc_copy_loopinfo_to_se (&arrayse, ploop); - if (expr->rank == 0) - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, arrayexpr); - gfc_add_block_to_block (&block, &arrayse.pre); - - if (norm2) - { - /* if (x (i) != 0.0) - { - absX = abs(x(i)) - if (absX > scale) - { - val = scale/absX; - result = 1.0 + result * val * val; - scale = absX; - } - else - { - val = absX/scale; - result += val * val; - } - } */ - tree res1, res2, cond, absX, val; - stmtblock_t ifblock1, ifblock2, ifblock3; - - gfc_init_block (&ifblock1); - - absX = gfc_create_var (type, "absX"); - gfc_add_modify (&ifblock1, absX, - fold_build1_loc (input_location, ABS_EXPR, type, - arrayse.expr)); - val = gfc_create_var (type, "val"); - gfc_add_expr_to_block (&ifblock1, val); - - gfc_init_block (&ifblock2); - gfc_add_modify (&ifblock2, val, - fold_build2_loc (input_location, RDIV_EXPR, type, scale, - absX)); - res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); - res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1); - res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1, - gfc_build_const (type, integer_one_node)); - gfc_add_modify (&ifblock2, resvar, res1); - gfc_add_modify (&ifblock2, scale, absX); - res1 = gfc_finish_block (&ifblock2); - - gfc_init_block (&ifblock3); - gfc_add_modify (&ifblock3, val, - fold_build2_loc (input_location, RDIV_EXPR, type, absX, - scale)); - res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); - res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2); - gfc_add_modify (&ifblock3, resvar, res2); - res2 = gfc_finish_block (&ifblock3); - - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - absX, scale); - tmp = build3_v (COND_EXPR, cond, res1, res2); - gfc_add_expr_to_block (&ifblock1, tmp); - tmp = gfc_finish_block (&ifblock1); - - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - arrayse.expr, - gfc_build_const (type, integer_zero_node)); - - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - else - { - tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr); - gfc_add_modify (&block, resvar, tmp); - } - - gfc_add_block_to_block (&block, &arrayse.post); - - if (maskexpr && maskexpr->rank > 0) - { - /* We enclose the above in if (mask) {...} . If the mask is an - optional argument, generate - IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */ - tree ifmask; - tmp = gfc_finish_block (&block); - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - } - else - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&body, tmp); - - gfc_trans_scalarizing_loops (ploop, &body); - - /* For a scalar mask, enclose the loop in an if statement. */ - if (maskexpr && maskexpr->rank == 0) - { - gfc_init_block (&block); - gfc_add_block_to_block (&block, &ploop->pre); - gfc_add_block_to_block (&block, &ploop->post); - tmp = gfc_finish_block (&block); - - if (expr->rank > 0) - { - tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp, - build_empty_stmt (input_location)); - gfc_advance_se_ss_chain (se); - } - else - { - tree ifmask; - - gcc_assert (expr->rank == 0); - gfc_init_se (&maskse, NULL); - gfc_conv_expr_val (&maskse, maskexpr); - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&se->pre, &block); - gcc_assert (se->post.head == NULL); - } - else - { - gfc_add_block_to_block (&se->pre, &ploop->pre); - gfc_add_block_to_block (&se->pre, &ploop->post); - } - - if (expr->rank == 0) - gfc_cleanup_loop (ploop); - - if (norm2) - { - /* result = scale * sqrt(result). */ - tree sqrt; - sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind); - resvar = build_call_expr_loc (input_location, - sqrt, 1, resvar); - resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar); - } - - se->expr = resvar; -} - - -/* Inline implementation of the dot_product intrinsic. This function - is based on gfc_conv_intrinsic_arith (the previous function). */ -static void -gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) -{ - tree resvar; - tree type; - stmtblock_t body; - stmtblock_t block; - tree tmp; - gfc_loopinfo loop; - gfc_actual_arglist *actual; - gfc_ss *arrayss1, *arrayss2; - gfc_se arrayse1, arrayse2; - gfc_expr *arrayexpr1, *arrayexpr2; - - type = gfc_typenode_for_spec (&expr->ts); - - /* Initialize the result. */ - resvar = gfc_create_var (type, "val"); - if (expr->ts.type == BT_LOGICAL) - tmp = build_int_cst (type, 0); - else - tmp = gfc_build_const (type, integer_zero_node); - - gfc_add_modify (&se->pre, resvar, tmp); - - /* Walk argument #1. */ - actual = expr->value.function.actual; - arrayexpr1 = actual->expr; - arrayss1 = gfc_walk_expr (arrayexpr1); - gcc_assert (arrayss1 != gfc_ss_terminator); - - /* Walk argument #2. */ - actual = actual->next; - arrayexpr2 = actual->expr; - arrayss2 = gfc_walk_expr (arrayexpr2); - gcc_assert (arrayss2 != gfc_ss_terminator); - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss1); - gfc_add_ss_to_loop (&loop, arrayss2); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - gfc_mark_ss_chain_used (arrayss1, 1); - gfc_mark_ss_chain_used (arrayss2, 1); - - /* Generate the loop body. */ - gfc_start_scalarized_body (&loop, &body); - gfc_init_block (&block); - - /* Make the tree expression for [conjg(]array1[)]. */ - gfc_init_se (&arrayse1, NULL); - gfc_copy_loopinfo_to_se (&arrayse1, &loop); - arrayse1.ss = arrayss1; - gfc_conv_expr_val (&arrayse1, arrayexpr1); - if (expr->ts.type == BT_COMPLEX) - arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type, - arrayse1.expr); - gfc_add_block_to_block (&block, &arrayse1.pre); - - /* Make the tree expression for array2. */ - gfc_init_se (&arrayse2, NULL); - gfc_copy_loopinfo_to_se (&arrayse2, &loop); - arrayse2.ss = arrayss2; - gfc_conv_expr_val (&arrayse2, arrayexpr2); - gfc_add_block_to_block (&block, &arrayse2.pre); - - /* Do the actual product and sum. */ - if (expr->ts.type == BT_LOGICAL) - { - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type, - arrayse1.expr, arrayse2.expr); - tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp); - } - else - { - tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr, - arrayse2.expr); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp); - } - gfc_add_modify (&block, resvar, tmp); - - /* Finish up the loop block and the loop. */ - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&body, tmp); - - gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->pre, &loop.post); - gfc_cleanup_loop (&loop); - - se->expr = resvar; -} - - -/* Remove unneeded kind= argument from actual argument list when the - result conversion is dealt with in a different place. */ - -static void -strip_kind_from_actual (gfc_actual_arglist * actual) -{ - for (gfc_actual_arglist *a = actual; a; a = a->next) - { - if (a && a->name && strcmp (a->name, "kind") == 0) - { - gfc_free_expr (a->expr); - a->expr = NULL; - } - } -} - -/* Emit code for minloc or maxloc intrinsic. There are many different cases - we need to handle. For performance reasons we sometimes create two - loops instead of one, where the second one is much simpler. - Examples for minloc intrinsic: - 1) Result is an array, a call is generated - 2) Array mask is used and NaNs need to be supported: - limit = Infinity; - pos = 0; - S = from; - while (S <= to) { - if (mask[S]) { - if (pos == 0) pos = S + (1 - from); - if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } - } - S++; - } - goto lab2; - lab1:; - while (S <= to) { - if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - lab2:; - 3) NaNs need to be supported, but it is known at compile time or cheaply - at runtime whether array is nonempty or not: - limit = Infinity; - pos = 0; - S = from; - while (S <= to) { - if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } - S++; - } - if (from <= to) pos = 1; - goto lab2; - lab1:; - while (S <= to) { - if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - lab2:; - 4) NaNs aren't supported, array mask is used: - limit = infinities_supported ? Infinity : huge (limit); - pos = 0; - S = from; - while (S <= to) { - if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; } - S++; - } - goto lab2; - lab1:; - while (S <= to) { - if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - lab2:; - 5) Same without array mask: - limit = infinities_supported ? Infinity : huge (limit); - pos = (from <= to) ? 1 : 0; - S = from; - while (S <= to) { - if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } - S++; - } - For 3) and 5), if mask is scalar, this all goes into a conditional, - setting pos = 0; in the else branch. - - Since we now also support the BACK argument, instead of using - if (a[S] < limit), we now use - - if (back) - cond = a[S] <= limit; - else - cond = a[S] < limit; - if (cond) { - .... - - The optimizer is smart enough to move the condition out of the loop. - The are now marked as unlikely to for further speedup. */ - -static void -gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) -{ - stmtblock_t body; - stmtblock_t block; - stmtblock_t ifblock; - stmtblock_t elseblock; - tree limit; - tree type; - tree tmp; - tree cond; - tree elsetmp; - tree ifbody; - tree offset; - tree nonempty; - tree lab1, lab2; - tree b_if, b_else; - gfc_loopinfo loop; - gfc_actual_arglist *actual; - gfc_ss *arrayss; - gfc_ss *maskss; - gfc_se arrayse; - gfc_se maskse; - gfc_expr *arrayexpr; - gfc_expr *maskexpr; - gfc_expr *backexpr; - gfc_se backse; - tree pos; - int n; - bool optional_mask; - - actual = expr->value.function.actual; - - /* The last argument, BACK, is passed by value. Ensure that - by setting its name to %VAL. */ - for (gfc_actual_arglist *a = actual; a; a = a->next) - { - if (a->next == NULL) - a->name = "%VAL"; - } - - if (se->ss) - { - gfc_conv_intrinsic_funcall (se, expr); - return; - } - - arrayexpr = actual->expr; - - /* Special case for character maxloc. Remove unneeded actual - arguments, then call a library function. */ - - if (arrayexpr->ts.type == BT_CHARACTER) - { - gfc_actual_arglist *a; - a = actual; - strip_kind_from_actual (a); - while (a) - { - if (a->name && strcmp (a->name, "dim") == 0) - { - gfc_free_expr (a->expr); - a->expr = NULL; - } - a = a->next; - } - gfc_conv_intrinsic_funcall (se, expr); - return; - } - - /* Initialize the result. */ - pos = gfc_create_var (gfc_array_index_type, "pos"); - offset = gfc_create_var (gfc_array_index_type, "offset"); - type = gfc_typenode_for_spec (&expr->ts); - - /* Walk the arguments. */ - arrayss = gfc_walk_expr (arrayexpr); - gcc_assert (arrayss != gfc_ss_terminator); - - actual = actual->next->next; - gcc_assert (actual); - maskexpr = actual->expr; - optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE - && maskexpr->symtree->n.sym->attr.dummy - && maskexpr->symtree->n.sym->attr.optional; - backexpr = actual->next->next->expr; - nonempty = NULL; - if (maskexpr && maskexpr->rank != 0) - { - maskss = gfc_walk_expr (maskexpr); - gcc_assert (maskss != gfc_ss_terminator); - } - else - { - mpz_t asize; - if (gfc_array_size (arrayexpr, &asize)) - { - nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); - mpz_clear (asize); - nonempty = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, nonempty, - gfc_index_zero_node); - } - maskss = NULL; - } - - limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); - switch (arrayexpr->ts.type) - { - case BT_REAL: - tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind); - break; - - case BT_INTEGER: - n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); - tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, - arrayexpr->ts.kind); - break; - - default: - gcc_unreachable (); - } - - /* We start with the most negative possible value for MAXLOC, and the most - positive possible value for MINLOC. The most negative possible value is - -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive - possible value is HUGE in both cases. */ - if (op == GT_EXPR) - tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); - if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER) - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp, - build_int_cst (TREE_TYPE (tmp), 1)); - - gfc_add_modify (&se->pre, limit, tmp); - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - - /* We add the mask first because the number of iterations is taken - from the last ss, and this breaks if an absent optional argument - is used for mask. */ - - if (maskss) - gfc_add_ss_to_loop (&loop, maskss); - - gfc_add_ss_to_loop (&loop, arrayss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - - /* The code generated can have more than one loop in sequence (see the - comment at the function header). This doesn't work well with the - scalarizer, which changes arrays' offset when the scalarization loops - are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc - are currently inlined in the scalar case only (for which loop is of rank - one). As there is no dependency to care about in that case, there is no - temporary, so that we can use the scalarizer temporary code to handle - multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used - with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later - to restore offset. - TODO: this prevents inlining of rank > 0 minmaxloc calls, so this - should eventually go away. We could either create two loops properly, - or find another way to save/restore the array offsets between the two - loops (without conflicting with temporary management), or use a single - loop minmaxloc implementation. See PR 31067. */ - loop.temp_dim = loop.dimen; - gfc_conv_loop_setup (&loop, &expr->where); - - gcc_assert (loop.dimen == 1); - if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) - nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - loop.from[0], loop.to[0]); - - lab1 = NULL; - lab2 = NULL; - /* Initialize the position to zero, following Fortran 2003. We are free - to do this because Fortran 95 allows the result of an entirely false - mask to be processor dependent. If we know at compile time the array - is non-empty and no MASK is used, we can initialize to 1 to simplify - the inner loop. */ - if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit))) - gfc_add_modify (&loop.pre, pos, - fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, - nonempty, gfc_index_one_node, - gfc_index_zero_node)); - else - { - gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); - lab1 = gfc_build_label_decl (NULL_TREE); - TREE_USED (lab1) = 1; - lab2 = gfc_build_label_decl (NULL_TREE); - TREE_USED (lab2) = 1; - } - - /* An offset must be added to the loop - counter to obtain the required position. */ - gcc_assert (loop.from[0]); - - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, loop.from[0]); - gfc_add_modify (&loop.pre, offset, tmp); - - gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1); - if (maskss) - gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1); - /* Generate the loop body. */ - gfc_start_scalarized_body (&loop, &body); - - /* If we have a mask, only check this element if the mask is set. */ - if (maskss) - { - gfc_init_se (&maskse, NULL); - gfc_copy_loopinfo_to_se (&maskse, &loop); - maskse.ss = maskss; - gfc_conv_expr_val (&maskse, maskexpr); - gfc_add_block_to_block (&body, &maskse.pre); - - gfc_start_block (&block); - } - else - gfc_init_block (&block); - - /* Compare with the current limit. */ - gfc_init_se (&arrayse, NULL); - gfc_copy_loopinfo_to_se (&arrayse, &loop); - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, arrayexpr); - gfc_add_block_to_block (&block, &arrayse.pre); - - gfc_init_se (&backse, NULL); - gfc_conv_expr_val (&backse, backexpr); - gfc_add_block_to_block (&block, &backse.pre); - - /* We do the following if this is a more extreme value. */ - gfc_start_block (&ifblock); - - /* Assign the value to the limit... */ - gfc_add_modify (&ifblock, limit, arrayse.expr); - - if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit))) - { - stmtblock_t ifblock2; - tree ifbody2; - - gfc_start_block (&ifblock2); - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); - gfc_add_modify (&ifblock2, pos, tmp); - ifbody2 = gfc_finish_block (&ifblock2); - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos, - gfc_index_zero_node); - tmp = build3_v (COND_EXPR, cond, ifbody2, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); - gfc_add_modify (&ifblock, pos, tmp); - - if (lab1) - gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)); - - ifbody = gfc_finish_block (&ifblock); - - if (!lab1 || HONOR_NANS (DECL_MODE (limit))) - { - if (lab1) - cond = fold_build2_loc (input_location, - op == GT_EXPR ? GE_EXPR : LE_EXPR, - logical_type_node, arrayse.expr, limit); - else - { - tree ifbody2, elsebody2; - - /* We switch to > or >= depending on the value of the BACK argument. */ - cond = gfc_create_var (logical_type_node, "cond"); - - gfc_start_block (&ifblock); - b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, - logical_type_node, arrayse.expr, limit); - - gfc_add_modify (&ifblock, cond, b_if); - ifbody2 = gfc_finish_block (&ifblock); - - gfc_start_block (&elseblock); - b_else = fold_build2_loc (input_location, op, logical_type_node, - arrayse.expr, limit); - - gfc_add_modify (&elseblock, cond, b_else); - elsebody2 = gfc_finish_block (&elseblock); - - tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node, - backse.expr, ifbody2, elsebody2); - - gfc_add_expr_to_block (&block, tmp); - } - - cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT); - ifbody = build3_v (COND_EXPR, cond, ifbody, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&block, ifbody); - - if (maskss) - { - /* We enclose the above in if (mask) {...}. If the mask is an - optional argument, generate IF (.NOT. PRESENT(MASK) - .OR. MASK(I)). */ - - tree ifmask; - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - } - else - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&body, tmp); - - if (lab1) - { - gfc_trans_scalarized_loop_boundary (&loop, &body); - - if (HONOR_NANS (DECL_MODE (limit))) - { - if (nonempty != NULL) - { - ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node); - tmp = build3_v (COND_EXPR, nonempty, ifbody, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&loop.code[0], tmp); - } - } - - gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2)); - gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1)); - - /* If we have a mask, only check this element if the mask is set. */ - if (maskss) - { - gfc_init_se (&maskse, NULL); - gfc_copy_loopinfo_to_se (&maskse, &loop); - maskse.ss = maskss; - gfc_conv_expr_val (&maskse, maskexpr); - gfc_add_block_to_block (&body, &maskse.pre); - - gfc_start_block (&block); - } - else - gfc_init_block (&block); - - /* Compare with the current limit. */ - gfc_init_se (&arrayse, NULL); - gfc_copy_loopinfo_to_se (&arrayse, &loop); - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, arrayexpr); - gfc_add_block_to_block (&block, &arrayse.pre); - - /* We do the following if this is a more extreme value. */ - gfc_start_block (&ifblock); - - /* Assign the value to the limit... */ - gfc_add_modify (&ifblock, limit, arrayse.expr); - - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), - loop.loopvar[0], offset); - gfc_add_modify (&ifblock, pos, tmp); - - ifbody = gfc_finish_block (&ifblock); - - /* We switch to > or >= depending on the value of the BACK argument. */ - { - tree ifbody2, elsebody2; - - cond = gfc_create_var (logical_type_node, "cond"); - - gfc_start_block (&ifblock); - b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, - logical_type_node, arrayse.expr, limit); - - gfc_add_modify (&ifblock, cond, b_if); - ifbody2 = gfc_finish_block (&ifblock); - - gfc_start_block (&elseblock); - b_else = fold_build2_loc (input_location, op, logical_type_node, - arrayse.expr, limit); - - gfc_add_modify (&elseblock, cond, b_else); - elsebody2 = gfc_finish_block (&elseblock); - - tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node, - backse.expr, ifbody2, elsebody2); - } - - gfc_add_expr_to_block (&block, tmp); - cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT); - tmp = build3_v (COND_EXPR, cond, ifbody, - build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - - if (maskss) - { - /* We enclose the above in if (mask) {...}. If the mask is - an optional argument, generate IF (.NOT. PRESENT(MASK) - .OR. MASK(I)).*/ - - tree ifmask; - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - } - else - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&body, tmp); - /* Avoid initializing loopvar[0] again, it should be left where - it finished by the first loop. */ - loop.from[0] = loop.loopvar[0]; - } - - gfc_trans_scalarizing_loops (&loop, &body); - - if (lab2) - gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2)); - - /* For a scalar mask, enclose the loop in an if statement. */ - if (maskexpr && maskss == NULL) - { - tree ifmask; - - gfc_init_se (&maskse, NULL); - gfc_conv_expr_val (&maskse, maskexpr); - gfc_init_block (&block); - gfc_add_block_to_block (&block, &loop.pre); - gfc_add_block_to_block (&block, &loop.post); - tmp = gfc_finish_block (&block); - - /* For the else part of the scalar mask, just initialize - the pos variable the same way as above. */ - - gfc_init_block (&elseblock); - gfc_add_modify (&elseblock, pos, gfc_index_zero_node); - elsetmp = gfc_finish_block (&elseblock); - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp); - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&se->pre, &block); - } - else - { - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->pre, &loop.post); - } - gfc_cleanup_loop (&loop); - - se->expr = convert (type, pos); -} - -/* Emit code for findloc. */ - -static void -gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) -{ - gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg, - *kind_arg, *back_arg; - gfc_expr *value_expr; - int ikind; - tree resvar; - stmtblock_t block; - stmtblock_t body; - stmtblock_t loopblock; - tree type; - tree tmp; - tree found; - tree forward_branch = NULL_TREE; - tree back_branch; - gfc_loopinfo loop; - gfc_ss *arrayss; - gfc_ss *maskss; - gfc_se arrayse; - gfc_se valuese; - gfc_se maskse; - gfc_se backse; - tree exit_label; - gfc_expr *maskexpr; - tree offset; - int i; - bool optional_mask; - - array_arg = expr->value.function.actual; - value_arg = array_arg->next; - dim_arg = value_arg->next; - mask_arg = dim_arg->next; - kind_arg = mask_arg->next; - back_arg = kind_arg->next; - - /* Remove kind and set ikind. */ - if (kind_arg->expr) - { - ikind = mpz_get_si (kind_arg->expr->value.integer); - gfc_free_expr (kind_arg->expr); - kind_arg->expr = NULL; - } - else - ikind = gfc_default_integer_kind; - - value_expr = value_arg->expr; - - /* Unless it's a string, pass VALUE by value. */ - if (value_expr->ts.type != BT_CHARACTER) - value_arg->name = "%VAL"; - - /* Pass BACK argument by value. */ - back_arg->name = "%VAL"; - - /* Call the library if we have a character function or if - rank > 0. */ - if (se->ss || array_arg->expr->ts.type == BT_CHARACTER) - { - se->ignore_optional = 1; - if (expr->rank == 0) - { - /* Remove dim argument. */ - gfc_free_expr (dim_arg->expr); - dim_arg->expr = NULL; - } - gfc_conv_intrinsic_funcall (se, expr); - return; - } - - type = gfc_get_int_type (ikind); - - /* Initialize the result. */ - resvar = gfc_create_var (gfc_array_index_type, "pos"); - gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0)); - offset = gfc_create_var (gfc_array_index_type, "offset"); - - maskexpr = mask_arg->expr; - optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE - && maskexpr->symtree->n.sym->attr.dummy - && maskexpr->symtree->n.sym->attr.optional; - - /* Generate two loops, one for BACK=.true. and one for BACK=.false. */ - - for (i = 0 ; i < 2; i++) - { - /* Walk the arguments. */ - arrayss = gfc_walk_expr (array_arg->expr); - gcc_assert (arrayss != gfc_ss_terminator); - - if (maskexpr && maskexpr->rank != 0) - { - maskss = gfc_walk_expr (maskexpr); - gcc_assert (maskss != gfc_ss_terminator); - } - else - maskss = NULL; - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - - /* We add the mask first because the number of iterations is - taken from the last ss, and this breaks if an absent - optional argument is used for mask. */ - - if (maskss) - gfc_add_ss_to_loop (&loop, maskss); - gfc_add_ss_to_loop (&loop, arrayss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - /* Calculate the offset. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, loop.from[0]); - gfc_add_modify (&loop.pre, offset, tmp); - - gfc_mark_ss_chain_used (arrayss, 1); - if (maskss) - gfc_mark_ss_chain_used (maskss, 1); - - /* The first loop is for BACK=.true. */ - if (i == 0) - loop.reverse[0] = GFC_REVERSE_SET; - - /* Generate the loop body. */ - gfc_start_scalarized_body (&loop, &body); - - /* If we have an array mask, only add the element if it is - set. */ - if (maskss) - { - gfc_init_se (&maskse, NULL); - gfc_copy_loopinfo_to_se (&maskse, &loop); - maskse.ss = maskss; - gfc_conv_expr_val (&maskse, maskexpr); - gfc_add_block_to_block (&body, &maskse.pre); - } - - /* If the condition matches then set the return value. */ - gfc_start_block (&block); - - /* Add the offset. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (resvar), - loop.loopvar[0], offset); - gfc_add_modify (&block, resvar, tmp); - /* And break out of the loop. */ - tmp = build1_v (GOTO_EXPR, exit_label); - gfc_add_expr_to_block (&block, tmp); - - found = gfc_finish_block (&block); - - /* Check this element. */ - gfc_init_se (&arrayse, NULL); - gfc_copy_loopinfo_to_se (&arrayse, &loop); - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, array_arg->expr); - gfc_add_block_to_block (&body, &arrayse.pre); - - gfc_init_se (&valuese, NULL); - gfc_conv_expr_val (&valuese, value_arg->expr); - gfc_add_block_to_block (&body, &valuese.pre); - - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - arrayse.expr, valuese.expr); - - tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); - if (maskss) - { - /* We enclose the above in if (mask) {...}. If the mask is - an optional argument, generate IF (.NOT. PRESENT(MASK) - .OR. MASK(I)). */ - - tree ifmask; - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&body, tmp); - gfc_add_block_to_block (&body, &arrayse.post); - - gfc_trans_scalarizing_loops (&loop, &body); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&loop.pre, tmp); - gfc_start_block (&loopblock); - gfc_add_block_to_block (&loopblock, &loop.pre); - gfc_add_block_to_block (&loopblock, &loop.post); - if (i == 0) - forward_branch = gfc_finish_block (&loopblock); - else - back_branch = gfc_finish_block (&loopblock); - - gfc_cleanup_loop (&loop); - } - - /* Enclose the two loops in an IF statement. */ - - gfc_init_se (&backse, NULL); - gfc_conv_expr_val (&backse, back_arg->expr); - gfc_add_block_to_block (&se->pre, &backse.pre); - tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch); - - /* For a scalar mask, enclose the loop in an if statement. */ - if (maskexpr && maskss == NULL) - { - tree ifmask; - tree if_stmt; - - gfc_init_se (&maskse, NULL); - gfc_conv_expr_val (&maskse, maskexpr); - gfc_init_block (&block); - gfc_add_expr_to_block (&block, maskse.expr); - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - if_stmt = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, if_stmt); - tmp = gfc_finish_block (&block); - } - - gfc_add_expr_to_block (&se->pre, tmp); - se->expr = convert (type, resvar); - -} - -/* Emit code for minval or maxval intrinsic. There are many different cases - we need to handle. For performance reasons we sometimes create two - loops instead of one, where the second one is much simpler. - Examples for minval intrinsic: - 1) Result is an array, a call is generated - 2) Array mask is used and NaNs need to be supported, rank 1: - limit = Infinity; - nonempty = false; - S = from; - while (S <= to) { - if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; } - S++; - } - limit = nonempty ? NaN : huge (limit); - lab: - while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; } - 3) NaNs need to be supported, but it is known at compile time or cheaply - at runtime whether array is nonempty or not, rank 1: - limit = Infinity; - S = from; - while (S <= to) { if (a[S] <= limit) goto lab; S++; } - limit = (from <= to) ? NaN : huge (limit); - lab: - while (S <= to) { limit = min (a[S], limit); S++; } - 4) Array mask is used and NaNs need to be supported, rank > 1: - limit = Infinity; - nonempty = false; - fast = false; - S1 = from1; - while (S1 <= to1) { - S2 = from2; - while (S2 <= to2) { - if (mask[S1][S2]) { - if (fast) limit = min (a[S1][S2], limit); - else { - nonempty = true; - if (a[S1][S2] <= limit) { - limit = a[S1][S2]; - fast = true; - } - } - } - S2++; - } - S1++; - } - if (!fast) - limit = nonempty ? NaN : huge (limit); - 5) NaNs need to be supported, but it is known at compile time or cheaply - at runtime whether array is nonempty or not, rank > 1: - limit = Infinity; - fast = false; - S1 = from1; - while (S1 <= to1) { - S2 = from2; - while (S2 <= to2) { - if (fast) limit = min (a[S1][S2], limit); - else { - if (a[S1][S2] <= limit) { - limit = a[S1][S2]; - fast = true; - } - } - S2++; - } - S1++; - } - if (!fast) - limit = (nonempty_array) ? NaN : huge (limit); - 6) NaNs aren't supported, but infinities are. Array mask is used: - limit = Infinity; - nonempty = false; - S = from; - while (S <= to) { - if (mask[S]) { nonempty = true; limit = min (a[S], limit); } - S++; - } - limit = nonempty ? limit : huge (limit); - 7) Same without array mask: - limit = Infinity; - S = from; - while (S <= to) { limit = min (a[S], limit); S++; } - limit = (from <= to) ? limit : huge (limit); - 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER): - limit = huge (limit); - S = from; - while (S <= to) { limit = min (a[S], limit); S++); } - (or - while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; } - with array mask instead). - For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional, - setting limit = huge (limit); in the else branch. */ - -static void -gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) -{ - tree limit; - tree type; - tree tmp; - tree ifbody; - tree nonempty; - tree nonempty_var; - tree lab; - tree fast; - tree huge_cst = NULL, nan_cst = NULL; - stmtblock_t body; - stmtblock_t block, block2; - gfc_loopinfo loop; - gfc_actual_arglist *actual; - gfc_ss *arrayss; - gfc_ss *maskss; - gfc_se arrayse; - gfc_se maskse; - gfc_expr *arrayexpr; - gfc_expr *maskexpr; - int n; - bool optional_mask; - - if (se->ss) - { - gfc_conv_intrinsic_funcall (se, expr); - return; - } - - actual = expr->value.function.actual; - arrayexpr = actual->expr; - - if (arrayexpr->ts.type == BT_CHARACTER) - { - gfc_actual_arglist *dim = actual->next; - if (expr->rank == 0 && dim->expr != 0) - { - gfc_free_expr (dim->expr); - dim->expr = NULL; - } - gfc_conv_intrinsic_funcall (se, expr); - return; - } - - type = gfc_typenode_for_spec (&expr->ts); - /* Initialize the result. */ - limit = gfc_create_var (type, "limit"); - n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false); - switch (expr->ts.type) - { - case BT_REAL: - huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, - expr->ts.kind, 0); - if (HONOR_INFINITIES (DECL_MODE (limit))) - { - REAL_VALUE_TYPE real; - real_inf (&real); - tmp = build_real (type, real); - } - else - tmp = huge_cst; - if (HONOR_NANS (DECL_MODE (limit))) - nan_cst = gfc_build_nan (type, ""); - break; - - case BT_INTEGER: - tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind); - break; - - default: - gcc_unreachable (); - } - - /* We start with the most negative possible value for MAXVAL, and the most - positive possible value for MINVAL. The most negative possible value is - -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive - possible value is HUGE in both cases. */ - if (op == GT_EXPR) - { - tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); - if (huge_cst) - huge_cst = fold_build1_loc (input_location, NEGATE_EXPR, - TREE_TYPE (huge_cst), huge_cst); - } - - if (op == GT_EXPR && expr->ts.type == BT_INTEGER) - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), - tmp, build_int_cst (type, 1)); - - gfc_add_modify (&se->pre, limit, tmp); - - /* Walk the arguments. */ - arrayss = gfc_walk_expr (arrayexpr); - gcc_assert (arrayss != gfc_ss_terminator); - - actual = actual->next->next; - gcc_assert (actual); - maskexpr = actual->expr; - optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE - && maskexpr->symtree->n.sym->attr.dummy - && maskexpr->symtree->n.sym->attr.optional; - nonempty = NULL; - if (maskexpr && maskexpr->rank != 0) - { - maskss = gfc_walk_expr (maskexpr); - gcc_assert (maskss != gfc_ss_terminator); - } - else - { - mpz_t asize; - if (gfc_array_size (arrayexpr, &asize)) - { - nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); - mpz_clear (asize); - nonempty = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, nonempty, - gfc_index_zero_node); - } - maskss = NULL; - } - - /* Initialize the scalarizer. */ - gfc_init_loopinfo (&loop); - - /* We add the mask first because the number of iterations is taken - from the last ss, and this breaks if an absent optional argument - is used for mask. */ - - if (maskss) - gfc_add_ss_to_loop (&loop, maskss); - gfc_add_ss_to_loop (&loop, arrayss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - - /* The code generated can have more than one loop in sequence (see the - comment at the function header). This doesn't work well with the - scalarizer, which changes arrays' offset when the scalarization loops - are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val - are currently inlined in the scalar case only. As there is no dependency - to care about in that case, there is no temporary, so that we can use the - scalarizer temporary code to handle multiple loops. Thus, we set temp_dim - here, we call gfc_mark_ss_chain_used with flag=3 later, and we use - gfc_trans_scalarized_loop_boundary even later to restore offset. - TODO: this prevents inlining of rank > 0 minmaxval calls, so this - should eventually go away. We could either create two loops properly, - or find another way to save/restore the array offsets between the two - loops (without conflicting with temporary management), or use a single - loop minmaxval implementation. See PR 31067. */ - loop.temp_dim = loop.dimen; - gfc_conv_loop_setup (&loop, &expr->where); - - if (nonempty == NULL && maskss == NULL - && loop.dimen == 1 && loop.from[0] && loop.to[0]) - nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - loop.from[0], loop.to[0]); - nonempty_var = NULL; - if (nonempty == NULL - && (HONOR_INFINITIES (DECL_MODE (limit)) - || HONOR_NANS (DECL_MODE (limit)))) - { - nonempty_var = gfc_create_var (logical_type_node, "nonempty"); - gfc_add_modify (&se->pre, nonempty_var, logical_false_node); - nonempty = nonempty_var; - } - lab = NULL; - fast = NULL; - if (HONOR_NANS (DECL_MODE (limit))) - { - if (loop.dimen == 1) - { - lab = gfc_build_label_decl (NULL_TREE); - TREE_USED (lab) = 1; - } - else - { - fast = gfc_create_var (logical_type_node, "fast"); - gfc_add_modify (&se->pre, fast, logical_false_node); - } - } - - gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1); - if (maskss) - gfc_mark_ss_chain_used (maskss, lab ? 3 : 1); - /* Generate the loop body. */ - gfc_start_scalarized_body (&loop, &body); - - /* If we have a mask, only add this element if the mask is set. */ - if (maskss) - { - gfc_init_se (&maskse, NULL); - gfc_copy_loopinfo_to_se (&maskse, &loop); - maskse.ss = maskss; - gfc_conv_expr_val (&maskse, maskexpr); - gfc_add_block_to_block (&body, &maskse.pre); - - gfc_start_block (&block); - } - else - gfc_init_block (&block); - - /* Compare with the current limit. */ - gfc_init_se (&arrayse, NULL); - gfc_copy_loopinfo_to_se (&arrayse, &loop); - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, arrayexpr); - gfc_add_block_to_block (&block, &arrayse.pre); - - gfc_init_block (&block2); - - if (nonempty_var) - gfc_add_modify (&block2, nonempty_var, logical_true_node); - - if (HONOR_NANS (DECL_MODE (limit))) - { - tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, - logical_type_node, arrayse.expr, limit); - if (lab) - ifbody = build1_v (GOTO_EXPR, lab); - else - { - stmtblock_t ifblock; - - gfc_init_block (&ifblock); - gfc_add_modify (&ifblock, limit, arrayse.expr); - gfc_add_modify (&ifblock, fast, logical_true_node); - ifbody = gfc_finish_block (&ifblock); - } - tmp = build3_v (COND_EXPR, tmp, ifbody, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block2, tmp); - } - else - { - /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or - signed zeros. */ - tmp = fold_build2_loc (input_location, - op == GT_EXPR ? MAX_EXPR : MIN_EXPR, - type, arrayse.expr, limit); - gfc_add_modify (&block2, limit, tmp); - } - - if (fast) - { - tree elsebody = gfc_finish_block (&block2); - - /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or - signed zeros. */ - if (HONOR_NANS (DECL_MODE (limit))) - { - tmp = fold_build2_loc (input_location, op, logical_type_node, - arrayse.expr, limit); - ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); - ifbody = build3_v (COND_EXPR, tmp, ifbody, - build_empty_stmt (input_location)); - } - else - { - tmp = fold_build2_loc (input_location, - op == GT_EXPR ? MAX_EXPR : MIN_EXPR, - type, arrayse.expr, limit); - ifbody = build2_v (MODIFY_EXPR, limit, tmp); - } - tmp = build3_v (COND_EXPR, fast, ifbody, elsebody); - gfc_add_expr_to_block (&block, tmp); - } - else - gfc_add_block_to_block (&block, &block2); - - gfc_add_block_to_block (&block, &arrayse.post); - - tmp = gfc_finish_block (&block); - if (maskss) - { - /* We enclose the above in if (mask) {...}. If the mask is an - optional argument, generate IF (.NOT. PRESENT(MASK) - .OR. MASK(I)). */ - tree ifmask; - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&body, tmp); - - if (lab) - { - gfc_trans_scalarized_loop_boundary (&loop, &body); - - tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, - nan_cst, huge_cst); - gfc_add_modify (&loop.code[0], limit, tmp); - gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab)); - - /* If we have a mask, only add this element if the mask is set. */ - if (maskss) - { - gfc_init_se (&maskse, NULL); - gfc_copy_loopinfo_to_se (&maskse, &loop); - maskse.ss = maskss; - gfc_conv_expr_val (&maskse, maskexpr); - gfc_add_block_to_block (&body, &maskse.pre); - - gfc_start_block (&block); - } - else - gfc_init_block (&block); - - /* Compare with the current limit. */ - gfc_init_se (&arrayse, NULL); - gfc_copy_loopinfo_to_se (&arrayse, &loop); - arrayse.ss = arrayss; - gfc_conv_expr_val (&arrayse, arrayexpr); - gfc_add_block_to_block (&block, &arrayse.pre); - - /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or - signed zeros. */ - if (HONOR_NANS (DECL_MODE (limit))) - { - tmp = fold_build2_loc (input_location, op, logical_type_node, - arrayse.expr, limit); - ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); - tmp = build3_v (COND_EXPR, tmp, ifbody, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - else - { - tmp = fold_build2_loc (input_location, - op == GT_EXPR ? MAX_EXPR : MIN_EXPR, - type, arrayse.expr, limit); - gfc_add_modify (&block, limit, tmp); - } - - gfc_add_block_to_block (&block, &arrayse.post); - - tmp = gfc_finish_block (&block); - if (maskss) - /* We enclose the above in if (mask) {...}. */ - { - tree ifmask; - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = build3_v (COND_EXPR, ifmask, tmp, - build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&body, tmp); - /* Avoid initializing loopvar[0] again, it should be left where - it finished by the first loop. */ - loop.from[0] = loop.loopvar[0]; - } - gfc_trans_scalarizing_loops (&loop, &body); - - if (fast) - { - tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, - nan_cst, huge_cst); - ifbody = build2_v (MODIFY_EXPR, limit, tmp); - tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location), - ifbody); - gfc_add_expr_to_block (&loop.pre, tmp); - } - else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab) - { - tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit, - huge_cst); - gfc_add_modify (&loop.pre, limit, tmp); - } - - /* For a scalar mask, enclose the loop in an if statement. */ - if (maskexpr && maskss == NULL) - { - tree else_stmt; - tree ifmask; - - gfc_init_se (&maskse, NULL); - gfc_conv_expr_val (&maskse, maskexpr); - gfc_init_block (&block); - gfc_add_block_to_block (&block, &loop.pre); - gfc_add_block_to_block (&block, &loop.post); - tmp = gfc_finish_block (&block); - - if (HONOR_INFINITIES (DECL_MODE (limit))) - else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst); - else - else_stmt = build_empty_stmt (input_location); - - ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); - tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt); - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&se->pre, &block); - } - else - { - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->pre, &loop.post); - } - - gfc_cleanup_loop (&loop); - - se->expr = limit; -} - -/* BTEST (i, pos) = (i & (1 << pos)) != 0. */ -static void -gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) -{ - tree args[2]; - tree type; - tree tmp; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - type = TREE_TYPE (args[0]); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, args[1], - build_int_cst (TREE_TYPE (args[1]), 0)); - tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); - tree above = fold_build2_loc (input_location, GE_EXPR, - logical_type_node, args[1], nbits); - tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "POS argument (%ld) out of range 0:%ld " - "in intrinsic BTEST", - fold_convert (long_integer_type_node, args[1]), - fold_convert (long_integer_type_node, nbits)); - } - - tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, - build_int_cst (type, 1), args[1]); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, - build_int_cst (type, 0)); - type = gfc_typenode_for_spec (&expr->ts); - se->expr = convert (type, tmp); -} - - -/* Generate code for BGE, BGT, BLE and BLT intrinsics. */ -static void -gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op) -{ - tree args[2]; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - - /* Convert both arguments to the unsigned type of the same size. */ - args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]); - args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]); - - /* If they have unequal type size, convert to the larger one. */ - if (TYPE_PRECISION (TREE_TYPE (args[0])) - > TYPE_PRECISION (TREE_TYPE (args[1]))) - args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); - else if (TYPE_PRECISION (TREE_TYPE (args[1])) - > TYPE_PRECISION (TREE_TYPE (args[0]))) - args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); - - /* Now, we compare them. */ - se->expr = fold_build2_loc (input_location, op, logical_type_node, - args[0], args[1]); -} - - -/* Generate code to perform the specified operation. */ -static void -gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op) -{ - tree args[2]; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]), - args[0], args[1]); -} - -/* Bitwise not. */ -static void -gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) -{ - tree arg; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR, - TREE_TYPE (arg), arg); -} - -/* Set or clear a single bit. */ -static void -gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) -{ - tree args[2]; - tree type; - tree tmp; - enum tree_code op; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - type = TREE_TYPE (args[0]); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, args[1], - build_int_cst (TREE_TYPE (args[1]), 0)); - tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); - tree above = fold_build2_loc (input_location, GE_EXPR, - logical_type_node, args[1], nbits); - tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - size_t len_name = strlen (expr->value.function.isym->name); - char *name = XALLOCAVEC (char, len_name + 1); - for (size_t i = 0; i < len_name; i++) - name[i] = TOUPPER (expr->value.function.isym->name[i]); - name[len_name] = '\0'; - tree iname = gfc_build_addr_expr (pchar_type_node, - gfc_build_cstring_const (name)); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "POS argument (%ld) out of range 0:%ld " - "in intrinsic %s", - fold_convert (long_integer_type_node, args[1]), - fold_convert (long_integer_type_node, nbits), - iname); - } - - tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, - build_int_cst (type, 1), args[1]); - if (set) - op = BIT_IOR_EXPR; - else - { - op = BIT_AND_EXPR; - tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp); - } - se->expr = fold_build2_loc (input_location, op, type, args[0], tmp); -} - -/* Extract a sequence of bits. - IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */ -static void -gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) -{ - tree args[3]; - tree type; - tree tmp; - tree mask; - - gfc_conv_intrinsic_function_args (se, expr, args, 3); - type = TREE_TYPE (args[0]); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree tmp1 = fold_convert (long_integer_type_node, args[1]); - tree tmp2 = fold_convert (long_integer_type_node, args[2]); - tree nbits = build_int_cst (long_integer_type_node, - TYPE_PRECISION (type)); - tree below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, args[1], - build_int_cst (TREE_TYPE (args[1]), 0)); - tree above = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, tmp1, nbits); - tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "POS argument (%ld) out of range 0:%ld " - "in intrinsic IBITS", tmp1, nbits); - below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, args[2], - build_int_cst (TREE_TYPE (args[2]), 0)); - above = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, tmp2, nbits); - scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "LEN argument (%ld) out of range 0:%ld " - "in intrinsic IBITS", tmp2, nbits); - above = fold_build2_loc (input_location, PLUS_EXPR, - long_integer_type_node, tmp1, tmp2); - scond = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, above, nbits); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) " - "in intrinsic IBITS", tmp1, tmp2, nbits); - } - - mask = build_int_cst (type, -1); - mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]); - mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask); - - tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]); - - se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask); -} - -static void -gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, - bool arithmetic) -{ - tree args[2], type, num_bits, cond; - tree bigshift; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - - args[0] = gfc_evaluate_now (args[0], &se->pre); - args[1] = gfc_evaluate_now (args[1], &se->pre); - type = TREE_TYPE (args[0]); - - if (!arithmetic) - args[0] = fold_convert (unsigned_type_for (type), args[0]); - else - gcc_assert (right_shift); - - se->expr = fold_build2_loc (input_location, - right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, - TREE_TYPE (args[0]), args[0], args[1]); - - if (!arithmetic) - se->expr = fold_convert (type, se->expr); - - if (!arithmetic) - bigshift = build_int_cst (type, 0); - else - { - tree nonneg = fold_build2_loc (input_location, GE_EXPR, - logical_type_node, args[0], - build_int_cst (TREE_TYPE (args[0]), 0)); - bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg, - build_int_cst (type, 0), - build_int_cst (type, -1)); - } - - /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas - gcc requires a shift width < BIT_SIZE(I), so we have to catch this - special case. */ - num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, args[1], - build_int_cst (TREE_TYPE (args[1]), 0)); - tree above = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, args[1], num_bits); - tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - size_t len_name = strlen (expr->value.function.isym->name); - char *name = XALLOCAVEC (char, len_name + 1); - for (size_t i = 0; i < len_name; i++) - name[i] = TOUPPER (expr->value.function.isym->name[i]); - name[len_name] = '\0'; - tree iname = gfc_build_addr_expr (pchar_type_node, - gfc_build_cstring_const (name)); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "SHIFT argument (%ld) out of range 0:%ld " - "in intrinsic %s", - fold_convert (long_integer_type_node, args[1]), - fold_convert (long_integer_type_node, num_bits), - iname); - } - - cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - args[1], num_bits); - - se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, - bigshift, se->expr); -} - -/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i)) - ? 0 - : ((shift >= 0) ? i << shift : i >> -shift) - where all shifts are logical shifts. */ -static void -gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) -{ - tree args[2]; - tree type; - tree utype; - tree tmp; - tree width; - tree num_bits; - tree cond; - tree lshift; - tree rshift; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - - args[0] = gfc_evaluate_now (args[0], &se->pre); - args[1] = gfc_evaluate_now (args[1], &se->pre); - - type = TREE_TYPE (args[0]); - utype = unsigned_type_for (type); - - width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]), - args[1]); - - /* Left shift if positive. */ - lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width); - - /* Right shift if negative. - We convert to an unsigned type because we want a logical shift. - The standard doesn't define the case of shifting negative - numbers, and we try to be compatible with other compilers, most - notably g77, here. */ - rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR, - utype, convert (utype, args[0]), width)); - - tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1], - build_int_cst (TREE_TYPE (args[1]), 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift); - - /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas - gcc requires a shift width < BIT_SIZE(I), so we have to catch this - special case. */ - num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree outside = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, width, num_bits); - gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where, - "SHIFT argument (%ld) out of range -%ld:%ld " - "in intrinsic ISHFT", - fold_convert (long_integer_type_node, args[1]), - fold_convert (long_integer_type_node, num_bits), - fold_convert (long_integer_type_node, num_bits)); - } - - cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width, - num_bits); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, - build_int_cst (type, 0), tmp); -} - - -/* Circular shift. AKA rotate or barrel shift. */ - -static void -gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) -{ - tree *args; - tree type; - tree tmp; - tree lrot; - tree rrot; - tree zero; - tree nbits; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, num_args); - - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - - type = TREE_TYPE (args[0]); - nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type)); - - if (num_args == 3) - { - /* Use a library function for the 3 parameter version. */ - tree int4type = gfc_get_int_type (4); - - /* We convert the first argument to at least 4 bytes, and - convert back afterwards. This removes the need for library - functions for all argument sizes, and function will be - aligned to at least 32 bits, so there's no loss. */ - if (expr->ts.kind < 4) - args[0] = convert (int4type, args[0]); - - /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would - need loads of library functions. They cannot have values > - BIT_SIZE (I) so the conversion is safe. */ - args[1] = convert (int4type, args[1]); - args[2] = convert (int4type, args[2]); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree size = fold_convert (long_integer_type_node, args[2]); - tree below = fold_build2_loc (input_location, LE_EXPR, - logical_type_node, size, - build_int_cst (TREE_TYPE (args[1]), 0)); - tree above = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, size, nbits); - tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "SIZE argument (%ld) out of range 1:%ld " - "in intrinsic ISHFTC", size, nbits); - tree width = fold_convert (long_integer_type_node, args[1]); - width = fold_build1_loc (input_location, ABS_EXPR, - long_integer_type_node, width); - scond = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, width, size); - gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, - "SHIFT argument (%ld) out of range -%ld:%ld " - "in intrinsic ISHFTC", - fold_convert (long_integer_type_node, args[1]), - size, size); - } - - switch (expr->ts.kind) - { - case 1: - case 2: - case 4: - tmp = gfor_fndecl_math_ishftc4; - break; - case 8: - tmp = gfor_fndecl_math_ishftc8; - break; - case 16: - tmp = gfor_fndecl_math_ishftc16; - break; - default: - gcc_unreachable (); - } - se->expr = build_call_expr_loc (input_location, - tmp, 3, args[0], args[1], args[2]); - /* Convert the result back to the original type, if we extended - the first argument's width above. */ - if (expr->ts.kind < 4) - se->expr = convert (type, se->expr); - - return; - } - - /* Evaluate arguments only once. */ - args[0] = gfc_evaluate_now (args[0], &se->pre); - args[1] = gfc_evaluate_now (args[1], &se->pre); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree width = fold_convert (long_integer_type_node, args[1]); - width = fold_build1_loc (input_location, ABS_EXPR, - long_integer_type_node, width); - tree outside = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, width, nbits); - gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where, - "SHIFT argument (%ld) out of range -%ld:%ld " - "in intrinsic ISHFTC", - fold_convert (long_integer_type_node, args[1]), - nbits, nbits); - } - - /* Rotate left if positive. */ - lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]); - - /* Rotate right if negative. */ - tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]), - args[1]); - rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp); - - zero = build_int_cst (TREE_TYPE (args[1]), 0); - tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1], - zero); - rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot); - - /* Do nothing if shift == 0. */ - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1], - zero); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0], - rrot); -} - - -/* LEADZ (i) = (i == 0) ? BIT_SIZE (i) - : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i)) - - The conditional expression is necessary because the result of LEADZ(0) - is defined, but the result of __builtin_clz(0) is undefined for most - targets. - - For INTEGER kinds smaller than the C 'int' type, we have to subtract the - difference in bit size between the argument of LEADZ and the C int. */ - -static void -gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) -{ - tree arg; - tree arg_type; - tree cond; - tree result_type; - tree leadz; - tree bit_size; - tree tmp; - tree func; - int s, argsize; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - argsize = TYPE_PRECISION (TREE_TYPE (arg)); - - /* Which variant of __builtin_clz* should we call? */ - if (argsize <= INT_TYPE_SIZE) - { - arg_type = unsigned_type_node; - func = builtin_decl_explicit (BUILT_IN_CLZ); - } - else if (argsize <= LONG_TYPE_SIZE) - { - arg_type = long_unsigned_type_node; - func = builtin_decl_explicit (BUILT_IN_CLZL); - } - else if (argsize <= LONG_LONG_TYPE_SIZE) - { - arg_type = long_long_unsigned_type_node; - func = builtin_decl_explicit (BUILT_IN_CLZLL); - } - else - { - gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); - arg_type = gfc_build_uint_type (argsize); - func = NULL_TREE; - } - - /* Convert the actual argument twice: first, to the unsigned type of the - same size; then, to the proper argument type for the built-in - function. But the return type is of the default INTEGER kind. */ - arg = fold_convert (gfc_build_uint_type (argsize), arg); - arg = fold_convert (arg_type, arg); - arg = gfc_evaluate_now (arg, &se->pre); - result_type = gfc_get_int_type (gfc_default_integer_kind); - - /* Compute LEADZ for the case i .ne. 0. */ - if (func) - { - s = TYPE_PRECISION (arg_type) - argsize; - tmp = fold_convert (result_type, - build_call_expr_loc (input_location, func, - 1, arg)); - leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type, - tmp, build_int_cst (result_type, s)); - } - else - { - /* We end up here if the argument type is larger than 'long long'. - We generate this code: - - if (x & (ULL_MAX << ULL_SIZE) != 0) - return clzll ((unsigned long long) (x >> ULLSIZE)); - else - return ULL_SIZE + clzll ((unsigned long long) x); - where ULL_MAX is the largest value that a ULL_MAX can hold - (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE - is the bit-size of the long long type (64 in this example). */ - tree ullsize, ullmax, tmp1, tmp2, btmp; - - ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); - ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, - long_long_unsigned_type_node, - build_int_cst (long_long_unsigned_type_node, - 0)); - - cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type, - fold_convert (arg_type, ullmax), ullsize); - cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, - arg, cond); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - cond, build_int_cst (arg_type, 0)); - - tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, - arg, ullsize); - tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); - btmp = builtin_decl_explicit (BUILT_IN_CLZLL); - tmp1 = fold_convert (result_type, - build_call_expr_loc (input_location, btmp, 1, tmp1)); - - tmp2 = fold_convert (long_long_unsigned_type_node, arg); - btmp = builtin_decl_explicit (BUILT_IN_CLZLL); - tmp2 = fold_convert (result_type, - build_call_expr_loc (input_location, btmp, 1, tmp2)); - tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type, - tmp2, ullsize); - - leadz = fold_build3_loc (input_location, COND_EXPR, result_type, - cond, tmp1, tmp2); - } - - /* Build BIT_SIZE. */ - bit_size = build_int_cst (result_type, argsize); - - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - arg, build_int_cst (arg_type, 0)); - se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, - bit_size, leadz); -} - - -/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i) - - The conditional expression is necessary because the result of TRAILZ(0) - is defined, but the result of __builtin_ctz(0) is undefined for most - targets. */ - -static void -gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) -{ - tree arg; - tree arg_type; - tree cond; - tree result_type; - tree trailz; - tree bit_size; - tree func; - int argsize; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - argsize = TYPE_PRECISION (TREE_TYPE (arg)); - - /* Which variant of __builtin_ctz* should we call? */ - if (argsize <= INT_TYPE_SIZE) - { - arg_type = unsigned_type_node; - func = builtin_decl_explicit (BUILT_IN_CTZ); - } - else if (argsize <= LONG_TYPE_SIZE) - { - arg_type = long_unsigned_type_node; - func = builtin_decl_explicit (BUILT_IN_CTZL); - } - else if (argsize <= LONG_LONG_TYPE_SIZE) - { - arg_type = long_long_unsigned_type_node; - func = builtin_decl_explicit (BUILT_IN_CTZLL); - } - else - { - gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); - arg_type = gfc_build_uint_type (argsize); - func = NULL_TREE; - } - - /* Convert the actual argument twice: first, to the unsigned type of the - same size; then, to the proper argument type for the built-in - function. But the return type is of the default INTEGER kind. */ - arg = fold_convert (gfc_build_uint_type (argsize), arg); - arg = fold_convert (arg_type, arg); - arg = gfc_evaluate_now (arg, &se->pre); - result_type = gfc_get_int_type (gfc_default_integer_kind); - - /* Compute TRAILZ for the case i .ne. 0. */ - if (func) - trailz = fold_convert (result_type, build_call_expr_loc (input_location, - func, 1, arg)); - else - { - /* We end up here if the argument type is larger than 'long long'. - We generate this code: - - if ((x & ULL_MAX) == 0) - return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE)); - else - return ctzll ((unsigned long long) x); - - where ULL_MAX is the largest value that a ULL_MAX can hold - (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE - is the bit-size of the long long type (64 in this example). */ - tree ullsize, ullmax, tmp1, tmp2, btmp; - - ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); - ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, - long_long_unsigned_type_node, - build_int_cst (long_long_unsigned_type_node, 0)); - - cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg, - fold_convert (arg_type, ullmax)); - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond, - build_int_cst (arg_type, 0)); - - tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, - arg, ullsize); - tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); - btmp = builtin_decl_explicit (BUILT_IN_CTZLL); - tmp1 = fold_convert (result_type, - build_call_expr_loc (input_location, btmp, 1, tmp1)); - tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type, - tmp1, ullsize); - - tmp2 = fold_convert (long_long_unsigned_type_node, arg); - btmp = builtin_decl_explicit (BUILT_IN_CTZLL); - tmp2 = fold_convert (result_type, - build_call_expr_loc (input_location, btmp, 1, tmp2)); - - trailz = fold_build3_loc (input_location, COND_EXPR, result_type, - cond, tmp1, tmp2); - } - - /* Build BIT_SIZE. */ - bit_size = build_int_cst (result_type, argsize); - - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - arg, build_int_cst (arg_type, 0)); - se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, - bit_size, trailz); -} - -/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR; - for types larger than "long long", we call the long long built-in for - the lower and higher bits and combine the result. */ - -static void -gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity) -{ - tree arg; - tree arg_type; - tree result_type; - tree func; - int argsize; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - argsize = TYPE_PRECISION (TREE_TYPE (arg)); - result_type = gfc_get_int_type (gfc_default_integer_kind); - - /* Which variant of the builtin should we call? */ - if (argsize <= INT_TYPE_SIZE) - { - arg_type = unsigned_type_node; - func = builtin_decl_explicit (parity - ? BUILT_IN_PARITY - : BUILT_IN_POPCOUNT); - } - else if (argsize <= LONG_TYPE_SIZE) - { - arg_type = long_unsigned_type_node; - func = builtin_decl_explicit (parity - ? BUILT_IN_PARITYL - : BUILT_IN_POPCOUNTL); - } - else if (argsize <= LONG_LONG_TYPE_SIZE) - { - arg_type = long_long_unsigned_type_node; - func = builtin_decl_explicit (parity - ? BUILT_IN_PARITYLL - : BUILT_IN_POPCOUNTLL); - } - else - { - /* Our argument type is larger than 'long long', which mean none - of the POPCOUNT builtins covers it. We thus call the 'long long' - variant multiple times, and add the results. */ - tree utype, arg2, call1, call2; - - /* For now, we only cover the case where argsize is twice as large - as 'long long'. */ - gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); - - func = builtin_decl_explicit (parity - ? BUILT_IN_PARITYLL - : BUILT_IN_POPCOUNTLL); - - /* Convert it to an integer, and store into a variable. */ - utype = gfc_build_uint_type (argsize); - arg = fold_convert (utype, arg); - arg = gfc_evaluate_now (arg, &se->pre); - - /* Call the builtin twice. */ - call1 = build_call_expr_loc (input_location, func, 1, - fold_convert (long_long_unsigned_type_node, - arg)); - - arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg, - build_int_cst (utype, LONG_LONG_TYPE_SIZE)); - call2 = build_call_expr_loc (input_location, func, 1, - fold_convert (long_long_unsigned_type_node, - arg2)); - - /* Combine the results. */ - if (parity) - se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type, - call1, call2); - else - se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type, - call1, call2); - - return; - } - - /* Convert the actual argument twice: first, to the unsigned type of the - same size; then, to the proper argument type for the built-in - function. */ - arg = fold_convert (gfc_build_uint_type (argsize), arg); - arg = fold_convert (arg_type, arg); - - se->expr = fold_convert (result_type, - build_call_expr_loc (input_location, func, 1, arg)); -} - - -/* Process an intrinsic with unspecified argument-types that has an optional - argument (which could be of type character), e.g. EOSHIFT. For those, we - need to append the string length of the optional argument if it is not - present and the type is really character. - primary specifies the position (starting at 1) of the non-optional argument - specifying the type and optional gives the position of the optional - argument in the arglist. */ - -static void -conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, - unsigned primary, unsigned optional) -{ - gfc_actual_arglist* prim_arg; - gfc_actual_arglist* opt_arg; - unsigned cur_pos; - gfc_actual_arglist* arg; - gfc_symbol* sym; - vec *append_args; - - /* Find the two arguments given as position. */ - cur_pos = 0; - prim_arg = NULL; - opt_arg = NULL; - for (arg = expr->value.function.actual; arg; arg = arg->next) - { - ++cur_pos; - - if (cur_pos == primary) - prim_arg = arg; - if (cur_pos == optional) - opt_arg = arg; - - if (cur_pos >= primary && cur_pos >= optional) - break; - } - gcc_assert (prim_arg); - gcc_assert (prim_arg->expr); - gcc_assert (opt_arg); - - /* If we do have type CHARACTER and the optional argument is really absent, - append a dummy 0 as string length. */ - append_args = NULL; - if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr) - { - tree dummy; - - dummy = build_int_cst (gfc_charlen_type_node, 0); - vec_alloc (append_args, 1); - append_args->quick_push (dummy); - } - - /* Build the call itself. */ - gcc_assert (!se->ignore_optional); - sym = gfc_get_symbol_for_expr (expr, false); - gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, - append_args); - gfc_free_symbol (sym); -} - -/* The length of a character string. */ -static void -gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) -{ - tree len; - tree type; - tree decl; - gfc_symbol *sym; - gfc_se argse; - gfc_expr *arg; - - gcc_assert (!se->ss); - - arg = expr->value.function.actual->expr; - - type = gfc_typenode_for_spec (&expr->ts); - switch (arg->expr_type) - { - case EXPR_CONSTANT: - len = build_int_cst (gfc_charlen_type_node, arg->value.character.length); - break; - - case EXPR_ARRAY: - /* Obtain the string length from the function used by - trans-array.c(gfc_trans_array_constructor). */ - len = NULL_TREE; - get_array_ctor_strlen (&se->pre, arg->value.constructor, &len); - break; - - case EXPR_VARIABLE: - if (arg->ref == NULL - || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY)) - { - /* This doesn't catch all cases. - See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html - and the surrounding thread. */ - sym = arg->symtree->n.sym; - decl = gfc_get_symbol_decl (sym); - if (decl == current_function_decl && sym->attr.function - && (sym->result == sym)) - decl = gfc_get_fake_result_decl (sym, 0); - - len = sym->ts.u.cl->backend_decl; - gcc_assert (len); - break; - } - - /* Fall through. */ - - default: - gfc_init_se (&argse, se); - if (arg->rank == 0) - gfc_conv_expr (&argse, arg); - else - gfc_conv_expr_descriptor (&argse, arg); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - len = argse.string_length; - break; - } - se->expr = convert (type, len); -} - -/* The length of a character string not including trailing blanks. */ -static void -gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) -{ - int kind = expr->value.function.actual->expr->ts.kind; - tree args[2], type, fndecl; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - type = gfc_typenode_for_spec (&expr->ts); - - if (kind == 1) - fndecl = gfor_fndecl_string_len_trim; - else if (kind == 4) - fndecl = gfor_fndecl_string_len_trim_char4; - else - gcc_unreachable (); - - se->expr = build_call_expr_loc (input_location, - fndecl, 2, args[0], args[1]); - se->expr = convert (type, se->expr); -} - - -/* Returns the starting position of a substring within a string. */ - -static void -gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, - tree function) -{ - tree logical4_type_node = gfc_get_logical_type (4); - tree type; - tree fndecl; - tree *args; - unsigned int num_args; - - args = XALLOCAVEC (tree, 5); - - /* Get number of arguments; characters count double due to the - string length argument. Kind= is not passed to the library - and thus ignored. */ - if (expr->value.function.actual->next->next->expr == NULL) - num_args = 4; - else - num_args = 5; - - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - type = gfc_typenode_for_spec (&expr->ts); - - if (num_args == 4) - args[4] = build_int_cst (logical4_type_node, 0); - else - args[4] = convert (logical4_type_node, args[4]); - - fndecl = build_addr (function); - se->expr = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (function)), fndecl, - 5, args); - se->expr = convert (type, se->expr); - -} - -/* The ascii value for a single character. */ -static void -gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) -{ - tree args[3], type, pchartype; - int nargs; - - nargs = gfc_intrinsic_argument_list_length (expr); - gfc_conv_intrinsic_function_args (se, expr, args, nargs); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1]))); - pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind); - args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]); - type = gfc_typenode_for_spec (&expr->ts); - - se->expr = build_fold_indirect_ref_loc (input_location, - args[1]); - se->expr = convert (type, se->expr); -} - - -/* Intrinsic ISNAN calls __builtin_isnan. */ - -static void -gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr) -{ - tree arg; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISNAN), - 1, arg); - STRIP_TYPE_NOPS (se->expr); - se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - - -/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare - their argument against a constant integer value. */ - -static void -gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value) -{ - tree arg; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = fold_build2_loc (input_location, EQ_EXPR, - gfc_typenode_for_spec (&expr->ts), - arg, build_int_cst (TREE_TYPE (arg), value)); -} - - - -/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */ - -static void -gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) -{ - tree tsource; - tree fsource; - tree mask; - tree type; - tree len, len2; - tree *args; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, num_args); - - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - if (expr->ts.type != BT_CHARACTER) - { - tsource = args[0]; - fsource = args[1]; - mask = args[2]; - } - else - { - /* We do the same as in the non-character case, but the argument - list is different because of the string length arguments. We - also have to set the string length for the result. */ - len = args[0]; - tsource = args[1]; - len2 = args[2]; - fsource = args[3]; - mask = args[4]; - - gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2, - &se->pre); - se->string_length = len; - } - type = TREE_TYPE (tsource); - se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource, - fold_convert (type, fsource)); -} - - -/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */ - -static void -gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr) -{ - tree args[3], mask, type; - - gfc_conv_intrinsic_function_args (se, expr, args, 3); - mask = gfc_evaluate_now (args[2], &se->pre); - - type = TREE_TYPE (args[0]); - gcc_assert (TREE_TYPE (args[1]) == type); - gcc_assert (TREE_TYPE (mask) == type); - - args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask); - args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1], - fold_build1_loc (input_location, BIT_NOT_EXPR, - type, mask)); - se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type, - args[0], args[1]); -} - - -/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n) - MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */ - -static void -gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left) -{ - tree arg, allones, type, utype, res, cond, bitsize; - int i; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - arg = gfc_evaluate_now (arg, &se->pre); - - type = gfc_get_int_type (expr->ts.kind); - utype = unsigned_type_for (type); - - i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false); - bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size); - - allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, - build_int_cst (utype, 0)); - - if (left) - { - /* Left-justified mask. */ - res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg), - bitsize, arg); - res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, - fold_convert (utype, res)); - - /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly - smaller than type width. */ - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, - build_int_cst (TREE_TYPE (arg), 0)); - res = fold_build3_loc (input_location, COND_EXPR, utype, cond, - build_int_cst (utype, 0), res); - } - else - { - /* Right-justified mask. */ - res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, - fold_convert (utype, arg)); - res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res); - - /* Special case agr == bit_size, because SHIFT_EXPR wants a shift - strictly smaller than type width. */ - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - arg, bitsize); - res = fold_build3_loc (input_location, COND_EXPR, utype, - cond, allones, res); - } - - se->expr = fold_convert (type, res); -} - - -/* FRACTION (s) is translated into: - isfinite (s) ? frexp (s, &dummy_int) : NaN */ -static void -gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) -{ - tree arg, type, tmp, res, frexp, cond; - - frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - arg = gfc_evaluate_now (arg, &se->pre); - - cond = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISFINITE), - 1, arg); - - tmp = gfc_create_var (integer_type_node, NULL); - res = build_call_expr_loc (input_location, frexp, 2, - fold_convert (type, arg), - gfc_build_addr_expr (NULL_TREE, tmp)); - res = fold_convert (type, res); - - se->expr = fold_build3_loc (input_location, COND_EXPR, type, - cond, res, gfc_build_nan (type, "")); -} - - -/* NEAREST (s, dir) is translated into - tmp = copysign (HUGE_VAL, dir); - return nextafter (s, tmp); - */ -static void -gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) -{ - tree args[2], type, tmp, nextafter, copysign, huge_val; - - nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind); - copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, args, 2); - - huge_val = gfc_build_inf_or_huge (type, expr->ts.kind); - tmp = build_call_expr_loc (input_location, copysign, 2, huge_val, - fold_convert (type, args[1])); - se->expr = build_call_expr_loc (input_location, nextafter, 2, - fold_convert (type, args[0]), tmp); - se->expr = fold_convert (type, se->expr); -} - - -/* SPACING (s) is translated into - int e; - if (!isfinite (s)) - res = NaN; - else if (s == 0) - res = tiny; - else - { - frexp (s, &e); - e = e - prec; - e = MAX_EXPR (e, emin); - res = scalbn (1., e); - } - return res; - - where prec is the precision of s, gfc_real_kinds[k].digits, - emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1, - and tiny is tiny(s), gfc_real_kinds[k].tiny. */ - -static void -gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) -{ - tree arg, type, prec, emin, tiny, res, e; - tree cond, nan, tmp, frexp, scalbn; - int k; - stmtblock_t block; - - k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); - prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits); - emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1); - tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0); - - frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); - scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - arg = gfc_evaluate_now (arg, &se->pre); - - type = gfc_typenode_for_spec (&expr->ts); - e = gfc_create_var (integer_type_node, NULL); - res = gfc_create_var (type, NULL); - - - /* Build the block for s /= 0. */ - gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, frexp, 2, arg, - gfc_build_addr_expr (NULL_TREE, e)); - gfc_add_expr_to_block (&block, tmp); - - tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e, - prec); - gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR, - integer_type_node, tmp, emin)); - - tmp = build_call_expr_loc (input_location, scalbn, 2, - build_real_from_int_cst (type, integer_one_node), e); - gfc_add_modify (&block, res, tmp); - - /* Finish by building the IF statement for value zero. */ - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, - build_real_from_int_cst (type, integer_zero_node)); - tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny), - gfc_finish_block (&block)); - - /* And deal with infinities and NaNs. */ - cond = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISFINITE), - 1, arg); - nan = gfc_build_nan (type, ""); - tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan)); - - gfc_add_expr_to_block (&se->pre, tmp); - se->expr = res; -} - - -/* RRSPACING (s) is translated into - int e; - real x; - x = fabs (s); - if (isfinite (x)) - { - if (x != 0) - { - frexp (s, &e); - x = scalbn (x, precision - e); - } - } - else - x = NaN; - return x; - - where precision is gfc_real_kinds[k].digits. */ - -static void -gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) -{ - tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs; - int prec, k; - stmtblock_t block; - - k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); - prec = gfc_real_kinds[k].digits; - - frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); - scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); - fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - arg = gfc_evaluate_now (arg, &se->pre); - - e = gfc_create_var (integer_type_node, NULL); - x = gfc_create_var (type, NULL); - gfc_add_modify (&se->pre, x, - build_call_expr_loc (input_location, fabs, 1, arg)); - - - gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, frexp, 2, arg, - gfc_build_addr_expr (NULL_TREE, e)); - gfc_add_expr_to_block (&block, tmp); - - tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, - build_int_cst (integer_type_node, prec), e); - tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp); - gfc_add_modify (&block, x, tmp); - stmt = gfc_finish_block (&block); - - /* if (x != 0) */ - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x, - build_real_from_int_cst (type, integer_zero_node)); - tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location)); - - /* And deal with infinities and NaNs. */ - cond = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISFINITE), - 1, x); - nan = gfc_build_nan (type, ""); - tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan)); - - gfc_add_expr_to_block (&se->pre, tmp); - se->expr = fold_convert (type, x); -} - - -/* SCALE (s, i) is translated into scalbn (s, i). */ -static void -gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) -{ - tree args[2], type, scalbn; - - scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = build_call_expr_loc (input_location, scalbn, 2, - fold_convert (type, args[0]), - fold_convert (integer_type_node, args[1])); - se->expr = fold_convert (type, se->expr); -} - - -/* SET_EXPONENT (s, i) is translated into - isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */ -static void -gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) -{ - tree args[2], type, tmp, frexp, scalbn, cond, nan, res; - - frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); - scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); - - type = gfc_typenode_for_spec (&expr->ts); - gfc_conv_intrinsic_function_args (se, expr, args, 2); - args[0] = gfc_evaluate_now (args[0], &se->pre); - - tmp = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr_loc (input_location, frexp, 2, - fold_convert (type, args[0]), - gfc_build_addr_expr (NULL_TREE, tmp)); - res = build_call_expr_loc (input_location, scalbn, 2, tmp, - fold_convert (integer_type_node, args[1])); - res = fold_convert (type, res); - - /* Call to isfinite */ - cond = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISFINITE), - 1, args[0]); - nan = gfc_build_nan (type, ""); - - se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, - res, nan); -} - - -static void -gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) -{ - gfc_actual_arglist *actual; - tree arg1; - tree type; - tree size; - gfc_se argse; - gfc_expr *e; - gfc_symbol *sym = NULL; - - gfc_init_se (&argse, NULL); - actual = expr->value.function.actual; - - if (actual->expr->ts.type == BT_CLASS) - gfc_add_class_array_ref (actual->expr); - - e = actual->expr; - - /* These are emerging from the interface mapping, when a class valued - function appears as the rhs in a realloc on assign statement, where - the size of the result is that of one of the actual arguments. */ - if (e->expr_type == EXPR_VARIABLE - && e->symtree->n.sym->ns == NULL /* This is distinctive! */ - && e->symtree->n.sym->ts.type == BT_CLASS - && e->ref && e->ref->type == REF_COMPONENT - && strcmp (e->ref->u.c.component->name, "_data") == 0) - sym = e->symtree->n.sym; - - if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER) - && e - && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)) - { - symbol_attribute attr; - char *msg; - tree temp; - tree cond; - - if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym)) - { - attr = CLASS_DATA (e->symtree->n.sym)->attr; - attr.pointer = attr.class_pointer; - } - else - attr = gfc_expr_attr (e); - - if (attr.allocatable) - msg = xasprintf ("Allocatable argument '%s' is not allocated", - e->symtree->n.sym->name); - else if (attr.pointer) - msg = xasprintf ("Pointer argument '%s' is not associated", - e->symtree->n.sym->name); - else - goto end_arg_check; - - if (sym) - { - temp = gfc_class_data_get (sym->backend_decl); - temp = gfc_conv_descriptor_data_get (temp); - } - else - { - argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, actual->expr); - temp = gfc_conv_descriptor_data_get (argse.expr); - } - - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, temp, - fold_convert (TREE_TYPE (temp), - null_pointer_node)); - gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg); - - free (msg); - } - end_arg_check: - - argse.data_not_needed = 1; - if (gfc_is_class_array_function (e)) - { - /* For functions that return a class array conv_expr_descriptor is not - able to get the descriptor right. Therefore this special case. */ - gfc_conv_expr_reference (&argse, e); - argse.expr = gfc_class_data_get (argse.expr); - } - else if (sym && sym->backend_decl) - { - gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl))); - argse.expr = gfc_class_data_get (sym->backend_decl); - } - else - gfc_conv_expr_descriptor (&argse, actual->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - arg1 = argse.expr; - - actual = actual->next; - if (actual->expr) - { - stmtblock_t block; - gfc_init_block (&block); - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, actual->expr, - gfc_array_index_type); - gfc_add_block_to_block (&block, &argse.pre); - tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - argse.expr, gfc_index_one_node); - size = gfc_tree_array_size (&block, arg1, e, tmp); - - /* Unusually, for an intrinsic, size does not exclude - an optional arg2, so we must test for it. */ - if (actual->expr->expr_type == EXPR_VARIABLE - && actual->expr->symtree->n.sym->attr.dummy - && actual->expr->symtree->n.sym->attr.optional) - { - tree cond; - stmtblock_t block2; - gfc_init_block (&block2); - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - argse.data_not_needed = 1; - gfc_conv_expr (&argse, actual->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - argse.expr, null_pointer_node); - cond = gfc_evaluate_now (cond, &se->pre); - /* 'block2' contains the arg2 absent case, 'block' the arg2 present - case; size_var can be used in both blocks. */ - tree size_var = gfc_create_var (TREE_TYPE (size), "size"); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (size_var), size_var, size); - gfc_add_expr_to_block (&block, tmp); - size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (size_var), size_var, size); - gfc_add_expr_to_block (&block2, tmp); - tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block), - gfc_finish_block (&block2)); - gfc_add_expr_to_block (&se->pre, tmp); - size = size_var; - } - else - gfc_add_block_to_block (&se->pre, &block); - } - else - size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE); - type = gfc_typenode_for_spec (&expr->ts); - se->expr = convert (type, size); -} - - -/* Helper function to compute the size of a character variable, - excluding the terminating null characters. The result has - gfc_array_index_type type. */ - -tree -size_of_string_in_bytes (int kind, tree string_length) -{ - tree bytesize; - int i = gfc_validate_kind (BT_CHARACTER, kind, false); - - bytesize = build_int_cst (gfc_array_index_type, - gfc_character_kinds[i].bit_size / 8); - - return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - bytesize, - fold_convert (gfc_array_index_type, string_length)); -} - - -static void -gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) -{ - gfc_expr *arg; - gfc_se argse; - tree source_bytes; - tree tmp; - tree lower; - tree upper; - tree byte_size; - tree field; - int n; - - gfc_init_se (&argse, NULL); - arg = expr->value.function.actual->expr; - - if (arg->rank || arg->ts.type == BT_ASSUMED) - gfc_conv_expr_descriptor (&argse, arg); - else - gfc_conv_expr_reference (&argse, arg); - - if (arg->ts.type == BT_ASSUMED) - { - /* This only works if an array descriptor has been passed; thus, extract - the size from the descriptor. */ - gcc_assert (TYPE_PRECISION (gfc_array_index_type) - == TYPE_PRECISION (size_type_node)); - tmp = arg->symtree->n.sym->backend_decl; - tmp = DECL_LANG_SPECIFIC (tmp) - && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE - ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp; - if (POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - - tmp = gfc_conv_descriptor_dtype (tmp); - field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()), - GFC_DTYPE_ELEM_LEN); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - tmp, field, NULL_TREE); - - byte_size = fold_convert (gfc_array_index_type, tmp); - } - else if (arg->ts.type == BT_CLASS) - { - /* Conv_expr_descriptor returns a component_ref to _data component of the - class object. The class object may be a non-pointer object, e.g. - located on the stack, or a memory location pointed to, e.g. a - parameter, i.e., an indirect_ref. */ - if (arg->rank < 0 - || (arg->rank > 0 && !VAR_P (argse.expr) - && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0)) - && GFC_DECL_CLASS (TREE_OPERAND ( - TREE_OPERAND (argse.expr, 0), 0))) - || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0))))) - byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); - else if (arg->rank > 0 - || (arg->rank == 0 - && arg->ref && arg->ref->type == REF_COMPONENT)) - /* The scalarizer added an additional temp. To get the class' vptr - one has to look at the original backend_decl. */ - byte_size = gfc_class_vtab_size_get ( - GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); - else - byte_size = gfc_class_vtab_size_get (argse.expr); - } - else - { - if (arg->ts.type == BT_CHARACTER) - byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length); - else - { - if (arg->rank == 0) - byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location, - argse.expr)); - else - byte_size = gfc_get_element_type (TREE_TYPE (argse.expr)); - byte_size = fold_convert (gfc_array_index_type, - size_in_bytes (byte_size)); - } - } - - if (arg->rank == 0) - se->expr = byte_size; - else - { - source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); - gfc_add_modify (&argse.pre, source_bytes, byte_size); - - if (arg->rank == -1) - { - tree cond, loop_var, exit_label; - stmtblock_t body; - - tmp = fold_convert (gfc_array_index_type, - gfc_conv_descriptor_rank (argse.expr)); - loop_var = gfc_create_var (gfc_array_index_type, "i"); - gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node); - exit_label = gfc_build_label_decl (NULL_TREE); - - /* Create loop: - for (;;) - { - if (i >= rank) - goto exit; - source_bytes = source_bytes * array.dim[i].extent; - i = i + 1; - } - exit: */ - gfc_start_block (&body); - cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - loop_var, tmp); - 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 (&body, tmp); - - lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var); - upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var); - tmp = gfc_conv_array_extent_dim (lower, upper, NULL); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, source_bytes); - gfc_add_modify (&body, source_bytes, tmp); - - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, loop_var, - gfc_index_one_node); - gfc_add_modify_loc (input_location, &body, loop_var, tmp); - - tmp = gfc_finish_block (&body); - - tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node, - tmp); - gfc_add_expr_to_block (&argse.pre, tmp); - - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&argse.pre, tmp); - } - else - { - /* Obtain the size of the array in bytes. */ - for (n = 0; n < arg->rank; n++) - { - tree idx; - idx = gfc_rank_cst[n]; - lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); - upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); - tmp = gfc_conv_array_extent_dim (lower, upper, NULL); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, source_bytes); - gfc_add_modify (&argse.pre, source_bytes, tmp); - } - } - se->expr = source_bytes; - } - - gfc_add_block_to_block (&se->pre, &argse.pre); -} - - -static void -gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) -{ - gfc_expr *arg; - gfc_se argse; - tree type, result_type, tmp; - - arg = expr->value.function.actual->expr; - - gfc_init_se (&argse, NULL); - result_type = gfc_get_int_type (expr->ts.kind); - - if (arg->rank == 0) - { - if (arg->ts.type == BT_CLASS) - { - gfc_add_vptr_component (arg); - gfc_add_size_component (arg); - gfc_conv_expr (&argse, arg); - tmp = fold_convert (result_type, argse.expr); - goto done; - } - - gfc_conv_expr_reference (&argse, arg); - type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, - argse.expr)); - } - else - { - argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg); - if (arg->ts.type == BT_CLASS) - { - if (arg->rank > 0) - tmp = gfc_class_vtab_size_get ( - GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); - else - tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); - tmp = fold_convert (result_type, tmp); - goto done; - } - type = gfc_get_element_type (TREE_TYPE (argse.expr)); - } - - /* Obtain the argument's word length. */ - if (arg->ts.type == BT_CHARACTER) - tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); - else - tmp = size_in_bytes (type); - tmp = fold_convert (result_type, tmp); - -done: - se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp, - build_int_cst (result_type, BITS_PER_UNIT)); - gfc_add_block_to_block (&se->pre, &argse.pre); -} - - -/* Intrinsic string comparison functions. */ - -static void -gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op) -{ - tree args[4]; - - gfc_conv_intrinsic_function_args (se, expr, args, 4); - - se->expr - = gfc_build_compare_string (args[0], args[1], args[2], args[3], - expr->value.function.actual->expr->ts.kind, - op); - se->expr = fold_build2_loc (input_location, op, - gfc_typenode_for_spec (&expr->ts), se->expr, - build_int_cst (TREE_TYPE (se->expr), 0)); -} - -/* Generate a call to the adjustl/adjustr library function. */ -static void -gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) -{ - tree args[3]; - tree len; - tree type; - tree var; - tree tmp; - - gfc_conv_intrinsic_function_args (se, expr, &args[1], 2); - len = args[1]; - - type = TREE_TYPE (args[2]); - var = gfc_conv_string_tmp (se, type, len); - args[0] = var; - - tmp = build_call_expr_loc (input_location, - fndecl, 3, args[0], args[1], args[2]); - gfc_add_expr_to_block (&se->pre, tmp); - se->expr = var; - se->string_length = len; -} - - -/* Generate code for the TRANSFER intrinsic: - For scalar results: - DEST = TRANSFER (SOURCE, MOLD) - where: - typeof = typeof - and: - MOLD is scalar. - - For array results: - DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) - where: - typeof = typeof - and: - N = min (sizeof (SOURCE(:)), sizeof (DEST(:)), - sizeof (DEST(0) * SIZE). */ -static void -gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) -{ - tree tmp; - tree tmpdecl; - tree ptr; - tree extent; - tree source; - tree source_type; - tree source_bytes; - tree mold_type; - tree dest_word_len; - tree size_words; - tree size_bytes; - tree upper; - tree lower; - tree stmt; - tree class_ref = NULL_TREE; - gfc_actual_arglist *arg; - gfc_se argse; - gfc_array_info *info; - stmtblock_t block; - int n; - bool scalar_mold; - gfc_expr *source_expr, *mold_expr, *class_expr; - - info = NULL; - if (se->loop) - info = &se->ss->info->data.array; - - /* Convert SOURCE. The output from this stage is:- - source_bytes = length of the source in bytes - source = pointer to the source data. */ - arg = expr->value.function.actual; - source_expr = arg->expr; - - /* Ensure double transfer through LOGICAL preserves all - the needed bits. */ - if (arg->expr->expr_type == EXPR_FUNCTION - && arg->expr->value.function.esym == NULL - && arg->expr->value.function.isym != NULL - && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER - && arg->expr->ts.type == BT_LOGICAL - && expr->ts.type != arg->expr->ts.type) - arg->expr->value.function.name = "__transfer_in_transfer"; - - gfc_init_se (&argse, NULL); - - source_bytes = gfc_create_var (gfc_array_index_type, NULL); - - /* Obtain the pointer to source and the length of source in bytes. */ - if (arg->expr->rank == 0) - { - gfc_conv_expr_reference (&argse, arg->expr); - if (arg->expr->ts.type == BT_CLASS) - { - tmp = build_fold_indirect_ref_loc (input_location, argse.expr); - if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) - source = gfc_class_data_get (tmp); - else - { - /* Array elements are evaluated as a reference to the data. - To obtain the vptr for the element size, the argument - expression must be stripped to the class reference and - re-evaluated. The pre and post blocks are not needed. */ - gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); - source = argse.expr; - class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr); - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, class_expr); - class_ref = argse.expr; - } - } - else - source = argse.expr; - - /* Obtain the source word length. */ - switch (arg->expr->ts.type) - { - case BT_CHARACTER: - tmp = size_of_string_in_bytes (arg->expr->ts.kind, - argse.string_length); - break; - case BT_CLASS: - if (class_ref != NULL_TREE) - tmp = gfc_class_vtab_size_get (class_ref); - else - tmp = gfc_class_vtab_size_get (argse.expr); - break; - default: - source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, - source)); - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (source_type)); - break; - } - } - else - { - argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg->expr); - source = gfc_conv_descriptor_data_get (argse.expr); - source_type = gfc_get_element_type (TREE_TYPE (argse.expr)); - - /* Repack the source if not simply contiguous. */ - if (!gfc_is_simply_contiguous (arg->expr, false, true)) - { - tmp = gfc_build_addr_expr (NULL_TREE, argse.expr); - - if (warn_array_temporaries) - gfc_warning (OPT_Warray_temporaries, - "Creating array temporary at %L", &expr->where); - - source = build_call_expr_loc (input_location, - gfor_fndecl_in_pack, 1, tmp); - source = gfc_evaluate_now (source, &argse.pre); - - /* Free the temporary. */ - gfc_start_block (&block); - tmp = gfc_call_free (source); - gfc_add_expr_to_block (&block, tmp); - stmt = gfc_finish_block (&block); - - /* Clean up if it was repacked. */ - gfc_init_block (&block); - tmp = gfc_conv_array_data (argse.expr); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - source, tmp); - tmp = build3_v (COND_EXPR, tmp, stmt, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &se->post); - gfc_init_block (&se->post); - gfc_add_block_to_block (&se->post, &block); - } - - /* Obtain the source word length. */ - if (arg->expr->ts.type == BT_CHARACTER) - tmp = size_of_string_in_bytes (arg->expr->ts.kind, - argse.string_length); - else - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (source_type)); - - /* Obtain the size of the array in bytes. */ - extent = gfc_create_var (gfc_array_index_type, NULL); - for (n = 0; n < arg->expr->rank; n++) - { - tree idx; - idx = gfc_rank_cst[n]; - gfc_add_modify (&argse.pre, source_bytes, tmp); - lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); - upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - gfc_add_modify (&argse.pre, extent, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, extent, - gfc_index_one_node); - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, source_bytes); - } - } - - gfc_add_modify (&argse.pre, source_bytes, tmp); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - - /* Now convert MOLD. The outputs are: - mold_type = the TREE type of MOLD - dest_word_len = destination word length in bytes. */ - arg = arg->next; - mold_expr = arg->expr; - - gfc_init_se (&argse, NULL); - - scalar_mold = arg->expr->rank == 0; - - if (arg->expr->rank == 0) - { - gfc_conv_expr_reference (&argse, arg->expr); - mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, - argse.expr)); - } - else - { - gfc_init_se (&argse, NULL); - argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg->expr); - mold_type = gfc_get_element_type (TREE_TYPE (argse.expr)); - } - - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - - if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0) - { - /* If this TRANSFER is nested in another TRANSFER, use a type - that preserves all bits. */ - if (arg->expr->ts.type == BT_LOGICAL) - mold_type = gfc_get_int_type (arg->expr->ts.kind); - } - - /* Obtain the destination word length. */ - switch (arg->expr->ts.type) - { - case BT_CHARACTER: - tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); - mold_type = gfc_get_character_type_len (arg->expr->ts.kind, - argse.string_length); - break; - case BT_CLASS: - tmp = gfc_class_vtab_size_get (argse.expr); - break; - default: - tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type)); - break; - } - dest_word_len = gfc_create_var (gfc_array_index_type, NULL); - gfc_add_modify (&se->pre, dest_word_len, tmp); - - /* Finally convert SIZE, if it is present. */ - arg = arg->next; - size_words = gfc_create_var (gfc_array_index_type, NULL); - - if (arg->expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_reference (&argse, arg->expr); - tmp = convert (gfc_array_index_type, - build_fold_indirect_ref_loc (input_location, - argse.expr)); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - } - else - tmp = NULL_TREE; - - /* Separate array and scalar results. */ - if (scalar_mold && tmp == NULL_TREE) - goto scalar_transfer; - - size_bytes = gfc_create_var (gfc_array_index_type, NULL); - if (tmp != NULL_TREE) - tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - tmp, dest_word_len); - else - tmp = source_bytes; - - gfc_add_modify (&se->pre, size_bytes, tmp); - gfc_add_modify (&se->pre, size_words, - fold_build2_loc (input_location, CEIL_DIV_EXPR, - gfc_array_index_type, - size_bytes, dest_word_len)); - - /* Evaluate the bounds of the result. If the loop range exists, we have - to check if it is too large. If so, we modify loop->to be consistent - with min(size, size(source)). Otherwise, size is made consistent with - the loop range, so that the right number of bytes is transferred.*/ - n = se->loop->order[0]; - if (se->loop->to[n] != NULL_TREE) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - se->loop->to[n], se->loop->from[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, - tmp, size_words); - gfc_add_modify (&se->pre, size_words, tmp); - gfc_add_modify (&se->pre, size_bytes, - fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - size_words, dest_word_len)); - upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size_words, se->loop->from[n]); - upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - upper, gfc_index_one_node); - } - else - { - upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size_words, gfc_index_one_node); - se->loop->from[n] = gfc_index_zero_node; - } - - se->loop->to[n] = upper; - - /* Build a destination descriptor, using the pointer, source, as the - data field. */ - gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type, - NULL_TREE, false, true, false, &expr->where); - - /* Cast the pointer to the result. */ - tmp = gfc_conv_descriptor_data_get (info->descriptor); - tmp = fold_convert (pvoid_type_node, tmp); - - /* Use memcpy to do the transfer. */ - tmp - = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp, - fold_convert (pvoid_type_node, source), - fold_convert (size_type_node, - fold_build2_loc (input_location, - MIN_EXPR, - gfc_array_index_type, - size_bytes, - source_bytes))); - gfc_add_expr_to_block (&se->pre, tmp); - - se->expr = info->descriptor; - if (expr->ts.type == BT_CHARACTER) - { - tmp = fold_convert (gfc_charlen_type_node, - TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind))); - se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_charlen_type_node, - dest_word_len, tmp); - } - - return; - -/* Deal with scalar results. */ -scalar_transfer: - extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, - dest_word_len, source_bytes); - extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, - extent, gfc_index_zero_node); - - if (expr->ts.type == BT_CHARACTER) - { - tree direct, indirect, free; - - ptr = convert (gfc_get_pchar_type (expr->ts.kind), source); - tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), - "transfer"); - - /* If source is longer than the destination, use a pointer to - the source directly. */ - gfc_init_block (&block); - gfc_add_modify (&block, tmpdecl, ptr); - direct = gfc_finish_block (&block); - - /* Otherwise, allocate a string with the length of the destination - and copy the source into it. */ - gfc_init_block (&block); - tmp = gfc_get_pchar_type (expr->ts.kind); - tmp = gfc_call_malloc (&block, tmp, dest_word_len); - gfc_add_modify (&block, tmpdecl, - fold_convert (TREE_TYPE (ptr), tmp)); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, - fold_convert (pvoid_type_node, tmpdecl), - fold_convert (pvoid_type_node, ptr), - fold_convert (size_type_node, extent)); - gfc_add_expr_to_block (&block, tmp); - indirect = gfc_finish_block (&block); - - /* Wrap it up with the condition. */ - tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - dest_word_len, source_bytes); - tmp = build3_v (COND_EXPR, tmp, direct, indirect); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Free the temporary string, if necessary. */ - free = gfc_call_free (tmpdecl); - tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - dest_word_len, source_bytes); - tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->post, tmp); - - se->expr = tmpdecl; - tmp = fold_convert (gfc_charlen_type_node, - TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind))); - se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - gfc_charlen_type_node, - dest_word_len, tmp); - } - else - { - tmpdecl = gfc_create_var (mold_type, "transfer"); - - ptr = convert (build_pointer_type (mold_type), source); - - /* For CLASS results, allocate the needed memory first. */ - if (mold_expr->ts.type == BT_CLASS) - { - tree cdata; - cdata = gfc_class_data_get (tmpdecl); - tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len); - gfc_add_modify (&se->pre, cdata, tmp); - } - - /* Use memcpy to do the transfer. */ - if (mold_expr->ts.type == BT_CLASS) - tmp = gfc_class_data_get (tmpdecl); - else - tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl); - - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, - fold_convert (pvoid_type_node, tmp), - fold_convert (pvoid_type_node, ptr), - fold_convert (size_type_node, extent)); - gfc_add_expr_to_block (&se->pre, tmp); - - /* For CLASS results, set the _vptr. */ - if (mold_expr->ts.type == BT_CLASS) - { - tree vptr; - gfc_symbol *vtab; - vptr = gfc_class_vptr_get (tmpdecl); - vtab = gfc_find_derived_vtab (source_expr->ts.u.derived); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp)); - } - - se->expr = tmpdecl; - } -} - - -/* Generate a call to caf_is_present. */ - -static tree -trans_caf_is_present (gfc_se *se, gfc_expr *expr) -{ - tree caf_reference, caf_decl, token, image_index; - - /* Compile the reference chain. */ - caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr); - gcc_assert (caf_reference != NULL_TREE); - - caf_decl = gfc_get_tree_for_caf_expr (expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl); - gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, - expr); - - return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present, - 3, token, image_index, caf_reference); -} - - -/* Test whether this ref-chain refs this image only. */ - -static bool -caf_this_image_ref (gfc_ref *ref) -{ - for ( ; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen) - return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE; - - return false; -} - - -/* Generate code for the ALLOCATED intrinsic. - Generate inline code that directly check the address of the argument. */ - -static void -gfc_conv_allocated (gfc_se *se, gfc_expr *expr) -{ - gfc_se arg1se; - tree tmp; - bool coindexed_caf_comp = false; - gfc_expr *e = expr->value.function.actual->expr; - - gfc_init_se (&arg1se, NULL); - if (e->ts.type == BT_CLASS) - { - /* Make sure that class array expressions have both a _data - component reference and an array reference.... */ - if (CLASS_DATA (e)->attr.dimension) - gfc_add_class_array_ref (e); - /* .... whilst scalars only need the _data component. */ - else - gfc_add_data_component (e); - } - - /* When 'e' references an allocatable component in a coarray, then call - the caf-library function caf_is_present (). */ - if (flag_coarray == GFC_FCOARRAY_LIB && e->expr_type == EXPR_FUNCTION - && e->value.function.isym - && e->value.function.isym->id == GFC_ISYM_CAF_GET) - { - e = e->value.function.actual->expr; - if (gfc_expr_attr (e).codimension) - { - /* Last partref is the coindexed coarray. As coarrays are collectively - (de)allocated, the allocation status must be the same as the one of - the local allocation. Convert to local access. */ - for (gfc_ref *ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.codimen) - { - for (int i = ref->u.ar.dimen; - i < ref->u.ar.dimen + ref->u.ar.codimen; ++i) - ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE; - break; - } - } - else if (!caf_this_image_ref (e->ref)) - coindexed_caf_comp = true; - } - if (coindexed_caf_comp) - tmp = trans_caf_is_present (se, e); - else - { - if (e->rank == 0) - { - /* Allocatable scalar. */ - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, e); - tmp = arg1se.expr; - } - else - { - /* Allocatable array. */ - arg1se.descriptor_only = 1; - gfc_conv_expr_descriptor (&arg1se, e); - tmp = gfc_conv_descriptor_data_get (arg1se.expr); - } - - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, - fold_convert (TREE_TYPE (tmp), null_pointer_node)); - } - - /* Components of pointer array references sometimes come back with a pre block. */ - if (arg1se.pre.head) - gfc_add_block_to_block (&se->pre, &arg1se.pre); - - se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); -} - - -/* Generate code for the ASSOCIATED intrinsic. - If both POINTER and TARGET are arrays, generate a call to library function - _gfor_associated, and pass descriptors of POINTER and TARGET to it. - In other cases, generate inline code that directly compare the address of - POINTER with the address of TARGET. */ - -static void -gfc_conv_associated (gfc_se *se, gfc_expr *expr) -{ - gfc_actual_arglist *arg1; - gfc_actual_arglist *arg2; - gfc_se arg1se; - gfc_se arg2se; - tree tmp2; - tree tmp; - tree nonzero_arraylen = NULL_TREE; - gfc_ss *ss; - bool scalar; - - gfc_init_se (&arg1se, NULL); - gfc_init_se (&arg2se, NULL); - arg1 = expr->value.function.actual; - arg2 = arg1->next; - - /* Check whether the expression is a scalar or not; we cannot use - arg1->expr->rank as it can be nonzero for proc pointers. */ - ss = gfc_walk_expr (arg1->expr); - scalar = ss == gfc_ss_terminator; - if (!scalar) - gfc_free_ss_chain (ss); - - if (!arg2->expr) - { - /* No optional target. */ - if (scalar) - { - /* A pointer to a scalar. */ - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); - if (arg1->expr->symtree->n.sym->attr.proc_pointer - && arg1->expr->symtree->n.sym->attr.dummy) - arg1se.expr = build_fold_indirect_ref_loc (input_location, - arg1se.expr); - if (arg1->expr->ts.type == BT_CLASS) - { - tmp2 = gfc_class_data_get (arg1se.expr); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2))) - tmp2 = gfc_conv_descriptor_data_get (tmp2); - } - else - tmp2 = arg1se.expr; - } - else - { - /* A pointer to an array. */ - gfc_conv_expr_descriptor (&arg1se, arg1->expr); - tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); - } - gfc_add_block_to_block (&se->pre, &arg1se.pre); - gfc_add_block_to_block (&se->post, &arg1se.post); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2, - fold_convert (TREE_TYPE (tmp2), null_pointer_node)); - se->expr = tmp; - } - else - { - /* An optional target. */ - if (arg2->expr->ts.type == BT_CLASS - && arg2->expr->expr_type != EXPR_FUNCTION) - gfc_add_data_component (arg2->expr); - - if (scalar) - { - /* A pointer to a scalar. */ - arg1se.want_pointer = 1; - gfc_conv_expr (&arg1se, arg1->expr); - if (arg1->expr->symtree->n.sym->attr.proc_pointer - && arg1->expr->symtree->n.sym->attr.dummy) - arg1se.expr = build_fold_indirect_ref_loc (input_location, - arg1se.expr); - if (arg1->expr->ts.type == BT_CLASS) - arg1se.expr = gfc_class_data_get (arg1se.expr); - - arg2se.want_pointer = 1; - gfc_conv_expr (&arg2se, arg2->expr); - if (arg2->expr->symtree->n.sym->attr.proc_pointer - && arg2->expr->symtree->n.sym->attr.dummy) - arg2se.expr = build_fold_indirect_ref_loc (input_location, - arg2se.expr); - if (arg2->expr->ts.type == BT_CLASS) - { - arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre); - arg2se.expr = gfc_class_data_get (arg2se.expr); - } - gfc_add_block_to_block (&se->pre, &arg1se.pre); - gfc_add_block_to_block (&se->post, &arg1se.post); - gfc_add_block_to_block (&se->pre, &arg2se.pre); - gfc_add_block_to_block (&se->post, &arg2se.post); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - arg1se.expr, arg2se.expr); - tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - arg1se.expr, null_pointer_node); - se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, tmp, tmp2); - } - else - { - /* An array pointer of zero length is not associated if target is - present. */ - arg1se.descriptor_only = 1; - gfc_conv_expr_lhs (&arg1se, arg1->expr); - if (arg1->expr->rank == -1) - { - tmp = gfc_conv_descriptor_rank (arg1se.expr); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (tmp), tmp, - build_int_cst (TREE_TYPE (tmp), 1)); - } - else - tmp = gfc_rank_cst[arg1->expr->rank - 1]; - tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); - if (arg2->expr->rank != 0) - nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), 0)); - - /* A pointer to an array, call library function _gfor_associated. */ - arg1se.want_pointer = 1; - gfc_conv_expr_descriptor (&arg1se, arg1->expr); - gfc_add_block_to_block (&se->pre, &arg1se.pre); - gfc_add_block_to_block (&se->post, &arg1se.post); - - arg2se.want_pointer = 1; - arg2se.force_no_tmp = 1; - if (arg2->expr->rank != 0) - gfc_conv_expr_descriptor (&arg2se, arg2->expr); - else - { - gfc_conv_expr (&arg2se, arg2->expr); - arg2se.expr - = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr, - gfc_expr_attr (arg2->expr)); - arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr); - } - gfc_add_block_to_block (&se->pre, &arg2se.pre); - gfc_add_block_to_block (&se->post, &arg2se.post); - se->expr = build_call_expr_loc (input_location, - gfor_fndecl_associated, 2, - arg1se.expr, arg2se.expr); - se->expr = convert (logical_type_node, se->expr); - if (arg2->expr->rank != 0) - se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, se->expr, - nonzero_arraylen); - } - - /* If target is present zero character length pointers cannot - be associated. */ - if (arg1->expr->ts.type == BT_CHARACTER) - { - tmp = arg1se.string_length; - tmp = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tmp, - build_zero_cst (TREE_TYPE (tmp))); - se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, se->expr, tmp); - } - } - - se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - - -/* Generate code for the SAME_TYPE_AS intrinsic. - Generate inline code that directly checks the vindices. */ - -static void -gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) -{ - gfc_expr *a, *b; - gfc_se se1, se2; - tree tmp; - tree conda = NULL_TREE, condb = NULL_TREE; - - gfc_init_se (&se1, NULL); - gfc_init_se (&se2, NULL); - - a = expr->value.function.actual->expr; - b = expr->value.function.actual->next->expr; - - bool unlimited_poly_a = UNLIMITED_POLY (a); - bool unlimited_poly_b = UNLIMITED_POLY (b); - if (unlimited_poly_a) - { - se1.want_pointer = 1; - gfc_add_vptr_component (a); - } - else if (a->ts.type == BT_CLASS) - { - gfc_add_vptr_component (a); - gfc_add_hash_component (a); - } - else if (a->ts.type == BT_DERIVED) - a = gfc_get_int_expr (gfc_default_integer_kind, NULL, - a->ts.u.derived->hash_value); - - if (unlimited_poly_b) - { - se2.want_pointer = 1; - gfc_add_vptr_component (b); - } - else if (b->ts.type == BT_CLASS) - { - gfc_add_vptr_component (b); - gfc_add_hash_component (b); - } - else if (b->ts.type == BT_DERIVED) - b = gfc_get_int_expr (gfc_default_integer_kind, NULL, - b->ts.u.derived->hash_value); - - gfc_conv_expr (&se1, a); - gfc_conv_expr (&se2, b); - - if (unlimited_poly_a) - { - conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - se1.expr, - build_int_cst (TREE_TYPE (se1.expr), 0)); - se1.expr = gfc_vptr_hash_get (se1.expr); - } - - if (unlimited_poly_b) - { - condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - se2.expr, - build_int_cst (TREE_TYPE (se2.expr), 0)); - se2.expr = gfc_vptr_hash_get (se2.expr); - } - - tmp = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, se1.expr, - fold_convert (TREE_TYPE (se1.expr), se2.expr)); - - if (conda) - tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - logical_type_node, conda, tmp); - - if (condb) - tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - logical_type_node, condb, tmp); - - se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); -} - - -/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ - -static void -gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr) -{ - tree args[2]; - - gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = build_call_expr_loc (input_location, - gfor_fndecl_sc_kind, 2, args[0], args[1]); - se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - - -/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ - -static void -gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr) -{ - tree arg, type; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - - /* The argument to SELECTED_INT_KIND is INTEGER(4). */ - type = gfc_get_int_type (4); - arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg)); - - /* Convert it to the required type. */ - type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_call_expr_loc (input_location, - gfor_fndecl_si_kind, 1, arg); - se->expr = fold_convert (type, se->expr); -} - - -/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */ - -static void -gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) -{ - gfc_actual_arglist *actual; - tree type; - gfc_se argse; - vec *args = NULL; - - for (actual = expr->value.function.actual; actual; actual = actual->next) - { - gfc_init_se (&argse, se); - - /* Pass a NULL pointer for an absent arg. */ - if (actual->expr == NULL) - argse.expr = null_pointer_node; - else - { - gfc_typespec ts; - gfc_clear_ts (&ts); - - if (actual->expr->ts.kind != gfc_c_int_kind) - { - /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */ - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - gfc_convert_type (actual->expr, &ts, 2); - } - gfc_conv_expr_reference (&argse, actual->expr); - } - - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - vec_safe_push (args, argse.expr); - } - - /* Convert it to the required type. */ - type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_call_expr_loc_vec (input_location, - gfor_fndecl_sr_kind, args); - se->expr = fold_convert (type, se->expr); -} - - -/* Generate code for TRIM (A) intrinsic function. */ - -static void -gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) -{ - tree var; - tree len; - tree addr; - tree tmp; - tree cond; - tree fndecl; - tree function; - tree *args; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = XALLOCAVEC (tree, num_args); - - var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); - addr = gfc_build_addr_expr (ppvoid_type_node, var); - len = gfc_create_var (gfc_charlen_type_node, "len"); - - gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = gfc_build_addr_expr (NULL_TREE, len); - args[1] = addr; - - if (expr->ts.kind == 1) - function = gfor_fndecl_string_trim; - else if (expr->ts.kind == 4) - function = gfor_fndecl_string_trim_char4; - else - gcc_unreachable (); - - fndecl = build_addr (function); - tmp = build_call_array_loc (input_location, - TREE_TYPE (TREE_TYPE (function)), fndecl, - num_args, args); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - len, build_int_cst (TREE_TYPE (len), 0)); - tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->post, tmp); - - se->expr = var; - se->string_length = len; -} - - -/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */ - -static void -gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) -{ - tree args[3], ncopies, dest, dlen, src, slen, ncopies_type; - tree type, cond, tmp, count, exit_label, n, max, largest; - tree size; - stmtblock_t block, body; - int i; - - /* We store in charsize the size of a character. */ - i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); - size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8); - - /* Get the arguments. */ - gfc_conv_intrinsic_function_args (se, expr, args, 3); - slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre)); - src = args[1]; - ncopies = gfc_evaluate_now (args[2], &se->pre); - ncopies_type = TREE_TYPE (ncopies); - - /* Check that NCOPIES is not negative. */ - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies, - build_int_cst (ncopies_type, 0)); - gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, - "Argument NCOPIES of REPEAT intrinsic is negative " - "(its value is %ld)", - fold_convert (long_integer_type_node, ncopies)); - - /* If the source length is zero, any non negative value of NCOPIES - is valid, and nothing happens. */ - n = gfc_create_var (ncopies_type, "ncopies"); - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, - size_zero_node); - tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond, - build_int_cst (ncopies_type, 0), ncopies); - gfc_add_modify (&se->pre, n, tmp); - ncopies = n; - - /* Check that ncopies is not too large: ncopies should be less than - (or equal to) MAX / slen, where MAX is the maximal integer of - the gfc_charlen_type_node type. If slen == 0, we need a special - case to avoid the division by zero. */ - max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype, - fold_convert (sizetype, - TYPE_MAX_VALUE (gfc_charlen_type_node)), - slen); - largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type) - ? sizetype : ncopies_type; - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - fold_convert (largest, ncopies), - fold_convert (largest, max)); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, - size_zero_node); - cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp, - logical_false_node, cond); - gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, - "Argument NCOPIES of REPEAT intrinsic is too large"); - - /* Compute the destination length. */ - dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, - fold_convert (gfc_charlen_type_node, slen), - fold_convert (gfc_charlen_type_node, ncopies)); - type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); - dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen); - - /* Generate the code to do the repeat operation: - for (i = 0; i < ncopies; i++) - memmove (dest + (i * slen * size), src, slen*size); */ - gfc_start_block (&block); - count = gfc_create_var (sizetype, "count"); - gfc_add_modify (&block, count, size_zero_node); - exit_label = gfc_build_label_decl (NULL_TREE); - - /* Start the loop body. */ - gfc_start_block (&body); - - /* Exit the loop if count >= ncopies. */ - cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count, - fold_convert (sizetype, ncopies)); - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&body, tmp); - - /* Call memmove (dest + (i*slen*size), src, slen*size). */ - tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen, - count); - tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp, - size); - tmp = fold_build_pointer_plus_loc (input_location, - fold_convert (pvoid_type_node, dest), tmp); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMMOVE), - 3, tmp, src, - fold_build2_loc (input_location, MULT_EXPR, - size_type_node, slen, size)); - gfc_add_expr_to_block (&body, tmp); - - /* Increment count. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype, - count, size_one_node); - gfc_add_modify (&body, count, tmp); - - /* Build the loop. */ - tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body)); - gfc_add_expr_to_block (&block, tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&block, tmp); - - /* Finish the block. */ - tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&se->pre, tmp); - - /* Set the result value. */ - se->expr = dest; - se->string_length = dlen; -} - - -/* Generate code for the IARGC intrinsic. */ - -static void -gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) -{ - tree tmp; - tree fndecl; - tree type; - - /* Call the library function. This always returns an INTEGER(4). */ - fndecl = gfor_fndecl_iargc; - tmp = build_call_expr_loc (input_location, - fndecl, 0); - - /* Convert it to the required type. */ - type = gfc_typenode_for_spec (&expr->ts); - tmp = fold_convert (type, tmp); - - se->expr = tmp; -} - - -/* Generate code for the KILL intrinsic. */ - -static void -conv_intrinsic_kill (gfc_se *se, gfc_expr *expr) -{ - tree *args; - tree int4_type_node = gfc_get_int_type (4); - tree pid; - tree sig; - tree tmp; - unsigned int num_args; - - num_args = gfc_intrinsic_argument_list_length (expr); - args = XALLOCAVEC (tree, num_args); - gfc_conv_intrinsic_function_args (se, expr, args, num_args); - - /* Convert PID to a INTEGER(4) entity. */ - pid = convert (int4_type_node, args[0]); - - /* Convert SIG to a INTEGER(4) entity. */ - sig = convert (int4_type_node, args[1]); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig); - - se->expr = fold_convert (TREE_TYPE (args[0]), tmp); -} - - -static tree -conv_intrinsic_kill_sub (gfc_code *code) -{ - stmtblock_t block; - gfc_se se, se_stat; - tree int4_type_node = gfc_get_int_type (4); - tree pid; - tree sig; - tree statp; - tree tmp; - - /* Make the function call. */ - gfc_init_block (&block); - gfc_init_se (&se, NULL); - - /* Convert PID to a INTEGER(4) entity. */ - gfc_conv_expr (&se, code->ext.actual->expr); - gfc_add_block_to_block (&block, &se.pre); - pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block)); - gfc_add_block_to_block (&block, &se.post); - - /* Convert SIG to a INTEGER(4) entity. */ - gfc_conv_expr (&se, code->ext.actual->next->expr); - gfc_add_block_to_block (&block, &se.pre); - sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block)); - gfc_add_block_to_block (&block, &se.post); - - /* Deal with an optional STATUS. */ - if (code->ext.actual->next->next->expr) - { - gfc_init_se (&se_stat, NULL); - gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr); - statp = gfc_create_var (gfc_get_int_type (4), "_statp"); - } - else - statp = NULL_TREE; - - tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig, - statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node); - - gfc_add_expr_to_block (&block, tmp); - - if (statp && statp != se_stat.expr) - gfc_add_modify (&block, se_stat.expr, - fold_convert (TREE_TYPE (se_stat.expr), statp)); - - return gfc_finish_block (&block); -} - - - -/* The loc intrinsic returns the address of its argument as - gfc_index_integer_kind integer. */ - -static void -gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) -{ - tree temp_var; - gfc_expr *arg_expr; - - gcc_assert (!se->ss); - - arg_expr = expr->value.function.actual->expr; - if (arg_expr->rank == 0) - { - if (arg_expr->ts.type == BT_CLASS) - gfc_add_data_component (arg_expr); - gfc_conv_expr_reference (se, arg_expr); - } - else - gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL); - se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); - - /* Create a temporary variable for loc return value. Without this, - we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */ - temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL); - gfc_add_modify (&se->pre, temp_var, se->expr); - se->expr = temp_var; -} - - -/* The following routine generates code for the intrinsic - functions from the ISO_C_BINDING module: - * C_LOC - * C_FUNLOC - * C_ASSOCIATED */ - -static void -conv_isocbinding_function (gfc_se *se, gfc_expr *expr) -{ - gfc_actual_arglist *arg = expr->value.function.actual; - - if (expr->value.function.isym->id == GFC_ISYM_C_LOC) - { - if (arg->expr->rank == 0) - gfc_conv_expr_reference (se, arg->expr); - else if (gfc_is_simply_contiguous (arg->expr, false, false)) - gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL); - else - { - gfc_conv_expr_descriptor (se, arg->expr); - se->expr = gfc_conv_descriptor_data_get (se->expr); - } - - /* TODO -- the following two lines shouldn't be necessary, but if - they're removed, a bug is exposed later in the code path. - This workaround was thus introduced, but will have to be - removed; please see PR 35150 for details about the issue. */ - se->expr = convert (pvoid_type_node, se->expr); - se->expr = gfc_evaluate_now (se->expr, &se->pre); - } - else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC) - gfc_conv_expr_reference (se, arg->expr); - else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED) - { - gfc_se arg1se; - gfc_se arg2se; - - /* Build the addr_expr for the first argument. The argument is - already an *address* so we don't need to set want_pointer in - the gfc_se. */ - gfc_init_se (&arg1se, NULL); - gfc_conv_expr (&arg1se, arg->expr); - gfc_add_block_to_block (&se->pre, &arg1se.pre); - gfc_add_block_to_block (&se->post, &arg1se.post); - - /* See if we were given two arguments. */ - if (arg->next->expr == NULL) - /* Only given one arg so generate a null and do a - not-equal comparison against the first arg. */ - se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - arg1se.expr, - fold_convert (TREE_TYPE (arg1se.expr), - null_pointer_node)); - else - { - tree eq_expr; - tree not_null_expr; - - /* Given two arguments so build the arg2se from second arg. */ - gfc_init_se (&arg2se, NULL); - gfc_conv_expr (&arg2se, arg->next->expr); - gfc_add_block_to_block (&se->pre, &arg2se.pre); - gfc_add_block_to_block (&se->post, &arg2se.post); - - /* Generate test to compare that the two args are equal. */ - eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - arg1se.expr, arg2se.expr); - /* Generate test to ensure that the first arg is not null. */ - not_null_expr = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, - arg1se.expr, null_pointer_node); - - /* Finally, the generated test must check that both arg1 is not - NULL and that it is equal to the second arg. */ - se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, - not_null_expr, eq_expr); - } - } - else - gcc_unreachable (); -} - - -/* The following routine generates code for the intrinsic - subroutines from the ISO_C_BINDING module: - * C_F_POINTER - * C_F_PROCPOINTER. */ - -static tree -conv_isocbinding_subroutine (gfc_code *code) -{ - gfc_se se; - gfc_se cptrse; - gfc_se fptrse; - gfc_se shapese; - gfc_ss *shape_ss; - tree desc, dim, tmp, stride, offset; - stmtblock_t body, block; - gfc_loopinfo loop; - gfc_actual_arglist *arg = code->ext.actual; - - gfc_init_se (&se, NULL); - gfc_init_se (&cptrse, NULL); - gfc_conv_expr (&cptrse, arg->expr); - gfc_add_block_to_block (&se.pre, &cptrse.pre); - gfc_add_block_to_block (&se.post, &cptrse.post); - - gfc_init_se (&fptrse, NULL); - if (arg->next->expr->rank == 0) - { - fptrse.want_pointer = 1; - gfc_conv_expr (&fptrse, arg->next->expr); - gfc_add_block_to_block (&se.pre, &fptrse.pre); - gfc_add_block_to_block (&se.post, &fptrse.post); - if (arg->next->expr->symtree->n.sym->attr.proc_pointer - && arg->next->expr->symtree->n.sym->attr.dummy) - fptrse.expr = build_fold_indirect_ref_loc (input_location, - fptrse.expr); - se.expr = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (fptrse.expr), - fptrse.expr, - fold_convert (TREE_TYPE (fptrse.expr), - cptrse.expr)); - gfc_add_expr_to_block (&se.pre, se.expr); - gfc_add_block_to_block (&se.pre, &se.post); - return gfc_finish_block (&se.pre); - } - - gfc_start_block (&block); - - /* Get the descriptor of the Fortran pointer. */ - fptrse.descriptor_only = 1; - gfc_conv_expr_descriptor (&fptrse, arg->next->expr); - gfc_add_block_to_block (&block, &fptrse.pre); - desc = fptrse.expr; - - /* Set the span field. */ - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); - tmp = fold_convert (gfc_array_index_type, tmp); - gfc_conv_descriptor_span_set (&block, desc, tmp); - - /* Set data value, dtype, and offset. */ - tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); - gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr)); - gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), - gfc_get_dtype (TREE_TYPE (desc))); - - /* Start scalarization of the bounds, using the shape argument. */ - - shape_ss = gfc_walk_expr (arg->next->next->expr); - gcc_assert (shape_ss != gfc_ss_terminator); - gfc_init_se (&shapese, NULL); - - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, shape_ss); - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &arg->next->expr->where); - gfc_mark_ss_chain_used (shape_ss, 1); - - gfc_copy_loopinfo_to_se (&shapese, &loop); - shapese.ss = shape_ss; - - stride = gfc_create_var (gfc_array_index_type, "stride"); - offset = gfc_create_var (gfc_array_index_type, "offset"); - gfc_add_modify (&block, stride, gfc_index_one_node); - gfc_add_modify (&block, offset, gfc_index_zero_node); - - /* Loop body. */ - gfc_start_scalarized_body (&loop, &body); - - dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - loop.loopvar[0], loop.from[0]); - - /* Set bounds and stride. */ - gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); - gfc_conv_descriptor_stride_set (&body, desc, dim, stride); - - gfc_conv_expr (&shapese, arg->next->next->expr); - gfc_add_block_to_block (&body, &shapese.pre); - gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); - gfc_add_block_to_block (&body, &shapese.post); - - /* Calculate offset. */ - gfc_add_modify (&body, offset, - fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, offset, stride)); - /* Update stride. */ - gfc_add_modify (&body, stride, - fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, stride, - fold_convert (gfc_array_index_type, - shapese.expr))); - /* Finish scalarization loop. */ - gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&block, &loop.pre); - gfc_add_block_to_block (&block, &loop.post); - gfc_add_block_to_block (&block, &fptrse.post); - gfc_cleanup_loop (&loop); - - gfc_add_modify (&block, offset, - fold_build1_loc (input_location, NEGATE_EXPR, - gfc_array_index_type, offset)); - gfc_conv_descriptor_offset_set (&block, desc, offset); - - gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block)); - gfc_add_block_to_block (&se.pre, &se.post); - return gfc_finish_block (&se.pre); -} - - -/* Save and restore floating-point state. */ - -tree -gfc_save_fp_state (stmtblock_t *block) -{ - tree type, fpstate, tmp; - - type = build_array_type (char_type_node, - build_range_type (size_type_node, size_zero_node, - size_int (GFC_FPE_STATE_BUFFER_SIZE))); - fpstate = gfc_create_var (type, "fpstate"); - fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry, - 1, fpstate); - gfc_add_expr_to_block (block, tmp); - - return fpstate; -} - - -void -gfc_restore_fp_state (stmtblock_t *block, tree fpstate) -{ - tree tmp; - - tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit, - 1, fpstate); - gfc_add_expr_to_block (block, tmp); -} - - -/* Generate code for arguments of IEEE functions. */ - -static void -conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray, - int nargs) -{ - gfc_actual_arglist *actual; - gfc_expr *e; - gfc_se argse; - int arg; - - actual = expr->value.function.actual; - for (arg = 0; arg < nargs; arg++, actual = actual->next) - { - gcc_assert (actual); - e = actual->expr; - - gfc_init_se (&argse, se); - gfc_conv_expr_val (&argse, e); - - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - argarray[arg] = argse.expr; - } -} - - -/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE, - and IEEE_UNORDERED, which translate directly to GCC type-generic - built-ins. */ - -static void -conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr, - enum built_in_function code, int nargs) -{ - tree args[2]; - gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0])); - - conv_ieee_function_args (se, expr, args, nargs); - se->expr = build_call_expr_loc_array (input_location, - builtin_decl_explicit (code), - nargs, args); - STRIP_TYPE_NOPS (se->expr); - se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - - -/* Generate code for IEEE_IS_NORMAL intrinsic: - IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */ - -static void -conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr) -{ - tree arg, isnormal, iszero; - - /* Convert arg, evaluate it only once. */ - conv_ieee_function_args (se, expr, &arg, 1); - arg = gfc_evaluate_now (arg, &se->pre); - - isnormal = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISNORMAL), - 1, arg); - iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, - build_real_from_int_cst (TREE_TYPE (arg), - integer_zero_node)); - se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, isnormal, iszero); - se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - - -/* Generate code for IEEE_IS_NEGATIVE intrinsic: - IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */ - -static void -conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr) -{ - tree arg, signbit, isnan; - - /* Convert arg, evaluate it only once. */ - conv_ieee_function_args (se, expr, &arg, 1); - arg = gfc_evaluate_now (arg, &se->pre); - - isnan = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_ISNAN), - 1, arg); - STRIP_TYPE_NOPS (isnan); - - signbit = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_SIGNBIT), - 1, arg); - signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - signbit, integer_zero_node); - - se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, signbit, - fold_build1_loc (input_location, TRUTH_NOT_EXPR, - TREE_TYPE(isnan), isnan)); - - se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); -} - - -/* Generate code for IEEE_LOGB and IEEE_RINT. */ - -static void -conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr, - enum built_in_function code) -{ - tree arg, decl, call, fpstate; - int argprec; - - conv_ieee_function_args (se, expr, &arg, 1); - argprec = TYPE_PRECISION (TREE_TYPE (arg)); - decl = builtin_decl_for_precision (code, argprec); - - /* Save floating-point state. */ - fpstate = gfc_save_fp_state (&se->pre); - - /* Make the function call. */ - call = build_call_expr_loc (input_location, decl, 1, arg); - se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call); - - /* Restore floating-point state. */ - gfc_restore_fp_state (&se->post, fpstate); -} - - -/* Generate code for IEEE_REM. */ - -static void -conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr) -{ - tree args[2], decl, call, fpstate; - int argprec; - - conv_ieee_function_args (se, expr, args, 2); - - /* If arguments have unequal size, convert them to the larger. */ - if (TYPE_PRECISION (TREE_TYPE (args[0])) - > TYPE_PRECISION (TREE_TYPE (args[1]))) - args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); - else if (TYPE_PRECISION (TREE_TYPE (args[1])) - > TYPE_PRECISION (TREE_TYPE (args[0]))) - args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); - - argprec = TYPE_PRECISION (TREE_TYPE (args[0])); - decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec); - - /* Save floating-point state. */ - fpstate = gfc_save_fp_state (&se->pre); - - /* Make the function call. */ - call = build_call_expr_loc_array (input_location, decl, 2, args); - se->expr = fold_convert (TREE_TYPE (args[0]), call); - - /* Restore floating-point state. */ - gfc_restore_fp_state (&se->post, fpstate); -} - - -/* Generate code for IEEE_NEXT_AFTER. */ - -static void -conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr) -{ - tree args[2], decl, call, fpstate; - int argprec; - - conv_ieee_function_args (se, expr, args, 2); - - /* Result has the characteristics of first argument. */ - args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); - argprec = TYPE_PRECISION (TREE_TYPE (args[0])); - decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec); - - /* Save floating-point state. */ - fpstate = gfc_save_fp_state (&se->pre); - - /* Make the function call. */ - call = build_call_expr_loc_array (input_location, decl, 2, args); - se->expr = fold_convert (TREE_TYPE (args[0]), call); - - /* Restore floating-point state. */ - gfc_restore_fp_state (&se->post, fpstate); -} - - -/* Generate code for IEEE_SCALB. */ - -static void -conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr) -{ - tree args[2], decl, call, huge, type; - int argprec, n; - - conv_ieee_function_args (se, expr, args, 2); - - /* Result has the characteristics of first argument. */ - argprec = TYPE_PRECISION (TREE_TYPE (args[0])); - decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec); - - if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node)) - { - /* We need to fold the integer into the range of a C int. */ - args[1] = gfc_evaluate_now (args[1], &se->pre); - type = TREE_TYPE (args[1]); - - n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false); - huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, - gfc_c_int_kind); - huge = fold_convert (type, huge); - args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1], - huge); - args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1], - fold_build1_loc (input_location, NEGATE_EXPR, - type, huge)); - } - - args[1] = fold_convert (integer_type_node, args[1]); - - /* Make the function call. */ - call = build_call_expr_loc_array (input_location, decl, 2, args); - se->expr = fold_convert (TREE_TYPE (args[0]), call); -} - - -/* Generate code for IEEE_COPY_SIGN. */ - -static void -conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr) -{ - tree args[2], decl, sign; - int argprec; - - conv_ieee_function_args (se, expr, args, 2); - - /* Get the sign of the second argument. */ - sign = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_SIGNBIT), - 1, args[1]); - sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - sign, integer_zero_node); - - /* Create a value of one, with the right sign. */ - sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node, - sign, - fold_build1_loc (input_location, NEGATE_EXPR, - integer_type_node, - integer_one_node), - integer_one_node); - args[1] = fold_convert (TREE_TYPE (args[0]), sign); - - argprec = TYPE_PRECISION (TREE_TYPE (args[0])); - decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec); - - se->expr = build_call_expr_loc_array (input_location, decl, 2, args); -} - - -/* Generate code for an intrinsic function from the IEEE_ARITHMETIC - module. */ - -bool -gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr) -{ - const char *name = expr->value.function.name; - - if (startswith (name, "_gfortran_ieee_is_nan")) - conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1); - else if (startswith (name, "_gfortran_ieee_is_finite")) - conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1); - else if (startswith (name, "_gfortran_ieee_unordered")) - conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2); - else if (startswith (name, "_gfortran_ieee_is_normal")) - conv_intrinsic_ieee_is_normal (se, expr); - else if (startswith (name, "_gfortran_ieee_is_negative")) - conv_intrinsic_ieee_is_negative (se, expr); - else if (startswith (name, "_gfortran_ieee_copy_sign")) - conv_intrinsic_ieee_copy_sign (se, expr); - else if (startswith (name, "_gfortran_ieee_scalb")) - conv_intrinsic_ieee_scalb (se, expr); - else if (startswith (name, "_gfortran_ieee_next_after")) - conv_intrinsic_ieee_next_after (se, expr); - else if (startswith (name, "_gfortran_ieee_rem")) - conv_intrinsic_ieee_rem (se, expr); - else if (startswith (name, "_gfortran_ieee_logb")) - conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB); - else if (startswith (name, "_gfortran_ieee_rint")) - conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT); - else - /* It is not among the functions we translate directly. We return - false, so a library function call is emitted. */ - return false; - - return true; -} - - -/* Generate a direct call to malloc() for the MALLOC intrinsic. */ - -static void -gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr) -{ - tree arg, res, restype; - - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - arg = fold_convert (size_type_node, arg); - res = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg); - restype = gfc_typenode_for_spec (&expr->ts); - se->expr = fold_convert (restype, res); -} - - -/* Generate code for an intrinsic function. Some map directly to library - calls, others get special handling. In some cases the name of the function - used depends on the type specifiers. */ - -void -gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) -{ - const char *name; - int lib, kind; - tree fndecl; - - name = &expr->value.function.name[2]; - - if (expr->rank > 0) - { - lib = gfc_is_intrinsic_libcall (expr); - if (lib != 0) - { - if (lib == 1) - se->ignore_optional = 1; - - switch (expr->value.function.isym->id) - { - case GFC_ISYM_EOSHIFT: - case GFC_ISYM_PACK: - case GFC_ISYM_RESHAPE: - /* For all of those the first argument specifies the type and the - third is optional. */ - conv_generic_with_optional_char_arg (se, expr, 1, 3); - break; - - case GFC_ISYM_FINDLOC: - gfc_conv_intrinsic_findloc (se, expr); - break; - - case GFC_ISYM_MINLOC: - gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); - break; - - case GFC_ISYM_MAXLOC: - gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); - break; - - default: - gfc_conv_intrinsic_funcall (se, expr); - break; - } - - return; - } - } - - switch (expr->value.function.isym->id) - { - case GFC_ISYM_NONE: - gcc_unreachable (); - - case GFC_ISYM_REPEAT: - gfc_conv_intrinsic_repeat (se, expr); - break; - - case GFC_ISYM_TRIM: - gfc_conv_intrinsic_trim (se, expr); - break; - - case GFC_ISYM_SC_KIND: - gfc_conv_intrinsic_sc_kind (se, expr); - break; - - case GFC_ISYM_SI_KIND: - gfc_conv_intrinsic_si_kind (se, expr); - break; - - case GFC_ISYM_SR_KIND: - gfc_conv_intrinsic_sr_kind (se, expr); - break; - - case GFC_ISYM_EXPONENT: - gfc_conv_intrinsic_exponent (se, expr); - break; - - case GFC_ISYM_SCAN: - kind = expr->value.function.actual->expr->ts.kind; - if (kind == 1) - fndecl = gfor_fndecl_string_scan; - else if (kind == 4) - fndecl = gfor_fndecl_string_scan_char4; - else - gcc_unreachable (); - - gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); - break; - - case GFC_ISYM_VERIFY: - kind = expr->value.function.actual->expr->ts.kind; - if (kind == 1) - fndecl = gfor_fndecl_string_verify; - else if (kind == 4) - fndecl = gfor_fndecl_string_verify_char4; - else - gcc_unreachable (); - - gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); - break; - - case GFC_ISYM_ALLOCATED: - gfc_conv_allocated (se, expr); - break; - - case GFC_ISYM_ASSOCIATED: - gfc_conv_associated(se, expr); - break; - - case GFC_ISYM_SAME_TYPE_AS: - gfc_conv_same_type_as (se, expr); - break; - - case GFC_ISYM_ABS: - gfc_conv_intrinsic_abs (se, expr); - break; - - case GFC_ISYM_ADJUSTL: - if (expr->ts.kind == 1) - fndecl = gfor_fndecl_adjustl; - else if (expr->ts.kind == 4) - fndecl = gfor_fndecl_adjustl_char4; - else - gcc_unreachable (); - - gfc_conv_intrinsic_adjust (se, expr, fndecl); - break; - - case GFC_ISYM_ADJUSTR: - if (expr->ts.kind == 1) - fndecl = gfor_fndecl_adjustr; - else if (expr->ts.kind == 4) - fndecl = gfor_fndecl_adjustr_char4; - else - gcc_unreachable (); - - gfc_conv_intrinsic_adjust (se, expr, fndecl); - break; - - case GFC_ISYM_AIMAG: - gfc_conv_intrinsic_imagpart (se, expr); - break; - - case GFC_ISYM_AINT: - gfc_conv_intrinsic_aint (se, expr, RND_TRUNC); - break; - - case GFC_ISYM_ALL: - gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR); - break; - - case GFC_ISYM_ANINT: - gfc_conv_intrinsic_aint (se, expr, RND_ROUND); - break; - - case GFC_ISYM_AND: - gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); - break; - - case GFC_ISYM_ANY: - gfc_conv_intrinsic_anyall (se, expr, NE_EXPR); - break; - - case GFC_ISYM_ACOSD: - case GFC_ISYM_ASIND: - case GFC_ISYM_ATAND: - gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id); - break; - - case GFC_ISYM_COTAN: - gfc_conv_intrinsic_cotan (se, expr); - break; - - case GFC_ISYM_COTAND: - gfc_conv_intrinsic_cotand (se, expr); - break; - - case GFC_ISYM_ATAN2D: - gfc_conv_intrinsic_atan2d (se, expr); - break; - - case GFC_ISYM_BTEST: - gfc_conv_intrinsic_btest (se, expr); - break; - - case GFC_ISYM_BGE: - gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR); - break; - - case GFC_ISYM_BGT: - gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR); - break; - - case GFC_ISYM_BLE: - gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR); - break; - - case GFC_ISYM_BLT: - gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR); - break; - - case GFC_ISYM_C_ASSOCIATED: - case GFC_ISYM_C_FUNLOC: - case GFC_ISYM_C_LOC: - conv_isocbinding_function (se, expr); - break; - - case GFC_ISYM_ACHAR: - case GFC_ISYM_CHAR: - gfc_conv_intrinsic_char (se, expr); - break; - - case GFC_ISYM_CONVERSION: - case GFC_ISYM_DBLE: - case GFC_ISYM_DFLOAT: - case GFC_ISYM_FLOAT: - case GFC_ISYM_LOGICAL: - case GFC_ISYM_REAL: - case GFC_ISYM_REALPART: - case GFC_ISYM_SNGL: - gfc_conv_intrinsic_conversion (se, expr); - break; - - /* Integer conversions are handled separately to make sure we get the - correct rounding mode. */ - case GFC_ISYM_INT: - case GFC_ISYM_INT2: - case GFC_ISYM_INT8: - case GFC_ISYM_LONG: - gfc_conv_intrinsic_int (se, expr, RND_TRUNC); - break; - - case GFC_ISYM_NINT: - gfc_conv_intrinsic_int (se, expr, RND_ROUND); - break; - - case GFC_ISYM_CEILING: - gfc_conv_intrinsic_int (se, expr, RND_CEIL); - break; - - case GFC_ISYM_FLOOR: - gfc_conv_intrinsic_int (se, expr, RND_FLOOR); - break; - - case GFC_ISYM_MOD: - gfc_conv_intrinsic_mod (se, expr, 0); - break; - - case GFC_ISYM_MODULO: - gfc_conv_intrinsic_mod (se, expr, 1); - break; - - case GFC_ISYM_CAF_GET: - gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE, - false, NULL); - break; - - case GFC_ISYM_CMPLX: - gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1'); - break; - - case GFC_ISYM_COMMAND_ARGUMENT_COUNT: - gfc_conv_intrinsic_iargc (se, expr); - break; - - case GFC_ISYM_COMPLEX: - gfc_conv_intrinsic_cmplx (se, expr, 1); - break; - - case GFC_ISYM_CONJG: - gfc_conv_intrinsic_conjg (se, expr); - break; - - case GFC_ISYM_COUNT: - gfc_conv_intrinsic_count (se, expr); - break; - - case GFC_ISYM_CTIME: - gfc_conv_intrinsic_ctime (se, expr); - break; - - case GFC_ISYM_DIM: - gfc_conv_intrinsic_dim (se, expr); - break; - - case GFC_ISYM_DOT_PRODUCT: - gfc_conv_intrinsic_dot_product (se, expr); - break; - - case GFC_ISYM_DPROD: - gfc_conv_intrinsic_dprod (se, expr); - break; - - case GFC_ISYM_DSHIFTL: - gfc_conv_intrinsic_dshift (se, expr, true); - break; - - case GFC_ISYM_DSHIFTR: - gfc_conv_intrinsic_dshift (se, expr, false); - break; - - case GFC_ISYM_FDATE: - gfc_conv_intrinsic_fdate (se, expr); - break; - - case GFC_ISYM_FRACTION: - gfc_conv_intrinsic_fraction (se, expr); - break; - - case GFC_ISYM_IALL: - gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false); - break; - - case GFC_ISYM_IAND: - gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); - break; - - case GFC_ISYM_IANY: - gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false); - break; - - case GFC_ISYM_IBCLR: - gfc_conv_intrinsic_singlebitop (se, expr, 0); - break; - - case GFC_ISYM_IBITS: - gfc_conv_intrinsic_ibits (se, expr); - break; - - case GFC_ISYM_IBSET: - gfc_conv_intrinsic_singlebitop (se, expr, 1); - break; - - case GFC_ISYM_IACHAR: - case GFC_ISYM_ICHAR: - /* We assume ASCII character sequence. */ - gfc_conv_intrinsic_ichar (se, expr); - break; - - case GFC_ISYM_IARGC: - gfc_conv_intrinsic_iargc (se, expr); - break; - - case GFC_ISYM_IEOR: - gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); - break; - - case GFC_ISYM_INDEX: - kind = expr->value.function.actual->expr->ts.kind; - if (kind == 1) - fndecl = gfor_fndecl_string_index; - else if (kind == 4) - fndecl = gfor_fndecl_string_index_char4; - else - gcc_unreachable (); - - gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); - break; - - case GFC_ISYM_IOR: - gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); - break; - - case GFC_ISYM_IPARITY: - gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false); - break; - - case GFC_ISYM_IS_IOSTAT_END: - gfc_conv_has_intvalue (se, expr, LIBERROR_END); - break; - - case GFC_ISYM_IS_IOSTAT_EOR: - gfc_conv_has_intvalue (se, expr, LIBERROR_EOR); - break; - - case GFC_ISYM_IS_CONTIGUOUS: - gfc_conv_intrinsic_is_contiguous (se, expr); - break; - - case GFC_ISYM_ISNAN: - gfc_conv_intrinsic_isnan (se, expr); - break; - - case GFC_ISYM_KILL: - conv_intrinsic_kill (se, expr); - break; - - case GFC_ISYM_LSHIFT: - gfc_conv_intrinsic_shift (se, expr, false, false); - break; - - case GFC_ISYM_RSHIFT: - gfc_conv_intrinsic_shift (se, expr, true, true); - break; - - case GFC_ISYM_SHIFTA: - gfc_conv_intrinsic_shift (se, expr, true, true); - break; - - case GFC_ISYM_SHIFTL: - gfc_conv_intrinsic_shift (se, expr, false, false); - break; - - case GFC_ISYM_SHIFTR: - gfc_conv_intrinsic_shift (se, expr, true, false); - break; - - case GFC_ISYM_ISHFT: - gfc_conv_intrinsic_ishft (se, expr); - break; - - case GFC_ISYM_ISHFTC: - gfc_conv_intrinsic_ishftc (se, expr); - break; - - case GFC_ISYM_LEADZ: - gfc_conv_intrinsic_leadz (se, expr); - break; - - case GFC_ISYM_TRAILZ: - gfc_conv_intrinsic_trailz (se, expr); - break; - - case GFC_ISYM_POPCNT: - gfc_conv_intrinsic_popcnt_poppar (se, expr, 0); - break; - - case GFC_ISYM_POPPAR: - gfc_conv_intrinsic_popcnt_poppar (se, expr, 1); - break; - - case GFC_ISYM_LBOUND: - gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND); - break; - - case GFC_ISYM_LCOBOUND: - conv_intrinsic_cobound (se, expr); - break; - - case GFC_ISYM_TRANSPOSE: - /* The scalarizer has already been set up for reversed dimension access - order ; now we just get the argument value normally. */ - gfc_conv_expr (se, expr->value.function.actual->expr); - break; - - case GFC_ISYM_LEN: - gfc_conv_intrinsic_len (se, expr); - break; - - case GFC_ISYM_LEN_TRIM: - gfc_conv_intrinsic_len_trim (se, expr); - break; - - case GFC_ISYM_LGE: - gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR); - break; - - case GFC_ISYM_LGT: - gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR); - break; - - case GFC_ISYM_LLE: - gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR); - break; - - case GFC_ISYM_LLT: - gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR); - break; - - case GFC_ISYM_MALLOC: - gfc_conv_intrinsic_malloc (se, expr); - break; - - case GFC_ISYM_MASKL: - gfc_conv_intrinsic_mask (se, expr, 1); - break; - - case GFC_ISYM_MASKR: - gfc_conv_intrinsic_mask (se, expr, 0); - break; - - case GFC_ISYM_MAX: - if (expr->ts.type == BT_CHARACTER) - gfc_conv_intrinsic_minmax_char (se, expr, 1); - else - gfc_conv_intrinsic_minmax (se, expr, GT_EXPR); - break; - - case GFC_ISYM_MAXLOC: - gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); - break; - - case GFC_ISYM_FINDLOC: - gfc_conv_intrinsic_findloc (se, expr); - break; - - case GFC_ISYM_MAXVAL: - gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR); - break; - - case GFC_ISYM_MERGE: - gfc_conv_intrinsic_merge (se, expr); - break; - - case GFC_ISYM_MERGE_BITS: - gfc_conv_intrinsic_merge_bits (se, expr); - break; - - case GFC_ISYM_MIN: - if (expr->ts.type == BT_CHARACTER) - gfc_conv_intrinsic_minmax_char (se, expr, -1); - else - gfc_conv_intrinsic_minmax (se, expr, LT_EXPR); - break; - - case GFC_ISYM_MINLOC: - gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); - break; - - case GFC_ISYM_MINVAL: - gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR); - break; - - case GFC_ISYM_NEAREST: - gfc_conv_intrinsic_nearest (se, expr); - break; - - case GFC_ISYM_NORM2: - gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true); - break; - - case GFC_ISYM_NOT: - gfc_conv_intrinsic_not (se, expr); - break; - - case GFC_ISYM_OR: - gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); - break; - - case GFC_ISYM_PARITY: - gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false); - break; - - case GFC_ISYM_PRESENT: - gfc_conv_intrinsic_present (se, expr); - break; - - case GFC_ISYM_PRODUCT: - gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false); - break; - - case GFC_ISYM_RANK: - gfc_conv_intrinsic_rank (se, expr); - break; - - case GFC_ISYM_RRSPACING: - gfc_conv_intrinsic_rrspacing (se, expr); - break; - - case GFC_ISYM_SET_EXPONENT: - gfc_conv_intrinsic_set_exponent (se, expr); - break; - - case GFC_ISYM_SCALE: - gfc_conv_intrinsic_scale (se, expr); - break; - - case GFC_ISYM_SHAPE: - gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE); - break; - - case GFC_ISYM_SIGN: - gfc_conv_intrinsic_sign (se, expr); - break; - - case GFC_ISYM_SIZE: - gfc_conv_intrinsic_size (se, expr); - break; - - case GFC_ISYM_SIZEOF: - case GFC_ISYM_C_SIZEOF: - gfc_conv_intrinsic_sizeof (se, expr); - break; - - case GFC_ISYM_STORAGE_SIZE: - gfc_conv_intrinsic_storage_size (se, expr); - break; - - case GFC_ISYM_SPACING: - gfc_conv_intrinsic_spacing (se, expr); - break; - - case GFC_ISYM_STRIDE: - conv_intrinsic_stride (se, expr); - break; - - case GFC_ISYM_SUM: - gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false); - break; - - case GFC_ISYM_TEAM_NUMBER: - conv_intrinsic_team_number (se, expr); - break; - - case GFC_ISYM_TRANSFER: - if (se->ss && se->ss->info->useflags) - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - else - gfc_conv_intrinsic_transfer (se, expr); - break; - - case GFC_ISYM_TTYNAM: - gfc_conv_intrinsic_ttynam (se, expr); - break; - - case GFC_ISYM_UBOUND: - gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND); - break; - - case GFC_ISYM_UCOBOUND: - conv_intrinsic_cobound (se, expr); - break; - - case GFC_ISYM_XOR: - gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); - break; - - case GFC_ISYM_LOC: - gfc_conv_intrinsic_loc (se, expr); - break; - - case GFC_ISYM_THIS_IMAGE: - /* For num_images() == 1, handle as LCOBOUND. */ - if (expr->value.function.actual->expr - && flag_coarray == GFC_FCOARRAY_SINGLE) - conv_intrinsic_cobound (se, expr); - else - trans_this_image (se, expr); - break; - - case GFC_ISYM_IMAGE_INDEX: - trans_image_index (se, expr); - break; - - case GFC_ISYM_IMAGE_STATUS: - conv_intrinsic_image_status (se, expr); - break; - - case GFC_ISYM_NUM_IMAGES: - trans_num_images (se, expr); - break; - - case GFC_ISYM_ACCESS: - case GFC_ISYM_CHDIR: - case GFC_ISYM_CHMOD: - case GFC_ISYM_DTIME: - case GFC_ISYM_ETIME: - case GFC_ISYM_EXTENDS_TYPE_OF: - case GFC_ISYM_FGET: - case GFC_ISYM_FGETC: - case GFC_ISYM_FNUM: - case GFC_ISYM_FPUT: - case GFC_ISYM_FPUTC: - case GFC_ISYM_FSTAT: - case GFC_ISYM_FTELL: - case GFC_ISYM_GETCWD: - case GFC_ISYM_GETGID: - case GFC_ISYM_GETPID: - case GFC_ISYM_GETUID: - case GFC_ISYM_HOSTNM: - case GFC_ISYM_IERRNO: - case GFC_ISYM_IRAND: - case GFC_ISYM_ISATTY: - case GFC_ISYM_JN2: - case GFC_ISYM_LINK: - case GFC_ISYM_LSTAT: - case GFC_ISYM_MATMUL: - case GFC_ISYM_MCLOCK: - case GFC_ISYM_MCLOCK8: - case GFC_ISYM_RAND: - case GFC_ISYM_RENAME: - case GFC_ISYM_SECOND: - case GFC_ISYM_SECNDS: - case GFC_ISYM_SIGNAL: - case GFC_ISYM_STAT: - case GFC_ISYM_SYMLNK: - case GFC_ISYM_SYSTEM: - case GFC_ISYM_TIME: - case GFC_ISYM_TIME8: - case GFC_ISYM_UMASK: - case GFC_ISYM_UNLINK: - case GFC_ISYM_YN2: - gfc_conv_intrinsic_funcall (se, expr); - break; - - case GFC_ISYM_EOSHIFT: - case GFC_ISYM_PACK: - case GFC_ISYM_RESHAPE: - /* For those, expr->rank should always be >0 and thus the if above the - switch should have matched. */ - gcc_unreachable (); - break; - - default: - gfc_conv_intrinsic_lib_function (se, expr); - break; - } -} - - -static gfc_ss * -walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr) -{ - gfc_ss *arg_ss, *tmp_ss; - gfc_actual_arglist *arg; - - arg = expr->value.function.actual; - - gcc_assert (arg->expr); - - arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr); - gcc_assert (arg_ss != gfc_ss_terminator); - - for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next) - { - if (tmp_ss->info->type != GFC_SS_SCALAR - && tmp_ss->info->type != GFC_SS_REFERENCE) - { - gcc_assert (tmp_ss->dimen == 2); - - /* We just invert dimensions. */ - std::swap (tmp_ss->dim[0], tmp_ss->dim[1]); - } - - /* Stop when tmp_ss points to the last valid element of the chain... */ - if (tmp_ss->next == gfc_ss_terminator) - break; - } - - /* ... so that we can attach the rest of the chain to it. */ - tmp_ss->next = ss; - - return arg_ss; -} - - -/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list. - This has the side effect of reversing the nested list, so there is no - need to call gfc_reverse_ss on it (the given list is assumed not to be - reversed yet). */ - -static gfc_ss * -nest_loop_dimension (gfc_ss *ss, int dim) -{ - int ss_dim, i; - gfc_ss *new_ss, *prev_ss = gfc_ss_terminator; - gfc_loopinfo *new_loop; - - gcc_assert (ss != gfc_ss_terminator); - - for (; ss != gfc_ss_terminator; ss = ss->next) - { - new_ss = gfc_get_ss (); - new_ss->next = prev_ss; - new_ss->parent = ss; - new_ss->info = ss->info; - new_ss->info->refcount++; - if (ss->dimen != 0) - { - gcc_assert (ss->info->type != GFC_SS_SCALAR - && ss->info->type != GFC_SS_REFERENCE); - - new_ss->dimen = 1; - new_ss->dim[0] = ss->dim[dim]; - - gcc_assert (dim < ss->dimen); - - ss_dim = --ss->dimen; - for (i = dim; i < ss_dim; i++) - ss->dim[i] = ss->dim[i + 1]; - - ss->dim[ss_dim] = 0; - } - prev_ss = new_ss; - - if (ss->nested_ss) - { - ss->nested_ss->parent = new_ss; - new_ss->nested_ss = ss->nested_ss; - } - ss->nested_ss = new_ss; - } - - new_loop = gfc_get_loopinfo (); - gfc_init_loopinfo (new_loop); - - gcc_assert (prev_ss != NULL); - gcc_assert (prev_ss != gfc_ss_terminator); - gfc_add_ss_to_loop (new_loop, prev_ss); - return new_ss->parent; -} - - -/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function - is to be inlined. */ - -static gfc_ss * -walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr) -{ - gfc_ss *tmp_ss, *tail, *array_ss; - gfc_actual_arglist *arg1, *arg2, *arg3; - int sum_dim; - bool scalar_mask = false; - - /* The rank of the result will be determined later. */ - arg1 = expr->value.function.actual; - arg2 = arg1->next; - arg3 = arg2->next; - gcc_assert (arg3 != NULL); - - if (expr->rank == 0) - return ss; - - tmp_ss = gfc_ss_terminator; - - if (arg3->expr) - { - gfc_ss *mask_ss; - - mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr); - if (mask_ss == tmp_ss) - scalar_mask = 1; - - tmp_ss = mask_ss; - } - - array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr); - gcc_assert (array_ss != tmp_ss); - - /* Odd thing: If the mask is scalar, it is used by the frontend after - the array (to make an if around the nested loop). Thus it shall - be after array_ss once the gfc_ss list is reversed. */ - if (scalar_mask) - tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr); - else - tmp_ss = array_ss; - - /* "Hide" the dimension on which we will sum in the first arg's scalarization - chain. */ - sum_dim = mpz_get_si (arg2->expr->value.integer) - 1; - tail = nest_loop_dimension (tmp_ss, sum_dim); - tail->next = ss; - - return tmp_ss; -} - - -static gfc_ss * -walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr) -{ - - switch (expr->value.function.isym->id) - { - case GFC_ISYM_PRODUCT: - case GFC_ISYM_SUM: - return walk_inline_intrinsic_arith (ss, expr); - - case GFC_ISYM_TRANSPOSE: - return walk_inline_intrinsic_transpose (ss, expr); - - default: - gcc_unreachable (); - } - gcc_unreachable (); -} - - -/* This generates code to execute before entering the scalarization loop. - Currently does nothing. */ - -void -gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) -{ - switch (ss->info->expr->value.function.isym->id) - { - case GFC_ISYM_UBOUND: - case GFC_ISYM_LBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_THIS_IMAGE: - case GFC_ISYM_SHAPE: - break; - - default: - gcc_unreachable (); - } -} - - -/* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with - one parameter are expanded into code inside the scalarization loop. */ - -static gfc_ss * -gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) -{ - if (expr->value.function.actual->expr->ts.type == BT_CLASS) - gfc_add_class_array_ref (expr->value.function.actual->expr); - - /* The two argument version returns a scalar. */ - if (expr->value.function.isym->id != GFC_ISYM_SHAPE - && expr->value.function.actual->next->expr) - return ss; - - return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC); -} - - -/* Walk an intrinsic array libcall. */ - -static gfc_ss * -gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) -{ - gcc_assert (expr->rank > 0); - return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); -} - - -/* Return whether the function call expression EXPR will be expanded - inline by gfc_conv_intrinsic_function. */ - -bool -gfc_inline_intrinsic_function_p (gfc_expr *expr) -{ - gfc_actual_arglist *args, *dim_arg, *mask_arg; - gfc_expr *maskexpr; - - if (!expr->value.function.isym) - return false; - - switch (expr->value.function.isym->id) - { - case GFC_ISYM_PRODUCT: - case GFC_ISYM_SUM: - /* Disable inline expansion if code size matters. */ - if (optimize_size) - return false; - - args = expr->value.function.actual; - dim_arg = args->next; - - /* We need to be able to subset the SUM argument at compile-time. */ - if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT) - return false; - - /* FIXME: If MASK is optional for a more than two-dimensional - argument, the scalarizer gets confused if the mask is - absent. See PR 82995. For now, fall back to the library - function. */ - - mask_arg = dim_arg->next; - maskexpr = mask_arg->expr; - - if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE - && maskexpr->symtree->n.sym->attr.dummy - && maskexpr->symtree->n.sym->attr.optional) - return false; - - return true; - - case GFC_ISYM_TRANSPOSE: - return true; - - default: - return false; - } -} - - -/* Returns nonzero if the specified intrinsic function call maps directly to - an external library call. Should only be used for functions that return - arrays. */ - -int -gfc_is_intrinsic_libcall (gfc_expr * expr) -{ - gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); - gcc_assert (expr->rank > 0); - - if (gfc_inline_intrinsic_function_p (expr)) - return 0; - - switch (expr->value.function.isym->id) - { - case GFC_ISYM_ALL: - case GFC_ISYM_ANY: - case GFC_ISYM_COUNT: - case GFC_ISYM_FINDLOC: - case GFC_ISYM_JN2: - case GFC_ISYM_IANY: - case GFC_ISYM_IALL: - case GFC_ISYM_IPARITY: - case GFC_ISYM_MATMUL: - case GFC_ISYM_MAXLOC: - case GFC_ISYM_MAXVAL: - case GFC_ISYM_MINLOC: - case GFC_ISYM_MINVAL: - case GFC_ISYM_NORM2: - case GFC_ISYM_PARITY: - case GFC_ISYM_PRODUCT: - case GFC_ISYM_SUM: - case GFC_ISYM_SPREAD: - case GFC_ISYM_YN2: - /* Ignore absent optional parameters. */ - return 1; - - case GFC_ISYM_CSHIFT: - case GFC_ISYM_EOSHIFT: - case GFC_ISYM_GET_TEAM: - case GFC_ISYM_FAILED_IMAGES: - case GFC_ISYM_STOPPED_IMAGES: - case GFC_ISYM_PACK: - case GFC_ISYM_RESHAPE: - case GFC_ISYM_UNPACK: - /* Pass absent optional parameters. */ - return 2; - - default: - return 0; - } -} - -/* Walk an intrinsic function. */ -gfc_ss * -gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, - gfc_intrinsic_sym * isym) -{ - gcc_assert (isym); - - if (isym->elemental) - return gfc_walk_elemental_function_args (ss, expr->value.function.actual, - expr->value.function.isym, - GFC_SS_SCALAR); - - if (expr->rank == 0) - return ss; - - if (gfc_inline_intrinsic_function_p (expr)) - return walk_inline_intrinsic_function (ss, expr); - - if (gfc_is_intrinsic_libcall (expr)) - return gfc_walk_intrinsic_libfunc (ss, expr); - - /* Special cases. */ - switch (isym->id) - { - case GFC_ISYM_LBOUND: - case GFC_ISYM_LCOBOUND: - case GFC_ISYM_UBOUND: - case GFC_ISYM_UCOBOUND: - case GFC_ISYM_THIS_IMAGE: - case GFC_ISYM_SHAPE: - return gfc_walk_intrinsic_bound (ss, expr); - - case GFC_ISYM_TRANSFER: - case GFC_ISYM_CAF_GET: - return gfc_walk_intrinsic_libfunc (ss, expr); - - default: - /* This probably meant someone forgot to add an intrinsic to the above - list(s) when they implemented it, or something's gone horribly - wrong. */ - gcc_unreachable (); - } -} - -static tree -conv_co_collective (gfc_code *code) -{ - gfc_se argse; - stmtblock_t block, post_block; - tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len; - gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr; - - gfc_start_block (&block); - gfc_init_block (&post_block); - - if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE) - { - opr_expr = code->ext.actual->next->expr; - image_idx_expr = code->ext.actual->next->next->expr; - stat_expr = code->ext.actual->next->next->next->expr; - errmsg_expr = code->ext.actual->next->next->next->next->expr; - } - else - { - opr_expr = NULL; - image_idx_expr = code->ext.actual->next->expr; - stat_expr = code->ext.actual->next->next->expr; - errmsg_expr = code->ext.actual->next->next->next->expr; - } - - /* stat. */ - if (stat_expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, stat_expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - stat = argse.expr; - if (flag_coarray != GFC_FCOARRAY_SINGLE) - stat = gfc_build_addr_expr (NULL_TREE, stat); - } - else if (flag_coarray == GFC_FCOARRAY_SINGLE) - stat = NULL_TREE; - else - stat = null_pointer_node; - - /* Early exit for GFC_FCOARRAY_SINGLE. */ - if (flag_coarray == GFC_FCOARRAY_SINGLE) - { - if (stat != NULL_TREE) - { - /* For optional stats, check the pointer is valid before zero'ing. */ - if (gfc_expr_attr (stat_expr).optional) - { - tree tmp; - stmtblock_t ass_block; - gfc_start_block (&ass_block); - gfc_add_modify (&ass_block, stat, - fold_convert (TREE_TYPE (stat), - integer_zero_node)); - tmp = fold_build2 (NE_EXPR, logical_type_node, - gfc_build_addr_expr (NULL_TREE, stat), - null_pointer_node); - tmp = fold_build3 (COND_EXPR, void_type_node, tmp, - gfc_finish_block (&ass_block), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - else - gfc_add_modify (&block, stat, - fold_convert (TREE_TYPE (stat), integer_zero_node)); - } - return gfc_finish_block (&block); - } - - /* Handle the array. */ - gfc_init_se (&argse, NULL); - if (code->ext.actual->expr->rank == 0) - { - symbol_attribute attr; - gfc_clear_attr (&attr); - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, code->ext.actual->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); - array = gfc_build_addr_expr (NULL_TREE, array); - } - else - { - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); - array = argse.expr; - } - - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - - if (code->ext.actual->expr->ts.type == BT_CHARACTER) - strlen = argse.string_length; - else - strlen = integer_zero_node; - - /* image_index. */ - if (image_idx_expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, image_idx_expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - image_index = fold_convert (integer_type_node, argse.expr); - } - else - image_index = integer_zero_node; - - /* errmsg. */ - if (errmsg_expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, errmsg_expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - errmsg = argse.expr; - errmsg_len = fold_convert (size_type_node, argse.string_length); - } - else - { - errmsg = null_pointer_node; - errmsg_len = build_zero_cst (size_type_node); - } - - /* Generate the function call. */ - switch (code->resolved_isym->id) - { - case GFC_ISYM_CO_BROADCAST: - fndecl = gfor_fndecl_co_broadcast; - break; - case GFC_ISYM_CO_MAX: - fndecl = gfor_fndecl_co_max; - break; - case GFC_ISYM_CO_MIN: - fndecl = gfor_fndecl_co_min; - break; - case GFC_ISYM_CO_REDUCE: - fndecl = gfor_fndecl_co_reduce; - break; - case GFC_ISYM_CO_SUM: - fndecl = gfor_fndecl_co_sum; - break; - default: - gcc_unreachable (); - } - - gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED - ? code->ext.actual->expr->ts.u.derived : NULL; - - if (derived && derived->attr.alloc_comp - && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) - /* The derived type has the attribute 'alloc_comp'. */ - { - tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr, - code->ext.actual->expr->rank, - image_index, stat, errmsg, errmsg_len); - gfc_add_expr_to_block (&block, tmp); - } - else - { - if (code->resolved_isym->id == GFC_ISYM_CO_SUM - || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) - fndecl = build_call_expr_loc (input_location, fndecl, 5, array, - image_index, stat, errmsg, errmsg_len); - else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE) - fndecl = build_call_expr_loc (input_location, fndecl, 6, array, - image_index, stat, errmsg, - strlen, errmsg_len); - else - { - tree opr, opr_flags; - - // FIXME: Handle TS29113's bind(C) strings with descriptor. - int opr_flag_int; - if (gfc_is_proc_ptr_comp (opr_expr)) - { - gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface; - opr_flag_int = sym->attr.dimension - || (sym->ts.type == BT_CHARACTER - && !sym->attr.is_bind_c) - ? GFC_CAF_BYREF : 0; - opr_flag_int |= opr_expr->ts.type == BT_CHARACTER - && !sym->attr.is_bind_c - ? GFC_CAF_HIDDENLEN : 0; - opr_flag_int |= sym->formal->sym->attr.value - ? GFC_CAF_ARG_VALUE : 0; - } - else - { - opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym) - ? GFC_CAF_BYREF : 0; - opr_flag_int |= opr_expr->ts.type == BT_CHARACTER - && !opr_expr->symtree->n.sym->attr.is_bind_c - ? GFC_CAF_HIDDENLEN : 0; - opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value - ? GFC_CAF_ARG_VALUE : 0; - } - opr_flags = build_int_cst (integer_type_node, opr_flag_int); - gfc_conv_expr (&argse, opr_expr); - opr = argse.expr; - fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, - opr_flags, image_index, stat, errmsg, - strlen, errmsg_len); - } - } - - gfc_add_expr_to_block (&block, fndecl); - gfc_add_block_to_block (&block, &post_block); - - return gfc_finish_block (&block); -} - - -static tree -conv_intrinsic_atomic_op (gfc_code *code) -{ - gfc_se argse; - tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE; - stmtblock_t block, post_block; - gfc_expr *atom_expr = code->ext.actual->expr; - gfc_expr *stat_expr; - built_in_function fn; - - if (atom_expr->expr_type == EXPR_FUNCTION - && atom_expr->value.function.isym - && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) - atom_expr = atom_expr->value.function.actual->expr; - - gfc_start_block (&block); - gfc_init_block (&post_block); - - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr (&argse, atom_expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - atom = argse.expr; - - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB - && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind) - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->ext.actual->next->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - value = argse.expr; - - switch (code->resolved_isym->id) - { - case GFC_ISYM_ATOMIC_ADD: - case GFC_ISYM_ATOMIC_AND: - case GFC_ISYM_ATOMIC_DEF: - case GFC_ISYM_ATOMIC_OR: - case GFC_ISYM_ATOMIC_XOR: - stat_expr = code->ext.actual->next->next->expr; - if (flag_coarray == GFC_FCOARRAY_LIB) - old = null_pointer_node; - break; - default: - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB) - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->ext.actual->next->next->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - old = argse.expr; - stat_expr = code->ext.actual->next->next->next->expr; - } - - /* STAT= */ - if (stat_expr != NULL) - { - gcc_assert (stat_expr->expr_type == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB) - argse.want_pointer = 1; - gfc_conv_expr_val (&argse, stat_expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - stat = argse.expr; - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - stat = null_pointer_node; - - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree image_index, caf_decl, offset, token; - int op; - - switch (code->resolved_isym->id) - { - case GFC_ISYM_ATOMIC_ADD: - case GFC_ISYM_ATOMIC_FETCH_ADD: - op = (int) GFC_CAF_ATOMIC_ADD; - break; - case GFC_ISYM_ATOMIC_AND: - case GFC_ISYM_ATOMIC_FETCH_AND: - op = (int) GFC_CAF_ATOMIC_AND; - break; - case GFC_ISYM_ATOMIC_OR: - case GFC_ISYM_ATOMIC_FETCH_OR: - op = (int) GFC_CAF_ATOMIC_OR; - break; - case GFC_ISYM_ATOMIC_XOR: - case GFC_ISYM_ATOMIC_FETCH_XOR: - op = (int) GFC_CAF_ATOMIC_XOR; - break; - case GFC_ISYM_ATOMIC_DEF: - op = 0; /* Unused. */ - break; - default: - gcc_unreachable (); - } - - caf_decl = gfc_get_tree_for_caf_expr (atom_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - - if (gfc_is_coindexed (atom_expr)) - image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); - else - image_index = integer_zero_node; - - if (!POINTER_TYPE_P (TREE_TYPE (value))) - { - tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value)); - value = gfc_build_addr_expr (NULL_TREE, tmp); - } - - gfc_init_se (&argse, NULL); - gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom, - atom_expr); - - gfc_add_block_to_block (&block, &argse.pre); - if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7, - token, offset, image_index, value, stat, - build_int_cst (integer_type_node, - (int) atom_expr->ts.type), - build_int_cst (integer_type_node, - (int) atom_expr->ts.kind)); - else - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9, - build_int_cst (integer_type_node, op), - token, offset, image_index, value, old, stat, - build_int_cst (integer_type_node, - (int) atom_expr->ts.type), - build_int_cst (integer_type_node, - (int) atom_expr->ts.kind)); - - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &argse.post); - gfc_add_block_to_block (&block, &post_block); - return gfc_finish_block (&block); - } - - - switch (code->resolved_isym->id) - { - case GFC_ISYM_ATOMIC_ADD: - case GFC_ISYM_ATOMIC_FETCH_ADD: - fn = BUILT_IN_ATOMIC_FETCH_ADD_N; - break; - case GFC_ISYM_ATOMIC_AND: - case GFC_ISYM_ATOMIC_FETCH_AND: - fn = BUILT_IN_ATOMIC_FETCH_AND_N; - break; - case GFC_ISYM_ATOMIC_DEF: - fn = BUILT_IN_ATOMIC_STORE_N; - break; - case GFC_ISYM_ATOMIC_OR: - case GFC_ISYM_ATOMIC_FETCH_OR: - fn = BUILT_IN_ATOMIC_FETCH_OR_N; - break; - case GFC_ISYM_ATOMIC_XOR: - case GFC_ISYM_ATOMIC_FETCH_XOR: - fn = BUILT_IN_ATOMIC_FETCH_XOR_N; - break; - default: - gcc_unreachable (); - } - - tmp = TREE_TYPE (TREE_TYPE (atom)); - fn = (built_in_function) ((int) fn - + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) - + 1); - tree itype = TREE_TYPE (TREE_TYPE (atom)); - tmp = builtin_decl_explicit (fn); - - switch (code->resolved_isym->id) - { - case GFC_ISYM_ATOMIC_ADD: - case GFC_ISYM_ATOMIC_AND: - case GFC_ISYM_ATOMIC_DEF: - case GFC_ISYM_ATOMIC_OR: - case GFC_ISYM_ATOMIC_XOR: - tmp = build_call_expr_loc (input_location, tmp, 3, atom, - fold_convert (itype, value), - build_int_cst (NULL, MEMMODEL_RELAXED)); - gfc_add_expr_to_block (&block, tmp); - break; - default: - tmp = build_call_expr_loc (input_location, tmp, 3, atom, - fold_convert (itype, value), - build_int_cst (NULL, MEMMODEL_RELAXED)); - gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp)); - break; - } - - if (stat != NULL_TREE) - gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); - gfc_add_block_to_block (&block, &post_block); - return gfc_finish_block (&block); -} - - -static tree -conv_intrinsic_atomic_ref (gfc_code *code) -{ - gfc_se argse; - tree tmp, atom, value, stat = NULL_TREE; - stmtblock_t block, post_block; - built_in_function fn; - gfc_expr *atom_expr = code->ext.actual->next->expr; - - if (atom_expr->expr_type == EXPR_FUNCTION - && atom_expr->value.function.isym - && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) - atom_expr = atom_expr->value.function.actual->expr; - - gfc_start_block (&block); - gfc_init_block (&post_block); - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr (&argse, atom_expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - atom = argse.expr; - - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB - && code->ext.actual->expr->ts.kind == atom_expr->ts.kind) - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->ext.actual->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - value = argse.expr; - - /* STAT= */ - if (code->ext.actual->next->next->expr != NULL) - { - gcc_assert (code->ext.actual->next->next->expr->expr_type - == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB) - argse.want_pointer = 1; - gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - stat = argse.expr; - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - stat = null_pointer_node; - - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree image_index, caf_decl, offset, token; - tree orig_value = NULL_TREE, vardecl = NULL_TREE; - - caf_decl = gfc_get_tree_for_caf_expr (atom_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - - if (gfc_is_coindexed (atom_expr)) - image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); - else - image_index = integer_zero_node; - - gfc_init_se (&argse, NULL); - gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom, - atom_expr); - gfc_add_block_to_block (&block, &argse.pre); - - /* Different type, need type conversion. */ - if (!POINTER_TYPE_P (TREE_TYPE (value))) - { - vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); - orig_value = value; - value = gfc_build_addr_expr (NULL_TREE, vardecl); - } - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7, - token, offset, image_index, value, stat, - build_int_cst (integer_type_node, - (int) atom_expr->ts.type), - build_int_cst (integer_type_node, - (int) atom_expr->ts.kind)); - gfc_add_expr_to_block (&block, tmp); - if (vardecl != NULL_TREE) - gfc_add_modify (&block, orig_value, - fold_convert (TREE_TYPE (orig_value), vardecl)); - gfc_add_block_to_block (&block, &argse.post); - gfc_add_block_to_block (&block, &post_block); - return gfc_finish_block (&block); - } - - tmp = TREE_TYPE (TREE_TYPE (atom)); - fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N - + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) - + 1); - tmp = builtin_decl_explicit (fn); - tmp = build_call_expr_loc (input_location, tmp, 2, atom, - build_int_cst (integer_type_node, - MEMMODEL_RELAXED)); - gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp)); - - if (stat != NULL_TREE) - gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); - gfc_add_block_to_block (&block, &post_block); - return gfc_finish_block (&block); -} - - -static tree -conv_intrinsic_atomic_cas (gfc_code *code) -{ - gfc_se argse; - tree tmp, atom, old, new_val, comp, stat = NULL_TREE; - stmtblock_t block, post_block; - built_in_function fn; - gfc_expr *atom_expr = code->ext.actual->expr; - - if (atom_expr->expr_type == EXPR_FUNCTION - && atom_expr->value.function.isym - && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) - atom_expr = atom_expr->value.function.actual->expr; - - gfc_init_block (&block); - gfc_init_block (&post_block); - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr (&argse, atom_expr); - atom = argse.expr; - - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB) - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->ext.actual->next->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - old = argse.expr; - - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB) - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->ext.actual->next->next->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - comp = argse.expr; - - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB - && code->ext.actual->next->next->next->expr->ts.kind - == atom_expr->ts.kind) - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - new_val = argse.expr; - - /* STAT= */ - if (code->ext.actual->next->next->next->next->expr != NULL) - { - gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type - == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - if (flag_coarray == GFC_FCOARRAY_LIB) - argse.want_pointer = 1; - gfc_conv_expr_val (&argse, - code->ext.actual->next->next->next->next->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - stat = argse.expr; - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - stat = null_pointer_node; - - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree image_index, caf_decl, offset, token; - - caf_decl = gfc_get_tree_for_caf_expr (atom_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - - if (gfc_is_coindexed (atom_expr)) - image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); - else - image_index = integer_zero_node; - - if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old))) - { - tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new"); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val)); - new_val = gfc_build_addr_expr (NULL_TREE, tmp); - } - - /* Convert a constant to a pointer. */ - if (!POINTER_TYPE_P (TREE_TYPE (comp))) - { - tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp"); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp)); - comp = gfc_build_addr_expr (NULL_TREE, tmp); - } - - gfc_init_se (&argse, NULL); - gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom, - atom_expr); - gfc_add_block_to_block (&block, &argse.pre); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9, - token, offset, image_index, old, comp, new_val, - stat, build_int_cst (integer_type_node, - (int) atom_expr->ts.type), - build_int_cst (integer_type_node, - (int) atom_expr->ts.kind)); - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, &argse.post); - gfc_add_block_to_block (&block, &post_block); - return gfc_finish_block (&block); - } - - tmp = TREE_TYPE (TREE_TYPE (atom)); - fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N - + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) - + 1); - tmp = builtin_decl_explicit (fn); - - gfc_add_modify (&block, old, comp); - tmp = build_call_expr_loc (input_location, tmp, 6, atom, - gfc_build_addr_expr (NULL, old), - fold_convert (TREE_TYPE (old), new_val), - boolean_false_node, - build_int_cst (NULL, MEMMODEL_RELAXED), - build_int_cst (NULL, MEMMODEL_RELAXED)); - gfc_add_expr_to_block (&block, tmp); - - if (stat != NULL_TREE) - gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); - gfc_add_block_to_block (&block, &post_block); - return gfc_finish_block (&block); -} - -static tree -conv_intrinsic_event_query (gfc_code *code) -{ - gfc_se se, argse; - tree stat = NULL_TREE, stat2 = NULL_TREE; - tree count = NULL_TREE, count2 = NULL_TREE; - - gfc_expr *event_expr = code->ext.actual->expr; - - if (code->ext.actual->next->next->expr) - { - gcc_assert (code->ext.actual->next->next->expr->expr_type - == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr); - stat = argse.expr; - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - stat = null_pointer_node; - - if (code->ext.actual->next->expr) - { - gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->ext.actual->next->expr); - count = argse.expr; - } - - gfc_start_block (&se.pre); - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree tmp, token, image_index; - tree index = build_zero_cst (gfc_array_index_type); - - if (event_expr->expr_type == EXPR_FUNCTION - && event_expr->value.function.isym - && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET) - event_expr = event_expr->value.function.actual->expr; - - tree caf_decl = gfc_get_tree_for_caf_expr (event_expr); - - if (event_expr->symtree->n.sym->ts.type != BT_DERIVED - || event_expr->symtree->n.sym->ts.u.derived->from_intmod - != INTMOD_ISO_FORTRAN_ENV - || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id - != ISOFORTRAN_EVENT_TYPE) - { - gfc_error ("Sorry, the event component of derived type at %L is not " - "yet supported", &event_expr->where); - return NULL_TREE; - } - - if (gfc_is_coindexed (event_expr)) - { - gfc_error ("The event variable at %L shall not be coindexed", - &event_expr->where); - return NULL_TREE; - } - - image_index = integer_zero_node; - - gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE, - event_expr); - - /* For arrays, obtain the array index. */ - if (gfc_expr_attr (event_expr).dimension) - { - tree desc, tmp, extent, lbound, ubound; - gfc_array_ref *ar, ar2; - int i; - - /* TODO: Extend this, once DT components are supported. */ - ar = &event_expr->ref->u.ar; - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; - - gfc_init_se (&argse, NULL); - argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, event_expr); - gfc_add_block_to_block (&se.pre, &argse.pre); - desc = argse.expr; - *ar = ar2; - - extent = build_one_cst (gfc_array_index_type); - for (i = 0; i < ar->dimen; i++) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); - gfc_add_block_to_block (&argse.pre, &argse.pre); - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (lbound), argse.expr, lbound); - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), extent, tmp); - index = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (tmp), index, tmp); - if (i < ar->dimen - 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); - } - } - } - - if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node) - { - count2 = count; - count = gfc_create_var (integer_type_node, "count"); - } - - if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) - { - stat2 = stat; - stat = gfc_create_var (integer_type_node, "stat"); - } - - index = fold_convert (size_type_node, index); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5, - token, index, image_index, count - ? gfc_build_addr_expr (NULL, count) : count, - stat != null_pointer_node - ? gfc_build_addr_expr (NULL, stat) : stat); - gfc_add_expr_to_block (&se.pre, tmp); - - if (count2 != NULL_TREE) - gfc_add_modify (&se.pre, count2, - fold_convert (TREE_TYPE (count2), count)); - - if (stat2 != NULL_TREE) - gfc_add_modify (&se.pre, stat2, - fold_convert (TREE_TYPE (stat2), stat)); - - return gfc_finish_block (&se.pre); - } - - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->ext.actual->expr); - gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr)); - - if (stat != NULL_TREE) - gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); - - return gfc_finish_block (&se.pre); -} - - -/* This is a peculiar case because of the need to do dependency checking. - It is called via trans-stmt.c(gfc_trans_call), where it is picked out as - a special case and this function called instead of - gfc_conv_procedure_call. */ -void -gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args, - gfc_loopinfo *loop) -{ - gfc_actual_arglist *actual; - gfc_se argse[5]; - gfc_expr *arg[5]; - gfc_ss *lss; - int n; - - tree from, frompos, len, to, topos; - tree lenmask, oldbits, newbits, bitsize; - tree type, utype, above, mask1, mask2; - - if (loop) - lss = loop->ss; - else - lss = gfc_ss_terminator; - - actual = actual_args; - for (n = 0; n < 5; n++, actual = actual->next) - { - arg[n] = actual->expr; - gfc_init_se (&argse[n], NULL); - - if (lss != gfc_ss_terminator) - { - gfc_copy_loopinfo_to_se (&argse[n], loop); - /* Find the ss for the expression if it is there. */ - argse[n].ss = lss; - gfc_mark_ss_chain_used (lss, 1); - } - - gfc_conv_expr (&argse[n], arg[n]); - - if (loop) - lss = argse[n].ss; - } - - from = argse[0].expr; - frompos = argse[1].expr; - len = argse[2].expr; - to = argse[3].expr; - topos = argse[4].expr; - - /* The type of the result (TO). */ - type = TREE_TYPE (to); - bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type)); - - /* Optionally generate code for runtime argument check. */ - if (gfc_option.rtcheck & GFC_RTCHECK_BITS) - { - tree nbits, below, ccond; - tree fp = fold_convert (long_integer_type_node, frompos); - tree ln = fold_convert (long_integer_type_node, len); - tree tp = fold_convert (long_integer_type_node, topos); - below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, frompos, - build_int_cst (TREE_TYPE (frompos), 0)); - above = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, frompos, - fold_convert (TREE_TYPE (frompos), bitsize)); - ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - gfc_trans_runtime_check (true, false, ccond, &argse[1].pre, - &arg[1]->where, - "FROMPOS argument (%ld) out of range 0:%d " - "in intrinsic MVBITS", fp, bitsize); - below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, len, - build_int_cst (TREE_TYPE (len), 0)); - above = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, len, - fold_convert (TREE_TYPE (len), bitsize)); - ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - gfc_trans_runtime_check (true, false, ccond, &argse[2].pre, - &arg[2]->where, - "LEN argument (%ld) out of range 0:%d " - "in intrinsic MVBITS", ln, bitsize); - below = fold_build2_loc (input_location, LT_EXPR, - logical_type_node, topos, - build_int_cst (TREE_TYPE (topos), 0)); - above = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, topos, - fold_convert (TREE_TYPE (topos), bitsize)); - ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, below, above); - gfc_trans_runtime_check (true, false, ccond, &argse[4].pre, - &arg[4]->where, - "TOPOS argument (%ld) out of range 0:%d " - "in intrinsic MVBITS", tp, bitsize); - - /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short - integers. Additions below cannot overflow. */ - nbits = fold_convert (long_integer_type_node, bitsize); - above = fold_build2_loc (input_location, PLUS_EXPR, - long_integer_type_node, fp, ln); - ccond = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, above, nbits); - gfc_trans_runtime_check (true, false, ccond, &argse[1].pre, - &arg[1]->where, - "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) " - "in intrinsic MVBITS", fp, ln, bitsize); - above = fold_build2_loc (input_location, PLUS_EXPR, - long_integer_type_node, tp, ln); - ccond = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, above, nbits); - gfc_trans_runtime_check (true, false, ccond, &argse[4].pre, - &arg[4]->where, - "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) " - "in intrinsic MVBITS", tp, ln, bitsize); - } - - for (n = 0; n < 5; n++) - { - gfc_add_block_to_block (&se->pre, &argse[n].pre); - gfc_add_block_to_block (&se->post, &argse[n].post); - } - - /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */ - above = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - len, fold_convert (TREE_TYPE (len), bitsize)); - mask1 = build_int_cst (type, -1); - mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type, - build_int_cst (type, 1), len); - mask2 = fold_build2_loc (input_location, MINUS_EXPR, type, - mask2, build_int_cst (type, 1)); - lenmask = fold_build3_loc (input_location, COND_EXPR, type, - above, mask1, mask2); - - /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS. - * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is - * not strictly necessary; artificial bits from rshift will be masked. */ - utype = unsigned_type_for (type); - newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype, - fold_convert (utype, from), frompos); - newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, - fold_convert (type, newbits), lenmask); - newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type, - newbits, topos); - - /* oldbits = TO & (~(lenmask << TOPOS)). */ - oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type, - lenmask, topos); - oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits); - oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to); - - /* TO = newbits | oldbits. */ - se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type, - oldbits, newbits); - - /* Return the assignment. */ - se->expr = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, to, se->expr); -} - - -static tree -conv_intrinsic_move_alloc (gfc_code *code) -{ - stmtblock_t block; - gfc_expr *from_expr, *to_expr; - gfc_expr *to_expr2, *from_expr2 = NULL; - gfc_se from_se, to_se; - tree tmp; - bool coarray; - - gfc_start_block (&block); - - from_expr = code->ext.actual->expr; - to_expr = code->ext.actual->next->expr; - - gfc_init_se (&from_se, NULL); - gfc_init_se (&to_se, NULL); - - gcc_assert (from_expr->ts.type != BT_CLASS - || to_expr->ts.type == BT_CLASS); - coarray = gfc_get_corank (from_expr) != 0; - - if (from_expr->rank == 0 && !coarray) - { - if (from_expr->ts.type != BT_CLASS) - from_expr2 = from_expr; - else - { - from_expr2 = gfc_copy_expr (from_expr); - gfc_add_data_component (from_expr2); - } - - if (to_expr->ts.type != BT_CLASS) - to_expr2 = to_expr; - else - { - to_expr2 = gfc_copy_expr (to_expr); - gfc_add_data_component (to_expr2); - } - - from_se.want_pointer = 1; - to_se.want_pointer = 1; - gfc_conv_expr (&from_se, from_expr2); - gfc_conv_expr (&to_se, to_expr2); - gfc_add_block_to_block (&block, &from_se.pre); - gfc_add_block_to_block (&block, &to_se.pre); - - /* Deallocate "to". */ - tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE, - true, to_expr, to_expr->ts); - gfc_add_expr_to_block (&block, tmp); - - /* Assign (_data) pointers. */ - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); - - /* Set "from" to NULL. */ - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), null_pointer_node)); - - gfc_add_block_to_block (&block, &from_se.post); - gfc_add_block_to_block (&block, &to_se.post); - - /* Set _vptr. */ - if (to_expr->ts.type == BT_CLASS) - { - gfc_symbol *vtab; - - gfc_free_expr (to_expr2); - gfc_init_se (&to_se, NULL); - to_se.want_pointer = 1; - gfc_add_vptr_component (to_expr); - gfc_conv_expr (&to_se, to_expr); - - if (from_expr->ts.type == BT_CLASS) - { - if (UNLIMITED_POLY (from_expr)) - vtab = NULL; - else - { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); - gcc_assert (vtab); - } - - gfc_free_expr (from_expr2); - gfc_init_se (&from_se, NULL); - from_se.want_pointer = 1; - gfc_add_vptr_component (from_expr); - gfc_conv_expr (&from_se, from_expr); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), - from_se.expr)); - - /* Reset _vptr component to declared type. */ - if (vtab == NULL) - /* Unlimited polymorphic. */ - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), - null_pointer_node)); - else - { - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), tmp)); - } - } - else - { - vtab = gfc_find_vtab (&from_expr->ts); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); - } - } - - if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) - { - gfc_add_modify_loc (input_location, &block, to_se.string_length, - fold_convert (TREE_TYPE (to_se.string_length), - from_se.string_length)); - if (from_expr->ts.deferred) - gfc_add_modify_loc (input_location, &block, from_se.string_length, - build_int_cst (TREE_TYPE (from_se.string_length), 0)); - } - - return gfc_finish_block (&block); - } - - /* Update _vptr component. */ - if (to_expr->ts.type == BT_CLASS) - { - gfc_symbol *vtab; - - to_se.want_pointer = 1; - to_expr2 = gfc_copy_expr (to_expr); - gfc_add_vptr_component (to_expr2); - gfc_conv_expr (&to_se, to_expr2); - - if (from_expr->ts.type == BT_CLASS) - { - if (UNLIMITED_POLY (from_expr)) - vtab = NULL; - else - { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); - gcc_assert (vtab); - } - - from_se.want_pointer = 1; - from_expr2 = gfc_copy_expr (from_expr); - gfc_add_vptr_component (from_expr2); - gfc_conv_expr (&from_se, from_expr2); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), - from_se.expr)); - - /* Reset _vptr component to declared type. */ - if (vtab == NULL) - /* Unlimited polymorphic. */ - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), - null_pointer_node)); - else - { - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), tmp)); - } - } - else - { - vtab = gfc_find_vtab (&from_expr->ts); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); - } - - gfc_free_expr (to_expr2); - gfc_init_se (&to_se, NULL); - - if (from_expr->ts.type == BT_CLASS) - { - gfc_free_expr (from_expr2); - gfc_init_se (&from_se, NULL); - } - } - - - /* Deallocate "to". */ - if (from_expr->rank == 0) - { - to_se.want_coarray = 1; - from_se.want_coarray = 1; - } - gfc_conv_expr_descriptor (&to_se, to_expr); - gfc_conv_expr_descriptor (&from_se, from_expr); - - /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC - is an image control "statement", cf. IR F08/0040 in 12-006A. */ - if (coarray && flag_coarray == GFC_FCOARRAY_LIB) - { - tree cond; - - tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_DEALLOCATE_ONLY); - gfc_add_expr_to_block (&block, tmp); - - tmp = gfc_conv_descriptor_data_get (to_se.expr); - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, tmp, - fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, - 3, null_pointer_node, null_pointer_node, - build_int_cst (integer_type_node, 0)); - - 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); - } - else - { - if (to_expr->ts.type == BT_DERIVED - && to_expr->ts.u.derived->attr.alloc_comp) - { - tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived, - to_se.expr, to_expr->rank); - gfc_add_expr_to_block (&block, tmp); - } - - tmp = gfc_conv_descriptor_data_get (to_se.expr); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_NOCOARRAY); - gfc_add_expr_to_block (&block, tmp); - } - - /* Move the pointer and update the array descriptor data. */ - gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr); - - /* Set "from" to NULL. */ - tmp = gfc_conv_descriptor_data_get (from_se.expr); - gfc_add_modify_loc (input_location, &block, tmp, - fold_convert (TREE_TYPE (tmp), null_pointer_node)); - - - if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) - { - gfc_add_modify_loc (input_location, &block, to_se.string_length, - fold_convert (TREE_TYPE (to_se.string_length), - from_se.string_length)); - if (from_expr->ts.deferred) - gfc_add_modify_loc (input_location, &block, from_se.string_length, - build_int_cst (TREE_TYPE (from_se.string_length), 0)); - } - - return gfc_finish_block (&block); -} - - -tree -gfc_conv_intrinsic_subroutine (gfc_code *code) -{ - tree res; - - gcc_assert (code->resolved_isym); - - switch (code->resolved_isym->id) - { - case GFC_ISYM_MOVE_ALLOC: - res = conv_intrinsic_move_alloc (code); - break; - - case GFC_ISYM_ATOMIC_CAS: - res = conv_intrinsic_atomic_cas (code); - break; - - case GFC_ISYM_ATOMIC_ADD: - case GFC_ISYM_ATOMIC_AND: - case GFC_ISYM_ATOMIC_DEF: - case GFC_ISYM_ATOMIC_OR: - case GFC_ISYM_ATOMIC_XOR: - case GFC_ISYM_ATOMIC_FETCH_ADD: - case GFC_ISYM_ATOMIC_FETCH_AND: - case GFC_ISYM_ATOMIC_FETCH_OR: - case GFC_ISYM_ATOMIC_FETCH_XOR: - res = conv_intrinsic_atomic_op (code); - break; - - case GFC_ISYM_ATOMIC_REF: - res = conv_intrinsic_atomic_ref (code); - break; - - case GFC_ISYM_EVENT_QUERY: - res = conv_intrinsic_event_query (code); - break; - - case GFC_ISYM_C_F_POINTER: - case GFC_ISYM_C_F_PROCPOINTER: - res = conv_isocbinding_subroutine (code); - break; - - case GFC_ISYM_CAF_SEND: - res = conv_caf_send (code); - break; - - case GFC_ISYM_CO_BROADCAST: - case GFC_ISYM_CO_MIN: - case GFC_ISYM_CO_MAX: - case GFC_ISYM_CO_REDUCE: - case GFC_ISYM_CO_SUM: - res = conv_co_collective (code); - break; - - case GFC_ISYM_FREE: - res = conv_intrinsic_free (code); - break; - - case GFC_ISYM_RANDOM_INIT: - res = conv_intrinsic_random_init (code); - break; - - case GFC_ISYM_KILL: - res = conv_intrinsic_kill_sub (code); - break; - - case GFC_ISYM_MVBITS: - res = NULL_TREE; - break; - - case GFC_ISYM_SYSTEM_CLOCK: - res = conv_intrinsic_system_clock (code); - break; - - default: - res = NULL_TREE; - break; - } - - return res; -} - -#include "gt-fortran-trans-intrinsic.h" diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc new file mode 100644 index 0000000..a7cbbeb --- /dev/null +++ b/gcc/fortran/trans-intrinsic.cc @@ -0,0 +1,12457 @@ +/* Intrinsic translation + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + and Steven Bosscher + +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 +. */ + +/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "memmodel.h" +#include "tm.h" /* For UNITS_PER_WORD. */ +#include "tree.h" +#include "gfortran.h" +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "internal-fn.h" +#include "tree-nested.h" +#include "stor-layout.h" +#include "toplev.h" /* For rest_of_decl_compilation. */ +#include "arith.h" +#include "trans-const.h" +#include "trans-types.h" +#include "trans-array.h" +#include "dependency.h" /* For CAF array alias analysis. */ +#include "attribs.h" + +/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ + +/* This maps Fortran intrinsic math functions to external library or GCC + builtin functions. */ +typedef struct GTY(()) gfc_intrinsic_map_t { + /* The explicit enum is required to work around inadequacies in the + garbage collection/gengtype parsing mechanism. */ + enum gfc_isym_id id; + + /* Enum value from the "language-independent", aka C-centric, part + of gcc, or END_BUILTINS of no such value set. */ + enum built_in_function float_built_in; + enum built_in_function double_built_in; + enum built_in_function long_double_built_in; + enum built_in_function complex_float_built_in; + enum built_in_function complex_double_built_in; + enum built_in_function complex_long_double_built_in; + + /* True if the naming pattern is to prepend "c" for complex and + append "f" for kind=4. False if the naming pattern is to + prepend "_gfortran_" and append "[rc](4|8|10|16)". */ + bool libm_name; + + /* True if a complex version of the function exists. */ + bool complex_available; + + /* True if the function should be marked const. */ + bool is_constant; + + /* The base library name of this function. */ + const char *name; + + /* Cache decls created for the various operand types. */ + tree real4_decl; + tree real8_decl; + tree real10_decl; + tree real16_decl; + tree complex4_decl; + tree complex8_decl; + tree complex10_decl; + tree complex16_decl; +} +gfc_intrinsic_map_t; + +/* ??? The NARGS==1 hack here is based on the fact that (c99 at least) + defines complex variants of all of the entries in mathbuiltins.def + except for atan2. */ +#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ + { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ + BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + +#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ + { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ + BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \ + BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + +#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \ + { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } + +#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ + { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ + BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + true, false, CONST, NAME, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + +static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = +{ + /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and + DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond + to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */ +#include "mathbuiltins.def" + + /* Functions in libgfortran. */ + LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false), + LIB_FUNCTION (SIND, "sind", false), + LIB_FUNCTION (COSD, "cosd", false), + LIB_FUNCTION (TAND, "tand", false), + + /* End the list. */ + LIB_FUNCTION (NONE, NULL, false) + +}; +#undef OTHER_BUILTIN +#undef LIB_FUNCTION +#undef DEFINE_MATH_BUILTIN +#undef DEFINE_MATH_BUILTIN_C + + +enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; + + +/* Find the correct variant of a given builtin from its argument. */ +static tree +builtin_decl_for_precision (enum built_in_function base_built_in, + int precision) +{ + enum built_in_function i = END_BUILTINS; + + gfc_intrinsic_map_t *m; + for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++) + ; + + if (precision == TYPE_PRECISION (float_type_node)) + i = m->float_built_in; + else if (precision == TYPE_PRECISION (double_type_node)) + i = m->double_built_in; + else if (precision == TYPE_PRECISION (long_double_type_node) + && (!gfc_real16_is_float128 + || long_double_type_node != gfc_float128_type_node)) + i = m->long_double_built_in; + else if (precision == TYPE_PRECISION (gfc_float128_type_node)) + { + /* Special treatment, because it is not exactly a built-in, but + a library function. */ + return m->real16_decl; + } + + return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i)); +} + + +tree +gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in, + int kind) +{ + int i = gfc_validate_kind (BT_REAL, kind, false); + + if (gfc_real_kinds[i].c_float128) + { + /* For _Float128, the story is a bit different, because we return + a decl to a library function rather than a built-in. */ + gfc_intrinsic_map_t *m; + for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++) + ; + + return m->real16_decl; + } + + return builtin_decl_for_precision (double_built_in, + gfc_real_kinds[i].mode_precision); +} + + +/* Evaluate the arguments to an intrinsic function. The value + of NARGS may be less than the actual number of arguments in EXPR + to allow optional "KIND" arguments that are not included in the + generated code to be ignored. */ + +static void +gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr, + tree *argarray, int nargs) +{ + gfc_actual_arglist *actual; + gfc_expr *e; + gfc_intrinsic_arg *formal; + gfc_se argse; + int curr_arg; + + formal = expr->value.function.isym->formal; + actual = expr->value.function.actual; + + for (curr_arg = 0; curr_arg < nargs; curr_arg++, + actual = actual->next, + formal = formal ? formal->next : NULL) + { + gcc_assert (actual); + e = actual->expr; + /* Skip omitted optional arguments. */ + if (!e) + { + --curr_arg; + continue; + } + + /* Evaluate the parameter. This will substitute scalarized + references automatically. */ + gfc_init_se (&argse, se); + + if (e->ts.type == BT_CHARACTER) + { + gfc_conv_expr (&argse, e); + gfc_conv_string_parameter (&argse); + argarray[curr_arg++] = argse.string_length; + gcc_assert (curr_arg < nargs); + } + else + gfc_conv_expr_val (&argse, e); + + /* If an optional argument is itself an optional dummy argument, + check its presence and substitute a null if absent. */ + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional + && formal + && formal->optional) + gfc_conv_missing_dummy (&argse, e, formal->ts, 0); + + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + argarray[curr_arg] = argse.expr; + } +} + +/* Count the number of actual arguments to the intrinsic function EXPR + including any "hidden" string length arguments. */ + +static unsigned int +gfc_intrinsic_argument_list_length (gfc_expr *expr) +{ + int n = 0; + gfc_actual_arglist *actual; + + for (actual = expr->value.function.actual; actual; actual = actual->next) + { + if (!actual->expr) + continue; + + if (actual->expr->ts.type == BT_CHARACTER) + n += 2; + else + n++; + } + + return n; +} + + +/* Conversions between different types are output by the frontend as + intrinsic functions. We implement these directly with inline code. */ + +static void +gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) +{ + tree type; + tree *args; + int nargs; + + nargs = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, nargs); + + /* Evaluate all the arguments passed. Whilst we're only interested in the + first one here, there are other parts of the front-end that assume this + and will trigger an ICE if it's not the case. */ + type = gfc_typenode_for_spec (&expr->ts); + gcc_assert (expr->value.function.actual->expr); + gfc_conv_intrinsic_function_args (se, expr, args, nargs); + + /* Conversion between character kinds involves a call to a library + function. */ + if (expr->ts.type == BT_CHARACTER) + { + tree fndecl, var, addr, tmp; + + if (expr->ts.kind == 1 + && expr->value.function.actual->expr->ts.kind == 4) + fndecl = gfor_fndecl_convert_char4_to_char1; + else if (expr->ts.kind == 4 + && expr->value.function.actual->expr->ts.kind == 1) + fndecl = gfor_fndecl_convert_char1_to_char4; + else + gcc_unreachable (); + + /* Create the variable storing the converted value. */ + type = gfc_get_pchar_type (expr->ts.kind); + var = gfc_create_var (type, "str"); + addr = gfc_build_addr_expr (build_pointer_type (type), var); + + /* Call the library function that will perform the conversion. */ + gcc_assert (nargs >= 2); + tmp = build_call_expr_loc (input_location, + fndecl, 3, addr, args[0], args[1]); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards. */ + tmp = gfc_call_free (var); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = args[0]; + + return; + } + + /* Conversion from complex to non-complex involves taking the real + component of the value. */ + if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE + && expr->ts.type != BT_COMPLEX) + { + tree artype; + + artype = TREE_TYPE (TREE_TYPE (args[0])); + args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, + args[0]); + } + + se->expr = convert (type, args[0]); +} + +/* This is needed because the gcc backend only implements + FIX_TRUNC_EXPR, which is the same as INT() in Fortran. + FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1 + Similarly for CEILING. */ + +static tree +build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) +{ + tree tmp; + tree cond; + tree argtype; + tree intval; + + argtype = TREE_TYPE (arg); + arg = gfc_evaluate_now (arg, pblock); + + intval = convert (type, arg); + intval = gfc_evaluate_now (intval, pblock); + + tmp = convert (argtype, intval); + cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR, + logical_type_node, tmp, arg); + + tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type, + intval, build_int_cst (type, 1)); + tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp); + return tmp; +} + + +/* Round to nearest integer, away from zero. */ + +static tree +build_round_expr (tree arg, tree restype) +{ + tree argtype; + tree fn; + int argprec, resprec; + + argtype = TREE_TYPE (arg); + argprec = TYPE_PRECISION (argtype); + resprec = TYPE_PRECISION (restype); + + /* Depending on the type of the result, choose the int intrinsic (iround, + available only as a builtin, therefore cannot use it for _Float128), long + int intrinsic (lround family) or long long intrinsic (llround). If we + don't have an appropriate function that converts directly to the integer + type (such as kind == 16), just use ROUND, and then convert the result to + an integer. We might also need to convert the result afterwards. */ + if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE) + fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec); + else if (resprec <= LONG_TYPE_SIZE) + fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec); + else if (resprec <= LONG_LONG_TYPE_SIZE) + fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec); + else if (resprec >= argprec) + fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec); + else + gcc_unreachable (); + + return convert (restype, build_call_expr_loc (input_location, + fn, 1, arg)); +} + + +/* Convert a real to an integer using a specific rounding mode. + Ideally we would just build the corresponding GENERIC node, + however the RTL expander only actually supports FIX_TRUNC_EXPR. */ + +static tree +build_fix_expr (stmtblock_t * pblock, tree arg, tree type, + enum rounding_mode op) +{ + switch (op) + { + case RND_FLOOR: + return build_fixbound_expr (pblock, arg, type, 0); + + case RND_CEIL: + return build_fixbound_expr (pblock, arg, type, 1); + + case RND_ROUND: + return build_round_expr (arg, type); + + case RND_TRUNC: + return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg); + + default: + gcc_unreachable (); + } +} + + +/* Round a real value using the specified rounding mode. + We use a temporary integer of that same kind size as the result. + Values larger than those that can be represented by this kind are + unchanged, as they will not be accurate enough to represent the + rounding. + huge = HUGE (KIND (a)) + aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a + */ + +static void +gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) +{ + tree type; + tree itype; + tree arg[2]; + tree tmp; + tree cond; + tree decl; + mpfr_t huge; + int n, nargs; + int kind; + + kind = expr->ts.kind; + nargs = gfc_intrinsic_argument_list_length (expr); + + decl = NULL_TREE; + /* We have builtin functions for some cases. */ + switch (op) + { + case RND_ROUND: + decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind); + break; + + case RND_TRUNC: + decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind); + break; + + default: + gcc_unreachable (); + } + + /* Evaluate the argument. */ + gcc_assert (expr->value.function.actual->expr); + gfc_conv_intrinsic_function_args (se, expr, arg, nargs); + + /* Use a builtin function if one exists. */ + if (decl != NULL_TREE) + { + se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]); + return; + } + + /* This code is probably redundant, but we'll keep it lying around just + in case. */ + type = gfc_typenode_for_spec (&expr->ts); + arg[0] = gfc_evaluate_now (arg[0], &se->pre); + + /* Test if the value is too large to handle sensibly. */ + gfc_set_model_kind (kind); + mpfr_init (huge); + n = gfc_validate_kind (BT_INTEGER, kind, false); + mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); + tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0], + tmp); + + mpfr_neg (huge, huge, GFC_RND_MODE); + tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0], + tmp); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + cond, tmp); + itype = gfc_get_int_type (kind); + + tmp = build_fix_expr (&se->pre, arg[0], itype, op); + tmp = convert (type, tmp); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp, + arg[0]); + mpfr_clear (huge); +} + + +/* Convert to an integer using the specified rounding mode. */ + +static void +gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) +{ + tree type; + tree *args; + int nargs; + + nargs = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, nargs); + + /* Evaluate the argument, we process all arguments even though we only + use the first one for code generation purposes. */ + type = gfc_typenode_for_spec (&expr->ts); + gcc_assert (expr->value.function.actual->expr); + gfc_conv_intrinsic_function_args (se, expr, args, nargs); + + if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE) + { + /* Conversion to a different integer kind. */ + se->expr = convert (type, args[0]); + } + else + { + /* Conversion from complex to non-complex involves taking the real + component of the value. */ + if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE + && expr->ts.type != BT_COMPLEX) + { + tree artype; + + artype = TREE_TYPE (TREE_TYPE (args[0])); + args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype, + args[0]); + } + + se->expr = build_fix_expr (&se->pre, args[0], type, op); + } +} + + +/* Get the imaginary component of a value. */ + +static void +gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) +{ + tree arg; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + se->expr = fold_build1_loc (input_location, IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (arg)), arg); +} + + +/* Get the complex conjugate of a value. */ + +static void +gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) +{ + tree arg; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg); +} + + + +static tree +define_quad_builtin (const char *name, tree type, bool is_const) +{ + tree fndecl; + fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name), + type); + + /* Mark the decl as external. */ + DECL_EXTERNAL (fndecl) = 1; + TREE_PUBLIC (fndecl) = 1; + + /* Mark it __attribute__((const)). */ + TREE_READONLY (fndecl) = is_const; + + rest_of_decl_compilation (fndecl, 1, 0); + + return fndecl; +} + +/* Add SIMD attribute for FNDECL built-in if the built-in + name is in VECTORIZED_BUILTINS. */ + +static void +add_simd_flag_for_built_in (tree fndecl) +{ + if (gfc_vectorized_builtins == NULL + || fndecl == NULL_TREE) + return; + + const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl)); + int *clauses = gfc_vectorized_builtins->get (name); + if (clauses) + { + for (unsigned i = 0; i < 3; i++) + if (*clauses & (1 << i)) + { + gfc_simd_clause simd_type = (gfc_simd_clause)*clauses; + tree omp_clause = NULL_TREE; + if (simd_type == SIMD_NONE) + ; /* No SIMD clause. */ + else + { + omp_clause_code code + = (simd_type == SIMD_INBRANCH + ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH); + omp_clause = build_omp_clause (UNKNOWN_LOCATION, code); + omp_clause = build_tree_list (NULL_TREE, omp_clause); + } + + DECL_ATTRIBUTES (fndecl) + = tree_cons (get_identifier ("omp declare simd"), omp_clause, + DECL_ATTRIBUTES (fndecl)); + } + } +} + + /* Set SIMD attribute to all built-in functions that are mentioned + in gfc_vectorized_builtins vector. */ + +void +gfc_adjust_builtins (void) +{ + gfc_intrinsic_map_t *m; + for (m = gfc_intrinsic_map; + m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) + { + add_simd_flag_for_built_in (m->real4_decl); + add_simd_flag_for_built_in (m->complex4_decl); + add_simd_flag_for_built_in (m->real8_decl); + add_simd_flag_for_built_in (m->complex8_decl); + add_simd_flag_for_built_in (m->real10_decl); + add_simd_flag_for_built_in (m->complex10_decl); + add_simd_flag_for_built_in (m->real16_decl); + add_simd_flag_for_built_in (m->complex16_decl); + add_simd_flag_for_built_in (m->real16_decl); + add_simd_flag_for_built_in (m->complex16_decl); + } + + /* Release all strings. */ + if (gfc_vectorized_builtins != NULL) + { + for (hash_map::iterator it + = gfc_vectorized_builtins->begin (); + it != gfc_vectorized_builtins->end (); ++it) + free (CONST_CAST (char *, (*it).first)); + + delete gfc_vectorized_builtins; + gfc_vectorized_builtins = NULL; + } +} + +/* Initialize function decls for library functions. The external functions + are created as required. Builtin functions are added here. */ + +void +gfc_build_intrinsic_lib_fndecls (void) +{ + gfc_intrinsic_map_t *m; + tree quad_decls[END_BUILTINS + 1]; + + if (gfc_real16_is_float128) + { + /* If we have soft-float types, we create the decls for their + C99-like library functions. For now, we only handle _Float128 + q-suffixed functions. */ + + tree type, complex_type, func_1, func_2, func_cabs, func_frexp; + tree func_iround, func_lround, func_llround, func_scalbn, func_cpow; + + memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1)); + + type = gfc_float128_type_node; + complex_type = gfc_complex_float128_type_node; + /* type (*) (type) */ + func_1 = build_function_type_list (type, type, NULL_TREE); + /* int (*) (type) */ + func_iround = build_function_type_list (integer_type_node, + type, NULL_TREE); + /* long (*) (type) */ + func_lround = build_function_type_list (long_integer_type_node, + type, NULL_TREE); + /* long long (*) (type) */ + func_llround = build_function_type_list (long_long_integer_type_node, + type, NULL_TREE); + /* type (*) (type, type) */ + func_2 = build_function_type_list (type, type, type, NULL_TREE); + /* type (*) (type, &int) */ + func_frexp + = build_function_type_list (type, + type, + build_pointer_type (integer_type_node), + NULL_TREE); + /* type (*) (type, int) */ + func_scalbn = build_function_type_list (type, + type, integer_type_node, NULL_TREE); + /* type (*) (complex type) */ + func_cabs = build_function_type_list (type, complex_type, NULL_TREE); + /* complex type (*) (complex type, complex type) */ + func_cpow + = build_function_type_list (complex_type, + complex_type, complex_type, NULL_TREE); + +#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) +#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) +#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) + + /* Only these built-ins are actually needed here. These are used directly + from the code, when calling builtin_decl_for_precision() or + builtin_decl_for_float_type(). The others are all constructed by + gfc_get_intrinsic_lib_fndecl(). */ +#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ + quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST); + +#include "mathbuiltins.def" + +#undef OTHER_BUILTIN +#undef LIB_FUNCTION +#undef DEFINE_MATH_BUILTIN +#undef DEFINE_MATH_BUILTIN_C + + /* There is one built-in we defined manually, because it gets called + with builtin_decl_for_precision() or builtin_decl_for_float_type() + even though it is not an OTHER_BUILTIN: it is SQRT. */ + quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true); + + } + + /* Add GCC builtin functions. */ + for (m = gfc_intrinsic_map; + m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) + { + if (m->float_built_in != END_BUILTINS) + m->real4_decl = builtin_decl_explicit (m->float_built_in); + if (m->complex_float_built_in != END_BUILTINS) + m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in); + if (m->double_built_in != END_BUILTINS) + m->real8_decl = builtin_decl_explicit (m->double_built_in); + if (m->complex_double_built_in != END_BUILTINS) + m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in); + + /* If real(kind=10) exists, it is always long double. */ + if (m->long_double_built_in != END_BUILTINS) + m->real10_decl = builtin_decl_explicit (m->long_double_built_in); + if (m->complex_long_double_built_in != END_BUILTINS) + m->complex10_decl + = builtin_decl_explicit (m->complex_long_double_built_in); + + if (!gfc_real16_is_float128) + { + if (m->long_double_built_in != END_BUILTINS) + m->real16_decl = builtin_decl_explicit (m->long_double_built_in); + if (m->complex_long_double_built_in != END_BUILTINS) + m->complex16_decl + = builtin_decl_explicit (m->complex_long_double_built_in); + } + else if (quad_decls[m->double_built_in] != NULL_TREE) + { + /* Quad-precision function calls are constructed when first + needed by builtin_decl_for_precision(), except for those + that will be used directly (define by OTHER_BUILTIN). */ + m->real16_decl = quad_decls[m->double_built_in]; + } + else if (quad_decls[m->complex_double_built_in] != NULL_TREE) + { + /* Same thing for the complex ones. */ + m->complex16_decl = quad_decls[m->double_built_in]; + } + } +} + + +/* Create a fndecl for a simple intrinsic library function. */ + +static tree +gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) +{ + tree type; + vec *argtypes; + tree fndecl; + gfc_actual_arglist *actual; + tree *pdecl; + gfc_typespec *ts; + char name[GFC_MAX_SYMBOL_LEN + 3]; + + ts = &expr->ts; + if (ts->type == BT_REAL) + { + switch (ts->kind) + { + case 4: + pdecl = &m->real4_decl; + break; + case 8: + pdecl = &m->real8_decl; + break; + case 10: + pdecl = &m->real10_decl; + break; + case 16: + pdecl = &m->real16_decl; + break; + default: + gcc_unreachable (); + } + } + else if (ts->type == BT_COMPLEX) + { + gcc_assert (m->complex_available); + + switch (ts->kind) + { + case 4: + pdecl = &m->complex4_decl; + break; + case 8: + pdecl = &m->complex8_decl; + break; + case 10: + pdecl = &m->complex10_decl; + break; + case 16: + pdecl = &m->complex16_decl; + break; + default: + gcc_unreachable (); + } + } + else + gcc_unreachable (); + + if (*pdecl) + return *pdecl; + + if (m->libm_name) + { + int n = gfc_validate_kind (BT_REAL, ts->kind, false); + if (gfc_real_kinds[n].c_float) + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); + else if (gfc_real_kinds[n].c_double) + snprintf (name, sizeof (name), "%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name); + else if (gfc_real_kinds[n].c_long_double) + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); + else if (gfc_real_kinds[n].c_float128) + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "q"); + else + gcc_unreachable (); + } + else + { + snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name, + ts->type == BT_COMPLEX ? 'c' : 'r', + gfc_type_abi_kind (ts)); + } + + argtypes = NULL; + for (actual = expr->value.function.actual; actual; actual = actual->next) + { + type = gfc_typenode_for_spec (&actual->expr->ts); + vec_safe_push (argtypes, type); + } + type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes); + fndecl = build_decl (input_location, + FUNCTION_DECL, get_identifier (name), type); + + /* Mark the decl as external. */ + DECL_EXTERNAL (fndecl) = 1; + TREE_PUBLIC (fndecl) = 1; + + /* Mark it __attribute__((const)), if possible. */ + TREE_READONLY (fndecl) = m->is_constant; + + rest_of_decl_compilation (fndecl, 1, 0); + + (*pdecl) = fndecl; + return fndecl; +} + + +/* Convert an intrinsic function into an external or builtin call. */ + +static void +gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) +{ + gfc_intrinsic_map_t *m; + tree fndecl; + tree rettype; + tree *args; + unsigned int num_args; + gfc_isym_id id; + + id = expr->value.function.isym->id; + /* Find the entry for this function. */ + for (m = gfc_intrinsic_map; + m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) + { + if (id == m->id) + break; + } + + if (m->id == GFC_ISYM_NONE) + { + gfc_internal_error ("Intrinsic function %qs (%d) not recognized", + expr->value.function.name, id); + } + + /* Get the decl and generate the call. */ + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); + rettype = TREE_TYPE (TREE_TYPE (fndecl)); + + fndecl = build_addr (fndecl); + se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args); +} + + +/* If bounds-checking is enabled, create code to verify at runtime that the + string lengths for both expressions are the same (needed for e.g. MERGE). + If bounds-checking is not enabled, does nothing. */ + +void +gfc_trans_same_strlen_check (const char* intr_name, locus* where, + tree a, tree b, stmtblock_t* target) +{ + tree cond; + tree name; + + /* If bounds-checking is disabled, do nothing. */ + if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) + return; + + /* Compare the two string lengths. */ + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b); + + /* Output the runtime-check. */ + name = gfc_build_cstring_const (intr_name); + name = gfc_build_addr_expr (pchar_type_node, name); + gfc_trans_runtime_check (true, false, cond, target, where, + "Unequal character lengths (%ld/%ld) in %s", + fold_convert (long_integer_type_node, a), + fold_convert (long_integer_type_node, b), name); +} + + +/* The EXPONENT(X) intrinsic function is translated into + int ret; + return isfinite(X) ? (frexp (X, &ret) , ret) : huge + so that if X is a NaN or infinity, the result is HUGE(0). + */ + +static void +gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) +{ + tree arg, type, res, tmp, frexp, cond, huge; + int i; + + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, + expr->value.function.actual->expr->ts.kind); + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false); + huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind); + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISFINITE), + 1, arg); + + res = gfc_create_var (integer_type_node, NULL); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, res)); + tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node, + tmp, res); + se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node, + cond, tmp, huge); + + type = gfc_typenode_for_spec (&expr->ts); + se->expr = fold_convert (type, se->expr); +} + + +/* Fill in the following structure + struct caf_vector_t { + size_t nvec; // size of the vector + union { + struct { + void *vector; + int kind; + } v; + struct { + ptrdiff_t lower_bound; + ptrdiff_t upper_bound; + ptrdiff_t stride; + } triplet; + } u; + } */ + +static void +conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc, + tree lower, tree upper, tree stride, + tree vector, int kind, tree nvec) +{ + tree field, type, tmp; + + desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE); + type = TREE_TYPE (desc); + + field = gfc_advance_chain (TYPE_FIELDS (type), 0); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec)); + + /* Access union. */ + field = gfc_advance_chain (TYPE_FIELDS (type), 1); + desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + type = TREE_TYPE (desc); + + /* Access the inner struct. */ + field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1); + desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + type = TREE_TYPE (desc); + + if (vector != NULL_TREE) + { + /* Set vector and kind. */ + field = gfc_advance_chain (TYPE_FIELDS (type), 0); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector)); + field = gfc_advance_chain (TYPE_FIELDS (type), 1); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind)); + } + else + { + /* Set dim.lower/upper/stride. */ + field = gfc_advance_chain (TYPE_FIELDS (type), 0); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower)); + + field = gfc_advance_chain (TYPE_FIELDS (type), 1); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper)); + + field = gfc_advance_chain (TYPE_FIELDS (type), 2); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride)); + } +} + + +static tree +conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar) +{ + gfc_se argse; + tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec; + tree lbound, ubound, tmp; + int i; + + var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector"); + + for (i = 0; i < ar->dimen; i++) + switch (ar->dimen_type[i]) + { + case DIMEN_RANGE: + if (ar->end[i]) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, ar->end[i]); + gfc_add_block_to_block (block, &argse.pre); + upper = gfc_evaluate_now (argse.expr, block); + } + else + upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); + if (ar->stride[i]) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, ar->stride[i]); + gfc_add_block_to_block (block, &argse.pre); + stride = gfc_evaluate_now (argse.expr, block); + } + else + stride = gfc_index_one_node; + + /* Fall through. */ + case DIMEN_ELEMENT: + if (ar->start[i]) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, ar->start[i]); + gfc_add_block_to_block (block, &argse.pre); + lower = gfc_evaluate_now (argse.expr, block); + } + else + lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + upper = lower; + stride = gfc_index_one_node; + } + vector = NULL_TREE; + nvec = size_zero_node; + conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, + vector, 0, nvec); + break; + + case DIMEN_VECTOR: + gfc_init_se (&argse, NULL); + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, ar->start[i]); + gfc_add_block_to_block (block, &argse.pre); + vector = argse.expr; + lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]); + ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]); + nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL); + tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]); + nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + TREE_TYPE (nvec), nvec, tmp); + lower = gfc_index_zero_node; + upper = gfc_index_zero_node; + stride = gfc_index_zero_node; + vector = gfc_conv_descriptor_data_get (vector); + conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride, + vector, ar->start[i]->ts.kind, nvec); + break; + default: + gcc_unreachable(); + } + return gfc_build_addr_expr (NULL_TREE, var); +} + + +static tree +compute_component_offset (tree field, tree type) +{ + tree tmp; + if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE + && !integer_zerop (DECL_FIELD_BIT_OFFSET (field))) + { + tmp = fold_build2 (TRUNC_DIV_EXPR, type, + DECL_FIELD_BIT_OFFSET (field), + bitsize_unit_node); + return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp); + } + else + return DECL_FIELD_OFFSET (field); +} + + +static tree +conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr) +{ + gfc_ref *ref = expr->ref, *last_comp_ref; + tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2, + field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type, + start, end, stride, vector, nvec; + gfc_se se; + bool ref_static_array = false; + tree last_component_ref_tree = NULL_TREE; + int i, last_type_n; + + if (expr->symtree) + { + last_component_ref_tree = expr->symtree->n.sym->backend_decl; + ref_static_array = !expr->symtree->n.sym->attr.allocatable + && !expr->symtree->n.sym->attr.pointer; + } + + /* Prevent uninit-warning. */ + reference_type = NULL_TREE; + + /* Skip refs upto the first coarray-ref. */ + last_comp_ref = NULL; + while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0)) + { + /* Remember the type of components skipped. */ + if (ref->type == REF_COMPONENT) + last_comp_ref = ref; + ref = ref->next; + } + /* When a component was skipped, get the type information of the last + component ref, else get the type from the symbol. */ + if (last_comp_ref) + { + last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts); + last_type_n = last_comp_ref->u.c.component->ts.type; + } + else + { + last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts); + last_type_n = expr->symtree->n.sym->ts.type; + } + + while (ref) + { + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0 + && ref->u.ar.dimen == 0) + { + /* Skip pure coindexes. */ + ref = ref->next; + continue; + } + tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref"); + reference_type = TREE_TYPE (tmp); + + if (caf_ref == NULL_TREE) + caf_ref = tmp; + + /* Construct the chain of refs. */ + if (prev_caf_ref != NULL_TREE) + { + field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0); + tmp2 = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), prev_caf_ref, field, + NULL_TREE); + gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field), + tmp)); + } + prev_caf_ref = tmp; + + switch (ref->type) + { + case REF_COMPONENT: + last_type = gfc_typenode_for_spec (&ref->u.c.component->ts); + last_type_n = ref->u.c.component->ts.type; + /* Set the type of the ref. */ + field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), prev_caf_ref, field, + NULL_TREE); + gfc_add_modify (block, tmp, build_int_cst (integer_type_node, + GFC_CAF_REF_COMPONENT)); + + /* Ref the c in union u. */ + field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), prev_caf_ref, field, + NULL_TREE); + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0); + inner_struct = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + + /* Set the offset. */ + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), inner_struct, field, + NULL_TREE); + /* Computing the offset is somewhat harder. The bit_offset has to be + taken into account. When the bit_offset in the field_decl is non- + null, divide it by the bitsize_unit and add it to the regular + offset. */ + tmp2 = compute_component_offset (ref->u.c.component->backend_decl, + TREE_TYPE (tmp)); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); + + /* Set caf_token_offset. */ + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), inner_struct, field, + NULL_TREE); + if ((ref->u.c.component->attr.allocatable + || ref->u.c.component->attr.pointer) + && ref->u.c.component->attr.dimension) + { + tree arr_desc_token_offset; + /* Get the token field from the descriptor. */ + arr_desc_token_offset = TREE_OPERAND ( + gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1); + arr_desc_token_offset + = compute_component_offset (arr_desc_token_offset, + TREE_TYPE (tmp)); + tmp2 = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (tmp2), tmp2, + arr_desc_token_offset); + } + else if (ref->u.c.component->caf_token) + tmp2 = compute_component_offset (ref->u.c.component->caf_token, + TREE_TYPE (tmp)); + else + tmp2 = integer_zero_node; + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); + + /* Remember whether this ref was to a non-allocatable/non-pointer + component so the next array ref can be tailored correctly. */ + ref_static_array = !ref->u.c.component->attr.allocatable + && !ref->u.c.component->attr.pointer; + last_component_ref_tree = ref_static_array + ? ref->u.c.component->backend_decl : NULL_TREE; + break; + case REF_ARRAY: + if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED) + ref_static_array = false; + /* Set the type of the ref. */ + field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), prev_caf_ref, field, + NULL_TREE); + gfc_add_modify (block, tmp, build_int_cst (integer_type_node, + ref_static_array + ? GFC_CAF_REF_STATIC_ARRAY + : GFC_CAF_REF_ARRAY)); + + /* Ref the a in union u. */ + field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), prev_caf_ref, field, + NULL_TREE); + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1); + inner_struct = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + + /* Set the static_array_type in a for static arrays. */ + if (ref_static_array) + { + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), + 1); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), inner_struct, field, + NULL_TREE); + gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp), + last_type_n)); + } + /* Ref the mode in the inner_struct. */ + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0); + mode = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), inner_struct, field, + NULL_TREE); + /* Ref the dim in the inner_struct. */ + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2); + dim_array = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), inner_struct, field, + NULL_TREE); + for (i = 0; i < ref->u.ar.dimen; ++i) + { + /* Ref dim i. */ + dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE); + dim_type = TREE_TYPE (dim); + mode_rhs = start = end = stride = NULL_TREE; + switch (ref->u.ar.dimen_type[i]) + { + case DIMEN_RANGE: + if (ref->u.ar.end[i]) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, ref->u.ar.end[i]); + gfc_add_block_to_block (block, &se.pre); + if (ref_static_array) + { + /* Make the index zero-based, when reffing a static + array. */ + end = se.expr; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, ref->u.ar.as->lower[i]); + gfc_add_block_to_block (block, &se.pre); + se.expr = fold_build2 (MINUS_EXPR, + gfc_array_index_type, + end, fold_convert ( + gfc_array_index_type, + se.expr)); + } + end = gfc_evaluate_now (fold_convert ( + gfc_array_index_type, + se.expr), + block); + } + else if (ref_static_array) + end = fold_build2 (MINUS_EXPR, + gfc_array_index_type, + gfc_conv_array_ubound ( + last_component_ref_tree, i), + gfc_conv_array_lbound ( + last_component_ref_tree, i)); + else + { + end = NULL_TREE; + mode_rhs = build_int_cst (unsigned_char_type_node, + GFC_CAF_ARR_REF_OPEN_END); + } + if (ref->u.ar.stride[i]) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, ref->u.ar.stride[i]); + gfc_add_block_to_block (block, &se.pre); + stride = gfc_evaluate_now (fold_convert ( + gfc_array_index_type, + se.expr), + block); + if (ref_static_array) + { + /* Make the index zero-based, when reffing a static + array. */ + stride = fold_build2 (MULT_EXPR, + gfc_array_index_type, + gfc_conv_array_stride ( + last_component_ref_tree, + i), + stride); + gcc_assert (end != NULL_TREE); + /* Multiply with the product of array's stride and + the step of the ref to a virtual upper bound. + We cannot compute the actual upper bound here or + the caflib would compute the extend + incorrectly. */ + end = fold_build2 (MULT_EXPR, gfc_array_index_type, + end, gfc_conv_array_stride ( + last_component_ref_tree, + i)); + end = gfc_evaluate_now (end, block); + stride = gfc_evaluate_now (stride, block); + } + } + else if (ref_static_array) + { + stride = gfc_conv_array_stride (last_component_ref_tree, + i); + end = fold_build2 (MULT_EXPR, gfc_array_index_type, + end, stride); + end = gfc_evaluate_now (end, block); + } + else + /* Always set a ref stride of one to make caflib's + handling easier. */ + stride = gfc_index_one_node; + + /* Fall through. */ + case DIMEN_ELEMENT: + if (ref->u.ar.start[i]) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, ref->u.ar.start[i]); + gfc_add_block_to_block (block, &se.pre); + if (ref_static_array) + { + /* Make the index zero-based, when reffing a static + array. */ + start = fold_convert (gfc_array_index_type, se.expr); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, ref->u.ar.as->lower[i]); + gfc_add_block_to_block (block, &se.pre); + se.expr = fold_build2 (MINUS_EXPR, + gfc_array_index_type, + start, fold_convert ( + gfc_array_index_type, + se.expr)); + /* Multiply with the stride. */ + se.expr = fold_build2 (MULT_EXPR, + gfc_array_index_type, + se.expr, + gfc_conv_array_stride ( + last_component_ref_tree, + i)); + } + start = gfc_evaluate_now (fold_convert ( + gfc_array_index_type, + se.expr), + block); + if (mode_rhs == NULL_TREE) + mode_rhs = build_int_cst (unsigned_char_type_node, + ref->u.ar.dimen_type[i] + == DIMEN_ELEMENT + ? GFC_CAF_ARR_REF_SINGLE + : GFC_CAF_ARR_REF_RANGE); + } + else if (ref_static_array) + { + start = integer_zero_node; + mode_rhs = build_int_cst (unsigned_char_type_node, + ref->u.ar.start[i] == NULL + ? GFC_CAF_ARR_REF_FULL + : GFC_CAF_ARR_REF_RANGE); + } + else if (end == NULL_TREE) + mode_rhs = build_int_cst (unsigned_char_type_node, + GFC_CAF_ARR_REF_FULL); + else + mode_rhs = build_int_cst (unsigned_char_type_node, + GFC_CAF_ARR_REF_OPEN_START); + + /* Ref the s in dim. */ + field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), dim, field, + NULL_TREE); + + /* Set start in s. */ + if (start != NULL_TREE) + { + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), + 0); + tmp2 = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + gfc_add_modify (block, tmp2, + fold_convert (TREE_TYPE (tmp2), start)); + } + + /* Set end in s. */ + if (end != NULL_TREE) + { + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), + 1); + tmp2 = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + gfc_add_modify (block, tmp2, + fold_convert (TREE_TYPE (tmp2), end)); + } + + /* Set end in s. */ + if (stride != NULL_TREE) + { + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), + 2); + tmp2 = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + gfc_add_modify (block, tmp2, + fold_convert (TREE_TYPE (tmp2), stride)); + } + break; + case DIMEN_VECTOR: + /* TODO: In case of static array. */ + gcc_assert (!ref_static_array); + mode_rhs = build_int_cst (unsigned_char_type_node, + GFC_CAF_ARR_REF_VECTOR); + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]); + gfc_add_block_to_block (block, &se.pre); + vector = se.expr; + tmp = gfc_conv_descriptor_lbound_get (vector, + gfc_rank_cst[0]); + tmp2 = gfc_conv_descriptor_ubound_get (vector, + gfc_rank_cst[0]); + nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL); + tmp = gfc_conv_descriptor_stride_get (vector, + gfc_rank_cst[0]); + nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + TREE_TYPE (nvec), nvec, tmp); + vector = gfc_conv_descriptor_data_get (vector); + + /* Ref the v in dim. */ + field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), dim, field, + NULL_TREE); + + /* Set vector in v. */ + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0); + tmp2 = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2), + vector)); + + /* Set nvec in v. */ + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1); + tmp2 = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2), + nvec)); + + /* Set kind in v. */ + field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2); + tmp2 = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), tmp, field, + NULL_TREE); + gfc_add_modify (block, tmp2, build_int_cst (integer_type_node, + ref->u.ar.start[i]->ts.kind)); + break; + default: + gcc_unreachable (); + } + /* Set the mode for dim i. */ + tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), + mode_rhs)); + } + + /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */ + if (i < GFC_MAX_DIMENSIONS) + { + tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE); + gfc_add_modify (block, tmp, + build_int_cst (unsigned_char_type_node, + GFC_CAF_ARR_REF_NONE)); + } + break; + default: + gcc_unreachable (); + } + + /* Set the size of the current type. */ + field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + prev_caf_ref, field, NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), + TYPE_SIZE_UNIT (last_type))); + + ref = ref->next; + } + + if (prev_caf_ref != NULL_TREE) + { + field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + prev_caf_ref, field, NULL_TREE); + gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), + null_pointer_node)); + } + return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref) + : NULL_TREE; +} + +/* Get data from a remote coarray. */ + +static void +gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, + tree may_require_tmp, bool may_realloc, + symbol_attribute *caf_attr) +{ + gfc_expr *array_expr, *tmp_stat; + gfc_se argse; + tree caf_decl, token, offset, image_index, tmp; + tree res_var, dst_var, type, kind, vec, stat; + tree caf_reference; + symbol_attribute caf_attr_store; + + gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); + + if (se->ss && se->ss->info->useflags) + { + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + return; + } + + /* If lhs is set, the CAF_GET intrinsic has already been stripped. */ + array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr; + type = gfc_typenode_for_spec (&array_expr->ts); + + if (caf_attr == NULL) + { + caf_attr_store = gfc_caf_attr (array_expr); + caf_attr = &caf_attr_store; + } + + res_var = lhs; + dst_var = lhs; + + vec = null_pointer_node; + tmp_stat = gfc_find_stat_co (expr); + + if (tmp_stat) + { + gfc_se stat_se; + gfc_init_se (&stat_se, NULL); + gfc_conv_expr_reference (&stat_se, tmp_stat); + stat = stat_se.expr; + gfc_add_block_to_block (&se->pre, &stat_se.pre); + gfc_add_block_to_block (&se->post, &stat_se.post); + } + else + stat = null_pointer_node; + + /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs + is reallocatable or the right-hand side has allocatable components. */ + if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc) + { + /* Get using caf_get_by_ref. */ + caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr); + + if (caf_reference != NULL_TREE) + { + if (lhs == NULL_TREE) + { + if (array_expr->ts.type == BT_CHARACTER) + gfc_init_se (&argse, NULL); + if (array_expr->rank == 0) + { + symbol_attribute attr; + gfc_clear_attr (&attr); + if (array_expr->ts.type == BT_CHARACTER) + { + res_var = gfc_conv_string_tmp (se, + build_pointer_type (type), + array_expr->ts.u.cl->backend_decl); + argse.string_length = array_expr->ts.u.cl->backend_decl; + } + else + res_var = gfc_create_var (type, "caf_res"); + dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr); + dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); + } + else + { + /* Create temporary. */ + if (array_expr->ts.type == BT_CHARACTER) + gfc_conv_expr_descriptor (&argse, array_expr); + may_realloc = gfc_trans_create_temp_array (&se->pre, + &se->post, + se->ss, type, + NULL_TREE, false, + false, false, + &array_expr->where) + == NULL_TREE; + res_var = se->ss->info->data.array.descriptor; + dst_var = gfc_build_addr_expr (NULL_TREE, res_var); + if (may_realloc) + { + tmp = gfc_conv_descriptor_data_get (res_var); + 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->post, tmp); + } + } + } + + kind = build_int_cst (integer_type_node, expr->ts.kind); + if (lhs_kind == NULL_TREE) + lhs_kind = kind; + + caf_decl = gfc_get_tree_for_caf_expr (array_expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + image_index = gfc_caf_get_image_index (&se->pre, array_expr, + caf_decl); + gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, + array_expr); + + /* No overlap possible as we have generated a temporary. */ + if (lhs == NULL_TREE) + may_require_tmp = boolean_false_node; + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, + NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE), + NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&se->pre, tmp); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref, + 10, token, image_index, dst_var, + caf_reference, lhs_kind, kind, + may_require_tmp, + may_realloc ? boolean_true_node : + boolean_false_node, + stat, build_int_cst (integer_type_node, + array_expr->ts.type)); + + gfc_add_expr_to_block (&se->pre, tmp); + + if (se->ss) + gfc_advance_se_ss_chain (se); + + se->expr = res_var; + if (array_expr->ts.type == BT_CHARACTER) + se->string_length = argse.string_length; + + return; + } + } + + gfc_init_se (&argse, NULL); + if (array_expr->rank == 0) + { + symbol_attribute attr; + + gfc_clear_attr (&attr); + gfc_conv_expr (&argse, array_expr); + + if (lhs == NULL_TREE) + { + gfc_clear_attr (&attr); + if (array_expr->ts.type == BT_CHARACTER) + res_var = gfc_conv_string_tmp (se, build_pointer_type (type), + argse.string_length); + else + res_var = gfc_create_var (type, "caf_res"); + dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr); + dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); + } + argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); + argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); + } + else + { + /* If has_vector, pass descriptor for whole array and the + vector bounds separately. */ + gfc_array_ref *ar, ar2; + bool has_vector = false; + + if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr)) + { + has_vector = true; + ar = gfc_find_array_ref (expr); + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + } + // TODO: Check whether argse.want_coarray = 1 can help with the below. + gfc_conv_expr_descriptor (&argse, array_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr), + gfc_get_dtype_rank_type (has_vector ? ar2.dimen + : array_expr->rank, + type)); + if (has_vector) + { + vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2); + *ar = ar2; + } + + if (lhs == NULL_TREE) + { + /* Create temporary. */ + for (int n = 0; n < se->ss->loop->dimen; n++) + if (se->loop->to[n] == NULL_TREE) + { + se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr, + gfc_rank_cst[n]); + se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr, + gfc_rank_cst[n]); + } + gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type, + NULL_TREE, false, true, false, + &array_expr->where); + res_var = se->ss->info->data.array.descriptor; + dst_var = gfc_build_addr_expr (NULL_TREE, res_var); + } + argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); + } + + kind = build_int_cst (integer_type_node, expr->ts.kind); + if (lhs_kind == NULL_TREE) + lhs_kind = kind; + + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + caf_decl = gfc_get_tree_for_caf_expr (array_expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl); + gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr, + array_expr); + + /* No overlap possible as we have generated a temporary. */ + if (lhs == NULL_TREE) + may_require_tmp = boolean_false_node; + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&se->pre, tmp); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10, + token, offset, image_index, argse.expr, vec, + dst_var, kind, lhs_kind, may_require_tmp, stat); + + gfc_add_expr_to_block (&se->pre, tmp); + + if (se->ss) + gfc_advance_se_ss_chain (se); + + se->expr = res_var; + if (array_expr->ts.type == BT_CHARACTER) + se->string_length = argse.string_length; +} + + +/* Send data to a remote coarray. */ + +static tree +conv_caf_send (gfc_code *code) { + gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team; + gfc_se lhs_se, rhs_se; + stmtblock_t block; + tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; + tree may_require_tmp, src_stat, dst_stat, dst_team; + tree lhs_type = NULL_TREE; + tree vec = null_pointer_node, rhs_vec = null_pointer_node; + symbol_attribute lhs_caf_attr, rhs_caf_attr; + + gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); + + lhs_expr = code->ext.actual->expr; + rhs_expr = code->ext.actual->next->expr; + may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0 + ? boolean_false_node : boolean_true_node; + gfc_init_block (&block); + + lhs_caf_attr = gfc_caf_attr (lhs_expr); + rhs_caf_attr = gfc_caf_attr (rhs_expr); + src_stat = dst_stat = null_pointer_node; + dst_team = null_pointer_node; + + /* LHS. */ + gfc_init_se (&lhs_se, NULL); + if (lhs_expr->rank == 0) + { + if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred) + { + lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr); + lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); + } + else + { + symbol_attribute attr; + gfc_clear_attr (&attr); + gfc_conv_expr (&lhs_se, lhs_expr); + lhs_type = TREE_TYPE (lhs_se.expr); + lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, + attr); + lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); + } + } + else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp) + && lhs_caf_attr.codimension) + { + lhs_se.want_pointer = 1; + gfc_conv_expr_descriptor (&lhs_se, lhs_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); + tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); + gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type ( + gfc_has_vector_subscript (lhs_expr) + ? gfc_find_array_ref (lhs_expr)->dimen + : lhs_expr->rank, + lhs_type)); + } + else + { + bool has_vector = gfc_has_vector_subscript (lhs_expr); + + if (gfc_is_coindexed (lhs_expr) || !has_vector) + { + /* If has_vector, pass descriptor for whole array and the + vector bounds separately. */ + gfc_array_ref *ar, ar2; + bool has_tmp_lhs_array = false; + if (has_vector) + { + has_tmp_lhs_array = true; + ar = gfc_find_array_ref (lhs_expr); + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + } + lhs_se.want_pointer = 1; + gfc_conv_expr_descriptor (&lhs_se, lhs_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but + that has the wrong type if component references are done. */ + lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); + tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); + gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type (has_vector ? ar2.dimen + : lhs_expr->rank, + lhs_type)); + if (has_tmp_lhs_array) + { + vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2); + *ar = ar2; + } + } + else + { + /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to + indexed array expression. This is rewritten to: + + tmp_array = arr2[...] + arr1 ([...]) = tmp_array + + because using the standard gfc_conv_expr (lhs_expr) did the + assignment with lhs and rhs exchanged. */ + + gfc_ss *lss_for_tmparray, *lss_real; + gfc_loopinfo loop; + gfc_se se; + stmtblock_t body; + tree tmparr_desc, src; + tree index = gfc_index_zero_node; + tree stride = gfc_index_zero_node; + int n; + + /* Walk both sides of the assignment, once to get the shape of the + temporary array to create right. */ + lss_for_tmparray = gfc_walk_expr (lhs_expr); + /* And a second time to be able to create an assignment of the + temporary to the lhs_expr. gfc_trans_create_temp_array replaces + the tree in the descriptor with the one for the temporary + array. */ + lss_real = gfc_walk_expr (lhs_expr); + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, lss_for_tmparray); + gfc_add_ss_to_loop (&loop, lss_real); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &lhs_expr->where); + lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); + gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post, + lss_for_tmparray, lhs_type, NULL_TREE, + false, true, false, + &lhs_expr->where); + tmparr_desc = lss_for_tmparray->info->data.array.descriptor; + gfc_start_scalarized_body (&loop, &body); + gfc_init_se (&se, NULL); + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = lss_real; + gfc_conv_expr (&se, lhs_expr); + gfc_add_block_to_block (&body, &se.pre); + + /* Walk over all indexes of the loop. */ + for (n = loop.dimen - 1; n > 0; --n) + { + tmp = loop.loopvar[n]; + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tmp, loop.from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, index); + + stride = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop.to[n - 1], loop.from[n - 1]); + stride = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + stride, gfc_index_one_node); + + index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, stride); + } + + index = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + index, loop.from[0]); + + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + loop.loopvar[0], index); + + src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc)); + src = gfc_build_array_ref (src, index, NULL); + /* Now create the assignment of lhs_expr = tmp_array. */ + gfc_add_modify (&body, se.expr, src); + gfc_add_block_to_block (&body, &se.post); + lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc); + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&loop.pre, &loop.post); + gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre)); + gfc_free_ss (lss_for_tmparray); + gfc_free_ss (lss_real); + } + } + + lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind); + + /* Special case: RHS is a coarray but LHS is not; this code path avoids a + temporary and a loop. */ + if (!gfc_is_coindexed (lhs_expr) + && (!lhs_caf_attr.codimension + || !(lhs_expr->rank > 0 + && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer)))) + { + bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable; + gcc_assert (gfc_is_coindexed (rhs_expr)); + gfc_init_se (&rhs_se, NULL); + if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable) + { + gfc_se scal_se; + gfc_init_se (&scal_se, NULL); + scal_se.want_pointer = 1; + gfc_conv_expr (&scal_se, lhs_expr); + /* Ensure scalar on lhs is allocated. */ + gfc_add_block_to_block (&block, &scal_se.pre); + + gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr, + TYPE_SIZE_UNIT ( + gfc_typenode_for_spec (&lhs_expr->ts)), + NULL_TREE); + tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr, + null_pointer_node); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, gfc_finish_block (&scal_se.pre), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + lhs_may_realloc = lhs_may_realloc + && gfc_full_array_ref_p (lhs_expr->ref, NULL); + gfc_add_block_to_block (&block, &lhs_se.pre); + gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind, + may_require_tmp, lhs_may_realloc, + &rhs_caf_attr); + gfc_add_block_to_block (&block, &rhs_se.pre); + gfc_add_block_to_block (&block, &rhs_se.post); + gfc_add_block_to_block (&block, &lhs_se.post); + return gfc_finish_block (&block); + } + + gfc_add_block_to_block (&block, &lhs_se.pre); + + /* Obtain token, offset and image index for the LHS. */ + caf_decl = gfc_get_tree_for_caf_expr (lhs_expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl); + tmp = lhs_se.expr; + if (lhs_caf_attr.alloc_comp) + gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE, + NULL); + else + gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp, + lhs_expr); + lhs_se.expr = tmp; + + /* RHS. */ + gfc_init_se (&rhs_se, NULL); + if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym + && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION) + rhs_expr = rhs_expr->value.function.actual->expr; + if (rhs_expr->rank == 0) + { + symbol_attribute attr; + gfc_clear_attr (&attr); + gfc_conv_expr (&rhs_se, rhs_expr); + rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr); + rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr); + } + else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp) + && rhs_caf_attr.codimension) + { + tree tmp2; + rhs_se.want_pointer = 1; + gfc_conv_expr_descriptor (&rhs_se, rhs_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); + tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); + gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type ( + gfc_has_vector_subscript (rhs_expr) + ? gfc_find_array_ref (rhs_expr)->dimen + : rhs_expr->rank, + tmp2)); + } + else + { + /* If has_vector, pass descriptor for whole array and the + vector bounds separately. */ + gfc_array_ref *ar, ar2; + bool has_vector = false; + tree tmp2; + + if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr)) + { + has_vector = true; + ar = gfc_find_array_ref (rhs_expr); + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + } + rhs_se.want_pointer = 1; + gfc_conv_expr_descriptor (&rhs_se, rhs_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); + tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); + gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type (has_vector ? ar2.dimen + : rhs_expr->rank, + tmp2)); + if (has_vector) + { + rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2); + *ar = ar2; + } + } + + gfc_add_block_to_block (&block, &rhs_se.pre); + + rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind); + + tmp_stat = gfc_find_stat_co (lhs_expr); + + if (tmp_stat) + { + gfc_se stat_se; + gfc_init_se (&stat_se, NULL); + gfc_conv_expr_reference (&stat_se, tmp_stat); + dst_stat = stat_se.expr; + gfc_add_block_to_block (&block, &stat_se.pre); + gfc_add_block_to_block (&block, &stat_se.post); + } + + tmp_team = gfc_find_team_co (lhs_expr); + + if (tmp_team) + { + gfc_se team_se; + gfc_init_se (&team_se, NULL); + gfc_conv_expr_reference (&team_se, tmp_team); + dst_team = team_se.expr; + gfc_add_block_to_block (&block, &team_se.pre); + gfc_add_block_to_block (&block, &team_se.post); + } + + if (!gfc_is_coindexed (rhs_expr)) + { + if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp) + { + tree reference, dst_realloc; + reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); + dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node + : boolean_false_node; + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_send_by_ref, + 10, token, image_index, rhs_se.expr, + reference, lhs_kind, rhs_kind, + may_require_tmp, dst_realloc, src_stat, + build_int_cst (integer_type_node, + lhs_expr->ts.type)); + } + else + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11, + token, offset, image_index, lhs_se.expr, vec, + rhs_se.expr, lhs_kind, rhs_kind, + may_require_tmp, src_stat, dst_team); + } + else + { + tree rhs_token, rhs_offset, rhs_image_index; + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&block, tmp); + + caf_decl = gfc_get_tree_for_caf_expr (rhs_expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl); + tmp = rhs_se.expr; + if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp) + { + tmp_stat = gfc_find_stat_co (lhs_expr); + + if (tmp_stat) + { + gfc_se stat_se; + gfc_init_se (&stat_se, NULL); + gfc_conv_expr_reference (&stat_se, tmp_stat); + src_stat = stat_se.expr; + gfc_add_block_to_block (&block, &stat_se.pre); + gfc_add_block_to_block (&block, &stat_se.post); + } + + gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl, + NULL_TREE, NULL); + tree lhs_reference, rhs_reference; + lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); + rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_sendget_by_ref, 13, + token, image_index, lhs_reference, + rhs_token, rhs_image_index, rhs_reference, + lhs_kind, rhs_kind, may_require_tmp, + dst_stat, src_stat, + build_int_cst (integer_type_node, + lhs_expr->ts.type), + build_int_cst (integer_type_node, + rhs_expr->ts.type)); + } + else + { + gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl, + tmp, rhs_expr); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget, + 14, token, offset, image_index, + lhs_se.expr, vec, rhs_token, rhs_offset, + rhs_image_index, tmp, rhs_vec, lhs_kind, + rhs_kind, may_require_tmp, src_stat); + } + } + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &lhs_se.post); + gfc_add_block_to_block (&block, &rhs_se.post); + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +static void +trans_this_image (gfc_se * se, gfc_expr *expr) +{ + stmtblock_t loop; + tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, + lbound, ubound, extent, ml; + gfc_se argse; + int rank, corank; + gfc_expr *distance = expr->value.function.actual->next->next->expr; + + if (expr->value.function.actual->expr + && !gfc_is_coarray (expr->value.function.actual->expr)) + distance = expr->value.function.actual->expr; + + /* The case -fcoarray=single is handled elsewhere. */ + gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE); + + /* Argument-free version: THIS_IMAGE(). */ + if (distance || expr->value.function.actual->expr == NULL) + { + if (distance) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, distance); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + tmp = fold_convert (integer_type_node, argse.expr); + } + else + tmp = integer_zero_node; + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, + tmp); + se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), + tmp); + return; + } + + /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */ + + type = gfc_get_int_type (gfc_default_integer_kind); + corank = gfc_get_corank (expr->value.function.actual->expr); + rank = expr->value.function.actual->expr->rank; + + /* Obtain the descriptor of the COARRAY. */ + gfc_init_se (&argse, NULL); + argse.want_coarray = 1; + gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = argse.expr; + + if (se->ss) + { + /* Create an implicit second parameter from the loop variable. */ + gcc_assert (!expr->value.function.actual->next->expr); + gcc_assert (corank > 0); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->info->expr == expr); + + dim_arg = se->loop->loopvar[0]; + dim_arg = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, dim_arg, + build_int_cst (TREE_TYPE (dim_arg), 1)); + gfc_advance_se_ss_chain (se); + } + else + { + /* Use the passed DIM= argument. */ + gcc_assert (expr->value.function.actual->next->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr, + gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + dim_arg = argse.expr; + + if (INTEGER_CST_P (dim_arg)) + { + if (wi::ltu_p (wi::to_wide (dim_arg), 1) + || wi::gtu_p (wi::to_wide (dim_arg), + GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))) + gfc_error ("% argument of %s intrinsic at %L is not a valid " + "dimension index", expr->value.function.isym->name, + &expr->where); + } + else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + dim_arg = gfc_evaluate_now (dim_arg, &se->pre); + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + dim_arg, + build_int_cst (TREE_TYPE (dim_arg), 1)); + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + dim_arg, tmp); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, cond, tmp); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + gfc_msg_fault); + } + } + + /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer, + one always has a dim_arg argument. + + m = this_image() - 1 + if (corank == 1) + { + sub(1) = m + lcobound(corank) + return; + } + i = rank + min_var = min (rank + corank - 2, rank + dim_arg - 1) + for (;;) + { + extent = gfc_extent(i) + ml = m + m = m/extent + if (i >= min_var) + goto exit_label + i++ + } + exit_label: + sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg) + : m + lcobound(corank) + */ + + /* this_image () - 1. */ + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, + integer_zero_node); + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, + fold_convert (type, tmp), build_int_cst (type, 1)); + if (corank == 1) + { + /* sub(1) = m + lcobound(corank). */ + lbound = gfc_conv_descriptor_lbound_get (desc, + build_int_cst (TREE_TYPE (gfc_array_index_type), + corank+rank-1)); + lbound = fold_convert (type, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound); + + se->expr = tmp; + return; + } + + m = gfc_create_var (type, NULL); + ml = gfc_create_var (type, NULL); + loop_var = gfc_create_var (integer_type_node, NULL); + min_var = gfc_create_var (integer_type_node, NULL); + + /* m = this_image () - 1. */ + gfc_add_modify (&se->pre, m, tmp); + + /* min_var = min (rank + corank-2, rank + dim_arg - 1). */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + fold_convert (integer_type_node, dim_arg), + build_int_cst (integer_type_node, rank - 1)); + tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node, + build_int_cst (integer_type_node, rank + corank - 2), + tmp); + gfc_add_modify (&se->pre, min_var, tmp); + + /* i = rank. */ + tmp = build_int_cst (integer_type_node, rank); + gfc_add_modify (&se->pre, loop_var, tmp); + + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + /* Loop body. */ + gfc_init_block (&loop); + + /* ml = m. */ + gfc_add_modify (&loop, ml, m); + + /* extent = ... */ + lbound = gfc_conv_descriptor_lbound_get (desc, loop_var); + ubound = gfc_conv_descriptor_ubound_get (desc, loop_var); + extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + extent = fold_convert (type, extent); + + /* m = m/extent. */ + gfc_add_modify (&loop, m, + fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, + m, extent)); + + /* Exit condition: if (i >= min_var) goto exit_label. */ + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var, + min_var); + 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); + + /* Increment loop variable: i++. */ + gfc_add_modify (&loop, loop_var, + fold_build2_loc (input_location, PLUS_EXPR, integer_type_node, + loop_var, + build_int_cst (integer_type_node, 1))); + + /* Making the loop... actually loop! */ + tmp = gfc_finish_block (&loop); + tmp = build1_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&se->pre, tmp); + + /* The exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&se->pre, tmp); + + /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg) + : m + lcobound(corank) */ + + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg, + build_int_cst (TREE_TYPE (dim_arg), corank)); + + lbound = gfc_conv_descriptor_lbound_get (desc, + fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, dim_arg, + build_int_cst (TREE_TYPE (dim_arg), rank-1))); + lbound = fold_convert (type, lbound); + + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml, + fold_build2_loc (input_location, MULT_EXPR, type, + m, extent)); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound); + + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp, + fold_build2_loc (input_location, PLUS_EXPR, type, + m, lbound)); +} + + +/* Convert a call to image_status. */ + +static void +conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) +{ + unsigned int num_args; + tree *args, tmp; + + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + /* In args[0] the number of the image the status is desired for has to be + given. */ + + if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + tree arg; + arg = gfc_evaluate_now (args[0], &se->pre); + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + fold_convert (integer_type_node, arg), + integer_one_node); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, + tmp, integer_zero_node, + build_int_cst (integer_type_node, + GFC_STAT_STOPPED_IMAGE)); + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2, + args[0], build_int_cst (integer_type_node, -1)); + else + gcc_unreachable (); + + se->expr = tmp; +} + +static void +conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) +{ + unsigned int num_args; + + tree *args, tmp; + + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + + if (flag_coarray == + GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr) + { + tree arg; + + arg = gfc_evaluate_now (args[0], &se->pre); + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + fold_convert (integer_type_node, arg), + integer_one_node); + tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, + tmp, integer_zero_node, + build_int_cst (integer_type_node, + GFC_STAT_STOPPED_IMAGE)); + } + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + // the value -1 represents that no team has been created yet + tmp = build_int_cst (integer_type_node, -1); + } + else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, + args[0], build_int_cst (integer_type_node, -1)); + else if (flag_coarray == GFC_FCOARRAY_LIB) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, + integer_zero_node, build_int_cst (integer_type_node, -1)); + else + gcc_unreachable (); + + se->expr = tmp; +} + + +static void +trans_image_index (gfc_se * se, gfc_expr *expr) +{ + tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, + tmp, invalid_bound; + gfc_se argse, subse; + int rank, corank, codim; + + type = gfc_get_int_type (gfc_default_integer_kind); + corank = gfc_get_corank (expr->value.function.actual->expr); + rank = expr->value.function.actual->expr->rank; + + /* Obtain the descriptor of the COARRAY. */ + gfc_init_se (&argse, NULL); + argse.want_coarray = 1; + gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = argse.expr; + + /* Obtain a handle to the SUB argument. */ + gfc_init_se (&subse, NULL); + gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr); + gfc_add_block_to_block (&se->pre, &subse.pre); + gfc_add_block_to_block (&se->post, &subse.post); + subdesc = build_fold_indirect_ref_loc (input_location, + gfc_conv_descriptor_data_get (subse.expr)); + + /* Fortran 2008 does not require that the values remain in the cobounds, + thus we need explicitly check this - and return 0 if they are exceeded. */ + + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); + tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL); + invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + fold_convert (gfc_array_index_type, tmp), + lbound); + + for (codim = corank + rank - 2; codim >= rank; codim--) + { + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); + tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + fold_convert (gfc_array_index_type, tmp), + lbound); + invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, invalid_bound, cond); + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + fold_convert (gfc_array_index_type, tmp), + ubound); + invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, invalid_bound, cond); + } + + invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND); + + /* See Fortran 2008, C.10 for the following algorithm. */ + + /* coindex = sub(corank) - lcobound(n). */ + coindex = fold_convert (gfc_array_index_type, + gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], + NULL)); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); + coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, coindex), + lbound); + + for (codim = corank + rank - 2; codim >= rank; codim--) + { + tree extent, ubound; + + /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */ + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); + ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); + extent = gfc_conv_array_extent_dim (lbound, ubound, NULL); + + /* coindex *= extent. */ + coindex = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, coindex, extent); + + /* coindex += sub(codim). */ + tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); + coindex = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, coindex, + fold_convert (gfc_array_index_type, tmp)); + + /* coindex -= lbound(codim). */ + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); + coindex = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, coindex, lbound); + } + + coindex = fold_build2_loc (input_location, PLUS_EXPR, type, + fold_convert(type, coindex), + build_int_cst (type, 1)); + + /* Return 0 if "coindex" exceeds num_images(). */ + + if (flag_coarray == GFC_FCOARRAY_SINGLE) + num_images = build_int_cst (type, 1); + else + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, + integer_zero_node, + build_int_cst (integer_type_node, -1)); + num_images = fold_convert (type, tmp); + } + + tmp = gfc_create_var (type, NULL); + gfc_add_modify (&se->pre, tmp, coindex); + + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp, + num_images); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, + cond, + fold_convert (logical_type_node, invalid_bound)); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, + build_int_cst (type, 0), tmp); +} + +static void +trans_num_images (gfc_se * se, gfc_expr *expr) +{ + tree tmp, distance, failed; + gfc_se argse; + + if (expr->value.function.actual->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, expr->value.function.actual->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + distance = fold_convert (integer_type_node, argse.expr); + } + else + distance = integer_zero_node; + + if (expr->value.function.actual->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + failed = fold_convert (integer_type_node, argse.expr); + } + else + failed = build_int_cst (integer_type_node, -1); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, + distance, failed); + se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); +} + + +static void +gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) +{ + gfc_se argse; + + gfc_init_se (&argse, NULL); + argse.data_not_needed = 1; + argse.descriptor_only = 1; + + gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + se->expr = gfc_conv_descriptor_rank (argse.expr); + se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), + se->expr); +} + + +static void +gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr) +{ + gfc_expr *arg; + arg = expr->value.function.actual->expr; + gfc_conv_is_contiguous_expr (se, arg); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + +/* This function does the work for gfc_conv_intrinsic_is_contiguous, + plus it can be called directly. */ + +void +gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) +{ + gfc_ss *ss; + gfc_se argse; + tree desc, tmp, stride, extent, cond; + int i; + tree fncall0; + gfc_array_spec *as; + + if (arg->ts.type == BT_CLASS) + gfc_add_class_array_ref (arg); + + ss = gfc_walk_expr (arg); + gcc_assert (ss != gfc_ss_terminator); + gfc_init_se (&argse, NULL); + argse.data_not_needed = 1; + gfc_conv_expr_descriptor (&argse, arg); + + as = gfc_get_full_arrayspec_from_expr (arg); + + /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ... + Note in addition that zero-sized arrays don't count as contiguous. */ + + if (as && as->type == AS_ASSUMED_RANK) + { + /* Build the call to is_contiguous0. */ + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, arg); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = gfc_evaluate_now (argse.expr, &se->pre); + fncall0 = build_call_expr_loc (input_location, + gfor_fndecl_is_contiguous0, 1, desc); + se->expr = fncall0; + se->expr = convert (logical_type_node, se->expr); + } + else + { + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = gfc_evaluate_now (argse.expr, &se->pre); + + stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + stride, build_int_cst (TREE_TYPE (stride), 1)); + + for (i = 0; i < arg->rank - 1; i++) + { + tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); + extent = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, extent, tmp); + extent = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, extent, + gfc_index_one_node); + tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), + tmp, extent); + stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + stride, tmp); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, tmp); + } + se->expr = cond; + } +} + + +/* Evaluate a single upper or lower bound. */ +/* TODO: bound intrinsic generates way too much unnecessary code. */ + +static void +gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op) +{ + gfc_actual_arglist *arg; + gfc_actual_arglist *arg2; + tree desc; + tree type; + tree bound; + tree tmp; + tree cond, cond1; + tree ubound; + tree lbound; + tree size; + gfc_se argse; + gfc_array_spec * as; + bool assumed_rank_lb_one; + + arg = expr->value.function.actual; + arg2 = arg->next; + + if (se->ss) + { + /* Create an implicit second parameter from the loop variable. */ + gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->info->expr == expr); + gfc_advance_se_ss_chain (se); + bound = se->loop->loopvar[0]; + bound = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, bound, + se->loop->from[0]); + } + else + { + /* use the passed argument. */ + gcc_assert (arg2->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + bound = argse.expr; + /* Convert from one based to zero based. */ + bound = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, bound, + gfc_index_one_node); + } + + /* TODO: don't re-evaluate the descriptor on each iteration. */ + /* Get a descriptor for the first parameter. */ + gfc_init_se (&argse, NULL); + gfc_conv_expr_descriptor (&argse, arg->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + desc = argse.expr; + + as = gfc_get_full_arrayspec_from_expr (arg->expr); + + if (INTEGER_CST_P (bound)) + { + gcc_assert (op != GFC_ISYM_SHAPE); + if (((!as || as->type != AS_ASSUMED_RANK) + && wi::geu_p (wi::to_wide (bound), + GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))) + || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS)) + gfc_error ("% argument of %s intrinsic at %L is not a valid " + "dimension index", + (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND", + &expr->where); + } + + if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK)) + { + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + bound = gfc_evaluate_now (bound, &se->pre); + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + bound, build_int_cst (TREE_TYPE (bound), 0)); + if (as && as->type == AS_ASSUMED_RANK) + tmp = gfc_conv_descriptor_rank (desc); + else + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + bound, fold_convert(TREE_TYPE (bound), tmp)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, cond, tmp); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + gfc_msg_fault); + } + } + + /* Take care of the lbound shift for assumed-rank arrays that are + nonallocatable and nonpointers. Those have a lbound of 1. */ + assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK + && ((arg->expr->ts.type != BT_CLASS + && !arg->expr->symtree->n.sym->attr.allocatable + && !arg->expr->symtree->n.sym->attr.pointer) + || (arg->expr->ts.type == BT_CLASS + && !CLASS_DATA (arg->expr)->attr.allocatable + && !CLASS_DATA (arg->expr)->attr.class_pointer)); + + ubound = gfc_conv_descriptor_ubound_get (desc, bound); + lbound = gfc_conv_descriptor_lbound_get (desc, bound); + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + size = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, size, gfc_index_one_node); + + /* 13.14.53: Result value for LBOUND + + Case (i): For an array section or for an array expression other than a + whole array or array structure component, LBOUND(ARRAY, DIM) + has the value 1. For a whole array or array structure + component, LBOUND(ARRAY, DIM) has the value: + (a) equal to the lower bound for subscript DIM of ARRAY if + dimension DIM of ARRAY does not have extent zero + or if ARRAY is an assumed-size array of rank DIM, + or (b) 1 otherwise. + + 13.14.113: Result value for UBOUND + + Case (i): For an array section or for an array expression other than a + whole array or array structure component, UBOUND(ARRAY, DIM) + has the value equal to the number of elements in the given + dimension; otherwise, it has a value equal to the upper bound + for subscript DIM of ARRAY if dimension DIM of ARRAY does + not have size zero and has value zero if dimension DIM has + size zero. */ + + if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one) + se->expr = gfc_index_one_node; + else if (as) + { + if (op == GFC_ISYM_UBOUND) + { + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + size, gfc_index_zero_node); + se->expr = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + (assumed_rank_lb_one ? size : ubound), + gfc_index_zero_node); + } + else if (op == GFC_ISYM_LBOUND) + { + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + size, gfc_index_zero_node); + if (as->type == AS_ASSUMED_SIZE) + { + cond1 = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, bound, + build_int_cst (TREE_TYPE (bound), + arg->expr->rank - 1)); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, cond, cond1); + } + se->expr = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + lbound, gfc_index_one_node); + } + else if (op == GFC_ISYM_SHAPE) + se->expr = size; + else + gcc_unreachable (); + + /* According to F2018 16.9.172, para 5, an assumed rank object, + argument associated with and assumed size array, has the ubound + of the final dimension set to -1 and UBOUND must return this. + Similarly for the SHAPE intrinsic. */ + if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one) + { + tree minus_one = build_int_cst (gfc_array_index_type, -1); + tree rank = fold_convert (gfc_array_index_type, + gfc_conv_descriptor_rank (desc)); + rank = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, rank, minus_one); + + /* Fix the expression to stop it from becoming even more + complicated. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); + + /* Descriptors for assumed-size arrays have ubound = -1 + in the last dimension. */ + cond1 = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, ubound, minus_one); + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, bound, rank); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, cond, cond1); + se->expr = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + minus_one, se->expr); + } + } + else /* as is null; this is an old-fashioned 1-based array. */ + { + if (op != GFC_ISYM_LBOUND) + { + se->expr = fold_build2_loc (input_location, MAX_EXPR, + gfc_array_index_type, size, + gfc_index_zero_node); + } + else + se->expr = gfc_index_one_node; + } + + + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, se->expr); +} + + +static void +conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *arg; + gfc_actual_arglist *arg2; + gfc_se argse; + tree bound, resbound, resbound2, desc, cond, tmp; + tree type; + int corank; + + gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND + || expr->value.function.isym->id == GFC_ISYM_UCOBOUND + || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE); + + arg = expr->value.function.actual; + arg2 = arg->next; + + gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); + corank = gfc_get_corank (arg->expr); + + gfc_init_se (&argse, NULL); + argse.want_coarray = 1; + + gfc_conv_expr_descriptor (&argse, arg->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = argse.expr; + + if (se->ss) + { + /* Create an implicit second parameter from the loop variable. */ + gcc_assert (!arg2->expr); + gcc_assert (corank > 0); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->info->expr == expr); + + bound = se->loop->loopvar[0]; + bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + bound, gfc_rank_cst[arg->expr->rank]); + gfc_advance_se_ss_chain (se); + } + else + { + /* use the passed argument. */ + gcc_assert (arg2->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + bound = argse.expr; + + if (INTEGER_CST_P (bound)) + { + if (wi::ltu_p (wi::to_wide (bound), 1) + || wi::gtu_p (wi::to_wide (bound), + GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))) + gfc_error ("% argument of %s intrinsic at %L is not a valid " + "dimension index", expr->value.function.isym->name, + &expr->where); + } + else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + { + bound = gfc_evaluate_now (bound, &se->pre); + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + bound, build_int_cst (TREE_TYPE (bound), 1)); + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + bound, tmp); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, cond, tmp); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + gfc_msg_fault); + } + + + /* Subtract 1 to get to zero based and add dimensions. */ + switch (arg->expr->rank) + { + case 0: + bound = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, bound, + gfc_index_one_node); + case 1: + break; + default: + bound = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, bound, + gfc_rank_cst[arg->expr->rank - 1]); + } + } + + resbound = gfc_conv_descriptor_lbound_get (desc, bound); + + /* Handle UCOBOUND with special handling of the last codimension. */ + if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) + { + /* Last codimension: For -fcoarray=single just return + the lcobound - otherwise add + ceiling (real (num_images ()) / real (size)) - 1 + = (num_images () + size - 1) / size - 1 + = (num_images - 1) / size(), + where size is the product of the extent of all but the last + codimension. */ + + if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1) + { + tree cosize; + + cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, + 2, integer_zero_node, + build_int_cst (integer_type_node, -1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, tmp), + build_int_cst (gfc_array_index_type, 1)); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, tmp, + fold_convert (gfc_array_index_type, cosize)); + resbound = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, resbound, tmp); + } + else if (flag_coarray != GFC_FCOARRAY_SINGLE) + { + /* ubound = lbound + num_images() - 1. */ + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, + 2, integer_zero_node, + build_int_cst (integer_type_node, -1)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, tmp), + build_int_cst (gfc_array_index_type, 1)); + resbound = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, resbound, tmp); + } + + if (corank > 1) + { + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + bound, + build_int_cst (TREE_TYPE (bound), + arg->expr->rank + corank - 1)); + + resbound2 = gfc_conv_descriptor_ubound_get (desc, bound); + se->expr = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + resbound, resbound2); + } + else + se->expr = resbound; + } + else + se->expr = resbound; + + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, se->expr); +} + + +static void +conv_intrinsic_stride (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *array_arg; + gfc_actual_arglist *dim_arg; + gfc_se argse; + tree desc, tmp; + + array_arg = expr->value.function.actual; + dim_arg = array_arg->next; + + gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE); + + gfc_init_se (&argse, NULL); + gfc_conv_expr_descriptor (&argse, array_arg->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = argse.expr; + + gcc_assert (dim_arg->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + argse.expr, gfc_index_one_node); + se->expr = gfc_conv_descriptor_stride_get (desc, tmp); +} + +static void +gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) +{ + tree arg, cabs; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + + switch (expr->value.function.actual->expr->ts.type) + { + case BT_INTEGER: + case BT_REAL: + se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg), + arg); + break; + + case BT_COMPLEX: + cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind); + se->expr = build_call_expr_loc (input_location, cabs, 1, arg); + break; + + default: + gcc_unreachable (); + } +} + + +/* Create a complex value from one or two real components. */ + +static void +gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) +{ + tree real; + tree imag; + tree type; + tree *args; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + real = convert (TREE_TYPE (type), args[0]); + if (both) + imag = convert (TREE_TYPE (type), args[1]); + else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE) + { + imag = fold_build1_loc (input_location, IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (args[0])), args[0]); + imag = convert (TREE_TYPE (type), imag); + } + else + imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); + + se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag); +} + + +/* Remainder function MOD(A, P) = A - INT(A / P) * P + MODULO(A, P) = A - FLOOR (A / P) * P + + The obvious algorithms above are numerically instable for large + arguments, hence these intrinsics are instead implemented via calls + to the fmod family of functions. It is the responsibility of the + user to ensure that the second argument is non-zero. */ + +static void +gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) +{ + tree type; + tree tmp; + tree test; + tree test2; + tree fmod; + tree zero; + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + + switch (expr->ts.type) + { + case BT_INTEGER: + /* Integer case is easy, we've got a builtin op. */ + type = TREE_TYPE (args[0]); + + if (modulo) + se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type, + args[0], args[1]); + else + se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type, + args[0], args[1]); + break; + + case BT_REAL: + fmod = NULL_TREE; + /* Check if we have a builtin fmod. */ + fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind); + + /* The builtin should always be available. */ + gcc_assert (fmod != NULL_TREE); + + tmp = build_addr (fmod); + se->expr = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (fmod)), + tmp, 2, args); + if (modulo == 0) + return; + + type = TREE_TYPE (args[0]); + + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + + /* Definition: + modulo = arg - floor (arg/arg2) * arg2 + + In order to calculate the result accurately, we use the fmod + function as follows. + + res = fmod (arg, arg2); + if (res) + { + if ((arg < 0) xor (arg2 < 0)) + res += arg2; + } + else + res = copysign (0., arg2); + + => As two nested ternary exprs: + + res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res) + : copysign (0., arg2); + + */ + + zero = gfc_build_const (type, integer_zero_node); + tmp = gfc_evaluate_now (se->expr, &se->pre); + if (!flag_signed_zeros) + { + test = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + args[0], zero); + test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + args[1], zero); + test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, + logical_type_node, test, test2); + test = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tmp, zero); + test = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, test, test2); + test = gfc_evaluate_now (test, &se->pre); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, + fold_build2_loc (input_location, + PLUS_EXPR, + type, tmp, args[1]), + tmp); + } + else + { + tree expr1, copysign, cscall; + copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, + expr->ts.kind); + test = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + args[0], zero); + test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + args[1], zero); + test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, + logical_type_node, test, test2); + expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2, + fold_build2_loc (input_location, + PLUS_EXPR, + type, tmp, args[1]), + tmp); + test = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tmp, zero); + cscall = build_call_expr_loc (input_location, copysign, 2, zero, + args[1]); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, + expr1, cscall); + } + return; + + default: + gcc_unreachable (); + } +} + +/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S)) + DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S) + where the right shifts are logical (i.e. 0's are shifted in). + Because SHIFT_EXPR's want shifts strictly smaller than the integral + type width, we have to special-case both S == 0 and S == BITSIZE(J): + DSHIFTL(I,J,0) = I + DSHIFTL(I,J,BITSIZE) = J + DSHIFTR(I,J,0) = J + DSHIFTR(I,J,BITSIZE) = I. */ + +static void +gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl) +{ + tree type, utype, stype, arg1, arg2, shift, res, left, right; + tree args[3], cond, tmp; + int bitsize; + + gfc_conv_intrinsic_function_args (se, expr, args, 3); + + gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1])); + type = TREE_TYPE (args[0]); + bitsize = TYPE_PRECISION (type); + utype = unsigned_type_for (type); + stype = TREE_TYPE (args[2]); + + arg1 = gfc_evaluate_now (args[0], &se->pre); + arg2 = gfc_evaluate_now (args[1], &se->pre); + shift = gfc_evaluate_now (args[2], &se->pre); + + /* The generic case. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, stype, + build_int_cst (stype, bitsize), shift); + left = fold_build2_loc (input_location, LSHIFT_EXPR, type, + arg1, dshiftl ? shift : tmp); + + right = fold_build2_loc (input_location, RSHIFT_EXPR, utype, + fold_convert (utype, arg2), dshiftl ? tmp : shift); + right = fold_convert (type, right); + + res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right); + + /* Special cases. */ + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift, + build_int_cst (stype, 0)); + res = fold_build3_loc (input_location, COND_EXPR, type, cond, + dshiftl ? arg1 : arg2, res); + + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift, + build_int_cst (stype, bitsize)); + res = fold_build3_loc (input_location, COND_EXPR, type, cond, + dshiftl ? arg2 : arg1, res); + + se->expr = res; +} + + +/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */ + +static void +gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) +{ + tree val; + tree tmp; + tree type; + tree zero; + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + type = TREE_TYPE (args[0]); + + val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]); + val = gfc_evaluate_now (val, &se->pre); + + zero = gfc_build_const (type, integer_zero_node); + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val); +} + + +/* SIGN(A, B) is absolute value of A times sign of B. + The real value versions use library functions to ensure the correct + handling of negative zero. Integer case implemented as: + SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp } + */ + +static void +gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) +{ + tree tmp; + tree type; + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + if (expr->ts.type == BT_REAL) + { + tree abs; + + tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); + abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); + + /* We explicitly have to ignore the minus sign. We do so by using + result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */ + if (!flag_sign_zero + && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1])))) + { + tree cond, zero; + zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node); + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + args[1], zero); + se->expr = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (args[0]), cond, + build_call_expr_loc (input_location, abs, 1, + args[0]), + build_call_expr_loc (input_location, tmp, 2, + args[0], args[1])); + } + else + se->expr = build_call_expr_loc (input_location, tmp, 2, + args[0], args[1]); + return; + } + + /* Having excluded floating point types, we know we are now dealing + with signed integer types. */ + type = TREE_TYPE (args[0]); + + /* Args[0] is used multiple times below. */ + args[0] = gfc_evaluate_now (args[0], &se->pre); + + /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if + the signs of A and B are the same, and of all ones if they differ. */ + tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]); + tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp, + build_int_cst (type, TYPE_PRECISION (type) - 1)); + tmp = gfc_evaluate_now (tmp, &se->pre); + + /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp] + is all ones (i.e. -1). */ + se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type, + fold_build2_loc (input_location, PLUS_EXPR, + type, args[0], tmp), tmp); +} + + +/* Test for the presence of an optional argument. */ + +static void +gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) +{ + gfc_expr *arg; + + arg = expr->value.function.actual->expr; + gcc_assert (arg->expr_type == EXPR_VARIABLE); + se->expr = gfc_conv_expr_present (arg->symtree->n.sym); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Calculate the double precision product of two single precision values. */ + +static void +gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) +{ + tree type; + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + + /* Convert the args to double precision before multiplying. */ + type = gfc_typenode_for_spec (&expr->ts); + args[0] = convert (type, args[0]); + args[1] = convert (type, args[1]); + se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0], + args[1]); +} + + +/* Return a length one character string containing an ascii character. */ + +static void +gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) +{ + tree arg[2]; + tree var; + tree type; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr); + gfc_conv_intrinsic_function_args (se, expr, arg, num_args); + + type = gfc_get_char_type (expr->ts.kind); + var = gfc_create_var (type, "char"); + + arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]); + gfc_add_modify (&se->pre, var, arg[0]); + se->expr = gfc_build_addr_expr (build_pointer_type (type), var); + se->string_length = build_int_cst (gfc_charlen_type_node, 1); +} + + +static void +gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree tmp; + tree cond; + tree fndecl; + tree *args; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr) + 2; + args = XALLOCAVEC (tree, num_args); + + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_charlen_type_node, "len"); + + gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); + args[0] = gfc_build_addr_expr (NULL_TREE, var); + args[1] = gfc_build_addr_expr (NULL_TREE, len); + + fndecl = build_addr (gfor_fndecl_ctime); + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)), + fndecl, num_args, args); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); + tmp = gfc_call_free (var); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +static void +gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree tmp; + tree cond; + tree fndecl; + tree *args; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr) + 2; + args = XALLOCAVEC (tree, num_args); + + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_charlen_type_node, "len"); + + gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); + args[0] = gfc_build_addr_expr (NULL_TREE, var); + args[1] = gfc_build_addr_expr (NULL_TREE, len); + + fndecl = build_addr (gfor_fndecl_fdate); + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)), + fndecl, num_args, args); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); + tmp = gfc_call_free (var); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +/* Generate a direct call to free() for the FREE subroutine. */ + +static tree +conv_intrinsic_free (gfc_code *code) +{ + stmtblock_t block; + gfc_se argse; + tree arg, call; + + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->ext.actual->expr); + arg = fold_convert (ptr_type_node, argse.expr); + + gfc_init_block (&block); + call = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, arg); + gfc_add_expr_to_block (&block, call); + return gfc_finish_block (&block); +} + + +/* Call the RANDOM_INIT library subroutine with a hidden argument for + handling seeding on coarray images. */ + +static tree +conv_intrinsic_random_init (gfc_code *code) +{ + stmtblock_t block; + gfc_se se; + tree arg1, arg2, tmp; + /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL. */ + tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB + ? logical_type_node + : gfc_get_logical_type (4); + + /* Make the function call. */ + gfc_init_block (&block); + gfc_init_se (&se, NULL); + + /* Convert REPEATABLE to the desired LOGICAL entity. */ + gfc_conv_expr (&se, code->ext.actual->expr); + gfc_add_block_to_block (&block, &se.pre); + arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block)); + gfc_add_block_to_block (&block, &se.post); + + /* Convert IMAGE_DISTINCT to the desired LOGICAL entity. */ + gfc_conv_expr (&se, code->ext.actual->next->expr); + gfc_add_block_to_block (&block, &se.pre); + arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block)); + gfc_add_block_to_block (&block, &se.post); + + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init, + 2, arg1, arg2); + } + else + { + /* The ABI for libgfortran needs to be maintained, so a hidden + argument must be include if code is compiled with -fcoarray=single + or without the option. Set to 0. */ + tree arg3 = build_int_cst (gfc_get_int_type (4), 0); + tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init, + 3, arg1, arg2, arg3); + } + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Call the SYSTEM_CLOCK library functions, handling the type and kind + conversions. */ + +static tree +conv_intrinsic_system_clock (gfc_code *code) +{ + stmtblock_t block; + gfc_se count_se, count_rate_se, count_max_se; + tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE; + tree tmp; + int least; + + gfc_expr *count = code->ext.actual->expr; + gfc_expr *count_rate = code->ext.actual->next->expr; + gfc_expr *count_max = code->ext.actual->next->next->expr; + + /* Evaluate our arguments. */ + if (count) + { + gfc_init_se (&count_se, NULL); + gfc_conv_expr (&count_se, count); + } + + if (count_rate) + { + gfc_init_se (&count_rate_se, NULL); + gfc_conv_expr (&count_rate_se, count_rate); + } + + if (count_max) + { + gfc_init_se (&count_max_se, NULL); + gfc_conv_expr (&count_max_se, count_max); + } + + /* Find the smallest kind found of the arguments. */ + least = 16; + least = (count && count->ts.kind < least) ? count->ts.kind : least; + least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind + : least; + least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind + : least; + + /* Prepare temporary variables. */ + + if (count) + { + if (least >= 8) + arg1 = gfc_create_var (gfc_get_int_type (8), "count"); + else if (least == 4) + arg1 = gfc_create_var (gfc_get_int_type (4), "count"); + else if (count->ts.kind == 1) + arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int, + count->ts.kind); + else + arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int, + count->ts.kind); + } + + if (count_rate) + { + if (least >= 8) + arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate"); + else if (least == 4) + arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate"); + else + arg2 = integer_zero_node; + } + + if (count_max) + { + if (least >= 8) + arg3 = gfc_create_var (gfc_get_int_type (8), "count_max"); + else if (least == 4) + arg3 = gfc_create_var (gfc_get_int_type (4), "count_max"); + else + arg3 = integer_zero_node; + } + + /* Make the function call. */ + gfc_init_block (&block); + +if (least <= 2) + { + if (least == 1) + { + arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) + : null_pointer_node; + arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) + : null_pointer_node; + arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) + : null_pointer_node; + } + + if (least == 2) + { + arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) + : null_pointer_node; + arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) + : null_pointer_node; + arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) + : null_pointer_node; + } + } +else + { + if (least == 4) + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_system_clock4, 3, + arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) + : null_pointer_node, + arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) + : null_pointer_node, + arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) + : null_pointer_node); + gfc_add_expr_to_block (&block, tmp); + } + /* Handle kind>=8, 10, or 16 arguments */ + if (least >= 8) + { + tmp = build_call_expr_loc (input_location, + gfor_fndecl_system_clock8, 3, + arg1 ? gfc_build_addr_expr (NULL_TREE, arg1) + : null_pointer_node, + arg2 ? gfc_build_addr_expr (NULL_TREE, arg2) + : null_pointer_node, + arg3 ? gfc_build_addr_expr (NULL_TREE, arg3) + : null_pointer_node); + gfc_add_expr_to_block (&block, tmp); + } + } + + /* And store values back if needed. */ + if (arg1 && arg1 != count_se.expr) + gfc_add_modify (&block, count_se.expr, + fold_convert (TREE_TYPE (count_se.expr), arg1)); + if (arg2 && arg2 != count_rate_se.expr) + gfc_add_modify (&block, count_rate_se.expr, + fold_convert (TREE_TYPE (count_rate_se.expr), arg2)); + if (arg3 && arg3 != count_max_se.expr) + gfc_add_modify (&block, count_max_se.expr, + fold_convert (TREE_TYPE (count_max_se.expr), arg3)); + + return gfc_finish_block (&block); +} + + +/* Return a character string containing the tty name. */ + +static void +gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree tmp; + tree cond; + tree fndecl; + tree *args; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr) + 2; + args = XALLOCAVEC (tree, num_args); + + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_charlen_type_node, "len"); + + gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); + args[0] = gfc_build_addr_expr (NULL_TREE, var); + args[1] = gfc_build_addr_expr (NULL_TREE, len); + + fndecl = build_addr (gfor_fndecl_ttynam); + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)), + fndecl, num_args, args); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); + tmp = gfc_call_free (var); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +/* Get the minimum/maximum value of all the parameters. + minmax (a1, a2, a3, ...) + { + mvar = a1; + mvar = COMP (mvar, a2) + mvar = COMP (mvar, a3) + ... + return mvar; + } + Where COMP is MIN/MAX_EXPR for integral types or when we don't + care about NaNs, or IFN_FMIN/MAX when the target has support for + fast NaN-honouring min/max. When neither holds expand a sequence + of explicit comparisons. */ + +/* TODO: Mismatching types can occur when specific names are used. + These should be handled during resolution. */ +static void +gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + tree tmp; + tree mvar; + tree val; + tree *args; + tree type; + tree argtype; + gfc_actual_arglist *argexpr; + unsigned int i, nargs; + + nargs = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, nargs); + + gfc_conv_intrinsic_function_args (se, expr, args, nargs); + type = gfc_typenode_for_spec (&expr->ts); + + /* Only evaluate the argument once. */ + if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0])) + args[0] = gfc_evaluate_now (args[0], &se->pre); + + /* Determine suitable type of temporary, as a GNU extension allows + different argument kinds. */ + argtype = TREE_TYPE (args[0]); + argexpr = expr->value.function.actual; + for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next) + { + tree tmptype = TREE_TYPE (args[i]); + if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype)) + argtype = tmptype; + } + mvar = gfc_create_var (argtype, "M"); + gfc_add_modify (&se->pre, mvar, convert (argtype, args[0])); + + argexpr = expr->value.function.actual; + for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next) + { + tree cond = NULL_TREE; + val = args[i]; + + /* Handle absent optional arguments by ignoring the comparison. */ + if (argexpr->expr->expr_type == EXPR_VARIABLE + && argexpr->expr->symtree->n.sym->attr.optional + && TREE_CODE (val) == INDIRECT_REF) + { + cond = fold_build2_loc (input_location, + NE_EXPR, logical_type_node, + TREE_OPERAND (val, 0), + build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); + } + else if (!VAR_P (val) && !TREE_CONSTANT (val)) + /* Only evaluate the argument once. */ + val = gfc_evaluate_now (val, &se->pre); + + tree calc; + /* For floating point types, the question is what MAX(a, NaN) or + MIN(a, NaN) should return (where "a" is a normal number). + There are valid usecase for returning either one, but the + Fortran standard doesn't specify which one should be chosen. + Also, there is no consensus among other tested compilers. In + short, it's a mess. So lets just do whatever is fastest. */ + tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR; + calc = fold_build2_loc (input_location, code, argtype, + convert (argtype, val), mvar); + tmp = build2_v (MODIFY_EXPR, mvar, calc); + + if (cond != NULL_TREE) + tmp = build3_v (COND_EXPR, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->pre, tmp); + } + se->expr = convert (type, mvar); +} + + +/* Generate library calls for MIN and MAX intrinsics for character + variables. */ +static void +gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) +{ + tree *args; + tree var, len, fndecl, tmp, cond, function; + unsigned int nargs; + + nargs = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, nargs + 4); + gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs); + + /* Create the result variables. */ + len = gfc_create_var (gfc_charlen_type_node, "len"); + args[0] = gfc_build_addr_expr (NULL_TREE, len); + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); + args[1] = gfc_build_addr_expr (ppvoid_type_node, var); + args[2] = build_int_cst (integer_type_node, op); + args[3] = build_int_cst (integer_type_node, nargs / 2); + + if (expr->ts.kind == 1) + function = gfor_fndecl_string_minmax; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_minmax_char4; + else + gcc_unreachable (); + + /* Make the function call. */ + fndecl = build_addr (function); + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, + nargs + 4, args); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); + tmp = gfc_call_free (var); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +/* Create a symbol node for this intrinsic. The symbol from the frontend + has the generic name. */ + +static gfc_symbol * +gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional) +{ + gfc_symbol *sym; + + /* TODO: Add symbols for intrinsic function to the global namespace. */ + gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); + sym = gfc_new_symbol (expr->value.function.name, NULL); + + sym->ts = expr->ts; + sym->attr.external = 1; + sym->attr.function = 1; + sym->attr.always_explicit = 1; + sym->attr.proc = PROC_INTRINSIC; + sym->attr.flavor = FL_PROCEDURE; + sym->result = sym; + if (expr->rank > 0) + { + sym->attr.dimension = 1; + sym->as = gfc_get_array_spec (); + sym->as->type = AS_ASSUMED_SHAPE; + sym->as->rank = expr->rank; + } + + gfc_copy_formal_args_intr (sym, expr->value.function.isym, + ignore_optional ? expr->value.function.actual + : NULL); + + return sym; +} + +/* Remove empty actual arguments. */ + +static void +remove_empty_actual_arguments (gfc_actual_arglist **ap) +{ + while (*ap) + { + if ((*ap)->expr == NULL) + { + gfc_actual_arglist *r = *ap; + *ap = r->next; + r->next = NULL; + gfc_free_actual_arglist (r); + } + else + ap = &((*ap)->next); + } +} + +#define MAX_SPEC_ARG 12 + +/* Make up an fn spec that's right for intrinsic functions that we + want to call. */ + +static char * +intrinsic_fnspec (gfc_expr *expr) +{ + static char fnspec_buf[MAX_SPEC_ARG*2+1]; + char *fp; + int i; + int num_char_args; + +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) + + /* Set the fndecl. */ + fp = fnspec_buf; + /* Function return value. FIXME: Check if the second letter could + be something other than a space, for further optimization. */ + ADD_CHAR ('.'); + if (expr->rank == 0) + { + if (expr->ts.type == BT_CHARACTER) + { + ADD_CHAR ('w'); /* Address of character. */ + ADD_CHAR ('.'); /* Length of character. */ + } + } + else + ADD_CHAR ('w'); /* Return value is a descriptor. */ + + num_char_args = 0; + for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) + { + if (a->expr == NULL) + continue; + + if (a->name && strcmp (a->name,"%VAL") == 0) + ADD_CHAR ('.'); + else + { + if (a->expr->rank > 0) + ADD_CHAR ('r'); + else + ADD_CHAR ('R'); + } + num_char_args += a->expr->ts.type == BT_CHARACTER; + gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2); + } + + for (i = 0; i < num_char_args; i++) + ADD_CHAR ('.'); + + *fp = '\0'; + return fnspec_buf; +} + +#undef MAX_SPEC_ARG +#undef ADD_CHAR + +/* Generate the right symbol for the specific intrinsic function and + modify the expr accordingly. This assumes that absent optional + arguments should be removed. */ + +gfc_symbol * +specific_intrinsic_symbol (gfc_expr *expr) +{ + gfc_symbol *sym; + + sym = gfc_find_intrinsic_symbol (expr); + if (sym == NULL) + { + sym = gfc_get_intrinsic_function_symbol (expr); + sym->ts = expr->ts; + if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl) + sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); + + gfc_copy_formal_args_intr (sym, expr->value.function.isym, + expr->value.function.actual, true); + sym->backend_decl + = gfc_get_extern_function_decl (sym, expr->value.function.actual, + intrinsic_fnspec (expr)); + } + + remove_empty_actual_arguments (&(expr->value.function.actual)); + + return sym; +} + +/* Generate a call to an external intrinsic function. FIXME: So far, + this only works for functions which are called with well-defined + types; CSHIFT and friends will come later. */ + +static void +gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) +{ + gfc_symbol *sym; + vec *append_args; + bool specific_symbol; + + gcc_assert (!se->ss || se->ss->info->expr == expr); + + if (se->ss) + gcc_assert (expr->rank > 0); + else + gcc_assert (expr->rank == 0); + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_ANY: + case GFC_ISYM_ALL: + case GFC_ISYM_FINDLOC: + case GFC_ISYM_MAXLOC: + case GFC_ISYM_MINLOC: + case GFC_ISYM_MAXVAL: + case GFC_ISYM_MINVAL: + case GFC_ISYM_NORM2: + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: + specific_symbol = true; + break; + default: + specific_symbol = false; + } + + if (specific_symbol) + { + /* Need to copy here because specific_intrinsic_symbol modifies + expr to omit the absent optional arguments. */ + expr = gfc_copy_expr (expr); + sym = specific_intrinsic_symbol (expr); + } + else + sym = gfc_get_symbol_for_expr (expr, se->ignore_optional); + + /* Calls to libgfortran_matmul need to be appended special arguments, + to be able to call the BLAS ?gemm functions if required and possible. */ + append_args = NULL; + if (expr->value.function.isym->id == GFC_ISYM_MATMUL + && !expr->external_blas + && sym->ts.type != BT_LOGICAL) + { + tree cint = gfc_get_int_type (gfc_c_int_kind); + + if (flag_external_blas + && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX) + && (sym->ts.kind == 4 || sym->ts.kind == 8)) + { + tree gemm_fndecl; + + if (sym->ts.type == BT_REAL) + { + if (sym->ts.kind == 4) + gemm_fndecl = gfor_fndecl_sgemm; + else + gemm_fndecl = gfor_fndecl_dgemm; + } + else + { + if (sym->ts.kind == 4) + gemm_fndecl = gfor_fndecl_cgemm; + else + gemm_fndecl = gfor_fndecl_zgemm; + } + + vec_alloc (append_args, 3); + append_args->quick_push (build_int_cst (cint, 1)); + append_args->quick_push (build_int_cst (cint, + flag_blas_matmul_limit)); + append_args->quick_push (gfc_build_addr_expr (NULL_TREE, + gemm_fndecl)); + } + else + { + vec_alloc (append_args, 3); + append_args->quick_push (build_int_cst (cint, 0)); + append_args->quick_push (build_int_cst (cint, 0)); + append_args->quick_push (null_pointer_node); + } + } + + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, + append_args); + + if (specific_symbol) + gfc_free_expr (expr); + else + gfc_free_symbol (sym); +} + +/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR. + Implemented as + any(a) + { + forall (i=...) + if (a[i] != 0) + return 1 + end forall + return 0 + } + all(a) + { + forall (i=...) + if (a[i] == 0) + return 0 + end forall + return 1 + } + */ +static void +gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + tree resvar; + stmtblock_t block; + stmtblock_t body; + tree type; + tree tmp; + tree found; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_se arrayse; + tree exit_label; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + actual = expr->value.function.actual; + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + resvar = gfc_create_var (type, "test"); + if (op == EQ_EXPR) + tmp = convert (type, boolean_true_node); + else + tmp = convert (type, boolean_false_node); + gfc_add_modify (&se->pre, resvar, tmp); + + /* Walk the arguments. */ + arrayss = gfc_walk_expr (actual->expr); + gcc_assert (arrayss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + gfc_mark_ss_chain_used (arrayss, 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If the condition matches then set the return value. */ + gfc_start_block (&block); + if (op == EQ_EXPR) + tmp = convert (type, boolean_false_node); + else + tmp = convert (type, boolean_true_node); + gfc_add_modify (&block, resvar, tmp); + + /* And break out of the loop. */ + tmp = build1_v (GOTO_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + found = gfc_finish_block (&block); + + /* Check this element. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, actual->expr); + + gfc_add_block_to_block (&body, &arrayse.pre); + tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, + build_int_cst (TREE_TYPE (arrayse.expr), 0)); + tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + gfc_add_block_to_block (&body, &arrayse.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&loop.pre, tmp); + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + + +/* Generate the constant 180 / pi, which is used in the conversion + of acosd(), asind(), atand(), atan2d(). */ + +static tree +rad2deg (int kind) +{ + tree retval; + mpfr_t pi, t0; + + gfc_set_model_kind (kind); + mpfr_init (pi); + mpfr_init (t0); + mpfr_set_si (t0, 180, GFC_RND_MODE); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_div (t0, t0, pi, GFC_RND_MODE); + retval = gfc_conv_mpfr_to_tree (t0, kind, 0); + mpfr_clear (t0); + mpfr_clear (pi); + return retval; +} + + +static gfc_intrinsic_map_t * +gfc_lookup_intrinsic (gfc_isym_id id) +{ + gfc_intrinsic_map_t *m = gfc_intrinsic_map; + for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++) + if (id == m->id) + break; + gcc_assert (id == m->id); + return m; +} + + +/* ACOSD(x) is translated into ACOS(x) * 180 / pi. + ASIND(x) is translated into ASIN(x) * 180 / pi. + ATAND(x) is translated into ATAN(x) * 180 / pi. */ + +static void +gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id) +{ + tree arg; + tree atrigd; + tree type; + gfc_intrinsic_map_t *m; + + type = gfc_typenode_for_spec (&expr->ts); + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + + switch (id) + { + case GFC_ISYM_ACOSD: + m = gfc_lookup_intrinsic (GFC_ISYM_ACOS); + break; + case GFC_ISYM_ASIND: + m = gfc_lookup_intrinsic (GFC_ISYM_ASIN); + break; + case GFC_ISYM_ATAND: + m = gfc_lookup_intrinsic (GFC_ISYM_ATAN); + break; + default: + gcc_unreachable (); + } + atrigd = gfc_get_intrinsic_lib_fndecl (m, expr); + atrigd = build_call_expr_loc (input_location, atrigd, 1, arg); + + se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd, + fold_convert (type, rad2deg (expr->ts.kind))); +} + + +/* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and + COS(X) / SIN(X) for COMPLEX argument. */ + +static void +gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr) +{ + gfc_intrinsic_map_t *m; + tree arg; + tree type; + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + + if (expr->ts.type == BT_REAL) + { + tree tan; + tree tmp; + mpfr_t pio2; + + /* Create pi/2. */ + gfc_set_model_kind (expr->ts.kind); + mpfr_init (pio2); + mpfr_const_pi (pio2, GFC_RND_MODE); + mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE); + tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0); + mpfr_clear (pio2); + + /* Find tan builtin function. */ + m = gfc_lookup_intrinsic (GFC_ISYM_TAN); + tan = gfc_get_intrinsic_lib_fndecl (m, expr); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp); + tan = build_call_expr_loc (input_location, tan, 1, tmp); + se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan); + } + else + { + tree sin; + tree cos; + + /* Find cos builtin function. */ + m = gfc_lookup_intrinsic (GFC_ISYM_COS); + cos = gfc_get_intrinsic_lib_fndecl (m, expr); + cos = build_call_expr_loc (input_location, cos, 1, arg); + + /* Find sin builtin function. */ + m = gfc_lookup_intrinsic (GFC_ISYM_SIN); + sin = gfc_get_intrinsic_lib_fndecl (m, expr); + sin = build_call_expr_loc (input_location, sin, 1, arg); + + /* Divide cos by sin. */ + se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin); + } +} + + +/* COTAND(X) is translated into -TAND(X+90) for REAL argument. */ + +static void +gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr) +{ + tree arg; + tree type; + tree ninety_tree; + mpfr_t ninety; + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + + gfc_set_model_kind (expr->ts.kind); + + /* Build the tree for x + 90. */ + mpfr_init_set_ui (ninety, 90, GFC_RND_MODE); + ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0); + arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree); + mpfr_clear (ninety); + + /* Find tand. */ + gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND); + tree tand = gfc_get_intrinsic_lib_fndecl (m, expr); + tand = build_call_expr_loc (input_location, tand, 1, arg); + + se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand); +} + + +/* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */ + +static void +gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr) +{ + tree args[2]; + tree atan2d; + tree type; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + type = TREE_TYPE (args[0]); + + gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2); + atan2d = gfc_get_intrinsic_lib_fndecl (m, expr); + atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]); + + se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d, + rad2deg (expr->ts.kind)); +} + + +/* COUNT(A) = Number of true elements in A. */ +static void +gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) +{ + tree resvar; + tree type; + stmtblock_t body; + tree tmp; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_se arrayse; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + actual = expr->value.function.actual; + + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + resvar = gfc_create_var (type, "count"); + gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0)); + + /* Walk the arguments. */ + arrayss = gfc_walk_expr (actual->expr); + gcc_assert (arrayss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + gfc_mark_ss_chain_used (arrayss, 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar), + resvar, build_int_cst (TREE_TYPE (resvar), 1)); + tmp = build2_v (MODIFY_EXPR, resvar, tmp); + + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, actual->expr); + tmp = build3_v (COND_EXPR, arrayse.expr, tmp, + build_empty_stmt (input_location)); + + gfc_add_block_to_block (&body, &arrayse.pre); + gfc_add_expr_to_block (&body, tmp); + gfc_add_block_to_block (&body, &arrayse.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + + +/* Update given gfc_se to have ss component pointing to the nested gfc_ss + struct and return the corresponding loopinfo. */ + +static gfc_loopinfo * +enter_nested_loop (gfc_se *se) +{ + se->ss = se->ss->nested_ss; + gcc_assert (se->ss == se->ss->loop->ss); + + return se->ss->loop; +} + +/* Build the condition for a mask, which may be optional. */ + +static tree +conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr, + bool optional_mask) +{ + tree present; + tree type; + + if (optional_mask) + { + type = TREE_TYPE (maskse->expr); + present = gfc_conv_expr_present (maskexpr->symtree->n.sym); + present = convert (type, present); + present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type, + present); + return fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + type, present, maskse->expr); + } + else + return maskse->expr; +} + +/* Inline implementation of the sum and product intrinsics. */ +static void +gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, + bool norm2) +{ + tree resvar; + tree scale = NULL_TREE; + tree type; + stmtblock_t body; + stmtblock_t block; + tree tmp; + gfc_loopinfo loop, *ploop; + gfc_actual_arglist *arg_array, *arg_mask; + gfc_ss *arrayss = NULL; + gfc_ss *maskss = NULL; + gfc_se arrayse; + gfc_se maskse; + gfc_se *parent_se; + gfc_expr *arrayexpr; + gfc_expr *maskexpr; + bool optional_mask; + + if (expr->rank > 0) + { + gcc_assert (gfc_inline_intrinsic_function_p (expr)); + parent_se = se; + } + else + parent_se = NULL; + + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + resvar = gfc_create_var (type, "val"); + if (norm2) + { + /* result = 0.0; + scale = 1.0. */ + scale = gfc_create_var (type, "scale"); + gfc_add_modify (&se->pre, scale, + gfc_build_const (type, integer_one_node)); + tmp = gfc_build_const (type, integer_zero_node); + } + else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR) + tmp = gfc_build_const (type, integer_zero_node); + else if (op == NE_EXPR) + /* PARITY. */ + tmp = convert (type, boolean_false_node); + else if (op == BIT_AND_EXPR) + tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR, + type, integer_one_node)); + else + tmp = gfc_build_const (type, integer_one_node); + + gfc_add_modify (&se->pre, resvar, tmp); + + arg_array = expr->value.function.actual; + + arrayexpr = arg_array->expr; + + if (op == NE_EXPR || norm2) + { + /* PARITY and NORM2. */ + maskexpr = NULL; + optional_mask = false; + } + else + { + arg_mask = arg_array->next->next; + gcc_assert (arg_mask != NULL); + maskexpr = arg_mask->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; + } + + if (expr->rank == 0) + { + /* Walk the arguments. */ + arrayss = gfc_walk_expr (arrayexpr); + gcc_assert (arrayss != gfc_ss_terminator); + + if (maskexpr && maskexpr->rank > 0) + { + maskss = gfc_walk_expr (maskexpr); + gcc_assert (maskss != gfc_ss_terminator); + } + else + maskss = NULL; + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + + /* We add the mask first because the number of iterations is + taken from the last ss, and this breaks if an absent + optional argument is used for mask. */ + + if (maskexpr && maskexpr->rank > 0) + gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + if (maskexpr && maskexpr->rank > 0) + gfc_mark_ss_chain_used (maskss, 1); + gfc_mark_ss_chain_used (arrayss, 1); + + ploop = &loop; + } + else + /* All the work has been done in the parent loops. */ + ploop = enter_nested_loop (se); + + gcc_assert (ploop); + + /* Generate the loop body. */ + gfc_start_scalarized_body (ploop, &body); + + /* If we have a mask, only add this element if the mask is set. */ + if (maskexpr && maskexpr->rank > 0) + { + gfc_init_se (&maskse, parent_se); + gfc_copy_loopinfo_to_se (&maskse, ploop); + if (expr->rank == 0) + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Do the actual summation/product. */ + gfc_init_se (&arrayse, parent_se); + gfc_copy_loopinfo_to_se (&arrayse, ploop); + if (expr->rank == 0) + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + if (norm2) + { + /* if (x (i) != 0.0) + { + absX = abs(x(i)) + if (absX > scale) + { + val = scale/absX; + result = 1.0 + result * val * val; + scale = absX; + } + else + { + val = absX/scale; + result += val * val; + } + } */ + tree res1, res2, cond, absX, val; + stmtblock_t ifblock1, ifblock2, ifblock3; + + gfc_init_block (&ifblock1); + + absX = gfc_create_var (type, "absX"); + gfc_add_modify (&ifblock1, absX, + fold_build1_loc (input_location, ABS_EXPR, type, + arrayse.expr)); + val = gfc_create_var (type, "val"); + gfc_add_expr_to_block (&ifblock1, val); + + gfc_init_block (&ifblock2); + gfc_add_modify (&ifblock2, val, + fold_build2_loc (input_location, RDIV_EXPR, type, scale, + absX)); + res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); + res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1); + res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1, + gfc_build_const (type, integer_one_node)); + gfc_add_modify (&ifblock2, resvar, res1); + gfc_add_modify (&ifblock2, scale, absX); + res1 = gfc_finish_block (&ifblock2); + + gfc_init_block (&ifblock3); + gfc_add_modify (&ifblock3, val, + fold_build2_loc (input_location, RDIV_EXPR, type, absX, + scale)); + res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val); + res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2); + gfc_add_modify (&ifblock3, resvar, res2); + res2 = gfc_finish_block (&ifblock3); + + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + absX, scale); + tmp = build3_v (COND_EXPR, cond, res1, res2); + gfc_add_expr_to_block (&ifblock1, tmp); + tmp = gfc_finish_block (&ifblock1); + + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + arrayse.expr, + gfc_build_const (type, integer_zero_node)); + + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr); + gfc_add_modify (&block, resvar, tmp); + } + + gfc_add_block_to_block (&block, &arrayse.post); + + if (maskexpr && maskexpr->rank > 0) + { + /* We enclose the above in if (mask) {...} . If the mask is an + optional argument, generate + IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */ + tree ifmask; + tmp = gfc_finish_block (&block); + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + gfc_trans_scalarizing_loops (ploop, &body); + + /* For a scalar mask, enclose the loop in an if statement. */ + if (maskexpr && maskexpr->rank == 0) + { + gfc_init_block (&block); + gfc_add_block_to_block (&block, &ploop->pre); + gfc_add_block_to_block (&block, &ploop->post); + tmp = gfc_finish_block (&block); + + if (expr->rank > 0) + { + tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp, + build_empty_stmt (input_location)); + gfc_advance_se_ss_chain (se); + } + else + { + tree ifmask; + + gcc_assert (expr->rank == 0); + gfc_init_se (&maskse, NULL); + gfc_conv_expr_val (&maskse, maskexpr); + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&se->pre, &block); + gcc_assert (se->post.head == NULL); + } + else + { + gfc_add_block_to_block (&se->pre, &ploop->pre); + gfc_add_block_to_block (&se->pre, &ploop->post); + } + + if (expr->rank == 0) + gfc_cleanup_loop (ploop); + + if (norm2) + { + /* result = scale * sqrt(result). */ + tree sqrt; + sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind); + resvar = build_call_expr_loc (input_location, + sqrt, 1, resvar); + resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar); + } + + se->expr = resvar; +} + + +/* Inline implementation of the dot_product intrinsic. This function + is based on gfc_conv_intrinsic_arith (the previous function). */ +static void +gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) +{ + tree resvar; + tree type; + stmtblock_t body; + stmtblock_t block; + tree tmp; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss1, *arrayss2; + gfc_se arrayse1, arrayse2; + gfc_expr *arrayexpr1, *arrayexpr2; + + type = gfc_typenode_for_spec (&expr->ts); + + /* Initialize the result. */ + resvar = gfc_create_var (type, "val"); + if (expr->ts.type == BT_LOGICAL) + tmp = build_int_cst (type, 0); + else + tmp = gfc_build_const (type, integer_zero_node); + + gfc_add_modify (&se->pre, resvar, tmp); + + /* Walk argument #1. */ + actual = expr->value.function.actual; + arrayexpr1 = actual->expr; + arrayss1 = gfc_walk_expr (arrayexpr1); + gcc_assert (arrayss1 != gfc_ss_terminator); + + /* Walk argument #2. */ + actual = actual->next; + arrayexpr2 = actual->expr; + arrayss2 = gfc_walk_expr (arrayexpr2); + gcc_assert (arrayss2 != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss1); + gfc_add_ss_to_loop (&loop, arrayss2); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + gfc_mark_ss_chain_used (arrayss1, 1); + gfc_mark_ss_chain_used (arrayss2, 1); + + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + gfc_init_block (&block); + + /* Make the tree expression for [conjg(]array1[)]. */ + gfc_init_se (&arrayse1, NULL); + gfc_copy_loopinfo_to_se (&arrayse1, &loop); + arrayse1.ss = arrayss1; + gfc_conv_expr_val (&arrayse1, arrayexpr1); + if (expr->ts.type == BT_COMPLEX) + arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type, + arrayse1.expr); + gfc_add_block_to_block (&block, &arrayse1.pre); + + /* Make the tree expression for array2. */ + gfc_init_se (&arrayse2, NULL); + gfc_copy_loopinfo_to_se (&arrayse2, &loop); + arrayse2.ss = arrayss2; + gfc_conv_expr_val (&arrayse2, arrayexpr2); + gfc_add_block_to_block (&block, &arrayse2.pre); + + /* Do the actual product and sum. */ + if (expr->ts.type == BT_LOGICAL) + { + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type, + arrayse1.expr, arrayse2.expr); + tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp); + } + else + { + tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr, + arrayse2.expr); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp); + } + gfc_add_modify (&block, resvar, tmp); + + /* Finish up the loop block and the loop. */ + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + + +/* Remove unneeded kind= argument from actual argument list when the + result conversion is dealt with in a different place. */ + +static void +strip_kind_from_actual (gfc_actual_arglist * actual) +{ + for (gfc_actual_arglist *a = actual; a; a = a->next) + { + if (a && a->name && strcmp (a->name, "kind") == 0) + { + gfc_free_expr (a->expr); + a->expr = NULL; + } + } +} + +/* Emit code for minloc or maxloc intrinsic. There are many different cases + we need to handle. For performance reasons we sometimes create two + loops instead of one, where the second one is much simpler. + Examples for minloc intrinsic: + 1) Result is an array, a call is generated + 2) Array mask is used and NaNs need to be supported: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { + if (pos == 0) pos = S + (1 - from); + if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } + } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 3) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } + S++; + } + if (from <= to) pos = 1; + goto lab2; + lab1:; + while (S <= to) { + if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 4) NaNs aren't supported, array mask is used: + limit = infinities_supported ? Infinity : huge (limit); + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 5) Same without array mask: + limit = infinities_supported ? Infinity : huge (limit); + pos = (from <= to) ? 1 : 0; + S = from; + while (S <= to) { + if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + For 3) and 5), if mask is scalar, this all goes into a conditional, + setting pos = 0; in the else branch. + + Since we now also support the BACK argument, instead of using + if (a[S] < limit), we now use + + if (back) + cond = a[S] <= limit; + else + cond = a[S] < limit; + if (cond) { + .... + + The optimizer is smart enough to move the condition out of the loop. + The are now marked as unlikely to for further speedup. */ + +static void +gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + stmtblock_t body; + stmtblock_t block; + stmtblock_t ifblock; + stmtblock_t elseblock; + tree limit; + tree type; + tree tmp; + tree cond; + tree elsetmp; + tree ifbody; + tree offset; + tree nonempty; + tree lab1, lab2; + tree b_if, b_else; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_ss *maskss; + gfc_se arrayse; + gfc_se maskse; + gfc_expr *arrayexpr; + gfc_expr *maskexpr; + gfc_expr *backexpr; + gfc_se backse; + tree pos; + int n; + bool optional_mask; + + actual = expr->value.function.actual; + + /* The last argument, BACK, is passed by value. Ensure that + by setting its name to %VAL. */ + for (gfc_actual_arglist *a = actual; a; a = a->next) + { + if (a->next == NULL) + a->name = "%VAL"; + } + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + arrayexpr = actual->expr; + + /* Special case for character maxloc. Remove unneeded actual + arguments, then call a library function. */ + + if (arrayexpr->ts.type == BT_CHARACTER) + { + gfc_actual_arglist *a; + a = actual; + strip_kind_from_actual (a); + while (a) + { + if (a->name && strcmp (a->name, "dim") == 0) + { + gfc_free_expr (a->expr); + a->expr = NULL; + } + a = a->next; + } + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + /* Initialize the result. */ + pos = gfc_create_var (gfc_array_index_type, "pos"); + offset = gfc_create_var (gfc_array_index_type, "offset"); + type = gfc_typenode_for_spec (&expr->ts); + + /* Walk the arguments. */ + arrayss = gfc_walk_expr (arrayexpr); + gcc_assert (arrayss != gfc_ss_terminator); + + actual = actual->next->next; + gcc_assert (actual); + maskexpr = actual->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; + backexpr = actual->next->next->expr; + nonempty = NULL; + if (maskexpr && maskexpr->rank != 0) + { + maskss = gfc_walk_expr (maskexpr); + gcc_assert (maskss != gfc_ss_terminator); + } + else + { + mpz_t asize; + if (gfc_array_size (arrayexpr, &asize)) + { + nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); + mpz_clear (asize); + nonempty = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, nonempty, + gfc_index_zero_node); + } + maskss = NULL; + } + + limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); + switch (arrayexpr->ts.type) + { + case BT_REAL: + tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind); + break; + + case BT_INTEGER: + n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); + tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, + arrayexpr->ts.kind); + break; + + default: + gcc_unreachable (); + } + + /* We start with the most negative possible value for MAXLOC, and the most + positive possible value for MINLOC. The most negative possible value is + -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive + possible value is HUGE in both cases. */ + if (op == GT_EXPR) + tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); + if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER) + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp, + build_int_cst (TREE_TYPE (tmp), 1)); + + gfc_add_modify (&se->pre, limit, tmp); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + + /* We add the mask first because the number of iterations is taken + from the last ss, and this breaks if an absent optional argument + is used for mask. */ + + if (maskss) + gfc_add_ss_to_loop (&loop, maskss); + + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + + /* The code generated can have more than one loop in sequence (see the + comment at the function header). This doesn't work well with the + scalarizer, which changes arrays' offset when the scalarization loops + are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc + are currently inlined in the scalar case only (for which loop is of rank + one). As there is no dependency to care about in that case, there is no + temporary, so that we can use the scalarizer temporary code to handle + multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used + with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later + to restore offset. + TODO: this prevents inlining of rank > 0 minmaxloc calls, so this + should eventually go away. We could either create two loops properly, + or find another way to save/restore the array offsets between the two + loops (without conflicting with temporary management), or use a single + loop minmaxloc implementation. See PR 31067. */ + loop.temp_dim = loop.dimen; + gfc_conv_loop_setup (&loop, &expr->where); + + gcc_assert (loop.dimen == 1); + if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) + nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + loop.from[0], loop.to[0]); + + lab1 = NULL; + lab2 = NULL; + /* Initialize the position to zero, following Fortran 2003. We are free + to do this because Fortran 95 allows the result of an entirely false + mask to be processor dependent. If we know at compile time the array + is non-empty and no MASK is used, we can initialize to 1 to simplify + the inner loop. */ + if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit))) + gfc_add_modify (&loop.pre, pos, + fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, + nonempty, gfc_index_one_node, + gfc_index_zero_node)); + else + { + gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); + lab1 = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab1) = 1; + lab2 = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab2) = 1; + } + + /* An offset must be added to the loop + counter to obtain the required position. */ + gcc_assert (loop.from[0]); + + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[0]); + gfc_add_modify (&loop.pre, offset, tmp); + + gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1); + if (maskss) + gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If we have a mask, only check this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + gfc_init_se (&backse, NULL); + gfc_conv_expr_val (&backse, backexpr); + gfc_add_block_to_block (&block, &backse.pre); + + /* We do the following if this is a more extreme value. */ + gfc_start_block (&ifblock); + + /* Assign the value to the limit... */ + gfc_add_modify (&ifblock, limit, arrayse.expr); + + if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit))) + { + stmtblock_t ifblock2; + tree ifbody2; + + gfc_start_block (&ifblock2); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); + gfc_add_modify (&ifblock2, pos, tmp); + ifbody2 = gfc_finish_block (&ifblock2); + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos, + gfc_index_zero_node); + tmp = build3_v (COND_EXPR, cond, ifbody2, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); + gfc_add_modify (&ifblock, pos, tmp); + + if (lab1) + gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)); + + ifbody = gfc_finish_block (&ifblock); + + if (!lab1 || HONOR_NANS (DECL_MODE (limit))) + { + if (lab1) + cond = fold_build2_loc (input_location, + op == GT_EXPR ? GE_EXPR : LE_EXPR, + logical_type_node, arrayse.expr, limit); + else + { + tree ifbody2, elsebody2; + + /* We switch to > or >= depending on the value of the BACK argument. */ + cond = gfc_create_var (logical_type_node, "cond"); + + gfc_start_block (&ifblock); + b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, + logical_type_node, arrayse.expr, limit); + + gfc_add_modify (&ifblock, cond, b_if); + ifbody2 = gfc_finish_block (&ifblock); + + gfc_start_block (&elseblock); + b_else = fold_build2_loc (input_location, op, logical_type_node, + arrayse.expr, limit); + + gfc_add_modify (&elseblock, cond, b_else); + elsebody2 = gfc_finish_block (&elseblock); + + tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node, + backse.expr, ifbody2, elsebody2); + + gfc_add_expr_to_block (&block, tmp); + } + + cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT); + ifbody = build3_v (COND_EXPR, cond, ifbody, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, ifbody); + + if (maskss) + { + /* We enclose the above in if (mask) {...}. If the mask is an + optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ + + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = gfc_finish_block (&block); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + if (lab1) + { + gfc_trans_scalarized_loop_boundary (&loop, &body); + + if (HONOR_NANS (DECL_MODE (limit))) + { + if (nonempty != NULL) + { + ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node); + tmp = build3_v (COND_EXPR, nonempty, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&loop.code[0], tmp); + } + } + + gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2)); + gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1)); + + /* If we have a mask, only check this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* We do the following if this is a more extreme value. */ + gfc_start_block (&ifblock); + + /* Assign the value to the limit... */ + gfc_add_modify (&ifblock, limit, arrayse.expr); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); + gfc_add_modify (&ifblock, pos, tmp); + + ifbody = gfc_finish_block (&ifblock); + + /* We switch to > or >= depending on the value of the BACK argument. */ + { + tree ifbody2, elsebody2; + + cond = gfc_create_var (logical_type_node, "cond"); + + gfc_start_block (&ifblock); + b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, + logical_type_node, arrayse.expr, limit); + + gfc_add_modify (&ifblock, cond, b_if); + ifbody2 = gfc_finish_block (&ifblock); + + gfc_start_block (&elseblock); + b_else = fold_build2_loc (input_location, op, logical_type_node, + arrayse.expr, limit); + + gfc_add_modify (&elseblock, cond, b_else); + elsebody2 = gfc_finish_block (&elseblock); + + tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node, + backse.expr, ifbody2, elsebody2); + } + + gfc_add_expr_to_block (&block, tmp); + cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT); + tmp = build3_v (COND_EXPR, cond, ifbody, + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&block, tmp); + + if (maskss) + { + /* We enclose the above in if (mask) {...}. If the mask is + an optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)).*/ + + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = gfc_finish_block (&block); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + /* Avoid initializing loopvar[0] again, it should be left where + it finished by the first loop. */ + loop.from[0] = loop.loopvar[0]; + } + + gfc_trans_scalarizing_loops (&loop, &body); + + if (lab2) + gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2)); + + /* For a scalar mask, enclose the loop in an if statement. */ + if (maskexpr && maskss == NULL) + { + tree ifmask; + + gfc_init_se (&maskse, NULL); + gfc_conv_expr_val (&maskse, maskexpr); + gfc_init_block (&block); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + tmp = gfc_finish_block (&block); + + /* For the else part of the scalar mask, just initialize + the pos variable the same way as above. */ + + gfc_init_block (&elseblock); + gfc_add_modify (&elseblock, pos, gfc_index_zero_node); + elsetmp = gfc_finish_block (&elseblock); + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&se->pre, &block); + } + else + { + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + } + gfc_cleanup_loop (&loop); + + se->expr = convert (type, pos); +} + +/* Emit code for findloc. */ + +static void +gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) +{ + gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg, + *kind_arg, *back_arg; + gfc_expr *value_expr; + int ikind; + tree resvar; + stmtblock_t block; + stmtblock_t body; + stmtblock_t loopblock; + tree type; + tree tmp; + tree found; + tree forward_branch = NULL_TREE; + tree back_branch; + gfc_loopinfo loop; + gfc_ss *arrayss; + gfc_ss *maskss; + gfc_se arrayse; + gfc_se valuese; + gfc_se maskse; + gfc_se backse; + tree exit_label; + gfc_expr *maskexpr; + tree offset; + int i; + bool optional_mask; + + array_arg = expr->value.function.actual; + value_arg = array_arg->next; + dim_arg = value_arg->next; + mask_arg = dim_arg->next; + kind_arg = mask_arg->next; + back_arg = kind_arg->next; + + /* Remove kind and set ikind. */ + if (kind_arg->expr) + { + ikind = mpz_get_si (kind_arg->expr->value.integer); + gfc_free_expr (kind_arg->expr); + kind_arg->expr = NULL; + } + else + ikind = gfc_default_integer_kind; + + value_expr = value_arg->expr; + + /* Unless it's a string, pass VALUE by value. */ + if (value_expr->ts.type != BT_CHARACTER) + value_arg->name = "%VAL"; + + /* Pass BACK argument by value. */ + back_arg->name = "%VAL"; + + /* Call the library if we have a character function or if + rank > 0. */ + if (se->ss || array_arg->expr->ts.type == BT_CHARACTER) + { + se->ignore_optional = 1; + if (expr->rank == 0) + { + /* Remove dim argument. */ + gfc_free_expr (dim_arg->expr); + dim_arg->expr = NULL; + } + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + type = gfc_get_int_type (ikind); + + /* Initialize the result. */ + resvar = gfc_create_var (gfc_array_index_type, "pos"); + gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0)); + offset = gfc_create_var (gfc_array_index_type, "offset"); + + maskexpr = mask_arg->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; + + /* Generate two loops, one for BACK=.true. and one for BACK=.false. */ + + for (i = 0 ; i < 2; i++) + { + /* Walk the arguments. */ + arrayss = gfc_walk_expr (array_arg->expr); + gcc_assert (arrayss != gfc_ss_terminator); + + if (maskexpr && maskexpr->rank != 0) + { + maskss = gfc_walk_expr (maskexpr); + gcc_assert (maskss != gfc_ss_terminator); + } + else + maskss = NULL; + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + /* We add the mask first because the number of iterations is + taken from the last ss, and this breaks if an absent + optional argument is used for mask. */ + + if (maskss) + gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + /* Calculate the offset. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[0]); + gfc_add_modify (&loop.pre, offset, tmp); + + gfc_mark_ss_chain_used (arrayss, 1); + if (maskss) + gfc_mark_ss_chain_used (maskss, 1); + + /* The first loop is for BACK=.true. */ + if (i == 0) + loop.reverse[0] = GFC_REVERSE_SET; + + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If we have an array mask, only add the element if it is + set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + } + + /* If the condition matches then set the return value. */ + gfc_start_block (&block); + + /* Add the offset. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (resvar), + loop.loopvar[0], offset); + gfc_add_modify (&block, resvar, tmp); + /* And break out of the loop. */ + tmp = build1_v (GOTO_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + found = gfc_finish_block (&block); + + /* Check this element. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, array_arg->expr); + gfc_add_block_to_block (&body, &arrayse.pre); + + gfc_init_se (&valuese, NULL); + gfc_conv_expr_val (&valuese, value_arg->expr); + gfc_add_block_to_block (&body, &valuese.pre); + + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + arrayse.expr, valuese.expr); + + tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); + if (maskss) + { + /* We enclose the above in if (mask) {...}. If the mask is + an optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ + + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&body, tmp); + gfc_add_block_to_block (&body, &arrayse.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&loop.pre, tmp); + gfc_start_block (&loopblock); + gfc_add_block_to_block (&loopblock, &loop.pre); + gfc_add_block_to_block (&loopblock, &loop.post); + if (i == 0) + forward_branch = gfc_finish_block (&loopblock); + else + back_branch = gfc_finish_block (&loopblock); + + gfc_cleanup_loop (&loop); + } + + /* Enclose the two loops in an IF statement. */ + + gfc_init_se (&backse, NULL); + gfc_conv_expr_val (&backse, back_arg->expr); + gfc_add_block_to_block (&se->pre, &backse.pre); + tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch); + + /* For a scalar mask, enclose the loop in an if statement. */ + if (maskexpr && maskss == NULL) + { + tree ifmask; + tree if_stmt; + + gfc_init_se (&maskse, NULL); + gfc_conv_expr_val (&maskse, maskexpr); + gfc_init_block (&block); + gfc_add_expr_to_block (&block, maskse.expr); + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + if_stmt = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, if_stmt); + tmp = gfc_finish_block (&block); + } + + gfc_add_expr_to_block (&se->pre, tmp); + se->expr = convert (type, resvar); + +} + +/* Emit code for minval or maxval intrinsic. There are many different cases + we need to handle. For performance reasons we sometimes create two + loops instead of one, where the second one is much simpler. + Examples for minval intrinsic: + 1) Result is an array, a call is generated + 2) Array mask is used and NaNs need to be supported, rank 1: + limit = Infinity; + nonempty = false; + S = from; + while (S <= to) { + if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; } + S++; + } + limit = nonempty ? NaN : huge (limit); + lab: + while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; } + 3) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not, rank 1: + limit = Infinity; + S = from; + while (S <= to) { if (a[S] <= limit) goto lab; S++; } + limit = (from <= to) ? NaN : huge (limit); + lab: + while (S <= to) { limit = min (a[S], limit); S++; } + 4) Array mask is used and NaNs need to be supported, rank > 1: + limit = Infinity; + nonempty = false; + fast = false; + S1 = from1; + while (S1 <= to1) { + S2 = from2; + while (S2 <= to2) { + if (mask[S1][S2]) { + if (fast) limit = min (a[S1][S2], limit); + else { + nonempty = true; + if (a[S1][S2] <= limit) { + limit = a[S1][S2]; + fast = true; + } + } + } + S2++; + } + S1++; + } + if (!fast) + limit = nonempty ? NaN : huge (limit); + 5) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not, rank > 1: + limit = Infinity; + fast = false; + S1 = from1; + while (S1 <= to1) { + S2 = from2; + while (S2 <= to2) { + if (fast) limit = min (a[S1][S2], limit); + else { + if (a[S1][S2] <= limit) { + limit = a[S1][S2]; + fast = true; + } + } + S2++; + } + S1++; + } + if (!fast) + limit = (nonempty_array) ? NaN : huge (limit); + 6) NaNs aren't supported, but infinities are. Array mask is used: + limit = Infinity; + nonempty = false; + S = from; + while (S <= to) { + if (mask[S]) { nonempty = true; limit = min (a[S], limit); } + S++; + } + limit = nonempty ? limit : huge (limit); + 7) Same without array mask: + limit = Infinity; + S = from; + while (S <= to) { limit = min (a[S], limit); S++; } + limit = (from <= to) ? limit : huge (limit); + 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER): + limit = huge (limit); + S = from; + while (S <= to) { limit = min (a[S], limit); S++); } + (or + while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; } + with array mask instead). + For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional, + setting limit = huge (limit); in the else branch. */ + +static void +gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + tree limit; + tree type; + tree tmp; + tree ifbody; + tree nonempty; + tree nonempty_var; + tree lab; + tree fast; + tree huge_cst = NULL, nan_cst = NULL; + stmtblock_t body; + stmtblock_t block, block2; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_ss *maskss; + gfc_se arrayse; + gfc_se maskse; + gfc_expr *arrayexpr; + gfc_expr *maskexpr; + int n; + bool optional_mask; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + actual = expr->value.function.actual; + arrayexpr = actual->expr; + + if (arrayexpr->ts.type == BT_CHARACTER) + { + gfc_actual_arglist *dim = actual->next; + if (expr->rank == 0 && dim->expr != 0) + { + gfc_free_expr (dim->expr); + dim->expr = NULL; + } + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + limit = gfc_create_var (type, "limit"); + n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false); + switch (expr->ts.type) + { + case BT_REAL: + huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, + expr->ts.kind, 0); + if (HONOR_INFINITIES (DECL_MODE (limit))) + { + REAL_VALUE_TYPE real; + real_inf (&real); + tmp = build_real (type, real); + } + else + tmp = huge_cst; + if (HONOR_NANS (DECL_MODE (limit))) + nan_cst = gfc_build_nan (type, ""); + break; + + case BT_INTEGER: + tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind); + break; + + default: + gcc_unreachable (); + } + + /* We start with the most negative possible value for MAXVAL, and the most + positive possible value for MINVAL. The most negative possible value is + -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive + possible value is HUGE in both cases. */ + if (op == GT_EXPR) + { + tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); + if (huge_cst) + huge_cst = fold_build1_loc (input_location, NEGATE_EXPR, + TREE_TYPE (huge_cst), huge_cst); + } + + if (op == GT_EXPR && expr->ts.type == BT_INTEGER) + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), + tmp, build_int_cst (type, 1)); + + gfc_add_modify (&se->pre, limit, tmp); + + /* Walk the arguments. */ + arrayss = gfc_walk_expr (arrayexpr); + gcc_assert (arrayss != gfc_ss_terminator); + + actual = actual->next->next; + gcc_assert (actual); + maskexpr = actual->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; + nonempty = NULL; + if (maskexpr && maskexpr->rank != 0) + { + maskss = gfc_walk_expr (maskexpr); + gcc_assert (maskss != gfc_ss_terminator); + } + else + { + mpz_t asize; + if (gfc_array_size (arrayexpr, &asize)) + { + nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); + mpz_clear (asize); + nonempty = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, nonempty, + gfc_index_zero_node); + } + maskss = NULL; + } + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + + /* We add the mask first because the number of iterations is taken + from the last ss, and this breaks if an absent optional argument + is used for mask. */ + + if (maskss) + gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + + /* The code generated can have more than one loop in sequence (see the + comment at the function header). This doesn't work well with the + scalarizer, which changes arrays' offset when the scalarization loops + are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val + are currently inlined in the scalar case only. As there is no dependency + to care about in that case, there is no temporary, so that we can use the + scalarizer temporary code to handle multiple loops. Thus, we set temp_dim + here, we call gfc_mark_ss_chain_used with flag=3 later, and we use + gfc_trans_scalarized_loop_boundary even later to restore offset. + TODO: this prevents inlining of rank > 0 minmaxval calls, so this + should eventually go away. We could either create two loops properly, + or find another way to save/restore the array offsets between the two + loops (without conflicting with temporary management), or use a single + loop minmaxval implementation. See PR 31067. */ + loop.temp_dim = loop.dimen; + gfc_conv_loop_setup (&loop, &expr->where); + + if (nonempty == NULL && maskss == NULL + && loop.dimen == 1 && loop.from[0] && loop.to[0]) + nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + loop.from[0], loop.to[0]); + nonempty_var = NULL; + if (nonempty == NULL + && (HONOR_INFINITIES (DECL_MODE (limit)) + || HONOR_NANS (DECL_MODE (limit)))) + { + nonempty_var = gfc_create_var (logical_type_node, "nonempty"); + gfc_add_modify (&se->pre, nonempty_var, logical_false_node); + nonempty = nonempty_var; + } + lab = NULL; + fast = NULL; + if (HONOR_NANS (DECL_MODE (limit))) + { + if (loop.dimen == 1) + { + lab = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab) = 1; + } + else + { + fast = gfc_create_var (logical_type_node, "fast"); + gfc_add_modify (&se->pre, fast, logical_false_node); + } + } + + gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1); + if (maskss) + gfc_mark_ss_chain_used (maskss, lab ? 3 : 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If we have a mask, only add this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + gfc_init_block (&block2); + + if (nonempty_var) + gfc_add_modify (&block2, nonempty_var, logical_true_node); + + if (HONOR_NANS (DECL_MODE (limit))) + { + tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, + logical_type_node, arrayse.expr, limit); + if (lab) + ifbody = build1_v (GOTO_EXPR, lab); + else + { + stmtblock_t ifblock; + + gfc_init_block (&ifblock); + gfc_add_modify (&ifblock, limit, arrayse.expr); + gfc_add_modify (&ifblock, fast, logical_true_node); + ifbody = gfc_finish_block (&ifblock); + } + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block2, tmp); + } + else + { + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + tmp = fold_build2_loc (input_location, + op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + gfc_add_modify (&block2, limit, tmp); + } + + if (fast) + { + tree elsebody = gfc_finish_block (&block2); + + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_NANS (DECL_MODE (limit))) + { + tmp = fold_build2_loc (input_location, op, logical_type_node, + arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + ifbody = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + } + else + { + tmp = fold_build2_loc (input_location, + op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, tmp); + } + tmp = build3_v (COND_EXPR, fast, ifbody, elsebody); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_block_to_block (&block, &block2); + + gfc_add_block_to_block (&block, &arrayse.post); + + tmp = gfc_finish_block (&block); + if (maskss) + { + /* We enclose the above in if (mask) {...}. If the mask is an + optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&body, tmp); + + if (lab) + { + gfc_trans_scalarized_loop_boundary (&loop, &body); + + tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, + nan_cst, huge_cst); + gfc_add_modify (&loop.code[0], limit, tmp); + gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab)); + + /* If we have a mask, only add this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_NANS (DECL_MODE (limit))) + { + tmp = fold_build2_loc (input_location, op, logical_type_node, + arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = fold_build2_loc (input_location, + op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + gfc_add_modify (&block, limit, tmp); + } + + gfc_add_block_to_block (&block, &arrayse.post); + + tmp = gfc_finish_block (&block); + if (maskss) + /* We enclose the above in if (mask) {...}. */ + { + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&body, tmp); + /* Avoid initializing loopvar[0] again, it should be left where + it finished by the first loop. */ + loop.from[0] = loop.loopvar[0]; + } + gfc_trans_scalarizing_loops (&loop, &body); + + if (fast) + { + tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, + nan_cst, huge_cst); + ifbody = build2_v (MODIFY_EXPR, limit, tmp); + tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location), + ifbody); + gfc_add_expr_to_block (&loop.pre, tmp); + } + else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab) + { + tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit, + huge_cst); + gfc_add_modify (&loop.pre, limit, tmp); + } + + /* For a scalar mask, enclose the loop in an if statement. */ + if (maskexpr && maskss == NULL) + { + tree else_stmt; + tree ifmask; + + gfc_init_se (&maskse, NULL); + gfc_conv_expr_val (&maskse, maskexpr); + gfc_init_block (&block); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + tmp = gfc_finish_block (&block); + + if (HONOR_INFINITIES (DECL_MODE (limit))) + else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst); + else + else_stmt = build_empty_stmt (input_location); + + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&se->pre, &block); + } + else + { + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + } + + gfc_cleanup_loop (&loop); + + se->expr = limit; +} + +/* BTEST (i, pos) = (i & (1 << pos)) != 0. */ +static void +gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) +{ + tree args[2]; + tree type; + tree tmp; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + type = TREE_TYPE (args[0]); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, args[1], + build_int_cst (TREE_TYPE (args[1]), 0)); + tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); + tree above = fold_build2_loc (input_location, GE_EXPR, + logical_type_node, args[1], nbits); + tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "POS argument (%ld) out of range 0:%ld " + "in intrinsic BTEST", + fold_convert (long_integer_type_node, args[1]), + fold_convert (long_integer_type_node, nbits)); + } + + tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, + build_int_cst (type, 1), args[1]); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, + build_int_cst (type, 0)); + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, tmp); +} + + +/* Generate code for BGE, BGT, BLE and BLT intrinsics. */ +static void +gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + + /* Convert both arguments to the unsigned type of the same size. */ + args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]); + args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]); + + /* If they have unequal type size, convert to the larger one. */ + if (TYPE_PRECISION (TREE_TYPE (args[0])) + > TYPE_PRECISION (TREE_TYPE (args[1]))) + args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); + else if (TYPE_PRECISION (TREE_TYPE (args[1])) + > TYPE_PRECISION (TREE_TYPE (args[0]))) + args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); + + /* Now, we compare them. */ + se->expr = fold_build2_loc (input_location, op, logical_type_node, + args[0], args[1]); +} + + +/* Generate code to perform the specified operation. */ +static void +gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]), + args[0], args[1]); +} + +/* Bitwise not. */ +static void +gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) +{ + tree arg; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR, + TREE_TYPE (arg), arg); +} + +/* Set or clear a single bit. */ +static void +gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) +{ + tree args[2]; + tree type; + tree tmp; + enum tree_code op; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + type = TREE_TYPE (args[0]); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, args[1], + build_int_cst (TREE_TYPE (args[1]), 0)); + tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); + tree above = fold_build2_loc (input_location, GE_EXPR, + logical_type_node, args[1], nbits); + tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + size_t len_name = strlen (expr->value.function.isym->name); + char *name = XALLOCAVEC (char, len_name + 1); + for (size_t i = 0; i < len_name; i++) + name[i] = TOUPPER (expr->value.function.isym->name[i]); + name[len_name] = '\0'; + tree iname = gfc_build_addr_expr (pchar_type_node, + gfc_build_cstring_const (name)); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "POS argument (%ld) out of range 0:%ld " + "in intrinsic %s", + fold_convert (long_integer_type_node, args[1]), + fold_convert (long_integer_type_node, nbits), + iname); + } + + tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, + build_int_cst (type, 1), args[1]); + if (set) + op = BIT_IOR_EXPR; + else + { + op = BIT_AND_EXPR; + tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp); + } + se->expr = fold_build2_loc (input_location, op, type, args[0], tmp); +} + +/* Extract a sequence of bits. + IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */ +static void +gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) +{ + tree args[3]; + tree type; + tree tmp; + tree mask; + + gfc_conv_intrinsic_function_args (se, expr, args, 3); + type = TREE_TYPE (args[0]); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree tmp1 = fold_convert (long_integer_type_node, args[1]); + tree tmp2 = fold_convert (long_integer_type_node, args[2]); + tree nbits = build_int_cst (long_integer_type_node, + TYPE_PRECISION (type)); + tree below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, args[1], + build_int_cst (TREE_TYPE (args[1]), 0)); + tree above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, tmp1, nbits); + tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "POS argument (%ld) out of range 0:%ld " + "in intrinsic IBITS", tmp1, nbits); + below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, args[2], + build_int_cst (TREE_TYPE (args[2]), 0)); + above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, tmp2, nbits); + scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "LEN argument (%ld) out of range 0:%ld " + "in intrinsic IBITS", tmp2, nbits); + above = fold_build2_loc (input_location, PLUS_EXPR, + long_integer_type_node, tmp1, tmp2); + scond = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, above, nbits); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) " + "in intrinsic IBITS", tmp1, tmp2, nbits); + } + + mask = build_int_cst (type, -1); + mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]); + mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask); + + tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]); + + se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask); +} + +static void +gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, + bool arithmetic) +{ + tree args[2], type, num_bits, cond; + tree bigshift; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + type = TREE_TYPE (args[0]); + + if (!arithmetic) + args[0] = fold_convert (unsigned_type_for (type), args[0]); + else + gcc_assert (right_shift); + + se->expr = fold_build2_loc (input_location, + right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, + TREE_TYPE (args[0]), args[0], args[1]); + + if (!arithmetic) + se->expr = fold_convert (type, se->expr); + + if (!arithmetic) + bigshift = build_int_cst (type, 0); + else + { + tree nonneg = fold_build2_loc (input_location, GE_EXPR, + logical_type_node, args[0], + build_int_cst (TREE_TYPE (args[0]), 0)); + bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg, + build_int_cst (type, 0), + build_int_cst (type, -1)); + } + + /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas + gcc requires a shift width < BIT_SIZE(I), so we have to catch this + special case. */ + num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, args[1], + build_int_cst (TREE_TYPE (args[1]), 0)); + tree above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, args[1], num_bits); + tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + size_t len_name = strlen (expr->value.function.isym->name); + char *name = XALLOCAVEC (char, len_name + 1); + for (size_t i = 0; i < len_name; i++) + name[i] = TOUPPER (expr->value.function.isym->name[i]); + name[len_name] = '\0'; + tree iname = gfc_build_addr_expr (pchar_type_node, + gfc_build_cstring_const (name)); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "SHIFT argument (%ld) out of range 0:%ld " + "in intrinsic %s", + fold_convert (long_integer_type_node, args[1]), + fold_convert (long_integer_type_node, num_bits), + iname); + } + + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + args[1], num_bits); + + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, + bigshift, se->expr); +} + +/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i)) + ? 0 + : ((shift >= 0) ? i << shift : i >> -shift) + where all shifts are logical shifts. */ +static void +gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) +{ + tree args[2]; + tree type; + tree utype; + tree tmp; + tree width; + tree num_bits; + tree cond; + tree lshift; + tree rshift; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + + type = TREE_TYPE (args[0]); + utype = unsigned_type_for (type); + + width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]), + args[1]); + + /* Left shift if positive. */ + lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width); + + /* Right shift if negative. + We convert to an unsigned type because we want a logical shift. + The standard doesn't define the case of shifting negative + numbers, and we try to be compatible with other compilers, most + notably g77, here. */ + rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR, + utype, convert (utype, args[0]), width)); + + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1], + build_int_cst (TREE_TYPE (args[1]), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift); + + /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas + gcc requires a shift width < BIT_SIZE(I), so we have to catch this + special case. */ + num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree outside = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, width, num_bits); + gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where, + "SHIFT argument (%ld) out of range -%ld:%ld " + "in intrinsic ISHFT", + fold_convert (long_integer_type_node, args[1]), + fold_convert (long_integer_type_node, num_bits), + fold_convert (long_integer_type_node, num_bits)); + } + + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width, + num_bits); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, + build_int_cst (type, 0), tmp); +} + + +/* Circular shift. AKA rotate or barrel shift. */ + +static void +gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) +{ + tree *args; + tree type; + tree tmp; + tree lrot; + tree rrot; + tree zero; + tree nbits; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + + type = TREE_TYPE (args[0]); + nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type)); + + if (num_args == 3) + { + /* Use a library function for the 3 parameter version. */ + tree int4type = gfc_get_int_type (4); + + /* We convert the first argument to at least 4 bytes, and + convert back afterwards. This removes the need for library + functions for all argument sizes, and function will be + aligned to at least 32 bits, so there's no loss. */ + if (expr->ts.kind < 4) + args[0] = convert (int4type, args[0]); + + /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would + need loads of library functions. They cannot have values > + BIT_SIZE (I) so the conversion is safe. */ + args[1] = convert (int4type, args[1]); + args[2] = convert (int4type, args[2]); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree size = fold_convert (long_integer_type_node, args[2]); + tree below = fold_build2_loc (input_location, LE_EXPR, + logical_type_node, size, + build_int_cst (TREE_TYPE (args[1]), 0)); + tree above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, size, nbits); + tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "SIZE argument (%ld) out of range 1:%ld " + "in intrinsic ISHFTC", size, nbits); + tree width = fold_convert (long_integer_type_node, args[1]); + width = fold_build1_loc (input_location, ABS_EXPR, + long_integer_type_node, width); + scond = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, width, size); + gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where, + "SHIFT argument (%ld) out of range -%ld:%ld " + "in intrinsic ISHFTC", + fold_convert (long_integer_type_node, args[1]), + size, size); + } + + switch (expr->ts.kind) + { + case 1: + case 2: + case 4: + tmp = gfor_fndecl_math_ishftc4; + break; + case 8: + tmp = gfor_fndecl_math_ishftc8; + break; + case 16: + tmp = gfor_fndecl_math_ishftc16; + break; + default: + gcc_unreachable (); + } + se->expr = build_call_expr_loc (input_location, + tmp, 3, args[0], args[1], args[2]); + /* Convert the result back to the original type, if we extended + the first argument's width above. */ + if (expr->ts.kind < 4) + se->expr = convert (type, se->expr); + + return; + } + + /* Evaluate arguments only once. */ + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree width = fold_convert (long_integer_type_node, args[1]); + width = fold_build1_loc (input_location, ABS_EXPR, + long_integer_type_node, width); + tree outside = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, width, nbits); + gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where, + "SHIFT argument (%ld) out of range -%ld:%ld " + "in intrinsic ISHFTC", + fold_convert (long_integer_type_node, args[1]), + nbits, nbits); + } + + /* Rotate left if positive. */ + lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]); + + /* Rotate right if negative. */ + tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]), + args[1]); + rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp); + + zero = build_int_cst (TREE_TYPE (args[1]), 0); + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1], + zero); + rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot); + + /* Do nothing if shift == 0. */ + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1], + zero); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0], + rrot); +} + + +/* LEADZ (i) = (i == 0) ? BIT_SIZE (i) + : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i)) + + The conditional expression is necessary because the result of LEADZ(0) + is defined, but the result of __builtin_clz(0) is undefined for most + targets. + + For INTEGER kinds smaller than the C 'int' type, we have to subtract the + difference in bit size between the argument of LEADZ and the C int. */ + +static void +gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg_type; + tree cond; + tree result_type; + tree leadz; + tree bit_size; + tree tmp; + tree func; + int s, argsize; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); + + /* Which variant of __builtin_clz* should we call? */ + if (argsize <= INT_TYPE_SIZE) + { + arg_type = unsigned_type_node; + func = builtin_decl_explicit (BUILT_IN_CLZ); + } + else if (argsize <= LONG_TYPE_SIZE) + { + arg_type = long_unsigned_type_node; + func = builtin_decl_explicit (BUILT_IN_CLZL); + } + else if (argsize <= LONG_LONG_TYPE_SIZE) + { + arg_type = long_long_unsigned_type_node; + func = builtin_decl_explicit (BUILT_IN_CLZLL); + } + else + { + gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); + arg_type = gfc_build_uint_type (argsize); + func = NULL_TREE; + } + + /* Convert the actual argument twice: first, to the unsigned type of the + same size; then, to the proper argument type for the built-in + function. But the return type is of the default INTEGER kind. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); + arg = fold_convert (arg_type, arg); + arg = gfc_evaluate_now (arg, &se->pre); + result_type = gfc_get_int_type (gfc_default_integer_kind); + + /* Compute LEADZ for the case i .ne. 0. */ + if (func) + { + s = TYPE_PRECISION (arg_type) - argsize; + tmp = fold_convert (result_type, + build_call_expr_loc (input_location, func, + 1, arg)); + leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type, + tmp, build_int_cst (result_type, s)); + } + else + { + /* We end up here if the argument type is larger than 'long long'. + We generate this code: + + if (x & (ULL_MAX << ULL_SIZE) != 0) + return clzll ((unsigned long long) (x >> ULLSIZE)); + else + return ULL_SIZE + clzll ((unsigned long long) x); + where ULL_MAX is the largest value that a ULL_MAX can hold + (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE + is the bit-size of the long long type (64 in this example). */ + tree ullsize, ullmax, tmp1, tmp2, btmp; + + ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); + ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, + long_long_unsigned_type_node, + build_int_cst (long_long_unsigned_type_node, + 0)); + + cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type, + fold_convert (arg_type, ullmax), ullsize); + cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, + arg, cond); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + cond, build_int_cst (arg_type, 0)); + + tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, + arg, ullsize); + tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); + btmp = builtin_decl_explicit (BUILT_IN_CLZLL); + tmp1 = fold_convert (result_type, + build_call_expr_loc (input_location, btmp, 1, tmp1)); + + tmp2 = fold_convert (long_long_unsigned_type_node, arg); + btmp = builtin_decl_explicit (BUILT_IN_CLZLL); + tmp2 = fold_convert (result_type, + build_call_expr_loc (input_location, btmp, 1, tmp2)); + tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type, + tmp2, ullsize); + + leadz = fold_build3_loc (input_location, COND_EXPR, result_type, + cond, tmp1, tmp2); + } + + /* Build BIT_SIZE. */ + bit_size = build_int_cst (result_type, argsize); + + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + arg, build_int_cst (arg_type, 0)); + se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, + bit_size, leadz); +} + + +/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i) + + The conditional expression is necessary because the result of TRAILZ(0) + is defined, but the result of __builtin_ctz(0) is undefined for most + targets. */ + +static void +gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) +{ + tree arg; + tree arg_type; + tree cond; + tree result_type; + tree trailz; + tree bit_size; + tree func; + int argsize; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); + + /* Which variant of __builtin_ctz* should we call? */ + if (argsize <= INT_TYPE_SIZE) + { + arg_type = unsigned_type_node; + func = builtin_decl_explicit (BUILT_IN_CTZ); + } + else if (argsize <= LONG_TYPE_SIZE) + { + arg_type = long_unsigned_type_node; + func = builtin_decl_explicit (BUILT_IN_CTZL); + } + else if (argsize <= LONG_LONG_TYPE_SIZE) + { + arg_type = long_long_unsigned_type_node; + func = builtin_decl_explicit (BUILT_IN_CTZLL); + } + else + { + gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); + arg_type = gfc_build_uint_type (argsize); + func = NULL_TREE; + } + + /* Convert the actual argument twice: first, to the unsigned type of the + same size; then, to the proper argument type for the built-in + function. But the return type is of the default INTEGER kind. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); + arg = fold_convert (arg_type, arg); + arg = gfc_evaluate_now (arg, &se->pre); + result_type = gfc_get_int_type (gfc_default_integer_kind); + + /* Compute TRAILZ for the case i .ne. 0. */ + if (func) + trailz = fold_convert (result_type, build_call_expr_loc (input_location, + func, 1, arg)); + else + { + /* We end up here if the argument type is larger than 'long long'. + We generate this code: + + if ((x & ULL_MAX) == 0) + return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE)); + else + return ctzll ((unsigned long long) x); + + where ULL_MAX is the largest value that a ULL_MAX can hold + (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE + is the bit-size of the long long type (64 in this example). */ + tree ullsize, ullmax, tmp1, tmp2, btmp; + + ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE); + ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR, + long_long_unsigned_type_node, + build_int_cst (long_long_unsigned_type_node, 0)); + + cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg, + fold_convert (arg_type, ullmax)); + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond, + build_int_cst (arg_type, 0)); + + tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, + arg, ullsize); + tmp1 = fold_convert (long_long_unsigned_type_node, tmp1); + btmp = builtin_decl_explicit (BUILT_IN_CTZLL); + tmp1 = fold_convert (result_type, + build_call_expr_loc (input_location, btmp, 1, tmp1)); + tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type, + tmp1, ullsize); + + tmp2 = fold_convert (long_long_unsigned_type_node, arg); + btmp = builtin_decl_explicit (BUILT_IN_CTZLL); + tmp2 = fold_convert (result_type, + build_call_expr_loc (input_location, btmp, 1, tmp2)); + + trailz = fold_build3_loc (input_location, COND_EXPR, result_type, + cond, tmp1, tmp2); + } + + /* Build BIT_SIZE. */ + bit_size = build_int_cst (result_type, argsize); + + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + arg, build_int_cst (arg_type, 0)); + se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, + bit_size, trailz); +} + +/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR; + for types larger than "long long", we call the long long built-in for + the lower and higher bits and combine the result. */ + +static void +gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity) +{ + tree arg; + tree arg_type; + tree result_type; + tree func; + int argsize; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); + result_type = gfc_get_int_type (gfc_default_integer_kind); + + /* Which variant of the builtin should we call? */ + if (argsize <= INT_TYPE_SIZE) + { + arg_type = unsigned_type_node; + func = builtin_decl_explicit (parity + ? BUILT_IN_PARITY + : BUILT_IN_POPCOUNT); + } + else if (argsize <= LONG_TYPE_SIZE) + { + arg_type = long_unsigned_type_node; + func = builtin_decl_explicit (parity + ? BUILT_IN_PARITYL + : BUILT_IN_POPCOUNTL); + } + else if (argsize <= LONG_LONG_TYPE_SIZE) + { + arg_type = long_long_unsigned_type_node; + func = builtin_decl_explicit (parity + ? BUILT_IN_PARITYLL + : BUILT_IN_POPCOUNTLL); + } + else + { + /* Our argument type is larger than 'long long', which mean none + of the POPCOUNT builtins covers it. We thus call the 'long long' + variant multiple times, and add the results. */ + tree utype, arg2, call1, call2; + + /* For now, we only cover the case where argsize is twice as large + as 'long long'. */ + gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE); + + func = builtin_decl_explicit (parity + ? BUILT_IN_PARITYLL + : BUILT_IN_POPCOUNTLL); + + /* Convert it to an integer, and store into a variable. */ + utype = gfc_build_uint_type (argsize); + arg = fold_convert (utype, arg); + arg = gfc_evaluate_now (arg, &se->pre); + + /* Call the builtin twice. */ + call1 = build_call_expr_loc (input_location, func, 1, + fold_convert (long_long_unsigned_type_node, + arg)); + + arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg, + build_int_cst (utype, LONG_LONG_TYPE_SIZE)); + call2 = build_call_expr_loc (input_location, func, 1, + fold_convert (long_long_unsigned_type_node, + arg2)); + + /* Combine the results. */ + if (parity) + se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type, + call1, call2); + else + se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type, + call1, call2); + + return; + } + + /* Convert the actual argument twice: first, to the unsigned type of the + same size; then, to the proper argument type for the built-in + function. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); + arg = fold_convert (arg_type, arg); + + se->expr = fold_convert (result_type, + build_call_expr_loc (input_location, func, 1, arg)); +} + + +/* Process an intrinsic with unspecified argument-types that has an optional + argument (which could be of type character), e.g. EOSHIFT. For those, we + need to append the string length of the optional argument if it is not + present and the type is really character. + primary specifies the position (starting at 1) of the non-optional argument + specifying the type and optional gives the position of the optional + argument in the arglist. */ + +static void +conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, + unsigned primary, unsigned optional) +{ + gfc_actual_arglist* prim_arg; + gfc_actual_arglist* opt_arg; + unsigned cur_pos; + gfc_actual_arglist* arg; + gfc_symbol* sym; + vec *append_args; + + /* Find the two arguments given as position. */ + cur_pos = 0; + prim_arg = NULL; + opt_arg = NULL; + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + ++cur_pos; + + if (cur_pos == primary) + prim_arg = arg; + if (cur_pos == optional) + opt_arg = arg; + + if (cur_pos >= primary && cur_pos >= optional) + break; + } + gcc_assert (prim_arg); + gcc_assert (prim_arg->expr); + gcc_assert (opt_arg); + + /* If we do have type CHARACTER and the optional argument is really absent, + append a dummy 0 as string length. */ + append_args = NULL; + if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr) + { + tree dummy; + + dummy = build_int_cst (gfc_charlen_type_node, 0); + vec_alloc (append_args, 1); + append_args->quick_push (dummy); + } + + /* Build the call itself. */ + gcc_assert (!se->ignore_optional); + sym = gfc_get_symbol_for_expr (expr, false); + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, + append_args); + gfc_free_symbol (sym); +} + +/* The length of a character string. */ +static void +gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) +{ + tree len; + tree type; + tree decl; + gfc_symbol *sym; + gfc_se argse; + gfc_expr *arg; + + gcc_assert (!se->ss); + + arg = expr->value.function.actual->expr; + + type = gfc_typenode_for_spec (&expr->ts); + switch (arg->expr_type) + { + case EXPR_CONSTANT: + len = build_int_cst (gfc_charlen_type_node, arg->value.character.length); + break; + + case EXPR_ARRAY: + /* Obtain the string length from the function used by + trans-array.c(gfc_trans_array_constructor). */ + len = NULL_TREE; + get_array_ctor_strlen (&se->pre, arg->value.constructor, &len); + break; + + case EXPR_VARIABLE: + if (arg->ref == NULL + || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY)) + { + /* This doesn't catch all cases. + See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html + and the surrounding thread. */ + sym = arg->symtree->n.sym; + decl = gfc_get_symbol_decl (sym); + if (decl == current_function_decl && sym->attr.function + && (sym->result == sym)) + decl = gfc_get_fake_result_decl (sym, 0); + + len = sym->ts.u.cl->backend_decl; + gcc_assert (len); + break; + } + + /* Fall through. */ + + default: + gfc_init_se (&argse, se); + if (arg->rank == 0) + gfc_conv_expr (&argse, arg); + else + gfc_conv_expr_descriptor (&argse, arg); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + len = argse.string_length; + break; + } + se->expr = convert (type, len); +} + +/* The length of a character string not including trailing blanks. */ +static void +gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) +{ + int kind = expr->value.function.actual->expr->ts.kind; + tree args[2], type, fndecl; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + type = gfc_typenode_for_spec (&expr->ts); + + if (kind == 1) + fndecl = gfor_fndecl_string_len_trim; + else if (kind == 4) + fndecl = gfor_fndecl_string_len_trim_char4; + else + gcc_unreachable (); + + se->expr = build_call_expr_loc (input_location, + fndecl, 2, args[0], args[1]); + se->expr = convert (type, se->expr); +} + + +/* Returns the starting position of a substring within a string. */ + +static void +gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, + tree function) +{ + tree logical4_type_node = gfc_get_logical_type (4); + tree type; + tree fndecl; + tree *args; + unsigned int num_args; + + args = XALLOCAVEC (tree, 5); + + /* Get number of arguments; characters count double due to the + string length argument. Kind= is not passed to the library + and thus ignored. */ + if (expr->value.function.actual->next->next->expr == NULL) + num_args = 4; + else + num_args = 5; + + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + type = gfc_typenode_for_spec (&expr->ts); + + if (num_args == 4) + args[4] = build_int_cst (logical4_type_node, 0); + else + args[4] = convert (logical4_type_node, args[4]); + + fndecl = build_addr (function); + se->expr = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, + 5, args); + se->expr = convert (type, se->expr); + +} + +/* The ascii value for a single character. */ +static void +gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) +{ + tree args[3], type, pchartype; + int nargs; + + nargs = gfc_intrinsic_argument_list_length (expr); + gfc_conv_intrinsic_function_args (se, expr, args, nargs); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1]))); + pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind); + args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]); + type = gfc_typenode_for_spec (&expr->ts); + + se->expr = build_fold_indirect_ref_loc (input_location, + args[1]); + se->expr = convert (type, se->expr); +} + + +/* Intrinsic ISNAN calls __builtin_isnan. */ + +static void +gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr) +{ + tree arg; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + se->expr = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISNAN), + 1, arg); + STRIP_TYPE_NOPS (se->expr); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare + their argument against a constant integer value. */ + +static void +gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value) +{ + tree arg; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + se->expr = fold_build2_loc (input_location, EQ_EXPR, + gfc_typenode_for_spec (&expr->ts), + arg, build_int_cst (TREE_TYPE (arg), value)); +} + + + +/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */ + +static void +gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) +{ + tree tsource; + tree fsource; + tree mask; + tree type; + tree len, len2; + tree *args; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + if (expr->ts.type != BT_CHARACTER) + { + tsource = args[0]; + fsource = args[1]; + mask = args[2]; + } + else + { + /* We do the same as in the non-character case, but the argument + list is different because of the string length arguments. We + also have to set the string length for the result. */ + len = args[0]; + tsource = args[1]; + len2 = args[2]; + fsource = args[3]; + mask = args[4]; + + gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2, + &se->pre); + se->string_length = len; + } + type = TREE_TYPE (tsource); + se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource, + fold_convert (type, fsource)); +} + + +/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */ + +static void +gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr) +{ + tree args[3], mask, type; + + gfc_conv_intrinsic_function_args (se, expr, args, 3); + mask = gfc_evaluate_now (args[2], &se->pre); + + type = TREE_TYPE (args[0]); + gcc_assert (TREE_TYPE (args[1]) == type); + gcc_assert (TREE_TYPE (mask) == type); + + args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask); + args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1], + fold_build1_loc (input_location, BIT_NOT_EXPR, + type, mask)); + se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type, + args[0], args[1]); +} + + +/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n) + MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */ + +static void +gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left) +{ + tree arg, allones, type, utype, res, cond, bitsize; + int i; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + type = gfc_get_int_type (expr->ts.kind); + utype = unsigned_type_for (type); + + i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false); + bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size); + + allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, + build_int_cst (utype, 0)); + + if (left) + { + /* Left-justified mask. */ + res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg), + bitsize, arg); + res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, + fold_convert (utype, res)); + + /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly + smaller than type width. */ + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, + build_int_cst (TREE_TYPE (arg), 0)); + res = fold_build3_loc (input_location, COND_EXPR, utype, cond, + build_int_cst (utype, 0), res); + } + else + { + /* Right-justified mask. */ + res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones, + fold_convert (utype, arg)); + res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res); + + /* Special case agr == bit_size, because SHIFT_EXPR wants a shift + strictly smaller than type width. */ + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + arg, bitsize); + res = fold_build3_loc (input_location, COND_EXPR, utype, + cond, allones, res); + } + + se->expr = fold_convert (type, res); +} + + +/* FRACTION (s) is translated into: + isfinite (s) ? frexp (s, &dummy_int) : NaN */ +static void +gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) +{ + tree arg, type, tmp, res, frexp, cond; + + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISFINITE), + 1, arg); + + tmp = gfc_create_var (integer_type_node, NULL); + res = build_call_expr_loc (input_location, frexp, 2, + fold_convert (type, arg), + gfc_build_addr_expr (NULL_TREE, tmp)); + res = fold_convert (type, res); + + se->expr = fold_build3_loc (input_location, COND_EXPR, type, + cond, res, gfc_build_nan (type, "")); +} + + +/* NEAREST (s, dir) is translated into + tmp = copysign (HUGE_VAL, dir); + return nextafter (s, tmp); + */ +static void +gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) +{ + tree args[2], type, tmp, nextafter, copysign, huge_val; + + nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind); + copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, args, 2); + + huge_val = gfc_build_inf_or_huge (type, expr->ts.kind); + tmp = build_call_expr_loc (input_location, copysign, 2, huge_val, + fold_convert (type, args[1])); + se->expr = build_call_expr_loc (input_location, nextafter, 2, + fold_convert (type, args[0]), tmp); + se->expr = fold_convert (type, se->expr); +} + + +/* SPACING (s) is translated into + int e; + if (!isfinite (s)) + res = NaN; + else if (s == 0) + res = tiny; + else + { + frexp (s, &e); + e = e - prec; + e = MAX_EXPR (e, emin); + res = scalbn (1., e); + } + return res; + + where prec is the precision of s, gfc_real_kinds[k].digits, + emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1, + and tiny is tiny(s), gfc_real_kinds[k].tiny. */ + +static void +gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) +{ + tree arg, type, prec, emin, tiny, res, e; + tree cond, nan, tmp, frexp, scalbn; + int k; + stmtblock_t block; + + k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); + prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits); + emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1); + tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0); + + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + type = gfc_typenode_for_spec (&expr->ts); + e = gfc_create_var (integer_type_node, NULL); + res = gfc_create_var (type, NULL); + + + /* Build the block for s /= 0. */ + gfc_start_block (&block); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); + gfc_add_expr_to_block (&block, tmp); + + tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e, + prec); + gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR, + integer_type_node, tmp, emin)); + + tmp = build_call_expr_loc (input_location, scalbn, 2, + build_real_from_int_cst (type, integer_one_node), e); + gfc_add_modify (&block, res, tmp); + + /* Finish by building the IF statement for value zero. */ + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, + build_real_from_int_cst (type, integer_zero_node)); + tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny), + gfc_finish_block (&block)); + + /* And deal with infinities and NaNs. */ + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISFINITE), + 1, arg); + nan = gfc_build_nan (type, ""); + tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan)); + + gfc_add_expr_to_block (&se->pre, tmp); + se->expr = res; +} + + +/* RRSPACING (s) is translated into + int e; + real x; + x = fabs (s); + if (isfinite (x)) + { + if (x != 0) + { + frexp (s, &e); + x = scalbn (x, precision - e); + } + } + else + x = NaN; + return x; + + where precision is gfc_real_kinds[k].digits. */ + +static void +gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) +{ + tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs; + int prec, k; + stmtblock_t block; + + k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); + prec = gfc_real_kinds[k].digits; + + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); + fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + e = gfc_create_var (integer_type_node, NULL); + x = gfc_create_var (type, NULL); + gfc_add_modify (&se->pre, x, + build_call_expr_loc (input_location, fabs, 1, arg)); + + + gfc_start_block (&block); + tmp = build_call_expr_loc (input_location, frexp, 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); + gfc_add_expr_to_block (&block, tmp); + + tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, + build_int_cst (integer_type_node, prec), e); + tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp); + gfc_add_modify (&block, x, tmp); + stmt = gfc_finish_block (&block); + + /* if (x != 0) */ + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x, + build_real_from_int_cst (type, integer_zero_node)); + tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location)); + + /* And deal with infinities and NaNs. */ + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISFINITE), + 1, x); + nan = gfc_build_nan (type, ""); + tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan)); + + gfc_add_expr_to_block (&se->pre, tmp); + se->expr = fold_convert (type, x); +} + + +/* SCALE (s, i) is translated into scalbn (s, i). */ +static void +gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) +{ + tree args[2], type, scalbn; + + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, args, 2); + se->expr = build_call_expr_loc (input_location, scalbn, 2, + fold_convert (type, args[0]), + fold_convert (integer_type_node, args[1])); + se->expr = fold_convert (type, se->expr); +} + + +/* SET_EXPONENT (s, i) is translated into + isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN */ +static void +gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) +{ + tree args[2], type, tmp, frexp, scalbn, cond, nan, res; + + frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind); + scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind); + + type = gfc_typenode_for_spec (&expr->ts); + gfc_conv_intrinsic_function_args (se, expr, args, 2); + args[0] = gfc_evaluate_now (args[0], &se->pre); + + tmp = gfc_create_var (integer_type_node, NULL); + tmp = build_call_expr_loc (input_location, frexp, 2, + fold_convert (type, args[0]), + gfc_build_addr_expr (NULL_TREE, tmp)); + res = build_call_expr_loc (input_location, scalbn, 2, tmp, + fold_convert (integer_type_node, args[1])); + res = fold_convert (type, res); + + /* Call to isfinite */ + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISFINITE), + 1, args[0]); + nan = gfc_build_nan (type, ""); + + se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, + res, nan); +} + + +static void +gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *actual; + tree arg1; + tree type; + tree size; + gfc_se argse; + gfc_expr *e; + gfc_symbol *sym = NULL; + + gfc_init_se (&argse, NULL); + actual = expr->value.function.actual; + + if (actual->expr->ts.type == BT_CLASS) + gfc_add_class_array_ref (actual->expr); + + e = actual->expr; + + /* These are emerging from the interface mapping, when a class valued + function appears as the rhs in a realloc on assign statement, where + the size of the result is that of one of the actual arguments. */ + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->ns == NULL /* This is distinctive! */ + && e->symtree->n.sym->ts.type == BT_CLASS + && e->ref && e->ref->type == REF_COMPONENT + && strcmp (e->ref->u.c.component->name, "_data") == 0) + sym = e->symtree->n.sym; + + if ((gfc_option.rtcheck & GFC_RTCHECK_POINTER) + && e + && (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)) + { + symbol_attribute attr; + char *msg; + tree temp; + tree cond; + + if (e->symtree->n.sym && IS_CLASS_ARRAY (e->symtree->n.sym)) + { + attr = CLASS_DATA (e->symtree->n.sym)->attr; + attr.pointer = attr.class_pointer; + } + else + attr = gfc_expr_attr (e); + + if (attr.allocatable) + msg = xasprintf ("Allocatable argument '%s' is not allocated", + e->symtree->n.sym->name); + else if (attr.pointer) + msg = xasprintf ("Pointer argument '%s' is not associated", + e->symtree->n.sym->name); + else + goto end_arg_check; + + if (sym) + { + temp = gfc_class_data_get (sym->backend_decl); + temp = gfc_conv_descriptor_data_get (temp); + } + else + { + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, actual->expr); + temp = gfc_conv_descriptor_data_get (argse.expr); + } + + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, temp, + fold_convert (TREE_TYPE (temp), + null_pointer_node)); + gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg); + + free (msg); + } + end_arg_check: + + argse.data_not_needed = 1; + if (gfc_is_class_array_function (e)) + { + /* For functions that return a class array conv_expr_descriptor is not + able to get the descriptor right. Therefore this special case. */ + gfc_conv_expr_reference (&argse, e); + argse.expr = gfc_class_data_get (argse.expr); + } + else if (sym && sym->backend_decl) + { + gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl))); + argse.expr = gfc_class_data_get (sym->backend_decl); + } + else + gfc_conv_expr_descriptor (&argse, actual->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + arg1 = argse.expr; + + actual = actual->next; + if (actual->expr) + { + stmtblock_t block; + gfc_init_block (&block); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, actual->expr, + gfc_array_index_type); + gfc_add_block_to_block (&block, &argse.pre); + tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + argse.expr, gfc_index_one_node); + size = gfc_tree_array_size (&block, arg1, e, tmp); + + /* Unusually, for an intrinsic, size does not exclude + an optional arg2, so we must test for it. */ + if (actual->expr->expr_type == EXPR_VARIABLE + && actual->expr->symtree->n.sym->attr.dummy + && actual->expr->symtree->n.sym->attr.optional) + { + tree cond; + stmtblock_t block2; + gfc_init_block (&block2); + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + argse.data_not_needed = 1; + gfc_conv_expr (&argse, actual->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + argse.expr, null_pointer_node); + cond = gfc_evaluate_now (cond, &se->pre); + /* 'block2' contains the arg2 absent case, 'block' the arg2 present + case; size_var can be used in both blocks. */ + tree size_var = gfc_create_var (TREE_TYPE (size), "size"); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (size_var), size_var, size); + gfc_add_expr_to_block (&block, tmp); + size = gfc_tree_array_size (&block2, arg1, e, NULL_TREE); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (size_var), size_var, size); + gfc_add_expr_to_block (&block2, tmp); + tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block), + gfc_finish_block (&block2)); + gfc_add_expr_to_block (&se->pre, tmp); + size = size_var; + } + else + gfc_add_block_to_block (&se->pre, &block); + } + else + size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE); + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, size); +} + + +/* Helper function to compute the size of a character variable, + excluding the terminating null characters. The result has + gfc_array_index_type type. */ + +tree +size_of_string_in_bytes (int kind, tree string_length) +{ + tree bytesize; + int i = gfc_validate_kind (BT_CHARACTER, kind, false); + + bytesize = build_int_cst (gfc_array_index_type, + gfc_character_kinds[i].bit_size / 8); + + return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + bytesize, + fold_convert (gfc_array_index_type, string_length)); +} + + +static void +gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *arg; + gfc_se argse; + tree source_bytes; + tree tmp; + tree lower; + tree upper; + tree byte_size; + tree field; + int n; + + gfc_init_se (&argse, NULL); + arg = expr->value.function.actual->expr; + + if (arg->rank || arg->ts.type == BT_ASSUMED) + gfc_conv_expr_descriptor (&argse, arg); + else + gfc_conv_expr_reference (&argse, arg); + + if (arg->ts.type == BT_ASSUMED) + { + /* This only works if an array descriptor has been passed; thus, extract + the size from the descriptor. */ + gcc_assert (TYPE_PRECISION (gfc_array_index_type) + == TYPE_PRECISION (size_type_node)); + tmp = arg->symtree->n.sym->backend_decl; + tmp = DECL_LANG_SPECIFIC (tmp) + && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE + ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp; + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + + tmp = gfc_conv_descriptor_dtype (tmp); + field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()), + GFC_DTYPE_ELEM_LEN); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + tmp, field, NULL_TREE); + + byte_size = fold_convert (gfc_array_index_type, tmp); + } + else if (arg->ts.type == BT_CLASS) + { + /* Conv_expr_descriptor returns a component_ref to _data component of the + class object. The class object may be a non-pointer object, e.g. + located on the stack, or a memory location pointed to, e.g. a + parameter, i.e., an indirect_ref. */ + if (arg->rank < 0 + || (arg->rank > 0 && !VAR_P (argse.expr) + && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0)) + && GFC_DECL_CLASS (TREE_OPERAND ( + TREE_OPERAND (argse.expr, 0), 0))) + || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0))))) + byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + else if (arg->rank > 0 + || (arg->rank == 0 + && arg->ref && arg->ref->type == REF_COMPONENT)) + /* The scalarizer added an additional temp. To get the class' vptr + one has to look at the original backend_decl. */ + byte_size = gfc_class_vtab_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); + else + byte_size = gfc_class_vtab_size_get (argse.expr); + } + else + { + if (arg->ts.type == BT_CHARACTER) + byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length); + else + { + if (arg->rank == 0) + byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); + else + byte_size = gfc_get_element_type (TREE_TYPE (argse.expr)); + byte_size = fold_convert (gfc_array_index_type, + size_in_bytes (byte_size)); + } + } + + if (arg->rank == 0) + se->expr = byte_size; + else + { + source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); + gfc_add_modify (&argse.pre, source_bytes, byte_size); + + if (arg->rank == -1) + { + tree cond, loop_var, exit_label; + stmtblock_t body; + + tmp = fold_convert (gfc_array_index_type, + gfc_conv_descriptor_rank (argse.expr)); + loop_var = gfc_create_var (gfc_array_index_type, "i"); + gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Create loop: + for (;;) + { + if (i >= rank) + goto exit; + source_bytes = source_bytes * array.dim[i].extent; + i = i + 1; + } + exit: */ + gfc_start_block (&body); + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + loop_var, tmp); + 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 (&body, tmp); + + lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var); + upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var); + tmp = gfc_conv_array_extent_dim (lower, upper, NULL); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, source_bytes); + gfc_add_modify (&body, source_bytes, tmp); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, loop_var, + gfc_index_one_node); + gfc_add_modify_loc (input_location, &body, loop_var, tmp); + + tmp = gfc_finish_block (&body); + + tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node, + tmp); + gfc_add_expr_to_block (&argse.pre, tmp); + + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&argse.pre, tmp); + } + else + { + /* Obtain the size of the array in bytes. */ + for (n = 0; n < arg->rank; n++) + { + tree idx; + idx = gfc_rank_cst[n]; + lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); + upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); + tmp = gfc_conv_array_extent_dim (lower, upper, NULL); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, source_bytes); + gfc_add_modify (&argse.pre, source_bytes, tmp); + } + } + se->expr = source_bytes; + } + + gfc_add_block_to_block (&se->pre, &argse.pre); +} + + +static void +gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *arg; + gfc_se argse; + tree type, result_type, tmp; + + arg = expr->value.function.actual->expr; + + gfc_init_se (&argse, NULL); + result_type = gfc_get_int_type (expr->ts.kind); + + if (arg->rank == 0) + { + if (arg->ts.type == BT_CLASS) + { + gfc_add_vptr_component (arg); + gfc_add_size_component (arg); + gfc_conv_expr (&argse, arg); + tmp = fold_convert (result_type, argse.expr); + goto done; + } + + gfc_conv_expr_reference (&argse, arg); + type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); + } + else + { + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg); + if (arg->ts.type == BT_CLASS) + { + if (arg->rank > 0) + tmp = gfc_class_vtab_size_get ( + GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); + else + tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); + tmp = fold_convert (result_type, tmp); + goto done; + } + type = gfc_get_element_type (TREE_TYPE (argse.expr)); + } + + /* Obtain the argument's word length. */ + if (arg->ts.type == BT_CHARACTER) + tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); + else + tmp = size_in_bytes (type); + tmp = fold_convert (result_type, tmp); + +done: + se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp, + build_int_cst (result_type, BITS_PER_UNIT)); + gfc_add_block_to_block (&se->pre, &argse.pre); +} + + +/* Intrinsic string comparison functions. */ + +static void +gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op) +{ + tree args[4]; + + gfc_conv_intrinsic_function_args (se, expr, args, 4); + + se->expr + = gfc_build_compare_string (args[0], args[1], args[2], args[3], + expr->value.function.actual->expr->ts.kind, + op); + se->expr = fold_build2_loc (input_location, op, + gfc_typenode_for_spec (&expr->ts), se->expr, + build_int_cst (TREE_TYPE (se->expr), 0)); +} + +/* Generate a call to the adjustl/adjustr library function. */ +static void +gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) +{ + tree args[3]; + tree len; + tree type; + tree var; + tree tmp; + + gfc_conv_intrinsic_function_args (se, expr, &args[1], 2); + len = args[1]; + + type = TREE_TYPE (args[2]); + var = gfc_conv_string_tmp (se, type, len); + args[0] = var; + + tmp = build_call_expr_loc (input_location, + fndecl, 3, args[0], args[1], args[2]); + gfc_add_expr_to_block (&se->pre, tmp); + se->expr = var; + se->string_length = len; +} + + +/* Generate code for the TRANSFER intrinsic: + For scalar results: + DEST = TRANSFER (SOURCE, MOLD) + where: + typeof = typeof + and: + MOLD is scalar. + + For array results: + DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) + where: + typeof = typeof + and: + N = min (sizeof (SOURCE(:)), sizeof (DEST(:)), + sizeof (DEST(0) * SIZE). */ +static void +gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) +{ + tree tmp; + tree tmpdecl; + tree ptr; + tree extent; + tree source; + tree source_type; + tree source_bytes; + tree mold_type; + tree dest_word_len; + tree size_words; + tree size_bytes; + tree upper; + tree lower; + tree stmt; + tree class_ref = NULL_TREE; + gfc_actual_arglist *arg; + gfc_se argse; + gfc_array_info *info; + stmtblock_t block; + int n; + bool scalar_mold; + gfc_expr *source_expr, *mold_expr, *class_expr; + + info = NULL; + if (se->loop) + info = &se->ss->info->data.array; + + /* Convert SOURCE. The output from this stage is:- + source_bytes = length of the source in bytes + source = pointer to the source data. */ + arg = expr->value.function.actual; + source_expr = arg->expr; + + /* Ensure double transfer through LOGICAL preserves all + the needed bits. */ + if (arg->expr->expr_type == EXPR_FUNCTION + && arg->expr->value.function.esym == NULL + && arg->expr->value.function.isym != NULL + && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER + && arg->expr->ts.type == BT_LOGICAL + && expr->ts.type != arg->expr->ts.type) + arg->expr->value.function.name = "__transfer_in_transfer"; + + gfc_init_se (&argse, NULL); + + source_bytes = gfc_create_var (gfc_array_index_type, NULL); + + /* Obtain the pointer to source and the length of source in bytes. */ + if (arg->expr->rank == 0) + { + gfc_conv_expr_reference (&argse, arg->expr); + if (arg->expr->ts.type == BT_CLASS) + { + tmp = build_fold_indirect_ref_loc (input_location, argse.expr); + if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + source = gfc_class_data_get (tmp); + else + { + /* Array elements are evaluated as a reference to the data. + To obtain the vptr for the element size, the argument + expression must be stripped to the class reference and + re-evaluated. The pre and post blocks are not needed. */ + gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); + source = argse.expr; + class_expr = gfc_find_and_cut_at_last_class_ref (arg->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, class_expr); + class_ref = argse.expr; + } + } + else + source = argse.expr; + + /* Obtain the source word length. */ + switch (arg->expr->ts.type) + { + case BT_CHARACTER: + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); + break; + case BT_CLASS: + if (class_ref != NULL_TREE) + tmp = gfc_class_vtab_size_get (class_ref); + else + tmp = gfc_class_vtab_size_get (argse.expr); + break; + default: + source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + source)); + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (source_type)); + break; + } + } + else + { + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg->expr); + source = gfc_conv_descriptor_data_get (argse.expr); + source_type = gfc_get_element_type (TREE_TYPE (argse.expr)); + + /* Repack the source if not simply contiguous. */ + if (!gfc_is_simply_contiguous (arg->expr, false, true)) + { + tmp = gfc_build_addr_expr (NULL_TREE, argse.expr); + + if (warn_array_temporaries) + gfc_warning (OPT_Warray_temporaries, + "Creating array temporary at %L", &expr->where); + + source = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, tmp); + source = gfc_evaluate_now (source, &argse.pre); + + /* Free the temporary. */ + gfc_start_block (&block); + tmp = gfc_call_free (source); + gfc_add_expr_to_block (&block, tmp); + stmt = gfc_finish_block (&block); + + /* Clean up if it was repacked. */ + gfc_init_block (&block); + tmp = gfc_conv_array_data (argse.expr); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + source, tmp); + tmp = build3_v (COND_EXPR, tmp, stmt, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se->post); + gfc_init_block (&se->post); + gfc_add_block_to_block (&se->post, &block); + } + + /* Obtain the source word length. */ + if (arg->expr->ts.type == BT_CHARACTER) + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); + else + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (source_type)); + + /* Obtain the size of the array in bytes. */ + extent = gfc_create_var (gfc_array_index_type, NULL); + for (n = 0; n < arg->expr->rank; n++) + { + tree idx; + idx = gfc_rank_cst[n]; + gfc_add_modify (&argse.pre, source_bytes, tmp); + lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); + upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + gfc_add_modify (&argse.pre, extent, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, extent, + gfc_index_one_node); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, source_bytes); + } + } + + gfc_add_modify (&argse.pre, source_bytes, tmp); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + /* Now convert MOLD. The outputs are: + mold_type = the TREE type of MOLD + dest_word_len = destination word length in bytes. */ + arg = arg->next; + mold_expr = arg->expr; + + gfc_init_se (&argse, NULL); + + scalar_mold = arg->expr->rank == 0; + + if (arg->expr->rank == 0) + { + gfc_conv_expr_reference (&argse, arg->expr); + mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); + } + else + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg->expr); + mold_type = gfc_get_element_type (TREE_TYPE (argse.expr)); + } + + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0) + { + /* If this TRANSFER is nested in another TRANSFER, use a type + that preserves all bits. */ + if (arg->expr->ts.type == BT_LOGICAL) + mold_type = gfc_get_int_type (arg->expr->ts.kind); + } + + /* Obtain the destination word length. */ + switch (arg->expr->ts.type) + { + case BT_CHARACTER: + tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); + mold_type = gfc_get_character_type_len (arg->expr->ts.kind, + argse.string_length); + break; + case BT_CLASS: + tmp = gfc_class_vtab_size_get (argse.expr); + break; + default: + tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type)); + break; + } + dest_word_len = gfc_create_var (gfc_array_index_type, NULL); + gfc_add_modify (&se->pre, dest_word_len, tmp); + + /* Finally convert SIZE, if it is present. */ + arg = arg->next; + size_words = gfc_create_var (gfc_array_index_type, NULL); + + if (arg->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_reference (&argse, arg->expr); + tmp = convert (gfc_array_index_type, + build_fold_indirect_ref_loc (input_location, + argse.expr)); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + else + tmp = NULL_TREE; + + /* Separate array and scalar results. */ + if (scalar_mold && tmp == NULL_TREE) + goto scalar_transfer; + + size_bytes = gfc_create_var (gfc_array_index_type, NULL); + if (tmp != NULL_TREE) + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + tmp, dest_word_len); + else + tmp = source_bytes; + + gfc_add_modify (&se->pre, size_bytes, tmp); + gfc_add_modify (&se->pre, size_words, + fold_build2_loc (input_location, CEIL_DIV_EXPR, + gfc_array_index_type, + size_bytes, dest_word_len)); + + /* Evaluate the bounds of the result. If the loop range exists, we have + to check if it is too large. If so, we modify loop->to be consistent + with min(size, size(source)). Otherwise, size is made consistent with + the loop range, so that the right number of bytes is transferred.*/ + n = se->loop->order[0]; + if (se->loop->to[n] != NULL_TREE) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + se->loop->to[n], se->loop->from[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, + tmp, size_words); + gfc_add_modify (&se->pre, size_words, tmp); + gfc_add_modify (&se->pre, size_bytes, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + size_words, dest_word_len)); + upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size_words, se->loop->from[n]); + upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + upper, gfc_index_one_node); + } + else + { + upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size_words, gfc_index_one_node); + se->loop->from[n] = gfc_index_zero_node; + } + + se->loop->to[n] = upper; + + /* Build a destination descriptor, using the pointer, source, as the + data field. */ + gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type, + NULL_TREE, false, true, false, &expr->where); + + /* Cast the pointer to the result. */ + tmp = gfc_conv_descriptor_data_get (info->descriptor); + tmp = fold_convert (pvoid_type_node, tmp); + + /* Use memcpy to do the transfer. */ + tmp + = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp, + fold_convert (pvoid_type_node, source), + fold_convert (size_type_node, + fold_build2_loc (input_location, + MIN_EXPR, + gfc_array_index_type, + size_bytes, + source_bytes))); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = info->descriptor; + if (expr->ts.type == BT_CHARACTER) + { + tmp = fold_convert (gfc_charlen_type_node, + TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind))); + se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_charlen_type_node, + dest_word_len, tmp); + } + + return; + +/* Deal with scalar results. */ +scalar_transfer: + extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type, + dest_word_len, source_bytes); + extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type, + extent, gfc_index_zero_node); + + if (expr->ts.type == BT_CHARACTER) + { + tree direct, indirect, free; + + ptr = convert (gfc_get_pchar_type (expr->ts.kind), source); + tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), + "transfer"); + + /* If source is longer than the destination, use a pointer to + the source directly. */ + gfc_init_block (&block); + gfc_add_modify (&block, tmpdecl, ptr); + direct = gfc_finish_block (&block); + + /* Otherwise, allocate a string with the length of the destination + and copy the source into it. */ + gfc_init_block (&block); + tmp = gfc_get_pchar_type (expr->ts.kind); + tmp = gfc_call_malloc (&block, tmp, dest_word_len); + gfc_add_modify (&block, tmpdecl, + fold_convert (TREE_TYPE (ptr), tmp)); + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, + fold_convert (pvoid_type_node, tmpdecl), + fold_convert (pvoid_type_node, ptr), + fold_convert (size_type_node, extent)); + gfc_add_expr_to_block (&block, tmp); + indirect = gfc_finish_block (&block); + + /* Wrap it up with the condition. */ + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + dest_word_len, source_bytes); + tmp = build3_v (COND_EXPR, tmp, direct, indirect); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary string, if necessary. */ + free = gfc_call_free (tmpdecl); + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + dest_word_len, source_bytes); + tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = tmpdecl; + tmp = fold_convert (gfc_charlen_type_node, + TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind))); + se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_charlen_type_node, + dest_word_len, tmp); + } + else + { + tmpdecl = gfc_create_var (mold_type, "transfer"); + + ptr = convert (build_pointer_type (mold_type), source); + + /* For CLASS results, allocate the needed memory first. */ + if (mold_expr->ts.type == BT_CLASS) + { + tree cdata; + cdata = gfc_class_data_get (tmpdecl); + tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len); + gfc_add_modify (&se->pre, cdata, tmp); + } + + /* Use memcpy to do the transfer. */ + if (mold_expr->ts.type == BT_CLASS) + tmp = gfc_class_data_get (tmpdecl); + else + tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl); + + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, + fold_convert (pvoid_type_node, tmp), + fold_convert (pvoid_type_node, ptr), + fold_convert (size_type_node, extent)); + gfc_add_expr_to_block (&se->pre, tmp); + + /* For CLASS results, set the _vptr. */ + if (mold_expr->ts.type == BT_CLASS) + { + tree vptr; + gfc_symbol *vtab; + vptr = gfc_class_vptr_get (tmpdecl); + vtab = gfc_find_derived_vtab (source_expr->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp)); + } + + se->expr = tmpdecl; + } +} + + +/* Generate a call to caf_is_present. */ + +static tree +trans_caf_is_present (gfc_se *se, gfc_expr *expr) +{ + tree caf_reference, caf_decl, token, image_index; + + /* Compile the reference chain. */ + caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr); + gcc_assert (caf_reference != NULL_TREE); + + caf_decl = gfc_get_tree_for_caf_expr (expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl); + gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, + expr); + + return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present, + 3, token, image_index, caf_reference); +} + + +/* Test whether this ref-chain refs this image only. */ + +static bool +caf_this_image_ref (gfc_ref *ref) +{ + for ( ; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE; + + return false; +} + + +/* Generate code for the ALLOCATED intrinsic. + Generate inline code that directly check the address of the argument. */ + +static void +gfc_conv_allocated (gfc_se *se, gfc_expr *expr) +{ + gfc_se arg1se; + tree tmp; + bool coindexed_caf_comp = false; + gfc_expr *e = expr->value.function.actual->expr; + + gfc_init_se (&arg1se, NULL); + if (e->ts.type == BT_CLASS) + { + /* Make sure that class array expressions have both a _data + component reference and an array reference.... */ + if (CLASS_DATA (e)->attr.dimension) + gfc_add_class_array_ref (e); + /* .... whilst scalars only need the _data component. */ + else + gfc_add_data_component (e); + } + + /* When 'e' references an allocatable component in a coarray, then call + the caf-library function caf_is_present (). */ + if (flag_coarray == GFC_FCOARRAY_LIB && e->expr_type == EXPR_FUNCTION + && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CAF_GET) + { + e = e->value.function.actual->expr; + if (gfc_expr_attr (e).codimension) + { + /* Last partref is the coindexed coarray. As coarrays are collectively + (de)allocated, the allocation status must be the same as the one of + the local allocation. Convert to local access. */ + for (gfc_ref *ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + for (int i = ref->u.ar.dimen; + i < ref->u.ar.dimen + ref->u.ar.codimen; ++i) + ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE; + break; + } + } + else if (!caf_this_image_ref (e->ref)) + coindexed_caf_comp = true; + } + if (coindexed_caf_comp) + tmp = trans_caf_is_present (se, e); + else + { + if (e->rank == 0) + { + /* Allocatable scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, e); + tmp = arg1se.expr; + } + else + { + /* Allocatable array. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_descriptor (&arg1se, e); + tmp = gfc_conv_descriptor_data_get (arg1se.expr); + } + + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); + } + + /* Components of pointer array references sometimes come back with a pre block. */ + if (arg1se.pre.head) + gfc_add_block_to_block (&se->pre, &arg1se.pre); + + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); +} + + +/* Generate code for the ASSOCIATED intrinsic. + If both POINTER and TARGET are arrays, generate a call to library function + _gfor_associated, and pass descriptors of POINTER and TARGET to it. + In other cases, generate inline code that directly compare the address of + POINTER with the address of TARGET. */ + +static void +gfc_conv_associated (gfc_se *se, gfc_expr *expr) +{ + gfc_actual_arglist *arg1; + gfc_actual_arglist *arg2; + gfc_se arg1se; + gfc_se arg2se; + tree tmp2; + tree tmp; + tree nonzero_arraylen = NULL_TREE; + gfc_ss *ss; + bool scalar; + + gfc_init_se (&arg1se, NULL); + gfc_init_se (&arg2se, NULL); + arg1 = expr->value.function.actual; + arg2 = arg1->next; + + /* Check whether the expression is a scalar or not; we cannot use + arg1->expr->rank as it can be nonzero for proc pointers. */ + ss = gfc_walk_expr (arg1->expr); + scalar = ss == gfc_ss_terminator; + if (!scalar) + gfc_free_ss_chain (ss); + + if (!arg2->expr) + { + /* No optional target. */ + if (scalar) + { + /* A pointer to a scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + if (arg1->expr->symtree->n.sym->attr.proc_pointer + && arg1->expr->symtree->n.sym->attr.dummy) + arg1se.expr = build_fold_indirect_ref_loc (input_location, + arg1se.expr); + if (arg1->expr->ts.type == BT_CLASS) + { + tmp2 = gfc_class_data_get (arg1se.expr); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2))) + tmp2 = gfc_conv_descriptor_data_get (tmp2); + } + else + tmp2 = arg1se.expr; + } + else + { + /* A pointer to an array. */ + gfc_conv_expr_descriptor (&arg1se, arg1->expr); + tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); + } + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2, + fold_convert (TREE_TYPE (tmp2), null_pointer_node)); + se->expr = tmp; + } + else + { + /* An optional target. */ + if (arg2->expr->ts.type == BT_CLASS + && arg2->expr->expr_type != EXPR_FUNCTION) + gfc_add_data_component (arg2->expr); + + if (scalar) + { + /* A pointer to a scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + if (arg1->expr->symtree->n.sym->attr.proc_pointer + && arg1->expr->symtree->n.sym->attr.dummy) + arg1se.expr = build_fold_indirect_ref_loc (input_location, + arg1se.expr); + if (arg1->expr->ts.type == BT_CLASS) + arg1se.expr = gfc_class_data_get (arg1se.expr); + + arg2se.want_pointer = 1; + gfc_conv_expr (&arg2se, arg2->expr); + if (arg2->expr->symtree->n.sym->attr.proc_pointer + && arg2->expr->symtree->n.sym->attr.dummy) + arg2se.expr = build_fold_indirect_ref_loc (input_location, + arg2se.expr); + if (arg2->expr->ts.type == BT_CLASS) + { + arg2se.expr = gfc_evaluate_now (arg2se.expr, &arg2se.pre); + arg2se.expr = gfc_class_data_get (arg2se.expr); + } + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + gfc_add_block_to_block (&se->pre, &arg2se.pre); + gfc_add_block_to_block (&se->post, &arg2se.post); + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + arg1se.expr, arg2se.expr); + tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + arg1se.expr, null_pointer_node); + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, tmp, tmp2); + } + else + { + /* An array pointer of zero length is not associated if target is + present. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_lhs (&arg1se, arg1->expr); + if (arg1->expr->rank == -1) + { + tmp = gfc_conv_descriptor_rank (arg1se.expr); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (tmp), tmp, + build_int_cst (TREE_TYPE (tmp), 1)); + } + else + tmp = gfc_rank_cst[arg1->expr->rank - 1]; + tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); + if (arg2->expr->rank != 0) + nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + + /* A pointer to an array, call library function _gfor_associated. */ + arg1se.want_pointer = 1; + gfc_conv_expr_descriptor (&arg1se, arg1->expr); + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + + arg2se.want_pointer = 1; + arg2se.force_no_tmp = 1; + if (arg2->expr->rank != 0) + gfc_conv_expr_descriptor (&arg2se, arg2->expr); + else + { + gfc_conv_expr (&arg2se, arg2->expr); + arg2se.expr + = gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr, + gfc_expr_attr (arg2->expr)); + arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr); + } + gfc_add_block_to_block (&se->pre, &arg2se.pre); + gfc_add_block_to_block (&se->post, &arg2se.post); + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_associated, 2, + arg1se.expr, arg2se.expr); + se->expr = convert (logical_type_node, se->expr); + if (arg2->expr->rank != 0) + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, se->expr, + nonzero_arraylen); + } + + /* If target is present zero character length pointers cannot + be associated. */ + if (arg1->expr->ts.type == BT_CHARACTER) + { + tmp = arg1se.string_length; + tmp = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tmp, + build_zero_cst (TREE_TYPE (tmp))); + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, se->expr, tmp); + } + } + + se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Generate code for the SAME_TYPE_AS intrinsic. + Generate inline code that directly checks the vindices. */ + +static void +gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *a, *b; + gfc_se se1, se2; + tree tmp; + tree conda = NULL_TREE, condb = NULL_TREE; + + gfc_init_se (&se1, NULL); + gfc_init_se (&se2, NULL); + + a = expr->value.function.actual->expr; + b = expr->value.function.actual->next->expr; + + bool unlimited_poly_a = UNLIMITED_POLY (a); + bool unlimited_poly_b = UNLIMITED_POLY (b); + if (unlimited_poly_a) + { + se1.want_pointer = 1; + gfc_add_vptr_component (a); + } + else if (a->ts.type == BT_CLASS) + { + gfc_add_vptr_component (a); + gfc_add_hash_component (a); + } + else if (a->ts.type == BT_DERIVED) + a = gfc_get_int_expr (gfc_default_integer_kind, NULL, + a->ts.u.derived->hash_value); + + if (unlimited_poly_b) + { + se2.want_pointer = 1; + gfc_add_vptr_component (b); + } + else if (b->ts.type == BT_CLASS) + { + gfc_add_vptr_component (b); + gfc_add_hash_component (b); + } + else if (b->ts.type == BT_DERIVED) + b = gfc_get_int_expr (gfc_default_integer_kind, NULL, + b->ts.u.derived->hash_value); + + gfc_conv_expr (&se1, a); + gfc_conv_expr (&se2, b); + + if (unlimited_poly_a) + { + conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se1.expr, + build_int_cst (TREE_TYPE (se1.expr), 0)); + se1.expr = gfc_vptr_hash_get (se1.expr); + } + + if (unlimited_poly_b) + { + condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se2.expr, + build_int_cst (TREE_TYPE (se2.expr), 0)); + se2.expr = gfc_vptr_hash_get (se2.expr); + } + + tmp = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, se1.expr, + fold_convert (TREE_TYPE (se1.expr), se2.expr)); + + if (conda) + tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, conda, tmp); + + if (condb) + tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, condb, tmp); + + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); +} + + +/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ + +static void +gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr) +{ + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_sc_kind, 2, args[0], args[1]); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ + +static void +gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr) +{ + tree arg, type; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + + /* The argument to SELECTED_INT_KIND is INTEGER(4). */ + type = gfc_get_int_type (4); + arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg)); + + /* Convert it to the required type. */ + type = gfc_typenode_for_spec (&expr->ts); + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_si_kind, 1, arg); + se->expr = fold_convert (type, se->expr); +} + + +/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */ + +static void +gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) +{ + gfc_actual_arglist *actual; + tree type; + gfc_se argse; + vec *args = NULL; + + for (actual = expr->value.function.actual; actual; actual = actual->next) + { + gfc_init_se (&argse, se); + + /* Pass a NULL pointer for an absent arg. */ + if (actual->expr == NULL) + argse.expr = null_pointer_node; + else + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + if (actual->expr->ts.kind != gfc_c_int_kind) + { + /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */ + ts.type = BT_INTEGER; + ts.kind = gfc_c_int_kind; + gfc_convert_type (actual->expr, &ts, 2); + } + gfc_conv_expr_reference (&argse, actual->expr); + } + + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + vec_safe_push (args, argse.expr); + } + + /* Convert it to the required type. */ + type = gfc_typenode_for_spec (&expr->ts); + se->expr = build_call_expr_loc_vec (input_location, + gfor_fndecl_sr_kind, args); + se->expr = fold_convert (type, se->expr); +} + + +/* Generate code for TRIM (A) intrinsic function. */ + +static void +gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree addr; + tree tmp; + tree cond; + tree fndecl; + tree function; + tree *args; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr) + 2; + args = XALLOCAVEC (tree, num_args); + + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); + addr = gfc_build_addr_expr (ppvoid_type_node, var); + len = gfc_create_var (gfc_charlen_type_node, "len"); + + gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); + args[0] = gfc_build_addr_expr (NULL_TREE, len); + args[1] = addr; + + if (expr->ts.kind == 1) + function = gfor_fndecl_string_trim; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_trim_char4; + else + gcc_unreachable (); + + fndecl = build_addr (function); + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, + num_args, args); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + len, build_int_cst (TREE_TYPE (len), 0)); + tmp = gfc_call_free (var); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */ + +static void +gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) +{ + tree args[3], ncopies, dest, dlen, src, slen, ncopies_type; + tree type, cond, tmp, count, exit_label, n, max, largest; + tree size; + stmtblock_t block, body; + int i; + + /* We store in charsize the size of a character. */ + i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); + size = build_int_cst (sizetype, gfc_character_kinds[i].bit_size / 8); + + /* Get the arguments. */ + gfc_conv_intrinsic_function_args (se, expr, args, 3); + slen = fold_convert (sizetype, gfc_evaluate_now (args[0], &se->pre)); + src = args[1]; + ncopies = gfc_evaluate_now (args[2], &se->pre); + ncopies_type = TREE_TYPE (ncopies); + + /* Check that NCOPIES is not negative. */ + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies, + build_int_cst (ncopies_type, 0)); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + "Argument NCOPIES of REPEAT intrinsic is negative " + "(its value is %ld)", + fold_convert (long_integer_type_node, ncopies)); + + /* If the source length is zero, any non negative value of NCOPIES + is valid, and nothing happens. */ + n = gfc_create_var (ncopies_type, "ncopies"); + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, + size_zero_node); + tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond, + build_int_cst (ncopies_type, 0), ncopies); + gfc_add_modify (&se->pre, n, tmp); + ncopies = n; + + /* Check that ncopies is not too large: ncopies should be less than + (or equal to) MAX / slen, where MAX is the maximal integer of + the gfc_charlen_type_node type. If slen == 0, we need a special + case to avoid the division by zero. */ + max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, sizetype, + fold_convert (sizetype, + TYPE_MAX_VALUE (gfc_charlen_type_node)), + slen); + largest = TYPE_PRECISION (sizetype) > TYPE_PRECISION (ncopies_type) + ? sizetype : ncopies_type; + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + fold_convert (largest, ncopies), + fold_convert (largest, max)); + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, + size_zero_node); + cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp, + logical_false_node, cond); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + "Argument NCOPIES of REPEAT intrinsic is too large"); + + /* Compute the destination length. */ + dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node, + fold_convert (gfc_charlen_type_node, slen), + fold_convert (gfc_charlen_type_node, ncopies)); + type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); + dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen); + + /* Generate the code to do the repeat operation: + for (i = 0; i < ncopies; i++) + memmove (dest + (i * slen * size), src, slen*size); */ + gfc_start_block (&block); + count = gfc_create_var (sizetype, "count"); + gfc_add_modify (&block, count, size_zero_node); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Start the loop body. */ + gfc_start_block (&body); + + /* Exit the loop if count >= ncopies. */ + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count, + fold_convert (sizetype, ncopies)); + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + + /* Call memmove (dest + (i*slen*size), src, slen*size). */ + tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, slen, + count); + tmp = fold_build2_loc (input_location, MULT_EXPR, sizetype, tmp, + size); + tmp = fold_build_pointer_plus_loc (input_location, + fold_convert (pvoid_type_node, dest), tmp); + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMMOVE), + 3, tmp, src, + fold_build2_loc (input_location, MULT_EXPR, + size_type_node, slen, size)); + gfc_add_expr_to_block (&body, tmp); + + /* Increment count. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, sizetype, + count, size_one_node); + gfc_add_modify (&body, count, tmp); + + /* Build the loop. */ + tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body)); + gfc_add_expr_to_block (&block, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + /* Finish the block. */ + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Set the result value. */ + se->expr = dest; + se->string_length = dlen; +} + + +/* Generate code for the IARGC intrinsic. */ + +static void +gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) +{ + tree tmp; + tree fndecl; + tree type; + + /* Call the library function. This always returns an INTEGER(4). */ + fndecl = gfor_fndecl_iargc; + tmp = build_call_expr_loc (input_location, + fndecl, 0); + + /* Convert it to the required type. */ + type = gfc_typenode_for_spec (&expr->ts); + tmp = fold_convert (type, tmp); + + se->expr = tmp; +} + + +/* Generate code for the KILL intrinsic. */ + +static void +conv_intrinsic_kill (gfc_se *se, gfc_expr *expr) +{ + tree *args; + tree int4_type_node = gfc_get_int_type (4); + tree pid; + tree sig; + tree tmp; + unsigned int num_args; + + num_args = gfc_intrinsic_argument_list_length (expr); + args = XALLOCAVEC (tree, num_args); + gfc_conv_intrinsic_function_args (se, expr, args, num_args); + + /* Convert PID to a INTEGER(4) entity. */ + pid = convert (int4_type_node, args[0]); + + /* Convert SIG to a INTEGER(4) entity. */ + sig = convert (int4_type_node, args[1]); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_kill, 2, pid, sig); + + se->expr = fold_convert (TREE_TYPE (args[0]), tmp); +} + + +static tree +conv_intrinsic_kill_sub (gfc_code *code) +{ + stmtblock_t block; + gfc_se se, se_stat; + tree int4_type_node = gfc_get_int_type (4); + tree pid; + tree sig; + tree statp; + tree tmp; + + /* Make the function call. */ + gfc_init_block (&block); + gfc_init_se (&se, NULL); + + /* Convert PID to a INTEGER(4) entity. */ + gfc_conv_expr (&se, code->ext.actual->expr); + gfc_add_block_to_block (&block, &se.pre); + pid = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block)); + gfc_add_block_to_block (&block, &se.post); + + /* Convert SIG to a INTEGER(4) entity. */ + gfc_conv_expr (&se, code->ext.actual->next->expr); + gfc_add_block_to_block (&block, &se.pre); + sig = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block)); + gfc_add_block_to_block (&block, &se.post); + + /* Deal with an optional STATUS. */ + if (code->ext.actual->next->next->expr) + { + gfc_init_se (&se_stat, NULL); + gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr); + statp = gfc_create_var (gfc_get_int_type (4), "_statp"); + } + else + statp = NULL_TREE; + + tmp = build_call_expr_loc (input_location, gfor_fndecl_kill_sub, 3, pid, sig, + statp ? gfc_build_addr_expr (NULL_TREE, statp) : null_pointer_node); + + gfc_add_expr_to_block (&block, tmp); + + if (statp && statp != se_stat.expr) + gfc_add_modify (&block, se_stat.expr, + fold_convert (TREE_TYPE (se_stat.expr), statp)); + + return gfc_finish_block (&block); +} + + + +/* The loc intrinsic returns the address of its argument as + gfc_index_integer_kind integer. */ + +static void +gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) +{ + tree temp_var; + gfc_expr *arg_expr; + + gcc_assert (!se->ss); + + arg_expr = expr->value.function.actual->expr; + if (arg_expr->rank == 0) + { + if (arg_expr->ts.type == BT_CLASS) + gfc_add_data_component (arg_expr); + gfc_conv_expr_reference (se, arg_expr); + } + else + gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL); + se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); + + /* Create a temporary variable for loc return value. Without this, + we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */ + temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL); + gfc_add_modify (&se->pre, temp_var, se->expr); + se->expr = temp_var; +} + + +/* The following routine generates code for the intrinsic + functions from the ISO_C_BINDING module: + * C_LOC + * C_FUNLOC + * C_ASSOCIATED */ + +static void +conv_isocbinding_function (gfc_se *se, gfc_expr *expr) +{ + gfc_actual_arglist *arg = expr->value.function.actual; + + if (expr->value.function.isym->id == GFC_ISYM_C_LOC) + { + if (arg->expr->rank == 0) + gfc_conv_expr_reference (se, arg->expr); + else if (gfc_is_simply_contiguous (arg->expr, false, false)) + gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL); + else + { + gfc_conv_expr_descriptor (se, arg->expr); + se->expr = gfc_conv_descriptor_data_get (se->expr); + } + + /* TODO -- the following two lines shouldn't be necessary, but if + they're removed, a bug is exposed later in the code path. + This workaround was thus introduced, but will have to be + removed; please see PR 35150 for details about the issue. */ + se->expr = convert (pvoid_type_node, se->expr); + se->expr = gfc_evaluate_now (se->expr, &se->pre); + } + else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC) + gfc_conv_expr_reference (se, arg->expr); + else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED) + { + gfc_se arg1se; + gfc_se arg2se; + + /* Build the addr_expr for the first argument. The argument is + already an *address* so we don't need to set want_pointer in + the gfc_se. */ + gfc_init_se (&arg1se, NULL); + gfc_conv_expr (&arg1se, arg->expr); + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + + /* See if we were given two arguments. */ + if (arg->next->expr == NULL) + /* Only given one arg so generate a null and do a + not-equal comparison against the first arg. */ + se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + arg1se.expr, + fold_convert (TREE_TYPE (arg1se.expr), + null_pointer_node)); + else + { + tree eq_expr; + tree not_null_expr; + + /* Given two arguments so build the arg2se from second arg. */ + gfc_init_se (&arg2se, NULL); + gfc_conv_expr (&arg2se, arg->next->expr); + gfc_add_block_to_block (&se->pre, &arg2se.pre); + gfc_add_block_to_block (&se->post, &arg2se.post); + + /* Generate test to compare that the two args are equal. */ + eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + arg1se.expr, arg2se.expr); + /* Generate test to ensure that the first arg is not null. */ + not_null_expr = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + arg1se.expr, null_pointer_node); + + /* Finally, the generated test must check that both arg1 is not + NULL and that it is equal to the second arg. */ + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, + not_null_expr, eq_expr); + } + } + else + gcc_unreachable (); +} + + +/* The following routine generates code for the intrinsic + subroutines from the ISO_C_BINDING module: + * C_F_POINTER + * C_F_PROCPOINTER. */ + +static tree +conv_isocbinding_subroutine (gfc_code *code) +{ + gfc_se se; + gfc_se cptrse; + gfc_se fptrse; + gfc_se shapese; + gfc_ss *shape_ss; + tree desc, dim, tmp, stride, offset; + stmtblock_t body, block; + gfc_loopinfo loop; + gfc_actual_arglist *arg = code->ext.actual; + + gfc_init_se (&se, NULL); + gfc_init_se (&cptrse, NULL); + gfc_conv_expr (&cptrse, arg->expr); + gfc_add_block_to_block (&se.pre, &cptrse.pre); + gfc_add_block_to_block (&se.post, &cptrse.post); + + gfc_init_se (&fptrse, NULL); + if (arg->next->expr->rank == 0) + { + fptrse.want_pointer = 1; + gfc_conv_expr (&fptrse, arg->next->expr); + gfc_add_block_to_block (&se.pre, &fptrse.pre); + gfc_add_block_to_block (&se.post, &fptrse.post); + if (arg->next->expr->symtree->n.sym->attr.proc_pointer + && arg->next->expr->symtree->n.sym->attr.dummy) + fptrse.expr = build_fold_indirect_ref_loc (input_location, + fptrse.expr); + se.expr = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); + gfc_add_expr_to_block (&se.pre, se.expr); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); + } + + gfc_start_block (&block); + + /* Get the descriptor of the Fortran pointer. */ + fptrse.descriptor_only = 1; + gfc_conv_expr_descriptor (&fptrse, arg->next->expr); + gfc_add_block_to_block (&block, &fptrse.pre); + desc = fptrse.expr; + + /* Set the span field. */ + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); + tmp = fold_convert (gfc_array_index_type, tmp); + gfc_conv_descriptor_span_set (&block, desc, tmp); + + /* Set data value, dtype, and offset. */ + tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); + gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr)); + gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), + gfc_get_dtype (TREE_TYPE (desc))); + + /* Start scalarization of the bounds, using the shape argument. */ + + shape_ss = gfc_walk_expr (arg->next->next->expr); + gcc_assert (shape_ss != gfc_ss_terminator); + gfc_init_se (&shapese, NULL); + + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, shape_ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &arg->next->expr->where); + gfc_mark_ss_chain_used (shape_ss, 1); + + gfc_copy_loopinfo_to_se (&shapese, &loop); + shapese.ss = shape_ss; + + stride = gfc_create_var (gfc_array_index_type, "stride"); + offset = gfc_create_var (gfc_array_index_type, "offset"); + gfc_add_modify (&block, stride, gfc_index_one_node); + gfc_add_modify (&block, offset, gfc_index_zero_node); + + /* Loop body. */ + gfc_start_scalarized_body (&loop, &body); + + dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + loop.loopvar[0], loop.from[0]); + + /* Set bounds and stride. */ + gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); + gfc_conv_descriptor_stride_set (&body, desc, dim, stride); + + gfc_conv_expr (&shapese, arg->next->next->expr); + gfc_add_block_to_block (&body, &shapese.pre); + gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); + gfc_add_block_to_block (&body, &shapese.post); + + /* Calculate offset. */ + gfc_add_modify (&body, offset, + fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offset, stride)); + /* Update stride. */ + gfc_add_modify (&body, stride, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, + fold_convert (gfc_array_index_type, + shapese.expr))); + /* Finish scalarization loop. */ + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + gfc_add_block_to_block (&block, &fptrse.post); + gfc_cleanup_loop (&loop); + + gfc_add_modify (&block, offset, + fold_build1_loc (input_location, NEGATE_EXPR, + gfc_array_index_type, offset)); + gfc_conv_descriptor_offset_set (&block, desc, offset); + + gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block)); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); +} + + +/* Save and restore floating-point state. */ + +tree +gfc_save_fp_state (stmtblock_t *block) +{ + tree type, fpstate, tmp; + + type = build_array_type (char_type_node, + build_range_type (size_type_node, size_zero_node, + size_int (GFC_FPE_STATE_BUFFER_SIZE))); + fpstate = gfc_create_var (type, "fpstate"); + fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry, + 1, fpstate); + gfc_add_expr_to_block (block, tmp); + + return fpstate; +} + + +void +gfc_restore_fp_state (stmtblock_t *block, tree fpstate) +{ + tree tmp; + + tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit, + 1, fpstate); + gfc_add_expr_to_block (block, tmp); +} + + +/* Generate code for arguments of IEEE functions. */ + +static void +conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray, + int nargs) +{ + gfc_actual_arglist *actual; + gfc_expr *e; + gfc_se argse; + int arg; + + actual = expr->value.function.actual; + for (arg = 0; arg < nargs; arg++, actual = actual->next) + { + gcc_assert (actual); + e = actual->expr; + + gfc_init_se (&argse, se); + gfc_conv_expr_val (&argse, e); + + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + argarray[arg] = argse.expr; + } +} + + +/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE, + and IEEE_UNORDERED, which translate directly to GCC type-generic + built-ins. */ + +static void +conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr, + enum built_in_function code, int nargs) +{ + tree args[2]; + gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0])); + + conv_ieee_function_args (se, expr, args, nargs); + se->expr = build_call_expr_loc_array (input_location, + builtin_decl_explicit (code), + nargs, args); + STRIP_TYPE_NOPS (se->expr); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Generate code for IEEE_IS_NORMAL intrinsic: + IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */ + +static void +conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr) +{ + tree arg, isnormal, iszero; + + /* Convert arg, evaluate it only once. */ + conv_ieee_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + isnormal = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISNORMAL), + 1, arg); + iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, + build_real_from_int_cst (TREE_TYPE (arg), + integer_zero_node)); + se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, isnormal, iszero); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Generate code for IEEE_IS_NEGATIVE intrinsic: + IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x)) */ + +static void +conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr) +{ + tree arg, signbit, isnan; + + /* Convert arg, evaluate it only once. */ + conv_ieee_function_args (se, expr, &arg, 1); + arg = gfc_evaluate_now (arg, &se->pre); + + isnan = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISNAN), + 1, arg); + STRIP_TYPE_NOPS (isnan); + + signbit = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_SIGNBIT), + 1, arg); + signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + signbit, integer_zero_node); + + se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, + logical_type_node, signbit, + fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE(isnan), isnan)); + + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Generate code for IEEE_LOGB and IEEE_RINT. */ + +static void +conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr, + enum built_in_function code) +{ + tree arg, decl, call, fpstate; + int argprec; + + conv_ieee_function_args (se, expr, &arg, 1); + argprec = TYPE_PRECISION (TREE_TYPE (arg)); + decl = builtin_decl_for_precision (code, argprec); + + /* Save floating-point state. */ + fpstate = gfc_save_fp_state (&se->pre); + + /* Make the function call. */ + call = build_call_expr_loc (input_location, decl, 1, arg); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call); + + /* Restore floating-point state. */ + gfc_restore_fp_state (&se->post, fpstate); +} + + +/* Generate code for IEEE_REM. */ + +static void +conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr) +{ + tree args[2], decl, call, fpstate; + int argprec; + + conv_ieee_function_args (se, expr, args, 2); + + /* If arguments have unequal size, convert them to the larger. */ + if (TYPE_PRECISION (TREE_TYPE (args[0])) + > TYPE_PRECISION (TREE_TYPE (args[1]))) + args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); + else if (TYPE_PRECISION (TREE_TYPE (args[1])) + > TYPE_PRECISION (TREE_TYPE (args[0]))) + args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); + + argprec = TYPE_PRECISION (TREE_TYPE (args[0])); + decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec); + + /* Save floating-point state. */ + fpstate = gfc_save_fp_state (&se->pre); + + /* Make the function call. */ + call = build_call_expr_loc_array (input_location, decl, 2, args); + se->expr = fold_convert (TREE_TYPE (args[0]), call); + + /* Restore floating-point state. */ + gfc_restore_fp_state (&se->post, fpstate); +} + + +/* Generate code for IEEE_NEXT_AFTER. */ + +static void +conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr) +{ + tree args[2], decl, call, fpstate; + int argprec; + + conv_ieee_function_args (se, expr, args, 2); + + /* Result has the characteristics of first argument. */ + args[1] = fold_convert (TREE_TYPE (args[0]), args[1]); + argprec = TYPE_PRECISION (TREE_TYPE (args[0])); + decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec); + + /* Save floating-point state. */ + fpstate = gfc_save_fp_state (&se->pre); + + /* Make the function call. */ + call = build_call_expr_loc_array (input_location, decl, 2, args); + se->expr = fold_convert (TREE_TYPE (args[0]), call); + + /* Restore floating-point state. */ + gfc_restore_fp_state (&se->post, fpstate); +} + + +/* Generate code for IEEE_SCALB. */ + +static void +conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr) +{ + tree args[2], decl, call, huge, type; + int argprec, n; + + conv_ieee_function_args (se, expr, args, 2); + + /* Result has the characteristics of first argument. */ + argprec = TYPE_PRECISION (TREE_TYPE (args[0])); + decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec); + + if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node)) + { + /* We need to fold the integer into the range of a C int. */ + args[1] = gfc_evaluate_now (args[1], &se->pre); + type = TREE_TYPE (args[1]); + + n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false); + huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, + gfc_c_int_kind); + huge = fold_convert (type, huge); + args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1], + huge); + args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1], + fold_build1_loc (input_location, NEGATE_EXPR, + type, huge)); + } + + args[1] = fold_convert (integer_type_node, args[1]); + + /* Make the function call. */ + call = build_call_expr_loc_array (input_location, decl, 2, args); + se->expr = fold_convert (TREE_TYPE (args[0]), call); +} + + +/* Generate code for IEEE_COPY_SIGN. */ + +static void +conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr) +{ + tree args[2], decl, sign; + int argprec; + + conv_ieee_function_args (se, expr, args, 2); + + /* Get the sign of the second argument. */ + sign = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_SIGNBIT), + 1, args[1]); + sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + sign, integer_zero_node); + + /* Create a value of one, with the right sign. */ + sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node, + sign, + fold_build1_loc (input_location, NEGATE_EXPR, + integer_type_node, + integer_one_node), + integer_one_node); + args[1] = fold_convert (TREE_TYPE (args[0]), sign); + + argprec = TYPE_PRECISION (TREE_TYPE (args[0])); + decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec); + + se->expr = build_call_expr_loc_array (input_location, decl, 2, args); +} + + +/* Generate code for an intrinsic function from the IEEE_ARITHMETIC + module. */ + +bool +gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr) +{ + const char *name = expr->value.function.name; + + if (startswith (name, "_gfortran_ieee_is_nan")) + conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1); + else if (startswith (name, "_gfortran_ieee_is_finite")) + conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1); + else if (startswith (name, "_gfortran_ieee_unordered")) + conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2); + else if (startswith (name, "_gfortran_ieee_is_normal")) + conv_intrinsic_ieee_is_normal (se, expr); + else if (startswith (name, "_gfortran_ieee_is_negative")) + conv_intrinsic_ieee_is_negative (se, expr); + else if (startswith (name, "_gfortran_ieee_copy_sign")) + conv_intrinsic_ieee_copy_sign (se, expr); + else if (startswith (name, "_gfortran_ieee_scalb")) + conv_intrinsic_ieee_scalb (se, expr); + else if (startswith (name, "_gfortran_ieee_next_after")) + conv_intrinsic_ieee_next_after (se, expr); + else if (startswith (name, "_gfortran_ieee_rem")) + conv_intrinsic_ieee_rem (se, expr); + else if (startswith (name, "_gfortran_ieee_logb")) + conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB); + else if (startswith (name, "_gfortran_ieee_rint")) + conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT); + else + /* It is not among the functions we translate directly. We return + false, so a library function call is emitted. */ + return false; + + return true; +} + + +/* Generate a direct call to malloc() for the MALLOC intrinsic. */ + +static void +gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr) +{ + tree arg, res, restype; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + arg = fold_convert (size_type_node, arg); + res = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg); + restype = gfc_typenode_for_spec (&expr->ts); + se->expr = fold_convert (restype, res); +} + + +/* Generate code for an intrinsic function. Some map directly to library + calls, others get special handling. In some cases the name of the function + used depends on the type specifiers. */ + +void +gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) +{ + const char *name; + int lib, kind; + tree fndecl; + + name = &expr->value.function.name[2]; + + if (expr->rank > 0) + { + lib = gfc_is_intrinsic_libcall (expr); + if (lib != 0) + { + if (lib == 1) + se->ignore_optional = 1; + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_EOSHIFT: + case GFC_ISYM_PACK: + case GFC_ISYM_RESHAPE: + /* For all of those the first argument specifies the type and the + third is optional. */ + conv_generic_with_optional_char_arg (se, expr, 1, 3); + break; + + case GFC_ISYM_FINDLOC: + gfc_conv_intrinsic_findloc (se, expr); + break; + + case GFC_ISYM_MINLOC: + gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); + break; + + case GFC_ISYM_MAXLOC: + gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); + break; + + default: + gfc_conv_intrinsic_funcall (se, expr); + break; + } + + return; + } + } + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_NONE: + gcc_unreachable (); + + case GFC_ISYM_REPEAT: + gfc_conv_intrinsic_repeat (se, expr); + break; + + case GFC_ISYM_TRIM: + gfc_conv_intrinsic_trim (se, expr); + break; + + case GFC_ISYM_SC_KIND: + gfc_conv_intrinsic_sc_kind (se, expr); + break; + + case GFC_ISYM_SI_KIND: + gfc_conv_intrinsic_si_kind (se, expr); + break; + + case GFC_ISYM_SR_KIND: + gfc_conv_intrinsic_sr_kind (se, expr); + break; + + case GFC_ISYM_EXPONENT: + gfc_conv_intrinsic_exponent (se, expr); + break; + + case GFC_ISYM_SCAN: + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_scan; + else if (kind == 4) + fndecl = gfor_fndecl_string_scan_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); + break; + + case GFC_ISYM_VERIFY: + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_verify; + else if (kind == 4) + fndecl = gfor_fndecl_string_verify_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); + break; + + case GFC_ISYM_ALLOCATED: + gfc_conv_allocated (se, expr); + break; + + case GFC_ISYM_ASSOCIATED: + gfc_conv_associated(se, expr); + break; + + case GFC_ISYM_SAME_TYPE_AS: + gfc_conv_same_type_as (se, expr); + break; + + case GFC_ISYM_ABS: + gfc_conv_intrinsic_abs (se, expr); + break; + + case GFC_ISYM_ADJUSTL: + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustl; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustl_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); + break; + + case GFC_ISYM_ADJUSTR: + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustr; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustr_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); + break; + + case GFC_ISYM_AIMAG: + gfc_conv_intrinsic_imagpart (se, expr); + break; + + case GFC_ISYM_AINT: + gfc_conv_intrinsic_aint (se, expr, RND_TRUNC); + break; + + case GFC_ISYM_ALL: + gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR); + break; + + case GFC_ISYM_ANINT: + gfc_conv_intrinsic_aint (se, expr, RND_ROUND); + break; + + case GFC_ISYM_AND: + gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); + break; + + case GFC_ISYM_ANY: + gfc_conv_intrinsic_anyall (se, expr, NE_EXPR); + break; + + case GFC_ISYM_ACOSD: + case GFC_ISYM_ASIND: + case GFC_ISYM_ATAND: + gfc_conv_intrinsic_atrigd (se, expr, expr->value.function.isym->id); + break; + + case GFC_ISYM_COTAN: + gfc_conv_intrinsic_cotan (se, expr); + break; + + case GFC_ISYM_COTAND: + gfc_conv_intrinsic_cotand (se, expr); + break; + + case GFC_ISYM_ATAN2D: + gfc_conv_intrinsic_atan2d (se, expr); + break; + + case GFC_ISYM_BTEST: + gfc_conv_intrinsic_btest (se, expr); + break; + + case GFC_ISYM_BGE: + gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR); + break; + + case GFC_ISYM_BGT: + gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR); + break; + + case GFC_ISYM_BLE: + gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR); + break; + + case GFC_ISYM_BLT: + gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR); + break; + + case GFC_ISYM_C_ASSOCIATED: + case GFC_ISYM_C_FUNLOC: + case GFC_ISYM_C_LOC: + conv_isocbinding_function (se, expr); + break; + + case GFC_ISYM_ACHAR: + case GFC_ISYM_CHAR: + gfc_conv_intrinsic_char (se, expr); + break; + + case GFC_ISYM_CONVERSION: + case GFC_ISYM_DBLE: + case GFC_ISYM_DFLOAT: + case GFC_ISYM_FLOAT: + case GFC_ISYM_LOGICAL: + case GFC_ISYM_REAL: + case GFC_ISYM_REALPART: + case GFC_ISYM_SNGL: + gfc_conv_intrinsic_conversion (se, expr); + break; + + /* Integer conversions are handled separately to make sure we get the + correct rounding mode. */ + case GFC_ISYM_INT: + case GFC_ISYM_INT2: + case GFC_ISYM_INT8: + case GFC_ISYM_LONG: + gfc_conv_intrinsic_int (se, expr, RND_TRUNC); + break; + + case GFC_ISYM_NINT: + gfc_conv_intrinsic_int (se, expr, RND_ROUND); + break; + + case GFC_ISYM_CEILING: + gfc_conv_intrinsic_int (se, expr, RND_CEIL); + break; + + case GFC_ISYM_FLOOR: + gfc_conv_intrinsic_int (se, expr, RND_FLOOR); + break; + + case GFC_ISYM_MOD: + gfc_conv_intrinsic_mod (se, expr, 0); + break; + + case GFC_ISYM_MODULO: + gfc_conv_intrinsic_mod (se, expr, 1); + break; + + case GFC_ISYM_CAF_GET: + gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE, + false, NULL); + break; + + case GFC_ISYM_CMPLX: + gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1'); + break; + + case GFC_ISYM_COMMAND_ARGUMENT_COUNT: + gfc_conv_intrinsic_iargc (se, expr); + break; + + case GFC_ISYM_COMPLEX: + gfc_conv_intrinsic_cmplx (se, expr, 1); + break; + + case GFC_ISYM_CONJG: + gfc_conv_intrinsic_conjg (se, expr); + break; + + case GFC_ISYM_COUNT: + gfc_conv_intrinsic_count (se, expr); + break; + + case GFC_ISYM_CTIME: + gfc_conv_intrinsic_ctime (se, expr); + break; + + case GFC_ISYM_DIM: + gfc_conv_intrinsic_dim (se, expr); + break; + + case GFC_ISYM_DOT_PRODUCT: + gfc_conv_intrinsic_dot_product (se, expr); + break; + + case GFC_ISYM_DPROD: + gfc_conv_intrinsic_dprod (se, expr); + break; + + case GFC_ISYM_DSHIFTL: + gfc_conv_intrinsic_dshift (se, expr, true); + break; + + case GFC_ISYM_DSHIFTR: + gfc_conv_intrinsic_dshift (se, expr, false); + break; + + case GFC_ISYM_FDATE: + gfc_conv_intrinsic_fdate (se, expr); + break; + + case GFC_ISYM_FRACTION: + gfc_conv_intrinsic_fraction (se, expr); + break; + + case GFC_ISYM_IALL: + gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false); + break; + + case GFC_ISYM_IAND: + gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); + break; + + case GFC_ISYM_IANY: + gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false); + break; + + case GFC_ISYM_IBCLR: + gfc_conv_intrinsic_singlebitop (se, expr, 0); + break; + + case GFC_ISYM_IBITS: + gfc_conv_intrinsic_ibits (se, expr); + break; + + case GFC_ISYM_IBSET: + gfc_conv_intrinsic_singlebitop (se, expr, 1); + break; + + case GFC_ISYM_IACHAR: + case GFC_ISYM_ICHAR: + /* We assume ASCII character sequence. */ + gfc_conv_intrinsic_ichar (se, expr); + break; + + case GFC_ISYM_IARGC: + gfc_conv_intrinsic_iargc (se, expr); + break; + + case GFC_ISYM_IEOR: + gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); + break; + + case GFC_ISYM_INDEX: + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_index; + else if (kind == 4) + fndecl = gfor_fndecl_string_index_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); + break; + + case GFC_ISYM_IOR: + gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); + break; + + case GFC_ISYM_IPARITY: + gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false); + break; + + case GFC_ISYM_IS_IOSTAT_END: + gfc_conv_has_intvalue (se, expr, LIBERROR_END); + break; + + case GFC_ISYM_IS_IOSTAT_EOR: + gfc_conv_has_intvalue (se, expr, LIBERROR_EOR); + break; + + case GFC_ISYM_IS_CONTIGUOUS: + gfc_conv_intrinsic_is_contiguous (se, expr); + break; + + case GFC_ISYM_ISNAN: + gfc_conv_intrinsic_isnan (se, expr); + break; + + case GFC_ISYM_KILL: + conv_intrinsic_kill (se, expr); + break; + + case GFC_ISYM_LSHIFT: + gfc_conv_intrinsic_shift (se, expr, false, false); + break; + + case GFC_ISYM_RSHIFT: + gfc_conv_intrinsic_shift (se, expr, true, true); + break; + + case GFC_ISYM_SHIFTA: + gfc_conv_intrinsic_shift (se, expr, true, true); + break; + + case GFC_ISYM_SHIFTL: + gfc_conv_intrinsic_shift (se, expr, false, false); + break; + + case GFC_ISYM_SHIFTR: + gfc_conv_intrinsic_shift (se, expr, true, false); + break; + + case GFC_ISYM_ISHFT: + gfc_conv_intrinsic_ishft (se, expr); + break; + + case GFC_ISYM_ISHFTC: + gfc_conv_intrinsic_ishftc (se, expr); + break; + + case GFC_ISYM_LEADZ: + gfc_conv_intrinsic_leadz (se, expr); + break; + + case GFC_ISYM_TRAILZ: + gfc_conv_intrinsic_trailz (se, expr); + break; + + case GFC_ISYM_POPCNT: + gfc_conv_intrinsic_popcnt_poppar (se, expr, 0); + break; + + case GFC_ISYM_POPPAR: + gfc_conv_intrinsic_popcnt_poppar (se, expr, 1); + break; + + case GFC_ISYM_LBOUND: + gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND); + break; + + case GFC_ISYM_LCOBOUND: + conv_intrinsic_cobound (se, expr); + break; + + case GFC_ISYM_TRANSPOSE: + /* The scalarizer has already been set up for reversed dimension access + order ; now we just get the argument value normally. */ + gfc_conv_expr (se, expr->value.function.actual->expr); + break; + + case GFC_ISYM_LEN: + gfc_conv_intrinsic_len (se, expr); + break; + + case GFC_ISYM_LEN_TRIM: + gfc_conv_intrinsic_len_trim (se, expr); + break; + + case GFC_ISYM_LGE: + gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR); + break; + + case GFC_ISYM_LGT: + gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR); + break; + + case GFC_ISYM_LLE: + gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR); + break; + + case GFC_ISYM_LLT: + gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR); + break; + + case GFC_ISYM_MALLOC: + gfc_conv_intrinsic_malloc (se, expr); + break; + + case GFC_ISYM_MASKL: + gfc_conv_intrinsic_mask (se, expr, 1); + break; + + case GFC_ISYM_MASKR: + gfc_conv_intrinsic_mask (se, expr, 0); + break; + + case GFC_ISYM_MAX: + if (expr->ts.type == BT_CHARACTER) + gfc_conv_intrinsic_minmax_char (se, expr, 1); + else + gfc_conv_intrinsic_minmax (se, expr, GT_EXPR); + break; + + case GFC_ISYM_MAXLOC: + gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); + break; + + case GFC_ISYM_FINDLOC: + gfc_conv_intrinsic_findloc (se, expr); + break; + + case GFC_ISYM_MAXVAL: + gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR); + break; + + case GFC_ISYM_MERGE: + gfc_conv_intrinsic_merge (se, expr); + break; + + case GFC_ISYM_MERGE_BITS: + gfc_conv_intrinsic_merge_bits (se, expr); + break; + + case GFC_ISYM_MIN: + if (expr->ts.type == BT_CHARACTER) + gfc_conv_intrinsic_minmax_char (se, expr, -1); + else + gfc_conv_intrinsic_minmax (se, expr, LT_EXPR); + break; + + case GFC_ISYM_MINLOC: + gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); + break; + + case GFC_ISYM_MINVAL: + gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR); + break; + + case GFC_ISYM_NEAREST: + gfc_conv_intrinsic_nearest (se, expr); + break; + + case GFC_ISYM_NORM2: + gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true); + break; + + case GFC_ISYM_NOT: + gfc_conv_intrinsic_not (se, expr); + break; + + case GFC_ISYM_OR: + gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); + break; + + case GFC_ISYM_PARITY: + gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false); + break; + + case GFC_ISYM_PRESENT: + gfc_conv_intrinsic_present (se, expr); + break; + + case GFC_ISYM_PRODUCT: + gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false); + break; + + case GFC_ISYM_RANK: + gfc_conv_intrinsic_rank (se, expr); + break; + + case GFC_ISYM_RRSPACING: + gfc_conv_intrinsic_rrspacing (se, expr); + break; + + case GFC_ISYM_SET_EXPONENT: + gfc_conv_intrinsic_set_exponent (se, expr); + break; + + case GFC_ISYM_SCALE: + gfc_conv_intrinsic_scale (se, expr); + break; + + case GFC_ISYM_SHAPE: + gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE); + break; + + case GFC_ISYM_SIGN: + gfc_conv_intrinsic_sign (se, expr); + break; + + case GFC_ISYM_SIZE: + gfc_conv_intrinsic_size (se, expr); + break; + + case GFC_ISYM_SIZEOF: + case GFC_ISYM_C_SIZEOF: + gfc_conv_intrinsic_sizeof (se, expr); + break; + + case GFC_ISYM_STORAGE_SIZE: + gfc_conv_intrinsic_storage_size (se, expr); + break; + + case GFC_ISYM_SPACING: + gfc_conv_intrinsic_spacing (se, expr); + break; + + case GFC_ISYM_STRIDE: + conv_intrinsic_stride (se, expr); + break; + + case GFC_ISYM_SUM: + gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false); + break; + + case GFC_ISYM_TEAM_NUMBER: + conv_intrinsic_team_number (se, expr); + break; + + case GFC_ISYM_TRANSFER: + if (se->ss && se->ss->info->useflags) + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + else + gfc_conv_intrinsic_transfer (se, expr); + break; + + case GFC_ISYM_TTYNAM: + gfc_conv_intrinsic_ttynam (se, expr); + break; + + case GFC_ISYM_UBOUND: + gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND); + break; + + case GFC_ISYM_UCOBOUND: + conv_intrinsic_cobound (se, expr); + break; + + case GFC_ISYM_XOR: + gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); + break; + + case GFC_ISYM_LOC: + gfc_conv_intrinsic_loc (se, expr); + break; + + case GFC_ISYM_THIS_IMAGE: + /* For num_images() == 1, handle as LCOBOUND. */ + if (expr->value.function.actual->expr + && flag_coarray == GFC_FCOARRAY_SINGLE) + conv_intrinsic_cobound (se, expr); + else + trans_this_image (se, expr); + break; + + case GFC_ISYM_IMAGE_INDEX: + trans_image_index (se, expr); + break; + + case GFC_ISYM_IMAGE_STATUS: + conv_intrinsic_image_status (se, expr); + break; + + case GFC_ISYM_NUM_IMAGES: + trans_num_images (se, expr); + break; + + case GFC_ISYM_ACCESS: + case GFC_ISYM_CHDIR: + case GFC_ISYM_CHMOD: + case GFC_ISYM_DTIME: + case GFC_ISYM_ETIME: + case GFC_ISYM_EXTENDS_TYPE_OF: + case GFC_ISYM_FGET: + case GFC_ISYM_FGETC: + case GFC_ISYM_FNUM: + case GFC_ISYM_FPUT: + case GFC_ISYM_FPUTC: + case GFC_ISYM_FSTAT: + case GFC_ISYM_FTELL: + case GFC_ISYM_GETCWD: + case GFC_ISYM_GETGID: + case GFC_ISYM_GETPID: + case GFC_ISYM_GETUID: + case GFC_ISYM_HOSTNM: + case GFC_ISYM_IERRNO: + case GFC_ISYM_IRAND: + case GFC_ISYM_ISATTY: + case GFC_ISYM_JN2: + case GFC_ISYM_LINK: + case GFC_ISYM_LSTAT: + case GFC_ISYM_MATMUL: + case GFC_ISYM_MCLOCK: + case GFC_ISYM_MCLOCK8: + case GFC_ISYM_RAND: + case GFC_ISYM_RENAME: + case GFC_ISYM_SECOND: + case GFC_ISYM_SECNDS: + case GFC_ISYM_SIGNAL: + case GFC_ISYM_STAT: + case GFC_ISYM_SYMLNK: + case GFC_ISYM_SYSTEM: + case GFC_ISYM_TIME: + case GFC_ISYM_TIME8: + case GFC_ISYM_UMASK: + case GFC_ISYM_UNLINK: + case GFC_ISYM_YN2: + gfc_conv_intrinsic_funcall (se, expr); + break; + + case GFC_ISYM_EOSHIFT: + case GFC_ISYM_PACK: + case GFC_ISYM_RESHAPE: + /* For those, expr->rank should always be >0 and thus the if above the + switch should have matched. */ + gcc_unreachable (); + break; + + default: + gfc_conv_intrinsic_lib_function (se, expr); + break; + } +} + + +static gfc_ss * +walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr) +{ + gfc_ss *arg_ss, *tmp_ss; + gfc_actual_arglist *arg; + + arg = expr->value.function.actual; + + gcc_assert (arg->expr); + + arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr); + gcc_assert (arg_ss != gfc_ss_terminator); + + for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next) + { + if (tmp_ss->info->type != GFC_SS_SCALAR + && tmp_ss->info->type != GFC_SS_REFERENCE) + { + gcc_assert (tmp_ss->dimen == 2); + + /* We just invert dimensions. */ + std::swap (tmp_ss->dim[0], tmp_ss->dim[1]); + } + + /* Stop when tmp_ss points to the last valid element of the chain... */ + if (tmp_ss->next == gfc_ss_terminator) + break; + } + + /* ... so that we can attach the rest of the chain to it. */ + tmp_ss->next = ss; + + return arg_ss; +} + + +/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list. + This has the side effect of reversing the nested list, so there is no + need to call gfc_reverse_ss on it (the given list is assumed not to be + reversed yet). */ + +static gfc_ss * +nest_loop_dimension (gfc_ss *ss, int dim) +{ + int ss_dim, i; + gfc_ss *new_ss, *prev_ss = gfc_ss_terminator; + gfc_loopinfo *new_loop; + + gcc_assert (ss != gfc_ss_terminator); + + for (; ss != gfc_ss_terminator; ss = ss->next) + { + new_ss = gfc_get_ss (); + new_ss->next = prev_ss; + new_ss->parent = ss; + new_ss->info = ss->info; + new_ss->info->refcount++; + if (ss->dimen != 0) + { + gcc_assert (ss->info->type != GFC_SS_SCALAR + && ss->info->type != GFC_SS_REFERENCE); + + new_ss->dimen = 1; + new_ss->dim[0] = ss->dim[dim]; + + gcc_assert (dim < ss->dimen); + + ss_dim = --ss->dimen; + for (i = dim; i < ss_dim; i++) + ss->dim[i] = ss->dim[i + 1]; + + ss->dim[ss_dim] = 0; + } + prev_ss = new_ss; + + if (ss->nested_ss) + { + ss->nested_ss->parent = new_ss; + new_ss->nested_ss = ss->nested_ss; + } + ss->nested_ss = new_ss; + } + + new_loop = gfc_get_loopinfo (); + gfc_init_loopinfo (new_loop); + + gcc_assert (prev_ss != NULL); + gcc_assert (prev_ss != gfc_ss_terminator); + gfc_add_ss_to_loop (new_loop, prev_ss); + return new_ss->parent; +} + + +/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function + is to be inlined. */ + +static gfc_ss * +walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr) +{ + gfc_ss *tmp_ss, *tail, *array_ss; + gfc_actual_arglist *arg1, *arg2, *arg3; + int sum_dim; + bool scalar_mask = false; + + /* The rank of the result will be determined later. */ + arg1 = expr->value.function.actual; + arg2 = arg1->next; + arg3 = arg2->next; + gcc_assert (arg3 != NULL); + + if (expr->rank == 0) + return ss; + + tmp_ss = gfc_ss_terminator; + + if (arg3->expr) + { + gfc_ss *mask_ss; + + mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr); + if (mask_ss == tmp_ss) + scalar_mask = 1; + + tmp_ss = mask_ss; + } + + array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr); + gcc_assert (array_ss != tmp_ss); + + /* Odd thing: If the mask is scalar, it is used by the frontend after + the array (to make an if around the nested loop). Thus it shall + be after array_ss once the gfc_ss list is reversed. */ + if (scalar_mask) + tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr); + else + tmp_ss = array_ss; + + /* "Hide" the dimension on which we will sum in the first arg's scalarization + chain. */ + sum_dim = mpz_get_si (arg2->expr->value.integer) - 1; + tail = nest_loop_dimension (tmp_ss, sum_dim); + tail->next = ss; + + return tmp_ss; +} + + +static gfc_ss * +walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr) +{ + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: + return walk_inline_intrinsic_arith (ss, expr); + + case GFC_ISYM_TRANSPOSE: + return walk_inline_intrinsic_transpose (ss, expr); + + default: + gcc_unreachable (); + } + gcc_unreachable (); +} + + +/* This generates code to execute before entering the scalarization loop. + Currently does nothing. */ + +void +gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) +{ + switch (ss->info->expr->value.function.isym->id) + { + case GFC_ISYM_UBOUND: + case GFC_ISYM_LBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_THIS_IMAGE: + case GFC_ISYM_SHAPE: + break; + + default: + gcc_unreachable (); + } +} + + +/* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with + one parameter are expanded into code inside the scalarization loop. */ + +static gfc_ss * +gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) +{ + if (expr->value.function.actual->expr->ts.type == BT_CLASS) + gfc_add_class_array_ref (expr->value.function.actual->expr); + + /* The two argument version returns a scalar. */ + if (expr->value.function.isym->id != GFC_ISYM_SHAPE + && expr->value.function.actual->next->expr) + return ss; + + return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC); +} + + +/* Walk an intrinsic array libcall. */ + +static gfc_ss * +gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) +{ + gcc_assert (expr->rank > 0); + return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); +} + + +/* Return whether the function call expression EXPR will be expanded + inline by gfc_conv_intrinsic_function. */ + +bool +gfc_inline_intrinsic_function_p (gfc_expr *expr) +{ + gfc_actual_arglist *args, *dim_arg, *mask_arg; + gfc_expr *maskexpr; + + if (!expr->value.function.isym) + return false; + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: + /* Disable inline expansion if code size matters. */ + if (optimize_size) + return false; + + args = expr->value.function.actual; + dim_arg = args->next; + + /* We need to be able to subset the SUM argument at compile-time. */ + if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT) + return false; + + /* FIXME: If MASK is optional for a more than two-dimensional + argument, the scalarizer gets confused if the mask is + absent. See PR 82995. For now, fall back to the library + function. */ + + mask_arg = dim_arg->next; + maskexpr = mask_arg->expr; + + if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional) + return false; + + return true; + + case GFC_ISYM_TRANSPOSE: + return true; + + default: + return false; + } +} + + +/* Returns nonzero if the specified intrinsic function call maps directly to + an external library call. Should only be used for functions that return + arrays. */ + +int +gfc_is_intrinsic_libcall (gfc_expr * expr) +{ + gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); + gcc_assert (expr->rank > 0); + + if (gfc_inline_intrinsic_function_p (expr)) + return 0; + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_ALL: + case GFC_ISYM_ANY: + case GFC_ISYM_COUNT: + case GFC_ISYM_FINDLOC: + case GFC_ISYM_JN2: + case GFC_ISYM_IANY: + case GFC_ISYM_IALL: + case GFC_ISYM_IPARITY: + case GFC_ISYM_MATMUL: + case GFC_ISYM_MAXLOC: + case GFC_ISYM_MAXVAL: + case GFC_ISYM_MINLOC: + case GFC_ISYM_MINVAL: + case GFC_ISYM_NORM2: + case GFC_ISYM_PARITY: + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: + case GFC_ISYM_SPREAD: + case GFC_ISYM_YN2: + /* Ignore absent optional parameters. */ + return 1; + + case GFC_ISYM_CSHIFT: + case GFC_ISYM_EOSHIFT: + case GFC_ISYM_GET_TEAM: + case GFC_ISYM_FAILED_IMAGES: + case GFC_ISYM_STOPPED_IMAGES: + case GFC_ISYM_PACK: + case GFC_ISYM_RESHAPE: + case GFC_ISYM_UNPACK: + /* Pass absent optional parameters. */ + return 2; + + default: + return 0; + } +} + +/* Walk an intrinsic function. */ +gfc_ss * +gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, + gfc_intrinsic_sym * isym) +{ + gcc_assert (isym); + + if (isym->elemental) + return gfc_walk_elemental_function_args (ss, expr->value.function.actual, + expr->value.function.isym, + GFC_SS_SCALAR); + + if (expr->rank == 0) + return ss; + + if (gfc_inline_intrinsic_function_p (expr)) + return walk_inline_intrinsic_function (ss, expr); + + if (gfc_is_intrinsic_libcall (expr)) + return gfc_walk_intrinsic_libfunc (ss, expr); + + /* Special cases. */ + switch (isym->id) + { + case GFC_ISYM_LBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_UBOUND: + case GFC_ISYM_UCOBOUND: + case GFC_ISYM_THIS_IMAGE: + case GFC_ISYM_SHAPE: + return gfc_walk_intrinsic_bound (ss, expr); + + case GFC_ISYM_TRANSFER: + case GFC_ISYM_CAF_GET: + return gfc_walk_intrinsic_libfunc (ss, expr); + + default: + /* This probably meant someone forgot to add an intrinsic to the above + list(s) when they implemented it, or something's gone horribly + wrong. */ + gcc_unreachable (); + } +} + +static tree +conv_co_collective (gfc_code *code) +{ + gfc_se argse; + stmtblock_t block, post_block; + tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len; + gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE) + { + opr_expr = code->ext.actual->next->expr; + image_idx_expr = code->ext.actual->next->next->expr; + stat_expr = code->ext.actual->next->next->next->expr; + errmsg_expr = code->ext.actual->next->next->next->next->expr; + } + else + { + opr_expr = NULL; + image_idx_expr = code->ext.actual->next->expr; + stat_expr = code->ext.actual->next->next->expr; + errmsg_expr = code->ext.actual->next->next->next->expr; + } + + /* stat. */ + if (stat_expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, stat_expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + stat = argse.expr; + if (flag_coarray != GFC_FCOARRAY_SINGLE) + stat = gfc_build_addr_expr (NULL_TREE, stat); + } + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + stat = NULL_TREE; + else + stat = null_pointer_node; + + /* Early exit for GFC_FCOARRAY_SINGLE. */ + if (flag_coarray == GFC_FCOARRAY_SINGLE) + { + if (stat != NULL_TREE) + { + /* For optional stats, check the pointer is valid before zero'ing. */ + if (gfc_expr_attr (stat_expr).optional) + { + tree tmp; + stmtblock_t ass_block; + gfc_start_block (&ass_block); + gfc_add_modify (&ass_block, stat, + fold_convert (TREE_TYPE (stat), + integer_zero_node)); + tmp = fold_build2 (NE_EXPR, logical_type_node, + gfc_build_addr_expr (NULL_TREE, stat), + null_pointer_node); + tmp = fold_build3 (COND_EXPR, void_type_node, tmp, + gfc_finish_block (&ass_block), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_modify (&block, stat, + fold_convert (TREE_TYPE (stat), integer_zero_node)); + } + return gfc_finish_block (&block); + } + + /* Handle the array. */ + gfc_init_se (&argse, NULL); + if (code->ext.actual->expr->rank == 0) + { + symbol_attribute attr; + gfc_clear_attr (&attr); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->ext.actual->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); + array = gfc_build_addr_expr (NULL_TREE, array); + } + else + { + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); + array = argse.expr; + } + + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + + if (code->ext.actual->expr->ts.type == BT_CHARACTER) + strlen = argse.string_length; + else + strlen = integer_zero_node; + + /* image_index. */ + if (image_idx_expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, image_idx_expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + image_index = fold_convert (integer_type_node, argse.expr); + } + else + image_index = integer_zero_node; + + /* errmsg. */ + if (errmsg_expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, errmsg_expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + errmsg = argse.expr; + errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + errmsg = null_pointer_node; + errmsg_len = build_zero_cst (size_type_node); + } + + /* Generate the function call. */ + switch (code->resolved_isym->id) + { + case GFC_ISYM_CO_BROADCAST: + fndecl = gfor_fndecl_co_broadcast; + break; + case GFC_ISYM_CO_MAX: + fndecl = gfor_fndecl_co_max; + break; + case GFC_ISYM_CO_MIN: + fndecl = gfor_fndecl_co_min; + break; + case GFC_ISYM_CO_REDUCE: + fndecl = gfor_fndecl_co_reduce; + break; + case GFC_ISYM_CO_SUM: + fndecl = gfor_fndecl_co_sum; + break; + default: + gcc_unreachable (); + } + + gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED + ? code->ext.actual->expr->ts.u.derived : NULL; + + if (derived && derived->attr.alloc_comp + && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) + /* The derived type has the attribute 'alloc_comp'. */ + { + tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr, + code->ext.actual->expr->rank, + image_index, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&block, tmp); + } + else + { + if (code->resolved_isym->id == GFC_ISYM_CO_SUM + || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) + fndecl = build_call_expr_loc (input_location, fndecl, 5, array, + image_index, stat, errmsg, errmsg_len); + else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE) + fndecl = build_call_expr_loc (input_location, fndecl, 6, array, + image_index, stat, errmsg, + strlen, errmsg_len); + else + { + tree opr, opr_flags; + + // FIXME: Handle TS29113's bind(C) strings with descriptor. + int opr_flag_int; + if (gfc_is_proc_ptr_comp (opr_expr)) + { + gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface; + opr_flag_int = sym->attr.dimension + || (sym->ts.type == BT_CHARACTER + && !sym->attr.is_bind_c) + ? GFC_CAF_BYREF : 0; + opr_flag_int |= opr_expr->ts.type == BT_CHARACTER + && !sym->attr.is_bind_c + ? GFC_CAF_HIDDENLEN : 0; + opr_flag_int |= sym->formal->sym->attr.value + ? GFC_CAF_ARG_VALUE : 0; + } + else + { + opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym) + ? GFC_CAF_BYREF : 0; + opr_flag_int |= opr_expr->ts.type == BT_CHARACTER + && !opr_expr->symtree->n.sym->attr.is_bind_c + ? GFC_CAF_HIDDENLEN : 0; + opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value + ? GFC_CAF_ARG_VALUE : 0; + } + opr_flags = build_int_cst (integer_type_node, opr_flag_int); + gfc_conv_expr (&argse, opr_expr); + opr = argse.expr; + fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, + opr_flags, image_index, stat, errmsg, + strlen, errmsg_len); + } + } + + gfc_add_expr_to_block (&block, fndecl); + gfc_add_block_to_block (&block, &post_block); + + return gfc_finish_block (&block); +} + + +static tree +conv_intrinsic_atomic_op (gfc_code *code) +{ + gfc_se argse; + tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE; + stmtblock_t block, post_block; + gfc_expr *atom_expr = code->ext.actual->expr; + gfc_expr *stat_expr; + built_in_function fn; + + if (atom_expr->expr_type == EXPR_FUNCTION + && atom_expr->value.function.isym + && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) + atom_expr = atom_expr->value.function.actual->expr; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, atom_expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + atom = argse.expr; + + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB + && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind) + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->ext.actual->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + value = argse.expr; + + switch (code->resolved_isym->id) + { + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_DEF: + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_XOR: + stat_expr = code->ext.actual->next->next->expr; + if (flag_coarray == GFC_FCOARRAY_LIB) + old = null_pointer_node; + break; + default: + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB) + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->ext.actual->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + old = argse.expr; + stat_expr = code->ext.actual->next->next->next->expr; + } + + /* STAT= */ + if (stat_expr != NULL) + { + gcc_assert (stat_expr->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB) + argse.want_pointer = 1; + gfc_conv_expr_val (&argse, stat_expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + stat = argse.expr; + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + stat = null_pointer_node; + + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree image_index, caf_decl, offset, token; + int op; + + switch (code->resolved_isym->id) + { + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_FETCH_ADD: + op = (int) GFC_CAF_ATOMIC_ADD; + break; + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_FETCH_AND: + op = (int) GFC_CAF_ATOMIC_AND; + break; + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_FETCH_OR: + op = (int) GFC_CAF_ATOMIC_OR; + break; + case GFC_ISYM_ATOMIC_XOR: + case GFC_ISYM_ATOMIC_FETCH_XOR: + op = (int) GFC_CAF_ATOMIC_XOR; + break; + case GFC_ISYM_ATOMIC_DEF: + op = 0; /* Unused. */ + break; + default: + gcc_unreachable (); + } + + caf_decl = gfc_get_tree_for_caf_expr (atom_expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + + if (gfc_is_coindexed (atom_expr)) + image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); + else + image_index = integer_zero_node; + + if (!POINTER_TYPE_P (TREE_TYPE (value))) + { + tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); + gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value)); + value = gfc_build_addr_expr (NULL_TREE, tmp); + } + + gfc_init_se (&argse, NULL); + gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom, + atom_expr); + + gfc_add_block_to_block (&block, &argse.pre); + if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7, + token, offset, image_index, value, stat, + build_int_cst (integer_type_node, + (int) atom_expr->ts.type), + build_int_cst (integer_type_node, + (int) atom_expr->ts.kind)); + else + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9, + build_int_cst (integer_type_node, op), + token, offset, image_index, value, old, stat, + build_int_cst (integer_type_node, + (int) atom_expr->ts.type), + build_int_cst (integer_type_node, + (int) atom_expr->ts.kind)); + + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &argse.post); + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); + } + + + switch (code->resolved_isym->id) + { + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_FETCH_ADD: + fn = BUILT_IN_ATOMIC_FETCH_ADD_N; + break; + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_FETCH_AND: + fn = BUILT_IN_ATOMIC_FETCH_AND_N; + break; + case GFC_ISYM_ATOMIC_DEF: + fn = BUILT_IN_ATOMIC_STORE_N; + break; + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_FETCH_OR: + fn = BUILT_IN_ATOMIC_FETCH_OR_N; + break; + case GFC_ISYM_ATOMIC_XOR: + case GFC_ISYM_ATOMIC_FETCH_XOR: + fn = BUILT_IN_ATOMIC_FETCH_XOR_N; + break; + default: + gcc_unreachable (); + } + + tmp = TREE_TYPE (TREE_TYPE (atom)); + fn = (built_in_function) ((int) fn + + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) + + 1); + tree itype = TREE_TYPE (TREE_TYPE (atom)); + tmp = builtin_decl_explicit (fn); + + switch (code->resolved_isym->id) + { + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_DEF: + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_XOR: + tmp = build_call_expr_loc (input_location, tmp, 3, atom, + fold_convert (itype, value), + build_int_cst (NULL, MEMMODEL_RELAXED)); + gfc_add_expr_to_block (&block, tmp); + break; + default: + tmp = build_call_expr_loc (input_location, tmp, 3, atom, + fold_convert (itype, value), + build_int_cst (NULL, MEMMODEL_RELAXED)); + gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp)); + break; + } + + if (stat != NULL_TREE) + gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); +} + + +static tree +conv_intrinsic_atomic_ref (gfc_code *code) +{ + gfc_se argse; + tree tmp, atom, value, stat = NULL_TREE; + stmtblock_t block, post_block; + built_in_function fn; + gfc_expr *atom_expr = code->ext.actual->next->expr; + + if (atom_expr->expr_type == EXPR_FUNCTION + && atom_expr->value.function.isym + && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) + atom_expr = atom_expr->value.function.actual->expr; + + gfc_start_block (&block); + gfc_init_block (&post_block); + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, atom_expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + atom = argse.expr; + + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB + && code->ext.actual->expr->ts.kind == atom_expr->ts.kind) + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->ext.actual->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + value = argse.expr; + + /* STAT= */ + if (code->ext.actual->next->next->expr != NULL) + { + gcc_assert (code->ext.actual->next->next->expr->expr_type + == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB) + argse.want_pointer = 1; + gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + stat = argse.expr; + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + stat = null_pointer_node; + + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree image_index, caf_decl, offset, token; + tree orig_value = NULL_TREE, vardecl = NULL_TREE; + + caf_decl = gfc_get_tree_for_caf_expr (atom_expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + + if (gfc_is_coindexed (atom_expr)) + image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); + else + image_index = integer_zero_node; + + gfc_init_se (&argse, NULL); + gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom, + atom_expr); + gfc_add_block_to_block (&block, &argse.pre); + + /* Different type, need type conversion. */ + if (!POINTER_TYPE_P (TREE_TYPE (value))) + { + vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); + orig_value = value; + value = gfc_build_addr_expr (NULL_TREE, vardecl); + } + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7, + token, offset, image_index, value, stat, + build_int_cst (integer_type_node, + (int) atom_expr->ts.type), + build_int_cst (integer_type_node, + (int) atom_expr->ts.kind)); + gfc_add_expr_to_block (&block, tmp); + if (vardecl != NULL_TREE) + gfc_add_modify (&block, orig_value, + fold_convert (TREE_TYPE (orig_value), vardecl)); + gfc_add_block_to_block (&block, &argse.post); + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); + } + + tmp = TREE_TYPE (TREE_TYPE (atom)); + fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N + + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) + + 1); + tmp = builtin_decl_explicit (fn); + tmp = build_call_expr_loc (input_location, tmp, 2, atom, + build_int_cst (integer_type_node, + MEMMODEL_RELAXED)); + gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp)); + + if (stat != NULL_TREE) + gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); +} + + +static tree +conv_intrinsic_atomic_cas (gfc_code *code) +{ + gfc_se argse; + tree tmp, atom, old, new_val, comp, stat = NULL_TREE; + stmtblock_t block, post_block; + built_in_function fn; + gfc_expr *atom_expr = code->ext.actual->expr; + + if (atom_expr->expr_type == EXPR_FUNCTION + && atom_expr->value.function.isym + && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) + atom_expr = atom_expr->value.function.actual->expr; + + gfc_init_block (&block); + gfc_init_block (&post_block); + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, atom_expr); + atom = argse.expr; + + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB) + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->ext.actual->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + old = argse.expr; + + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB) + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->ext.actual->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + comp = argse.expr; + + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB + && code->ext.actual->next->next->next->expr->ts.kind + == atom_expr->ts.kind) + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + new_val = argse.expr; + + /* STAT= */ + if (code->ext.actual->next->next->next->next->expr != NULL) + { + gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type + == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + if (flag_coarray == GFC_FCOARRAY_LIB) + argse.want_pointer = 1; + gfc_conv_expr_val (&argse, + code->ext.actual->next->next->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + stat = argse.expr; + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + stat = null_pointer_node; + + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree image_index, caf_decl, offset, token; + + caf_decl = gfc_get_tree_for_caf_expr (atom_expr); + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) + caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); + + if (gfc_is_coindexed (atom_expr)) + image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl); + else + image_index = integer_zero_node; + + if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old))) + { + tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new"); + gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val)); + new_val = gfc_build_addr_expr (NULL_TREE, tmp); + } + + /* Convert a constant to a pointer. */ + if (!POINTER_TYPE_P (TREE_TYPE (comp))) + { + tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp"); + gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp)); + comp = gfc_build_addr_expr (NULL_TREE, tmp); + } + + gfc_init_se (&argse, NULL); + gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom, + atom_expr); + gfc_add_block_to_block (&block, &argse.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9, + token, offset, image_index, old, comp, new_val, + stat, build_int_cst (integer_type_node, + (int) atom_expr->ts.type), + build_int_cst (integer_type_node, + (int) atom_expr->ts.kind)); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &argse.post); + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); + } + + tmp = TREE_TYPE (TREE_TYPE (atom)); + fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N + + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) + + 1); + tmp = builtin_decl_explicit (fn); + + gfc_add_modify (&block, old, comp); + tmp = build_call_expr_loc (input_location, tmp, 6, atom, + gfc_build_addr_expr (NULL, old), + fold_convert (TREE_TYPE (old), new_val), + boolean_false_node, + build_int_cst (NULL, MEMMODEL_RELAXED), + build_int_cst (NULL, MEMMODEL_RELAXED)); + gfc_add_expr_to_block (&block, tmp); + + if (stat != NULL_TREE) + gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0)); + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); +} + +static tree +conv_intrinsic_event_query (gfc_code *code) +{ + gfc_se se, argse; + tree stat = NULL_TREE, stat2 = NULL_TREE; + tree count = NULL_TREE, count2 = NULL_TREE; + + gfc_expr *event_expr = code->ext.actual->expr; + + if (code->ext.actual->next->next->expr) + { + gcc_assert (code->ext.actual->next->next->expr->expr_type + == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr); + stat = argse.expr; + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + stat = null_pointer_node; + + if (code->ext.actual->next->expr) + { + gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->ext.actual->next->expr); + count = argse.expr; + } + + gfc_start_block (&se.pre); + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree tmp, token, image_index; + tree index = build_zero_cst (gfc_array_index_type); + + if (event_expr->expr_type == EXPR_FUNCTION + && event_expr->value.function.isym + && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET) + event_expr = event_expr->value.function.actual->expr; + + tree caf_decl = gfc_get_tree_for_caf_expr (event_expr); + + if (event_expr->symtree->n.sym->ts.type != BT_DERIVED + || event_expr->symtree->n.sym->ts.u.derived->from_intmod + != INTMOD_ISO_FORTRAN_ENV + || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id + != ISOFORTRAN_EVENT_TYPE) + { + gfc_error ("Sorry, the event component of derived type at %L is not " + "yet supported", &event_expr->where); + return NULL_TREE; + } + + if (gfc_is_coindexed (event_expr)) + { + gfc_error ("The event variable at %L shall not be coindexed", + &event_expr->where); + return NULL_TREE; + } + + image_index = integer_zero_node; + + gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE, + event_expr); + + /* For arrays, obtain the array index. */ + if (gfc_expr_attr (event_expr).dimension) + { + tree desc, tmp, extent, lbound, ubound; + gfc_array_ref *ar, ar2; + int i; + + /* TODO: Extend this, once DT components are supported. */ + ar = &event_expr->ref->u.ar; + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + + gfc_init_se (&argse, NULL); + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, event_expr); + gfc_add_block_to_block (&se.pre, &argse.pre); + desc = argse.expr; + *ar = ar2; + + extent = build_one_cst (gfc_array_index_type); + for (i = 0; i < ar->dimen; i++) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); + gfc_add_block_to_block (&argse.pre, &argse.pre); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (lbound), argse.expr, lbound); + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), extent, tmp); + index = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (tmp), index, tmp); + if (i < ar->dimen - 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); + } + } + } + + if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node) + { + count2 = count; + count = gfc_create_var (integer_type_node, "count"); + } + + if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) + { + stat2 = stat; + stat = gfc_create_var (integer_type_node, "stat"); + } + + index = fold_convert (size_type_node, index); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5, + token, index, image_index, count + ? gfc_build_addr_expr (NULL, count) : count, + stat != null_pointer_node + ? gfc_build_addr_expr (NULL, stat) : stat); + gfc_add_expr_to_block (&se.pre, tmp); + + if (count2 != NULL_TREE) + gfc_add_modify (&se.pre, count2, + fold_convert (TREE_TYPE (count2), count)); + + if (stat2 != NULL_TREE) + gfc_add_modify (&se.pre, stat2, + fold_convert (TREE_TYPE (stat2), stat)); + + return gfc_finish_block (&se.pre); + } + + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->ext.actual->expr); + gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr)); + + if (stat != NULL_TREE) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); + + return gfc_finish_block (&se.pre); +} + + +/* This is a peculiar case because of the need to do dependency checking. + It is called via trans-stmt.c(gfc_trans_call), where it is picked out as + a special case and this function called instead of + gfc_conv_procedure_call. */ +void +gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args, + gfc_loopinfo *loop) +{ + gfc_actual_arglist *actual; + gfc_se argse[5]; + gfc_expr *arg[5]; + gfc_ss *lss; + int n; + + tree from, frompos, len, to, topos; + tree lenmask, oldbits, newbits, bitsize; + tree type, utype, above, mask1, mask2; + + if (loop) + lss = loop->ss; + else + lss = gfc_ss_terminator; + + actual = actual_args; + for (n = 0; n < 5; n++, actual = actual->next) + { + arg[n] = actual->expr; + gfc_init_se (&argse[n], NULL); + + if (lss != gfc_ss_terminator) + { + gfc_copy_loopinfo_to_se (&argse[n], loop); + /* Find the ss for the expression if it is there. */ + argse[n].ss = lss; + gfc_mark_ss_chain_used (lss, 1); + } + + gfc_conv_expr (&argse[n], arg[n]); + + if (loop) + lss = argse[n].ss; + } + + from = argse[0].expr; + frompos = argse[1].expr; + len = argse[2].expr; + to = argse[3].expr; + topos = argse[4].expr; + + /* The type of the result (TO). */ + type = TREE_TYPE (to); + bitsize = build_int_cst (integer_type_node, TYPE_PRECISION (type)); + + /* Optionally generate code for runtime argument check. */ + if (gfc_option.rtcheck & GFC_RTCHECK_BITS) + { + tree nbits, below, ccond; + tree fp = fold_convert (long_integer_type_node, frompos); + tree ln = fold_convert (long_integer_type_node, len); + tree tp = fold_convert (long_integer_type_node, topos); + below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, frompos, + build_int_cst (TREE_TYPE (frompos), 0)); + above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, frompos, + fold_convert (TREE_TYPE (frompos), bitsize)); + ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, ccond, &argse[1].pre, + &arg[1]->where, + "FROMPOS argument (%ld) out of range 0:%d " + "in intrinsic MVBITS", fp, bitsize); + below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, len, + build_int_cst (TREE_TYPE (len), 0)); + above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, len, + fold_convert (TREE_TYPE (len), bitsize)); + ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, ccond, &argse[2].pre, + &arg[2]->where, + "LEN argument (%ld) out of range 0:%d " + "in intrinsic MVBITS", ln, bitsize); + below = fold_build2_loc (input_location, LT_EXPR, + logical_type_node, topos, + build_int_cst (TREE_TYPE (topos), 0)); + above = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, topos, + fold_convert (TREE_TYPE (topos), bitsize)); + ccond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, below, above); + gfc_trans_runtime_check (true, false, ccond, &argse[4].pre, + &arg[4]->where, + "TOPOS argument (%ld) out of range 0:%d " + "in intrinsic MVBITS", tp, bitsize); + + /* The tests above ensure that FROMPOS, LEN and TOPOS fit into short + integers. Additions below cannot overflow. */ + nbits = fold_convert (long_integer_type_node, bitsize); + above = fold_build2_loc (input_location, PLUS_EXPR, + long_integer_type_node, fp, ln); + ccond = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, above, nbits); + gfc_trans_runtime_check (true, false, ccond, &argse[1].pre, + &arg[1]->where, + "FROMPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) " + "in intrinsic MVBITS", fp, ln, bitsize); + above = fold_build2_loc (input_location, PLUS_EXPR, + long_integer_type_node, tp, ln); + ccond = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, above, nbits); + gfc_trans_runtime_check (true, false, ccond, &argse[4].pre, + &arg[4]->where, + "TOPOS(%ld)+LEN(%ld)>BIT_SIZE(%d) " + "in intrinsic MVBITS", tp, ln, bitsize); + } + + for (n = 0; n < 5; n++) + { + gfc_add_block_to_block (&se->pre, &argse[n].pre); + gfc_add_block_to_block (&se->post, &argse[n].post); + } + + /* lenmask = (LEN >= bit_size (TYPE)) ? ~(TYPE)0 : ((TYPE)1 << LEN) - 1 */ + above = fold_build2_loc (input_location, GE_EXPR, logical_type_node, + len, fold_convert (TREE_TYPE (len), bitsize)); + mask1 = build_int_cst (type, -1); + mask2 = fold_build2_loc (input_location, LSHIFT_EXPR, type, + build_int_cst (type, 1), len); + mask2 = fold_build2_loc (input_location, MINUS_EXPR, type, + mask2, build_int_cst (type, 1)); + lenmask = fold_build3_loc (input_location, COND_EXPR, type, + above, mask1, mask2); + + /* newbits = (((UTYPE)(FROM) >> FROMPOS) & lenmask) << TOPOS. + * For valid frompos+len <= bit_size(FROM) the conversion to unsigned is + * not strictly necessary; artificial bits from rshift will be masked. */ + utype = unsigned_type_for (type); + newbits = fold_build2_loc (input_location, RSHIFT_EXPR, utype, + fold_convert (utype, from), frompos); + newbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, + fold_convert (type, newbits), lenmask); + newbits = fold_build2_loc (input_location, LSHIFT_EXPR, type, + newbits, topos); + + /* oldbits = TO & (~(lenmask << TOPOS)). */ + oldbits = fold_build2_loc (input_location, LSHIFT_EXPR, type, + lenmask, topos); + oldbits = fold_build1_loc (input_location, BIT_NOT_EXPR, type, oldbits); + oldbits = fold_build2_loc (input_location, BIT_AND_EXPR, type, oldbits, to); + + /* TO = newbits | oldbits. */ + se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type, + oldbits, newbits); + + /* Return the assignment. */ + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, to, se->expr); +} + + +static tree +conv_intrinsic_move_alloc (gfc_code *code) +{ + stmtblock_t block; + gfc_expr *from_expr, *to_expr; + gfc_expr *to_expr2, *from_expr2 = NULL; + gfc_se from_se, to_se; + tree tmp; + bool coarray; + + gfc_start_block (&block); + + from_expr = code->ext.actual->expr; + to_expr = code->ext.actual->next->expr; + + gfc_init_se (&from_se, NULL); + gfc_init_se (&to_se, NULL); + + gcc_assert (from_expr->ts.type != BT_CLASS + || to_expr->ts.type == BT_CLASS); + coarray = gfc_get_corank (from_expr) != 0; + + if (from_expr->rank == 0 && !coarray) + { + if (from_expr->ts.type != BT_CLASS) + from_expr2 = from_expr; + else + { + from_expr2 = gfc_copy_expr (from_expr); + gfc_add_data_component (from_expr2); + } + + if (to_expr->ts.type != BT_CLASS) + to_expr2 = to_expr; + else + { + to_expr2 = gfc_copy_expr (to_expr); + gfc_add_data_component (to_expr2); + } + + from_se.want_pointer = 1; + to_se.want_pointer = 1; + gfc_conv_expr (&from_se, from_expr2); + gfc_conv_expr (&to_se, to_expr2); + gfc_add_block_to_block (&block, &from_se.pre); + gfc_add_block_to_block (&block, &to_se.pre); + + /* Deallocate "to". */ + tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE, + true, to_expr, to_expr->ts); + gfc_add_expr_to_block (&block, tmp); + + /* Assign (_data) pointers. */ + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + + /* Set "from" to NULL. */ + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), null_pointer_node)); + + gfc_add_block_to_block (&block, &from_se.post); + gfc_add_block_to_block (&block, &to_se.post); + + /* Set _vptr. */ + if (to_expr->ts.type == BT_CLASS) + { + gfc_symbol *vtab; + + gfc_free_expr (to_expr2); + gfc_init_se (&to_se, NULL); + to_se.want_pointer = 1; + gfc_add_vptr_component (to_expr); + gfc_conv_expr (&to_se, to_expr); + + if (from_expr->ts.type == BT_CLASS) + { + if (UNLIMITED_POLY (from_expr)) + vtab = NULL; + else + { + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + } + + gfc_free_expr (from_expr2); + gfc_init_se (&from_se, NULL); + from_se.want_pointer = 1; + gfc_add_vptr_component (from_expr); + gfc_conv_expr (&from_se, from_expr); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), + from_se.expr)); + + /* Reset _vptr component to declared type. */ + if (vtab == NULL) + /* Unlimited polymorphic. */ + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), + null_pointer_node)); + else + { + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), tmp)); + } + } + else + { + vtab = gfc_find_vtab (&from_expr->ts); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), tmp)); + } + } + + if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) + { + gfc_add_modify_loc (input_location, &block, to_se.string_length, + fold_convert (TREE_TYPE (to_se.string_length), + from_se.string_length)); + if (from_expr->ts.deferred) + gfc_add_modify_loc (input_location, &block, from_se.string_length, + build_int_cst (TREE_TYPE (from_se.string_length), 0)); + } + + return gfc_finish_block (&block); + } + + /* Update _vptr component. */ + if (to_expr->ts.type == BT_CLASS) + { + gfc_symbol *vtab; + + to_se.want_pointer = 1; + to_expr2 = gfc_copy_expr (to_expr); + gfc_add_vptr_component (to_expr2); + gfc_conv_expr (&to_se, to_expr2); + + if (from_expr->ts.type == BT_CLASS) + { + if (UNLIMITED_POLY (from_expr)) + vtab = NULL; + else + { + vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + gcc_assert (vtab); + } + + from_se.want_pointer = 1; + from_expr2 = gfc_copy_expr (from_expr); + gfc_add_vptr_component (from_expr2); + gfc_conv_expr (&from_se, from_expr2); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), + from_se.expr)); + + /* Reset _vptr component to declared type. */ + if (vtab == NULL) + /* Unlimited polymorphic. */ + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), + null_pointer_node)); + else + { + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, from_se.expr, + fold_convert (TREE_TYPE (from_se.expr), tmp)); + } + } + else + { + vtab = gfc_find_vtab (&from_expr->ts); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), tmp)); + } + + gfc_free_expr (to_expr2); + gfc_init_se (&to_se, NULL); + + if (from_expr->ts.type == BT_CLASS) + { + gfc_free_expr (from_expr2); + gfc_init_se (&from_se, NULL); + } + } + + + /* Deallocate "to". */ + if (from_expr->rank == 0) + { + to_se.want_coarray = 1; + from_se.want_coarray = 1; + } + gfc_conv_expr_descriptor (&to_se, to_expr); + gfc_conv_expr_descriptor (&from_se, from_expr); + + /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC + is an image control "statement", cf. IR F08/0040 in 12-006A. */ + if (coarray && flag_coarray == GFC_FCOARRAY_LIB) + { + tree cond; + + tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, to_expr, + GFC_CAF_COARRAY_DEALLOCATE_ONLY); + gfc_add_expr_to_block (&block, tmp); + + tmp = gfc_conv_descriptor_data_get (to_se.expr); + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, tmp, + fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, null_pointer_node, null_pointer_node, + build_int_cst (integer_type_node, 0)); + + 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); + } + else + { + if (to_expr->ts.type == BT_DERIVED + && to_expr->ts.u.derived->attr.alloc_comp) + { + tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived, + to_se.expr, to_expr->rank); + gfc_add_expr_to_block (&block, tmp); + } + + tmp = gfc_conv_descriptor_data_get (to_se.expr); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, + NULL_TREE, true, to_expr, + GFC_CAF_COARRAY_NOCOARRAY); + gfc_add_expr_to_block (&block, tmp); + } + + /* Move the pointer and update the array descriptor data. */ + gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr); + + /* Set "from" to NULL. */ + tmp = gfc_conv_descriptor_data_get (from_se.expr); + gfc_add_modify_loc (input_location, &block, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); + + + if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) + { + gfc_add_modify_loc (input_location, &block, to_se.string_length, + fold_convert (TREE_TYPE (to_se.string_length), + from_se.string_length)); + if (from_expr->ts.deferred) + gfc_add_modify_loc (input_location, &block, from_se.string_length, + build_int_cst (TREE_TYPE (from_se.string_length), 0)); + } + + return gfc_finish_block (&block); +} + + +tree +gfc_conv_intrinsic_subroutine (gfc_code *code) +{ + tree res; + + gcc_assert (code->resolved_isym); + + switch (code->resolved_isym->id) + { + case GFC_ISYM_MOVE_ALLOC: + res = conv_intrinsic_move_alloc (code); + break; + + case GFC_ISYM_ATOMIC_CAS: + res = conv_intrinsic_atomic_cas (code); + break; + + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_DEF: + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_XOR: + case GFC_ISYM_ATOMIC_FETCH_ADD: + case GFC_ISYM_ATOMIC_FETCH_AND: + case GFC_ISYM_ATOMIC_FETCH_OR: + case GFC_ISYM_ATOMIC_FETCH_XOR: + res = conv_intrinsic_atomic_op (code); + break; + + case GFC_ISYM_ATOMIC_REF: + res = conv_intrinsic_atomic_ref (code); + break; + + case GFC_ISYM_EVENT_QUERY: + res = conv_intrinsic_event_query (code); + break; + + case GFC_ISYM_C_F_POINTER: + case GFC_ISYM_C_F_PROCPOINTER: + res = conv_isocbinding_subroutine (code); + break; + + case GFC_ISYM_CAF_SEND: + res = conv_caf_send (code); + break; + + case GFC_ISYM_CO_BROADCAST: + case GFC_ISYM_CO_MIN: + case GFC_ISYM_CO_MAX: + case GFC_ISYM_CO_REDUCE: + case GFC_ISYM_CO_SUM: + res = conv_co_collective (code); + break; + + case GFC_ISYM_FREE: + res = conv_intrinsic_free (code); + break; + + case GFC_ISYM_RANDOM_INIT: + res = conv_intrinsic_random_init (code); + break; + + case GFC_ISYM_KILL: + res = conv_intrinsic_kill_sub (code); + break; + + case GFC_ISYM_MVBITS: + res = NULL_TREE; + break; + + case GFC_ISYM_SYSTEM_CLOCK: + res = conv_intrinsic_system_clock (code); + break; + + default: + res = NULL_TREE; + break; + } + + return res; +} + +#include "gt-fortran-trans-intrinsic.h" diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c deleted file mode 100644 index 033b102..0000000 --- a/gcc/fortran/trans-io.c +++ /dev/null @@ -1,2686 +0,0 @@ -/* IO Code translation/library interface - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "tree.h" -#include "gfortran.h" -#include "trans.h" -#include "stringpool.h" -#include "fold-const.h" -#include "stor-layout.h" -#include "trans-stmt.h" -#include "trans-array.h" -#include "trans-types.h" -#include "trans-const.h" -#include "options.h" - -/* Members of the ioparm structure. */ - -enum ioparam_type -{ - IOPARM_ptype_common, - IOPARM_ptype_open, - IOPARM_ptype_close, - IOPARM_ptype_filepos, - IOPARM_ptype_inquire, - IOPARM_ptype_dt, - IOPARM_ptype_wait, - IOPARM_ptype_num -}; - -enum iofield_type -{ - IOPARM_type_int4, - IOPARM_type_intio, - IOPARM_type_pint4, - IOPARM_type_pintio, - IOPARM_type_pchar, - IOPARM_type_parray, - IOPARM_type_pad, - IOPARM_type_char1, - IOPARM_type_char2, - IOPARM_type_common, - IOPARM_type_num -}; - -typedef struct GTY(()) gfc_st_parameter_field { - const char *name; - unsigned int mask; - enum ioparam_type param_type; - enum iofield_type type; - tree field; - tree field_len; -} -gfc_st_parameter_field; - -typedef struct GTY(()) gfc_st_parameter { - const char *name; - tree type; -} -gfc_st_parameter; - -enum iofield -{ -#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name, -#include "ioparm.def" -#undef IOPARM - IOPARM_field_num -}; - -static GTY(()) gfc_st_parameter st_parameter[] = -{ - { "common", NULL }, - { "open", NULL }, - { "close", NULL }, - { "filepos", NULL }, - { "inquire", NULL }, - { "dt", NULL }, - { "wait", NULL } -}; - -static GTY(()) gfc_st_parameter_field st_parameter_field[] = -{ -#define IOPARM(param_type, name, mask, type) \ - { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL }, -#include "ioparm.def" -#undef IOPARM - { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL } -}; - -/* Library I/O subroutines */ - -enum iocall -{ - IOCALL_READ, - IOCALL_READ_DONE, - IOCALL_WRITE, - IOCALL_WRITE_DONE, - IOCALL_X_INTEGER, - IOCALL_X_INTEGER_WRITE, - IOCALL_X_LOGICAL, - IOCALL_X_LOGICAL_WRITE, - IOCALL_X_CHARACTER, - IOCALL_X_CHARACTER_WRITE, - IOCALL_X_CHARACTER_WIDE, - IOCALL_X_CHARACTER_WIDE_WRITE, - IOCALL_X_REAL, - IOCALL_X_REAL_WRITE, - IOCALL_X_COMPLEX, - IOCALL_X_COMPLEX_WRITE, - IOCALL_X_REAL128, - IOCALL_X_REAL128_WRITE, - IOCALL_X_COMPLEX128, - IOCALL_X_COMPLEX128_WRITE, - IOCALL_X_ARRAY, - IOCALL_X_ARRAY_WRITE, - IOCALL_X_DERIVED, - IOCALL_OPEN, - IOCALL_CLOSE, - IOCALL_INQUIRE, - IOCALL_IOLENGTH, - IOCALL_IOLENGTH_DONE, - IOCALL_REWIND, - IOCALL_BACKSPACE, - IOCALL_ENDFILE, - IOCALL_FLUSH, - IOCALL_SET_NML_VAL, - IOCALL_SET_NML_DTIO_VAL, - IOCALL_SET_NML_VAL_DIM, - IOCALL_WAIT, - IOCALL_NUM -}; - -static GTY(()) tree iocall[IOCALL_NUM]; - -/* Variable for keeping track of what the last data transfer statement - was. Used for deciding which subroutine to call when the data - transfer is complete. */ -static enum { READ, WRITE, IOLENGTH } last_dt; - -/* The data transfer parameter block that should be shared by all - data transfer calls belonging to the same read/write/iolength. */ -static GTY(()) tree dt_parm; -static stmtblock_t *dt_post_end_block; - -static void -gfc_build_st_parameter (enum ioparam_type ptype, tree *types) -{ - unsigned int type; - gfc_st_parameter_field *p; - char name[64]; - size_t len; - tree t = make_node (RECORD_TYPE); - tree *chain = NULL; - - len = strlen (st_parameter[ptype].name); - gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_")); - memcpy (name, "__st_parameter_", sizeof ("__st_parameter_")); - memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name, - len + 1); - TYPE_NAME (t) = get_identifier (name); - - for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++) - if (p->param_type == ptype) - switch (p->type) - { - case IOPARM_type_int4: - case IOPARM_type_intio: - case IOPARM_type_pint4: - case IOPARM_type_pintio: - case IOPARM_type_parray: - case IOPARM_type_pchar: - case IOPARM_type_pad: - p->field = gfc_add_field_to_struct (t, get_identifier (p->name), - types[p->type], &chain); - break; - case IOPARM_type_char1: - p->field = gfc_add_field_to_struct (t, get_identifier (p->name), - pchar_type_node, &chain); - /* FALLTHROUGH */ - case IOPARM_type_char2: - len = strlen (p->name); - gcc_assert (len <= sizeof (name) - sizeof ("_len")); - memcpy (name, p->name, len); - memcpy (name + len, "_len", sizeof ("_len")); - p->field_len = gfc_add_field_to_struct (t, get_identifier (name), - gfc_charlen_type_node, - &chain); - if (p->type == IOPARM_type_char2) - p->field = gfc_add_field_to_struct (t, get_identifier (p->name), - pchar_type_node, &chain); - break; - case IOPARM_type_common: - p->field - = gfc_add_field_to_struct (t, - get_identifier (p->name), - st_parameter[IOPARM_ptype_common].type, - &chain); - break; - case IOPARM_type_num: - gcc_unreachable (); - } - - /* -Wpadded warnings on these artificially created structures are not - helpful; suppress them. */ - int save_warn_padded = warn_padded; - warn_padded = 0; - gfc_finish_type (t); - warn_padded = save_warn_padded; - st_parameter[ptype].type = t; -} - - -/* Build code to test an error condition and call generate_error if needed. - Note: This builds calls to generate_error in the runtime library function. - The function generate_error is dependent on certain parameters in the - st_parameter_common flags to be set. (See libgfortran/runtime/error.c) - Therefore, the code to set these flags must be generated before - this function is used. */ - -static void -gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var, - int error_code, const char * msgid, - stmtblock_t * pblock) -{ - stmtblock_t block; - tree body; - tree tmp; - tree arg1, arg2, arg3; - char *message; - - if (integer_zerop (cond)) - return; - - /* The code to generate the error. */ - gfc_start_block (&block); - - if (has_iostat) - gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO, - NOT_TAKEN)); - else - gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN, - NOT_TAKEN)); - - arg1 = gfc_build_addr_expr (NULL_TREE, var); - - arg2 = build_int_cst (integer_type_node, error_code), - - message = xasprintf ("%s", _(msgid)); - arg3 = gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const (message)); - free (message); - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_generate_error, 3, arg1, arg2, arg3); - - gfc_add_expr_to_block (&block, tmp); - - body = gfc_finish_block (&block); - - if (integer_onep (cond)) - { - gfc_add_expr_to_block (pblock, body); - } - else - { - tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location)); - gfc_add_expr_to_block (pblock, tmp); - } -} - - -/* Create function decls for IO library functions. */ - -void -gfc_build_io_library_fndecls (void) -{ - tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node; - tree gfc_intio_type_node; - tree parm_type, dt_parm_type; - HOST_WIDE_INT pad_size; - unsigned int ptype; - - types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4); - types[IOPARM_type_intio] = gfc_intio_type_node - = gfc_get_int_type (gfc_intio_kind); - types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node); - types[IOPARM_type_pintio] - = build_pointer_type (gfc_intio_type_node); - types[IOPARM_type_parray] = pchar_type_node; - types[IOPARM_type_pchar] = pchar_type_node; - pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node)); - pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node)); - pad_idx = build_index_type (size_int (pad_size - 1)); - types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx); - - /* pad actually contains pointers and integers so it needs to have an - alignment that is at least as large as the needed alignment for those - types. See the st_parameter_dt structure in libgfortran/io/io.h for - what really goes into this space. */ - SET_TYPE_ALIGN (types[IOPARM_type_pad], MAX (TYPE_ALIGN (pchar_type_node), - TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)))); - - for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) - gfc_build_st_parameter ((enum ioparam_type) ptype, types); - - /* Define the transfer functions. */ - - dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type); - - iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_integer")), ". w W . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_integer_write")), ". w R . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_logical")), ". w W . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_logical_write")), ". w R . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_character")), ". w W . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); - - iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_character_write")), ". w R . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); - - iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_character_wide")), ". w W . . ", - void_type_node, 4, dt_parm_type, pvoid_type_node, - gfc_charlen_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_CHARACTER_WIDE_WRITE] = - gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_character_wide_write")), ". w R . . ", - void_type_node, 4, dt_parm_type, pvoid_type_node, - gfc_charlen_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_real")), ". w W . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_real_write")), ". w R . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_complex")), ". w W . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_complex_write")), ". w R . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - /* Version for __float128. */ - iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_real128")), ". w W . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_real128_write")), ". w R . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_complex128")), ". w W . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_complex128_write")), ". w R . ", - void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_array")), ". w w . . ", - void_type_node, 4, dt_parm_type, pvoid_type_node, - integer_type_node, gfc_charlen_type_node); - - iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_array_write")), ". w r . . ", - void_type_node, 4, dt_parm_type, pvoid_type_node, - integer_type_node, gfc_charlen_type_node); - - iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("transfer_derived")), ". w r ", - void_type_node, 2, dt_parm_type, pvoid_type_node); - - /* Library entry points */ - - iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_read")), ". w ", - void_type_node, 1, dt_parm_type); - - iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_write")), ". w ", - void_type_node, 1, dt_parm_type); - - parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type); - iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_open")), ". w ", - void_type_node, 1, parm_type); - - parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type); - iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_close")), ". w ", - void_type_node, 1, parm_type); - - parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type); - iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_inquire")), ". w ", - void_type_node, 1, parm_type); - - iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec( - get_identifier (PREFIX("st_iolength")), ". w ", - void_type_node, 1, dt_parm_type); - - parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); - iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_wait_async")), ". w ", - void_type_node, 1, parm_type); - - parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); - iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_rewind")), ". w ", - void_type_node, 1, parm_type); - - iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_backspace")), ". w ", - void_type_node, 1, parm_type); - - iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_endfile")), ". w ", - void_type_node, 1, parm_type); - - iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_flush")), ". w ", - void_type_node, 1, parm_type); - - /* Library helpers */ - - iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_read_done")), ". w ", - void_type_node, 1, dt_parm_type); - - iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_write_done")), ". w ", - void_type_node, 1, dt_parm_type); - - iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_iolength_done")), ". w ", - void_type_node, 1, dt_parm_type); - - iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_set_nml_var")), ". w . R . . . ", - void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node()); - - iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_set_nml_dtio_var")), ". w . R . . . . . ", - void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node(), - pvoid_type_node, pvoid_type_node); - - iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("st_set_nml_var_dim")), ". w . . . . ", - void_type_node, 5, dt_parm_type, gfc_int4_type_node, - gfc_array_index_type, gfc_array_index_type, gfc_array_index_type); -} - - -static void -set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value) -{ - tree tmp; - gfc_st_parameter_field *p = &st_parameter_field[type]; - - if (p->param_type == IOPARM_ptype_common) - var = fold_build3_loc (input_location, COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); - gfc_add_modify (block, tmp, value); -} - - -/* Generate code to store an integer constant into the - st_parameter_XXX structure. */ - -static unsigned int -set_parameter_const (stmtblock_t *block, tree var, enum iofield type, - unsigned int val) -{ - gfc_st_parameter_field *p = &st_parameter_field[type]; - - set_parameter_tree (block, var, type, - build_int_cst (TREE_TYPE (p->field), val)); - return p->mask; -} - - -/* Generate code to store a non-string I/O parameter into the - st_parameter_XXX structure. This is a pass by value. */ - -static unsigned int -set_parameter_value (stmtblock_t *block, tree var, enum iofield type, - gfc_expr *e) -{ - gfc_se se; - tree tmp; - gfc_st_parameter_field *p = &st_parameter_field[type]; - tree dest_type = TREE_TYPE (p->field); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, e); - - se.expr = convert (dest_type, se.expr); - gfc_add_block_to_block (block, &se.pre); - - if (p->param_type == IOPARM_ptype_common) - var = fold_build3_loc (input_location, COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - - tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, - p->field, NULL_TREE); - gfc_add_modify (block, tmp, se.expr); - return p->mask; -} - - -/* Similar to set_parameter_value except generate runtime - error checks. */ - -static unsigned int -set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var, - enum iofield type, gfc_expr *e) -{ - gfc_se se; - tree tmp; - gfc_st_parameter_field *p = &st_parameter_field[type]; - tree dest_type = TREE_TYPE (p->field); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, e); - - /* If we're storing a UNIT number, we need to check it first. */ - if (type == IOPARM_common_unit && e->ts.kind > 4) - { - tree cond, val; - int i; - - /* Don't evaluate the UNIT number multiple times. */ - se.expr = gfc_evaluate_now (se.expr, &se.pre); - - /* UNIT numbers should be greater than the min. */ - i = gfc_validate_kind (BT_INTEGER, 4, false); - val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - se.expr, - fold_convert (TREE_TYPE (se.expr), val)); - gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, - "Unit number in I/O statement too small", - &se.pre); - - /* UNIT numbers should be less than the max. */ - val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - se.expr, - fold_convert (TREE_TYPE (se.expr), val)); - gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, - "Unit number in I/O statement too large", - &se.pre); - } - - se.expr = convert (dest_type, se.expr); - gfc_add_block_to_block (block, &se.pre); - - if (p->param_type == IOPARM_ptype_common) - var = fold_build3_loc (input_location, COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - - tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, - p->field, NULL_TREE); - gfc_add_modify (block, tmp, se.expr); - return p->mask; -} - - -/* Build code to check the unit range if KIND=8 is used. Similar to - set_parameter_value_chk but we do not generate error calls for - inquire statements. */ - -static unsigned int -set_parameter_value_inquire (stmtblock_t *block, tree var, - enum iofield type, gfc_expr *e) -{ - gfc_se se; - gfc_st_parameter_field *p = &st_parameter_field[type]; - tree dest_type = TREE_TYPE (p->field); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, e); - - /* If we're inquiring on a UNIT number, we need to check to make - sure it exists for larger than kind = 4. */ - if (type == IOPARM_common_unit && e->ts.kind > 4) - { - stmtblock_t newblock; - tree cond1, cond2, cond3, val, body; - int i; - - /* Don't evaluate the UNIT number multiple times. */ - se.expr = gfc_evaluate_now (se.expr, &se.pre); - - /* UNIT numbers should be greater than the min. */ - i = gfc_validate_kind (BT_INTEGER, 4, false); - val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); - cond1 = build2_loc (input_location, LT_EXPR, logical_type_node, - se.expr, - fold_convert (TREE_TYPE (se.expr), val)); - /* UNIT numbers should be less than the max. */ - val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); - cond2 = build2_loc (input_location, GT_EXPR, logical_type_node, - se.expr, - fold_convert (TREE_TYPE (se.expr), val)); - cond3 = build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond1, cond2); - - gfc_start_block (&newblock); - - /* The unit number GFC_INVALID_UNIT is reserved. No units can - ever have this value. It is used here to signal to the - runtime library that the inquire unit number is outside the - allowable range and so cannot exist. It is needed when - -fdefault-integer-8 is used. */ - set_parameter_const (&newblock, var, IOPARM_common_unit, - GFC_INVALID_UNIT); - - body = gfc_finish_block (&newblock); - - cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO); - var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se.pre, var); - } - - se.expr = convert (dest_type, se.expr); - gfc_add_block_to_block (block, &se.pre); - - return p->mask; -} - - -/* Generate code to store a non-string I/O parameter into the - st_parameter_XXX structure. This is pass by reference. */ - -static unsigned int -set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, - tree var, enum iofield type, gfc_expr *e) -{ - gfc_se se; - tree tmp, addr; - gfc_st_parameter_field *p = &st_parameter_field[type]; - - gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL); - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, e); - - gfc_add_block_to_block (block, &se.pre); - - if (TYPE_MODE (TREE_TYPE (se.expr)) - == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field)))) - { - addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr)); - - /* If this is for the iostat variable initialize the - user variable to LIBERROR_OK which is zero. */ - if (type == IOPARM_common_iostat) - gfc_add_modify (block, se.expr, - build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK)); - } - else - { - /* The type used by the library has different size - from the type of the variable supplied by the user. - Need to use a temporary. */ - tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)), - st_parameter_field[type].name); - - /* If this is for the iostat variable, initialize the - user variable to LIBERROR_OK which is zero. */ - if (type == IOPARM_common_iostat) - gfc_add_modify (block, tmpvar, - build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK)); - - addr = gfc_build_addr_expr (NULL_TREE, tmpvar); - /* After the I/O operation, we set the variable from the temporary. */ - tmp = convert (TREE_TYPE (se.expr), tmpvar); - gfc_add_modify (postblock, se.expr, tmp); - } - - set_parameter_tree (block, var, type, addr); - return p->mask; -} - -/* Given an array expr, find its address and length to get a string. If the - array is full, the string's address is the address of array's first element - and the length is the size of the whole array. If it is an element, the - string's address is the element's address and the length is the rest size of - the array. */ - -static void -gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) -{ - tree size; - - if (e->rank == 0) - { - tree type, array, tmp; - gfc_symbol *sym; - int rank; - - /* If it is an element, we need its address and size of the rest. */ - gcc_assert (e->expr_type == EXPR_VARIABLE); - gcc_assert (e->ref->u.ar.type == AR_ELEMENT); - sym = e->symtree->n.sym; - rank = sym->as->rank - 1; - gfc_conv_expr (se, e); - - array = sym->backend_decl; - type = TREE_TYPE (array); - - if (GFC_ARRAY_TYPE_P (type)) - size = GFC_TYPE_ARRAY_SIZE (type); - else - { - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - size = gfc_conv_array_stride (array, rank); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_array_ubound (array, rank), - gfc_conv_array_lbound (array, rank)); - 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, tmp, size); - } - gcc_assert (size); - - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, size, - TREE_OPERAND (se->expr, 1)); - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, - fold_convert (gfc_array_index_type, tmp)); - se->string_length = fold_convert (gfc_charlen_type_node, size); - return; - } - - gfc_conv_array_parameter (se, e, true, NULL, NULL, &size); - se->string_length = fold_convert (gfc_charlen_type_node, size); -} - - -/* Generate code to store a string and its length into the - st_parameter_XXX structure. */ - -static unsigned int -set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, - enum iofield type, gfc_expr * e) -{ - gfc_se se; - tree tmp; - tree io; - tree len; - gfc_st_parameter_field *p = &st_parameter_field[type]; - - gfc_init_se (&se, NULL); - - if (p->param_type == IOPARM_ptype_common) - var = fold_build3_loc (input_location, COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); - len = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (p->field_len), - var, p->field_len, NULL_TREE); - - /* Integer variable assigned a format label. */ - if (e->ts.type == BT_INTEGER - && e->rank == 0 - && e->symtree->n.sym->attr.assign == 1) - { - char * msg; - tree cond; - - gfc_conv_label_variable (&se, e); - tmp = GFC_DECL_STRING_LEN (se.expr); - cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), 0)); - - msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format " - "label", e->symtree->name); - gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg, - fold_convert (long_integer_type_node, tmp)); - free (msg); - - gfc_add_modify (&se.pre, io, - fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); - gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); - } - else - { - /* General character. */ - if (e->ts.type == BT_CHARACTER && e->rank == 0) - gfc_conv_expr (&se, e); - /* Array assigned Hollerith constant or character array. */ - else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0)) - gfc_convert_array_to_string (&se, e); - else - gcc_unreachable (); - - gfc_conv_string_parameter (&se); - gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); - gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), - se.string_length)); - } - - gfc_add_block_to_block (block, &se.pre); - gfc_add_block_to_block (postblock, &se.post); - return p->mask; -} - - -/* Generate code to store the character (array) and the character length - for an internal unit. */ - -static unsigned int -set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, - tree var, gfc_expr * e) -{ - gfc_se se; - tree io; - tree len; - tree desc; - tree tmp; - gfc_st_parameter_field *p; - unsigned int mask; - - gfc_init_se (&se, NULL); - - p = &st_parameter_field[IOPARM_dt_internal_unit]; - mask = p->mask; - io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); - len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len), - var, p->field_len, NULL_TREE); - p = &st_parameter_field[IOPARM_dt_internal_unit_desc]; - desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); - - gcc_assert (e->ts.type == BT_CHARACTER); - - /* Character scalars. */ - if (e->rank == 0) - { - gfc_conv_expr (&se, e); - gfc_conv_string_parameter (&se); - tmp = se.expr; - se.expr = build_int_cst (pchar_type_node, 0); - } - - /* Character array. */ - else if (e->rank > 0) - { - if (is_subref_array (e)) - { - /* Use a temporary for components of arrays of derived types - or substring array references. */ - gfc_conv_subref_array_arg (&se, e, 0, - last_dt == READ ? INTENT_IN : INTENT_OUT, false); - tmp = build_fold_indirect_ref_loc (input_location, - se.expr); - se.expr = gfc_build_addr_expr (pchar_type_node, tmp); - tmp = gfc_conv_descriptor_data_get (tmp); - } - else - { - /* Return the data pointer and rank from the descriptor. */ - gfc_conv_expr_descriptor (&se, e); - tmp = gfc_conv_descriptor_data_get (se.expr); - se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); - } - } - else - gcc_unreachable (); - - /* The cast is needed for character substrings and the descriptor - data. */ - gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp)); - gfc_add_modify (&se.pre, len, - fold_convert (TREE_TYPE (len), se.string_length)); - gfc_add_modify (&se.pre, desc, se.expr); - - gfc_add_block_to_block (block, &se.pre); - gfc_add_block_to_block (post_block, &se.post); - return mask; -} - -/* Add a case to a IO-result switch. */ - -static void -add_case (int label_value, gfc_st_label * label, stmtblock_t * body) -{ - tree tmp, value; - - if (label == NULL) - return; /* No label, no case */ - - value = build_int_cst (integer_type_node, label_value); - - /* Make a backend label for this case. */ - tmp = gfc_build_label_decl (NULL_TREE); - - /* And the case itself. */ - tmp = build_case_label (value, NULL_TREE, tmp); - gfc_add_expr_to_block (body, tmp); - - /* Jump to the label. */ - tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label)); - gfc_add_expr_to_block (body, tmp); -} - - -/* Generate a switch statement that branches to the correct I/O - result label. The last statement of an I/O call stores the - result into a variable because there is often cleanup that - must be done before the switch, so a temporary would have to - be created anyway. */ - -static void -io_result (stmtblock_t * block, tree var, gfc_st_label * err_label, - gfc_st_label * end_label, gfc_st_label * eor_label) -{ - stmtblock_t body; - tree tmp, rc; - gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; - - /* If no labels are specified, ignore the result instead - of building an empty switch. */ - if (err_label == NULL - && end_label == NULL - && eor_label == NULL) - return; - - /* Build a switch statement. */ - gfc_start_block (&body); - - /* The label values here must be the same as the values - in the library_return enum in the runtime library */ - add_case (1, err_label, &body); - add_case (2, end_label, &body); - add_case (3, eor_label, &body); - - tmp = gfc_finish_block (&body); - - var = fold_build3_loc (input_location, COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), - var, p->field, NULL_TREE); - rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc), - rc, build_int_cst (TREE_TYPE (rc), - IOPARM_common_libreturn_mask)); - - tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, rc, tmp); - - gfc_add_expr_to_block (block, tmp); -} - - -/* Store the current file and line number to variables so that if a - library call goes awry, we can tell the user where the problem is. */ - -static void -set_error_locus (stmtblock_t * block, tree var, locus * where) -{ - gfc_file *f; - tree str, locus_file; - int line; - gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename]; - - locus_file = fold_build3_loc (input_location, COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - locus_file = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (p->field), locus_file, - p->field, NULL_TREE); - f = where->lb->file; - str = gfc_build_cstring_const (f->filename); - - str = gfc_build_addr_expr (pchar_type_node, str); - gfc_add_modify (block, locus_file, str); - - line = LOCATION_LINE (where->lb->location); - set_parameter_const (block, var, IOPARM_common_line, line); -} - - -/* Translate an OPEN statement. */ - -tree -gfc_trans_open (gfc_code * code) -{ - stmtblock_t block, post_block; - gfc_open *p; - tree tmp, var; - unsigned int mask = 0; - - gfc_start_block (&block); - gfc_init_block (&post_block); - - var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm"); - - set_error_locus (&block, var, &code->loc); - p = code->ext.open; - - if (p->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - p->iomsg); - - if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); - - if (p->err) - mask |= IOPARM_common_err; - - if (p->file) - mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file); - - if (p->status) - mask |= set_string (&block, &post_block, var, IOPARM_open_status, - p->status); - - if (p->access) - mask |= set_string (&block, &post_block, var, IOPARM_open_access, - p->access); - - if (p->form) - mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form); - - if (p->recl) - mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, - p->recl); - - if (p->blank) - mask |= set_string (&block, &post_block, var, IOPARM_open_blank, - p->blank); - - if (p->position) - mask |= set_string (&block, &post_block, var, IOPARM_open_position, - p->position); - - if (p->action) - mask |= set_string (&block, &post_block, var, IOPARM_open_action, - p->action); - - if (p->delim) - mask |= set_string (&block, &post_block, var, IOPARM_open_delim, - p->delim); - - if (p->pad) - mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); - - if (p->decimal) - mask |= set_string (&block, &post_block, var, IOPARM_open_decimal, - p->decimal); - - if (p->encoding) - mask |= set_string (&block, &post_block, var, IOPARM_open_encoding, - p->encoding); - - if (p->round) - mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round); - - if (p->sign) - mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign); - - if (p->asynchronous) - mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous, - p->asynchronous); - - if (p->convert) - mask |= set_string (&block, &post_block, var, IOPARM_open_convert, - p->convert); - - if (p->newunit) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit, - p->newunit); - - if (p->cc) - mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc); - - if (p->share) - mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share); - - mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly); - - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - if (p->unit) - set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr_loc (input_location, - iocall[IOCALL_OPEN], 1, tmp); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &post_block); - - io_result (&block, var, p->err, NULL, NULL); - - return gfc_finish_block (&block); -} - - -/* Translate a CLOSE statement. */ - -tree -gfc_trans_close (gfc_code * code) -{ - stmtblock_t block, post_block; - gfc_close *p; - tree tmp, var; - unsigned int mask = 0; - - gfc_start_block (&block); - gfc_init_block (&post_block); - - var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm"); - - set_error_locus (&block, var, &code->loc); - p = code->ext.close; - - if (p->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - p->iomsg); - - if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); - - if (p->err) - mask |= IOPARM_common_err; - - if (p->status) - mask |= set_string (&block, &post_block, var, IOPARM_close_status, - p->status); - - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - if (p->unit) - set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr_loc (input_location, - iocall[IOCALL_CLOSE], 1, tmp); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &post_block); - - io_result (&block, var, p->err, NULL, NULL); - - return gfc_finish_block (&block); -} - - -/* Common subroutine for building a file positioning statement. */ - -static tree -build_filepos (tree function, gfc_code * code) -{ - stmtblock_t block, post_block; - gfc_filepos *p; - tree tmp, var; - unsigned int mask = 0; - - p = code->ext.filepos; - - gfc_start_block (&block); - gfc_init_block (&post_block); - - var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type, - "filepos_parm"); - - set_error_locus (&block, var, &code->loc); - - if (p->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - p->iomsg); - - if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, - IOPARM_common_iostat, p->iostat); - - if (p->err) - mask |= IOPARM_common_err; - - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - if (p->unit) - set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, - p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr_loc (input_location, - function, 1, tmp); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &post_block); - - io_result (&block, var, p->err, NULL, NULL); - - return gfc_finish_block (&block); -} - - -/* Translate a BACKSPACE statement. */ - -tree -gfc_trans_backspace (gfc_code * code) -{ - return build_filepos (iocall[IOCALL_BACKSPACE], code); -} - - -/* Translate an ENDFILE statement. */ - -tree -gfc_trans_endfile (gfc_code * code) -{ - return build_filepos (iocall[IOCALL_ENDFILE], code); -} - - -/* Translate a REWIND statement. */ - -tree -gfc_trans_rewind (gfc_code * code) -{ - return build_filepos (iocall[IOCALL_REWIND], code); -} - - -/* Translate a FLUSH statement. */ - -tree -gfc_trans_flush (gfc_code * code) -{ - return build_filepos (iocall[IOCALL_FLUSH], code); -} - - -/* Translate the non-IOLENGTH form of an INQUIRE statement. */ - -tree -gfc_trans_inquire (gfc_code * code) -{ - stmtblock_t block, post_block; - gfc_inquire *p; - tree tmp, var; - unsigned int mask = 0, mask2 = 0; - - gfc_start_block (&block); - gfc_init_block (&post_block); - - var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type, - "inquire_parm"); - - set_error_locus (&block, var, &code->loc); - p = code->ext.inquire; - - if (p->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - p->iomsg); - - if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); - - if (p->err) - mask |= IOPARM_common_err; - - /* Sanity check. */ - if (p->unit && p->file) - gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc); - - if (p->file) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, - p->file); - - if (p->exist) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, - p->exist); - - if (p->opened) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened, - p->opened); - - if (p->number) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number, - p->number); - - if (p->named) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named, - p->named); - - if (p->name) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_name, - p->name); - - if (p->access) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_access, - p->access); - - if (p->sequential) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential, - p->sequential); - - if (p->direct) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct, - p->direct); - - if (p->form) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_form, - p->form); - - if (p->formatted) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted, - p->formatted); - - if (p->unformatted) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted, - p->unformatted); - - if (p->recl) - mask |= set_parameter_ref (&block, &post_block, var, - IOPARM_inquire_recl_out, p->recl); - - if (p->nextrec) - mask |= set_parameter_ref (&block, &post_block, var, - IOPARM_inquire_nextrec, p->nextrec); - - if (p->blank) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank, - p->blank); - - if (p->delim) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim, - p->delim); - - if (p->position) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_position, - p->position); - - if (p->action) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_action, - p->action); - - if (p->read) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_read, - p->read); - - if (p->write) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_write, - p->write); - - if (p->readwrite) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite, - p->readwrite); - - if (p->pad) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad, - p->pad); - - if (p->convert) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert, - p->convert); - - if (p->strm_pos) - mask |= set_parameter_ref (&block, &post_block, var, - IOPARM_inquire_strm_pos_out, p->strm_pos); - - /* The second series of flags. */ - if (p->asynchronous) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous, - p->asynchronous); - - if (p->decimal) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal, - p->decimal); - - if (p->encoding) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding, - p->encoding); - - if (p->round) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round, - p->round); - - if (p->sign) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign, - p->sign); - - if (p->pending) - mask2 |= set_parameter_ref (&block, &post_block, var, - IOPARM_inquire_pending, p->pending); - - if (p->size) - mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size, - p->size); - - if (p->id) - mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id, - p->id); - if (p->iqstream) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream, - p->iqstream); - - if (p->share) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share, - p->share); - - if (p->cc) - mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc); - - if (mask2) - mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2); - - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - if (p->unit) - { - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit); - } - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr_loc (input_location, - iocall[IOCALL_INQUIRE], 1, tmp); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &post_block); - - io_result (&block, var, p->err, NULL, NULL); - - return gfc_finish_block (&block); -} - - -tree -gfc_trans_wait (gfc_code * code) -{ - stmtblock_t block, post_block; - gfc_wait *p; - tree tmp, var; - unsigned int mask = 0; - - gfc_start_block (&block); - gfc_init_block (&post_block); - - var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type, - "wait_parm"); - - set_error_locus (&block, var, &code->loc); - p = code->ext.wait; - - /* Set parameters here. */ - if (p->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - p->iomsg); - - if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); - - if (p->err) - mask |= IOPARM_common_err; - - if (p->id) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id); - - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - if (p->unit) - set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); - - tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr_loc (input_location, - iocall[IOCALL_WAIT], 1, tmp); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &post_block); - - io_result (&block, var, p->err, NULL, NULL); - - return gfc_finish_block (&block); - -} - - -/* nml_full_name builds up the fully qualified name of a - derived type component. '+' is used to denote a type extension. */ - -static char* -nml_full_name (const char* var_name, const char* cmp_name, bool parent) -{ - int full_name_length; - char * full_name; - - full_name_length = strlen (var_name) + strlen (cmp_name) + 1; - full_name = XCNEWVEC (char, full_name_length + 1); - strcpy (full_name, var_name); - full_name = strcat (full_name, parent ? "+" : "%"); - full_name = strcat (full_name, cmp_name); - return full_name; -} - - -/* nml_get_addr_expr builds an address expression from the - gfc_symbol or gfc_component backend_decl's. An offset is - provided so that the address of an element of an array of - derived types is returned. This is used in the runtime to - determine that span of the derived type. */ - -static tree -nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, - tree base_addr) -{ - tree decl = NULL_TREE; - tree tmp; - - if (sym) - { - sym->attr.referenced = 1; - decl = gfc_get_symbol_decl (sym); - - /* If this is the enclosing function declaration, use - the fake result instead. */ - if (decl == current_function_decl) - decl = gfc_get_fake_result_decl (sym, 0); - else if (decl == DECL_CONTEXT (current_function_decl)) - decl = gfc_get_fake_result_decl (sym, 1); - } - else - decl = c->backend_decl; - - gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL - || VAR_P (decl) - || TREE_CODE (decl) == PARM_DECL - || TREE_CODE (decl) == COMPONENT_REF)); - - tmp = decl; - - /* Build indirect reference, if dummy argument. */ - - if (POINTER_TYPE_P (TREE_TYPE(tmp))) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - - /* Treat the component of a derived type, using base_addr for - the derived type. */ - - if (TREE_CODE (decl) == FIELD_DECL) - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), - base_addr, tmp, NULL_TREE); - - if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp)))) - tmp = gfc_class_data_get (tmp); - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_conv_array_data (tmp); - else - { - if (!POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - - if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) - tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL); - - if (!POINTER_TYPE_P (TREE_TYPE (tmp))) - tmp = build_fold_indirect_ref_loc (input_location, - tmp); - } - - gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp))); - - return tmp; -} - - -/* For an object VAR_NAME whose base address is BASE_ADDR, generate a - call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively - generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */ - -#define IARG(i) build_int_cst (gfc_array_index_type, i) - -static void -transfer_namelist_element (stmtblock_t * block, const char * var_name, - gfc_symbol * sym, gfc_component * c, - tree base_addr) -{ - gfc_typespec * ts = NULL; - gfc_array_spec * as = NULL; - tree addr_expr = NULL; - tree dt = NULL; - tree string; - tree tmp; - tree dtype; - tree dt_parm_addr; - tree decl = NULL_TREE; - tree gfc_int4_type_node = gfc_get_int_type (4); - tree dtio_proc = null_pointer_node; - tree vtable = null_pointer_node; - int n_dim; - int rank = 0; - - gcc_assert (sym || c); - - /* Build the namelist object name. */ - - string = gfc_build_cstring_const (var_name); - string = gfc_build_addr_expr (pchar_type_node, string); - - /* Build ts, as and data address using symbol or component. */ - - ts = sym ? &sym->ts : &c->ts; - - if (ts->type != BT_CLASS) - as = sym ? sym->as : c->as; - else - as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as; - - addr_expr = nml_get_addr_expr (sym, c, base_addr); - - if (as) - rank = as->rank; - - if (rank) - { - decl = sym ? sym->backend_decl : c->backend_decl; - if (sym && sym->attr.dummy) - decl = build_fold_indirect_ref_loc (input_location, decl); - - if (ts->type == BT_CLASS) - decl = gfc_class_data_get (decl); - dt = TREE_TYPE (decl); - dtype = gfc_get_dtype (dt); - } - else - { - dt = gfc_typenode_for_spec (ts); - dtype = gfc_get_dtype_rank_type (0, dt); - } - - /* Build up the arguments for the transfer call. - The call for the scalar part transfers: - (address, name, type, kind or string_length, dtype) */ - - dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); - - /* Check if the derived type has a specific DTIO for the mode. - Note that although namelist io is forbidden to have a format - list, the specific subroutine is of the formatted kind. */ - if (ts->type == BT_DERIVED || ts->type == BT_CLASS) - { - gfc_symbol *derived; - if (ts->type==BT_CLASS) - derived = ts->u.derived->components->ts.u.derived; - else - derived = ts->u.derived; - - gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived, - last_dt == WRITE, true); - - if (ts->type == BT_CLASS && tb_io_st) - { - // polymorphic DTIO call (based on the dynamic type) - gfc_se se; - gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name); - // build vtable expr - gfc_expr *expr = gfc_get_variable_expr (st); - gfc_add_vptr_component (expr); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, expr); - vtable = se.expr; - // build dtio expr - gfc_add_component_ref (expr, - tb_io_st->n.tb->u.generic->specific_st->name); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, expr); - gfc_free_expr (expr); - dtio_proc = se.expr; - } - else - { - // non-polymorphic DTIO call (based on the declared type) - gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived, - last_dt == WRITE, true); - if (dtio_sub != NULL) - { - dtio_proc = gfc_get_symbol_decl (dtio_sub); - dtio_proc = gfc_build_addr_expr (NULL, dtio_proc); - gfc_symbol *vtab = gfc_find_derived_vtab (derived); - vtable = vtab->backend_decl; - if (vtable == NULL_TREE) - vtable = gfc_get_symbol_decl (vtab); - vtable = gfc_build_addr_expr (pvoid_type_node, vtable); - } - } - } - - if (ts->type == BT_CHARACTER) - tmp = ts->u.cl->backend_decl; - else - tmp = build_int_cst (gfc_charlen_type_node, 0); - - int abi_kind = gfc_type_abi_kind (ts); - if (dtio_proc == null_pointer_node) - tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_VAL], 6, - dt_parm_addr, addr_expr, string, - build_int_cst (gfc_int4_type_node, abi_kind), - tmp, dtype); - else - tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_DTIO_VAL], - 8, dt_parm_addr, addr_expr, string, - build_int_cst (gfc_int4_type_node, abi_kind), - tmp, dtype, dtio_proc, vtable); - gfc_add_expr_to_block (block, tmp); - - /* If the object is an array, transfer rank times: - (null pointer, name, stride, lbound, ubound) */ - - for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) - { - tmp = build_call_expr_loc (input_location, - iocall[IOCALL_SET_NML_VAL_DIM], 5, - dt_parm_addr, - build_int_cst (gfc_int4_type_node, n_dim), - gfc_conv_array_stride (decl, n_dim), - gfc_conv_array_lbound (decl, n_dim), - gfc_conv_array_ubound (decl, n_dim)); - gfc_add_expr_to_block (block, tmp); - } - - if (gfc_bt_struct (ts->type) && ts->u.derived->components - && dtio_proc == null_pointer_node) - { - gfc_component *cmp; - - /* Provide the RECORD_TYPE to build component references. */ - - tree expr = build_fold_indirect_ref_loc (input_location, - addr_expr); - - for (cmp = ts->u.derived->components; cmp; cmp = cmp->next) - { - char *full_name = nml_full_name (var_name, cmp->name, - ts->u.derived->attr.extension); - transfer_namelist_element (block, - full_name, - NULL, cmp, expr); - free (full_name); - } - } -} - -#undef IARG - -/* Create a data transfer statement. Not all of the fields are valid - for both reading and writing, but improper use has been filtered - out by now. */ - -static tree -build_dt (tree function, gfc_code * code) -{ - stmtblock_t block, post_block, post_end_block, post_iu_block; - gfc_dt *dt; - tree tmp, var; - gfc_expr *nmlname; - gfc_namelist *nml; - unsigned int mask = 0; - - gfc_start_block (&block); - gfc_init_block (&post_block); - gfc_init_block (&post_end_block); - gfc_init_block (&post_iu_block); - - var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm"); - - set_error_locus (&block, var, &code->loc); - - if (last_dt == IOLENGTH) - { - gfc_inquire *inq; - - inq = code->ext.inquire; - - /* First check that preconditions are met. */ - gcc_assert (inq != NULL); - gcc_assert (inq->iolength != NULL); - - /* Connect to the iolength variable. */ - mask |= set_parameter_ref (&block, &post_end_block, var, - IOPARM_dt_iolength, inq->iolength); - dt = NULL; - } - else - { - dt = code->ext.dt; - gcc_assert (dt != NULL); - } - - if (dt && dt->io_unit) - { - if (dt->io_unit->ts.type == BT_CHARACTER) - { - mask |= set_internal_unit (&block, &post_iu_block, - var, dt->io_unit); - set_parameter_const (&block, var, IOPARM_common_unit, - dt->io_unit->ts.kind == 1 ? - GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4); - } - } - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - if (dt) - { - if (dt->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - dt->iomsg); - - if (dt->iostat) - mask |= set_parameter_ref (&block, &post_end_block, var, - IOPARM_common_iostat, dt->iostat); - - if (dt->err) - mask |= IOPARM_common_err; - - if (dt->eor) - mask |= IOPARM_common_eor; - - if (dt->end) - mask |= IOPARM_common_end; - - if (dt->id) - mask |= set_parameter_ref (&block, &post_end_block, var, - IOPARM_dt_id, dt->id); - - if (dt->pos) - mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos); - - if (dt->asynchronous) - mask |= set_string (&block, &post_block, var, - IOPARM_dt_asynchronous, dt->asynchronous); - - if (dt->blank) - mask |= set_string (&block, &post_block, var, IOPARM_dt_blank, - dt->blank); - - if (dt->decimal) - mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal, - dt->decimal); - - if (dt->delim) - mask |= set_string (&block, &post_block, var, IOPARM_dt_delim, - dt->delim); - - if (dt->pad) - mask |= set_string (&block, &post_block, var, IOPARM_dt_pad, - dt->pad); - - if (dt->round) - mask |= set_string (&block, &post_block, var, IOPARM_dt_round, - dt->round); - - if (dt->sign) - mask |= set_string (&block, &post_block, var, IOPARM_dt_sign, - dt->sign); - - if (dt->rec) - mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); - - if (dt->advance) - mask |= set_string (&block, &post_block, var, IOPARM_dt_advance, - dt->advance); - - if (dt->format_expr) - mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format, - dt->format_expr); - - if (dt->format_label) - { - if (dt->format_label == &format_asterisk) - mask |= IOPARM_dt_list_format; - else - mask |= set_string (&block, &post_block, var, IOPARM_dt_format, - dt->format_label->format); - } - - if (dt->size) - mask |= set_parameter_ref (&block, &post_end_block, var, - IOPARM_dt_size, dt->size); - - if (dt->udtio) - mask |= IOPARM_dt_dtio; - - if (dt->dec_ext) - mask |= IOPARM_dt_dec_ext; - - if (dt->namelist) - { - if (dt->format_expr || dt->format_label) - gfc_internal_error ("build_dt: format with namelist"); - - nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL, - dt->namelist->name, - strlen (dt->namelist->name)); - - mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name, - nmlname); - - gfc_free_expr (nmlname); - - if (last_dt == READ) - mask |= IOPARM_dt_namelist_read_mode; - - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - dt_parm = var; - - for (nml = dt->namelist->namelist; nml; nml = nml->next) - transfer_namelist_element (&block, nml->sym->name, nml->sym, - NULL, NULL_TREE); - } - else - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER) - set_parameter_value_chk (&block, dt->iostat, var, - IOPARM_common_unit, dt->io_unit); - } - else - set_parameter_const (&block, var, IOPARM_common_flags, mask); - - tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr_loc (UNKNOWN_LOCATION, - function, 1, tmp); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &post_block); - - dt_parm = var; - dt_post_end_block = &post_end_block; - - /* Set implied do loop exit condition. */ - if (last_dt == READ || last_dt == WRITE) - { - gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; - - tmp = fold_build3_loc (input_location, COMPONENT_REF, - st_parameter[IOPARM_ptype_common].type, - dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), - NULL_TREE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (p->field), tmp, p->field, NULL_TREE); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp), - tmp, build_int_cst (TREE_TYPE (tmp), - IOPARM_common_libreturn_mask)); - } - else /* IOLENGTH */ - tmp = NULL_TREE; - - gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp)); - - gfc_add_block_to_block (&block, &post_iu_block); - - dt_parm = NULL; - dt_post_end_block = NULL; - - return gfc_finish_block (&block); -} - - -/* Translate the IOLENGTH form of an INQUIRE statement. We treat - this as a third sort of data transfer statement, except that - lengths are summed instead of actually transferring any data. */ - -tree -gfc_trans_iolength (gfc_code * code) -{ - last_dt = IOLENGTH; - return build_dt (iocall[IOCALL_IOLENGTH], code); -} - - -/* Translate a READ statement. */ - -tree -gfc_trans_read (gfc_code * code) -{ - last_dt = READ; - return build_dt (iocall[IOCALL_READ], code); -} - - -/* Translate a WRITE statement */ - -tree -gfc_trans_write (gfc_code * code) -{ - last_dt = WRITE; - return build_dt (iocall[IOCALL_WRITE], code); -} - - -/* Finish a data transfer statement. */ - -tree -gfc_trans_dt_end (gfc_code * code) -{ - tree function, tmp; - stmtblock_t block; - - gfc_init_block (&block); - - switch (last_dt) - { - case READ: - function = iocall[IOCALL_READ_DONE]; - break; - - case WRITE: - function = iocall[IOCALL_WRITE_DONE]; - break; - - case IOLENGTH: - function = iocall[IOCALL_IOLENGTH_DONE]; - break; - - default: - gcc_unreachable (); - } - - tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - tmp = build_call_expr_loc (input_location, - function, 1, tmp); - gfc_add_expr_to_block (&block, tmp); - gfc_add_block_to_block (&block, dt_post_end_block); - gfc_init_block (dt_post_end_block); - - if (last_dt != IOLENGTH) - { - gcc_assert (code->ext.dt != NULL); - io_result (&block, dt_parm, code->ext.dt->err, - code->ext.dt->end, code->ext.dt->eor); - } - - return gfc_finish_block (&block); -} - -static void -transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, - gfc_code * code, tree vptr); - -/* Given an array field in a derived type variable, generate the code - for the loop that iterates over array elements, and the code that - accesses those array elements. Use transfer_expr to generate code - for transferring that element. Because elements may also be - derived types, transfer_expr and transfer_array_component are mutually - recursive. */ - -static tree -transfer_array_component (tree expr, gfc_component * cm, locus * where) -{ - tree tmp; - stmtblock_t body; - stmtblock_t block; - gfc_loopinfo loop; - int n; - gfc_ss *ss; - gfc_se se; - gfc_array_info *ss_array; - - gfc_start_block (&block); - gfc_init_se (&se, NULL); - - /* Create and initialize Scalarization Status. Unlike in - gfc_trans_transfer, we can't simply use gfc_walk_expr to take - care of this task, because we don't have a gfc_expr at hand. - Build one manually, as in gfc_trans_subarray_assign. */ - - ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank, - GFC_SS_COMPONENT); - ss_array = &ss->info->data.array; - - if (cm->attr.pdt_array) - ss_array->shape = NULL; - else - ss_array->shape = gfc_get_shape (cm->as->rank); - - ss_array->descriptor = expr; - ss_array->data = gfc_conv_array_data (expr); - ss_array->offset = gfc_conv_array_offset (expr); - for (n = 0; n < cm->as->rank; n++) - { - ss_array->start[n] = gfc_conv_array_lbound (expr, n); - ss_array->stride[n] = gfc_index_one_node; - - if (cm->attr.pdt_array) - ss_array->end[n] = gfc_conv_array_ubound (expr, n); - else - { - mpz_init (ss_array->shape[n]); - mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer, - cm->as->lower[n]->value.integer); - mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1); - } - } - - /* Once we got ss, we use scalarizer to create the loop. */ - - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, ss); - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, where); - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &body); - - gfc_copy_loopinfo_to_se (&se, &loop); - se.ss = ss; - - /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */ - se.expr = expr; - gfc_conv_tmp_array_ref (&se); - - /* Now se.expr contains an element of the array. Take the address and pass - it to the IO routines. */ - tmp = gfc_build_addr_expr (NULL_TREE, se.expr); - transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE); - - /* We are done now with the loop body. Wrap up the scalarizer and - return. */ - - gfc_add_block_to_block (&body, &se.pre); - gfc_add_block_to_block (&body, &se.post); - - gfc_trans_scalarizing_loops (&loop, &body); - - gfc_add_block_to_block (&block, &loop.pre); - gfc_add_block_to_block (&block, &loop.post); - - if (!cm->attr.pdt_array) - { - gcc_assert (ss_array->shape != NULL); - gfc_free_shape (&ss_array->shape, cm->as->rank); - } - gfc_cleanup_loop (&loop); - - return gfc_finish_block (&block); -} - - -/* Helper function for transfer_expr that looks for the DTIO procedure - either as a typebound binding or in a generic interface. If present, - the address expression of the procedure is returned. It is assumed - that the procedure interface has been checked during resolution. */ - -static tree -get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub) -{ - gfc_symbol *derived; - bool formatted = false; - gfc_dt *dt = code->ext.dt; - - /* Determine when to use the formatted DTIO procedure. */ - if (dt && (dt->format_expr || dt->format_label)) - formatted = true; - - if (ts->type == BT_CLASS) - derived = ts->u.derived->components->ts.u.derived; - else - derived = ts->u.derived; - - gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived, - last_dt == WRITE, formatted); - if (ts->type == BT_CLASS && tb_io_st) - { - // polymorphic DTIO call (based on the dynamic type) - gfc_se se; - gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1); - gfc_add_vptr_component (expr); - gfc_add_component_ref (expr, - tb_io_st->n.tb->u.generic->specific_st->name); - *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym; - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, expr); - gfc_free_expr (expr); - return se.expr; - } - else - { - // non-polymorphic DTIO call (based on the declared type) - *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE, - formatted); - - if (*dtio_sub) - return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub)); - } - - return NULL_TREE; -} - -/* Generate the call for a scalar transfer node. */ - -static void -transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, - gfc_code * code, tree vptr) -{ - tree tmp, function, arg2, arg3, field, expr; - gfc_component *c; - int kind; - - /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if - the user says something like: print *, 'c_null_ptr: ', c_null_ptr - We need to translate the expression to a constant if it's either - C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of - type C_PTR or C_FUNPTR, in which case the ts->type may no longer be - BT_DERIVED (could have been changed by gfc_conv_expr). */ - if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER) - && ts->u.derived != NULL - && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1)) - { - ts->type = BT_INTEGER; - ts->kind = gfc_index_integer_kind; - } - - /* gfortran reaches here for "print *, c_loc(xxx)". */ - if (ts->type == BT_VOID - && code->expr1 && code->expr1->ts.type == BT_VOID - && code->expr1->symtree - && strcmp (code->expr1->symtree->name, "c_loc") == 0) - { - ts->type = BT_INTEGER; - ts->kind = gfc_index_integer_kind; - } - - kind = gfc_type_abi_kind (ts); - function = NULL; - arg2 = NULL; - arg3 = NULL; - - switch (ts->type) - { - case BT_INTEGER: - arg2 = build_int_cst (integer_type_node, kind); - if (last_dt == READ) - function = iocall[IOCALL_X_INTEGER]; - else - function = iocall[IOCALL_X_INTEGER_WRITE]; - - break; - - case BT_REAL: - arg2 = build_int_cst (integer_type_node, kind); - if (last_dt == READ) - { - if ((gfc_real16_is_float128 && kind == 16) || kind == 17) - function = iocall[IOCALL_X_REAL128]; - else - function = iocall[IOCALL_X_REAL]; - } - else - { - if ((gfc_real16_is_float128 && kind == 16) || kind == 17) - function = iocall[IOCALL_X_REAL128_WRITE]; - else - function = iocall[IOCALL_X_REAL_WRITE]; - } - - break; - - case BT_COMPLEX: - arg2 = build_int_cst (integer_type_node, kind); - if (last_dt == READ) - { - if ((gfc_real16_is_float128 && kind == 16) || kind == 17) - function = iocall[IOCALL_X_COMPLEX128]; - else - function = iocall[IOCALL_X_COMPLEX]; - } - else - { - if ((gfc_real16_is_float128 && kind == 16) || kind == 17) - function = iocall[IOCALL_X_COMPLEX128_WRITE]; - else - function = iocall[IOCALL_X_COMPLEX_WRITE]; - } - - break; - - case BT_LOGICAL: - arg2 = build_int_cst (integer_type_node, kind); - if (last_dt == READ) - function = iocall[IOCALL_X_LOGICAL]; - else - function = iocall[IOCALL_X_LOGICAL_WRITE]; - - break; - - case BT_CHARACTER: - if (kind == 4) - { - if (se->string_length) - arg2 = se->string_length; - else - { - tmp = build_fold_indirect_ref_loc (input_location, - addr_expr); - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); - arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); - arg2 = fold_convert (gfc_charlen_type_node, arg2); - } - arg3 = build_int_cst (integer_type_node, kind); - if (last_dt == READ) - function = iocall[IOCALL_X_CHARACTER_WIDE]; - else - function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE]; - - tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - tmp = build_call_expr_loc (input_location, - function, 4, tmp, addr_expr, arg2, arg3); - gfc_add_expr_to_block (&se->pre, tmp); - gfc_add_block_to_block (&se->pre, &se->post); - return; - } - /* Fall through. */ - case BT_HOLLERITH: - if (se->string_length) - arg2 = se->string_length; - else - { - tmp = build_fold_indirect_ref_loc (input_location, - addr_expr); - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); - arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); - } - if (last_dt == READ) - function = iocall[IOCALL_X_CHARACTER]; - else - function = iocall[IOCALL_X_CHARACTER_WRITE]; - - break; - - case_bt_struct: - case BT_CLASS: - if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS) - { - gfc_symbol *derived; - gfc_symbol *dtio_sub = NULL; - /* Test for a specific DTIO subroutine. */ - if (ts->type == BT_DERIVED) - derived = ts->u.derived; - else - derived = ts->u.derived->components->ts.u.derived; - - if (derived->attr.has_dtio_procs) - arg2 = get_dtio_proc (ts, code, &dtio_sub); - - if ((dtio_sub != NULL) && (last_dt != IOLENGTH)) - { - tree decl; - decl = build_fold_indirect_ref_loc (input_location, - se->expr); - /* Remember that the first dummy of the DTIO subroutines - is CLASS(derived) for extensible derived types, so the - conversion must be done here for derived type and for - scalarized CLASS array element io-list objects. */ - if ((ts->type == BT_DERIVED - && !(ts->u.derived->attr.sequence - || ts->u.derived->attr.is_bind_c)) - || (ts->type == BT_CLASS - && !GFC_CLASS_TYPE_P (TREE_TYPE (decl)))) - gfc_conv_derived_to_class (se, code->expr1, - dtio_sub->formal->sym->ts, - vptr, false, false); - addr_expr = se->expr; - function = iocall[IOCALL_X_DERIVED]; - break; - } - else if (gfc_bt_struct (ts->type)) - { - /* Recurse into the elements of the derived type. */ - expr = gfc_evaluate_now (addr_expr, &se->pre); - expr = build_fold_indirect_ref_loc (input_location, expr); - - /* Make sure that the derived type has been built. An external - function, if only referenced in an io statement, requires this - check (see PR58771). */ - if (ts->u.derived->backend_decl == NULL_TREE) - (void) gfc_typenode_for_spec (ts); - - for (c = ts->u.derived->components; c; c = c->next) - { - /* Ignore hidden string lengths. */ - if (c->name[0] == '_') - continue; - - field = c->backend_decl; - gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - - tmp = fold_build3_loc (UNKNOWN_LOCATION, - COMPONENT_REF, TREE_TYPE (field), - expr, field, NULL_TREE); - - if (c->attr.dimension) - { - tmp = transfer_array_component (tmp, c, & code->loc); - gfc_add_expr_to_block (&se->pre, tmp); - } - else - { - tree strlen = NULL_TREE; - - if (!c->attr.pointer && !c->attr.pdt_string) - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - - /* Use the hidden string length for pdt strings. */ - if (c->attr.pdt_string - && gfc_deferred_strlen (c, &strlen) - && strlen != NULL_TREE) - { - strlen = fold_build3_loc (UNKNOWN_LOCATION, - COMPONENT_REF, - TREE_TYPE (strlen), - expr, strlen, NULL_TREE); - se->string_length = strlen; - } - - transfer_expr (se, &c->ts, tmp, code, NULL_TREE); - - /* Reset so that the pdt string length does not propagate - through to other strings. */ - if (c->attr.pdt_string && strlen) - se->string_length = NULL_TREE; - } - } - return; - } - /* If a CLASS object gets through to here, fall through and ICE. */ - } - gcc_fallthrough (); - default: - gfc_internal_error ("Bad IO basetype (%d)", ts->type); - } - - tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - tmp = build_call_expr_loc (input_location, - function, 3, tmp, addr_expr, arg2); - gfc_add_expr_to_block (&se->pre, tmp); - gfc_add_block_to_block (&se->pre, &se->post); - -} - - -/* Generate a call to pass an array descriptor to the IO library. The - array should be of one of the intrinsic types. */ - -static void -transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr) -{ - tree tmp, charlen_arg, kind_arg, io_call; - - if (ts->type == BT_CHARACTER) - charlen_arg = se->string_length; - else - charlen_arg = build_int_cst (gfc_charlen_type_node, 0); - - kind_arg = build_int_cst (integer_type_node, gfc_type_abi_kind (ts)); - - tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - if (last_dt == READ) - io_call = iocall[IOCALL_X_ARRAY]; - else - io_call = iocall[IOCALL_X_ARRAY_WRITE]; - - tmp = build_call_expr_loc (UNKNOWN_LOCATION, - io_call, 4, - tmp, addr_expr, kind_arg, charlen_arg); - gfc_add_expr_to_block (&se->pre, tmp); - gfc_add_block_to_block (&se->pre, &se->post); -} - - -/* gfc_trans_transfer()-- Translate a TRANSFER code node */ - -tree -gfc_trans_transfer (gfc_code * code) -{ - stmtblock_t block, body; - gfc_loopinfo loop; - gfc_expr *expr; - gfc_ref *ref; - gfc_ss *ss; - gfc_se se; - tree tmp; - tree vptr; - int n; - - gfc_start_block (&block); - gfc_init_block (&body); - - expr = code->expr1; - ref = NULL; - gfc_init_se (&se, NULL); - - if (expr->rank == 0) - { - /* Transfer a scalar value. */ - if (expr->ts.type == BT_CLASS) - { - se.want_pointer = 1; - gfc_conv_expr (&se, expr); - vptr = gfc_get_vptr_from_expr (se.expr); - } - else - { - vptr = NULL_TREE; - gfc_conv_expr_reference (&se, expr); - } - transfer_expr (&se, &expr->ts, se.expr, code, vptr); - } - else - { - /* Transfer an array. If it is an array of an intrinsic - type, pass the descriptor to the library. Otherwise - scalarize the transfer. */ - if (expr->ref && !gfc_is_proc_ptr_comp (expr)) - { - for (ref = expr->ref; ref && ref->type != REF_ARRAY; - ref = ref->next); - gcc_assert (ref && ref->type == REF_ARRAY); - } - - if (expr->ts.type != BT_CLASS - && expr->expr_type == EXPR_VARIABLE - && gfc_expr_attr (expr).pointer) - goto scalarize; - - - if (!(gfc_bt_struct (expr->ts.type) - || expr->ts.type == BT_CLASS) - && ref && ref->next == NULL - && !is_subref_array (expr)) - { - bool seen_vector = false; - - if (ref && ref->u.ar.type == AR_SECTION) - { - for (n = 0; n < ref->u.ar.dimen; n++) - if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) - { - seen_vector = true; - break; - } - } - - if (seen_vector && last_dt == READ) - { - /* Create a temp, read to that and copy it back. */ - gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false); - tmp = se.expr; - } - else - { - /* Get the descriptor. */ - gfc_conv_expr_descriptor (&se, expr); - tmp = gfc_build_addr_expr (NULL_TREE, se.expr); - } - - transfer_array_desc (&se, &expr->ts, tmp); - goto finish_block_label; - } - -scalarize: - /* Initialize the scalarizer. */ - ss = gfc_walk_expr (expr); - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, ss); - - /* Initialize the loop. */ - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &code->expr1->where); - - /* The main loop body. */ - gfc_mark_ss_chain_used (ss, 1); - gfc_start_scalarized_body (&loop, &body); - - gfc_copy_loopinfo_to_se (&se, &loop); - se.ss = ss; - - gfc_conv_expr_reference (&se, expr); - - if (expr->ts.type == BT_CLASS) - vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor); - else - vptr = NULL_TREE; - transfer_expr (&se, &expr->ts, se.expr, code, vptr); - } - - finish_block_label: - - gfc_add_block_to_block (&body, &se.pre); - gfc_add_block_to_block (&body, &se.post); - - if (se.ss == NULL) - tmp = gfc_finish_block (&body); - else - { - gcc_assert (expr->rank != 0); - gcc_assert (se.ss == gfc_ss_terminator); - gfc_trans_scalarizing_loops (&loop, &body); - - gfc_add_block_to_block (&loop.pre, &loop.post); - tmp = gfc_finish_block (&loop.pre); - gfc_cleanup_loop (&loop); - } - - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - -#include "gt-fortran-trans-io.h" diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc new file mode 100644 index 0000000..033b102 --- /dev/null +++ b/gcc/fortran/trans-io.cc @@ -0,0 +1,2686 @@ +/* IO Code translation/library interface + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "gfortran.h" +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "stor-layout.h" +#include "trans-stmt.h" +#include "trans-array.h" +#include "trans-types.h" +#include "trans-const.h" +#include "options.h" + +/* Members of the ioparm structure. */ + +enum ioparam_type +{ + IOPARM_ptype_common, + IOPARM_ptype_open, + IOPARM_ptype_close, + IOPARM_ptype_filepos, + IOPARM_ptype_inquire, + IOPARM_ptype_dt, + IOPARM_ptype_wait, + IOPARM_ptype_num +}; + +enum iofield_type +{ + IOPARM_type_int4, + IOPARM_type_intio, + IOPARM_type_pint4, + IOPARM_type_pintio, + IOPARM_type_pchar, + IOPARM_type_parray, + IOPARM_type_pad, + IOPARM_type_char1, + IOPARM_type_char2, + IOPARM_type_common, + IOPARM_type_num +}; + +typedef struct GTY(()) gfc_st_parameter_field { + const char *name; + unsigned int mask; + enum ioparam_type param_type; + enum iofield_type type; + tree field; + tree field_len; +} +gfc_st_parameter_field; + +typedef struct GTY(()) gfc_st_parameter { + const char *name; + tree type; +} +gfc_st_parameter; + +enum iofield +{ +#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name, +#include "ioparm.def" +#undef IOPARM + IOPARM_field_num +}; + +static GTY(()) gfc_st_parameter st_parameter[] = +{ + { "common", NULL }, + { "open", NULL }, + { "close", NULL }, + { "filepos", NULL }, + { "inquire", NULL }, + { "dt", NULL }, + { "wait", NULL } +}; + +static GTY(()) gfc_st_parameter_field st_parameter_field[] = +{ +#define IOPARM(param_type, name, mask, type) \ + { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL }, +#include "ioparm.def" +#undef IOPARM + { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL } +}; + +/* Library I/O subroutines */ + +enum iocall +{ + IOCALL_READ, + IOCALL_READ_DONE, + IOCALL_WRITE, + IOCALL_WRITE_DONE, + IOCALL_X_INTEGER, + IOCALL_X_INTEGER_WRITE, + IOCALL_X_LOGICAL, + IOCALL_X_LOGICAL_WRITE, + IOCALL_X_CHARACTER, + IOCALL_X_CHARACTER_WRITE, + IOCALL_X_CHARACTER_WIDE, + IOCALL_X_CHARACTER_WIDE_WRITE, + IOCALL_X_REAL, + IOCALL_X_REAL_WRITE, + IOCALL_X_COMPLEX, + IOCALL_X_COMPLEX_WRITE, + IOCALL_X_REAL128, + IOCALL_X_REAL128_WRITE, + IOCALL_X_COMPLEX128, + IOCALL_X_COMPLEX128_WRITE, + IOCALL_X_ARRAY, + IOCALL_X_ARRAY_WRITE, + IOCALL_X_DERIVED, + IOCALL_OPEN, + IOCALL_CLOSE, + IOCALL_INQUIRE, + IOCALL_IOLENGTH, + IOCALL_IOLENGTH_DONE, + IOCALL_REWIND, + IOCALL_BACKSPACE, + IOCALL_ENDFILE, + IOCALL_FLUSH, + IOCALL_SET_NML_VAL, + IOCALL_SET_NML_DTIO_VAL, + IOCALL_SET_NML_VAL_DIM, + IOCALL_WAIT, + IOCALL_NUM +}; + +static GTY(()) tree iocall[IOCALL_NUM]; + +/* Variable for keeping track of what the last data transfer statement + was. Used for deciding which subroutine to call when the data + transfer is complete. */ +static enum { READ, WRITE, IOLENGTH } last_dt; + +/* The data transfer parameter block that should be shared by all + data transfer calls belonging to the same read/write/iolength. */ +static GTY(()) tree dt_parm; +static stmtblock_t *dt_post_end_block; + +static void +gfc_build_st_parameter (enum ioparam_type ptype, tree *types) +{ + unsigned int type; + gfc_st_parameter_field *p; + char name[64]; + size_t len; + tree t = make_node (RECORD_TYPE); + tree *chain = NULL; + + len = strlen (st_parameter[ptype].name); + gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_")); + memcpy (name, "__st_parameter_", sizeof ("__st_parameter_")); + memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name, + len + 1); + TYPE_NAME (t) = get_identifier (name); + + for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++) + if (p->param_type == ptype) + switch (p->type) + { + case IOPARM_type_int4: + case IOPARM_type_intio: + case IOPARM_type_pint4: + case IOPARM_type_pintio: + case IOPARM_type_parray: + case IOPARM_type_pchar: + case IOPARM_type_pad: + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + types[p->type], &chain); + break; + case IOPARM_type_char1: + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + pchar_type_node, &chain); + /* FALLTHROUGH */ + case IOPARM_type_char2: + len = strlen (p->name); + gcc_assert (len <= sizeof (name) - sizeof ("_len")); + memcpy (name, p->name, len); + memcpy (name + len, "_len", sizeof ("_len")); + p->field_len = gfc_add_field_to_struct (t, get_identifier (name), + gfc_charlen_type_node, + &chain); + if (p->type == IOPARM_type_char2) + p->field = gfc_add_field_to_struct (t, get_identifier (p->name), + pchar_type_node, &chain); + break; + case IOPARM_type_common: + p->field + = gfc_add_field_to_struct (t, + get_identifier (p->name), + st_parameter[IOPARM_ptype_common].type, + &chain); + break; + case IOPARM_type_num: + gcc_unreachable (); + } + + /* -Wpadded warnings on these artificially created structures are not + helpful; suppress them. */ + int save_warn_padded = warn_padded; + warn_padded = 0; + gfc_finish_type (t); + warn_padded = save_warn_padded; + st_parameter[ptype].type = t; +} + + +/* Build code to test an error condition and call generate_error if needed. + Note: This builds calls to generate_error in the runtime library function. + The function generate_error is dependent on certain parameters in the + st_parameter_common flags to be set. (See libgfortran/runtime/error.c) + Therefore, the code to set these flags must be generated before + this function is used. */ + +static void +gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var, + int error_code, const char * msgid, + stmtblock_t * pblock) +{ + stmtblock_t block; + tree body; + tree tmp; + tree arg1, arg2, arg3; + char *message; + + if (integer_zerop (cond)) + return; + + /* The code to generate the error. */ + gfc_start_block (&block); + + if (has_iostat) + gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO, + NOT_TAKEN)); + else + gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN, + NOT_TAKEN)); + + arg1 = gfc_build_addr_expr (NULL_TREE, var); + + arg2 = build_int_cst (integer_type_node, error_code), + + message = xasprintf ("%s", _(msgid)); + arg3 = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (message)); + free (message); + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_generate_error, 3, arg1, arg2, arg3); + + gfc_add_expr_to_block (&block, tmp); + + body = gfc_finish_block (&block); + + if (integer_onep (cond)) + { + gfc_add_expr_to_block (pblock, body); + } + else + { + tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location)); + gfc_add_expr_to_block (pblock, tmp); + } +} + + +/* Create function decls for IO library functions. */ + +void +gfc_build_io_library_fndecls (void) +{ + tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node; + tree gfc_intio_type_node; + tree parm_type, dt_parm_type; + HOST_WIDE_INT pad_size; + unsigned int ptype; + + types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4); + types[IOPARM_type_intio] = gfc_intio_type_node + = gfc_get_int_type (gfc_intio_kind); + types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node); + types[IOPARM_type_pintio] + = build_pointer_type (gfc_intio_type_node); + types[IOPARM_type_parray] = pchar_type_node; + types[IOPARM_type_pchar] = pchar_type_node; + pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node)); + pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node)); + pad_idx = build_index_type (size_int (pad_size - 1)); + types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx); + + /* pad actually contains pointers and integers so it needs to have an + alignment that is at least as large as the needed alignment for those + types. See the st_parameter_dt structure in libgfortran/io/io.h for + what really goes into this space. */ + SET_TYPE_ALIGN (types[IOPARM_type_pad], MAX (TYPE_ALIGN (pchar_type_node), + TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)))); + + for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) + gfc_build_st_parameter ((enum ioparam_type) ptype, types); + + /* Define the transfer functions. */ + + dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type); + + iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_integer")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_integer_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_logical")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_logical_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); + + iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_charlen_type_node); + + iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character_wide")), ". w W . . ", + void_type_node, 4, dt_parm_type, pvoid_type_node, + gfc_charlen_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_CHARACTER_WIDE_WRITE] = + gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_character_wide_write")), ". w R . . ", + void_type_node, 4, dt_parm_type, pvoid_type_node, + gfc_charlen_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + /* Version for __float128. */ + iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real128")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_real128_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex128")), ". w W . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_complex128_write")), ". w R . ", + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); + + iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_array")), ". w w . . ", + void_type_node, 4, dt_parm_type, pvoid_type_node, + integer_type_node, gfc_charlen_type_node); + + iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_array_write")), ". w r . . ", + void_type_node, 4, dt_parm_type, pvoid_type_node, + integer_type_node, gfc_charlen_type_node); + + iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_derived")), ". w r ", + void_type_node, 2, dt_parm_type, pvoid_type_node); + + /* Library entry points */ + + iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_read")), ". w ", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_write")), ". w ", + void_type_node, 1, dt_parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type); + iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_open")), ". w ", + void_type_node, 1, parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type); + iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_close")), ". w ", + void_type_node, 1, parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type); + iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_inquire")), ". w ", + void_type_node, 1, parm_type); + + iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec( + get_identifier (PREFIX("st_iolength")), ". w ", + void_type_node, 1, dt_parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); + iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_wait_async")), ". w ", + void_type_node, 1, parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); + iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_rewind")), ". w ", + void_type_node, 1, parm_type); + + iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_backspace")), ". w ", + void_type_node, 1, parm_type); + + iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_endfile")), ". w ", + void_type_node, 1, parm_type); + + iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_flush")), ". w ", + void_type_node, 1, parm_type); + + /* Library helpers */ + + iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_read_done")), ". w ", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_write_done")), ". w ", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_iolength_done")), ". w ", + void_type_node, 1, dt_parm_type); + + iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_var")), ". w . R . . . ", + void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node, + gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node()); + + iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_dtio_var")), ". w . R . . . . . ", + void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node, + gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node(), + pvoid_type_node, pvoid_type_node); + + iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_var_dim")), ". w . . . . ", + void_type_node, 5, dt_parm_type, gfc_int4_type_node, + gfc_array_index_type, gfc_array_index_type, gfc_array_index_type); +} + + +static void +set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value) +{ + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + gfc_add_modify (block, tmp, value); +} + + +/* Generate code to store an integer constant into the + st_parameter_XXX structure. */ + +static unsigned int +set_parameter_const (stmtblock_t *block, tree var, enum iofield type, + unsigned int val) +{ + gfc_st_parameter_field *p = &st_parameter_field[type]; + + set_parameter_tree (block, var, type, + build_int_cst (TREE_TYPE (p->field), val)); + return p->mask; +} + + +/* Generate code to store a non-string I/O parameter into the + st_parameter_XXX structure. This is a pass by value. */ + +static unsigned int +set_parameter_value (stmtblock_t *block, tree var, enum iofield type, + gfc_expr *e) +{ + gfc_se se; + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + + tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, + p->field, NULL_TREE); + gfc_add_modify (block, tmp, se.expr); + return p->mask; +} + + +/* Similar to set_parameter_value except generate runtime + error checks. */ + +static unsigned int +set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var, + enum iofield type, gfc_expr *e) +{ + gfc_se se; + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + /* If we're storing a UNIT number, we need to check it first. */ + if (type == IOPARM_common_unit && e->ts.kind > 4) + { + tree cond, val; + int i; + + /* Don't evaluate the UNIT number multiple times. */ + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* UNIT numbers should be greater than the min. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, + "Unit number in I/O statement too small", + &se.pre); + + /* UNIT numbers should be less than the max. */ + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, + "Unit number in I/O statement too large", + &se.pre); + } + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + + tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, + p->field, NULL_TREE); + gfc_add_modify (block, tmp, se.expr); + return p->mask; +} + + +/* Build code to check the unit range if KIND=8 is used. Similar to + set_parameter_value_chk but we do not generate error calls for + inquire statements. */ + +static unsigned int +set_parameter_value_inquire (stmtblock_t *block, tree var, + enum iofield type, gfc_expr *e) +{ + gfc_se se; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + /* If we're inquiring on a UNIT number, we need to check to make + sure it exists for larger than kind = 4. */ + if (type == IOPARM_common_unit && e->ts.kind > 4) + { + stmtblock_t newblock; + tree cond1, cond2, cond3, val, body; + int i; + + /* Don't evaluate the UNIT number multiple times. */ + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* UNIT numbers should be greater than the min. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); + cond1 = build2_loc (input_location, LT_EXPR, logical_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + /* UNIT numbers should be less than the max. */ + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); + cond2 = build2_loc (input_location, GT_EXPR, logical_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + cond3 = build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, cond1, cond2); + + gfc_start_block (&newblock); + + /* The unit number GFC_INVALID_UNIT is reserved. No units can + ever have this value. It is used here to signal to the + runtime library that the inquire unit number is outside the + allowable range and so cannot exist. It is needed when + -fdefault-integer-8 is used. */ + set_parameter_const (&newblock, var, IOPARM_common_unit, + GFC_INVALID_UNIT); + + body = gfc_finish_block (&newblock); + + cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO); + var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, var); + } + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + return p->mask; +} + + +/* Generate code to store a non-string I/O parameter into the + st_parameter_XXX structure. This is pass by reference. */ + +static unsigned int +set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, + tree var, enum iofield type, gfc_expr *e) +{ + gfc_se se; + tree tmp, addr; + gfc_st_parameter_field *p = &st_parameter_field[type]; + + gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL); + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, e); + + gfc_add_block_to_block (block, &se.pre); + + if (TYPE_MODE (TREE_TYPE (se.expr)) + == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field)))) + { + addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr)); + + /* If this is for the iostat variable initialize the + user variable to LIBERROR_OK which is zero. */ + if (type == IOPARM_common_iostat) + gfc_add_modify (block, se.expr, + build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK)); + } + else + { + /* The type used by the library has different size + from the type of the variable supplied by the user. + Need to use a temporary. */ + tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)), + st_parameter_field[type].name); + + /* If this is for the iostat variable, initialize the + user variable to LIBERROR_OK which is zero. */ + if (type == IOPARM_common_iostat) + gfc_add_modify (block, tmpvar, + build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK)); + + addr = gfc_build_addr_expr (NULL_TREE, tmpvar); + /* After the I/O operation, we set the variable from the temporary. */ + tmp = convert (TREE_TYPE (se.expr), tmpvar); + gfc_add_modify (postblock, se.expr, tmp); + } + + set_parameter_tree (block, var, type, addr); + return p->mask; +} + +/* Given an array expr, find its address and length to get a string. If the + array is full, the string's address is the address of array's first element + and the length is the size of the whole array. If it is an element, the + string's address is the element's address and the length is the rest size of + the array. */ + +static void +gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) +{ + tree size; + + if (e->rank == 0) + { + tree type, array, tmp; + gfc_symbol *sym; + int rank; + + /* If it is an element, we need its address and size of the rest. */ + gcc_assert (e->expr_type == EXPR_VARIABLE); + gcc_assert (e->ref->u.ar.type == AR_ELEMENT); + sym = e->symtree->n.sym; + rank = sym->as->rank - 1; + gfc_conv_expr (se, e); + + array = sym->backend_decl; + type = TREE_TYPE (array); + + if (GFC_ARRAY_TYPE_P (type)) + size = GFC_TYPE_ARRAY_SIZE (type); + else + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + size = gfc_conv_array_stride (array, rank); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_conv_array_ubound (array, rank), + gfc_conv_array_lbound (array, rank)); + 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, tmp, size); + } + gcc_assert (size); + + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, size, + TREE_OPERAND (se->expr, 1)); + se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + fold_convert (gfc_array_index_type, tmp)); + se->string_length = fold_convert (gfc_charlen_type_node, size); + return; + } + + gfc_conv_array_parameter (se, e, true, NULL, NULL, &size); + se->string_length = fold_convert (gfc_charlen_type_node, size); +} + + +/* Generate code to store a string and its length into the + st_parameter_XXX structure. */ + +static unsigned int +set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, + enum iofield type, gfc_expr * e) +{ + gfc_se se; + tree tmp; + tree io; + tree len; + gfc_st_parameter_field *p = &st_parameter_field[type]; + + gfc_init_se (&se, NULL); + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field_len), + var, p->field_len, NULL_TREE); + + /* Integer variable assigned a format label. */ + if (e->ts.type == BT_INTEGER + && e->rank == 0 + && e->symtree->n.sym->attr.assign == 1) + { + char * msg; + tree cond; + + gfc_conv_label_variable (&se, e); + tmp = GFC_DECL_STRING_LEN (se.expr); + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + + msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format " + "label", e->symtree->name); + gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg, + fold_convert (long_integer_type_node, tmp)); + free (msg); + + gfc_add_modify (&se.pre, io, + fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr))); + gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); + } + else + { + /* General character. */ + if (e->ts.type == BT_CHARACTER && e->rank == 0) + gfc_conv_expr (&se, e); + /* Array assigned Hollerith constant or character array. */ + else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0)) + gfc_convert_array_to_string (&se, e); + else + gcc_unreachable (); + + gfc_conv_string_parameter (&se); + gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr)); + gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), + se.string_length)); + } + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (postblock, &se.post); + return p->mask; +} + + +/* Generate code to store the character (array) and the character length + for an internal unit. */ + +static unsigned int +set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, + tree var, gfc_expr * e) +{ + gfc_se se; + tree io; + tree len; + tree desc; + tree tmp; + gfc_st_parameter_field *p; + unsigned int mask; + + gfc_init_se (&se, NULL); + + p = &st_parameter_field[IOPARM_dt_internal_unit]; + mask = p->mask; + io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len), + var, p->field_len, NULL_TREE); + p = &st_parameter_field[IOPARM_dt_internal_unit_desc]; + desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + + gcc_assert (e->ts.type == BT_CHARACTER); + + /* Character scalars. */ + if (e->rank == 0) + { + gfc_conv_expr (&se, e); + gfc_conv_string_parameter (&se); + tmp = se.expr; + se.expr = build_int_cst (pchar_type_node, 0); + } + + /* Character array. */ + else if (e->rank > 0) + { + if (is_subref_array (e)) + { + /* Use a temporary for components of arrays of derived types + or substring array references. */ + gfc_conv_subref_array_arg (&se, e, 0, + last_dt == READ ? INTENT_IN : INTENT_OUT, false); + tmp = build_fold_indirect_ref_loc (input_location, + se.expr); + se.expr = gfc_build_addr_expr (pchar_type_node, tmp); + tmp = gfc_conv_descriptor_data_get (tmp); + } + else + { + /* Return the data pointer and rank from the descriptor. */ + gfc_conv_expr_descriptor (&se, e); + tmp = gfc_conv_descriptor_data_get (se.expr); + se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); + } + } + else + gcc_unreachable (); + + /* The cast is needed for character substrings and the descriptor + data. */ + gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp)); + gfc_add_modify (&se.pre, len, + fold_convert (TREE_TYPE (len), se.string_length)); + gfc_add_modify (&se.pre, desc, se.expr); + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (post_block, &se.post); + return mask; +} + +/* Add a case to a IO-result switch. */ + +static void +add_case (int label_value, gfc_st_label * label, stmtblock_t * body) +{ + tree tmp, value; + + if (label == NULL) + return; /* No label, no case */ + + value = build_int_cst (integer_type_node, label_value); + + /* Make a backend label for this case. */ + tmp = gfc_build_label_decl (NULL_TREE); + + /* And the case itself. */ + tmp = build_case_label (value, NULL_TREE, tmp); + gfc_add_expr_to_block (body, tmp); + + /* Jump to the label. */ + tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label)); + gfc_add_expr_to_block (body, tmp); +} + + +/* Generate a switch statement that branches to the correct I/O + result label. The last statement of an I/O call stores the + result into a variable because there is often cleanup that + must be done before the switch, so a temporary would have to + be created anyway. */ + +static void +io_result (stmtblock_t * block, tree var, gfc_st_label * err_label, + gfc_st_label * end_label, gfc_st_label * eor_label) +{ + stmtblock_t body; + tree tmp, rc; + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; + + /* If no labels are specified, ignore the result instead + of building an empty switch. */ + if (err_label == NULL + && end_label == NULL + && eor_label == NULL) + return; + + /* Build a switch statement. */ + gfc_start_block (&body); + + /* The label values here must be the same as the values + in the library_return enum in the runtime library */ + add_case (1, err_label, &body); + add_case (2, end_label, &body); + add_case (3, eor_label, &body); + + tmp = gfc_finish_block (&body); + + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), + var, p->field, NULL_TREE); + rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc), + rc, build_int_cst (TREE_TYPE (rc), + IOPARM_common_libreturn_mask)); + + tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, rc, tmp); + + gfc_add_expr_to_block (block, tmp); +} + + +/* Store the current file and line number to variables so that if a + library call goes awry, we can tell the user where the problem is. */ + +static void +set_error_locus (stmtblock_t * block, tree var, locus * where) +{ + gfc_file *f; + tree str, locus_file; + int line; + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename]; + + locus_file = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + locus_file = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field), locus_file, + p->field, NULL_TREE); + f = where->lb->file; + str = gfc_build_cstring_const (f->filename); + + str = gfc_build_addr_expr (pchar_type_node, str); + gfc_add_modify (block, locus_file, str); + + line = LOCATION_LINE (where->lb->location); + set_parameter_const (block, var, IOPARM_common_line, line); +} + + +/* Translate an OPEN statement. */ + +tree +gfc_trans_open (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_open *p; + tree tmp, var; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.open; + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + if (p->file) + mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file); + + if (p->status) + mask |= set_string (&block, &post_block, var, IOPARM_open_status, + p->status); + + if (p->access) + mask |= set_string (&block, &post_block, var, IOPARM_open_access, + p->access); + + if (p->form) + mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form); + + if (p->recl) + mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, + p->recl); + + if (p->blank) + mask |= set_string (&block, &post_block, var, IOPARM_open_blank, + p->blank); + + if (p->position) + mask |= set_string (&block, &post_block, var, IOPARM_open_position, + p->position); + + if (p->action) + mask |= set_string (&block, &post_block, var, IOPARM_open_action, + p->action); + + if (p->delim) + mask |= set_string (&block, &post_block, var, IOPARM_open_delim, + p->delim); + + if (p->pad) + mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); + + if (p->decimal) + mask |= set_string (&block, &post_block, var, IOPARM_open_decimal, + p->decimal); + + if (p->encoding) + mask |= set_string (&block, &post_block, var, IOPARM_open_encoding, + p->encoding); + + if (p->round) + mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round); + + if (p->sign) + mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign); + + if (p->asynchronous) + mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous, + p->asynchronous); + + if (p->convert) + mask |= set_string (&block, &post_block, var, IOPARM_open_convert, + p->convert); + + if (p->newunit) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit, + p->newunit); + + if (p->cc) + mask |= set_string (&block, &post_block, var, IOPARM_open_cc, p->cc); + + if (p->share) + mask |= set_string (&block, &post_block, var, IOPARM_open_share, p->share); + + mask |= set_parameter_const (&block, var, IOPARM_open_readonly, p->readonly); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_OPEN], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Translate a CLOSE statement. */ + +tree +gfc_trans_close (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_close *p; + tree tmp, var; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.close; + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + if (p->status) + mask |= set_string (&block, &post_block, var, IOPARM_close_status, + p->status); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_CLOSE], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Common subroutine for building a file positioning statement. */ + +static tree +build_filepos (tree function, gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_filepos *p; + tree tmp, var; + unsigned int mask = 0; + + p = code->ext.filepos; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type, + "filepos_parm"); + + set_error_locus (&block, var, &code->loc); + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_common_iostat, p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, + p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + function, 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Translate a BACKSPACE statement. */ + +tree +gfc_trans_backspace (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_BACKSPACE], code); +} + + +/* Translate an ENDFILE statement. */ + +tree +gfc_trans_endfile (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_ENDFILE], code); +} + + +/* Translate a REWIND statement. */ + +tree +gfc_trans_rewind (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_REWIND], code); +} + + +/* Translate a FLUSH statement. */ + +tree +gfc_trans_flush (gfc_code * code) +{ + return build_filepos (iocall[IOCALL_FLUSH], code); +} + + +/* Translate the non-IOLENGTH form of an INQUIRE statement. */ + +tree +gfc_trans_inquire (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_inquire *p; + tree tmp, var; + unsigned int mask = 0, mask2 = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type, + "inquire_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.inquire; + + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + /* Sanity check. */ + if (p->unit && p->file) + gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc); + + if (p->file) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, + p->file); + + if (p->exist) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, + p->exist); + + if (p->opened) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened, + p->opened); + + if (p->number) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number, + p->number); + + if (p->named) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named, + p->named); + + if (p->name) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_name, + p->name); + + if (p->access) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_access, + p->access); + + if (p->sequential) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential, + p->sequential); + + if (p->direct) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct, + p->direct); + + if (p->form) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_form, + p->form); + + if (p->formatted) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted, + p->formatted); + + if (p->unformatted) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted, + p->unformatted); + + if (p->recl) + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_recl_out, p->recl); + + if (p->nextrec) + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_nextrec, p->nextrec); + + if (p->blank) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank, + p->blank); + + if (p->delim) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim, + p->delim); + + if (p->position) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_position, + p->position); + + if (p->action) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_action, + p->action); + + if (p->read) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_read, + p->read); + + if (p->write) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_write, + p->write); + + if (p->readwrite) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite, + p->readwrite); + + if (p->pad) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad, + p->pad); + + if (p->convert) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert, + p->convert); + + if (p->strm_pos) + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_strm_pos_out, p->strm_pos); + + /* The second series of flags. */ + if (p->asynchronous) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous, + p->asynchronous); + + if (p->decimal) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal, + p->decimal); + + if (p->encoding) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding, + p->encoding); + + if (p->round) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round, + p->round); + + if (p->sign) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign, + p->sign); + + if (p->pending) + mask2 |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_pending, p->pending); + + if (p->size) + mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size, + p->size); + + if (p->id) + mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id, + p->id); + if (p->iqstream) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream, + p->iqstream); + + if (p->share) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_share, + p->share); + + if (p->cc) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_cc, p->cc); + + if (mask2) + mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + { + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit); + } + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_INQUIRE], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +tree +gfc_trans_wait (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_wait *p; + tree tmp, var; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type, + "wait_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.wait; + + /* Set parameters here. */ + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + if (p->id) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_WAIT], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); + +} + + +/* nml_full_name builds up the fully qualified name of a + derived type component. '+' is used to denote a type extension. */ + +static char* +nml_full_name (const char* var_name, const char* cmp_name, bool parent) +{ + int full_name_length; + char * full_name; + + full_name_length = strlen (var_name) + strlen (cmp_name) + 1; + full_name = XCNEWVEC (char, full_name_length + 1); + strcpy (full_name, var_name); + full_name = strcat (full_name, parent ? "+" : "%"); + full_name = strcat (full_name, cmp_name); + return full_name; +} + + +/* nml_get_addr_expr builds an address expression from the + gfc_symbol or gfc_component backend_decl's. An offset is + provided so that the address of an element of an array of + derived types is returned. This is used in the runtime to + determine that span of the derived type. */ + +static tree +nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, + tree base_addr) +{ + tree decl = NULL_TREE; + tree tmp; + + if (sym) + { + sym->attr.referenced = 1; + decl = gfc_get_symbol_decl (sym); + + /* If this is the enclosing function declaration, use + the fake result instead. */ + if (decl == current_function_decl) + decl = gfc_get_fake_result_decl (sym, 0); + else if (decl == DECL_CONTEXT (current_function_decl)) + decl = gfc_get_fake_result_decl (sym, 1); + } + else + decl = c->backend_decl; + + gcc_assert (decl && (TREE_CODE (decl) == FIELD_DECL + || VAR_P (decl) + || TREE_CODE (decl) == PARM_DECL + || TREE_CODE (decl) == COMPONENT_REF)); + + tmp = decl; + + /* Build indirect reference, if dummy argument. */ + + if (POINTER_TYPE_P (TREE_TYPE(tmp))) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + + /* Treat the component of a derived type, using base_addr for + the derived type. */ + + if (TREE_CODE (decl) == FIELD_DECL) + tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + base_addr, tmp, NULL_TREE); + + if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp)))) + tmp = gfc_class_data_get (tmp); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_array_data (tmp); + else + { + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + + if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) + tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL); + + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref_loc (input_location, + tmp); + } + + gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp))); + + return tmp; +} + + +/* For an object VAR_NAME whose base address is BASE_ADDR, generate a + call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively + generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */ + +#define IARG(i) build_int_cst (gfc_array_index_type, i) + +static void +transfer_namelist_element (stmtblock_t * block, const char * var_name, + gfc_symbol * sym, gfc_component * c, + tree base_addr) +{ + gfc_typespec * ts = NULL; + gfc_array_spec * as = NULL; + tree addr_expr = NULL; + tree dt = NULL; + tree string; + tree tmp; + tree dtype; + tree dt_parm_addr; + tree decl = NULL_TREE; + tree gfc_int4_type_node = gfc_get_int_type (4); + tree dtio_proc = null_pointer_node; + tree vtable = null_pointer_node; + int n_dim; + int rank = 0; + + gcc_assert (sym || c); + + /* Build the namelist object name. */ + + string = gfc_build_cstring_const (var_name); + string = gfc_build_addr_expr (pchar_type_node, string); + + /* Build ts, as and data address using symbol or component. */ + + ts = sym ? &sym->ts : &c->ts; + + if (ts->type != BT_CLASS) + as = sym ? sym->as : c->as; + else + as = sym ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as; + + addr_expr = nml_get_addr_expr (sym, c, base_addr); + + if (as) + rank = as->rank; + + if (rank) + { + decl = sym ? sym->backend_decl : c->backend_decl; + if (sym && sym->attr.dummy) + decl = build_fold_indirect_ref_loc (input_location, decl); + + if (ts->type == BT_CLASS) + decl = gfc_class_data_get (decl); + dt = TREE_TYPE (decl); + dtype = gfc_get_dtype (dt); + } + else + { + dt = gfc_typenode_for_spec (ts); + dtype = gfc_get_dtype_rank_type (0, dt); + } + + /* Build up the arguments for the transfer call. + The call for the scalar part transfers: + (address, name, type, kind or string_length, dtype) */ + + dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); + + /* Check if the derived type has a specific DTIO for the mode. + Note that although namelist io is forbidden to have a format + list, the specific subroutine is of the formatted kind. */ + if (ts->type == BT_DERIVED || ts->type == BT_CLASS) + { + gfc_symbol *derived; + if (ts->type==BT_CLASS) + derived = ts->u.derived->components->ts.u.derived; + else + derived = ts->u.derived; + + gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived, + last_dt == WRITE, true); + + if (ts->type == BT_CLASS && tb_io_st) + { + // polymorphic DTIO call (based on the dynamic type) + gfc_se se; + gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name); + // build vtable expr + gfc_expr *expr = gfc_get_variable_expr (st); + gfc_add_vptr_component (expr); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + vtable = se.expr; + // build dtio expr + gfc_add_component_ref (expr, + tb_io_st->n.tb->u.generic->specific_st->name); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + gfc_free_expr (expr); + dtio_proc = se.expr; + } + else + { + // non-polymorphic DTIO call (based on the declared type) + gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived, + last_dt == WRITE, true); + if (dtio_sub != NULL) + { + dtio_proc = gfc_get_symbol_decl (dtio_sub); + dtio_proc = gfc_build_addr_expr (NULL, dtio_proc); + gfc_symbol *vtab = gfc_find_derived_vtab (derived); + vtable = vtab->backend_decl; + if (vtable == NULL_TREE) + vtable = gfc_get_symbol_decl (vtab); + vtable = gfc_build_addr_expr (pvoid_type_node, vtable); + } + } + } + + if (ts->type == BT_CHARACTER) + tmp = ts->u.cl->backend_decl; + else + tmp = build_int_cst (gfc_charlen_type_node, 0); + + int abi_kind = gfc_type_abi_kind (ts); + if (dtio_proc == null_pointer_node) + tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_VAL], 6, + dt_parm_addr, addr_expr, string, + build_int_cst (gfc_int4_type_node, abi_kind), + tmp, dtype); + else + tmp = build_call_expr_loc (input_location, iocall[IOCALL_SET_NML_DTIO_VAL], + 8, dt_parm_addr, addr_expr, string, + build_int_cst (gfc_int4_type_node, abi_kind), + tmp, dtype, dtio_proc, vtable); + gfc_add_expr_to_block (block, tmp); + + /* If the object is an array, transfer rank times: + (null pointer, name, stride, lbound, ubound) */ + + for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) + { + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_SET_NML_VAL_DIM], 5, + dt_parm_addr, + build_int_cst (gfc_int4_type_node, n_dim), + gfc_conv_array_stride (decl, n_dim), + gfc_conv_array_lbound (decl, n_dim), + gfc_conv_array_ubound (decl, n_dim)); + gfc_add_expr_to_block (block, tmp); + } + + if (gfc_bt_struct (ts->type) && ts->u.derived->components + && dtio_proc == null_pointer_node) + { + gfc_component *cmp; + + /* Provide the RECORD_TYPE to build component references. */ + + tree expr = build_fold_indirect_ref_loc (input_location, + addr_expr); + + for (cmp = ts->u.derived->components; cmp; cmp = cmp->next) + { + char *full_name = nml_full_name (var_name, cmp->name, + ts->u.derived->attr.extension); + transfer_namelist_element (block, + full_name, + NULL, cmp, expr); + free (full_name); + } + } +} + +#undef IARG + +/* Create a data transfer statement. Not all of the fields are valid + for both reading and writing, but improper use has been filtered + out by now. */ + +static tree +build_dt (tree function, gfc_code * code) +{ + stmtblock_t block, post_block, post_end_block, post_iu_block; + gfc_dt *dt; + tree tmp, var; + gfc_expr *nmlname; + gfc_namelist *nml; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + gfc_init_block (&post_end_block); + gfc_init_block (&post_iu_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm"); + + set_error_locus (&block, var, &code->loc); + + if (last_dt == IOLENGTH) + { + gfc_inquire *inq; + + inq = code->ext.inquire; + + /* First check that preconditions are met. */ + gcc_assert (inq != NULL); + gcc_assert (inq->iolength != NULL); + + /* Connect to the iolength variable. */ + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_iolength, inq->iolength); + dt = NULL; + } + else + { + dt = code->ext.dt; + gcc_assert (dt != NULL); + } + + if (dt && dt->io_unit) + { + if (dt->io_unit->ts.type == BT_CHARACTER) + { + mask |= set_internal_unit (&block, &post_iu_block, + var, dt->io_unit); + set_parameter_const (&block, var, IOPARM_common_unit, + dt->io_unit->ts.kind == 1 ? + GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4); + } + } + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + + if (dt) + { + if (dt->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + dt->iomsg); + + if (dt->iostat) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_common_iostat, dt->iostat); + + if (dt->err) + mask |= IOPARM_common_err; + + if (dt->eor) + mask |= IOPARM_common_eor; + + if (dt->end) + mask |= IOPARM_common_end; + + if (dt->id) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_id, dt->id); + + if (dt->pos) + mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos); + + if (dt->asynchronous) + mask |= set_string (&block, &post_block, var, + IOPARM_dt_asynchronous, dt->asynchronous); + + if (dt->blank) + mask |= set_string (&block, &post_block, var, IOPARM_dt_blank, + dt->blank); + + if (dt->decimal) + mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal, + dt->decimal); + + if (dt->delim) + mask |= set_string (&block, &post_block, var, IOPARM_dt_delim, + dt->delim); + + if (dt->pad) + mask |= set_string (&block, &post_block, var, IOPARM_dt_pad, + dt->pad); + + if (dt->round) + mask |= set_string (&block, &post_block, var, IOPARM_dt_round, + dt->round); + + if (dt->sign) + mask |= set_string (&block, &post_block, var, IOPARM_dt_sign, + dt->sign); + + if (dt->rec) + mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); + + if (dt->advance) + mask |= set_string (&block, &post_block, var, IOPARM_dt_advance, + dt->advance); + + if (dt->format_expr) + mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format, + dt->format_expr); + + if (dt->format_label) + { + if (dt->format_label == &format_asterisk) + mask |= IOPARM_dt_list_format; + else + mask |= set_string (&block, &post_block, var, IOPARM_dt_format, + dt->format_label->format); + } + + if (dt->size) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_size, dt->size); + + if (dt->udtio) + mask |= IOPARM_dt_dtio; + + if (dt->dec_ext) + mask |= IOPARM_dt_dec_ext; + + if (dt->namelist) + { + if (dt->format_expr || dt->format_label) + gfc_internal_error ("build_dt: format with namelist"); + + nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL, + dt->namelist->name, + strlen (dt->namelist->name)); + + mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name, + nmlname); + + gfc_free_expr (nmlname); + + if (last_dt == READ) + mask |= IOPARM_dt_namelist_read_mode; + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + dt_parm = var; + + for (nml = dt->namelist->namelist; nml; nml = nml->next) + transfer_namelist_element (&block, nml->sym->name, nml->sym, + NULL, NULL_TREE); + } + else + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER) + set_parameter_value_chk (&block, dt->iostat, var, + IOPARM_common_unit, dt->io_unit); + } + else + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = build_call_expr_loc (UNKNOWN_LOCATION, + function, 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + dt_parm = var; + dt_post_end_block = &post_end_block; + + /* Set implied do loop exit condition. */ + if (last_dt == READ || last_dt == WRITE) + { + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; + + tmp = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), + NULL_TREE); + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (p->field), tmp, p->field, NULL_TREE); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + IOPARM_common_libreturn_mask)); + } + else /* IOLENGTH */ + tmp = NULL_TREE; + + gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp)); + + gfc_add_block_to_block (&block, &post_iu_block); + + dt_parm = NULL; + dt_post_end_block = NULL; + + return gfc_finish_block (&block); +} + + +/* Translate the IOLENGTH form of an INQUIRE statement. We treat + this as a third sort of data transfer statement, except that + lengths are summed instead of actually transferring any data. */ + +tree +gfc_trans_iolength (gfc_code * code) +{ + last_dt = IOLENGTH; + return build_dt (iocall[IOCALL_IOLENGTH], code); +} + + +/* Translate a READ statement. */ + +tree +gfc_trans_read (gfc_code * code) +{ + last_dt = READ; + return build_dt (iocall[IOCALL_READ], code); +} + + +/* Translate a WRITE statement */ + +tree +gfc_trans_write (gfc_code * code) +{ + last_dt = WRITE; + return build_dt (iocall[IOCALL_WRITE], code); +} + + +/* Finish a data transfer statement. */ + +tree +gfc_trans_dt_end (gfc_code * code) +{ + tree function, tmp; + stmtblock_t block; + + gfc_init_block (&block); + + switch (last_dt) + { + case READ: + function = iocall[IOCALL_READ_DONE]; + break; + + case WRITE: + function = iocall[IOCALL_WRITE_DONE]; + break; + + case IOLENGTH: + function = iocall[IOCALL_IOLENGTH_DONE]; + break; + + default: + gcc_unreachable (); + } + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + tmp = build_call_expr_loc (input_location, + function, 1, tmp); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, dt_post_end_block); + gfc_init_block (dt_post_end_block); + + if (last_dt != IOLENGTH) + { + gcc_assert (code->ext.dt != NULL); + io_result (&block, dt_parm, code->ext.dt->err, + code->ext.dt->end, code->ext.dt->eor); + } + + return gfc_finish_block (&block); +} + +static void +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, + gfc_code * code, tree vptr); + +/* Given an array field in a derived type variable, generate the code + for the loop that iterates over array elements, and the code that + accesses those array elements. Use transfer_expr to generate code + for transferring that element. Because elements may also be + derived types, transfer_expr and transfer_array_component are mutually + recursive. */ + +static tree +transfer_array_component (tree expr, gfc_component * cm, locus * where) +{ + tree tmp; + stmtblock_t body; + stmtblock_t block; + gfc_loopinfo loop; + int n; + gfc_ss *ss; + gfc_se se; + gfc_array_info *ss_array; + + gfc_start_block (&block); + gfc_init_se (&se, NULL); + + /* Create and initialize Scalarization Status. Unlike in + gfc_trans_transfer, we can't simply use gfc_walk_expr to take + care of this task, because we don't have a gfc_expr at hand. + Build one manually, as in gfc_trans_subarray_assign. */ + + ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank, + GFC_SS_COMPONENT); + ss_array = &ss->info->data.array; + + if (cm->attr.pdt_array) + ss_array->shape = NULL; + else + ss_array->shape = gfc_get_shape (cm->as->rank); + + ss_array->descriptor = expr; + ss_array->data = gfc_conv_array_data (expr); + ss_array->offset = gfc_conv_array_offset (expr); + for (n = 0; n < cm->as->rank; n++) + { + ss_array->start[n] = gfc_conv_array_lbound (expr, n); + ss_array->stride[n] = gfc_index_one_node; + + if (cm->attr.pdt_array) + ss_array->end[n] = gfc_conv_array_ubound (expr, n); + else + { + mpz_init (ss_array->shape[n]); + mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer, + cm->as->lower[n]->value.integer); + mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1); + } + } + + /* Once we got ss, we use scalarizer to create the loop. */ + + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, where); + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + + /* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */ + se.expr = expr; + gfc_conv_tmp_array_ref (&se); + + /* Now se.expr contains an element of the array. Take the address and pass + it to the IO routines. */ + tmp = gfc_build_addr_expr (NULL_TREE, se.expr); + transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE); + + /* We are done now with the loop body. Wrap up the scalarizer and + return. */ + + gfc_add_block_to_block (&body, &se.pre); + gfc_add_block_to_block (&body, &se.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + + if (!cm->attr.pdt_array) + { + gcc_assert (ss_array->shape != NULL); + gfc_free_shape (&ss_array->shape, cm->as->rank); + } + gfc_cleanup_loop (&loop); + + return gfc_finish_block (&block); +} + + +/* Helper function for transfer_expr that looks for the DTIO procedure + either as a typebound binding or in a generic interface. If present, + the address expression of the procedure is returned. It is assumed + that the procedure interface has been checked during resolution. */ + +static tree +get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub) +{ + gfc_symbol *derived; + bool formatted = false; + gfc_dt *dt = code->ext.dt; + + /* Determine when to use the formatted DTIO procedure. */ + if (dt && (dt->format_expr || dt->format_label)) + formatted = true; + + if (ts->type == BT_CLASS) + derived = ts->u.derived->components->ts.u.derived; + else + derived = ts->u.derived; + + gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived, + last_dt == WRITE, formatted); + if (ts->type == BT_CLASS && tb_io_st) + { + // polymorphic DTIO call (based on the dynamic type) + gfc_se se; + gfc_expr *expr = gfc_find_and_cut_at_last_class_ref (code->expr1); + gfc_add_vptr_component (expr); + gfc_add_component_ref (expr, + tb_io_st->n.tb->u.generic->specific_st->name); + *dtio_sub = tb_io_st->n.tb->u.generic->specific->u.specific->n.sym; + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + gfc_free_expr (expr); + return se.expr; + } + else + { + // non-polymorphic DTIO call (based on the declared type) + *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE, + formatted); + + if (*dtio_sub) + return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub)); + } + + return NULL_TREE; +} + +/* Generate the call for a scalar transfer node. */ + +static void +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, + gfc_code * code, tree vptr) +{ + tree tmp, function, arg2, arg3, field, expr; + gfc_component *c; + int kind; + + /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if + the user says something like: print *, 'c_null_ptr: ', c_null_ptr + We need to translate the expression to a constant if it's either + C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of + type C_PTR or C_FUNPTR, in which case the ts->type may no longer be + BT_DERIVED (could have been changed by gfc_conv_expr). */ + if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER) + && ts->u.derived != NULL + && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1)) + { + ts->type = BT_INTEGER; + ts->kind = gfc_index_integer_kind; + } + + /* gfortran reaches here for "print *, c_loc(xxx)". */ + if (ts->type == BT_VOID + && code->expr1 && code->expr1->ts.type == BT_VOID + && code->expr1->symtree + && strcmp (code->expr1->symtree->name, "c_loc") == 0) + { + ts->type = BT_INTEGER; + ts->kind = gfc_index_integer_kind; + } + + kind = gfc_type_abi_kind (ts); + function = NULL; + arg2 = NULL; + arg3 = NULL; + + switch (ts->type) + { + case BT_INTEGER: + arg2 = build_int_cst (integer_type_node, kind); + if (last_dt == READ) + function = iocall[IOCALL_X_INTEGER]; + else + function = iocall[IOCALL_X_INTEGER_WRITE]; + + break; + + case BT_REAL: + arg2 = build_int_cst (integer_type_node, kind); + if (last_dt == READ) + { + if ((gfc_real16_is_float128 && kind == 16) || kind == 17) + function = iocall[IOCALL_X_REAL128]; + else + function = iocall[IOCALL_X_REAL]; + } + else + { + if ((gfc_real16_is_float128 && kind == 16) || kind == 17) + function = iocall[IOCALL_X_REAL128_WRITE]; + else + function = iocall[IOCALL_X_REAL_WRITE]; + } + + break; + + case BT_COMPLEX: + arg2 = build_int_cst (integer_type_node, kind); + if (last_dt == READ) + { + if ((gfc_real16_is_float128 && kind == 16) || kind == 17) + function = iocall[IOCALL_X_COMPLEX128]; + else + function = iocall[IOCALL_X_COMPLEX]; + } + else + { + if ((gfc_real16_is_float128 && kind == 16) || kind == 17) + function = iocall[IOCALL_X_COMPLEX128_WRITE]; + else + function = iocall[IOCALL_X_COMPLEX_WRITE]; + } + + break; + + case BT_LOGICAL: + arg2 = build_int_cst (integer_type_node, kind); + if (last_dt == READ) + function = iocall[IOCALL_X_LOGICAL]; + else + function = iocall[IOCALL_X_LOGICAL_WRITE]; + + break; + + case BT_CHARACTER: + if (kind == 4) + { + if (se->string_length) + arg2 = se->string_length; + else + { + tmp = build_fold_indirect_ref_loc (input_location, + addr_expr); + gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); + arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); + arg2 = fold_convert (gfc_charlen_type_node, arg2); + } + arg3 = build_int_cst (integer_type_node, kind); + if (last_dt == READ) + function = iocall[IOCALL_X_CHARACTER_WIDE]; + else + function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE]; + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + tmp = build_call_expr_loc (input_location, + function, 4, tmp, addr_expr, arg2, arg3); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &se->post); + return; + } + /* Fall through. */ + case BT_HOLLERITH: + if (se->string_length) + arg2 = se->string_length; + else + { + tmp = build_fold_indirect_ref_loc (input_location, + addr_expr); + gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); + arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); + } + if (last_dt == READ) + function = iocall[IOCALL_X_CHARACTER]; + else + function = iocall[IOCALL_X_CHARACTER_WRITE]; + + break; + + case_bt_struct: + case BT_CLASS: + if (gfc_bt_struct (ts->type) || ts->type == BT_CLASS) + { + gfc_symbol *derived; + gfc_symbol *dtio_sub = NULL; + /* Test for a specific DTIO subroutine. */ + if (ts->type == BT_DERIVED) + derived = ts->u.derived; + else + derived = ts->u.derived->components->ts.u.derived; + + if (derived->attr.has_dtio_procs) + arg2 = get_dtio_proc (ts, code, &dtio_sub); + + if ((dtio_sub != NULL) && (last_dt != IOLENGTH)) + { + tree decl; + decl = build_fold_indirect_ref_loc (input_location, + se->expr); + /* Remember that the first dummy of the DTIO subroutines + is CLASS(derived) for extensible derived types, so the + conversion must be done here for derived type and for + scalarized CLASS array element io-list objects. */ + if ((ts->type == BT_DERIVED + && !(ts->u.derived->attr.sequence + || ts->u.derived->attr.is_bind_c)) + || (ts->type == BT_CLASS + && !GFC_CLASS_TYPE_P (TREE_TYPE (decl)))) + gfc_conv_derived_to_class (se, code->expr1, + dtio_sub->formal->sym->ts, + vptr, false, false); + addr_expr = se->expr; + function = iocall[IOCALL_X_DERIVED]; + break; + } + else if (gfc_bt_struct (ts->type)) + { + /* Recurse into the elements of the derived type. */ + expr = gfc_evaluate_now (addr_expr, &se->pre); + expr = build_fold_indirect_ref_loc (input_location, expr); + + /* Make sure that the derived type has been built. An external + function, if only referenced in an io statement, requires this + check (see PR58771). */ + if (ts->u.derived->backend_decl == NULL_TREE) + (void) gfc_typenode_for_spec (ts); + + for (c = ts->u.derived->components; c; c = c->next) + { + /* Ignore hidden string lengths. */ + if (c->name[0] == '_') + continue; + + field = c->backend_decl; + gcc_assert (field && TREE_CODE (field) == FIELD_DECL); + + tmp = fold_build3_loc (UNKNOWN_LOCATION, + COMPONENT_REF, TREE_TYPE (field), + expr, field, NULL_TREE); + + if (c->attr.dimension) + { + tmp = transfer_array_component (tmp, c, & code->loc); + gfc_add_expr_to_block (&se->pre, tmp); + } + else + { + tree strlen = NULL_TREE; + + if (!c->attr.pointer && !c->attr.pdt_string) + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + + /* Use the hidden string length for pdt strings. */ + if (c->attr.pdt_string + && gfc_deferred_strlen (c, &strlen) + && strlen != NULL_TREE) + { + strlen = fold_build3_loc (UNKNOWN_LOCATION, + COMPONENT_REF, + TREE_TYPE (strlen), + expr, strlen, NULL_TREE); + se->string_length = strlen; + } + + transfer_expr (se, &c->ts, tmp, code, NULL_TREE); + + /* Reset so that the pdt string length does not propagate + through to other strings. */ + if (c->attr.pdt_string && strlen) + se->string_length = NULL_TREE; + } + } + return; + } + /* If a CLASS object gets through to here, fall through and ICE. */ + } + gcc_fallthrough (); + default: + gfc_internal_error ("Bad IO basetype (%d)", ts->type); + } + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + tmp = build_call_expr_loc (input_location, + function, 3, tmp, addr_expr, arg2); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &se->post); + +} + + +/* Generate a call to pass an array descriptor to the IO library. The + array should be of one of the intrinsic types. */ + +static void +transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr) +{ + tree tmp, charlen_arg, kind_arg, io_call; + + if (ts->type == BT_CHARACTER) + charlen_arg = se->string_length; + else + charlen_arg = build_int_cst (gfc_charlen_type_node, 0); + + kind_arg = build_int_cst (integer_type_node, gfc_type_abi_kind (ts)); + + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + if (last_dt == READ) + io_call = iocall[IOCALL_X_ARRAY]; + else + io_call = iocall[IOCALL_X_ARRAY_WRITE]; + + tmp = build_call_expr_loc (UNKNOWN_LOCATION, + io_call, 4, + tmp, addr_expr, kind_arg, charlen_arg); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &se->post); +} + + +/* gfc_trans_transfer()-- Translate a TRANSFER code node */ + +tree +gfc_trans_transfer (gfc_code * code) +{ + stmtblock_t block, body; + gfc_loopinfo loop; + gfc_expr *expr; + gfc_ref *ref; + gfc_ss *ss; + gfc_se se; + tree tmp; + tree vptr; + int n; + + gfc_start_block (&block); + gfc_init_block (&body); + + expr = code->expr1; + ref = NULL; + gfc_init_se (&se, NULL); + + if (expr->rank == 0) + { + /* Transfer a scalar value. */ + if (expr->ts.type == BT_CLASS) + { + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + vptr = gfc_get_vptr_from_expr (se.expr); + } + else + { + vptr = NULL_TREE; + gfc_conv_expr_reference (&se, expr); + } + transfer_expr (&se, &expr->ts, se.expr, code, vptr); + } + else + { + /* Transfer an array. If it is an array of an intrinsic + type, pass the descriptor to the library. Otherwise + scalarize the transfer. */ + if (expr->ref && !gfc_is_proc_ptr_comp (expr)) + { + for (ref = expr->ref; ref && ref->type != REF_ARRAY; + ref = ref->next); + gcc_assert (ref && ref->type == REF_ARRAY); + } + + if (expr->ts.type != BT_CLASS + && expr->expr_type == EXPR_VARIABLE + && gfc_expr_attr (expr).pointer) + goto scalarize; + + + if (!(gfc_bt_struct (expr->ts.type) + || expr->ts.type == BT_CLASS) + && ref && ref->next == NULL + && !is_subref_array (expr)) + { + bool seen_vector = false; + + if (ref && ref->u.ar.type == AR_SECTION) + { + for (n = 0; n < ref->u.ar.dimen; n++) + if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) + { + seen_vector = true; + break; + } + } + + if (seen_vector && last_dt == READ) + { + /* Create a temp, read to that and copy it back. */ + gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false); + tmp = se.expr; + } + else + { + /* Get the descriptor. */ + gfc_conv_expr_descriptor (&se, expr); + tmp = gfc_build_addr_expr (NULL_TREE, se.expr); + } + + transfer_array_desc (&se, &expr->ts, tmp); + goto finish_block_label; + } + +scalarize: + /* Initialize the scalarizer. */ + ss = gfc_walk_expr (expr); + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &code->expr1->where); + + /* The main loop body. */ + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + + gfc_conv_expr_reference (&se, expr); + + if (expr->ts.type == BT_CLASS) + vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor); + else + vptr = NULL_TREE; + transfer_expr (&se, &expr->ts, se.expr, code, vptr); + } + + finish_block_label: + + gfc_add_block_to_block (&body, &se.pre); + gfc_add_block_to_block (&body, &se.post); + + if (se.ss == NULL) + tmp = gfc_finish_block (&body); + else + { + gcc_assert (expr->rank != 0); + gcc_assert (se.ss == gfc_ss_terminator); + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&loop.pre, &loop.post); + tmp = gfc_finish_block (&loop.pre); + gfc_cleanup_loop (&loop); + } + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + +#include "gt-fortran-trans-io.h" diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c deleted file mode 100644 index d363258..0000000 --- a/gcc/fortran/trans-openmp.c +++ /dev/null @@ -1,7701 +0,0 @@ -/* OpenMP directive translation -- generate GCC trees from gfc_code. - Copyright (C) 2005-2022 Free Software Foundation, Inc. - Contributed by Jakub Jelinek - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "tree.h" -#include "gfortran.h" -#include "gimple-expr.h" -#include "trans.h" -#include "stringpool.h" -#include "fold-const.h" -#include "gimplify.h" /* For create_tmp_var_raw. */ -#include "trans-stmt.h" -#include "trans-types.h" -#include "trans-array.h" -#include "trans-const.h" -#include "arith.h" -#include "constructor.h" -#include "gomp-constants.h" -#include "omp-general.h" -#include "omp-low.h" -#include "memmodel.h" /* For MEMMODEL_ enums. */ - -#undef GCC_DIAG_STYLE -#define GCC_DIAG_STYLE __gcc_tdiag__ -#include "diagnostic-core.h" -#undef GCC_DIAG_STYLE -#define GCC_DIAG_STYLE __gcc_gfc__ -#include "attribs.h" -#include "function.h" - -int ompws_flags; - -/* True if OpenMP should regard this DECL as being a scalar which has Fortran's - allocatable or pointer attribute. */ - -bool -gfc_omp_is_allocatable_or_ptr (const_tree decl) -{ - return (DECL_P (decl) - && (GFC_DECL_GET_SCALAR_POINTER (decl) - || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))); -} - -/* True if the argument is an optional argument; except that false is also - returned for arguments with the value attribute (nonpointers) and for - assumed-shape variables (decl is a local variable containing arg->data). - Note that for 'procedure(), optional' the value false is used as that's - always a pointer and no additional indirection is used. - Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */ - -static bool -gfc_omp_is_optional_argument (const_tree decl) -{ - /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */ - return ((TREE_CODE (decl) == PARM_DECL || TREE_CODE (decl) == VAR_DECL) - && DECL_LANG_SPECIFIC (decl) - && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE - && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) - && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE - && GFC_DECL_OPTIONAL_ARGUMENT (decl)); -} - -/* Check whether this DECL belongs to a Fortran optional argument. - With 'for_present_check' set to false, decls which are optional parameters - themselve are returned as tree - or a NULL_TREE otherwise. Those decls are - always pointers. With 'for_present_check' set to true, the decl for checking - whether an argument is present is returned; for arguments with value - attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is - unrelated to optional arguments, NULL_TREE is returned. */ - -tree -gfc_omp_check_optional_argument (tree decl, bool for_present_check) -{ - if (!for_present_check) - return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE; - - if (!DECL_LANG_SPECIFIC (decl)) - return NULL_TREE; - - tree orig_decl = decl; - - /* For assumed-shape arrays, a local decl with arg->data is used. */ - if (TREE_CODE (decl) != PARM_DECL - && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) - || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - - /* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */ - if (decl == NULL_TREE - || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL) - || !DECL_LANG_SPECIFIC (decl) - || !GFC_DECL_OPTIONAL_ARGUMENT (decl)) - return NULL_TREE; - - /* Scalars with VALUE attribute which are passed by value use a hidden - argument to denote the present status. They are passed as nonpointer type - with one exception: 'type(c_ptr), value' as 'void*'. */ - /* Cf. trans-expr.c's gfc_conv_expr_present. */ - if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE - || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) - { - char name[GFC_MAX_SYMBOL_LEN + 2]; - tree tree_name; - - name[0] = '_'; - strcpy (&name[1], IDENTIFIER_POINTER (DECL_NAME (decl))); - tree_name = get_identifier (name); - - /* Walk function argument list to find the hidden arg. */ - decl = DECL_ARGUMENTS (DECL_CONTEXT (decl)); - for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl)) - if (DECL_NAME (decl) == tree_name - && DECL_ARTIFICIAL (decl)) - break; - - gcc_assert (decl); - return decl; - } - - return fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - orig_decl, null_pointer_node); -} - - -/* Returns tree with NULL if it is not an array descriptor and with the tree to - access the 'data' component otherwise. With type_only = true, it returns the - TREE_TYPE without creating a new tree. */ - -tree -gfc_omp_array_data (tree decl, bool type_only) -{ - tree type = TREE_TYPE (decl); - - if (POINTER_TYPE_P (type)) - type = TREE_TYPE (type); - - if (!GFC_DESCRIPTOR_TYPE_P (type)) - return NULL_TREE; - - if (type_only) - return GFC_TYPE_ARRAY_DATAPTR_TYPE (type); - - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref (decl); - - decl = gfc_conv_descriptor_data_get (decl); - STRIP_NOPS (decl); - return decl; -} - -/* True if OpenMP should privatize what this DECL points to rather - than the DECL itself. */ - -bool -gfc_omp_privatize_by_reference (const_tree decl) -{ - tree type = TREE_TYPE (decl); - - if (TREE_CODE (type) == REFERENCE_TYPE - && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL)) - return true; - - if (TREE_CODE (type) == POINTER_TYPE - && gfc_omp_is_optional_argument (decl)) - return true; - - if (TREE_CODE (type) == POINTER_TYPE) - { - while (TREE_CODE (decl) == COMPONENT_REF) - decl = TREE_OPERAND (decl, 1); - - /* Array POINTER/ALLOCATABLE have aggregate types, all user variables - that have POINTER_TYPE type and aren't scalar pointers, scalar - allocatables, Cray pointees or C pointers are supposed to be - privatized by reference. */ - if (GFC_DECL_GET_SCALAR_POINTER (decl) - || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) - || GFC_DECL_CRAY_POINTEE (decl) - || GFC_DECL_ASSOCIATE_VAR_P (decl) - || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) - return false; - - if (!DECL_ARTIFICIAL (decl) - && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE) - return true; - - /* Some arrays are expanded as DECL_ARTIFICIAL pointers - by the frontend. */ - if (DECL_LANG_SPECIFIC (decl) - && GFC_DECL_SAVED_DESCRIPTOR (decl)) - return true; - } - - return false; -} - -/* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute - of DECL is predetermined. */ - -enum omp_clause_default_kind -gfc_omp_predetermined_sharing (tree decl) -{ - /* Associate names preserve the association established during ASSOCIATE. - As they are implemented either as pointers to the selector or array - descriptor and shouldn't really change in the ASSOCIATE region, - this decl can be either shared or firstprivate. If it is a pointer, - use firstprivate, as it is cheaper that way, otherwise make it shared. */ - if (GFC_DECL_ASSOCIATE_VAR_P (decl)) - { - if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) - return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; - else - return OMP_CLAUSE_DEFAULT_SHARED; - } - - if (DECL_ARTIFICIAL (decl) - && ! GFC_DECL_RESULT (decl) - && ! (DECL_LANG_SPECIFIC (decl) - && GFC_DECL_SAVED_DESCRIPTOR (decl))) - return OMP_CLAUSE_DEFAULT_SHARED; - - /* Cray pointees shouldn't be listed in any clauses and should be - gimplified to dereference of the corresponding Cray pointer. - Make them all private, so that they are emitted in the debug - information. */ - if (GFC_DECL_CRAY_POINTEE (decl)) - return OMP_CLAUSE_DEFAULT_PRIVATE; - - /* Assumed-size arrays are predetermined shared. */ - if (TREE_CODE (decl) == PARM_DECL - && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN - && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), - GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) - == NULL) - return OMP_CLAUSE_DEFAULT_SHARED; - - /* Dummy procedures aren't considered variables by OpenMP, thus are - disallowed in OpenMP clauses. They are represented as PARM_DECLs - in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here - to avoid complaining about their uses with default(none). */ - if (TREE_CODE (decl) == PARM_DECL - && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE - && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE) - return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; - - /* COMMON and EQUIVALENCE decls are shared. They - are only referenced through DECL_VALUE_EXPR of the variables - contained in them. If those are privatized, they will not be - gimplified to the COMMON or EQUIVALENCE decls. */ - if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) - return OMP_CLAUSE_DEFAULT_SHARED; - - if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) - return OMP_CLAUSE_DEFAULT_SHARED; - - /* These are either array or derived parameters, or vtables. - In the former cases, the OpenMP standard doesn't consider them to be - variables at all (they can't be redefined), but they can nevertheless appear - in parallel/task regions and for default(none) purposes treat them as shared. - For vtables likely the same handling is desirable. */ - if (VAR_P (decl) && TREE_READONLY (decl) - && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) - return OMP_CLAUSE_DEFAULT_SHARED; - - return OMP_CLAUSE_DEFAULT_UNSPECIFIED; -} - - -/* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute - of DECL is predetermined. */ - -enum omp_clause_defaultmap_kind -gfc_omp_predetermined_mapping (tree decl) -{ - if (DECL_ARTIFICIAL (decl) - && ! GFC_DECL_RESULT (decl) - && ! (DECL_LANG_SPECIFIC (decl) - && GFC_DECL_SAVED_DESCRIPTOR (decl))) - return OMP_CLAUSE_DEFAULTMAP_TO; - - /* These are either array or derived parameters, or vtables. */ - if (VAR_P (decl) && TREE_READONLY (decl) - && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) - return OMP_CLAUSE_DEFAULTMAP_TO; - - return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; -} - - -/* Return decl that should be used when reporting DEFAULT(NONE) - diagnostics. */ - -tree -gfc_omp_report_decl (tree decl) -{ - if (DECL_ARTIFICIAL (decl) - && DECL_LANG_SPECIFIC (decl) - && GFC_DECL_SAVED_DESCRIPTOR (decl)) - return GFC_DECL_SAVED_DESCRIPTOR (decl); - - return decl; -} - -/* Return true if TYPE has any allocatable components. */ - -static bool -gfc_has_alloc_comps (tree type, tree decl) -{ - tree field, ftype; - - if (POINTER_TYPE_P (type)) - { - if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) - type = TREE_TYPE (type); - else if (GFC_DECL_GET_SCALAR_POINTER (decl)) - return false; - } - - if (GFC_DESCRIPTOR_TYPE_P (type) - && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER - || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) - return false; - - if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) - type = gfc_get_element_type (type); - - if (TREE_CODE (type) != RECORD_TYPE) - return false; - - for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) - { - ftype = TREE_TYPE (field); - if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) - return true; - if (GFC_DESCRIPTOR_TYPE_P (ftype) - && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) - return true; - if (gfc_has_alloc_comps (ftype, field)) - return true; - } - return false; -} - -/* Return true if TYPE is polymorphic but not with pointer attribute. */ - -static bool -gfc_is_polymorphic_nonptr (tree type) -{ - if (POINTER_TYPE_P (type)) - type = TREE_TYPE (type); - return GFC_CLASS_TYPE_P (type); -} - -/* Return true if TYPE is unlimited polymorphic but not with pointer attribute; - unlimited means also intrinsic types are handled and _len is used. */ - -static bool -gfc_is_unlimited_polymorphic_nonptr (tree type) -{ - if (POINTER_TYPE_P (type)) - type = TREE_TYPE (type); - if (!GFC_CLASS_TYPE_P (type)) - return false; - - tree field = TYPE_FIELDS (type); /* _data */ - gcc_assert (field); - field = DECL_CHAIN (field); /* _vptr */ - gcc_assert (field); - field = DECL_CHAIN (field); - if (!field) - return false; - gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0); - return true; -} - -/* Return true if the DECL is for an allocatable array or scalar. */ - -bool -gfc_omp_allocatable_p (tree decl) -{ - if (!DECL_P (decl)) - return false; - - if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) - return true; - - tree type = TREE_TYPE (decl); - if (gfc_omp_privatize_by_reference (decl)) - type = TREE_TYPE (type); - - if (GFC_DESCRIPTOR_TYPE_P (type) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) - return true; - - return false; -} - - -/* Return true if DECL in private clause needs - OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ -bool -gfc_omp_private_outer_ref (tree decl) -{ - tree type = TREE_TYPE (decl); - - if (gfc_omp_privatize_by_reference (decl)) - type = TREE_TYPE (type); - - if (GFC_DESCRIPTOR_TYPE_P (type) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) - return true; - - if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) - return true; - - if (gfc_has_alloc_comps (type, decl)) - return true; - - return false; -} - -/* Callback for gfc_omp_unshare_expr. */ - -static tree -gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *) -{ - tree t = *tp; - enum tree_code code = TREE_CODE (t); - - /* Stop at types, decls, constants like copy_tree_r. */ - if (TREE_CODE_CLASS (code) == tcc_type - || TREE_CODE_CLASS (code) == tcc_declaration - || TREE_CODE_CLASS (code) == tcc_constant - || code == BLOCK) - *walk_subtrees = 0; - else if (handled_component_p (t) - || TREE_CODE (t) == MEM_REF) - { - *tp = unshare_expr (t); - *walk_subtrees = 0; - } - - return NULL_TREE; -} - -/* Unshare in expr anything that the FE which normally doesn't - care much about tree sharing (because during gimplification - everything is unshared) could cause problems with tree sharing - at omp-low.c time. */ - -static tree -gfc_omp_unshare_expr (tree expr) -{ - walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL); - return expr; -} - -enum walk_alloc_comps -{ - WALK_ALLOC_COMPS_DTOR, - WALK_ALLOC_COMPS_DEFAULT_CTOR, - WALK_ALLOC_COMPS_COPY_CTOR -}; - -/* Handle allocatable components in OpenMP clauses. */ - -static tree -gfc_walk_alloc_comps (tree decl, tree dest, tree var, - enum walk_alloc_comps kind) -{ - stmtblock_t block, tmpblock; - tree type = TREE_TYPE (decl), then_b, tem, field; - gfc_init_block (&block); - - if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) - { - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - gfc_init_block (&tmpblock); - tem = gfc_full_array_size (&tmpblock, decl, - GFC_TYPE_ARRAY_RANK (type)); - then_b = gfc_finish_block (&tmpblock); - gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b)); - tem = gfc_omp_unshare_expr (tem); - tem = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tem, - gfc_index_one_node); - } - else - { - bool compute_nelts = false; - if (!TYPE_DOMAIN (type) - || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE - || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node - || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) - compute_nelts = true; - else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) - { - tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); - if (lookup_attribute ("omp dummy var", a)) - compute_nelts = true; - } - if (compute_nelts) - { - tem = fold_build2 (EXACT_DIV_EXPR, sizetype, - TYPE_SIZE_UNIT (type), - TYPE_SIZE_UNIT (TREE_TYPE (type))); - tem = size_binop (MINUS_EXPR, tem, size_one_node); - } - else - tem = array_type_nelts (type); - tem = fold_convert (gfc_array_index_type, tem); - } - - tree nelems = gfc_evaluate_now (tem, &block); - tree index = gfc_create_var (gfc_array_index_type, "S"); - - gfc_init_block (&tmpblock); - tem = gfc_conv_array_data (decl); - tree declvar = build_fold_indirect_ref_loc (input_location, tem); - tree declvref = gfc_build_array_ref (declvar, index, NULL); - tree destvar, destvref = NULL_TREE; - if (dest) - { - tem = gfc_conv_array_data (dest); - destvar = build_fold_indirect_ref_loc (input_location, tem); - destvref = gfc_build_array_ref (destvar, index, NULL); - } - gfc_add_expr_to_block (&tmpblock, - gfc_walk_alloc_comps (declvref, destvref, - var, kind)); - - gfc_loopinfo loop; - 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, &tmpblock); - gfc_add_block_to_block (&block, &loop.pre); - return gfc_finish_block (&block); - } - else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var)) - { - decl = build_fold_indirect_ref_loc (input_location, decl); - if (dest) - dest = build_fold_indirect_ref_loc (input_location, dest); - type = TREE_TYPE (decl); - } - - gcc_assert (TREE_CODE (type) == RECORD_TYPE); - for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) - { - tree ftype = TREE_TYPE (field); - tree declf, destf = NULL_TREE; - bool has_alloc_comps = gfc_has_alloc_comps (ftype, field); - if ((!GFC_DESCRIPTOR_TYPE_P (ftype) - || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE) - && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field) - && !has_alloc_comps) - continue; - declf = fold_build3_loc (input_location, COMPONENT_REF, ftype, - decl, field, NULL_TREE); - if (dest) - destf = fold_build3_loc (input_location, COMPONENT_REF, ftype, - dest, field, NULL_TREE); - - tem = NULL_TREE; - switch (kind) - { - case WALK_ALLOC_COMPS_DTOR: - break; - case WALK_ALLOC_COMPS_DEFAULT_CTOR: - if (GFC_DESCRIPTOR_TYPE_P (ftype) - && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) - { - gfc_add_modify (&block, unshare_expr (destf), - unshare_expr (declf)); - tem = gfc_duplicate_allocatable_nocopy - (destf, declf, ftype, - GFC_TYPE_ARRAY_RANK (ftype)); - } - else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) - tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0); - break; - case WALK_ALLOC_COMPS_COPY_CTOR: - if (GFC_DESCRIPTOR_TYPE_P (ftype) - && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) - tem = gfc_duplicate_allocatable (destf, declf, ftype, - GFC_TYPE_ARRAY_RANK (ftype), - NULL_TREE); - else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) - tem = gfc_duplicate_allocatable (destf, declf, ftype, 0, - NULL_TREE); - break; - } - if (tem) - gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); - if (has_alloc_comps) - { - gfc_init_block (&tmpblock); - gfc_add_expr_to_block (&tmpblock, - gfc_walk_alloc_comps (declf, destf, - field, kind)); - then_b = gfc_finish_block (&tmpblock); - if (GFC_DESCRIPTOR_TYPE_P (ftype) - && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) - tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); - else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) - tem = unshare_expr (declf); - else - tem = NULL_TREE; - if (tem) - { - tem = fold_convert (pvoid_type_node, tem); - tem = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tem, - null_pointer_node); - then_b = build3_loc (input_location, COND_EXPR, void_type_node, - tem, then_b, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&block, then_b); - } - if (kind == WALK_ALLOC_COMPS_DTOR) - { - if (GFC_DESCRIPTOR_TYPE_P (ftype) - && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) - { - tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); - tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, - NULL, - GFC_CAF_COARRAY_NOCOARRAY); - gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); - } - else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) - { - tem = gfc_call_free (unshare_expr (declf)); - gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); - } - } - } - - return gfc_finish_block (&block); -} - -/* Return code to initialize DECL with its default constructor, or - NULL if there's nothing to do. */ - -tree -gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) -{ - tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b; - stmtblock_t block, cond_block; - - switch (OMP_CLAUSE_CODE (clause)) - { - case OMP_CLAUSE__LOOPTEMP_: - case OMP_CLAUSE__REDUCTEMP_: - case OMP_CLAUSE__CONDTEMP_: - case OMP_CLAUSE__SCANTEMP_: - return NULL; - case OMP_CLAUSE_PRIVATE: - case OMP_CLAUSE_LASTPRIVATE: - case OMP_CLAUSE_LINEAR: - case OMP_CLAUSE_REDUCTION: - case OMP_CLAUSE_IN_REDUCTION: - case OMP_CLAUSE_TASK_REDUCTION: - break; - default: - gcc_unreachable (); - } - - if ((! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) - || !POINTER_TYPE_P (type))) - { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - gcc_assert (outer); - gfc_start_block (&block); - tree tem = gfc_walk_alloc_comps (outer, decl, - OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_DEFAULT_CTOR); - gfc_add_expr_to_block (&block, tem); - return gfc_finish_block (&block); - } - return NULL_TREE; - } - - gcc_assert (outer != NULL_TREE); - - /* Allocatable arrays and scalars in PRIVATE clauses need to be set to - "not currently allocated" allocation status if outer - array is "not currently allocated", otherwise should be allocated. */ - gfc_start_block (&block); - - gfc_init_block (&cond_block); - - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - gfc_add_modify (&cond_block, decl, outer); - tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (decl, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, - gfc_conv_descriptor_lbound_get (decl, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (decl, rank)); - tree esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = unshare_expr (size); - size = gfc_evaluate_now (fold_convert (size_type_node, size), - &cond_block); - } - else - size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); - ptr = gfc_create_var (pvoid_type_node, NULL); - gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); - if (GFC_DESCRIPTOR_TYPE_P (type)) - gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr); - else - gfc_add_modify (&cond_block, unshare_expr (decl), - fold_convert (TREE_TYPE (decl), ptr)); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - tree tem = gfc_walk_alloc_comps (outer, decl, - OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_DEFAULT_CTOR); - gfc_add_expr_to_block (&cond_block, tem); - } - then_b = gfc_finish_block (&cond_block); - - /* Reduction clause requires allocated ALLOCATABLE. */ - if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION - && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_IN_REDUCTION - && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_TASK_REDUCTION) - { - gfc_init_block (&cond_block); - if (GFC_DESCRIPTOR_TYPE_P (type)) - gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), - null_pointer_node); - else - gfc_add_modify (&cond_block, unshare_expr (decl), - build_zero_cst (TREE_TYPE (decl))); - else_b = gfc_finish_block (&cond_block); - - tree tem = fold_convert (pvoid_type_node, - GFC_DESCRIPTOR_TYPE_P (type) - ? gfc_conv_descriptor_data_get (outer) : outer); - tem = unshare_expr (tem); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tem, null_pointer_node); - gfc_add_expr_to_block (&block, - build3_loc (input_location, COND_EXPR, - void_type_node, cond, then_b, - else_b)); - /* Avoid -W*uninitialized warnings. */ - if (DECL_P (decl)) - suppress_warning (decl, OPT_Wuninitialized); - } - else - gfc_add_expr_to_block (&block, then_b); - - return gfc_finish_block (&block); -} - -/* Build and return code for a copy constructor from SRC to DEST. */ - -tree -gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) -{ - tree type = TREE_TYPE (dest), ptr, size, call; - tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); - tree cond, then_b, else_b; - stmtblock_t block, cond_block; - - gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE - || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); - - if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) - && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) - && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) - decl_type - = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); - - if (gfc_is_polymorphic_nonptr (decl_type)) - { - if (POINTER_TYPE_P (decl_type)) - decl_type = TREE_TYPE (decl_type); - decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); - if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) - fatal_error (input_location, - "Sorry, polymorphic arrays not yet supported for " - "firstprivate"); - tree src_len; - tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */ - tree src_data = gfc_class_data_get (unshare_expr (src)); - tree dest_data = gfc_class_data_get (unshare_expr (dest)); - bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type); - - gfc_start_block (&block); - gfc_add_modify (&block, gfc_class_vptr_get (dest), - gfc_class_vptr_get (src)); - gfc_init_block (&cond_block); - - if (unlimited) - { - src_len = gfc_class_len_get (src); - gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len); - } - - /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */ - size = fold_convert (size_type_node, gfc_class_vtab_size_get (src)); - if (unlimited) - { - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, - unshare_expr (src_len), - build_zero_cst (TREE_TYPE (src_len))); - cond = build3_loc (input_location, COND_EXPR, size_type_node, cond, - fold_convert (size_type_node, - unshare_expr (src_len)), - build_int_cst (size_type_node, 1)); - size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, - size, cond); - } - - /* Malloc memory + call class->_vpt->_copy. */ - call = builtin_decl_explicit (BUILT_IN_MALLOC); - call = build_call_expr_loc (input_location, call, 1, size); - gfc_add_modify (&cond_block, dest_data, - fold_convert (TREE_TYPE (dest_data), call)); - gfc_add_expr_to_block (&cond_block, - gfc_copy_class_to_class (src, dest, nelems, - unlimited)); - - gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF); - if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1))) - { - gfc_add_block_to_block (&block, &cond_block); - } - else - { - /* Create: if (class._data != 0) else class._data = NULL; */ - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - src_data, null_pointer_node); - gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, - void_type_node, cond, - gfc_finish_block (&cond_block), - fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - unshare_expr (dest_data), null_pointer_node))); - } - return gfc_finish_block (&block); - } - - if ((! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) - || !POINTER_TYPE_P (type))) - { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - gfc_start_block (&block); - gfc_add_modify (&block, dest, src); - tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_COPY_CTOR); - gfc_add_expr_to_block (&block, tem); - return gfc_finish_block (&block); - } - else - return build2_v (MODIFY_EXPR, dest, src); - } - - /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated - and copied from SRC. */ - gfc_start_block (&block); - - gfc_init_block (&cond_block); - - gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src)); - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (dest, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, - gfc_conv_descriptor_lbound_get (dest, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (dest, rank)); - tree esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = unshare_expr (size); - size = gfc_evaluate_now (fold_convert (size_type_node, size), - &cond_block); - } - else - size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); - ptr = gfc_create_var (pvoid_type_node, NULL); - gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); - if (GFC_DESCRIPTOR_TYPE_P (type)) - gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr); - else - gfc_add_modify (&cond_block, unshare_expr (dest), - fold_convert (TREE_TYPE (dest), ptr)); - - tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) - ? gfc_conv_descriptor_data_get (src) : src; - srcptr = unshare_expr (srcptr); - srcptr = fold_convert (pvoid_type_node, srcptr); - call = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, - srcptr, size); - gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - tree tem = gfc_walk_alloc_comps (src, dest, - OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_COPY_CTOR); - gfc_add_expr_to_block (&cond_block, tem); - } - then_b = gfc_finish_block (&cond_block); - - gfc_init_block (&cond_block); - if (GFC_DESCRIPTOR_TYPE_P (type)) - gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), - null_pointer_node); - else - gfc_add_modify (&cond_block, unshare_expr (dest), - build_zero_cst (TREE_TYPE (dest))); - else_b = gfc_finish_block (&cond_block); - - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - unshare_expr (srcptr), null_pointer_node); - gfc_add_expr_to_block (&block, - build3_loc (input_location, COND_EXPR, - void_type_node, cond, then_b, else_b)); - /* Avoid -W*uninitialized warnings. */ - if (DECL_P (dest)) - suppress_warning (dest, OPT_Wuninitialized); - - return gfc_finish_block (&block); -} - -/* Similarly, except use an intrinsic or pointer assignment operator - instead. */ - -tree -gfc_omp_clause_assign_op (tree clause, tree dest, tree src) -{ - tree type = TREE_TYPE (dest), ptr, size, call, nonalloc; - tree cond, then_b, else_b; - stmtblock_t block, cond_block, cond_block2, inner_block; - - if ((! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) - || !POINTER_TYPE_P (type))) - { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - gfc_start_block (&block); - /* First dealloc any allocatable components in DEST. */ - tree tem = gfc_walk_alloc_comps (dest, NULL_TREE, - OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_DTOR); - gfc_add_expr_to_block (&block, tem); - /* Then copy over toplevel data. */ - gfc_add_modify (&block, dest, src); - /* Finally allocate any allocatable components and copy. */ - tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_COPY_CTOR); - gfc_add_expr_to_block (&block, tem); - return gfc_finish_block (&block); - } - else - return build2_v (MODIFY_EXPR, dest, src); - } - - gfc_start_block (&block); - - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_DTOR); - tree tem = fold_convert (pvoid_type_node, - GFC_DESCRIPTOR_TYPE_P (type) - ? gfc_conv_descriptor_data_get (dest) : dest); - tem = unshare_expr (tem); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tem, null_pointer_node); - tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, - then_b, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tem); - } - - gfc_init_block (&cond_block); - - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (src, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, - gfc_conv_descriptor_lbound_get (src, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (src, rank)); - tree esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = unshare_expr (size); - size = gfc_evaluate_now (fold_convert (size_type_node, size), - &cond_block); - } - else - size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); - ptr = gfc_create_var (pvoid_type_node, NULL); - - tree destptr = GFC_DESCRIPTOR_TYPE_P (type) - ? gfc_conv_descriptor_data_get (dest) : dest; - destptr = unshare_expr (destptr); - destptr = fold_convert (pvoid_type_node, destptr); - gfc_add_modify (&cond_block, ptr, destptr); - - nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - destptr, null_pointer_node); - cond = nonalloc; - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - int i; - for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++) - { - tree rank = gfc_rank_cst[i]; - tree tem = gfc_conv_descriptor_ubound_get (src, rank); - tem = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tem, - gfc_conv_descriptor_lbound_get (src, rank)); - tem = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tem, - gfc_conv_descriptor_lbound_get (dest, rank)); - tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tem, gfc_conv_descriptor_ubound_get (dest, - rank)); - cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, cond, tem); - } - } - - gfc_init_block (&cond_block2); - - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - gfc_init_block (&inner_block); - gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE); - then_b = gfc_finish_block (&inner_block); - - gfc_init_block (&inner_block); - gfc_add_modify (&inner_block, ptr, - gfc_call_realloc (&inner_block, ptr, size)); - else_b = gfc_finish_block (&inner_block); - - gfc_add_expr_to_block (&cond_block2, - build3_loc (input_location, COND_EXPR, - void_type_node, - unshare_expr (nonalloc), - then_b, else_b)); - gfc_add_modify (&cond_block2, dest, src); - gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr); - } - else - { - gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE); - gfc_add_modify (&cond_block2, unshare_expr (dest), - fold_convert (type, ptr)); - } - then_b = gfc_finish_block (&cond_block2); - else_b = build_empty_stmt (input_location); - - gfc_add_expr_to_block (&cond_block, - build3_loc (input_location, COND_EXPR, - void_type_node, unshare_expr (cond), - then_b, else_b)); - - tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) - ? gfc_conv_descriptor_data_get (src) : src; - srcptr = unshare_expr (srcptr); - srcptr = fold_convert (pvoid_type_node, srcptr); - call = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, - srcptr, size); - gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - tree tem = gfc_walk_alloc_comps (src, dest, - OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_COPY_CTOR); - gfc_add_expr_to_block (&cond_block, tem); - } - then_b = gfc_finish_block (&cond_block); - - if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN) - { - gfc_init_block (&cond_block); - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest)); - 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 (&cond_block, tmp); - } - else - { - destptr = gfc_evaluate_now (destptr, &cond_block); - gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr)); - gfc_add_modify (&cond_block, unshare_expr (dest), - build_zero_cst (TREE_TYPE (dest))); - } - else_b = gfc_finish_block (&cond_block); - - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - unshare_expr (srcptr), null_pointer_node); - gfc_add_expr_to_block (&block, - build3_loc (input_location, COND_EXPR, - void_type_node, cond, - then_b, else_b)); - } - else - gfc_add_expr_to_block (&block, then_b); - - return gfc_finish_block (&block); -} - -static void -gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src, - tree add, tree nelems) -{ - stmtblock_t tmpblock; - tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S"); - nelems = gfc_evaluate_now (nelems, block); - - gfc_init_block (&tmpblock); - if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE) - { - desta = gfc_build_array_ref (dest, index, NULL); - srca = gfc_build_array_ref (src, index, NULL); - } - else - { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest))); - tree idx = fold_build2 (MULT_EXPR, sizetype, - fold_convert (sizetype, index), - TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest)))); - desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, - TREE_TYPE (dest), dest, - idx)); - srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, - TREE_TYPE (src), src, - idx)); - } - gfc_add_modify (&tmpblock, desta, - fold_build2 (PLUS_EXPR, TREE_TYPE (desta), - srca, add)); - - gfc_loopinfo loop; - 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, &tmpblock); - gfc_add_block_to_block (block, &loop.pre); -} - -/* Build and return code for a constructor of DEST that initializes - it to SRC plus ADD (ADD is scalar integer). */ - -tree -gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add) -{ - tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE; - stmtblock_t block; - - gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); - - gfc_start_block (&block); - add = gfc_evaluate_now (add, &block); - - if ((! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) - || !POINTER_TYPE_P (type))) - { - bool compute_nelts = false; - gcc_assert (TREE_CODE (type) == ARRAY_TYPE); - if (!TYPE_DOMAIN (type) - || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE - || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node - || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) - compute_nelts = true; - else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) - { - tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); - if (lookup_attribute ("omp dummy var", a)) - compute_nelts = true; - } - if (compute_nelts) - { - nelems = fold_build2 (EXACT_DIV_EXPR, sizetype, - TYPE_SIZE_UNIT (type), - TYPE_SIZE_UNIT (TREE_TYPE (type))); - nelems = size_binop (MINUS_EXPR, nelems, size_one_node); - } - else - nelems = array_type_nelts (type); - nelems = fold_convert (gfc_array_index_type, nelems); - - gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems); - return gfc_finish_block (&block); - } - - /* Allocatable arrays in LINEAR clauses need to be allocated - and copied from SRC. */ - gfc_add_modify (&block, dest, src); - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (dest, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, - gfc_conv_descriptor_lbound_get (dest, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (dest, rank)); - tree esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - nelems = gfc_evaluate_now (unshare_expr (size), &block); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - nelems, unshare_expr (esize)); - size = gfc_evaluate_now (fold_convert (size_type_node, size), - &block); - nelems = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, nelems, - gfc_index_one_node); - } - else - size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); - ptr = gfc_create_var (pvoid_type_node, NULL); - gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr); - tree etype = gfc_get_element_type (type); - ptr = fold_convert (build_pointer_type (etype), ptr); - tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src)); - srcptr = fold_convert (build_pointer_type (etype), srcptr); - gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems); - } - else - { - gfc_add_modify (&block, unshare_expr (dest), - fold_convert (TREE_TYPE (dest), ptr)); - ptr = fold_convert (TREE_TYPE (dest), ptr); - tree dstm = build_fold_indirect_ref (ptr); - tree srcm = build_fold_indirect_ref (unshare_expr (src)); - gfc_add_modify (&block, dstm, - fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add)); - } - return gfc_finish_block (&block); -} - -/* Build and return code destructing DECL. Return NULL if nothing - to be done. */ - -tree -gfc_omp_clause_dtor (tree clause, tree decl) -{ - tree type = TREE_TYPE (decl), tem; - tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); - - if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) - && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) - && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) - decl_type - = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); - if (gfc_is_polymorphic_nonptr (decl_type)) - { - if (POINTER_TYPE_P (decl_type)) - decl_type = TREE_TYPE (decl_type); - decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); - if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) - fatal_error (input_location, - "Sorry, polymorphic arrays not yet supported for " - "firstprivate"); - stmtblock_t block, cond_block; - gfc_start_block (&block); - gfc_init_block (&cond_block); - tree final = gfc_class_vtab_final_get (decl); - tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl)); - gfc_se se; - gfc_init_se (&se, NULL); - symbol_attribute attr = {}; - tree data = gfc_class_data_get (decl); - tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr); - - /* Call class->_vpt->_finalize + free. */ - tree call = build_fold_indirect_ref (final); - call = build_call_expr_loc (input_location, call, 3, - gfc_build_addr_expr (NULL, desc), - size, boolean_false_node); - gfc_add_block_to_block (&cond_block, &se.pre); - gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); - gfc_add_block_to_block (&cond_block, &se.post); - /* Create: if (_vtab && _final) */ - tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - gfc_class_vptr_get (decl), - null_pointer_node); - tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - final, null_pointer_node); - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, cond, cond2); - gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, - void_type_node, cond, - gfc_finish_block (&cond_block), NULL_TREE)); - call = builtin_decl_explicit (BUILT_IN_FREE); - call = build_call_expr_loc (input_location, call, 1, data); - gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); - return gfc_finish_block (&block); - } - - if ((! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) - || !POINTER_TYPE_P (type))) - { - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - return gfc_walk_alloc_comps (decl, NULL_TREE, - OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_DTOR); - return NULL_TREE; - } - - if (GFC_DESCRIPTOR_TYPE_P (type)) - { - /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need - to be deallocated if they were allocated. */ - tem = gfc_conv_descriptor_data_get (decl); - tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, true, NULL, - GFC_CAF_COARRAY_NOCOARRAY); - } - else - tem = gfc_call_free (decl); - tem = gfc_omp_unshare_expr (tem); - - if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) - { - stmtblock_t block; - tree then_b; - - gfc_init_block (&block); - gfc_add_expr_to_block (&block, - gfc_walk_alloc_comps (decl, NULL_TREE, - OMP_CLAUSE_DECL (clause), - WALK_ALLOC_COMPS_DTOR)); - gfc_add_expr_to_block (&block, tem); - then_b = gfc_finish_block (&block); - - tem = fold_convert (pvoid_type_node, - GFC_DESCRIPTOR_TYPE_P (type) - ? gfc_conv_descriptor_data_get (decl) : decl); - tem = unshare_expr (tem); - tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tem, null_pointer_node); - tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, - then_b, build_empty_stmt (input_location)); - } - return tem; -} - -/* Build a conditional expression in BLOCK. If COND_VAL is not - null, then the block THEN_B is executed, otherwise ELSE_VAL - is assigned to VAL. */ - -static void -gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val, - tree then_b, tree else_val) -{ - stmtblock_t cond_block; - tree else_b = NULL_TREE; - tree val_ty = TREE_TYPE (val); - - if (else_val) - { - gfc_init_block (&cond_block); - gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val)); - else_b = gfc_finish_block (&cond_block); - } - gfc_add_expr_to_block (block, - build3_loc (input_location, COND_EXPR, void_type_node, - cond_val, then_b, else_b)); -} - -/* Build a conditional expression in BLOCK, returning a temporary - variable containing the result. If COND_VAL is not null, then - THEN_VAL will be assigned to the variable, otherwise ELSE_VAL - is assigned. - */ - -static tree -gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val, - tree then_val, tree else_val) -{ - tree val; - tree val_ty = TREE_TYPE (then_val); - stmtblock_t cond_block; - - val = create_tmp_var (val_ty); - - gfc_init_block (&cond_block); - gfc_add_modify (&cond_block, val, then_val); - tree then_b = gfc_finish_block (&cond_block); - - gfc_build_cond_assign (block, val, cond_val, then_b, else_val); - - return val; -} - -void -gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) -{ - if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP) - return; - - tree decl = OMP_CLAUSE_DECL (c); - - /* Assumed-size arrays can't be mapped implicitly, they have to be - mapped explicitly using array sections. */ - if (TREE_CODE (decl) == PARM_DECL - && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN - && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), - GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) - == NULL) - { - error_at (OMP_CLAUSE_LOCATION (c), - "implicit mapping of assumed size array %qD", decl); - return; - } - - tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; - tree present = gfc_omp_check_optional_argument (decl, true); - if (POINTER_TYPE_P (TREE_TYPE (decl))) - { - if (!gfc_omp_privatize_by_reference (decl) - && !GFC_DECL_GET_SCALAR_POINTER (decl) - && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) - && !GFC_DECL_CRAY_POINTEE (decl) - && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) - return; - tree orig_decl = decl; - - c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (c4) = decl; - OMP_CLAUSE_SIZE (c4) = size_int (0); - decl = build_fold_indirect_ref (decl); - if (present - && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) - || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) - { - c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (c2) = decl; - OMP_CLAUSE_SIZE (c2) = size_int (0); - - stmtblock_t block; - gfc_start_block (&block); - tree ptr = decl; - ptr = gfc_build_cond_assign_expr (&block, present, decl, - null_pointer_node); - gimplify_and_add (gfc_finish_block (&block), pre_p); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (c) = ptr; - OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); - } - else - { - OMP_CLAUSE_DECL (c) = decl; - OMP_CLAUSE_SIZE (c) = NULL_TREE; - } - if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE - && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) - || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) - { - c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (c3) = unshare_expr (decl); - OMP_CLAUSE_SIZE (c3) = size_int (0); - decl = build_fold_indirect_ref (decl); - OMP_CLAUSE_DECL (c) = decl; - } - } - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - { - stmtblock_t block; - gfc_start_block (&block); - tree type = TREE_TYPE (decl); - tree ptr = gfc_conv_descriptor_data_get (decl); - - /* OpenMP: automatically map pointer targets with the pointer; - hence, always update the descriptor/pointer itself. - NOTE: This also remaps the pointer for allocatable arrays with - 'target' attribute which also don't have the 'restrict' qualifier. */ - bool always_modifier = false; - - if (!openacc - && !(TYPE_QUALS (TREE_TYPE (ptr)) & TYPE_QUAL_RESTRICT)) - always_modifier = true; - - if (present) - ptr = gfc_build_cond_assign_expr (&block, present, ptr, - null_pointer_node); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (c) = ptr; - c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET); - if (present) - { - ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0))); - gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0)); - - OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr); - } - else - OMP_CLAUSE_DECL (c2) = decl; - OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type); - c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (c3, always_modifier ? GOMP_MAP_ALWAYS_POINTER - : GOMP_MAP_POINTER); - if (present) - { - ptr = gfc_conv_descriptor_data_get (decl); - ptr = gfc_build_addr_expr (NULL, ptr); - ptr = gfc_build_cond_assign_expr (&block, present, - ptr, null_pointer_node); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (c3) = ptr; - } - else - OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); - OMP_CLAUSE_SIZE (c3) = size_int (0); - tree size = create_tmp_var (gfc_array_index_type); - tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER - || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) - { - stmtblock_t cond_block; - tree tem, then_b, else_b, zero, cond; - - gfc_init_block (&cond_block); - tem = gfc_full_array_size (&cond_block, decl, - GFC_TYPE_ARRAY_RANK (type)); - gfc_add_modify (&cond_block, size, tem); - gfc_add_modify (&cond_block, size, - fold_build2 (MULT_EXPR, gfc_array_index_type, - size, elemsz)); - then_b = gfc_finish_block (&cond_block); - gfc_init_block (&cond_block); - zero = build_int_cst (gfc_array_index_type, 0); - gfc_add_modify (&cond_block, size, zero); - else_b = gfc_finish_block (&cond_block); - tem = gfc_conv_descriptor_data_get (decl); - tem = fold_convert (pvoid_type_node, tem); - cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tem, null_pointer_node); - if (present) - { - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, present, cond); - } - gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, - void_type_node, cond, - then_b, else_b)); - } - else if (present) - { - stmtblock_t cond_block; - tree then_b; - - gfc_init_block (&cond_block); - gfc_add_modify (&cond_block, size, - gfc_full_array_size (&cond_block, decl, - GFC_TYPE_ARRAY_RANK (type))); - gfc_add_modify (&cond_block, size, - fold_build2 (MULT_EXPR, gfc_array_index_type, - size, elemsz)); - then_b = gfc_finish_block (&cond_block); - - gfc_build_cond_assign (&block, size, present, then_b, - build_int_cst (gfc_array_index_type, 0)); - } - else - { - gfc_add_modify (&block, size, - gfc_full_array_size (&block, decl, - GFC_TYPE_ARRAY_RANK (type))); - gfc_add_modify (&block, size, - fold_build2 (MULT_EXPR, gfc_array_index_type, - size, elemsz)); - } - OMP_CLAUSE_SIZE (c) = size; - tree stmt = gfc_finish_block (&block); - gimplify_and_add (stmt, pre_p); - } - tree last = c; - if (OMP_CLAUSE_SIZE (c) == NULL_TREE) - OMP_CLAUSE_SIZE (c) - = DECL_P (decl) ? DECL_SIZE_UNIT (decl) - : TYPE_SIZE_UNIT (TREE_TYPE (decl)); - if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, - NULL, is_gimple_val, fb_rvalue) == GS_ERROR) - OMP_CLAUSE_SIZE (c) = size_int (0); - if (c2) - { - OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); - OMP_CLAUSE_CHAIN (last) = c2; - last = c2; - } - if (c3) - { - OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last); - OMP_CLAUSE_CHAIN (last) = c3; - last = c3; - } - if (c4) - { - OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last); - OMP_CLAUSE_CHAIN (last) = c4; - } -} - - -/* Return true if DECL is a scalar variable (for the purpose of - implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.' - is true, allocatables and pointers are permitted. */ - -bool -gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok) -{ - tree type = TREE_TYPE (decl); - if (TREE_CODE (type) == REFERENCE_TYPE) - type = TREE_TYPE (type); - if (TREE_CODE (type) == POINTER_TYPE) - { - if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) - || GFC_DECL_GET_SCALAR_POINTER (decl)) - { - if (!ptr_alloc_ok) - return false; - type = TREE_TYPE (type); - } - if (GFC_ARRAY_TYPE_P (type) - || GFC_CLASS_TYPE_P (type)) - return false; - } - if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE) - && TYPE_STRING_FLAG (type)) - return false; - if (INTEGRAL_TYPE_P (type) - || SCALAR_FLOAT_TYPE_P (type) - || COMPLEX_FLOAT_TYPE_P (type)) - return true; - return false; -} - - -/* Return true if DECL is a scalar with target attribute but does not have the - allocatable (or pointer) attribute (for the purpose of implicit mapping). */ - -bool -gfc_omp_scalar_target_p (tree decl) -{ - return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl) - && gfc_omp_scalar_p (decl, false)); -} - - -/* Return true if DECL's DECL_VALUE_EXPR (if any) should be - disregarded in OpenMP construct, because it is going to be - remapped during OpenMP lowering. SHARED is true if DECL - is going to be shared, false if it is going to be privatized. */ - -bool -gfc_omp_disregard_value_expr (tree decl, bool shared) -{ - if (GFC_DECL_COMMON_OR_EQUIV (decl) - && DECL_HAS_VALUE_EXPR_P (decl)) - { - tree value = DECL_VALUE_EXPR (decl); - - if (TREE_CODE (value) == COMPONENT_REF - && VAR_P (TREE_OPERAND (value, 0)) - && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) - { - /* If variable in COMMON or EQUIVALENCE is privatized, return - true, as just that variable is supposed to be privatized, - not the whole COMMON or whole EQUIVALENCE. - For shared variables in COMMON or EQUIVALENCE, let them be - gimplified to DECL_VALUE_EXPR, so that for multiple shared vars - from the same COMMON or EQUIVALENCE just one sharing of the - whole COMMON or EQUIVALENCE is enough. */ - return ! shared; - } - } - - if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl)) - return ! shared; - - return false; -} - -/* Return true if DECL that is shared iff SHARED is true should - be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG - flag set. */ - -bool -gfc_omp_private_debug_clause (tree decl, bool shared) -{ - if (GFC_DECL_CRAY_POINTEE (decl)) - return true; - - if (GFC_DECL_COMMON_OR_EQUIV (decl) - && DECL_HAS_VALUE_EXPR_P (decl)) - { - tree value = DECL_VALUE_EXPR (decl); - - if (TREE_CODE (value) == COMPONENT_REF - && VAR_P (TREE_OPERAND (value, 0)) - && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) - return shared; - } - - return false; -} - -/* Register language specific type size variables as potentially OpenMP - firstprivate variables. */ - -void -gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type) -{ - if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) - { - int r; - - gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL); - for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++) - { - omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r)); - omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r)); - omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r)); - } - omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type)); - omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type)); - } -} - - -static inline tree -gfc_trans_add_clause (tree node, tree tail) -{ - OMP_CLAUSE_CHAIN (node) = tail; - return node; -} - -static tree -gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd) -{ - if (declare_simd) - { - int cnt = 0; - gfc_symbol *proc_sym; - gfc_formal_arglist *f; - - gcc_assert (sym->attr.dummy); - proc_sym = sym->ns->proc_name; - if (proc_sym->attr.entry_master) - ++cnt; - if (gfc_return_by_reference (proc_sym)) - { - ++cnt; - if (proc_sym->ts.type == BT_CHARACTER) - ++cnt; - } - for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) - if (f->sym == sym) - break; - else if (f->sym) - ++cnt; - gcc_assert (f); - return build_int_cst (integer_type_node, cnt); - } - - tree t = gfc_get_symbol_decl (sym); - tree parent_decl; - int parent_flag; - bool return_value; - bool alternate_entry; - bool entry_master; - - 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); - parent_decl = current_function_decl - ? DECL_CONTEXT (current_function_decl) : NULL_TREE; - - if ((t == parent_decl && return_value) - || (sym->ns && sym->ns->proc_name - && 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 && (t == current_function_decl || parent_flag)) - t = 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) - { - t = gfc_get_fake_result_decl (sym, parent_flag); - break; - } - } - - else if (entry_master - && (sym->ns->proc_name->backend_decl == current_function_decl - || parent_flag)) - t = gfc_get_fake_result_decl (sym, parent_flag); - - return t; -} - -static tree -gfc_trans_omp_variable_list (enum omp_clause_code code, - gfc_omp_namelist *namelist, tree list, - bool declare_simd) -{ - for (; namelist != NULL; namelist = namelist->next) - if (namelist->sym->attr.referenced || declare_simd) - { - tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); - if (t != error_mark_node) - { - tree node = build_omp_clause (input_location, code); - OMP_CLAUSE_DECL (node) = t; - list = gfc_trans_add_clause (node, list); - - if (code == OMP_CLAUSE_LASTPRIVATE - && namelist->u.lastprivate_conditional) - OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1; - } - } - return list; -} - -struct omp_udr_find_orig_data -{ - gfc_omp_udr *omp_udr; - bool omp_orig_seen; -}; - -static int -omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - void *data) -{ - struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data; - if ((*e)->expr_type == EXPR_VARIABLE - && (*e)->symtree->n.sym == cd->omp_udr->omp_orig) - cd->omp_orig_seen = true; - - return 0; -} - -static void -gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) -{ - gfc_symbol *sym = n->sym; - gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; - gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; - gfc_symbol init_val_sym, outer_sym, intrinsic_sym; - gfc_symbol omp_var_copy[4]; - gfc_expr *e1, *e2, *e3, *e4; - gfc_ref *ref; - tree decl, backend_decl, stmt, type, outer_decl; - locus old_loc = gfc_current_locus; - const char *iname; - bool t; - gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL; - - decl = OMP_CLAUSE_DECL (c); - gfc_current_locus = where; - type = TREE_TYPE (decl); - outer_decl = create_tmp_var_raw (type); - if (TREE_CODE (decl) == PARM_DECL - && TREE_CODE (type) == REFERENCE_TYPE - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE) - { - decl = build_fold_indirect_ref (decl); - type = TREE_TYPE (type); - } - - /* Create a fake symbol for init value. */ - memset (&init_val_sym, 0, sizeof (init_val_sym)); - init_val_sym.ns = sym->ns; - init_val_sym.name = sym->name; - init_val_sym.ts = sym->ts; - init_val_sym.attr.referenced = 1; - init_val_sym.declared_at = where; - init_val_sym.attr.flavor = FL_VARIABLE; - if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) - backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); - else if (udr->initializer_ns) - backend_decl = NULL; - else - switch (sym->ts.type) - { - case BT_LOGICAL: - case BT_INTEGER: - case BT_REAL: - case BT_COMPLEX: - backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym)); - break; - default: - backend_decl = NULL_TREE; - break; - } - init_val_sym.backend_decl = backend_decl; - - /* Create a fake symbol for the outer array reference. */ - outer_sym = *sym; - if (sym->as) - outer_sym.as = gfc_copy_array_spec (sym->as); - outer_sym.attr.dummy = 0; - outer_sym.attr.result = 0; - outer_sym.attr.flavor = FL_VARIABLE; - outer_sym.backend_decl = outer_decl; - if (decl != OMP_CLAUSE_DECL (c)) - outer_sym.backend_decl = build_fold_indirect_ref (outer_decl); - - /* Create fake symtrees for it. */ - symtree1 = gfc_new_symtree (&root1, sym->name); - symtree1->n.sym = sym; - gcc_assert (symtree1 == root1); - - symtree2 = gfc_new_symtree (&root2, sym->name); - symtree2->n.sym = &init_val_sym; - gcc_assert (symtree2 == root2); - - symtree3 = gfc_new_symtree (&root3, sym->name); - symtree3->n.sym = &outer_sym; - gcc_assert (symtree3 == root3); - - memset (omp_var_copy, 0, sizeof omp_var_copy); - if (udr) - { - omp_var_copy[0] = *udr->omp_out; - omp_var_copy[1] = *udr->omp_in; - *udr->omp_out = outer_sym; - *udr->omp_in = *sym; - if (udr->initializer_ns) - { - omp_var_copy[2] = *udr->omp_priv; - omp_var_copy[3] = *udr->omp_orig; - *udr->omp_priv = *sym; - *udr->omp_orig = outer_sym; - } - } - - /* Create expressions. */ - e1 = gfc_get_expr (); - e1->expr_type = EXPR_VARIABLE; - e1->where = where; - e1->symtree = symtree1; - e1->ts = sym->ts; - if (sym->attr.dimension) - { - e1->ref = ref = gfc_get_ref (); - ref->type = REF_ARRAY; - ref->u.ar.where = where; - ref->u.ar.as = sym->as; - ref->u.ar.type = AR_FULL; - ref->u.ar.dimen = 0; - } - t = gfc_resolve_expr (e1); - gcc_assert (t); - - e2 = NULL; - if (backend_decl != NULL_TREE) - { - e2 = gfc_get_expr (); - e2->expr_type = EXPR_VARIABLE; - e2->where = where; - e2->symtree = symtree2; - e2->ts = sym->ts; - t = gfc_resolve_expr (e2); - gcc_assert (t); - } - else if (udr->initializer_ns == NULL) - { - gcc_assert (sym->ts.type == BT_DERIVED); - e2 = gfc_default_initializer (&sym->ts); - gcc_assert (e2); - t = gfc_resolve_expr (e2); - gcc_assert (t); - } - else if (n->u2.udr->initializer->op == EXEC_ASSIGN) - { - e2 = gfc_copy_expr (n->u2.udr->initializer->expr2); - t = gfc_resolve_expr (e2); - gcc_assert (t); - } - if (udr && udr->initializer_ns) - { - struct omp_udr_find_orig_data cd; - cd.omp_udr = udr; - cd.omp_orig_seen = false; - gfc_code_walker (&n->u2.udr->initializer, - gfc_dummy_code_callback, omp_udr_find_orig, &cd); - if (cd.omp_orig_seen) - OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; - } - - e3 = gfc_copy_expr (e1); - e3->symtree = symtree3; - t = gfc_resolve_expr (e3); - gcc_assert (t); - - iname = NULL; - e4 = NULL; - switch (OMP_CLAUSE_REDUCTION_CODE (c)) - { - case PLUS_EXPR: - case MINUS_EXPR: - e4 = gfc_add (e3, e1); - break; - case MULT_EXPR: - e4 = gfc_multiply (e3, e1); - break; - case TRUTH_ANDIF_EXPR: - e4 = gfc_and (e3, e1); - break; - case TRUTH_ORIF_EXPR: - e4 = gfc_or (e3, e1); - break; - case EQ_EXPR: - e4 = gfc_eqv (e3, e1); - break; - case NE_EXPR: - e4 = gfc_neqv (e3, e1); - break; - case MIN_EXPR: - iname = "min"; - break; - case MAX_EXPR: - iname = "max"; - break; - case BIT_AND_EXPR: - iname = "iand"; - break; - case BIT_IOR_EXPR: - iname = "ior"; - break; - case BIT_XOR_EXPR: - iname = "ieor"; - break; - case ERROR_MARK: - if (n->u2.udr->combiner->op == EXEC_ASSIGN) - { - gfc_free_expr (e3); - e3 = gfc_copy_expr (n->u2.udr->combiner->expr1); - e4 = gfc_copy_expr (n->u2.udr->combiner->expr2); - t = gfc_resolve_expr (e3); - gcc_assert (t); - t = gfc_resolve_expr (e4); - gcc_assert (t); - } - break; - default: - gcc_unreachable (); - } - if (iname != NULL) - { - memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); - intrinsic_sym.ns = sym->ns; - intrinsic_sym.name = iname; - intrinsic_sym.ts = sym->ts; - intrinsic_sym.attr.referenced = 1; - intrinsic_sym.attr.intrinsic = 1; - intrinsic_sym.attr.function = 1; - intrinsic_sym.attr.implicit_type = 1; - intrinsic_sym.result = &intrinsic_sym; - intrinsic_sym.declared_at = where; - - symtree4 = gfc_new_symtree (&root4, iname); - symtree4->n.sym = &intrinsic_sym; - gcc_assert (symtree4 == root4); - - e4 = gfc_get_expr (); - e4->expr_type = EXPR_FUNCTION; - e4->where = where; - e4->symtree = symtree4; - e4->value.function.actual = gfc_get_actual_arglist (); - e4->value.function.actual->expr = e3; - e4->value.function.actual->next = gfc_get_actual_arglist (); - e4->value.function.actual->next->expr = e1; - } - if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) - { - /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ - e1 = gfc_copy_expr (e1); - e3 = gfc_copy_expr (e3); - t = gfc_resolve_expr (e4); - gcc_assert (t); - } - - /* Create the init statement list. */ - pushlevel (); - if (e2) - stmt = gfc_trans_assignment (e1, e2, false, false); - else - stmt = gfc_trans_call (n->u2.udr->initializer, false, - NULL_TREE, NULL_TREE, false); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - OMP_CLAUSE_REDUCTION_INIT (c) = stmt; - - /* Create the merge statement list. */ - pushlevel (); - if (e4) - stmt = gfc_trans_assignment (e3, e4, false, true); - else - stmt = gfc_trans_call (n->u2.udr->combiner, false, - NULL_TREE, NULL_TREE, false); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; - - /* And stick the placeholder VAR_DECL into the clause as well. */ - OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl; - - gfc_current_locus = old_loc; - - gfc_free_expr (e1); - if (e2) - gfc_free_expr (e2); - gfc_free_expr (e3); - if (e4) - gfc_free_expr (e4); - free (symtree1); - free (symtree2); - free (symtree3); - free (symtree4); - if (outer_sym.as) - gfc_free_array_spec (outer_sym.as); - - if (udr) - { - *udr->omp_out = omp_var_copy[0]; - *udr->omp_in = omp_var_copy[1]; - if (udr->initializer_ns) - { - *udr->omp_priv = omp_var_copy[2]; - *udr->omp_orig = omp_var_copy[3]; - } - } -} - -static tree -gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list, - locus where, bool mark_addressable) -{ - omp_clause_code clause = OMP_CLAUSE_REDUCTION; - switch (kind) - { - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: - break; - case OMP_LIST_IN_REDUCTION: - clause = OMP_CLAUSE_IN_REDUCTION; - break; - case OMP_LIST_TASK_REDUCTION: - clause = OMP_CLAUSE_TASK_REDUCTION; - break; - default: - gcc_unreachable (); - } - for (; namelist != NULL; namelist = namelist->next) - if (namelist->sym->attr.referenced) - { - tree t = gfc_trans_omp_variable (namelist->sym, false); - if (t != error_mark_node) - { - tree node = build_omp_clause (gfc_get_location (&namelist->where), - clause); - OMP_CLAUSE_DECL (node) = t; - if (mark_addressable) - TREE_ADDRESSABLE (t) = 1; - if (kind == OMP_LIST_REDUCTION_INSCAN) - OMP_CLAUSE_REDUCTION_INSCAN (node) = 1; - if (kind == OMP_LIST_REDUCTION_TASK) - OMP_CLAUSE_REDUCTION_TASK (node) = 1; - switch (namelist->u.reduction_op) - { - case OMP_REDUCTION_PLUS: - OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR; - break; - case OMP_REDUCTION_MINUS: - OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR; - break; - case OMP_REDUCTION_TIMES: - OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR; - break; - case OMP_REDUCTION_AND: - OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR; - break; - case OMP_REDUCTION_OR: - OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR; - break; - case OMP_REDUCTION_EQV: - OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR; - break; - case OMP_REDUCTION_NEQV: - OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR; - break; - case OMP_REDUCTION_MAX: - OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR; - break; - case OMP_REDUCTION_MIN: - OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR; - break; - case OMP_REDUCTION_IAND: - OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR; - break; - case OMP_REDUCTION_IOR: - OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR; - break; - case OMP_REDUCTION_IEOR: - OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR; - break; - case OMP_REDUCTION_USER: - OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK; - break; - default: - gcc_unreachable (); - } - if (namelist->sym->attr.dimension - || namelist->u.reduction_op == OMP_REDUCTION_USER - || namelist->sym->attr.allocatable) - gfc_trans_omp_array_reduction_or_udr (node, namelist, where); - list = gfc_trans_add_clause (node, list); - } - } - return list; -} - -static inline tree -gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr) -{ - gfc_se se; - tree result; - - gfc_init_se (&se, NULL ); - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (block, &se.pre); - result = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - return result; -} - -static vec *doacross_steps; - - -/* Translate an array section or array element. */ - -static void -gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, - tree decl, bool element, gomp_map_kind ptr_kind, - tree &node, tree &node2, tree &node3, tree &node4) -{ - gfc_se se; - tree ptr, ptr2; - tree elemsz = NULL_TREE; - - gfc_init_se (&se, NULL); - - if (element) - { - gfc_conv_expr_reference (&se, n->expr); - gfc_add_block_to_block (block, &se.pre); - ptr = se.expr; - OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr))); - elemsz = OMP_CLAUSE_SIZE (node); - } - else - { - gfc_conv_expr_descriptor (&se, n->expr); - ptr = gfc_conv_array_data (se.expr); - tree type = TREE_TYPE (se.expr); - gfc_add_block_to_block (block, &se.pre); - OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr, - GFC_TYPE_ARRAY_RANK (type)); - elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); - } - gcc_assert (se.post.head == NULL_TREE); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); - OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); - ptr = fold_convert (ptrdiff_type_node, ptr); - - if (POINTER_TYPE_P (TREE_TYPE (decl)) - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) - && ptr_kind == GOMP_MAP_POINTER) - { - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node4) = decl; - OMP_CLAUSE_SIZE (node4) = size_int (0); - decl = build_fold_indirect_ref (decl); - } - else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER - && n->expr->ts.type == BT_CHARACTER - && n->expr->ts.deferred) - { - gomp_map_kind map_kind; - if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node))) - map_kind = GOMP_MAP_TO; - else if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE - || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE) - map_kind = OMP_CLAUSE_MAP_KIND (node); - else - map_kind = GOMP_MAP_ALLOC; - gcc_assert (se.string_length); - node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); - OMP_CLAUSE_DECL (node4) = se.string_length; - OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node); - } - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - { - tree desc_node; - tree type = TREE_TYPE (decl); - ptr2 = gfc_conv_descriptor_data_get (decl); - desc_node = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_DECL (desc_node) = decl; - OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type); - if (ptr_kind == GOMP_MAP_ALWAYS_POINTER) - { - OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO); - node2 = node; - node = desc_node; /* Needs to come first. */ - } - else - { - OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO_PSET); - node2 = desc_node; - } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); - /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra - cast prevents gimplify.c from recognising it as being part of the - struct – and adding an 'alloc: for the 'desc.data' pointer, which - would break as the 'desc' (the descriptor) is also mapped - (see node4 above). */ - if (ptr_kind == GOMP_MAP_ATTACH_DETACH) - STRIP_NOPS (OMP_CLAUSE_DECL (node3)); - } - else - { - if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) - { - tree offset; - ptr2 = build_fold_addr_expr (decl); - offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr, - fold_convert (ptrdiff_type_node, ptr2)); - offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node, - offset, fold_convert (ptrdiff_type_node, elemsz)); - offset = build4_loc (input_location, ARRAY_REF, - TREE_TYPE (TREE_TYPE (decl)), - decl, offset, NULL_TREE, NULL_TREE); - OMP_CLAUSE_DECL (node) = offset; - - if (ptr_kind == GOMP_MAP_ALWAYS_POINTER) - return; - } - else - { - gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); - ptr2 = decl; - } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); - OMP_CLAUSE_DECL (node3) = decl; - } - ptr2 = fold_convert (ptrdiff_type_node, ptr2); - OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node, - ptr, ptr2); -} - -static tree -handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) -{ - tree list = NULL_TREE; - for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) - { - gfc_constructor *c; - gfc_se se; - - tree last = make_tree_vec (6); - tree iter_var = gfc_get_symbol_decl (sym); - tree type = TREE_TYPE (iter_var); - TREE_VEC_ELT (last, 0) = iter_var; - DECL_CHAIN (iter_var) = BLOCK_VARS (block); - BLOCK_VARS (block) = iter_var; - - /* begin */ - c = gfc_constructor_first (sym->value->value.constructor); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, c->expr); - gfc_add_block_to_block (iter_block, &se.pre); - gfc_add_block_to_block (iter_block, &se.post); - TREE_VEC_ELT (last, 1) = fold_convert (type, - gfc_evaluate_now (se.expr, - iter_block)); - /* end */ - c = gfc_constructor_next (c); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, c->expr); - gfc_add_block_to_block (iter_block, &se.pre); - gfc_add_block_to_block (iter_block, &se.post); - TREE_VEC_ELT (last, 2) = fold_convert (type, - gfc_evaluate_now (se.expr, - iter_block)); - /* step */ - c = gfc_constructor_next (c); - tree step; - if (c) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, c->expr); - gfc_add_block_to_block (iter_block, &se.pre); - gfc_add_block_to_block (iter_block, &se.post); - gfc_conv_expr (&se, c->expr); - step = fold_convert (type, - gfc_evaluate_now (se.expr, - iter_block)); - } - else - step = build_int_cst (type, 1); - TREE_VEC_ELT (last, 3) = step; - /* orig_step */ - TREE_VEC_ELT (last, 4) = save_expr (step); - TREE_CHAIN (last) = list; - list = last; - } - return list; -} - -static tree -gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, - locus where, bool declare_simd = false, - bool openacc = false) -{ - tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c; - tree iterator = NULL_TREE; - tree tree_block = NULL_TREE; - stmtblock_t iter_block; - int list, ifc; - enum omp_clause_code clause_code; - gfc_omp_namelist *prev = NULL; - gfc_se se; - - if (clauses == NULL) - return NULL_TREE; - - for (list = 0; list < OMP_LIST_NUM; list++) - { - gfc_omp_namelist *n = clauses->lists[list]; - - if (n == NULL) - continue; - switch (list) - { - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: - case OMP_LIST_IN_REDUCTION: - case OMP_LIST_TASK_REDUCTION: - /* An OpenACC async clause indicates the need to set reduction - arguments addressable, to allow asynchronous copy-out. */ - omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses, - where, clauses->async); - break; - case OMP_LIST_PRIVATE: - clause_code = OMP_CLAUSE_PRIVATE; - goto add_clause; - case OMP_LIST_SHARED: - clause_code = OMP_CLAUSE_SHARED; - goto add_clause; - case OMP_LIST_FIRSTPRIVATE: - clause_code = OMP_CLAUSE_FIRSTPRIVATE; - goto add_clause; - case OMP_LIST_LASTPRIVATE: - clause_code = OMP_CLAUSE_LASTPRIVATE; - goto add_clause; - case OMP_LIST_COPYIN: - clause_code = OMP_CLAUSE_COPYIN; - goto add_clause; - case OMP_LIST_COPYPRIVATE: - clause_code = OMP_CLAUSE_COPYPRIVATE; - goto add_clause; - case OMP_LIST_UNIFORM: - clause_code = OMP_CLAUSE_UNIFORM; - goto add_clause; - case OMP_LIST_USE_DEVICE: - case OMP_LIST_USE_DEVICE_PTR: - clause_code = OMP_CLAUSE_USE_DEVICE_PTR; - goto add_clause; - case OMP_LIST_USE_DEVICE_ADDR: - clause_code = OMP_CLAUSE_USE_DEVICE_ADDR; - goto add_clause; - case OMP_LIST_IS_DEVICE_PTR: - clause_code = OMP_CLAUSE_IS_DEVICE_PTR; - goto add_clause; - case OMP_LIST_NONTEMPORAL: - clause_code = OMP_CLAUSE_NONTEMPORAL; - goto add_clause; - case OMP_LIST_SCAN_IN: - clause_code = OMP_CLAUSE_INCLUSIVE; - goto add_clause; - case OMP_LIST_SCAN_EX: - clause_code = OMP_CLAUSE_EXCLUSIVE; - goto add_clause; - - add_clause: - omp_clauses - = gfc_trans_omp_variable_list (clause_code, n, omp_clauses, - declare_simd); - break; - case OMP_LIST_ALIGNED: - for (; n != NULL; n = n->next) - if (n->sym->attr.referenced || declare_simd) - { - tree t = gfc_trans_omp_variable (n->sym, declare_simd); - if (t != error_mark_node) - { - tree node = build_omp_clause (input_location, - OMP_CLAUSE_ALIGNED); - OMP_CLAUSE_DECL (node) = t; - if (n->expr) - { - tree alignment_var; - - if (declare_simd) - alignment_var = gfc_conv_constant_to_tree (n->expr); - else - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, n->expr); - gfc_add_block_to_block (block, &se.pre); - alignment_var = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - } - OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var; - } - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - } - } - break; - case OMP_LIST_ALLOCATE: - for (; n != NULL; n = n->next) - if (n->sym->attr.referenced) - { - tree t = gfc_trans_omp_variable (n->sym, false); - if (t != error_mark_node) - { - tree node = build_omp_clause (input_location, - OMP_CLAUSE_ALLOCATE); - OMP_CLAUSE_DECL (node) = t; - if (n->expr) - { - tree allocator_; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, n->expr); - allocator_ = gfc_evaluate_now (se.expr, block); - OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_; - } - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - } - } - break; - case OMP_LIST_LINEAR: - { - gfc_expr *last_step_expr = NULL; - tree last_step = NULL_TREE; - bool last_step_parm = false; - - for (; n != NULL; n = n->next) - { - if (n->expr) - { - last_step_expr = n->expr; - last_step = NULL_TREE; - last_step_parm = false; - } - if (n->sym->attr.referenced || declare_simd) - { - tree t = gfc_trans_omp_variable (n->sym, declare_simd); - if (t != error_mark_node) - { - tree node = build_omp_clause (input_location, - OMP_CLAUSE_LINEAR); - OMP_CLAUSE_DECL (node) = t; - omp_clause_linear_kind kind; - switch (n->u.linear_op) - { - case OMP_LINEAR_DEFAULT: - kind = OMP_CLAUSE_LINEAR_DEFAULT; - break; - case OMP_LINEAR_REF: - kind = OMP_CLAUSE_LINEAR_REF; - break; - case OMP_LINEAR_VAL: - kind = OMP_CLAUSE_LINEAR_VAL; - break; - case OMP_LINEAR_UVAL: - kind = OMP_CLAUSE_LINEAR_UVAL; - break; - default: - gcc_unreachable (); - } - OMP_CLAUSE_LINEAR_KIND (node) = kind; - if (last_step_expr && last_step == NULL_TREE) - { - if (!declare_simd) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, last_step_expr); - gfc_add_block_to_block (block, &se.pre); - last_step = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - } - else if (last_step_expr->expr_type == EXPR_VARIABLE) - { - gfc_symbol *s = last_step_expr->symtree->n.sym; - last_step = gfc_trans_omp_variable (s, true); - last_step_parm = true; - } - else - last_step - = gfc_conv_constant_to_tree (last_step_expr); - } - if (last_step_parm) - { - OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1; - OMP_CLAUSE_LINEAR_STEP (node) = last_step; - } - else - { - if (kind == OMP_CLAUSE_LINEAR_REF) - { - tree type; - if (n->sym->attr.flavor == FL_PROCEDURE) - { - type = gfc_get_function_type (n->sym); - type = build_pointer_type (type); - } - else - type = gfc_sym_type (n->sym); - if (POINTER_TYPE_P (type)) - type = TREE_TYPE (type); - /* Otherwise to be determined what exactly - should be done. */ - tree t = fold_convert (sizetype, last_step); - t = size_binop (MULT_EXPR, t, - TYPE_SIZE_UNIT (type)); - OMP_CLAUSE_LINEAR_STEP (node) = t; - } - else - { - tree type - = gfc_typenode_for_spec (&n->sym->ts); - OMP_CLAUSE_LINEAR_STEP (node) - = fold_convert (type, last_step); - } - } - if (n->sym->attr.dimension || n->sym->attr.allocatable) - OMP_CLAUSE_LINEAR_ARRAY (node) = 1; - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - } - } - } - } - break; - case OMP_LIST_AFFINITY: - case OMP_LIST_DEPEND: - iterator = NULL_TREE; - prev = NULL; - prev_clauses = omp_clauses; - for (; n != NULL; n = n->next) - { - if (iterator && prev->u2.ns != n->u2.ns) - { - BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); - TREE_VEC_ELT (iterator, 5) = tree_block; - for (tree c = omp_clauses; c != prev_clauses; - c = OMP_CLAUSE_CHAIN (c)) - OMP_CLAUSE_DECL (c) = build_tree_list (iterator, - OMP_CLAUSE_DECL (c)); - prev_clauses = omp_clauses; - iterator = NULL_TREE; - } - if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns)) - { - gfc_init_block (&iter_block); - tree_block = make_node (BLOCK); - TREE_USED (tree_block) = 1; - BLOCK_VARS (tree_block) = NULL_TREE; - iterator = handle_iterator (n->u2.ns, block, - tree_block); - } - if (!iterator) - gfc_init_block (&iter_block); - prev = n; - if (list == OMP_LIST_DEPEND - && n->u.depend_op == OMP_DEPEND_SINK_FIRST) - { - tree vec = NULL_TREE; - unsigned int i; - for (i = 0; ; i++) - { - tree addend = integer_zero_node, t; - bool neg = false; - if (n->expr) - { - addend = gfc_conv_constant_to_tree (n->expr); - if (TREE_CODE (addend) == INTEGER_CST - && tree_int_cst_sgn (addend) == -1) - { - neg = true; - addend = const_unop (NEGATE_EXPR, - TREE_TYPE (addend), addend); - } - } - t = gfc_trans_omp_variable (n->sym, false); - if (t != error_mark_node) - { - if (i < vec_safe_length (doacross_steps) - && !integer_zerop (addend) - && (*doacross_steps)[i]) - { - tree step = (*doacross_steps)[i]; - addend = fold_convert (TREE_TYPE (step), addend); - addend = build2 (TRUNC_DIV_EXPR, - TREE_TYPE (step), addend, step); - } - vec = tree_cons (addend, t, vec); - if (neg) - OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec) = 1; - } - if (n->next == NULL - || n->next->u.depend_op != OMP_DEPEND_SINK) - break; - n = n->next; - } - if (vec == NULL_TREE) - continue; - - tree node = build_omp_clause (input_location, - OMP_CLAUSE_DEPEND); - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_SINK; - OMP_CLAUSE_DECL (node) = nreverse (vec); - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - continue; - } - - if (!n->sym->attr.referenced) - continue; - - tree node = build_omp_clause (input_location, - list == OMP_LIST_DEPEND - ? OMP_CLAUSE_DEPEND - : OMP_CLAUSE_AFFINITY); - if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) - { - tree decl = gfc_trans_omp_variable (n->sym, false); - if (gfc_omp_privatize_by_reference (decl)) - decl = build_fold_indirect_ref (decl); - if (n->u.depend_op == OMP_DEPEND_DEPOBJ - && POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref (decl); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - { - decl = gfc_conv_descriptor_data_get (decl); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); - decl = build_fold_indirect_ref (decl); - } - else if (DECL_P (decl)) - TREE_ADDRESSABLE (decl) = 1; - OMP_CLAUSE_DECL (node) = decl; - } - else - { - tree ptr; - gfc_init_se (&se, NULL); - if (n->expr->ref->u.ar.type == AR_ELEMENT) - { - gfc_conv_expr_reference (&se, n->expr); - ptr = se.expr; - } - else - { - gfc_conv_expr_descriptor (&se, n->expr); - ptr = gfc_conv_array_data (se.expr); - } - gfc_add_block_to_block (&iter_block, &se.pre); - gfc_add_block_to_block (&iter_block, &se.post); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); - OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); - } - if (list == OMP_LIST_DEPEND) - switch (n->u.depend_op) - { - case OMP_DEPEND_IN: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; - break; - case OMP_DEPEND_OUT: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; - break; - case OMP_DEPEND_INOUT: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; - break; - case OMP_DEPEND_MUTEXINOUTSET: - OMP_CLAUSE_DEPEND_KIND (node) - = OMP_CLAUSE_DEPEND_MUTEXINOUTSET; - break; - case OMP_DEPEND_DEPOBJ: - OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ; - break; - default: - gcc_unreachable (); - } - if (!iterator) - gfc_add_block_to_block (block, &iter_block); - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - } - if (iterator) - { - BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); - TREE_VEC_ELT (iterator, 5) = tree_block; - for (tree c = omp_clauses; c != prev_clauses; - c = OMP_CLAUSE_CHAIN (c)) - OMP_CLAUSE_DECL (c) = build_tree_list (iterator, - OMP_CLAUSE_DECL (c)); - } - break; - case OMP_LIST_MAP: - for (; n != NULL; n = n->next) - { - if (!n->sym->attr.referenced) - continue; - - bool always_modifier = false; - tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP); - tree node2 = NULL_TREE; - tree node3 = NULL_TREE; - tree node4 = NULL_TREE; - - /* OpenMP: automatically map pointer targets with the pointer; - hence, always update the descriptor/pointer itself. */ - if (!openacc - && ((n->expr == NULL && n->sym->attr.pointer) - || (n->expr && gfc_expr_attr (n->expr).pointer))) - always_modifier = true; - - switch (n->u.map_op) - { - case OMP_MAP_ALLOC: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); - break; - case OMP_MAP_IF_PRESENT: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT); - break; - case OMP_MAP_ATTACH: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH); - break; - case OMP_MAP_TO: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); - break; - case OMP_MAP_FROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM); - break; - case OMP_MAP_TOFROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM); - break; - case OMP_MAP_ALWAYS_TO: - always_modifier = true; - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO); - break; - case OMP_MAP_ALWAYS_FROM: - always_modifier = true; - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM); - break; - case OMP_MAP_ALWAYS_TOFROM: - always_modifier = true; - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM); - break; - case OMP_MAP_RELEASE: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE); - break; - case OMP_MAP_DELETE: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); - break; - case OMP_MAP_DETACH: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH); - break; - case OMP_MAP_FORCE_ALLOC: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); - break; - case OMP_MAP_FORCE_TO: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO); - break; - case OMP_MAP_FORCE_FROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM); - break; - case OMP_MAP_FORCE_TOFROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM); - break; - case OMP_MAP_FORCE_PRESENT: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT); - break; - case OMP_MAP_FORCE_DEVICEPTR: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR); - break; - default: - gcc_unreachable (); - } - - tree decl = gfc_trans_omp_variable (n->sym, false); - if (DECL_P (decl)) - TREE_ADDRESSABLE (decl) = 1; - - gfc_ref *lastref = NULL; - - if (n->expr) - for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY) - lastref = ref; - - bool allocatable = false, pointer = false; - - if (lastref && lastref->type == REF_COMPONENT) - { - gfc_component *c = lastref->u.c.component; - - if (c->ts.type == BT_CLASS) - { - pointer = CLASS_DATA (c)->attr.class_pointer; - allocatable = CLASS_DATA (c)->attr.allocatable; - } - else - { - pointer = c->attr.pointer; - allocatable = c->attr.allocatable; - } - } - - if (n->expr == NULL - || (n->expr->ref->type == REF_ARRAY - && n->expr->ref->u.ar.type == AR_FULL)) - { - tree present = gfc_omp_check_optional_argument (decl, true); - if (openacc && n->sym->ts.type == BT_CLASS) - { - tree type = TREE_TYPE (decl); - if (n->sym->attr.optional) - sorry ("optional class parameter"); - if (POINTER_TYPE_P (type)) - { - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node4) = decl; - OMP_CLAUSE_SIZE (node4) = size_int (0); - decl = build_fold_indirect_ref (decl); - } - tree ptr = gfc_class_data_get (decl); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (node) = ptr; - OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl); - node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); - OMP_CLAUSE_DECL (node2) = decl; - OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); - node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH); - OMP_CLAUSE_DECL (node3) = gfc_class_data_get (decl); - OMP_CLAUSE_SIZE (node3) = size_int (0); - goto finalize_map_clause; - } - else if (POINTER_TYPE_P (TREE_TYPE (decl)) - && (gfc_omp_privatize_by_reference (decl) - || GFC_DECL_GET_SCALAR_POINTER (decl) - || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) - || GFC_DECL_CRAY_POINTEE (decl) - || GFC_DESCRIPTOR_TYPE_P - (TREE_TYPE (TREE_TYPE (decl))) - || n->sym->ts.type == BT_DERIVED)) - { - tree orig_decl = decl; - - /* For nonallocatable, nonpointer arrays, a temporary - variable is generated, but this one is only defined if - the variable is present; hence, we now set it to NULL - to avoid accessing undefined variables. We cannot use - a temporary variable here as otherwise the replacement - of the variables in omp-low.c will not work. */ - if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) - { - tree tmp = fold_build2_loc (input_location, - MODIFY_EXPR, - void_type_node, decl, - null_pointer_node); - tree cond = fold_build1_loc (input_location, - TRUTH_NOT_EXPR, - boolean_type_node, - present); - gfc_add_expr_to_block (block, - build3_loc (input_location, - COND_EXPR, - void_type_node, - cond, tmp, - NULL_TREE)); - } - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node4) = decl; - OMP_CLAUSE_SIZE (node4) = size_int (0); - decl = build_fold_indirect_ref (decl); - if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE - || gfc_omp_is_optional_argument (orig_decl)) - && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) - || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) - { - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node3) = decl; - OMP_CLAUSE_SIZE (node3) = size_int (0); - decl = build_fold_indirect_ref (decl); - } - } - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - { - tree type = TREE_TYPE (decl); - tree ptr = gfc_conv_descriptor_data_get (decl); - if (present) - ptr = gfc_build_cond_assign_expr (block, present, ptr, - null_pointer_node); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (node) = ptr; - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); - OMP_CLAUSE_DECL (node2) = decl; - OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - if (present) - { - ptr = gfc_conv_descriptor_data_get (decl); - ptr = gfc_build_addr_expr (NULL, ptr); - ptr = gfc_build_cond_assign_expr (block, present, ptr, - null_pointer_node); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (node3) = ptr; - } - else - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); - OMP_CLAUSE_SIZE (node3) = size_int (0); - if (n->u.map_op == OMP_MAP_ATTACH) - { - /* Standalone attach clauses used with arrays with - descriptors must copy the descriptor to the target, - else they won't have anything to perform the - attachment onto (see OpenACC 2.6, "2.6.3. Data - Structures with Pointers"). */ - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH); - /* We don't want to map PTR at all in this case, so - delete its node and shuffle the others down. */ - node = node2; - node2 = node3; - node3 = NULL; - goto finalize_map_clause; - } - else if (n->u.map_op == OMP_MAP_DETACH) - { - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH); - /* Similarly to above, we don't want to unmap PTR - here. */ - node = node2; - node2 = node3; - node3 = NULL; - goto finalize_map_clause; - } - else - OMP_CLAUSE_SET_MAP_KIND (node3, - always_modifier - ? GOMP_MAP_ALWAYS_POINTER - : GOMP_MAP_POINTER); - - /* We have to check for n->sym->attr.dimension because - of scalar coarrays. */ - if (n->sym->attr.pointer && n->sym->attr.dimension) - { - stmtblock_t cond_block; - tree size - = gfc_create_var (gfc_array_index_type, NULL); - tree tem, then_b, else_b, zero, cond; - - gfc_init_block (&cond_block); - tem - = gfc_full_array_size (&cond_block, decl, - GFC_TYPE_ARRAY_RANK (type)); - gfc_add_modify (&cond_block, size, tem); - then_b = gfc_finish_block (&cond_block); - gfc_init_block (&cond_block); - zero = build_int_cst (gfc_array_index_type, 0); - gfc_add_modify (&cond_block, size, zero); - else_b = gfc_finish_block (&cond_block); - tem = gfc_conv_descriptor_data_get (decl); - tem = fold_convert (pvoid_type_node, tem); - cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, - tem, null_pointer_node); - if (present) - cond = fold_build2_loc (input_location, - TRUTH_ANDIF_EXPR, - boolean_type_node, - present, cond); - gfc_add_expr_to_block (block, - build3_loc (input_location, - COND_EXPR, - void_type_node, - cond, then_b, - else_b)); - OMP_CLAUSE_SIZE (node) = size; - } - else if (n->sym->attr.dimension) - { - stmtblock_t cond_block; - gfc_init_block (&cond_block); - tree size = gfc_full_array_size (&cond_block, decl, - GFC_TYPE_ARRAY_RANK (type)); - if (present) - { - tree var = gfc_create_var (gfc_array_index_type, - NULL); - gfc_add_modify (&cond_block, var, size); - tree cond_body = gfc_finish_block (&cond_block); - tree cond = build3_loc (input_location, COND_EXPR, - void_type_node, present, - cond_body, NULL_TREE); - gfc_add_expr_to_block (block, cond); - OMP_CLAUSE_SIZE (node) = var; - } - else - { - gfc_add_block_to_block (block, &cond_block); - OMP_CLAUSE_SIZE (node) = size; - } - } - if (n->sym->attr.dimension) - { - tree elemsz - = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); - } - } - else if (present - && TREE_CODE (decl) == INDIRECT_REF - && (TREE_CODE (TREE_OPERAND (decl, 0)) - == INDIRECT_REF)) - { - /* A single indirectref is handled by the middle end. */ - gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl))); - decl = TREE_OPERAND (decl, 0); - decl = gfc_build_cond_assign_expr (block, present, decl, - null_pointer_node); - OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl); - } - else - OMP_CLAUSE_DECL (node) = decl; - } - else if (n->expr - && n->expr->expr_type == EXPR_VARIABLE - && n->expr->ref->type == REF_ARRAY - && !n->expr->ref->next) - { - /* An array element or array section which is not part of a - derived type, etc. */ - bool element = n->expr->ref->u.ar.type == AR_ELEMENT; - gfc_trans_omp_array_section (block, n, decl, element, - GOMP_MAP_POINTER, node, node2, - node3, node4); - } - else if (n->expr - && n->expr->expr_type == EXPR_VARIABLE - && (n->expr->ref->type == REF_COMPONENT - || n->expr->ref->type == REF_ARRAY) - && lastref - && lastref->type == REF_COMPONENT - && lastref->u.c.component->ts.type != BT_CLASS - && lastref->u.c.component->ts.type != BT_DERIVED - && !lastref->u.c.component->attr.dimension) - { - /* Derived type access with last component being a scalar. */ - gfc_init_se (&se, NULL); - - gfc_conv_expr (&se, n->expr); - gfc_add_block_to_block (block, &se.pre); - /* For BT_CHARACTER a pointer is returned. */ - OMP_CLAUSE_DECL (node) - = POINTER_TYPE_P (TREE_TYPE (se.expr)) - ? build_fold_indirect_ref (se.expr) : se.expr; - gfc_add_block_to_block (block, &se.post); - if (pointer || allocatable) - { - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - gomp_map_kind kind - = (openacc ? GOMP_MAP_ATTACH_DETACH - : GOMP_MAP_ALWAYS_POINTER); - OMP_CLAUSE_SET_MAP_KIND (node2, kind); - OMP_CLAUSE_DECL (node2) - = POINTER_TYPE_P (TREE_TYPE (se.expr)) - ? se.expr - : gfc_build_addr_expr (NULL, se.expr); - OMP_CLAUSE_SIZE (node2) = size_int (0); - if (!openacc - && n->expr->ts.type == BT_CHARACTER - && n->expr->ts.deferred) - { - gcc_assert (se.string_length); - tree tmp - = gfc_get_char_type (n->expr->ts.kind); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, size_type_node, - fold_convert (size_type_node, - se.string_length), - TYPE_SIZE_UNIT (tmp)); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO); - OMP_CLAUSE_DECL (node3) = se.string_length; - OMP_CLAUSE_SIZE (node3) - = TYPE_SIZE_UNIT (gfc_charlen_type_node); - } - } - } - else if (n->expr - && n->expr->expr_type == EXPR_VARIABLE - && (n->expr->ref->type == REF_COMPONENT - || n->expr->ref->type == REF_ARRAY)) - { - gfc_init_se (&se, NULL); - se.expr = gfc_maybe_dereference_var (n->sym, decl); - - for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT) - { - if (ref->u.c.sym->attr.extension) - conv_parent_component_references (&se, ref); - - gfc_conv_component_ref (&se, ref); - } - else if (ref->type == REF_ARRAY) - { - if (ref->u.ar.type == AR_ELEMENT && ref->next) - gfc_conv_array_ref (&se, &ref->u.ar, n->expr, - &n->expr->where); - else - gcc_assert (!ref->next); - } - else - sorry ("unhandled expression type"); - } - - tree inner = se.expr; - - /* Last component is a derived type or class pointer. */ - if (lastref->type == REF_COMPONENT - && (lastref->u.c.component->ts.type == BT_DERIVED - || lastref->u.c.component->ts.type == BT_CLASS)) - { - if (pointer || (openacc && allocatable)) - { - tree data, size; - - if (lastref->u.c.component->ts.type == BT_CLASS) - { - data = gfc_class_data_get (inner); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (data))); - data = build_fold_indirect_ref (data); - size = gfc_class_vtab_size_get (inner); - } - else /* BT_DERIVED. */ - { - data = inner; - size = TYPE_SIZE_UNIT (TREE_TYPE (inner)); - } - - OMP_CLAUSE_DECL (node) = data; - OMP_CLAUSE_SIZE (node) = size; - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, - openacc - ? GOMP_MAP_ATTACH_DETACH - : GOMP_MAP_ALWAYS_POINTER); - OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data); - OMP_CLAUSE_SIZE (node2) = size_int (0); - } - else - { - OMP_CLAUSE_DECL (node) = inner; - OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (inner)); - } - } - else if (lastref->type == REF_ARRAY - && lastref->u.ar.type == AR_FULL) - { - /* Just pass the (auto-dereferenced) decl through for - bare attach and detach clauses. */ - if (n->u.map_op == OMP_MAP_ATTACH - || n->u.map_op == OMP_MAP_DETACH) - { - OMP_CLAUSE_DECL (node) = inner; - OMP_CLAUSE_SIZE (node) = size_zero_node; - goto finalize_map_clause; - } - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) - { - gomp_map_kind map_kind; - tree desc_node; - tree type = TREE_TYPE (inner); - tree ptr = gfc_conv_descriptor_data_get (inner); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (node) = ptr; - int rank = GFC_TYPE_ARRAY_RANK (type); - OMP_CLAUSE_SIZE (node) - = gfc_full_array_size (block, inner, rank); - tree elemsz - = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node))) - map_kind = GOMP_MAP_TO; - else if (n->u.map_op == OMP_MAP_RELEASE - || n->u.map_op == OMP_MAP_DELETE) - map_kind = OMP_CLAUSE_MAP_KIND (node); - else - map_kind = GOMP_MAP_ALLOC; - if (!openacc - && n->expr->ts.type == BT_CHARACTER - && n->expr->ts.deferred) - { - gcc_assert (se.string_length); - tree len = fold_convert (size_type_node, - se.string_length); - elemsz = gfc_get_char_type (n->expr->ts.kind); - elemsz = TYPE_SIZE_UNIT (elemsz); - elemsz = fold_build2 (MULT_EXPR, size_type_node, - len, elemsz); - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); - OMP_CLAUSE_DECL (node4) = se.string_length; - OMP_CLAUSE_SIZE (node4) - = TYPE_SIZE_UNIT (gfc_charlen_type_node); - } - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); - desc_node = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - if (openacc) - OMP_CLAUSE_SET_MAP_KIND (desc_node, - GOMP_MAP_TO_PSET); - else - OMP_CLAUSE_SET_MAP_KIND (desc_node, map_kind); - OMP_CLAUSE_DECL (desc_node) = inner; - OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type); - if (openacc) - node2 = desc_node; - else - { - node2 = node; - node = desc_node; /* Put first. */ - } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, - openacc - ? GOMP_MAP_ATTACH_DETACH - : GOMP_MAP_ALWAYS_POINTER); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (inner); - /* Similar to gfc_trans_omp_array_section (details - there), we add/keep the cast for OpenMP to prevent - that an 'alloc:' gets added for node3 ('desc.data') - as that is part of the whole descriptor (node3). - TODO: Remove once the ME handles this properly. */ - if (!openacc) - OMP_CLAUSE_DECL (node3) - = fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)), - OMP_CLAUSE_DECL (node3)); - else - STRIP_NOPS (OMP_CLAUSE_DECL (node3)); - OMP_CLAUSE_SIZE (node3) = size_int (0); - } - else - OMP_CLAUSE_DECL (node) = inner; - } - else if (lastref->type == REF_ARRAY) - { - /* An array element or section. */ - bool element = lastref->u.ar.type == AR_ELEMENT; - gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH - : GOMP_MAP_ALWAYS_POINTER); - gfc_trans_omp_array_section (block, n, inner, element, - kind, node, node2, node3, - node4); - } - else - gcc_unreachable (); - } - else - sorry ("unhandled expression"); - - finalize_map_clause: - - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - if (node2) - omp_clauses = gfc_trans_add_clause (node2, omp_clauses); - if (node3) - omp_clauses = gfc_trans_add_clause (node3, omp_clauses); - if (node4) - omp_clauses = gfc_trans_add_clause (node4, omp_clauses); - } - break; - case OMP_LIST_TO: - case OMP_LIST_FROM: - case OMP_LIST_CACHE: - for (; n != NULL; n = n->next) - { - if (!n->sym->attr.referenced) - continue; - - switch (list) - { - case OMP_LIST_TO: - clause_code = OMP_CLAUSE_TO; - break; - case OMP_LIST_FROM: - clause_code = OMP_CLAUSE_FROM; - break; - case OMP_LIST_CACHE: - clause_code = OMP_CLAUSE__CACHE_; - break; - default: - gcc_unreachable (); - } - tree node = build_omp_clause (input_location, clause_code); - if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) - { - tree decl = gfc_trans_omp_variable (n->sym, false); - if (gfc_omp_privatize_by_reference (decl)) - { - if (gfc_omp_is_allocatable_or_ptr (decl)) - decl = build_fold_indirect_ref (decl); - decl = build_fold_indirect_ref (decl); - } - else if (DECL_P (decl)) - TREE_ADDRESSABLE (decl) = 1; - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - { - tree type = TREE_TYPE (decl); - tree ptr = gfc_conv_descriptor_data_get (decl); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (node) = ptr; - OMP_CLAUSE_SIZE (node) - = gfc_full_array_size (block, decl, - GFC_TYPE_ARRAY_RANK (type)); - tree elemsz - = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); - } - else - { - OMP_CLAUSE_DECL (node) = decl; - if (gfc_omp_is_allocatable_or_ptr (decl)) - OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl))); - } - } - else - { - tree ptr; - gfc_init_se (&se, NULL); - if (n->expr->ref->u.ar.type == AR_ELEMENT) - { - gfc_conv_expr_reference (&se, n->expr); - ptr = se.expr; - gfc_add_block_to_block (block, &se.pre); - OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); - } - else - { - gfc_conv_expr_descriptor (&se, n->expr); - ptr = gfc_conv_array_data (se.expr); - tree type = TREE_TYPE (se.expr); - gfc_add_block_to_block (block, &se.pre); - OMP_CLAUSE_SIZE (node) - = gfc_full_array_size (block, se.expr, - GFC_TYPE_ARRAY_RANK (type)); - tree elemsz - = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); - } - gfc_add_block_to_block (block, &se.post); - gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); - OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); - } - omp_clauses = gfc_trans_add_clause (node, omp_clauses); - } - break; - default: - break; - } - } - - if (clauses->if_expr) - { - tree if_var; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->if_expr); - gfc_add_block_to_block (block, &se.pre); - if_var = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); - OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK; - OMP_CLAUSE_IF_EXPR (c) = if_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - for (ifc = 0; ifc < OMP_IF_LAST; ifc++) - if (clauses->if_exprs[ifc]) - { - tree if_var; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->if_exprs[ifc]); - gfc_add_block_to_block (block, &se.pre); - if_var = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); - switch (ifc) - { - case OMP_IF_CANCEL: - OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST; - break; - case OMP_IF_PARALLEL: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL; - break; - case OMP_IF_SIMD: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD; - break; - case OMP_IF_TASK: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK; - break; - case OMP_IF_TASKLOOP: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP; - break; - case OMP_IF_TARGET: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET; - break; - case OMP_IF_TARGET_DATA: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA; - break; - case OMP_IF_TARGET_UPDATE: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE; - break; - case OMP_IF_TARGET_ENTER_DATA: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA; - break; - case OMP_IF_TARGET_EXIT_DATA: - OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA; - break; - default: - gcc_unreachable (); - } - OMP_CLAUSE_IF_EXPR (c) = if_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->final_expr) - { - tree final_var; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->final_expr); - gfc_add_block_to_block (block, &se.pre); - final_var = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL); - OMP_CLAUSE_FINAL_EXPR (c) = final_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->num_threads) - { - tree num_threads; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->num_threads); - gfc_add_block_to_block (block, &se.pre); - num_threads = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS); - OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - chunk_size = NULL_TREE; - if (clauses->chunk_size) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->chunk_size); - gfc_add_block_to_block (block, &se.pre); - chunk_size = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - } - - if (clauses->sched_kind != OMP_SCHED_NONE) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE); - OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; - switch (clauses->sched_kind) - { - case OMP_SCHED_STATIC: - OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; - break; - case OMP_SCHED_DYNAMIC: - OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; - break; - case OMP_SCHED_GUIDED: - OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; - break; - case OMP_SCHED_RUNTIME: - OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; - break; - case OMP_SCHED_AUTO: - OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO; - break; - default: - gcc_unreachable (); - } - if (clauses->sched_monotonic) - OMP_CLAUSE_SCHEDULE_KIND (c) - = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) - | OMP_CLAUSE_SCHEDULE_MONOTONIC); - else if (clauses->sched_nonmonotonic) - OMP_CLAUSE_SCHEDULE_KIND (c) - = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) - | OMP_CLAUSE_SCHEDULE_NONMONOTONIC); - if (clauses->sched_simd) - OMP_CLAUSE_SCHEDULE_SIMD (c) = 1; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT); - switch (clauses->default_sharing) - { - case OMP_DEFAULT_NONE: - OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; - break; - case OMP_DEFAULT_SHARED: - OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; - break; - case OMP_DEFAULT_PRIVATE: - OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; - break; - case OMP_DEFAULT_FIRSTPRIVATE: - OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; - break; - case OMP_DEFAULT_PRESENT: - OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT; - break; - default: - gcc_unreachable (); - } - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->nowait) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->ordered) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED); - OMP_CLAUSE_ORDERED_EXPR (c) - = clauses->orderedc ? build_int_cst (integer_type_node, - clauses->orderedc) : NULL_TREE; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->order_concurrent) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER); - OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained; - OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->untied) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->mergeable) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->collapse) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE); - OMP_CLAUSE_COLLAPSE_EXPR (c) - = build_int_cst (integer_type_node, clauses->collapse); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->inbranch) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->notinbranch) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - switch (clauses->cancel) - { - case OMP_CANCEL_UNKNOWN: - break; - case OMP_CANCEL_PARALLEL: - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - break; - case OMP_CANCEL_SECTIONS: - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - break; - case OMP_CANCEL_DO: - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - break; - case OMP_CANCEL_TASKGROUP: - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - break; - } - - if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND); - switch (clauses->proc_bind) - { - case OMP_PROC_BIND_PRIMARY: - OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY; - break; - case OMP_PROC_BIND_MASTER: - OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER; - break; - case OMP_PROC_BIND_SPREAD: - OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD; - break; - case OMP_PROC_BIND_CLOSE: - OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE; - break; - default: - gcc_unreachable (); - } - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->safelen_expr) - { - tree safelen_var; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->safelen_expr); - gfc_add_block_to_block (block, &se.pre); - safelen_var = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN); - OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->simdlen_expr) - { - if (declare_simd) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN); - OMP_CLAUSE_SIMDLEN_EXPR (c) - = gfc_conv_constant_to_tree (clauses->simdlen_expr); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - else - { - tree simdlen_var; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->simdlen_expr); - gfc_add_block_to_block (block, &se.pre); - simdlen_var = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN); - OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - } - - if (clauses->num_teams_upper) - { - tree num_teams_lower = NULL_TREE, num_teams_upper; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->num_teams_upper); - gfc_add_block_to_block (block, &se.pre); - num_teams_upper = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - if (clauses->num_teams_lower) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->num_teams_lower); - gfc_add_block_to_block (block, &se.pre); - num_teams_lower = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - } - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS); - OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower; - OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->device) - { - tree device; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->device); - gfc_add_block_to_block (block, &se.pre); - device = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE); - OMP_CLAUSE_DEVICE_ID (c) = device; - - if (clauses->ancestor) - OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1; - - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->thread_limit) - { - tree thread_limit; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->thread_limit); - gfc_add_block_to_block (block, &se.pre); - thread_limit = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT); - OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - chunk_size = NULL_TREE; - if (clauses->dist_chunk_size) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->dist_chunk_size); - gfc_add_block_to_block (block, &se.pre); - chunk_size = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - } - - if (clauses->dist_sched_kind != OMP_SCHED_NONE) - { - c = build_omp_clause (gfc_get_location (&where), - OMP_CLAUSE_DIST_SCHEDULE); - OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->grainsize) - { - tree grainsize; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->grainsize); - gfc_add_block_to_block (block, &se.pre); - grainsize = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE); - OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize; - if (clauses->grainsize_strict) - OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->num_tasks) - { - tree num_tasks; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->num_tasks); - gfc_add_block_to_block (block, &se.pre); - num_tasks = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS); - OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks; - if (clauses->num_tasks_strict) - OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->priority) - { - tree priority; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->priority); - gfc_add_block_to_block (block, &se.pre); - priority = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY); - OMP_CLAUSE_PRIORITY_EXPR (c) = priority; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->detach) - { - tree detach; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->detach); - gfc_add_block_to_block (block, &se.pre); - detach = se.expr; - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH); - TREE_ADDRESSABLE (detach) = 1; - OMP_CLAUSE_DECL (c) = detach; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->filter) - { - tree filter; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->filter); - gfc_add_block_to_block (block, &se.pre); - filter = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER); - OMP_CLAUSE_FILTER_EXPR (c) = filter; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->hint) - { - tree hint; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, clauses->hint); - gfc_add_block_to_block (block, &se.pre); - hint = gfc_evaluate_now (se.expr, block); - gfc_add_block_to_block (block, &se.post); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT); - OMP_CLAUSE_HINT_EXPR (c) = hint; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->simd) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->threads) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->nogroup) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) - { - if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) - continue; - enum omp_clause_defaultmap_kind behavior, category; - switch ((gfc_omp_defaultmap_category) i) - { - case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: - category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; - break; - case OMP_DEFAULTMAP_CAT_SCALAR: - category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR; - break; - case OMP_DEFAULTMAP_CAT_AGGREGATE: - category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE; - break; - case OMP_DEFAULTMAP_CAT_ALLOCATABLE: - category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE; - break; - case OMP_DEFAULTMAP_CAT_POINTER: - category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER; - break; - default: gcc_unreachable (); - } - switch (clauses->defaultmap[i]) - { - case OMP_DEFAULTMAP_ALLOC: - behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC; - break; - case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break; - case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break; - case OMP_DEFAULTMAP_TOFROM: - behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM; - break; - case OMP_DEFAULTMAP_FIRSTPRIVATE: - behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE; - break; - case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break; - case OMP_DEFAULTMAP_DEFAULT: - behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT; - break; - default: gcc_unreachable (); - } - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP); - OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->depend_source) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEPEND); - OMP_CLAUSE_DEPEND_KIND (c) = OMP_CLAUSE_DEPEND_SOURCE; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - - if (clauses->async) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC); - if (clauses->async_expr) - OMP_CLAUSE_ASYNC_EXPR (c) - = gfc_convert_expr_to_tree (block, clauses->async_expr); - else - OMP_CLAUSE_ASYNC_EXPR (c) = NULL; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->seq) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->par_auto) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->if_present) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->finalize) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->independent) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->wait_list) - { - gfc_expr_list *el; - - for (el = clauses->wait_list; el; el = el->next) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT); - OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr); - OMP_CLAUSE_CHAIN (c) = omp_clauses; - omp_clauses = c; - } - } - if (clauses->num_gangs_expr) - { - tree num_gangs_var - = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr); - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS); - OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->num_workers_expr) - { - tree num_workers_var - = gfc_convert_expr_to_tree (block, clauses->num_workers_expr); - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS); - OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->vector_length_expr) - { - tree vector_length_var - = gfc_convert_expr_to_tree (block, clauses->vector_length_expr); - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH); - OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var; - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - } - if (clauses->tile_list) - { - vec *tvec; - gfc_expr_list *el; - - vec_alloc (tvec, 4); - - for (el = clauses->tile_list; el; el = el->next) - vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr)); - - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE); - OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - tvec->truncate (0); - } - if (clauses->vector) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - - if (clauses->vector_expr) - { - tree vector_var - = gfc_convert_expr_to_tree (block, clauses->vector_expr); - OMP_CLAUSE_VECTOR_EXPR (c) = vector_var; - - /* TODO: We're not capturing location information for individual - clauses. However, if we have an expression attached to the - clause, that one provides better location information. */ - OMP_CLAUSE_LOCATION (c) - = gfc_get_location (&clauses->vector_expr->where); - } - } - if (clauses->worker) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - - if (clauses->worker_expr) - { - tree worker_var - = gfc_convert_expr_to_tree (block, clauses->worker_expr); - OMP_CLAUSE_WORKER_EXPR (c) = worker_var; - - /* TODO: We're not capturing location information for individual - clauses. However, if we have an expression attached to the - clause, that one provides better location information. */ - OMP_CLAUSE_LOCATION (c) - = gfc_get_location (&clauses->worker_expr->where); - } - } - if (clauses->gang) - { - tree arg; - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - - if (clauses->gang_num_expr) - { - arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr); - OMP_CLAUSE_GANG_EXPR (c) = arg; - - /* TODO: We're not capturing location information for individual - clauses. However, if we have an expression attached to the - clause, that one provides better location information. */ - OMP_CLAUSE_LOCATION (c) - = gfc_get_location (&clauses->gang_num_expr->where); - } - - if (clauses->gang_static) - { - arg = clauses->gang_static_expr - ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr) - : integer_minus_one_node; - OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg; - } - } - if (clauses->bind != OMP_BIND_UNSET) - { - c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND); - omp_clauses = gfc_trans_add_clause (c, omp_clauses); - switch (clauses->bind) - { - case OMP_BIND_TEAMS: - OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS; - break; - case OMP_BIND_PARALLEL: - OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL; - break; - case OMP_BIND_THREAD: - OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD; - break; - default: - gcc_unreachable (); - } - } - /* OpenACC 'nohost' clauses cannot appear here. */ - gcc_checking_assert (!clauses->nohost); - - return nreverse (omp_clauses); -} - -/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ - -static tree -gfc_trans_omp_code (gfc_code *code, bool force_empty) -{ - tree stmt; - - pushlevel (); - stmt = gfc_trans_code (code); - if (TREE_CODE (stmt) != BIND_EXPR) - { - if (!IS_EMPTY_STMT (stmt) || force_empty) - { - tree block = poplevel (1, 0); - stmt = build3_v (BIND_EXPR, NULL, stmt, block); - } - else - poplevel (0, 0); - } - else - poplevel (0, 0); - return stmt; -} - -/* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data' - construct. */ - -static tree -gfc_trans_oacc_construct (gfc_code *code) -{ - stmtblock_t block; - tree stmt, oacc_clauses; - enum tree_code construct_code; - - switch (code->op) - { - case EXEC_OACC_PARALLEL: - construct_code = OACC_PARALLEL; - break; - case EXEC_OACC_KERNELS: - construct_code = OACC_KERNELS; - break; - case EXEC_OACC_SERIAL: - construct_code = OACC_SERIAL; - break; - case EXEC_OACC_DATA: - construct_code = OACC_DATA; - break; - case EXEC_OACC_HOST_DATA: - construct_code = OACC_HOST_DATA; - break; - default: - gcc_unreachable (); - } - - gfc_start_block (&block); - oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc, false, true); - stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2_loc (gfc_get_location (&code->loc), construct_code, - void_type_node, stmt, oacc_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -/* update, enter_data, exit_data, cache. */ -static tree -gfc_trans_oacc_executable_directive (gfc_code *code) -{ - stmtblock_t block; - tree stmt, oacc_clauses; - enum tree_code construct_code; - - switch (code->op) - { - case EXEC_OACC_UPDATE: - construct_code = OACC_UPDATE; - break; - case EXEC_OACC_ENTER_DATA: - construct_code = OACC_ENTER_DATA; - break; - case EXEC_OACC_EXIT_DATA: - construct_code = OACC_EXIT_DATA; - break; - case EXEC_OACC_CACHE: - construct_code = OACC_CACHE; - break; - default: - gcc_unreachable (); - } - - gfc_start_block (&block); - oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc, false, true); - stmt = build1_loc (input_location, construct_code, void_type_node, - oacc_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_oacc_wait_directive (gfc_code *code) -{ - stmtblock_t block; - tree stmt, t; - vec *args; - int nparms = 0; - gfc_expr_list *el; - gfc_omp_clauses *clauses = code->ext.omp_clauses; - location_t loc = input_location; - - for (el = clauses->wait_list; el; el = el->next) - nparms++; - - vec_alloc (args, nparms + 2); - stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT); - - gfc_start_block (&block); - - if (clauses->async_expr) - t = gfc_convert_expr_to_tree (&block, clauses->async_expr); - else - t = build_int_cst (integer_type_node, -2); - - args->quick_push (t); - args->quick_push (build_int_cst (integer_type_node, nparms)); - - for (el = clauses->wait_list; el; el = el->next) - args->quick_push (gfc_convert_expr_to_tree (&block, el->expr)); - - stmt = build_call_expr_loc_vec (loc, stmt, args); - gfc_add_expr_to_block (&block, stmt); - - vec_free (args); - - return gfc_finish_block (&block); -} - -static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *); -static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); - -static tree -gfc_trans_omp_atomic (gfc_code *code) -{ - gfc_code *atomic_code = code->block; - gfc_se lse; - gfc_se rse; - gfc_se vse; - gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL; - gfc_symbol *var; - stmtblock_t block; - tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE; - enum tree_code op = ERROR_MARK; - enum tree_code aop = OMP_ATOMIC; - bool var_on_left = false, else_branch = false; - enum omp_memory_order mo, fail_mo; - switch (atomic_code->ext.omp_clauses->memorder) - { - case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break; - case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break; - case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break; - case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break; - case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break; - case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break; - default: gcc_unreachable (); - } - switch (atomic_code->ext.omp_clauses->fail) - { - case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break; - case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break; - case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break; - case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break; - default: gcc_unreachable (); - } - mo = (omp_memory_order) (mo | fail_mo); - - code = code->block->next; - if (atomic_code->ext.omp_clauses->compare) - { - gfc_expr *comp_expr; - if (code->op == EXEC_IF) - { - comp_expr = code->block->expr1; - gcc_assert (code->block->next->op == EXEC_ASSIGN); - expr1 = code->block->next->expr1; - expr2 = code->block->next->expr2; - if (code->block->block) - { - gcc_assert (atomic_code->ext.omp_clauses->capture - && code->block->block->next->op == EXEC_ASSIGN); - else_branch = true; - aop = OMP_ATOMIC_CAPTURE_OLD; - capture_expr1 = code->block->block->next->expr1; - capture_expr2 = code->block->block->next->expr2; - } - else if (atomic_code->ext.omp_clauses->capture) - { - gcc_assert (code->next->op == EXEC_ASSIGN); - aop = OMP_ATOMIC_CAPTURE_NEW; - capture_expr1 = code->next->expr1; - capture_expr2 = code->next->expr2; - } - } - else - { - gcc_assert (atomic_code->ext.omp_clauses->capture - && code->op == EXEC_ASSIGN - && code->next->op == EXEC_IF); - aop = OMP_ATOMIC_CAPTURE_OLD; - capture_expr1 = code->expr1; - capture_expr2 = code->expr2; - expr1 = code->next->block->next->expr1; - expr2 = code->next->block->next->expr2; - comp_expr = code->next->block->expr1; - } - gfc_init_se (&lse, NULL); - gfc_conv_expr (&lse, comp_expr->value.op.op2); - gfc_add_block_to_block (&block, &lse.pre); - compare = lse.expr; - var = expr1->symtree->n.sym; - } - else - { - gcc_assert (code->op == EXEC_ASSIGN); - expr1 = code->expr1; - expr2 = code->expr2; - if (atomic_code->ext.omp_clauses->capture - && (expr2->expr_type == EXPR_VARIABLE - || (expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym - && expr2->value.function.isym->id == GFC_ISYM_CONVERSION - && (expr2->value.function.actual->expr->expr_type - == EXPR_VARIABLE)))) - { - capture_expr1 = expr1; - capture_expr2 = expr2; - expr1 = code->next->expr1; - expr2 = code->next->expr2; - aop = OMP_ATOMIC_CAPTURE_OLD; - } - else if (atomic_code->ext.omp_clauses->capture) - { - aop = OMP_ATOMIC_CAPTURE_NEW; - capture_expr1 = code->next->expr1; - capture_expr2 = code->next->expr2; - } - var = expr1->symtree->n.sym; - } - - gfc_init_se (&lse, NULL); - gfc_init_se (&rse, NULL); - gfc_init_se (&vse, NULL); - gfc_start_block (&block); - - if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) - != GFC_OMP_ATOMIC_WRITE) - && expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym - && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) - expr2 = expr2->value.function.actual->expr; - - if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) - == GFC_OMP_ATOMIC_READ) - { - gfc_conv_expr (&vse, expr1); - gfc_add_block_to_block (&block, &vse.pre); - - gfc_conv_expr (&lse, expr2); - gfc_add_block_to_block (&block, &lse.pre); - type = TREE_TYPE (lse.expr); - lhsaddr = gfc_build_addr_expr (NULL, lse.expr); - - x = build1 (OMP_ATOMIC_READ, type, lhsaddr); - OMP_ATOMIC_MEMORY_ORDER (x) = mo; - x = convert (TREE_TYPE (vse.expr), x); - gfc_add_modify (&block, vse.expr, x); - - gfc_add_block_to_block (&block, &lse.pre); - gfc_add_block_to_block (&block, &rse.pre); - - return gfc_finish_block (&block); - } - - if (capture_expr2 - && capture_expr2->expr_type == EXPR_FUNCTION - && capture_expr2->value.function.isym - && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION) - capture_expr2 = capture_expr2->value.function.actual->expr; - gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE); - - if (aop == OMP_ATOMIC_CAPTURE_OLD) - { - gfc_conv_expr (&vse, capture_expr1); - gfc_add_block_to_block (&block, &vse.pre); - gfc_conv_expr (&lse, capture_expr2); - gfc_add_block_to_block (&block, &lse.pre); - gfc_init_se (&lse, NULL); - } - - gfc_conv_expr (&lse, expr1); - gfc_add_block_to_block (&block, &lse.pre); - type = TREE_TYPE (lse.expr); - lhsaddr = gfc_build_addr_expr (NULL, lse.expr); - - if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) - == GFC_OMP_ATOMIC_WRITE) - || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP) - || compare) - { - gfc_conv_expr (&rse, expr2); - gfc_add_block_to_block (&block, &rse.pre); - } - else if (expr2->expr_type == EXPR_OP) - { - gfc_expr *e; - switch (expr2->value.op.op) - { - case INTRINSIC_PLUS: - op = PLUS_EXPR; - break; - case INTRINSIC_TIMES: - op = MULT_EXPR; - break; - case INTRINSIC_MINUS: - op = MINUS_EXPR; - break; - case INTRINSIC_DIVIDE: - if (expr2->ts.type == BT_INTEGER) - op = TRUNC_DIV_EXPR; - else - op = RDIV_EXPR; - break; - case INTRINSIC_AND: - op = TRUTH_ANDIF_EXPR; - break; - case INTRINSIC_OR: - op = TRUTH_ORIF_EXPR; - break; - case INTRINSIC_EQV: - op = EQ_EXPR; - break; - case INTRINSIC_NEQV: - op = NE_EXPR; - break; - default: - gcc_unreachable (); - } - e = expr2->value.op.op1; - if (e->expr_type == EXPR_FUNCTION - && e->value.function.isym - && e->value.function.isym->id == GFC_ISYM_CONVERSION) - e = e->value.function.actual->expr; - if (e->expr_type == EXPR_VARIABLE - && e->symtree != NULL - && e->symtree->n.sym == var) - { - expr2 = expr2->value.op.op2; - var_on_left = true; - } - else - { - e = expr2->value.op.op2; - if (e->expr_type == EXPR_FUNCTION - && e->value.function.isym - && e->value.function.isym->id == GFC_ISYM_CONVERSION) - e = e->value.function.actual->expr; - gcc_assert (e->expr_type == EXPR_VARIABLE - && e->symtree != NULL - && e->symtree->n.sym == var); - expr2 = expr2->value.op.op1; - var_on_left = false; - } - gfc_conv_expr (&rse, expr2); - gfc_add_block_to_block (&block, &rse.pre); - } - else - { - gcc_assert (expr2->expr_type == EXPR_FUNCTION); - switch (expr2->value.function.isym->id) - { - case GFC_ISYM_MIN: - op = MIN_EXPR; - break; - case GFC_ISYM_MAX: - op = MAX_EXPR; - break; - case GFC_ISYM_IAND: - op = BIT_AND_EXPR; - break; - case GFC_ISYM_IOR: - op = BIT_IOR_EXPR; - break; - case GFC_ISYM_IEOR: - op = BIT_XOR_EXPR; - break; - default: - gcc_unreachable (); - } - e = expr2->value.function.actual->expr; - if (e->expr_type == EXPR_FUNCTION - && e->value.function.isym - && e->value.function.isym->id == GFC_ISYM_CONVERSION) - e = e->value.function.actual->expr; - gcc_assert (e->expr_type == EXPR_VARIABLE - && e->symtree != NULL - && e->symtree->n.sym == var); - - gfc_conv_expr (&rse, expr2->value.function.actual->next->expr); - gfc_add_block_to_block (&block, &rse.pre); - if (expr2->value.function.actual->next->next != NULL) - { - tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL); - gfc_actual_arglist *arg; - - gfc_add_modify (&block, accum, rse.expr); - for (arg = expr2->value.function.actual->next->next; arg; - arg = arg->next) - { - gfc_init_block (&rse.pre); - gfc_conv_expr (&rse, arg->expr); - gfc_add_block_to_block (&block, &rse.pre); - x = fold_build2_loc (input_location, op, TREE_TYPE (accum), - accum, rse.expr); - gfc_add_modify (&block, accum, x); - } - - rse.expr = accum; - } - - expr2 = expr2->value.function.actual->next->expr; - } - - lhsaddr = save_expr (lhsaddr); - if (TREE_CODE (lhsaddr) != SAVE_EXPR - && (TREE_CODE (lhsaddr) != ADDR_EXPR - || !VAR_P (TREE_OPERAND (lhsaddr, 0)))) - { - /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize - it even after unsharing function body. */ - tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr)); - DECL_CONTEXT (var) = current_function_decl; - lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, - NULL_TREE, NULL_TREE); - } - - if (compare) - { - tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr)); - DECL_CONTEXT (var) = current_function_decl; - lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL, - NULL); - lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr); - compare = convert (TREE_TYPE (lse.expr), compare); - compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - lse.expr, compare); - } - - if (expr2->expr_type == EXPR_VARIABLE || compare) - rhs = rse.expr; - else - rhs = gfc_evaluate_now (rse.expr, &block); - - if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) - == GFC_OMP_ATOMIC_WRITE) - || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP) - || compare) - x = rhs; - else - { - x = convert (TREE_TYPE (rhs), - build_fold_indirect_ref_loc (input_location, lhsaddr)); - if (var_on_left) - x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs); - else - x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x); - } - - if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE - && TREE_CODE (type) != COMPLEX_TYPE) - x = fold_build1_loc (input_location, REALPART_EXPR, - TREE_TYPE (TREE_TYPE (rhs)), x); - - gfc_add_block_to_block (&block, &lse.pre); - gfc_add_block_to_block (&block, &rse.pre); - - if (aop == OMP_ATOMIC_CAPTURE_NEW) - { - gfc_conv_expr (&vse, capture_expr1); - gfc_add_block_to_block (&block, &vse.pre); - gfc_add_block_to_block (&block, &lse.pre); - } - - if (compare && else_branch) - { - tree var2 = create_tmp_var_raw (boolean_type_node); - DECL_CONTEXT (var2) = current_function_decl; - comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2, - boolean_false_node, NULL, NULL); - compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2), - var2, compare); - TREE_OPERAND (compare, 0) = comp_tgt; - compare = omit_one_operand_loc (input_location, boolean_type_node, - compare, comp_tgt); - } - - if (compare) - x = build3_loc (input_location, COND_EXPR, type, compare, - convert (type, x), lse.expr); - - if (aop == OMP_ATOMIC) - { - x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); - OMP_ATOMIC_MEMORY_ORDER (x) = mo; - OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; - gfc_add_expr_to_block (&block, x); - } - else - { - x = build2 (aop, type, lhsaddr, convert (type, x)); - OMP_ATOMIC_MEMORY_ORDER (x) = mo; - OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; - if (compare && else_branch) - { - tree vtmp = create_tmp_var_raw (TREE_TYPE (x)); - DECL_CONTEXT (vtmp) = current_function_decl; - x = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (vtmp), vtmp, x); - vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp, - build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL); - TREE_OPERAND (x, 0) = vtmp; - tree x2 = convert (TREE_TYPE (vse.expr), vtmp); - x2 = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (vse.expr), vse.expr, x2); - x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt, - void_node, x2); - x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x); - gfc_add_expr_to_block (&block, x); - } - else - { - x = convert (TREE_TYPE (vse.expr), x); - gfc_add_modify (&block, vse.expr, x); - } - } - - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_barrier (void) -{ - tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER); - return build_call_expr_loc (input_location, decl, 0); -} - -static tree -gfc_trans_omp_cancel (gfc_code *code) -{ - int mask = 0; - tree ifc = boolean_true_node; - stmtblock_t block; - switch (code->ext.omp_clauses->cancel) - { - case OMP_CANCEL_PARALLEL: mask = 1; break; - case OMP_CANCEL_DO: mask = 2; break; - case OMP_CANCEL_SECTIONS: mask = 4; break; - case OMP_CANCEL_TASKGROUP: mask = 8; break; - default: gcc_unreachable (); - } - gfc_start_block (&block); - if (code->ext.omp_clauses->if_expr - || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]) - { - gfc_se se; - tree if_var; - - gcc_assert ((code->ext.omp_clauses->if_expr == NULL) - ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL)); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL - ? code->ext.omp_clauses->if_expr - : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]); - gfc_add_block_to_block (&block, &se.pre); - if_var = gfc_evaluate_now (se.expr, &block); - gfc_add_block_to_block (&block, &se.post); - tree type = TREE_TYPE (if_var); - ifc = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, if_var, - build_zero_cst (type)); - } - tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL); - tree c_bool_type = TREE_TYPE (TREE_TYPE (decl)); - ifc = fold_convert (c_bool_type, ifc); - gfc_add_expr_to_block (&block, - build_call_expr_loc (input_location, decl, 2, - build_int_cst (integer_type_node, - mask), ifc)); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_cancellation_point (gfc_code *code) -{ - int mask = 0; - switch (code->ext.omp_clauses->cancel) - { - case OMP_CANCEL_PARALLEL: mask = 1; break; - case OMP_CANCEL_DO: mask = 2; break; - case OMP_CANCEL_SECTIONS: mask = 4; break; - case OMP_CANCEL_TASKGROUP: mask = 8; break; - default: gcc_unreachable (); - } - tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT); - return build_call_expr_loc (input_location, decl, 1, - build_int_cst (integer_type_node, mask)); -} - -static tree -gfc_trans_omp_critical (gfc_code *code) -{ - stmtblock_t block; - tree stmt, name = NULL_TREE; - if (code->ext.omp_clauses->critical_name != NULL) - name = get_identifier (code->ext.omp_clauses->critical_name); - gfc_start_block (&block); - stmt = make_node (OMP_CRITICAL); - TREE_TYPE (stmt) = void_type_node; - OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next); - OMP_CRITICAL_NAME (stmt) = name; - OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, - code->ext.omp_clauses, - code->loc); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -typedef struct dovar_init_d { - tree var; - tree init; -} dovar_init; - - -static tree -gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, - gfc_omp_clauses *do_clauses, tree par_clauses) -{ - gfc_se se; - tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls; - tree count = NULL_TREE, cycle_label, tmp, omp_clauses; - stmtblock_t block; - stmtblock_t body; - gfc_omp_clauses *clauses = code->ext.omp_clauses; - int i, collapse = clauses->collapse; - vec inits = vNULL; - dovar_init *di; - unsigned ix; - vec *saved_doacross_steps = doacross_steps; - gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list; - - /* Both collapsed and tiled loops are lowered the same way. In - OpenACC, those clauses are not compatible, so prioritize the tile - clause, if present. */ - if (tile) - { - collapse = 0; - for (gfc_expr_list *el = tile; el; el = el->next) - collapse++; - } - - doacross_steps = NULL; - if (clauses->orderedc) - collapse = clauses->orderedc; - if (collapse <= 0) - collapse = 1; - - code = code->block->next; - gcc_assert (code->op == EXEC_DO); - - init = make_tree_vec (collapse); - cond = make_tree_vec (collapse); - incr = make_tree_vec (collapse); - orig_decls = clauses->orderedc ? make_tree_vec (collapse) : NULL_TREE; - - if (pblock == NULL) - { - gfc_start_block (&block); - pblock = █ - } - - /* simd schedule modifier is only useful for composite do simd and other - constructs including that, where gfc_trans_omp_do is only called - on the simd construct and DO's clauses are translated elsewhere. */ - do_clauses->sched_simd = false; - - omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc); - - for (i = 0; i < collapse; i++) - { - int simple = 0; - int dovar_found = 0; - tree dovar_decl; - - if (clauses) - { - gfc_omp_namelist *n = NULL; - if (op == EXEC_OMP_SIMD && collapse == 1) - for (n = clauses->lists[OMP_LIST_LINEAR]; - n != NULL; n = n->next) - if (code->ext.iterator->var->symtree->n.sym == n->sym) - { - dovar_found = 3; - break; - } - if (n == NULL && op != EXEC_OMP_DISTRIBUTE) - for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; - n != NULL; n = n->next) - if (code->ext.iterator->var->symtree->n.sym == n->sym) - { - dovar_found = 2; - break; - } - if (n == NULL) - for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) - if (code->ext.iterator->var->symtree->n.sym == n->sym) - { - dovar_found = 1; - break; - } - } - - /* Evaluate all the expressions in the iterator. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->ext.iterator->var); - gfc_add_block_to_block (pblock, &se.pre); - dovar = se.expr; - type = TREE_TYPE (dovar); - gcc_assert (TREE_CODE (type) == INTEGER_TYPE); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->ext.iterator->start); - gfc_add_block_to_block (pblock, &se.pre); - from = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->ext.iterator->end); - gfc_add_block_to_block (pblock, &se.pre); - to = gfc_evaluate_now (se.expr, pblock); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->ext.iterator->step); - gfc_add_block_to_block (pblock, &se.pre); - step = gfc_evaluate_now (se.expr, pblock); - dovar_decl = dovar; - - /* Special case simple loops. */ - if (VAR_P (dovar)) - { - if (integer_onep (step)) - simple = 1; - else if (tree_int_cst_equal (step, integer_minus_one_node)) - simple = -1; - } - else - dovar_decl - = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym, - false); - - /* Loop body. */ - if (simple) - { - TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from); - /* The condition should not be folded. */ - TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0 - ? LE_EXPR : GE_EXPR, - logical_type_node, dovar, to); - TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, - type, dovar, step); - TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, - MODIFY_EXPR, - type, dovar, - TREE_VEC_ELT (incr, i)); - } - else - { - /* STEP is not 1 or -1. Use: - for (count = 0; count < (to + step - from) / step; count++) - { - dovar = from + count * step; - body; - cycle_label:; - } */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp); - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp, - step); - tmp = gfc_evaluate_now (tmp, pblock); - count = gfc_create_var (type, "count"); - TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count, - build_int_cst (type, 0)); - /* The condition should not be folded. */ - TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR, - logical_type_node, - count, tmp); - TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, - type, count, - build_int_cst (type, 1)); - TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, - MODIFY_EXPR, type, count, - TREE_VEC_ELT (incr, i)); - - /* Initialize DOVAR. */ - tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp); - dovar_init e = {dovar, tmp}; - inits.safe_push (e); - if (clauses->orderedc) - { - if (doacross_steps == NULL) - vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true); - (*doacross_steps)[i] = step; - } - } - if (orig_decls) - TREE_VEC_ELT (orig_decls, i) = dovar_decl; - - if (dovar_found == 3 - && op == EXEC_OMP_SIMD - && collapse == 1 - && !simple) - { - for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp)) - if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR - && OMP_CLAUSE_DECL (tmp) == dovar) - { - OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; - break; - } - } - if (!dovar_found && op == EXEC_OMP_SIMD) - { - if (collapse == 1) - { - tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); - OMP_CLAUSE_LINEAR_STEP (tmp) = step; - OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; - OMP_CLAUSE_DECL (tmp) = dovar_decl; - omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); - } - if (!simple) - dovar_found = 3; - } - else if (!dovar_found && !simple) - { - tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); - OMP_CLAUSE_DECL (tmp) = dovar_decl; - omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); - } - if (dovar_found > 1) - { - tree c = NULL; - - tmp = NULL; - if (!simple) - { - /* If dovar is lastprivate, but different counter is used, - dovar += step needs to be added to - OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar - will have the value on entry of the last loop, rather - than value after iterator increment. */ - if (clauses->orderedc) - { - if (clauses->collapse <= 1 || i >= clauses->collapse) - tmp = count; - else - tmp = fold_build2_loc (input_location, PLUS_EXPR, - type, count, build_one_cst (type)); - tmp = fold_build2_loc (input_location, MULT_EXPR, type, - tmp, step); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, - from, tmp); - } - else - { - tmp = gfc_evaluate_now (step, pblock); - tmp = fold_build2_loc (input_location, PLUS_EXPR, type, - dovar, tmp); - } - tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, - dovar, tmp); - for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) - if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE - && OMP_CLAUSE_DECL (c) == dovar_decl) - { - OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; - break; - } - else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR - && OMP_CLAUSE_DECL (c) == dovar_decl) - { - OMP_CLAUSE_LINEAR_STMT (c) = tmp; - break; - } - } - if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL) - { - for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) - if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE - && OMP_CLAUSE_DECL (c) == dovar_decl) - { - tree l = build_omp_clause (input_location, - OMP_CLAUSE_LASTPRIVATE); - if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c)) - OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1; - OMP_CLAUSE_DECL (l) = dovar_decl; - OMP_CLAUSE_CHAIN (l) = omp_clauses; - OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; - omp_clauses = l; - OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED); - break; - } - } - gcc_assert (simple || c != NULL); - } - if (!simple) - { - if (op != EXEC_OMP_SIMD || dovar_found == 1) - tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); - else if (collapse == 1) - { - tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); - OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1); - OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; - OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1; - } - else - tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); - OMP_CLAUSE_DECL (tmp) = count; - omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); - } - - if (i + 1 < collapse) - code = code->block->next; - } - - if (pblock != &block) - { - pushlevel (); - gfc_start_block (&block); - } - - gfc_start_block (&body); - - FOR_EACH_VEC_ELT (inits, ix, di) - gfc_add_modify (&body, di->var, di->init); - inits.release (); - - /* Cycle statement is implemented with a goto. Exit statement must not be - present for this loop. */ - cycle_label = gfc_build_label_decl (NULL_TREE); - - /* Put these labels where they can be found later. */ - - code->cycle_label = cycle_label; - code->exit_label = NULL_TREE; - - /* Main loop body. */ - if (clauses->lists[OMP_LIST_REDUCTION_INSCAN]) - { - gcc_assert (code->block->next->next->op == EXEC_OMP_SCAN); - gcc_assert (code->block->next->next->next->next == NULL); - locus *cloc = &code->block->next->next->loc; - location_t loc = gfc_get_location (cloc); - - gfc_code code2 = *code->block->next; - code2.next = NULL; - tmp = gfc_trans_code (&code2); - tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE); - SET_EXPR_LOCATION (tmp, loc); - gfc_add_expr_to_block (&body, tmp); - input_location = loc; - tree c = gfc_trans_omp_clauses (&body, - code->block->next->next->ext.omp_clauses, - *cloc); - code2 = *code->block->next->next->next; - code2.next = NULL; - tmp = gfc_trans_code (&code2); - tmp = build2 (OMP_SCAN, void_type_node, tmp, c); - SET_EXPR_LOCATION (tmp, loc); - } - else - tmp = gfc_trans_omp_code (code->block->next, true); - gfc_add_expr_to_block (&body, tmp); - - /* Label for cycle statements (if needed). */ - if (TREE_USED (cycle_label)) - { - tmp = build1_v (LABEL_EXPR, cycle_label); - gfc_add_expr_to_block (&body, tmp); - } - - /* End of loop body. */ - switch (op) - { - case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break; - case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break; - case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break; - case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break; - case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break; - case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break; - default: gcc_unreachable (); - } - - TREE_TYPE (stmt) = void_type_node; - OMP_FOR_BODY (stmt) = gfc_finish_block (&body); - OMP_FOR_CLAUSES (stmt) = omp_clauses; - OMP_FOR_INIT (stmt) = init; - OMP_FOR_COND (stmt) = cond; - OMP_FOR_INCR (stmt) = incr; - if (orig_decls) - OMP_FOR_ORIG_DECLS (stmt) = orig_decls; - gfc_add_expr_to_block (&block, stmt); - - vec_free (doacross_steps); - doacross_steps = saved_doacross_steps; - - return gfc_finish_block (&block); -} - -/* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop' - construct. */ - -static tree -gfc_trans_oacc_combined_directive (gfc_code *code) -{ - stmtblock_t block, *pblock = NULL; - gfc_omp_clauses construct_clauses, loop_clauses; - tree stmt, oacc_clauses = NULL_TREE; - enum tree_code construct_code; - location_t loc = input_location; - - switch (code->op) - { - case EXEC_OACC_PARALLEL_LOOP: - construct_code = OACC_PARALLEL; - break; - case EXEC_OACC_KERNELS_LOOP: - construct_code = OACC_KERNELS; - break; - case EXEC_OACC_SERIAL_LOOP: - construct_code = OACC_SERIAL; - break; - default: - gcc_unreachable (); - } - - gfc_start_block (&block); - - memset (&loop_clauses, 0, sizeof (loop_clauses)); - if (code->ext.omp_clauses != NULL) - { - memcpy (&construct_clauses, code->ext.omp_clauses, - sizeof (construct_clauses)); - loop_clauses.collapse = construct_clauses.collapse; - loop_clauses.gang = construct_clauses.gang; - loop_clauses.gang_static = construct_clauses.gang_static; - loop_clauses.gang_num_expr = construct_clauses.gang_num_expr; - loop_clauses.gang_static_expr = construct_clauses.gang_static_expr; - loop_clauses.vector = construct_clauses.vector; - loop_clauses.vector_expr = construct_clauses.vector_expr; - loop_clauses.worker = construct_clauses.worker; - loop_clauses.worker_expr = construct_clauses.worker_expr; - loop_clauses.seq = construct_clauses.seq; - loop_clauses.par_auto = construct_clauses.par_auto; - loop_clauses.independent = construct_clauses.independent; - loop_clauses.tile_list = construct_clauses.tile_list; - loop_clauses.lists[OMP_LIST_PRIVATE] - = construct_clauses.lists[OMP_LIST_PRIVATE]; - loop_clauses.lists[OMP_LIST_REDUCTION] - = construct_clauses.lists[OMP_LIST_REDUCTION]; - construct_clauses.gang = false; - construct_clauses.gang_static = false; - construct_clauses.gang_num_expr = NULL; - construct_clauses.gang_static_expr = NULL; - construct_clauses.vector = false; - construct_clauses.vector_expr = NULL; - construct_clauses.worker = false; - construct_clauses.worker_expr = NULL; - construct_clauses.seq = false; - construct_clauses.par_auto = false; - construct_clauses.independent = false; - construct_clauses.independent = false; - construct_clauses.tile_list = NULL; - construct_clauses.lists[OMP_LIST_PRIVATE] = NULL; - if (construct_code == OACC_KERNELS) - construct_clauses.lists[OMP_LIST_REDUCTION] = NULL; - oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses, - code->loc, false, true); - } - if (!loop_clauses.seq) - pblock = █ - else - pushlevel (); - stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL); - protected_set_expr_location (stmt, loc); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_depobj (gfc_code *code) -{ - stmtblock_t block; - gfc_se se; - gfc_init_se (&se, NULL); - gfc_init_block (&block); - gfc_conv_expr (&se, code->ext.omp_clauses->depobj); - gcc_assert (se.pre.head == NULL && se.post.head == NULL); - tree depobj = se.expr; - location_t loc = EXPR_LOCATION (depobj); - if (!POINTER_TYPE_P (TREE_TYPE (depobj))) - depobj = gfc_build_addr_expr (NULL, depobj); - depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node, - TYPE_MODE (ptr_type_node), - true), depobj); - gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND]; - if (n) - { - tree var; - if (n->expr) - var = gfc_convert_expr_to_tree (&block, n->expr); - else - var = gfc_get_symbol_decl (n->sym); - if (!POINTER_TYPE_P (TREE_TYPE (var))) - var = gfc_build_addr_expr (NULL, var); - depobj = save_expr (depobj); - tree r = build_fold_indirect_ref_loc (loc, depobj); - gfc_add_expr_to_block (&block, - build2 (MODIFY_EXPR, void_type_node, r, var)); - } - - /* Only one may be set. */ - gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy) - + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET)) - == 1); - int k = -1; /* omp_clauses->destroy */ - if (!code->ext.omp_clauses->destroy) - switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET - ? code->ext.omp_clauses->depobj_update : n->u.depend_op) - { - case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break; - case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break; - case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break; - case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break; - default: gcc_unreachable (); - } - tree t = build_int_cst (ptr_type_node, k); - depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj, - TYPE_SIZE_UNIT (ptr_type_node)); - depobj = build_fold_indirect_ref_loc (loc, depobj); - gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t)); - - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_error (gfc_code *code) -{ - stmtblock_t block; - gfc_se se; - tree len, message; - bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL; - tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR - : BUILT_IN_GOMP_WARNING); - gfc_start_block (&block); - gfc_init_se (&se, NULL ); - if (!code->ext.omp_clauses->message) - { - message = null_pointer_node; - len = build_int_cst (size_type_node, 0); - } - else - { - gfc_conv_expr (&se, code->ext.omp_clauses->message); - message = se.expr; - if (!POINTER_TYPE_P (TREE_TYPE (message))) - /* To ensure an ARRAY_TYPE is not passed as such. */ - message = gfc_build_addr_expr (NULL, message); - len = se.string_length; - } - gfc_add_block_to_block (&block, &se.pre); - gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl, - 2, message, len)); - gfc_add_block_to_block (&block, &se.post); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_flush (gfc_code *code) -{ - tree call; - if (!code->ext.omp_clauses - || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET - || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST) - { - call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); - call = build_call_expr_loc (input_location, call, 0); - } - else - { - enum memmodel mo = MEMMODEL_LAST; - switch (code->ext.omp_clauses->memorder) - { - case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break; - case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break; - case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break; - default: gcc_unreachable (); break; - } - call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE); - call = build_call_expr_loc (input_location, call, 1, - build_int_cst (integer_type_node, mo)); - } - return call; -} - -static tree -gfc_trans_omp_master (gfc_code *code) -{ - tree stmt = gfc_trans_code (code->block->next); - if (IS_EMPTY_STMT (stmt)) - return stmt; - return build1_v (OMP_MASTER, stmt); -} - -static tree -gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses) -{ - stmtblock_t block; - tree body = gfc_trans_code (code->block->next); - if (IS_EMPTY_STMT (body)) - return body; - if (!clauses) - clauses = code->ext.omp_clauses; - gfc_start_block (&block); - tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); - tree stmt = make_node (OMP_MASKED); - TREE_TYPE (stmt) = void_type_node; - OMP_MASKED_BODY (stmt) = body; - OMP_MASKED_CLAUSES (stmt) = omp_clauses; - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - - -static tree -gfc_trans_omp_ordered (gfc_code *code) -{ - if (!flag_openmp) - { - if (!code->ext.omp_clauses->simd) - return gfc_trans_code (code->block ? code->block->next : NULL); - code->ext.omp_clauses->threads = 0; - } - tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses, - code->loc); - return build2_loc (input_location, OMP_ORDERED, void_type_node, - code->block ? gfc_trans_code (code->block->next) - : NULL_TREE, omp_clauses); -} - -static tree -gfc_trans_omp_parallel (gfc_code *code) -{ - stmtblock_t block; - tree stmt, omp_clauses; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - pushlevel (); - stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, - omp_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -enum -{ - GFC_OMP_SPLIT_SIMD, - GFC_OMP_SPLIT_DO, - GFC_OMP_SPLIT_PARALLEL, - GFC_OMP_SPLIT_DISTRIBUTE, - GFC_OMP_SPLIT_TEAMS, - GFC_OMP_SPLIT_TARGET, - GFC_OMP_SPLIT_TASKLOOP, - GFC_OMP_SPLIT_MASKED, - GFC_OMP_SPLIT_NUM -}; - -enum -{ - GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD), - GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO), - GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL), - GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE), - GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS), - GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET), - GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP), - GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED) -}; - -/* If a var is in lastprivate/firstprivate/reduction but not in a - data mapping/sharing clause, add it to 'map(tofrom:' if is_target - and to 'shared' otherwise. */ -static void -gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out, - gfc_omp_clauses *clauses_in, - bool is_target, bool is_parallel_do) -{ - int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED; - gfc_omp_namelist *tail = NULL; - for (int i = 0; i < 5; ++i) - { - gfc_omp_namelist *n; - switch (i) - { - case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break; - case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break; - case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break; - case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break; - case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break; - default: gcc_unreachable (); - } - for (; n != NULL; n = n->next) - { - gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL; - for (int j = 0; j < 6; ++j) - { - gfc_omp_namelist **n2ref = NULL, *prev2 = NULL; - switch (j) - { - case 0: - n2ref = &clauses_out->lists[clauselist_to_add]; - break; - case 1: - n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE]; - break; - case 2: - if (is_target) - n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE]; - else - n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE]; - break; - case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break; - case 4: - n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN]; - break; - case 5: - n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK]; - break; - default: gcc_unreachable (); - } - for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next) - if (n2->sym == n->sym) - break; - if (n2) - { - if (j == 0 /* clauselist_to_add */) - break; /* Already present. */ - if (j == 1 /* OMP_LIST_FIRSTPRIVATE */) - { - n_firstp = prev2 ? &prev2->next : n2ref; - continue; - } - if (j == 2 /* OMP_LIST_LASTPRIVATE */) - { - n_lastp = prev2 ? &prev2->next : n2ref; - continue; - } - break; - } - } - if (n_firstp && n_lastp) - { - /* For parallel do, GCC puts firstprivatee/lastprivate - on the parallel. */ - if (is_parallel_do) - continue; - *n_firstp = (*n_firstp)->next; - if (!is_target) - *n_lastp = (*n_lastp)->next; - } - else if (is_target && n_lastp) - ; - else if (n2 || n_firstp || n_lastp) - continue; - if (clauses_out->lists[clauselist_to_add] - && (clauses_out->lists[clauselist_to_add] - == clauses_in->lists[clauselist_to_add])) - { - gfc_omp_namelist *p = NULL; - for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next) - { - if (p) - { - p->next = gfc_get_omp_namelist (); - p = p->next; - } - else - { - p = gfc_get_omp_namelist (); - clauses_out->lists[clauselist_to_add] = p; - } - *p = *n2; - } - } - if (!tail) - { - tail = clauses_out->lists[clauselist_to_add]; - for (; tail && tail->next; tail = tail->next) - ; - } - n2 = gfc_get_omp_namelist (); - n2->where = n->where; - n2->sym = n->sym; - if (is_target) - n2->u.map_op = OMP_MAP_TOFROM; - if (tail) - { - tail->next = n2; - tail = n2; - } - else - clauses_out->lists[clauselist_to_add] = n2; - } - } -} - -static void -gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa) -{ - for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i) - for (int j = 0; j < OMP_LIST_NUM; ++j) - if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j]) - for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;) - { - gfc_omp_namelist *p = n; - n = n->next; - free (p); - } -} - -static void -gfc_split_omp_clauses (gfc_code *code, - gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]) -{ - int mask = 0, innermost = 0; - bool is_loop = false; - memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses)); - switch (code->op) - { - case EXEC_OMP_DISTRIBUTE: - innermost = GFC_OMP_SPLIT_DISTRIBUTE; - break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; - innermost = GFC_OMP_SPLIT_DO; - break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL - | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_DISTRIBUTE_SIMD: - mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_DO: - case EXEC_OMP_LOOP: - innermost = GFC_OMP_SPLIT_DO; - break; - case EXEC_OMP_DO_SIMD: - mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_PARALLEL: - innermost = GFC_OMP_SPLIT_PARALLEL; - break; - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_LOOP: - mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; - innermost = GFC_OMP_SPLIT_DO; - break; - case EXEC_OMP_PARALLEL_DO_SIMD: - mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_PARALLEL_MASKED: - mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED; - innermost = GFC_OMP_SPLIT_MASKED; - break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED - | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); - innermost = GFC_OMP_SPLIT_TASKLOOP; - break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_TASKLOOP; - break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED - | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_SIMD: - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TARGET: - innermost = GFC_OMP_SPLIT_TARGET; - break; - case EXEC_OMP_TARGET_PARALLEL: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL; - innermost = GFC_OMP_SPLIT_PARALLEL; - break; - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; - innermost = GFC_OMP_SPLIT_DO; - break; - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO - | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TARGET_SIMD: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TARGET_TEAMS: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS; - innermost = GFC_OMP_SPLIT_TEAMS; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS - | GFC_OMP_MASK_DISTRIBUTE; - innermost = GFC_OMP_SPLIT_DISTRIBUTE; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE - | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; - innermost = GFC_OMP_SPLIT_DO; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE - | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS - | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TARGET_TEAMS_LOOP: - mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; - innermost = GFC_OMP_SPLIT_DO; - break; - case EXEC_OMP_MASKED_TASKLOOP: - mask = GFC_OMP_SPLIT_MASKED | GFC_OMP_SPLIT_TASKLOOP; - innermost = GFC_OMP_SPLIT_TASKLOOP; - break; - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_TASKLOOP: - innermost = GFC_OMP_SPLIT_TASKLOOP; - break; - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_TASKLOOP_SIMD: - mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TEAMS: - innermost = GFC_OMP_SPLIT_TEAMS; - break; - case EXEC_OMP_TEAMS_DISTRIBUTE: - mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE; - innermost = GFC_OMP_SPLIT_DISTRIBUTE; - break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE - | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; - innermost = GFC_OMP_SPLIT_DO; - break; - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE - | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; - innermost = GFC_OMP_SPLIT_SIMD; - break; - case EXEC_OMP_TEAMS_LOOP: - mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; - innermost = GFC_OMP_SPLIT_DO; - break; - default: - gcc_unreachable (); - } - if (mask == 0) - { - clausesa[innermost] = *code->ext.omp_clauses; - return; - } - /* Loops are similar to DO but still a bit different. */ - switch (code->op) - { - case EXEC_OMP_LOOP: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_TEAMS_LOOP: - is_loop = true; - default: - break; - } - if (code->ext.omp_clauses != NULL) - { - if (mask & GFC_OMP_MASK_TARGET) - { - /* First the clauses that are unique to some constructs. */ - clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP] - = code->ext.omp_clauses->lists[OMP_LIST_MAP]; - clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR] - = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR]; - clausesa[GFC_OMP_SPLIT_TARGET].device - = code->ext.omp_clauses->device; - clausesa[GFC_OMP_SPLIT_TARGET].thread_limit - = code->ext.omp_clauses->thread_limit; - for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) - clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i] - = code->ext.omp_clauses->defaultmap[i]; - clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET] - = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET]; - /* And this is copied to all. */ - clausesa[GFC_OMP_SPLIT_TARGET].if_expr - = code->ext.omp_clauses->if_expr; - clausesa[GFC_OMP_SPLIT_TARGET].nowait - = code->ext.omp_clauses->nowait; - } - if (mask & GFC_OMP_MASK_TEAMS) - { - /* First the clauses that are unique to some constructs. */ - clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower - = code->ext.omp_clauses->num_teams_lower; - clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper - = code->ext.omp_clauses->num_teams_upper; - clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit - = code->ext.omp_clauses->thread_limit; - /* Shared and default clauses are allowed on parallel, teams - and taskloop. */ - clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED] - = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; - clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing - = code->ext.omp_clauses->default_sharing; - } - if (mask & GFC_OMP_MASK_DISTRIBUTE) - { - /* First the clauses that are unique to some constructs. */ - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind - = code->ext.omp_clauses->dist_sched_kind; - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size - = code->ext.omp_clauses->dist_chunk_size; - /* Duplicate collapse. */ - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse - = code->ext.omp_clauses->collapse; - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent - = code->ext.omp_clauses->order_concurrent; - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained - = code->ext.omp_clauses->order_unconstrained; - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible - = code->ext.omp_clauses->order_reproducible; - } - if (mask & GFC_OMP_MASK_PARALLEL) - { - /* First the clauses that are unique to some constructs. */ - clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN] - = code->ext.omp_clauses->lists[OMP_LIST_COPYIN]; - clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads - = code->ext.omp_clauses->num_threads; - clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind - = code->ext.omp_clauses->proc_bind; - /* Shared and default clauses are allowed on parallel, teams - and taskloop. */ - clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED] - = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; - clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing - = code->ext.omp_clauses->default_sharing; - clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL] - = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL]; - /* And this is copied to all. */ - clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr - = code->ext.omp_clauses->if_expr; - } - if (mask & GFC_OMP_MASK_MASKED) - clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter; - if ((mask & GFC_OMP_MASK_DO) && !is_loop) - { - /* First the clauses that are unique to some constructs. */ - clausesa[GFC_OMP_SPLIT_DO].ordered - = code->ext.omp_clauses->ordered; - clausesa[GFC_OMP_SPLIT_DO].orderedc - = code->ext.omp_clauses->orderedc; - clausesa[GFC_OMP_SPLIT_DO].sched_kind - = code->ext.omp_clauses->sched_kind; - if (innermost == GFC_OMP_SPLIT_SIMD) - clausesa[GFC_OMP_SPLIT_DO].sched_simd - = code->ext.omp_clauses->sched_simd; - clausesa[GFC_OMP_SPLIT_DO].sched_monotonic - = code->ext.omp_clauses->sched_monotonic; - clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic - = code->ext.omp_clauses->sched_nonmonotonic; - clausesa[GFC_OMP_SPLIT_DO].chunk_size - = code->ext.omp_clauses->chunk_size; - clausesa[GFC_OMP_SPLIT_DO].nowait - = code->ext.omp_clauses->nowait; - } - if (mask & GFC_OMP_MASK_DO) - { - clausesa[GFC_OMP_SPLIT_DO].bind - = code->ext.omp_clauses->bind; - /* Duplicate collapse. */ - clausesa[GFC_OMP_SPLIT_DO].collapse - = code->ext.omp_clauses->collapse; - clausesa[GFC_OMP_SPLIT_DO].order_concurrent - = code->ext.omp_clauses->order_concurrent; - clausesa[GFC_OMP_SPLIT_DO].order_unconstrained - = code->ext.omp_clauses->order_unconstrained; - clausesa[GFC_OMP_SPLIT_DO].order_reproducible - = code->ext.omp_clauses->order_reproducible; - } - if (mask & GFC_OMP_MASK_SIMD) - { - clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr - = code->ext.omp_clauses->safelen_expr; - clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr - = code->ext.omp_clauses->simdlen_expr; - clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED] - = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED]; - /* Duplicate collapse. */ - clausesa[GFC_OMP_SPLIT_SIMD].collapse - = code->ext.omp_clauses->collapse; - clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD] - = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD]; - clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent - = code->ext.omp_clauses->order_concurrent; - clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained - = code->ext.omp_clauses->order_unconstrained; - clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible - = code->ext.omp_clauses->order_reproducible; - /* And this is copied to all. */ - clausesa[GFC_OMP_SPLIT_SIMD].if_expr - = code->ext.omp_clauses->if_expr; - } - if (mask & GFC_OMP_MASK_TASKLOOP) - { - /* First the clauses that are unique to some constructs. */ - clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup - = code->ext.omp_clauses->nogroup; - clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize - = code->ext.omp_clauses->grainsize; - clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict - = code->ext.omp_clauses->grainsize_strict; - clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks - = code->ext.omp_clauses->num_tasks; - clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict - = code->ext.omp_clauses->num_tasks_strict; - clausesa[GFC_OMP_SPLIT_TASKLOOP].priority - = code->ext.omp_clauses->priority; - clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr - = code->ext.omp_clauses->final_expr; - clausesa[GFC_OMP_SPLIT_TASKLOOP].untied - = code->ext.omp_clauses->untied; - clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable - = code->ext.omp_clauses->mergeable; - clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP] - = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP]; - /* And this is copied to all. */ - clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr - = code->ext.omp_clauses->if_expr; - /* Shared and default clauses are allowed on parallel, teams - and taskloop. */ - clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED] - = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; - clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing - = code->ext.omp_clauses->default_sharing; - /* Duplicate collapse. */ - clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse - = code->ext.omp_clauses->collapse; - } - /* Private clause is supported on all constructs but master/masked, - it is enough to put it on the innermost one except for master/masked. For - !$ omp parallel do put it on parallel though, - as that's what we did for OpenMP 3.1. */ - clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop) - || code->op == EXEC_OMP_PARALLEL_MASTER - || code->op == EXEC_OMP_PARALLEL_MASKED) - ? (int) GFC_OMP_SPLIT_PARALLEL - : innermost].lists[OMP_LIST_PRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE]; - /* Firstprivate clause is supported on all constructs but - simd and masked/master. Put it on the outermost of those and duplicate - on parallel and teams. */ - if (mask & GFC_OMP_MASK_TARGET) - clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_FIRSTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - if (mask & GFC_OMP_MASK_TEAMS) - clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - else if (mask & GFC_OMP_MASK_DISTRIBUTE) - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - if (mask & GFC_OMP_MASK_TASKLOOP) - clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - if ((mask & GFC_OMP_MASK_PARALLEL) - && !(mask & GFC_OMP_MASK_TASKLOOP)) - clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - else if ((mask & GFC_OMP_MASK_DO) && !is_loop) - clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; - /* Lastprivate is allowed on distribute, do, simd, taskloop and loop. - In parallel do{, simd} we actually want to put it on - parallel rather than do. */ - if (mask & GFC_OMP_MASK_DISTRIBUTE) - clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; - if (mask & GFC_OMP_MASK_TASKLOOP) - clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; - if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop - && !(mask & GFC_OMP_MASK_TASKLOOP)) - clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; - else if (mask & GFC_OMP_MASK_DO) - clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; - if (mask & GFC_OMP_MASK_SIMD) - clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE] - = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; - /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop. - Duplicate it on all of them, but - - omit on do if parallel is present; - - omit on task and parallel if loop is present; - additionally, inscan applies to do/simd only. */ - for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++) - { - if (mask & GFC_OMP_MASK_TASKLOOP - && i != OMP_LIST_REDUCTION_INSCAN) - clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i] - = code->ext.omp_clauses->lists[i]; - if (mask & GFC_OMP_MASK_TEAMS - && i != OMP_LIST_REDUCTION_INSCAN - && !is_loop) - clausesa[GFC_OMP_SPLIT_TEAMS].lists[i] - = code->ext.omp_clauses->lists[i]; - if (mask & GFC_OMP_MASK_PARALLEL - && i != OMP_LIST_REDUCTION_INSCAN - && !(mask & GFC_OMP_MASK_TASKLOOP) - && !is_loop) - clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i] - = code->ext.omp_clauses->lists[i]; - else if (mask & GFC_OMP_MASK_DO) - clausesa[GFC_OMP_SPLIT_DO].lists[i] - = code->ext.omp_clauses->lists[i]; - if (mask & GFC_OMP_MASK_SIMD) - clausesa[GFC_OMP_SPLIT_SIMD].lists[i] - = code->ext.omp_clauses->lists[i]; - } - if (mask & GFC_OMP_MASK_TARGET) - clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION] - = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION]; - if (mask & GFC_OMP_MASK_TASKLOOP) - clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION] - = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION]; - /* Linear clause is supported on do and simd, - put it on the innermost one. */ - clausesa[innermost].lists[OMP_LIST_LINEAR] - = code->ext.omp_clauses->lists[OMP_LIST_LINEAR]; - } - /* Propagate firstprivate/lastprivate/reduction vars to - shared (parallel, teams) and map-tofrom (target). */ - if (mask & GFC_OMP_MASK_TARGET) - gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET], - code->ext.omp_clauses, true, false); - if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL) - gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL], - code->ext.omp_clauses, false, - mask & GFC_OMP_MASK_DO); - if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS) - gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS], - code->ext.omp_clauses, false, false); - if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) - == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) - && !is_loop) - clausesa[GFC_OMP_SPLIT_DO].nowait = true; - - /* Distribute allocate clause to do, parallel, distribute, teams, target - and taskloop. The code below itereates over variables in the - allocate list and checks if that available is also in any - privatization clause on those construct. If yes, then we add it - to the list of 'allocate'ed variables for that construct. If a - variable is found in none of them then we issue an error. */ - - if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]) - { - gfc_omp_namelist *alloc_nl, *priv_nl; - gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM]; - for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; - alloc_nl; alloc_nl = alloc_nl->next) - { - bool found = false; - for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++) - { - gfc_omp_namelist *p; - int list; - for (list = 0; list < OMP_LIST_NUM; list++) - { - switch (list) - { - case OMP_LIST_PRIVATE: - case OMP_LIST_FIRSTPRIVATE: - case OMP_LIST_LASTPRIVATE: - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: - case OMP_LIST_IN_REDUCTION: - case OMP_LIST_TASK_REDUCTION: - case OMP_LIST_LINEAR: - for (priv_nl = clausesa[i].lists[list]; priv_nl; - priv_nl = priv_nl->next) - if (alloc_nl->sym == priv_nl->sym) - { - found = true; - p = gfc_get_omp_namelist (); - p->sym = alloc_nl->sym; - p->expr = alloc_nl->expr; - p->where = alloc_nl->where; - if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL) - { - clausesa[i].lists[OMP_LIST_ALLOCATE] = p; - tails[i] = p; - } - else - { - tails[i]->next = p; - tails[i] = tails[i]->next; - } - } - break; - default: - break; - } - } - } - if (!found) - gfc_error ("%qs specified in 'allocate' clause at %L but not " - "in an explicit privatization clause", - alloc_nl->sym->name, &alloc_nl->where); - } - } -} - -static tree -gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, - gfc_omp_clauses *clausesa, tree omp_clauses) -{ - stmtblock_t block; - gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; - tree stmt, body, omp_do_clauses = NULL_TREE; - bool free_clausesa = false; - - if (pblock == NULL) - gfc_start_block (&block); - else - gfc_init_block (&block); - - if (clausesa == NULL) - { - clausesa = clausesa_buf; - gfc_split_omp_clauses (code, clausesa); - free_clausesa = true; - } - if (flag_openmp) - omp_do_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc); - body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block, - &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses); - if (pblock == NULL) - { - if (TREE_CODE (body) != BIND_EXPR) - body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0)); - else - poplevel (0, 0); - } - else if (TREE_CODE (body) != BIND_EXPR) - body = build3_v (BIND_EXPR, NULL, body, NULL_TREE); - if (flag_openmp) - { - stmt = make_node (OMP_FOR); - TREE_TYPE (stmt) = void_type_node; - OMP_FOR_BODY (stmt) = body; - OMP_FOR_CLAUSES (stmt) = omp_do_clauses; - } - else - stmt = body; - gfc_add_expr_to_block (&block, stmt); - if (free_clausesa) - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock, - gfc_omp_clauses *clausesa) -{ - stmtblock_t block, *new_pblock = pblock; - gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; - tree stmt, omp_clauses = NULL_TREE; - bool free_clausesa = false; - - if (pblock == NULL) - gfc_start_block (&block); - else - gfc_init_block (&block); - - if (clausesa == NULL) - { - clausesa = clausesa_buf; - gfc_split_omp_clauses (code, clausesa); - free_clausesa = true; - } - omp_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], - code->loc); - if (pblock == NULL) - { - if (!clausesa[GFC_OMP_SPLIT_DO].ordered - && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC) - new_pblock = █ - else - pushlevel (); - } - stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO, - new_pblock, &clausesa[GFC_OMP_SPLIT_DO], - omp_clauses); - if (pblock == NULL) - { - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - } - else if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, - void_type_node, stmt, omp_clauses); - OMP_PARALLEL_COMBINED (stmt) = 1; - gfc_add_expr_to_block (&block, stmt); - if (free_clausesa) - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, - gfc_omp_clauses *clausesa) -{ - stmtblock_t block; - gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; - tree stmt, omp_clauses = NULL_TREE; - bool free_clausesa = false; - - if (pblock == NULL) - gfc_start_block (&block); - else - gfc_init_block (&block); - - if (clausesa == NULL) - { - clausesa = clausesa_buf; - gfc_split_omp_clauses (code, clausesa); - free_clausesa = true; - } - if (flag_openmp) - omp_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], - code->loc); - if (pblock == NULL) - pushlevel (); - stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses); - if (pblock == NULL) - { - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - } - else if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); - if (flag_openmp) - { - stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, - void_type_node, stmt, omp_clauses); - OMP_PARALLEL_COMBINED (stmt) = 1; - } - gfc_add_expr_to_block (&block, stmt); - if (free_clausesa) - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_parallel_sections (gfc_code *code) -{ - stmtblock_t block; - gfc_omp_clauses section_clauses; - tree stmt, omp_clauses; - - memset (§ion_clauses, 0, sizeof (section_clauses)); - section_clauses.nowait = true; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - pushlevel (); - stmt = gfc_trans_omp_sections (code, §ion_clauses); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, - void_type_node, stmt, omp_clauses); - OMP_PARALLEL_COMBINED (stmt) = 1; - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_parallel_workshare (gfc_code *code) -{ - stmtblock_t block; - gfc_omp_clauses workshare_clauses; - tree stmt, omp_clauses; - - memset (&workshare_clauses, 0, sizeof (workshare_clauses)); - workshare_clauses.nowait = true; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - pushlevel (); - stmt = gfc_trans_omp_workshare (code, &workshare_clauses); - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, - void_type_node, stmt, omp_clauses); - OMP_PARALLEL_COMBINED (stmt) = 1; - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_scope (gfc_code *code) -{ - stmtblock_t block; - tree body = gfc_trans_code (code->block->next); - if (IS_EMPTY_STMT (body)) - return body; - gfc_start_block (&block); - tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - tree stmt = make_node (OMP_SCOPE); - TREE_TYPE (stmt) = void_type_node; - OMP_SCOPE_BODY (stmt) = body; - OMP_SCOPE_CLAUSES (stmt) = omp_clauses; - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) -{ - stmtblock_t block, body; - tree omp_clauses, stmt; - bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL; - location_t loc = gfc_get_location (&code->loc); - - gfc_start_block (&block); - - omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); - - gfc_init_block (&body); - for (code = code->block; code; code = code->block) - { - /* Last section is special because of lastprivate, so even if it - is empty, chain it in. */ - stmt = gfc_trans_omp_code (code->next, - has_lastprivate && code->block == NULL); - if (! IS_EMPTY_STMT (stmt)) - { - stmt = build1_v (OMP_SECTION, stmt); - gfc_add_expr_to_block (&body, stmt); - } - } - stmt = gfc_finish_block (&body); - - stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses); - gfc_add_expr_to_block (&block, stmt); - - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) -{ - tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc); - tree stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node, - stmt, omp_clauses); - return stmt; -} - -static tree -gfc_trans_omp_task (gfc_code *code) -{ - stmtblock_t block; - tree stmt, omp_clauses; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - pushlevel (); - stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node, - stmt, omp_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_taskgroup (gfc_code *code) -{ - stmtblock_t block; - gfc_start_block (&block); - tree body = gfc_trans_code (code->block->next); - tree stmt = make_node (OMP_TASKGROUP); - TREE_TYPE (stmt) = void_type_node; - OMP_TASKGROUP_BODY (stmt) = body; - OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, - code->ext.omp_clauses, - code->loc); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_taskwait (gfc_code *code) -{ - if (!code->ext.omp_clauses) - { - tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); - return build_call_expr_loc (input_location, decl, 0); - } - stmtblock_t block; - gfc_start_block (&block); - tree stmt = make_node (OMP_TASK); - TREE_TYPE (stmt) = void_type_node; - OMP_TASK_BODY (stmt) = NULL_TREE; - OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, - code->ext.omp_clauses, - code->loc); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_taskyield (void) -{ - tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD); - return build_call_expr_loc (input_location, decl, 0); -} - -static tree -gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) -{ - stmtblock_t block; - gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; - tree stmt, omp_clauses = NULL_TREE; - bool free_clausesa = false; - - gfc_start_block (&block); - if (clausesa == NULL) - { - clausesa = clausesa_buf; - gfc_split_omp_clauses (code, clausesa); - free_clausesa = true; - } - if (flag_openmp) - omp_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], - code->loc); - switch (code->op) - { - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE: - /* This is handled in gfc_trans_omp_do. */ - gcc_unreachable (); - break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, - &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - default: - gcc_unreachable (); - } - if (flag_openmp) - { - tree distribute = make_node (OMP_DISTRIBUTE); - TREE_TYPE (distribute) = void_type_node; - OMP_FOR_BODY (distribute) = stmt; - OMP_FOR_CLAUSES (distribute) = omp_clauses; - stmt = distribute; - } - gfc_add_expr_to_block (&block, stmt); - if (free_clausesa) - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, - tree omp_clauses) -{ - stmtblock_t block; - gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; - tree stmt; - bool combined = true, free_clausesa = false; - - gfc_start_block (&block); - if (clausesa == NULL) - { - clausesa = clausesa_buf; - gfc_split_omp_clauses (code, clausesa); - free_clausesa = true; - } - if (flag_openmp) - { - omp_clauses - = chainon (omp_clauses, - gfc_trans_omp_clauses (&block, - &clausesa[GFC_OMP_SPLIT_TEAMS], - code->loc)); - pushlevel (); - } - switch (code->op) - { - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TEAMS: - stmt = gfc_trans_omp_code (code->block->next, true); - combined = false; - break; - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE: - stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL, - &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], - NULL); - break; - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TEAMS_LOOP: - stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL, - &clausesa[GFC_OMP_SPLIT_DO], - NULL); - break; - default: - stmt = gfc_trans_omp_distribute (code, clausesa); - break; - } - if (flag_openmp) - { - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS, - void_type_node, stmt, omp_clauses); - if (combined) - OMP_TEAMS_COMBINED (stmt) = 1; - } - gfc_add_expr_to_block (&block, stmt); - if (free_clausesa) - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_target (gfc_code *code) -{ - stmtblock_t block; - gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; - tree stmt, omp_clauses = NULL_TREE; - - gfc_start_block (&block); - gfc_split_omp_clauses (code, clausesa); - if (flag_openmp) - omp_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET], - code->loc); - switch (code->op) - { - case EXEC_OMP_TARGET: - pushlevel (); - stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - break; - case EXEC_OMP_TARGET_PARALLEL: - { - stmtblock_t iblock; - - pushlevel (); - gfc_start_block (&iblock); - tree inner_clauses - = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL], - code->loc); - stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, - inner_clauses); - gfc_add_expr_to_block (&iblock, stmt); - stmt = gfc_finish_block (&iblock); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - } - break; - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - stmt = gfc_trans_omp_parallel_do (code, - (code->op - == EXEC_OMP_TARGET_PARALLEL_LOOP), - &block, clausesa); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - case EXEC_OMP_TARGET_SIMD: - stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, - &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - default: - if (flag_openmp - && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper - || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit)) - { - gfc_omp_clauses clausesb; - tree teams_clauses; - /* For combined !$omp target teams, the num_teams and - thread_limit clauses are evaluated before entering the - target construct. */ - memset (&clausesb, '\0', sizeof (clausesb)); - clausesb.num_teams_lower - = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower; - clausesb.num_teams_upper - = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper; - clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit; - clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL; - clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL; - clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL; - teams_clauses - = gfc_trans_omp_clauses (&block, &clausesb, code->loc); - pushlevel (); - stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses); - } - else - { - pushlevel (); - stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE); - } - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - } - if (flag_openmp) - { - stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET, - void_type_node, stmt, omp_clauses); - if (code->op != EXEC_OMP_TARGET) - OMP_TARGET_COMBINED (stmt) = 1; - cfun->has_omp_target = true; - } - gfc_add_expr_to_block (&block, stmt); - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op) -{ - stmtblock_t block; - gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; - tree stmt, omp_clauses = NULL_TREE; - - gfc_start_block (&block); - gfc_split_omp_clauses (code, clausesa); - if (flag_openmp) - omp_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP], - code->loc); - switch (op) - { - case EXEC_OMP_TASKLOOP: - /* This is handled in gfc_trans_omp_do. */ - gcc_unreachable (); - break; - case EXEC_OMP_TASKLOOP_SIMD: - stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, - &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - break; - default: - gcc_unreachable (); - } - if (flag_openmp) - { - tree taskloop = make_node (OMP_TASKLOOP); - TREE_TYPE (taskloop) = void_type_node; - OMP_FOR_BODY (taskloop) = stmt; - OMP_FOR_CLAUSES (taskloop) = omp_clauses; - stmt = taskloop; - } - gfc_add_expr_to_block (&block, stmt); - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op) -{ - gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; - stmtblock_t block; - tree stmt; - - if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD - && code->op != EXEC_OMP_MASTER_TASKLOOP) - gfc_split_omp_clauses (code, clausesa); - - pushlevel (); - if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD - || op == EXEC_OMP_MASTER_TASKLOOP_SIMD) - stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD); - else - { - gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP - || op == EXEC_OMP_MASTER_TASKLOOP); - stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL, - code->op != EXEC_OMP_MASTER_TASKLOOP - ? &clausesa[GFC_OMP_SPLIT_TASKLOOP] - : code->ext.omp_clauses, NULL); - } - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - gfc_start_block (&block); - if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD) - { - tree clauses = gfc_trans_omp_clauses (&block, - &clausesa[GFC_OMP_SPLIT_MASKED], - code->loc); - tree msk = make_node (OMP_MASKED); - TREE_TYPE (msk) = void_type_node; - OMP_MASKED_BODY (msk) = stmt; - OMP_MASKED_CLAUSES (msk) = clauses; - OMP_MASKED_COMBINED (msk) = 1; - gfc_add_expr_to_block (&block, msk); - } - else - { - gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP - || op == EXEC_OMP_MASTER_TASKLOOP_SIMD); - stmt = build1_v (OMP_MASTER, stmt); - gfc_add_expr_to_block (&block, stmt); - } - if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD - && code->op != EXEC_OMP_MASTER_TASKLOOP) - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_parallel_master_masked (gfc_code *code) -{ - stmtblock_t block; - tree stmt, omp_clauses; - gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; - bool parallel_combined = false; - - if (code->op != EXEC_OMP_PARALLEL_MASTER) - gfc_split_omp_clauses (code, clausesa); - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, - code->op == EXEC_OMP_PARALLEL_MASTER - ? code->ext.omp_clauses - : &clausesa[GFC_OMP_SPLIT_PARALLEL], - code->loc); - pushlevel (); - if (code->op == EXEC_OMP_PARALLEL_MASTER) - stmt = gfc_trans_omp_master (code); - else if (code->op == EXEC_OMP_PARALLEL_MASKED) - stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]); - else - { - gfc_exec_op op; - switch (code->op) - { - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - op = EXEC_OMP_MASKED_TASKLOOP; - break; - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - op = EXEC_OMP_MASKED_TASKLOOP_SIMD; - break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - op = EXEC_OMP_MASTER_TASKLOOP; - break; - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - op = EXEC_OMP_MASTER_TASKLOOP_SIMD; - break; - default: - gcc_unreachable (); - } - stmt = gfc_trans_omp_master_masked_taskloop (code, op); - parallel_combined = true; - } - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); - else - poplevel (0, 0); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, - void_type_node, stmt, omp_clauses); - /* masked does have just filter clause, but during gimplification - isn't represented by a gimplification omp context, so for - !$omp parallel masked don't set OMP_PARALLEL_COMBINED, - so that - !$omp parallel masked - !$omp taskloop simd lastprivate (x) - isn't confused with - !$omp parallel masked taskloop simd lastprivate (x) */ - if (parallel_combined) - OMP_PARALLEL_COMBINED (stmt) = 1; - gfc_add_expr_to_block (&block, stmt); - if (code->op != EXEC_OMP_PARALLEL_MASTER) - gfc_free_split_omp_clauses (code, clausesa); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_target_data (gfc_code *code) -{ - stmtblock_t block; - tree stmt, omp_clauses; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA, - void_type_node, stmt, omp_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_target_enter_data (gfc_code *code) -{ - stmtblock_t block; - tree stmt, omp_clauses; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node, - omp_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_target_exit_data (gfc_code *code) -{ - stmtblock_t block; - tree stmt, omp_clauses; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node, - omp_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_target_update (gfc_code *code) -{ - stmtblock_t block; - tree stmt, omp_clauses; - - gfc_start_block (&block); - omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); - stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node, - omp_clauses); - gfc_add_expr_to_block (&block, stmt); - return gfc_finish_block (&block); -} - -static tree -gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) -{ - tree res, tmp, stmt; - stmtblock_t block, *pblock = NULL; - stmtblock_t singleblock; - int saved_ompws_flags; - bool singleblock_in_progress = false; - /* True if previous gfc_code in workshare construct is not workshared. */ - bool prev_singleunit; - location_t loc = gfc_get_location (&code->loc); - - code = code->block->next; - - pushlevel (); - - gfc_start_block (&block); - pblock = █ - - ompws_flags = OMPWS_WORKSHARE_FLAG; - prev_singleunit = false; - - /* Translate statements one by one to trees until we reach - the end of the workshare construct. Adjacent gfc_codes that - are a single unit of work are clustered and encapsulated in a - single OMP_SINGLE construct. */ - for (; code; code = code->next) - { - if (code->here != 0) - { - res = gfc_trans_label_here (code); - gfc_add_expr_to_block (pblock, res); - } - - /* No dependence analysis, use for clauses with wait. - If this is the last gfc_code, use default omp_clauses. */ - if (code->next == NULL && clauses->nowait) - ompws_flags |= OMPWS_NOWAIT; - - /* By default, every gfc_code is a single unit of work. */ - ompws_flags |= OMPWS_CURR_SINGLEUNIT; - ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY); - - switch (code->op) - { - case EXEC_NOP: - res = NULL_TREE; - break; - - case EXEC_ASSIGN: - res = gfc_trans_assign (code); - break; - - case EXEC_POINTER_ASSIGN: - res = gfc_trans_pointer_assign (code); - break; - - case EXEC_INIT_ASSIGN: - res = gfc_trans_init_assign (code); - break; - - case EXEC_FORALL: - res = gfc_trans_forall (code); - break; - - case EXEC_WHERE: - res = gfc_trans_where (code); - break; - - case EXEC_OMP_ATOMIC: - res = gfc_trans_omp_directive (code); - break; - - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_CRITICAL: - saved_ompws_flags = ompws_flags; - ompws_flags = 0; - res = gfc_trans_omp_directive (code); - ompws_flags = saved_ompws_flags; - break; - - case EXEC_BLOCK: - res = gfc_trans_block_construct (code); - break; - - default: - gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code"); - } - - gfc_set_backend_locus (&code->loc); - - if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) - { - if (prev_singleunit) - { - if (ompws_flags & OMPWS_CURR_SINGLEUNIT) - /* Add current gfc_code to single block. */ - gfc_add_expr_to_block (&singleblock, res); - else - { - /* Finish single block and add it to pblock. */ - tmp = gfc_finish_block (&singleblock); - tmp = build2_loc (loc, OMP_SINGLE, - void_type_node, tmp, NULL_TREE); - gfc_add_expr_to_block (pblock, tmp); - /* Add current gfc_code to pblock. */ - gfc_add_expr_to_block (pblock, res); - singleblock_in_progress = false; - } - } - else - { - if (ompws_flags & OMPWS_CURR_SINGLEUNIT) - { - /* Start single block. */ - gfc_init_block (&singleblock); - gfc_add_expr_to_block (&singleblock, res); - singleblock_in_progress = true; - loc = gfc_get_location (&code->loc); - } - else - /* Add the new statement to the block. */ - gfc_add_expr_to_block (pblock, res); - } - prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0; - } - } - - /* Finish remaining SINGLE block, if we were in the middle of one. */ - if (singleblock_in_progress) - { - /* Finish single block and add it to pblock. */ - tmp = gfc_finish_block (&singleblock); - tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp, - clauses->nowait - ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT) - : NULL_TREE); - gfc_add_expr_to_block (pblock, tmp); - } - - stmt = gfc_finish_block (pblock); - if (TREE_CODE (stmt) != BIND_EXPR) - { - if (!IS_EMPTY_STMT (stmt)) - { - tree bindblock = poplevel (1, 0); - stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock); - } - else - poplevel (0, 0); - } - else - poplevel (0, 0); - - if (IS_EMPTY_STMT (stmt) && !clauses->nowait) - stmt = gfc_trans_omp_barrier (); - - ompws_flags = 0; - return stmt; -} - -tree -gfc_trans_oacc_declare (gfc_code *code) -{ - stmtblock_t block; - tree stmt, oacc_clauses; - enum tree_code construct_code; - - construct_code = OACC_DATA; - - gfc_start_block (&block); - - oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses, - code->loc, false, true); - stmt = gfc_trans_omp_code (code->block->next, true); - stmt = build2_loc (input_location, construct_code, void_type_node, stmt, - oacc_clauses); - gfc_add_expr_to_block (&block, stmt); - - return gfc_finish_block (&block); -} - -tree -gfc_trans_oacc_directive (gfc_code *code) -{ - switch (code->op) - { - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_SERIAL_LOOP: - return gfc_trans_oacc_combined_directive (code); - case EXEC_OACC_PARALLEL: - case EXEC_OACC_KERNELS: - case EXEC_OACC_SERIAL: - case EXEC_OACC_DATA: - case EXEC_OACC_HOST_DATA: - return gfc_trans_oacc_construct (code); - case EXEC_OACC_LOOP: - return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, - NULL); - case EXEC_OACC_UPDATE: - case EXEC_OACC_CACHE: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - return gfc_trans_oacc_executable_directive (code); - case EXEC_OACC_WAIT: - return gfc_trans_oacc_wait_directive (code); - case EXEC_OACC_ATOMIC: - return gfc_trans_omp_atomic (code); - case EXEC_OACC_DECLARE: - return gfc_trans_oacc_declare (code); - default: - gcc_unreachable (); - } -} - -tree -gfc_trans_omp_directive (gfc_code *code) -{ - switch (code->op) - { - case EXEC_OMP_ATOMIC: - return gfc_trans_omp_atomic (code); - case EXEC_OMP_BARRIER: - return gfc_trans_omp_barrier (); - case EXEC_OMP_CANCEL: - return gfc_trans_omp_cancel (code); - case EXEC_OMP_CANCELLATION_POINT: - return gfc_trans_omp_cancellation_point (code); - case EXEC_OMP_CRITICAL: - return gfc_trans_omp_critical (code); - case EXEC_OMP_DEPOBJ: - return gfc_trans_omp_depobj (code); - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DO: - case EXEC_OMP_LOOP: - case EXEC_OMP_SIMD: - case EXEC_OMP_TASKLOOP: - return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, - NULL); - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - return gfc_trans_omp_distribute (code, NULL); - case EXEC_OMP_DO_SIMD: - return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE); - case EXEC_OMP_ERROR: - return gfc_trans_omp_error (code); - case EXEC_OMP_FLUSH: - return gfc_trans_omp_flush (code); - case EXEC_OMP_MASKED: - return gfc_trans_omp_masked (code, NULL); - case EXEC_OMP_MASTER: - return gfc_trans_omp_master (code); - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - return gfc_trans_omp_master_masked_taskloop (code, code->op); - case EXEC_OMP_ORDERED: - return gfc_trans_omp_ordered (code); - case EXEC_OMP_PARALLEL: - return gfc_trans_omp_parallel (code); - case EXEC_OMP_PARALLEL_DO: - return gfc_trans_omp_parallel_do (code, false, NULL, NULL); - case EXEC_OMP_PARALLEL_LOOP: - return gfc_trans_omp_parallel_do (code, true, NULL, NULL); - case EXEC_OMP_PARALLEL_DO_SIMD: - return gfc_trans_omp_parallel_do_simd (code, NULL, NULL); - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - return gfc_trans_omp_parallel_master_masked (code); - case EXEC_OMP_PARALLEL_SECTIONS: - return gfc_trans_omp_parallel_sections (code); - case EXEC_OMP_PARALLEL_WORKSHARE: - return gfc_trans_omp_parallel_workshare (code); - case EXEC_OMP_SCOPE: - return gfc_trans_omp_scope (code); - case EXEC_OMP_SECTIONS: - return gfc_trans_omp_sections (code, code->ext.omp_clauses); - case EXEC_OMP_SINGLE: - return gfc_trans_omp_single (code, code->ext.omp_clauses); - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - return gfc_trans_omp_target (code); - case EXEC_OMP_TARGET_DATA: - return gfc_trans_omp_target_data (code); - case EXEC_OMP_TARGET_ENTER_DATA: - return gfc_trans_omp_target_enter_data (code); - case EXEC_OMP_TARGET_EXIT_DATA: - return gfc_trans_omp_target_exit_data (code); - case EXEC_OMP_TARGET_UPDATE: - return gfc_trans_omp_target_update (code); - case EXEC_OMP_TASK: - return gfc_trans_omp_task (code); - case EXEC_OMP_TASKGROUP: - return gfc_trans_omp_taskgroup (code); - case EXEC_OMP_TASKLOOP_SIMD: - return gfc_trans_omp_taskloop (code, code->op); - case EXEC_OMP_TASKWAIT: - return gfc_trans_omp_taskwait (code); - case EXEC_OMP_TASKYIELD: - return gfc_trans_omp_taskyield (); - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - return gfc_trans_omp_teams (code, NULL, NULL_TREE); - case EXEC_OMP_WORKSHARE: - return gfc_trans_omp_workshare (code, code->ext.omp_clauses); - default: - gcc_unreachable (); - } -} - -void -gfc_trans_omp_declare_simd (gfc_namespace *ns) -{ - if (ns->entries) - return; - - gfc_omp_declare_simd *ods; - for (ods = ns->omp_declare_simd; ods; ods = ods->next) - { - tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true); - tree fndecl = ns->proc_name->backend_decl; - if (c != NULL_TREE) - c = tree_cons (NULL_TREE, c, NULL_TREE); - c = build_tree_list (get_identifier ("omp declare simd"), c); - TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl); - DECL_ATTRIBUTES (fndecl) = c; - } -} - -void -gfc_trans_omp_declare_variant (gfc_namespace *ns) -{ - tree base_fn_decl = ns->proc_name->backend_decl; - gfc_namespace *search_ns = ns; - gfc_omp_declare_variant *next; - - for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant; - search_ns; odv = next) - { - /* Look in the parent namespace if there are no more directives in the - current namespace. */ - if (!odv) - { - search_ns = search_ns->parent; - if (search_ns) - next = search_ns->omp_declare_variant; - continue; - } - - next = odv->next; - - if (odv->error_p) - continue; - - /* Check directive the first time it is encountered. */ - bool error_found = true; - - if (odv->checked_p) - error_found = false; - if (odv->base_proc_symtree == NULL) - { - if (!search_ns->proc_name->attr.function - && !search_ns->proc_name->attr.subroutine) - gfc_error ("The base name for 'declare variant' must be " - "specified at %L ", &odv->where); - else - error_found = false; - } - else - { - if (!search_ns->contained - && strcmp (odv->base_proc_symtree->name, - ns->proc_name->name)) - gfc_error ("The base name at %L does not match the name of the " - "current procedure", &odv->where); - else if (odv->base_proc_symtree->n.sym->attr.entry) - gfc_error ("The base name at %L must not be an entry name", - &odv->where); - else if (odv->base_proc_symtree->n.sym->attr.generic) - gfc_error ("The base name at %L must not be a generic name", - &odv->where); - else if (odv->base_proc_symtree->n.sym->attr.proc_pointer) - gfc_error ("The base name at %L must not be a procedure pointer", - &odv->where); - else if (odv->base_proc_symtree->n.sym->attr.implicit_type) - gfc_error ("The base procedure at %L must have an explicit " - "interface", &odv->where); - else - error_found = false; - } - - odv->checked_p = true; - if (error_found) - { - odv->error_p = true; - continue; - } - - /* Ignore directives that do not apply to the current procedure. */ - if ((odv->base_proc_symtree == NULL && search_ns != ns) - || (odv->base_proc_symtree != NULL - && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))) - continue; - - tree set_selectors = NULL_TREE; - gfc_omp_set_selector *oss; - - for (oss = odv->set_selectors; oss; oss = oss->next) - { - tree selectors = NULL_TREE; - gfc_omp_selector *os; - for (os = oss->trait_selectors; os; os = os->next) - { - tree properties = NULL_TREE; - gfc_omp_trait_property *otp; - - for (otp = os->properties; otp; otp = otp->next) - { - switch (otp->property_kind) - { - case CTX_PROPERTY_USER: - case CTX_PROPERTY_EXPR: - { - gfc_se se; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, otp->expr); - properties = tree_cons (NULL_TREE, se.expr, - properties); - } - break; - case CTX_PROPERTY_ID: - properties = tree_cons (get_identifier (otp->name), - NULL_TREE, properties); - break; - case CTX_PROPERTY_NAME_LIST: - { - tree prop = NULL_TREE, value = NULL_TREE; - if (otp->is_name) - prop = get_identifier (otp->name); - else - value = gfc_conv_constant_to_tree (otp->expr); - - properties = tree_cons (prop, value, properties); - } - break; - case CTX_PROPERTY_SIMD: - properties = gfc_trans_omp_clauses (NULL, otp->clauses, - odv->where, true); - break; - default: - gcc_unreachable (); - } - } - - if (os->score) - { - gfc_se se; - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, os->score); - properties = tree_cons (get_identifier (" score"), - se.expr, properties); - } - - selectors = tree_cons (get_identifier (os->trait_selector_name), - properties, selectors); - } - - set_selectors - = tree_cons (get_identifier (oss->trait_set_selector_name), - selectors, set_selectors); - } - - const char *variant_proc_name = odv->variant_proc_symtree->name; - gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym; - if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type) - { - gfc_symtree *proc_st; - gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st); - variant_proc_sym = proc_st->n.sym; - } - if (variant_proc_sym == NULL) - { - gfc_error ("Cannot find symbol %qs", variant_proc_name); - continue; - } - set_selectors = omp_check_context_selector - (gfc_get_location (&odv->where), set_selectors); - if (set_selectors != error_mark_node) - { - if (!variant_proc_sym->attr.implicit_type - && !variant_proc_sym->attr.subroutine - && !variant_proc_sym->attr.function) - { - gfc_error ("variant %qs at %L is not a function or subroutine", - variant_proc_name, &odv->where); - variant_proc_sym = NULL; - } - else if (omp_get_context_selector (set_selectors, "construct", - "simd") == NULL_TREE) - { - char err[256]; - if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym, - variant_proc_sym->name, 0, 1, - err, sizeof (err), NULL, NULL)) - { - gfc_error ("variant %qs and base %qs at %L have " - "incompatible types: %s", - variant_proc_name, ns->proc_name->name, - &odv->where, err); - variant_proc_sym = NULL; - } - } - if (variant_proc_sym != NULL) - { - gfc_set_sym_referenced (variant_proc_sym); - tree construct = omp_get_context_selector (set_selectors, - "construct", NULL); - omp_mark_declare_variant (gfc_get_location (&odv->where), - gfc_get_symbol_decl (variant_proc_sym), - construct); - if (omp_context_selector_matches (set_selectors)) - { - tree id = get_identifier ("omp declare variant base"); - tree variant = gfc_get_symbol_decl (variant_proc_sym); - DECL_ATTRIBUTES (base_fn_decl) - = tree_cons (id, build_tree_list (variant, set_selectors), - DECL_ATTRIBUTES (base_fn_decl)); - } - } - } - } -} diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc new file mode 100644 index 0000000..d363258 --- /dev/null +++ b/gcc/fortran/trans-openmp.cc @@ -0,0 +1,7701 @@ +/* OpenMP directive translation -- generate GCC trees from gfc_code. + Copyright (C) 2005-2022 Free Software Foundation, Inc. + Contributed by Jakub Jelinek + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "gimple-expr.h" +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "gimplify.h" /* For create_tmp_var_raw. */ +#include "trans-stmt.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +#include "arith.h" +#include "constructor.h" +#include "gomp-constants.h" +#include "omp-general.h" +#include "omp-low.h" +#include "memmodel.h" /* For MEMMODEL_ enums. */ + +#undef GCC_DIAG_STYLE +#define GCC_DIAG_STYLE __gcc_tdiag__ +#include "diagnostic-core.h" +#undef GCC_DIAG_STYLE +#define GCC_DIAG_STYLE __gcc_gfc__ +#include "attribs.h" +#include "function.h" + +int ompws_flags; + +/* True if OpenMP should regard this DECL as being a scalar which has Fortran's + allocatable or pointer attribute. */ + +bool +gfc_omp_is_allocatable_or_ptr (const_tree decl) +{ + return (DECL_P (decl) + && (GFC_DECL_GET_SCALAR_POINTER (decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))); +} + +/* True if the argument is an optional argument; except that false is also + returned for arguments with the value attribute (nonpointers) and for + assumed-shape variables (decl is a local variable containing arg->data). + Note that for 'procedure(), optional' the value false is used as that's + always a pointer and no additional indirection is used. + Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */ + +static bool +gfc_omp_is_optional_argument (const_tree decl) +{ + /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */ + return ((TREE_CODE (decl) == PARM_DECL || TREE_CODE (decl) == VAR_DECL) + && DECL_LANG_SPECIFIC (decl) + && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE + && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) + && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE + && GFC_DECL_OPTIONAL_ARGUMENT (decl)); +} + +/* Check whether this DECL belongs to a Fortran optional argument. + With 'for_present_check' set to false, decls which are optional parameters + themselve are returned as tree - or a NULL_TREE otherwise. Those decls are + always pointers. With 'for_present_check' set to true, the decl for checking + whether an argument is present is returned; for arguments with value + attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is + unrelated to optional arguments, NULL_TREE is returned. */ + +tree +gfc_omp_check_optional_argument (tree decl, bool for_present_check) +{ + if (!for_present_check) + return gfc_omp_is_optional_argument (decl) ? decl : NULL_TREE; + + if (!DECL_LANG_SPECIFIC (decl)) + return NULL_TREE; + + tree orig_decl = decl; + + /* For assumed-shape arrays, a local decl with arg->data is used. */ + if (TREE_CODE (decl) != PARM_DECL + && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) + || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + + /* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */ + if (decl == NULL_TREE + || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL) + || !DECL_LANG_SPECIFIC (decl) + || !GFC_DECL_OPTIONAL_ARGUMENT (decl)) + return NULL_TREE; + + /* Scalars with VALUE attribute which are passed by value use a hidden + argument to denote the present status. They are passed as nonpointer type + with one exception: 'type(c_ptr), value' as 'void*'. */ + /* Cf. trans-expr.c's gfc_conv_expr_present. */ + if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE + || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + { + char name[GFC_MAX_SYMBOL_LEN + 2]; + tree tree_name; + + name[0] = '_'; + strcpy (&name[1], IDENTIFIER_POINTER (DECL_NAME (decl))); + tree_name = get_identifier (name); + + /* Walk function argument list to find the hidden arg. */ + decl = DECL_ARGUMENTS (DECL_CONTEXT (decl)); + for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl)) + if (DECL_NAME (decl) == tree_name + && DECL_ARTIFICIAL (decl)) + break; + + gcc_assert (decl); + return decl; + } + + return fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + orig_decl, null_pointer_node); +} + + +/* Returns tree with NULL if it is not an array descriptor and with the tree to + access the 'data' component otherwise. With type_only = true, it returns the + TREE_TYPE without creating a new tree. */ + +tree +gfc_omp_array_data (tree decl, bool type_only) +{ + tree type = TREE_TYPE (decl); + + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + if (!GFC_DESCRIPTOR_TYPE_P (type)) + return NULL_TREE; + + if (type_only) + return GFC_TYPE_ARRAY_DATAPTR_TYPE (type); + + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref (decl); + + decl = gfc_conv_descriptor_data_get (decl); + STRIP_NOPS (decl); + return decl; +} + +/* True if OpenMP should privatize what this DECL points to rather + than the DECL itself. */ + +bool +gfc_omp_privatize_by_reference (const_tree decl) +{ + tree type = TREE_TYPE (decl); + + if (TREE_CODE (type) == REFERENCE_TYPE + && (!DECL_ARTIFICIAL (decl) || TREE_CODE (decl) == PARM_DECL)) + return true; + + if (TREE_CODE (type) == POINTER_TYPE + && gfc_omp_is_optional_argument (decl)) + return true; + + if (TREE_CODE (type) == POINTER_TYPE) + { + while (TREE_CODE (decl) == COMPONENT_REF) + decl = TREE_OPERAND (decl, 1); + + /* Array POINTER/ALLOCATABLE have aggregate types, all user variables + that have POINTER_TYPE type and aren't scalar pointers, scalar + allocatables, Cray pointees or C pointers are supposed to be + privatized by reference. */ + if (GFC_DECL_GET_SCALAR_POINTER (decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + || GFC_DECL_CRAY_POINTEE (decl) + || GFC_DECL_ASSOCIATE_VAR_P (decl) + || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + return false; + + if (!DECL_ARTIFICIAL (decl) + && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE) + return true; + + /* Some arrays are expanded as DECL_ARTIFICIAL pointers + by the frontend. */ + if (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + return true; + } + + return false; +} + +/* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute + of DECL is predetermined. */ + +enum omp_clause_default_kind +gfc_omp_predetermined_sharing (tree decl) +{ + /* Associate names preserve the association established during ASSOCIATE. + As they are implemented either as pointers to the selector or array + descriptor and shouldn't really change in the ASSOCIATE region, + this decl can be either shared or firstprivate. If it is a pointer, + use firstprivate, as it is cheaper that way, otherwise make it shared. */ + if (GFC_DECL_ASSOCIATE_VAR_P (decl)) + { + if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) + return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; + else + return OMP_CLAUSE_DEFAULT_SHARED; + } + + if (DECL_ARTIFICIAL (decl) + && ! GFC_DECL_RESULT (decl) + && ! (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl))) + return OMP_CLAUSE_DEFAULT_SHARED; + + /* Cray pointees shouldn't be listed in any clauses and should be + gimplified to dereference of the corresponding Cray pointer. + Make them all private, so that they are emitted in the debug + information. */ + if (GFC_DECL_CRAY_POINTEE (decl)) + return OMP_CLAUSE_DEFAULT_PRIVATE; + + /* Assumed-size arrays are predetermined shared. */ + if (TREE_CODE (decl) == PARM_DECL + && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) + && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN + && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), + GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) + == NULL) + return OMP_CLAUSE_DEFAULT_SHARED; + + /* Dummy procedures aren't considered variables by OpenMP, thus are + disallowed in OpenMP clauses. They are represented as PARM_DECLs + in the middle-end, so return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE here + to avoid complaining about their uses with default(none). */ + if (TREE_CODE (decl) == PARM_DECL + && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == FUNCTION_TYPE) + return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; + + /* COMMON and EQUIVALENCE decls are shared. They + are only referenced through DECL_VALUE_EXPR of the variables + contained in them. If those are privatized, they will not be + gimplified to the COMMON or EQUIVALENCE decls. */ + if (GFC_DECL_COMMON_OR_EQUIV (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) + return OMP_CLAUSE_DEFAULT_SHARED; + + if (GFC_DECL_RESULT (decl) && ! DECL_HAS_VALUE_EXPR_P (decl)) + return OMP_CLAUSE_DEFAULT_SHARED; + + /* These are either array or derived parameters, or vtables. + In the former cases, the OpenMP standard doesn't consider them to be + variables at all (they can't be redefined), but they can nevertheless appear + in parallel/task regions and for default(none) purposes treat them as shared. + For vtables likely the same handling is desirable. */ + if (VAR_P (decl) && TREE_READONLY (decl) + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + return OMP_CLAUSE_DEFAULT_SHARED; + + return OMP_CLAUSE_DEFAULT_UNSPECIFIED; +} + + +/* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute + of DECL is predetermined. */ + +enum omp_clause_defaultmap_kind +gfc_omp_predetermined_mapping (tree decl) +{ + if (DECL_ARTIFICIAL (decl) + && ! GFC_DECL_RESULT (decl) + && ! (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl))) + return OMP_CLAUSE_DEFAULTMAP_TO; + + /* These are either array or derived parameters, or vtables. */ + if (VAR_P (decl) && TREE_READONLY (decl) + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + return OMP_CLAUSE_DEFAULTMAP_TO; + + return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; +} + + +/* Return decl that should be used when reporting DEFAULT(NONE) + diagnostics. */ + +tree +gfc_omp_report_decl (tree decl) +{ + if (DECL_ARTIFICIAL (decl) + && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + return GFC_DECL_SAVED_DESCRIPTOR (decl); + + return decl; +} + +/* Return true if TYPE has any allocatable components. */ + +static bool +gfc_has_alloc_comps (tree type, tree decl) +{ + tree field, ftype; + + if (POINTER_TYPE_P (type)) + { + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + type = TREE_TYPE (type); + else if (GFC_DECL_GET_SCALAR_POINTER (decl)) + return false; + } + + if (GFC_DESCRIPTOR_TYPE_P (type) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) + return false; + + if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) + type = gfc_get_element_type (type); + + if (TREE_CODE (type) != RECORD_TYPE) + return false; + + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + { + ftype = TREE_TYPE (field); + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + return true; + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + return true; + if (gfc_has_alloc_comps (ftype, field)) + return true; + } + return false; +} + +/* Return true if TYPE is polymorphic but not with pointer attribute. */ + +static bool +gfc_is_polymorphic_nonptr (tree type) +{ + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + return GFC_CLASS_TYPE_P (type); +} + +/* Return true if TYPE is unlimited polymorphic but not with pointer attribute; + unlimited means also intrinsic types are handled and _len is used. */ + +static bool +gfc_is_unlimited_polymorphic_nonptr (tree type) +{ + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + if (!GFC_CLASS_TYPE_P (type)) + return false; + + tree field = TYPE_FIELDS (type); /* _data */ + gcc_assert (field); + field = DECL_CHAIN (field); /* _vptr */ + gcc_assert (field); + field = DECL_CHAIN (field); + if (!field) + return false; + gcc_assert (strcmp ("_len", IDENTIFIER_POINTER (DECL_NAME (field))) == 0); + return true; +} + +/* Return true if the DECL is for an allocatable array or scalar. */ + +bool +gfc_omp_allocatable_p (tree decl) +{ + if (!DECL_P (decl)) + return false; + + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + return true; + + tree type = TREE_TYPE (decl); + if (gfc_omp_privatize_by_reference (decl)) + type = TREE_TYPE (type); + + if (GFC_DESCRIPTOR_TYPE_P (type) + && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + return true; + + return false; +} + + +/* Return true if DECL in private clause needs + OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ +bool +gfc_omp_private_outer_ref (tree decl) +{ + tree type = TREE_TYPE (decl); + + if (gfc_omp_privatize_by_reference (decl)) + type = TREE_TYPE (type); + + if (GFC_DESCRIPTOR_TYPE_P (type) + && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + return true; + + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + return true; + + if (gfc_has_alloc_comps (type, decl)) + return true; + + return false; +} + +/* Callback for gfc_omp_unshare_expr. */ + +static tree +gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *) +{ + tree t = *tp; + enum tree_code code = TREE_CODE (t); + + /* Stop at types, decls, constants like copy_tree_r. */ + if (TREE_CODE_CLASS (code) == tcc_type + || TREE_CODE_CLASS (code) == tcc_declaration + || TREE_CODE_CLASS (code) == tcc_constant + || code == BLOCK) + *walk_subtrees = 0; + else if (handled_component_p (t) + || TREE_CODE (t) == MEM_REF) + { + *tp = unshare_expr (t); + *walk_subtrees = 0; + } + + return NULL_TREE; +} + +/* Unshare in expr anything that the FE which normally doesn't + care much about tree sharing (because during gimplification + everything is unshared) could cause problems with tree sharing + at omp-low.c time. */ + +static tree +gfc_omp_unshare_expr (tree expr) +{ + walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL); + return expr; +} + +enum walk_alloc_comps +{ + WALK_ALLOC_COMPS_DTOR, + WALK_ALLOC_COMPS_DEFAULT_CTOR, + WALK_ALLOC_COMPS_COPY_CTOR +}; + +/* Handle allocatable components in OpenMP clauses. */ + +static tree +gfc_walk_alloc_comps (tree decl, tree dest, tree var, + enum walk_alloc_comps kind) +{ + stmtblock_t block, tmpblock; + tree type = TREE_TYPE (decl), then_b, tem, field; + gfc_init_block (&block); + + if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) + { + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_init_block (&tmpblock); + tem = gfc_full_array_size (&tmpblock, decl, + GFC_TYPE_ARRAY_RANK (type)); + then_b = gfc_finish_block (&tmpblock); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b)); + tem = gfc_omp_unshare_expr (tem); + tem = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tem, + gfc_index_one_node); + } + else + { + bool compute_nelts = false; + if (!TYPE_DOMAIN (type) + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE + || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) + compute_nelts = true; + else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + { + tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); + if (lookup_attribute ("omp dummy var", a)) + compute_nelts = true; + } + if (compute_nelts) + { + tem = fold_build2 (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (type), + TYPE_SIZE_UNIT (TREE_TYPE (type))); + tem = size_binop (MINUS_EXPR, tem, size_one_node); + } + else + tem = array_type_nelts (type); + tem = fold_convert (gfc_array_index_type, tem); + } + + tree nelems = gfc_evaluate_now (tem, &block); + tree index = gfc_create_var (gfc_array_index_type, "S"); + + gfc_init_block (&tmpblock); + tem = gfc_conv_array_data (decl); + tree declvar = build_fold_indirect_ref_loc (input_location, tem); + tree declvref = gfc_build_array_ref (declvar, index, NULL); + tree destvar, destvref = NULL_TREE; + if (dest) + { + tem = gfc_conv_array_data (dest); + destvar = build_fold_indirect_ref_loc (input_location, tem); + destvref = gfc_build_array_ref (destvar, index, NULL); + } + gfc_add_expr_to_block (&tmpblock, + gfc_walk_alloc_comps (declvref, destvref, + var, kind)); + + gfc_loopinfo loop; + 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, &tmpblock); + gfc_add_block_to_block (&block, &loop.pre); + return gfc_finish_block (&block); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var)) + { + decl = build_fold_indirect_ref_loc (input_location, decl); + if (dest) + dest = build_fold_indirect_ref_loc (input_location, dest); + type = TREE_TYPE (decl); + } + + gcc_assert (TREE_CODE (type) == RECORD_TYPE); + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + { + tree ftype = TREE_TYPE (field); + tree declf, destf = NULL_TREE; + bool has_alloc_comps = gfc_has_alloc_comps (ftype, field); + if ((!GFC_DESCRIPTOR_TYPE_P (ftype) + || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field) + && !has_alloc_comps) + continue; + declf = fold_build3_loc (input_location, COMPONENT_REF, ftype, + decl, field, NULL_TREE); + if (dest) + destf = fold_build3_loc (input_location, COMPONENT_REF, ftype, + dest, field, NULL_TREE); + + tem = NULL_TREE; + switch (kind) + { + case WALK_ALLOC_COMPS_DTOR: + break; + case WALK_ALLOC_COMPS_DEFAULT_CTOR: + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + { + gfc_add_modify (&block, unshare_expr (destf), + unshare_expr (declf)); + tem = gfc_duplicate_allocatable_nocopy + (destf, declf, ftype, + GFC_TYPE_ARRAY_RANK (ftype)); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0); + break; + case WALK_ALLOC_COMPS_COPY_CTOR: + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + tem = gfc_duplicate_allocatable (destf, declf, ftype, + GFC_TYPE_ARRAY_RANK (ftype), + NULL_TREE); + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = gfc_duplicate_allocatable (destf, declf, ftype, 0, + NULL_TREE); + break; + } + if (tem) + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + if (has_alloc_comps) + { + gfc_init_block (&tmpblock); + gfc_add_expr_to_block (&tmpblock, + gfc_walk_alloc_comps (declf, destf, + field, kind)); + then_b = gfc_finish_block (&tmpblock); + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = unshare_expr (declf); + else + tem = NULL_TREE; + if (tem) + { + tem = fold_convert (pvoid_type_node, tem); + tem = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, tem, + null_pointer_node); + then_b = build3_loc (input_location, COND_EXPR, void_type_node, + tem, then_b, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, then_b); + } + if (kind == WALK_ALLOC_COMPS_DTOR) + { + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + { + tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); + tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, + NULL, + GFC_CAF_COARRAY_NOCOARRAY); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + { + tem = gfc_call_free (unshare_expr (declf)); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + } + } + } + + return gfc_finish_block (&block); +} + +/* Return code to initialize DECL with its default constructor, or + NULL if there's nothing to do. */ + +tree +gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) +{ + tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b; + stmtblock_t block, cond_block; + + switch (OMP_CLAUSE_CODE (clause)) + { + case OMP_CLAUSE__LOOPTEMP_: + case OMP_CLAUSE__REDUCTEMP_: + case OMP_CLAUSE__CONDTEMP_: + case OMP_CLAUSE__SCANTEMP_: + return NULL; + case OMP_CLAUSE_PRIVATE: + case OMP_CLAUSE_LASTPRIVATE: + case OMP_CLAUSE_LINEAR: + case OMP_CLAUSE_REDUCTION: + case OMP_CLAUSE_IN_REDUCTION: + case OMP_CLAUSE_TASK_REDUCTION: + break; + default: + gcc_unreachable (); + } + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gcc_assert (outer); + gfc_start_block (&block); + tree tem = gfc_walk_alloc_comps (outer, decl, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DEFAULT_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + return NULL_TREE; + } + + gcc_assert (outer != NULL_TREE); + + /* Allocatable arrays and scalars in PRIVATE clauses need to be set to + "not currently allocated" allocation status if outer + array is "not currently allocated", otherwise should be allocated. */ + gfc_start_block (&block); + + gfc_init_block (&cond_block); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_add_modify (&cond_block, decl, outer); + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (decl, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (decl, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (decl, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr); + else + gfc_add_modify (&cond_block, unshare_expr (decl), + fold_convert (TREE_TYPE (decl), ptr)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (outer, decl, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DEFAULT_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } + then_b = gfc_finish_block (&cond_block); + + /* Reduction clause requires allocated ALLOCATABLE. */ + if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION + && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_IN_REDUCTION + && OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_TASK_REDUCTION) + { + gfc_init_block (&cond_block); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), + null_pointer_node); + else + gfc_add_modify (&cond_block, unshare_expr (decl), + build_zero_cst (TREE_TYPE (decl))); + else_b = gfc_finish_block (&cond_block); + + tree tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (outer) : outer); + tem = unshare_expr (tem); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tem, null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, + else_b)); + /* Avoid -W*uninitialized warnings. */ + if (DECL_P (decl)) + suppress_warning (decl, OPT_Wuninitialized); + } + else + gfc_add_expr_to_block (&block, then_b); + + return gfc_finish_block (&block); +} + +/* Build and return code for a copy constructor from SRC to DEST. */ + +tree +gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) +{ + tree type = TREE_TYPE (dest), ptr, size, call; + tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); + tree cond, then_b, else_b; + stmtblock_t block, cond_block; + + gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); + + if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) + && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) + && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) + decl_type + = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); + + if (gfc_is_polymorphic_nonptr (decl_type)) + { + if (POINTER_TYPE_P (decl_type)) + decl_type = TREE_TYPE (decl_type); + decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); + if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) + fatal_error (input_location, + "Sorry, polymorphic arrays not yet supported for " + "firstprivate"); + tree src_len; + tree nelems = build_int_cst (size_type_node, 1); /* Scalar. */ + tree src_data = gfc_class_data_get (unshare_expr (src)); + tree dest_data = gfc_class_data_get (unshare_expr (dest)); + bool unlimited = gfc_is_unlimited_polymorphic_nonptr (type); + + gfc_start_block (&block); + gfc_add_modify (&block, gfc_class_vptr_get (dest), + gfc_class_vptr_get (src)); + gfc_init_block (&cond_block); + + if (unlimited) + { + src_len = gfc_class_len_get (src); + gfc_add_modify (&cond_block, gfc_class_len_get (unshare_expr (dest)), src_len); + } + + /* Use: size = class._vtab._size * (class._len > 0 ? class._len : 1). */ + size = fold_convert (size_type_node, gfc_class_vtab_size_get (src)); + if (unlimited) + { + cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + unshare_expr (src_len), + build_zero_cst (TREE_TYPE (src_len))); + cond = build3_loc (input_location, COND_EXPR, size_type_node, cond, + fold_convert (size_type_node, + unshare_expr (src_len)), + build_int_cst (size_type_node, 1)); + size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + size, cond); + } + + /* Malloc memory + call class->_vpt->_copy. */ + call = builtin_decl_explicit (BUILT_IN_MALLOC); + call = build_call_expr_loc (input_location, call, 1, size); + gfc_add_modify (&cond_block, dest_data, + fold_convert (TREE_TYPE (dest_data), call)); + gfc_add_expr_to_block (&cond_block, + gfc_copy_class_to_class (src, dest, nelems, + unlimited)); + + gcc_assert (TREE_CODE (dest_data) == COMPONENT_REF); + if (!GFC_DECL_GET_SCALAR_ALLOCATABLE (TREE_OPERAND (dest_data, 1))) + { + gfc_add_block_to_block (&block, &cond_block); + } + else + { + /* Create: if (class._data != 0) else class._data = NULL; */ + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + src_data, null_pointer_node); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + gfc_finish_block (&cond_block), + fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + unshare_expr (dest_data), null_pointer_node))); + } + return gfc_finish_block (&block); + } + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gfc_start_block (&block); + gfc_add_modify (&block, dest, src); + tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + else + return build2_v (MODIFY_EXPR, dest, src); + } + + /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated + and copied from SRC. */ + gfc_start_block (&block); + + gfc_init_block (&cond_block); + + gfc_add_modify (&cond_block, dest, fold_convert (TREE_TYPE (dest), src)); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (dest, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (dest, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr); + else + gfc_add_modify (&cond_block, unshare_expr (dest), + fold_convert (TREE_TYPE (dest), ptr)); + + tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (src) : src; + srcptr = unshare_expr (srcptr); + srcptr = fold_convert (pvoid_type_node, srcptr); + call = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, + srcptr, size); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (src, dest, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } + then_b = gfc_finish_block (&cond_block); + + gfc_init_block (&cond_block); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), + null_pointer_node); + else + gfc_add_modify (&cond_block, unshare_expr (dest), + build_zero_cst (TREE_TYPE (dest))); + else_b = gfc_finish_block (&cond_block); + + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + unshare_expr (srcptr), null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, else_b)); + /* Avoid -W*uninitialized warnings. */ + if (DECL_P (dest)) + suppress_warning (dest, OPT_Wuninitialized); + + return gfc_finish_block (&block); +} + +/* Similarly, except use an intrinsic or pointer assignment operator + instead. */ + +tree +gfc_omp_clause_assign_op (tree clause, tree dest, tree src) +{ + tree type = TREE_TYPE (dest), ptr, size, call, nonalloc; + tree cond, then_b, else_b; + stmtblock_t block, cond_block, cond_block2, inner_block; + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gfc_start_block (&block); + /* First dealloc any allocatable components in DEST. */ + tree tem = gfc_walk_alloc_comps (dest, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + gfc_add_expr_to_block (&block, tem); + /* Then copy over toplevel data. */ + gfc_add_modify (&block, dest, src); + /* Finally allocate any allocatable components and copy. */ + tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + else + return build2_v (MODIFY_EXPR, dest, src); + } + + gfc_start_block (&block); + + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + tree tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (dest) : dest); + tem = unshare_expr (tem); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tem, null_pointer_node); + tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, + then_b, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tem); + } + + gfc_init_block (&cond_block); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (src, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (src, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (src, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + + tree destptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (dest) : dest; + destptr = unshare_expr (destptr); + destptr = fold_convert (pvoid_type_node, destptr); + gfc_add_modify (&cond_block, ptr, destptr); + + nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + destptr, null_pointer_node); + cond = nonalloc; + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + int i; + for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++) + { + tree rank = gfc_rank_cst[i]; + tree tem = gfc_conv_descriptor_ubound_get (src, rank); + tem = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tem, + gfc_conv_descriptor_lbound_get (src, rank)); + tem = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tem, + gfc_conv_descriptor_lbound_get (dest, rank)); + tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tem, gfc_conv_descriptor_ubound_get (dest, + rank)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, cond, tem); + } + } + + gfc_init_block (&cond_block2); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_init_block (&inner_block); + gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE); + then_b = gfc_finish_block (&inner_block); + + gfc_init_block (&inner_block); + gfc_add_modify (&inner_block, ptr, + gfc_call_realloc (&inner_block, ptr, size)); + else_b = gfc_finish_block (&inner_block); + + gfc_add_expr_to_block (&cond_block2, + build3_loc (input_location, COND_EXPR, + void_type_node, + unshare_expr (nonalloc), + then_b, else_b)); + gfc_add_modify (&cond_block2, dest, src); + gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr); + } + else + { + gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE); + gfc_add_modify (&cond_block2, unshare_expr (dest), + fold_convert (type, ptr)); + } + then_b = gfc_finish_block (&cond_block2); + else_b = build_empty_stmt (input_location); + + gfc_add_expr_to_block (&cond_block, + build3_loc (input_location, COND_EXPR, + void_type_node, unshare_expr (cond), + then_b, else_b)); + + tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (src) : src; + srcptr = unshare_expr (srcptr); + srcptr = fold_convert (pvoid_type_node, srcptr); + call = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, + srcptr, size); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (src, dest, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } + then_b = gfc_finish_block (&cond_block); + + if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN) + { + gfc_init_block (&cond_block); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest)); + 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 (&cond_block, tmp); + } + else + { + destptr = gfc_evaluate_now (destptr, &cond_block); + gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr)); + gfc_add_modify (&cond_block, unshare_expr (dest), + build_zero_cst (TREE_TYPE (dest))); + } + else_b = gfc_finish_block (&cond_block); + + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + unshare_expr (srcptr), null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, + then_b, else_b)); + } + else + gfc_add_expr_to_block (&block, then_b); + + return gfc_finish_block (&block); +} + +static void +gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src, + tree add, tree nelems) +{ + stmtblock_t tmpblock; + tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S"); + nelems = gfc_evaluate_now (nelems, block); + + gfc_init_block (&tmpblock); + if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE) + { + desta = gfc_build_array_ref (dest, index, NULL); + srca = gfc_build_array_ref (src, index, NULL); + } + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest))); + tree idx = fold_build2 (MULT_EXPR, sizetype, + fold_convert (sizetype, index), + TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest)))); + desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (dest), dest, + idx)); + srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (src), src, + idx)); + } + gfc_add_modify (&tmpblock, desta, + fold_build2 (PLUS_EXPR, TREE_TYPE (desta), + srca, add)); + + gfc_loopinfo loop; + 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, &tmpblock); + gfc_add_block_to_block (block, &loop.pre); +} + +/* Build and return code for a constructor of DEST that initializes + it to SRC plus ADD (ADD is scalar integer). */ + +tree +gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add) +{ + tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE; + stmtblock_t block; + + gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); + + gfc_start_block (&block); + add = gfc_evaluate_now (add, &block); + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) + { + bool compute_nelts = false; + gcc_assert (TREE_CODE (type) == ARRAY_TYPE); + if (!TYPE_DOMAIN (type) + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE + || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) + compute_nelts = true; + else if (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + { + tree a = DECL_ATTRIBUTES (TYPE_MAX_VALUE (TYPE_DOMAIN (type))); + if (lookup_attribute ("omp dummy var", a)) + compute_nelts = true; + } + if (compute_nelts) + { + nelems = fold_build2 (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (type), + TYPE_SIZE_UNIT (TREE_TYPE (type))); + nelems = size_binop (MINUS_EXPR, nelems, size_one_node); + } + else + nelems = array_type_nelts (type); + nelems = fold_convert (gfc_array_index_type, nelems); + + gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems); + return gfc_finish_block (&block); + } + + /* Allocatable arrays in LINEAR clauses need to be allocated + and copied from SRC. */ + gfc_add_modify (&block, dest, src); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (dest, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (dest, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + nelems = gfc_evaluate_now (unshare_expr (size), &block); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + nelems, unshare_expr (esize)); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &block); + nelems = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, nelems, + gfc_index_one_node); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr); + tree etype = gfc_get_element_type (type); + ptr = fold_convert (build_pointer_type (etype), ptr); + tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src)); + srcptr = fold_convert (build_pointer_type (etype), srcptr); + gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems); + } + else + { + gfc_add_modify (&block, unshare_expr (dest), + fold_convert (TREE_TYPE (dest), ptr)); + ptr = fold_convert (TREE_TYPE (dest), ptr); + tree dstm = build_fold_indirect_ref (ptr); + tree srcm = build_fold_indirect_ref (unshare_expr (src)); + gfc_add_modify (&block, dstm, + fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add)); + } + return gfc_finish_block (&block); +} + +/* Build and return code destructing DECL. Return NULL if nothing + to be done. */ + +tree +gfc_omp_clause_dtor (tree clause, tree decl) +{ + tree type = TREE_TYPE (decl), tem; + tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); + + if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) + && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) + && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) + decl_type + = TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))); + if (gfc_is_polymorphic_nonptr (decl_type)) + { + if (POINTER_TYPE_P (decl_type)) + decl_type = TREE_TYPE (decl_type); + decl_type = TREE_TYPE (TYPE_FIELDS (decl_type)); + if (GFC_DESCRIPTOR_TYPE_P (decl_type) || GFC_ARRAY_TYPE_P (decl_type)) + fatal_error (input_location, + "Sorry, polymorphic arrays not yet supported for " + "firstprivate"); + stmtblock_t block, cond_block; + gfc_start_block (&block); + gfc_init_block (&cond_block); + tree final = gfc_class_vtab_final_get (decl); + tree size = fold_convert (size_type_node, gfc_class_vtab_size_get (decl)); + gfc_se se; + gfc_init_se (&se, NULL); + symbol_attribute attr = {}; + tree data = gfc_class_data_get (decl); + tree desc = gfc_conv_scalar_to_descriptor (&se, data, attr); + + /* Call class->_vpt->_finalize + free. */ + tree call = build_fold_indirect_ref (final); + call = build_call_expr_loc (input_location, call, 3, + gfc_build_addr_expr (NULL, desc), + size, boolean_false_node); + gfc_add_block_to_block (&cond_block, &se.pre); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + gfc_add_block_to_block (&cond_block, &se.post); + /* Create: if (_vtab && _final) */ + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + gfc_class_vptr_get (decl), + null_pointer_node); + tree cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + final, null_pointer_node); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, cond2); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + gfc_finish_block (&cond_block), NULL_TREE)); + call = builtin_decl_explicit (BUILT_IN_FREE); + call = build_call_expr_loc (input_location, call, 1, data); + gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); + return gfc_finish_block (&block); + } + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause)) + || !POINTER_TYPE_P (type))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + return gfc_walk_alloc_comps (decl, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + return NULL_TREE; + } + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need + to be deallocated if they were allocated. */ + tem = gfc_conv_descriptor_data_get (decl); + tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE, + NULL_TREE, true, NULL, + GFC_CAF_COARRAY_NOCOARRAY); + } + else + tem = gfc_call_free (decl); + tem = gfc_omp_unshare_expr (tem); + + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + stmtblock_t block; + tree then_b; + + gfc_init_block (&block); + gfc_add_expr_to_block (&block, + gfc_walk_alloc_comps (decl, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR)); + gfc_add_expr_to_block (&block, tem); + then_b = gfc_finish_block (&block); + + tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (decl) : decl); + tem = unshare_expr (tem); + tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tem, null_pointer_node); + tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, + then_b, build_empty_stmt (input_location)); + } + return tem; +} + +/* Build a conditional expression in BLOCK. If COND_VAL is not + null, then the block THEN_B is executed, otherwise ELSE_VAL + is assigned to VAL. */ + +static void +gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val, + tree then_b, tree else_val) +{ + stmtblock_t cond_block; + tree else_b = NULL_TREE; + tree val_ty = TREE_TYPE (val); + + if (else_val) + { + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val)); + else_b = gfc_finish_block (&cond_block); + } + gfc_add_expr_to_block (block, + build3_loc (input_location, COND_EXPR, void_type_node, + cond_val, then_b, else_b)); +} + +/* Build a conditional expression in BLOCK, returning a temporary + variable containing the result. If COND_VAL is not null, then + THEN_VAL will be assigned to the variable, otherwise ELSE_VAL + is assigned. + */ + +static tree +gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val, + tree then_val, tree else_val) +{ + tree val; + tree val_ty = TREE_TYPE (then_val); + stmtblock_t cond_block; + + val = create_tmp_var (val_ty); + + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, val, then_val); + tree then_b = gfc_finish_block (&cond_block); + + gfc_build_cond_assign (block, val, cond_val, then_b, else_val); + + return val; +} + +void +gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) +{ + if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP) + return; + + tree decl = OMP_CLAUSE_DECL (c); + + /* Assumed-size arrays can't be mapped implicitly, they have to be + mapped explicitly using array sections. */ + if (TREE_CODE (decl) == PARM_DECL + && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) + && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_UNKNOWN + && GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (decl), + GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)) - 1) + == NULL) + { + error_at (OMP_CLAUSE_LOCATION (c), + "implicit mapping of assumed size array %qD", decl); + return; + } + + tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; + tree present = gfc_omp_check_optional_argument (decl, true); + if (POINTER_TYPE_P (TREE_TYPE (decl))) + { + if (!gfc_omp_privatize_by_reference (decl) + && !GFC_DECL_GET_SCALAR_POINTER (decl) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + && !GFC_DECL_CRAY_POINTEE (decl) + && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + return; + tree orig_decl = decl; + + c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (c4) = decl; + OMP_CLAUSE_SIZE (c4) = size_int (0); + decl = build_fold_indirect_ref (decl); + if (present + && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) + { + c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (c2) = decl; + OMP_CLAUSE_SIZE (c2) = size_int (0); + + stmtblock_t block; + gfc_start_block (&block); + tree ptr = decl; + ptr = gfc_build_cond_assign_expr (&block, present, decl, + null_pointer_node); + gimplify_and_add (gfc_finish_block (&block), pre_p); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c) = ptr; + OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_SIZE (c) = NULL_TREE; + } + if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE + && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) + { + c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (c3) = unshare_expr (decl); + OMP_CLAUSE_SIZE (c3) = size_int (0); + decl = build_fold_indirect_ref (decl); + OMP_CLAUSE_DECL (c) = decl; + } + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + stmtblock_t block; + gfc_start_block (&block); + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + + /* OpenMP: automatically map pointer targets with the pointer; + hence, always update the descriptor/pointer itself. + NOTE: This also remaps the pointer for allocatable arrays with + 'target' attribute which also don't have the 'restrict' qualifier. */ + bool always_modifier = false; + + if (!openacc + && !(TYPE_QUALS (TREE_TYPE (ptr)) & TYPE_QUAL_RESTRICT)) + always_modifier = true; + + if (present) + ptr = gfc_build_cond_assign_expr (&block, present, ptr, + null_pointer_node); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c) = ptr; + c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET); + if (present) + { + ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0))); + gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0)); + + OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr); + } + else + OMP_CLAUSE_DECL (c2) = decl; + OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type); + c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (c3, always_modifier ? GOMP_MAP_ALWAYS_POINTER + : GOMP_MAP_POINTER); + if (present) + { + ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_build_addr_expr (NULL, ptr); + ptr = gfc_build_cond_assign_expr (&block, present, + ptr, null_pointer_node); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c3) = ptr; + } + else + OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_SIZE (c3) = size_int (0); + tree size = create_tmp_var (gfc_array_index_type); + tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) + { + stmtblock_t cond_block; + tree tem, then_b, else_b, zero, cond; + + gfc_init_block (&cond_block); + tem = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + gfc_add_modify (&cond_block, size, tem); + gfc_add_modify (&cond_block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + then_b = gfc_finish_block (&cond_block); + gfc_init_block (&cond_block); + zero = build_int_cst (gfc_array_index_type, 0); + gfc_add_modify (&cond_block, size, zero); + else_b = gfc_finish_block (&cond_block); + tem = gfc_conv_descriptor_data_get (decl); + tem = fold_convert (pvoid_type_node, tem); + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tem, null_pointer_node); + if (present) + { + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, present, cond); + } + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + then_b, else_b)); + } + else if (present) + { + stmtblock_t cond_block; + tree then_b; + + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, size, + gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type))); + gfc_add_modify (&cond_block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + then_b = gfc_finish_block (&cond_block); + + gfc_build_cond_assign (&block, size, present, then_b, + build_int_cst (gfc_array_index_type, 0)); + } + else + { + gfc_add_modify (&block, size, + gfc_full_array_size (&block, decl, + GFC_TYPE_ARRAY_RANK (type))); + gfc_add_modify (&block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + } + OMP_CLAUSE_SIZE (c) = size; + tree stmt = gfc_finish_block (&block); + gimplify_and_add (stmt, pre_p); + } + tree last = c; + if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) + = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); + if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p, + NULL, is_gimple_val, fb_rvalue) == GS_ERROR) + OMP_CLAUSE_SIZE (c) = size_int (0); + if (c2) + { + OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c2; + last = c2; + } + if (c3) + { + OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c3; + last = c3; + } + if (c4) + { + OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c4; + } +} + + +/* Return true if DECL is a scalar variable (for the purpose of + implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.' + is true, allocatables and pointers are permitted. */ + +bool +gfc_omp_scalar_p (tree decl, bool ptr_alloc_ok) +{ + tree type = TREE_TYPE (decl); + if (TREE_CODE (type) == REFERENCE_TYPE) + type = TREE_TYPE (type); + if (TREE_CODE (type) == POINTER_TYPE) + { + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + || GFC_DECL_GET_SCALAR_POINTER (decl)) + { + if (!ptr_alloc_ok) + return false; + type = TREE_TYPE (type); + } + if (GFC_ARRAY_TYPE_P (type) + || GFC_CLASS_TYPE_P (type)) + return false; + } + if ((TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE) + && TYPE_STRING_FLAG (type)) + return false; + if (INTEGRAL_TYPE_P (type) + || SCALAR_FLOAT_TYPE_P (type) + || COMPLEX_FLOAT_TYPE_P (type)) + return true; + return false; +} + + +/* Return true if DECL is a scalar with target attribute but does not have the + allocatable (or pointer) attribute (for the purpose of implicit mapping). */ + +bool +gfc_omp_scalar_target_p (tree decl) +{ + return (DECL_P (decl) && GFC_DECL_GET_SCALAR_TARGET (decl) + && gfc_omp_scalar_p (decl, false)); +} + + +/* Return true if DECL's DECL_VALUE_EXPR (if any) should be + disregarded in OpenMP construct, because it is going to be + remapped during OpenMP lowering. SHARED is true if DECL + is going to be shared, false if it is going to be privatized. */ + +bool +gfc_omp_disregard_value_expr (tree decl, bool shared) +{ + if (GFC_DECL_COMMON_OR_EQUIV (decl) + && DECL_HAS_VALUE_EXPR_P (decl)) + { + tree value = DECL_VALUE_EXPR (decl); + + if (TREE_CODE (value) == COMPONENT_REF + && VAR_P (TREE_OPERAND (value, 0)) + && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) + { + /* If variable in COMMON or EQUIVALENCE is privatized, return + true, as just that variable is supposed to be privatized, + not the whole COMMON or whole EQUIVALENCE. + For shared variables in COMMON or EQUIVALENCE, let them be + gimplified to DECL_VALUE_EXPR, so that for multiple shared vars + from the same COMMON or EQUIVALENCE just one sharing of the + whole COMMON or EQUIVALENCE is enough. */ + return ! shared; + } + } + + if (GFC_DECL_RESULT (decl) && DECL_HAS_VALUE_EXPR_P (decl)) + return ! shared; + + return false; +} + +/* Return true if DECL that is shared iff SHARED is true should + be put into OMP_CLAUSE_PRIVATE with OMP_CLAUSE_PRIVATE_DEBUG + flag set. */ + +bool +gfc_omp_private_debug_clause (tree decl, bool shared) +{ + if (GFC_DECL_CRAY_POINTEE (decl)) + return true; + + if (GFC_DECL_COMMON_OR_EQUIV (decl) + && DECL_HAS_VALUE_EXPR_P (decl)) + { + tree value = DECL_VALUE_EXPR (decl); + + if (TREE_CODE (value) == COMPONENT_REF + && VAR_P (TREE_OPERAND (value, 0)) + && GFC_DECL_COMMON_OR_EQUIV (TREE_OPERAND (value, 0))) + return shared; + } + + return false; +} + +/* Register language specific type size variables as potentially OpenMP + firstprivate variables. */ + +void +gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type) +{ + if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) + { + int r; + + gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL); + for (r = 0; r < GFC_TYPE_ARRAY_RANK (type); r++) + { + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r)); + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r)); + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r)); + } + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type)); + omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type)); + } +} + + +static inline tree +gfc_trans_add_clause (tree node, tree tail) +{ + OMP_CLAUSE_CHAIN (node) = tail; + return node; +} + +static tree +gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd) +{ + if (declare_simd) + { + int cnt = 0; + gfc_symbol *proc_sym; + gfc_formal_arglist *f; + + gcc_assert (sym->attr.dummy); + proc_sym = sym->ns->proc_name; + if (proc_sym->attr.entry_master) + ++cnt; + if (gfc_return_by_reference (proc_sym)) + { + ++cnt; + if (proc_sym->ts.type == BT_CHARACTER) + ++cnt; + } + for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) + if (f->sym == sym) + break; + else if (f->sym) + ++cnt; + gcc_assert (f); + return build_int_cst (integer_type_node, cnt); + } + + tree t = gfc_get_symbol_decl (sym); + tree parent_decl; + int parent_flag; + bool return_value; + bool alternate_entry; + bool entry_master; + + 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); + parent_decl = current_function_decl + ? DECL_CONTEXT (current_function_decl) : NULL_TREE; + + if ((t == parent_decl && return_value) + || (sym->ns && sym->ns->proc_name + && 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 && (t == current_function_decl || parent_flag)) + t = 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) + { + t = gfc_get_fake_result_decl (sym, parent_flag); + break; + } + } + + else if (entry_master + && (sym->ns->proc_name->backend_decl == current_function_decl + || parent_flag)) + t = gfc_get_fake_result_decl (sym, parent_flag); + + return t; +} + +static tree +gfc_trans_omp_variable_list (enum omp_clause_code code, + gfc_omp_namelist *namelist, tree list, + bool declare_simd) +{ + for (; namelist != NULL; namelist = namelist->next) + if (namelist->sym->attr.referenced || declare_simd) + { + tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); + if (t != error_mark_node) + { + tree node = build_omp_clause (input_location, code); + OMP_CLAUSE_DECL (node) = t; + list = gfc_trans_add_clause (node, list); + + if (code == OMP_CLAUSE_LASTPRIVATE + && namelist->u.lastprivate_conditional) + OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1; + } + } + return list; +} + +struct omp_udr_find_orig_data +{ + gfc_omp_udr *omp_udr; + bool omp_orig_seen; +}; + +static int +omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data; + if ((*e)->expr_type == EXPR_VARIABLE + && (*e)->symtree->n.sym == cd->omp_udr->omp_orig) + cd->omp_orig_seen = true; + + return 0; +} + +static void +gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) +{ + gfc_symbol *sym = n->sym; + gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; + gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; + gfc_symbol init_val_sym, outer_sym, intrinsic_sym; + gfc_symbol omp_var_copy[4]; + gfc_expr *e1, *e2, *e3, *e4; + gfc_ref *ref; + tree decl, backend_decl, stmt, type, outer_decl; + locus old_loc = gfc_current_locus; + const char *iname; + bool t; + gfc_omp_udr *udr = n->u2.udr ? n->u2.udr->udr : NULL; + + decl = OMP_CLAUSE_DECL (c); + gfc_current_locus = where; + type = TREE_TYPE (decl); + outer_decl = create_tmp_var_raw (type); + if (TREE_CODE (decl) == PARM_DECL + && TREE_CODE (type) == REFERENCE_TYPE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)) + && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (type)) == GFC_ARRAY_ALLOCATABLE) + { + decl = build_fold_indirect_ref (decl); + type = TREE_TYPE (type); + } + + /* Create a fake symbol for init value. */ + memset (&init_val_sym, 0, sizeof (init_val_sym)); + init_val_sym.ns = sym->ns; + init_val_sym.name = sym->name; + init_val_sym.ts = sym->ts; + init_val_sym.attr.referenced = 1; + init_val_sym.declared_at = where; + init_val_sym.attr.flavor = FL_VARIABLE; + if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) + backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); + else if (udr->initializer_ns) + backend_decl = NULL; + else + switch (sym->ts.type) + { + case BT_LOGICAL: + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym)); + break; + default: + backend_decl = NULL_TREE; + break; + } + init_val_sym.backend_decl = backend_decl; + + /* Create a fake symbol for the outer array reference. */ + outer_sym = *sym; + if (sym->as) + outer_sym.as = gfc_copy_array_spec (sym->as); + outer_sym.attr.dummy = 0; + outer_sym.attr.result = 0; + outer_sym.attr.flavor = FL_VARIABLE; + outer_sym.backend_decl = outer_decl; + if (decl != OMP_CLAUSE_DECL (c)) + outer_sym.backend_decl = build_fold_indirect_ref (outer_decl); + + /* Create fake symtrees for it. */ + symtree1 = gfc_new_symtree (&root1, sym->name); + symtree1->n.sym = sym; + gcc_assert (symtree1 == root1); + + symtree2 = gfc_new_symtree (&root2, sym->name); + symtree2->n.sym = &init_val_sym; + gcc_assert (symtree2 == root2); + + symtree3 = gfc_new_symtree (&root3, sym->name); + symtree3->n.sym = &outer_sym; + gcc_assert (symtree3 == root3); + + memset (omp_var_copy, 0, sizeof omp_var_copy); + if (udr) + { + omp_var_copy[0] = *udr->omp_out; + omp_var_copy[1] = *udr->omp_in; + *udr->omp_out = outer_sym; + *udr->omp_in = *sym; + if (udr->initializer_ns) + { + omp_var_copy[2] = *udr->omp_priv; + omp_var_copy[3] = *udr->omp_orig; + *udr->omp_priv = *sym; + *udr->omp_orig = outer_sym; + } + } + + /* Create expressions. */ + e1 = gfc_get_expr (); + e1->expr_type = EXPR_VARIABLE; + e1->where = where; + e1->symtree = symtree1; + e1->ts = sym->ts; + if (sym->attr.dimension) + { + e1->ref = ref = gfc_get_ref (); + ref->type = REF_ARRAY; + ref->u.ar.where = where; + ref->u.ar.as = sym->as; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = 0; + } + t = gfc_resolve_expr (e1); + gcc_assert (t); + + e2 = NULL; + if (backend_decl != NULL_TREE) + { + e2 = gfc_get_expr (); + e2->expr_type = EXPR_VARIABLE; + e2->where = where; + e2->symtree = symtree2; + e2->ts = sym->ts; + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + else if (udr->initializer_ns == NULL) + { + gcc_assert (sym->ts.type == BT_DERIVED); + e2 = gfc_default_initializer (&sym->ts); + gcc_assert (e2); + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + else if (n->u2.udr->initializer->op == EXEC_ASSIGN) + { + e2 = gfc_copy_expr (n->u2.udr->initializer->expr2); + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + if (udr && udr->initializer_ns) + { + struct omp_udr_find_orig_data cd; + cd.omp_udr = udr; + cd.omp_orig_seen = false; + gfc_code_walker (&n->u2.udr->initializer, + gfc_dummy_code_callback, omp_udr_find_orig, &cd); + if (cd.omp_orig_seen) + OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; + } + + e3 = gfc_copy_expr (e1); + e3->symtree = symtree3; + t = gfc_resolve_expr (e3); + gcc_assert (t); + + iname = NULL; + e4 = NULL; + switch (OMP_CLAUSE_REDUCTION_CODE (c)) + { + case PLUS_EXPR: + case MINUS_EXPR: + e4 = gfc_add (e3, e1); + break; + case MULT_EXPR: + e4 = gfc_multiply (e3, e1); + break; + case TRUTH_ANDIF_EXPR: + e4 = gfc_and (e3, e1); + break; + case TRUTH_ORIF_EXPR: + e4 = gfc_or (e3, e1); + break; + case EQ_EXPR: + e4 = gfc_eqv (e3, e1); + break; + case NE_EXPR: + e4 = gfc_neqv (e3, e1); + break; + case MIN_EXPR: + iname = "min"; + break; + case MAX_EXPR: + iname = "max"; + break; + case BIT_AND_EXPR: + iname = "iand"; + break; + case BIT_IOR_EXPR: + iname = "ior"; + break; + case BIT_XOR_EXPR: + iname = "ieor"; + break; + case ERROR_MARK: + if (n->u2.udr->combiner->op == EXEC_ASSIGN) + { + gfc_free_expr (e3); + e3 = gfc_copy_expr (n->u2.udr->combiner->expr1); + e4 = gfc_copy_expr (n->u2.udr->combiner->expr2); + t = gfc_resolve_expr (e3); + gcc_assert (t); + t = gfc_resolve_expr (e4); + gcc_assert (t); + } + break; + default: + gcc_unreachable (); + } + if (iname != NULL) + { + memset (&intrinsic_sym, 0, sizeof (intrinsic_sym)); + intrinsic_sym.ns = sym->ns; + intrinsic_sym.name = iname; + intrinsic_sym.ts = sym->ts; + intrinsic_sym.attr.referenced = 1; + intrinsic_sym.attr.intrinsic = 1; + intrinsic_sym.attr.function = 1; + intrinsic_sym.attr.implicit_type = 1; + intrinsic_sym.result = &intrinsic_sym; + intrinsic_sym.declared_at = where; + + symtree4 = gfc_new_symtree (&root4, iname); + symtree4->n.sym = &intrinsic_sym; + gcc_assert (symtree4 == root4); + + e4 = gfc_get_expr (); + e4->expr_type = EXPR_FUNCTION; + e4->where = where; + e4->symtree = symtree4; + e4->value.function.actual = gfc_get_actual_arglist (); + e4->value.function.actual->expr = e3; + e4->value.function.actual->next = gfc_get_actual_arglist (); + e4->value.function.actual->next->expr = e1; + } + if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) + { + /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ + e1 = gfc_copy_expr (e1); + e3 = gfc_copy_expr (e3); + t = gfc_resolve_expr (e4); + gcc_assert (t); + } + + /* Create the init statement list. */ + pushlevel (); + if (e2) + stmt = gfc_trans_assignment (e1, e2, false, false); + else + stmt = gfc_trans_call (n->u2.udr->initializer, false, + NULL_TREE, NULL_TREE, false); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + OMP_CLAUSE_REDUCTION_INIT (c) = stmt; + + /* Create the merge statement list. */ + pushlevel (); + if (e4) + stmt = gfc_trans_assignment (e3, e4, false, true); + else + stmt = gfc_trans_call (n->u2.udr->combiner, false, + NULL_TREE, NULL_TREE, false); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + OMP_CLAUSE_REDUCTION_MERGE (c) = stmt; + + /* And stick the placeholder VAR_DECL into the clause as well. */ + OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_decl; + + gfc_current_locus = old_loc; + + gfc_free_expr (e1); + if (e2) + gfc_free_expr (e2); + gfc_free_expr (e3); + if (e4) + gfc_free_expr (e4); + free (symtree1); + free (symtree2); + free (symtree3); + free (symtree4); + if (outer_sym.as) + gfc_free_array_spec (outer_sym.as); + + if (udr) + { + *udr->omp_out = omp_var_copy[0]; + *udr->omp_in = omp_var_copy[1]; + if (udr->initializer_ns) + { + *udr->omp_priv = omp_var_copy[2]; + *udr->omp_orig = omp_var_copy[3]; + } + } +} + +static tree +gfc_trans_omp_reduction_list (int kind, gfc_omp_namelist *namelist, tree list, + locus where, bool mark_addressable) +{ + omp_clause_code clause = OMP_CLAUSE_REDUCTION; + switch (kind) + { + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: + break; + case OMP_LIST_IN_REDUCTION: + clause = OMP_CLAUSE_IN_REDUCTION; + break; + case OMP_LIST_TASK_REDUCTION: + clause = OMP_CLAUSE_TASK_REDUCTION; + break; + default: + gcc_unreachable (); + } + for (; namelist != NULL; namelist = namelist->next) + if (namelist->sym->attr.referenced) + { + tree t = gfc_trans_omp_variable (namelist->sym, false); + if (t != error_mark_node) + { + tree node = build_omp_clause (gfc_get_location (&namelist->where), + clause); + OMP_CLAUSE_DECL (node) = t; + if (mark_addressable) + TREE_ADDRESSABLE (t) = 1; + if (kind == OMP_LIST_REDUCTION_INSCAN) + OMP_CLAUSE_REDUCTION_INSCAN (node) = 1; + if (kind == OMP_LIST_REDUCTION_TASK) + OMP_CLAUSE_REDUCTION_TASK (node) = 1; + switch (namelist->u.reduction_op) + { + case OMP_REDUCTION_PLUS: + OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR; + break; + case OMP_REDUCTION_MINUS: + OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR; + break; + case OMP_REDUCTION_TIMES: + OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR; + break; + case OMP_REDUCTION_AND: + OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR; + break; + case OMP_REDUCTION_OR: + OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR; + break; + case OMP_REDUCTION_EQV: + OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR; + break; + case OMP_REDUCTION_NEQV: + OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR; + break; + case OMP_REDUCTION_MAX: + OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR; + break; + case OMP_REDUCTION_MIN: + OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR; + break; + case OMP_REDUCTION_IAND: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR; + break; + case OMP_REDUCTION_IOR: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR; + break; + case OMP_REDUCTION_IEOR: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR; + break; + case OMP_REDUCTION_USER: + OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK; + break; + default: + gcc_unreachable (); + } + if (namelist->sym->attr.dimension + || namelist->u.reduction_op == OMP_REDUCTION_USER + || namelist->sym->attr.allocatable) + gfc_trans_omp_array_reduction_or_udr (node, namelist, where); + list = gfc_trans_add_clause (node, list); + } + } + return list; +} + +static inline tree +gfc_convert_expr_to_tree (stmtblock_t *block, gfc_expr *expr) +{ + gfc_se se; + tree result; + + gfc_init_se (&se, NULL ); + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (block, &se.pre); + result = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + return result; +} + +static vec *doacross_steps; + + +/* Translate an array section or array element. */ + +static void +gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, + tree decl, bool element, gomp_map_kind ptr_kind, + tree &node, tree &node2, tree &node3, tree &node4) +{ + gfc_se se; + tree ptr, ptr2; + tree elemsz = NULL_TREE; + + gfc_init_se (&se, NULL); + + if (element) + { + gfc_conv_expr_reference (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + ptr = se.expr; + OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr))); + elemsz = OMP_CLAUSE_SIZE (node); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gcc_assert (se.post.head == NULL_TREE); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + ptr = fold_convert (ptrdiff_type_node, ptr); + + if (POINTER_TYPE_P (TREE_TYPE (decl)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) + && ptr_kind == GOMP_MAP_POINTER) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER + && n->expr->ts.type == BT_CHARACTER + && n->expr->ts.deferred) + { + gomp_map_kind map_kind; + if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node))) + map_kind = GOMP_MAP_TO; + else if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE + || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE) + map_kind = OMP_CLAUSE_MAP_KIND (node); + else + map_kind = GOMP_MAP_ALLOC; + gcc_assert (se.string_length); + node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); + OMP_CLAUSE_DECL (node4) = se.string_length; + OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node); + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree desc_node; + tree type = TREE_TYPE (decl); + ptr2 = gfc_conv_descriptor_data_get (decl); + desc_node = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_DECL (desc_node) = decl; + OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type); + if (ptr_kind == GOMP_MAP_ALWAYS_POINTER) + { + OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO); + node2 = node; + node = desc_node; /* Needs to come first. */ + } + else + { + OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO_PSET); + node2 = desc_node; + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra + cast prevents gimplify.c from recognising it as being part of the + struct – and adding an 'alloc: for the 'desc.data' pointer, which + would break as the 'desc' (the descriptor) is also mapped + (see node4 above). */ + if (ptr_kind == GOMP_MAP_ATTACH_DETACH) + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + } + else + { + if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) + { + tree offset; + ptr2 = build_fold_addr_expr (decl); + offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr, + fold_convert (ptrdiff_type_node, ptr2)); + offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node, + offset, fold_convert (ptrdiff_type_node, elemsz)); + offset = build4_loc (input_location, ARRAY_REF, + TREE_TYPE (TREE_TYPE (decl)), + decl, offset, NULL_TREE, NULL_TREE); + OMP_CLAUSE_DECL (node) = offset; + + if (ptr_kind == GOMP_MAP_ALWAYS_POINTER) + return; + } + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); + ptr2 = decl; + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); + OMP_CLAUSE_DECL (node3) = decl; + } + ptr2 = fold_convert (ptrdiff_type_node, ptr2); + OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node, + ptr, ptr2); +} + +static tree +handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) +{ + tree list = NULL_TREE; + for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + { + gfc_constructor *c; + gfc_se se; + + tree last = make_tree_vec (6); + tree iter_var = gfc_get_symbol_decl (sym); + tree type = TREE_TYPE (iter_var); + TREE_VEC_ELT (last, 0) = iter_var; + DECL_CHAIN (iter_var) = BLOCK_VARS (block); + BLOCK_VARS (block) = iter_var; + + /* begin */ + c = gfc_constructor_first (sym->value->value.constructor); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + TREE_VEC_ELT (last, 1) = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + /* end */ + c = gfc_constructor_next (c); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + TREE_VEC_ELT (last, 2) = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + /* step */ + c = gfc_constructor_next (c); + tree step; + if (c) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (iter_block, &se.pre); + gfc_add_block_to_block (iter_block, &se.post); + gfc_conv_expr (&se, c->expr); + step = fold_convert (type, + gfc_evaluate_now (se.expr, + iter_block)); + } + else + step = build_int_cst (type, 1); + TREE_VEC_ELT (last, 3) = step; + /* orig_step */ + TREE_VEC_ELT (last, 4) = save_expr (step); + TREE_CHAIN (last) = list; + list = last; + } + return list; +} + +static tree +gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, + locus where, bool declare_simd = false, + bool openacc = false) +{ + tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c; + tree iterator = NULL_TREE; + tree tree_block = NULL_TREE; + stmtblock_t iter_block; + int list, ifc; + enum omp_clause_code clause_code; + gfc_omp_namelist *prev = NULL; + gfc_se se; + + if (clauses == NULL) + return NULL_TREE; + + for (list = 0; list < OMP_LIST_NUM; list++) + { + gfc_omp_namelist *n = clauses->lists[list]; + + if (n == NULL) + continue; + switch (list) + { + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: + case OMP_LIST_IN_REDUCTION: + case OMP_LIST_TASK_REDUCTION: + /* An OpenACC async clause indicates the need to set reduction + arguments addressable, to allow asynchronous copy-out. */ + omp_clauses = gfc_trans_omp_reduction_list (list, n, omp_clauses, + where, clauses->async); + break; + case OMP_LIST_PRIVATE: + clause_code = OMP_CLAUSE_PRIVATE; + goto add_clause; + case OMP_LIST_SHARED: + clause_code = OMP_CLAUSE_SHARED; + goto add_clause; + case OMP_LIST_FIRSTPRIVATE: + clause_code = OMP_CLAUSE_FIRSTPRIVATE; + goto add_clause; + case OMP_LIST_LASTPRIVATE: + clause_code = OMP_CLAUSE_LASTPRIVATE; + goto add_clause; + case OMP_LIST_COPYIN: + clause_code = OMP_CLAUSE_COPYIN; + goto add_clause; + case OMP_LIST_COPYPRIVATE: + clause_code = OMP_CLAUSE_COPYPRIVATE; + goto add_clause; + case OMP_LIST_UNIFORM: + clause_code = OMP_CLAUSE_UNIFORM; + goto add_clause; + case OMP_LIST_USE_DEVICE: + case OMP_LIST_USE_DEVICE_PTR: + clause_code = OMP_CLAUSE_USE_DEVICE_PTR; + goto add_clause; + case OMP_LIST_USE_DEVICE_ADDR: + clause_code = OMP_CLAUSE_USE_DEVICE_ADDR; + goto add_clause; + case OMP_LIST_IS_DEVICE_PTR: + clause_code = OMP_CLAUSE_IS_DEVICE_PTR; + goto add_clause; + case OMP_LIST_NONTEMPORAL: + clause_code = OMP_CLAUSE_NONTEMPORAL; + goto add_clause; + case OMP_LIST_SCAN_IN: + clause_code = OMP_CLAUSE_INCLUSIVE; + goto add_clause; + case OMP_LIST_SCAN_EX: + clause_code = OMP_CLAUSE_EXCLUSIVE; + goto add_clause; + + add_clause: + omp_clauses + = gfc_trans_omp_variable_list (clause_code, n, omp_clauses, + declare_simd); + break; + case OMP_LIST_ALIGNED: + for (; n != NULL; n = n->next) + if (n->sym->attr.referenced || declare_simd) + { + tree t = gfc_trans_omp_variable (n->sym, declare_simd); + if (t != error_mark_node) + { + tree node = build_omp_clause (input_location, + OMP_CLAUSE_ALIGNED); + OMP_CLAUSE_DECL (node) = t; + if (n->expr) + { + tree alignment_var; + + if (declare_simd) + alignment_var = gfc_conv_constant_to_tree (n->expr); + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + alignment_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var; + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + break; + case OMP_LIST_ALLOCATE: + for (; n != NULL; n = n->next) + if (n->sym->attr.referenced) + { + tree t = gfc_trans_omp_variable (n->sym, false); + if (t != error_mark_node) + { + tree node = build_omp_clause (input_location, + OMP_CLAUSE_ALLOCATE); + OMP_CLAUSE_DECL (node) = t; + if (n->expr) + { + tree allocator_; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, n->expr); + allocator_ = gfc_evaluate_now (se.expr, block); + OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_; + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + break; + case OMP_LIST_LINEAR: + { + gfc_expr *last_step_expr = NULL; + tree last_step = NULL_TREE; + bool last_step_parm = false; + + for (; n != NULL; n = n->next) + { + if (n->expr) + { + last_step_expr = n->expr; + last_step = NULL_TREE; + last_step_parm = false; + } + if (n->sym->attr.referenced || declare_simd) + { + tree t = gfc_trans_omp_variable (n->sym, declare_simd); + if (t != error_mark_node) + { + tree node = build_omp_clause (input_location, + OMP_CLAUSE_LINEAR); + OMP_CLAUSE_DECL (node) = t; + omp_clause_linear_kind kind; + switch (n->u.linear_op) + { + case OMP_LINEAR_DEFAULT: + kind = OMP_CLAUSE_LINEAR_DEFAULT; + break; + case OMP_LINEAR_REF: + kind = OMP_CLAUSE_LINEAR_REF; + break; + case OMP_LINEAR_VAL: + kind = OMP_CLAUSE_LINEAR_VAL; + break; + case OMP_LINEAR_UVAL: + kind = OMP_CLAUSE_LINEAR_UVAL; + break; + default: + gcc_unreachable (); + } + OMP_CLAUSE_LINEAR_KIND (node) = kind; + if (last_step_expr && last_step == NULL_TREE) + { + if (!declare_simd) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, last_step_expr); + gfc_add_block_to_block (block, &se.pre); + last_step = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + else if (last_step_expr->expr_type == EXPR_VARIABLE) + { + gfc_symbol *s = last_step_expr->symtree->n.sym; + last_step = gfc_trans_omp_variable (s, true); + last_step_parm = true; + } + else + last_step + = gfc_conv_constant_to_tree (last_step_expr); + } + if (last_step_parm) + { + OMP_CLAUSE_LINEAR_VARIABLE_STRIDE (node) = 1; + OMP_CLAUSE_LINEAR_STEP (node) = last_step; + } + else + { + if (kind == OMP_CLAUSE_LINEAR_REF) + { + tree type; + if (n->sym->attr.flavor == FL_PROCEDURE) + { + type = gfc_get_function_type (n->sym); + type = build_pointer_type (type); + } + else + type = gfc_sym_type (n->sym); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + /* Otherwise to be determined what exactly + should be done. */ + tree t = fold_convert (sizetype, last_step); + t = size_binop (MULT_EXPR, t, + TYPE_SIZE_UNIT (type)); + OMP_CLAUSE_LINEAR_STEP (node) = t; + } + else + { + tree type + = gfc_typenode_for_spec (&n->sym->ts); + OMP_CLAUSE_LINEAR_STEP (node) + = fold_convert (type, last_step); + } + } + if (n->sym->attr.dimension || n->sym->attr.allocatable) + OMP_CLAUSE_LINEAR_ARRAY (node) = 1; + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + } + } + break; + case OMP_LIST_AFFINITY: + case OMP_LIST_DEPEND: + iterator = NULL_TREE; + prev = NULL; + prev_clauses = omp_clauses; + for (; n != NULL; n = n->next) + { + if (iterator && prev->u2.ns != n->u2.ns) + { + BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); + TREE_VEC_ELT (iterator, 5) = tree_block; + for (tree c = omp_clauses; c != prev_clauses; + c = OMP_CLAUSE_CHAIN (c)) + OMP_CLAUSE_DECL (c) = build_tree_list (iterator, + OMP_CLAUSE_DECL (c)); + prev_clauses = omp_clauses; + iterator = NULL_TREE; + } + if (n->u2.ns && (!prev || prev->u2.ns != n->u2.ns)) + { + gfc_init_block (&iter_block); + tree_block = make_node (BLOCK); + TREE_USED (tree_block) = 1; + BLOCK_VARS (tree_block) = NULL_TREE; + iterator = handle_iterator (n->u2.ns, block, + tree_block); + } + if (!iterator) + gfc_init_block (&iter_block); + prev = n; + if (list == OMP_LIST_DEPEND + && n->u.depend_op == OMP_DEPEND_SINK_FIRST) + { + tree vec = NULL_TREE; + unsigned int i; + for (i = 0; ; i++) + { + tree addend = integer_zero_node, t; + bool neg = false; + if (n->expr) + { + addend = gfc_conv_constant_to_tree (n->expr); + if (TREE_CODE (addend) == INTEGER_CST + && tree_int_cst_sgn (addend) == -1) + { + neg = true; + addend = const_unop (NEGATE_EXPR, + TREE_TYPE (addend), addend); + } + } + t = gfc_trans_omp_variable (n->sym, false); + if (t != error_mark_node) + { + if (i < vec_safe_length (doacross_steps) + && !integer_zerop (addend) + && (*doacross_steps)[i]) + { + tree step = (*doacross_steps)[i]; + addend = fold_convert (TREE_TYPE (step), addend); + addend = build2 (TRUNC_DIV_EXPR, + TREE_TYPE (step), addend, step); + } + vec = tree_cons (addend, t, vec); + if (neg) + OMP_CLAUSE_DEPEND_SINK_NEGATIVE (vec) = 1; + } + if (n->next == NULL + || n->next->u.depend_op != OMP_DEPEND_SINK) + break; + n = n->next; + } + if (vec == NULL_TREE) + continue; + + tree node = build_omp_clause (input_location, + OMP_CLAUSE_DEPEND); + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_SINK; + OMP_CLAUSE_DECL (node) = nreverse (vec); + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + continue; + } + + if (!n->sym->attr.referenced) + continue; + + tree node = build_omp_clause (input_location, + list == OMP_LIST_DEPEND + ? OMP_CLAUSE_DEPEND + : OMP_CLAUSE_AFFINITY); + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + { + tree decl = gfc_trans_omp_variable (n->sym, false); + if (gfc_omp_privatize_by_reference (decl)) + decl = build_fold_indirect_ref (decl); + if (n->u.depend_op == OMP_DEPEND_DEPOBJ + && POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref (decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + decl = gfc_conv_descriptor_data_get (decl); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); + decl = build_fold_indirect_ref (decl); + } + else if (DECL_P (decl)) + TREE_ADDRESSABLE (decl) = 1; + OMP_CLAUSE_DECL (node) = decl; + } + else + { + tree ptr; + gfc_init_se (&se, NULL); + if (n->expr->ref->u.ar.type == AR_ELEMENT) + { + gfc_conv_expr_reference (&se, n->expr); + ptr = se.expr; + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + } + gfc_add_block_to_block (&iter_block, &se.pre); + gfc_add_block_to_block (&iter_block, &se.post); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + if (list == OMP_LIST_DEPEND) + switch (n->u.depend_op) + { + case OMP_DEPEND_IN: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; + break; + case OMP_DEPEND_OUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; + break; + case OMP_DEPEND_INOUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; + break; + case OMP_DEPEND_MUTEXINOUTSET: + OMP_CLAUSE_DEPEND_KIND (node) + = OMP_CLAUSE_DEPEND_MUTEXINOUTSET; + break; + case OMP_DEPEND_DEPOBJ: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_DEPOBJ; + break; + default: + gcc_unreachable (); + } + if (!iterator) + gfc_add_block_to_block (block, &iter_block); + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + if (iterator) + { + BLOCK_SUBBLOCKS (tree_block) = gfc_finish_block (&iter_block); + TREE_VEC_ELT (iterator, 5) = tree_block; + for (tree c = omp_clauses; c != prev_clauses; + c = OMP_CLAUSE_CHAIN (c)) + OMP_CLAUSE_DECL (c) = build_tree_list (iterator, + OMP_CLAUSE_DECL (c)); + } + break; + case OMP_LIST_MAP: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.referenced) + continue; + + bool always_modifier = false; + tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP); + tree node2 = NULL_TREE; + tree node3 = NULL_TREE; + tree node4 = NULL_TREE; + + /* OpenMP: automatically map pointer targets with the pointer; + hence, always update the descriptor/pointer itself. */ + if (!openacc + && ((n->expr == NULL && n->sym->attr.pointer) + || (n->expr && gfc_expr_attr (n->expr).pointer))) + always_modifier = true; + + switch (n->u.map_op) + { + case OMP_MAP_ALLOC: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); + break; + case OMP_MAP_IF_PRESENT: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT); + break; + case OMP_MAP_ATTACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH); + break; + case OMP_MAP_TO: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); + break; + case OMP_MAP_FROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM); + break; + case OMP_MAP_TOFROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM); + break; + case OMP_MAP_ALWAYS_TO: + always_modifier = true; + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO); + break; + case OMP_MAP_ALWAYS_FROM: + always_modifier = true; + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM); + break; + case OMP_MAP_ALWAYS_TOFROM: + always_modifier = true; + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM); + break; + case OMP_MAP_RELEASE: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE); + break; + case OMP_MAP_DELETE: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); + break; + case OMP_MAP_DETACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH); + break; + case OMP_MAP_FORCE_ALLOC: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); + break; + case OMP_MAP_FORCE_TO: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO); + break; + case OMP_MAP_FORCE_FROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM); + break; + case OMP_MAP_FORCE_TOFROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM); + break; + case OMP_MAP_FORCE_PRESENT: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT); + break; + case OMP_MAP_FORCE_DEVICEPTR: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR); + break; + default: + gcc_unreachable (); + } + + tree decl = gfc_trans_omp_variable (n->sym, false); + if (DECL_P (decl)) + TREE_ADDRESSABLE (decl) = 1; + + gfc_ref *lastref = NULL; + + if (n->expr) + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY) + lastref = ref; + + bool allocatable = false, pointer = false; + + if (lastref && lastref->type == REF_COMPONENT) + { + gfc_component *c = lastref->u.c.component; + + if (c->ts.type == BT_CLASS) + { + pointer = CLASS_DATA (c)->attr.class_pointer; + allocatable = CLASS_DATA (c)->attr.allocatable; + } + else + { + pointer = c->attr.pointer; + allocatable = c->attr.allocatable; + } + } + + if (n->expr == NULL + || (n->expr->ref->type == REF_ARRAY + && n->expr->ref->u.ar.type == AR_FULL)) + { + tree present = gfc_omp_check_optional_argument (decl, true); + if (openacc && n->sym->ts.type == BT_CLASS) + { + tree type = TREE_TYPE (decl); + if (n->sym->attr.optional) + sorry ("optional class parameter"); + if (POINTER_TYPE_P (type)) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + tree ptr = gfc_class_data_get (decl); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl); + node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH); + OMP_CLAUSE_DECL (node3) = gfc_class_data_get (decl); + OMP_CLAUSE_SIZE (node3) = size_int (0); + goto finalize_map_clause; + } + else if (POINTER_TYPE_P (TREE_TYPE (decl)) + && (gfc_omp_privatize_by_reference (decl) + || GFC_DECL_GET_SCALAR_POINTER (decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + || GFC_DECL_CRAY_POINTEE (decl) + || GFC_DESCRIPTOR_TYPE_P + (TREE_TYPE (TREE_TYPE (decl))) + || n->sym->ts.type == BT_DERIVED)) + { + tree orig_decl = decl; + + /* For nonallocatable, nonpointer arrays, a temporary + variable is generated, but this one is only defined if + the variable is present; hence, we now set it to NULL + to avoid accessing undefined variables. We cannot use + a temporary variable here as otherwise the replacement + of the variables in omp-low.c will not work. */ + if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) + { + tree tmp = fold_build2_loc (input_location, + MODIFY_EXPR, + void_type_node, decl, + null_pointer_node); + tree cond = fold_build1_loc (input_location, + TRUTH_NOT_EXPR, + boolean_type_node, + present); + gfc_add_expr_to_block (block, + build3_loc (input_location, + COND_EXPR, + void_type_node, + cond, tmp, + NULL_TREE)); + } + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE + || gfc_omp_is_optional_argument (orig_decl)) + && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) + { + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (node3) = decl; + OMP_CLAUSE_SIZE (node3) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + if (present) + ptr = gfc_build_cond_assign_expr (block, present, ptr, + null_pointer_node); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + if (present) + { + ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_build_addr_expr (NULL, ptr); + ptr = gfc_build_cond_assign_expr (block, present, ptr, + null_pointer_node); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node3) = ptr; + } + else + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_SIZE (node3) = size_int (0); + if (n->u.map_op == OMP_MAP_ATTACH) + { + /* Standalone attach clauses used with arrays with + descriptors must copy the descriptor to the target, + else they won't have anything to perform the + attachment onto (see OpenACC 2.6, "2.6.3. Data + Structures with Pointers"). */ + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH); + /* We don't want to map PTR at all in this case, so + delete its node and shuffle the others down. */ + node = node2; + node2 = node3; + node3 = NULL; + goto finalize_map_clause; + } + else if (n->u.map_op == OMP_MAP_DETACH) + { + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH); + /* Similarly to above, we don't want to unmap PTR + here. */ + node = node2; + node2 = node3; + node3 = NULL; + goto finalize_map_clause; + } + else + OMP_CLAUSE_SET_MAP_KIND (node3, + always_modifier + ? GOMP_MAP_ALWAYS_POINTER + : GOMP_MAP_POINTER); + + /* We have to check for n->sym->attr.dimension because + of scalar coarrays. */ + if (n->sym->attr.pointer && n->sym->attr.dimension) + { + stmtblock_t cond_block; + tree size + = gfc_create_var (gfc_array_index_type, NULL); + tree tem, then_b, else_b, zero, cond; + + gfc_init_block (&cond_block); + tem + = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + gfc_add_modify (&cond_block, size, tem); + then_b = gfc_finish_block (&cond_block); + gfc_init_block (&cond_block); + zero = build_int_cst (gfc_array_index_type, 0); + gfc_add_modify (&cond_block, size, zero); + else_b = gfc_finish_block (&cond_block); + tem = gfc_conv_descriptor_data_get (decl); + tem = fold_convert (pvoid_type_node, tem); + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + tem, null_pointer_node); + if (present) + cond = fold_build2_loc (input_location, + TRUTH_ANDIF_EXPR, + boolean_type_node, + present, cond); + gfc_add_expr_to_block (block, + build3_loc (input_location, + COND_EXPR, + void_type_node, + cond, then_b, + else_b)); + OMP_CLAUSE_SIZE (node) = size; + } + else if (n->sym->attr.dimension) + { + stmtblock_t cond_block; + gfc_init_block (&cond_block); + tree size = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + if (present) + { + tree var = gfc_create_var (gfc_array_index_type, + NULL); + gfc_add_modify (&cond_block, var, size); + tree cond_body = gfc_finish_block (&cond_block); + tree cond = build3_loc (input_location, COND_EXPR, + void_type_node, present, + cond_body, NULL_TREE); + gfc_add_expr_to_block (block, cond); + OMP_CLAUSE_SIZE (node) = var; + } + else + { + gfc_add_block_to_block (block, &cond_block); + OMP_CLAUSE_SIZE (node) = size; + } + } + if (n->sym->attr.dimension) + { + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + } + else if (present + && TREE_CODE (decl) == INDIRECT_REF + && (TREE_CODE (TREE_OPERAND (decl, 0)) + == INDIRECT_REF)) + { + /* A single indirectref is handled by the middle end. */ + gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl))); + decl = TREE_OPERAND (decl, 0); + decl = gfc_build_cond_assign_expr (block, present, decl, + null_pointer_node); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl); + } + else + OMP_CLAUSE_DECL (node) = decl; + } + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && n->expr->ref->type == REF_ARRAY + && !n->expr->ref->next) + { + /* An array element or array section which is not part of a + derived type, etc. */ + bool element = n->expr->ref->u.ar.type == AR_ELEMENT; + gfc_trans_omp_array_section (block, n, decl, element, + GOMP_MAP_POINTER, node, node2, + node3, node4); + } + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && (n->expr->ref->type == REF_COMPONENT + || n->expr->ref->type == REF_ARRAY) + && lastref + && lastref->type == REF_COMPONENT + && lastref->u.c.component->ts.type != BT_CLASS + && lastref->u.c.component->ts.type != BT_DERIVED + && !lastref->u.c.component->attr.dimension) + { + /* Derived type access with last component being a scalar. */ + gfc_init_se (&se, NULL); + + gfc_conv_expr (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + /* For BT_CHARACTER a pointer is returned. */ + OMP_CLAUSE_DECL (node) + = POINTER_TYPE_P (TREE_TYPE (se.expr)) + ? build_fold_indirect_ref (se.expr) : se.expr; + gfc_add_block_to_block (block, &se.post); + if (pointer || allocatable) + { + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + gomp_map_kind kind + = (openacc ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); + OMP_CLAUSE_SET_MAP_KIND (node2, kind); + OMP_CLAUSE_DECL (node2) + = POINTER_TYPE_P (TREE_TYPE (se.expr)) + ? se.expr + : gfc_build_addr_expr (NULL, se.expr); + OMP_CLAUSE_SIZE (node2) = size_int (0); + if (!openacc + && n->expr->ts.type == BT_CHARACTER + && n->expr->ts.deferred) + { + gcc_assert (se.string_length); + tree tmp + = gfc_get_char_type (n->expr->ts.kind); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, size_type_node, + fold_convert (size_type_node, + se.string_length), + TYPE_SIZE_UNIT (tmp)); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO); + OMP_CLAUSE_DECL (node3) = se.string_length; + OMP_CLAUSE_SIZE (node3) + = TYPE_SIZE_UNIT (gfc_charlen_type_node); + } + } + } + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && (n->expr->ref->type == REF_COMPONENT + || n->expr->ref->type == REF_ARRAY)) + { + gfc_init_se (&se, NULL); + se.expr = gfc_maybe_dereference_var (n->sym, decl); + + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + { + if (ref->u.c.sym->attr.extension) + conv_parent_component_references (&se, ref); + + gfc_conv_component_ref (&se, ref); + } + else if (ref->type == REF_ARRAY) + { + if (ref->u.ar.type == AR_ELEMENT && ref->next) + gfc_conv_array_ref (&se, &ref->u.ar, n->expr, + &n->expr->where); + else + gcc_assert (!ref->next); + } + else + sorry ("unhandled expression type"); + } + + tree inner = se.expr; + + /* Last component is a derived type or class pointer. */ + if (lastref->type == REF_COMPONENT + && (lastref->u.c.component->ts.type == BT_DERIVED + || lastref->u.c.component->ts.type == BT_CLASS)) + { + if (pointer || (openacc && allocatable)) + { + tree data, size; + + if (lastref->u.c.component->ts.type == BT_CLASS) + { + data = gfc_class_data_get (inner); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (data))); + data = build_fold_indirect_ref (data); + size = gfc_class_vtab_size_get (inner); + } + else /* BT_DERIVED. */ + { + data = inner; + size = TYPE_SIZE_UNIT (TREE_TYPE (inner)); + } + + OMP_CLAUSE_DECL (node) = data; + OMP_CLAUSE_SIZE (node) = size; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, + openacc + ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); + OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data); + OMP_CLAUSE_SIZE (node2) = size_int (0); + } + else + { + OMP_CLAUSE_DECL (node) = inner; + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (inner)); + } + } + else if (lastref->type == REF_ARRAY + && lastref->u.ar.type == AR_FULL) + { + /* Just pass the (auto-dereferenced) decl through for + bare attach and detach clauses. */ + if (n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH) + { + OMP_CLAUSE_DECL (node) = inner; + OMP_CLAUSE_SIZE (node) = size_zero_node; + goto finalize_map_clause; + } + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) + { + gomp_map_kind map_kind; + tree desc_node; + tree type = TREE_TYPE (inner); + tree ptr = gfc_conv_descriptor_data_get (inner); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + int rank = GFC_TYPE_ARRAY_RANK (type); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, inner, rank); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node))) + map_kind = GOMP_MAP_TO; + else if (n->u.map_op == OMP_MAP_RELEASE + || n->u.map_op == OMP_MAP_DELETE) + map_kind = OMP_CLAUSE_MAP_KIND (node); + else + map_kind = GOMP_MAP_ALLOC; + if (!openacc + && n->expr->ts.type == BT_CHARACTER + && n->expr->ts.deferred) + { + gcc_assert (se.string_length); + tree len = fold_convert (size_type_node, + se.string_length); + elemsz = gfc_get_char_type (n->expr->ts.kind); + elemsz = TYPE_SIZE_UNIT (elemsz); + elemsz = fold_build2 (MULT_EXPR, size_type_node, + len, elemsz); + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); + OMP_CLAUSE_DECL (node4) = se.string_length; + OMP_CLAUSE_SIZE (node4) + = TYPE_SIZE_UNIT (gfc_charlen_type_node); + } + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + desc_node = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + if (openacc) + OMP_CLAUSE_SET_MAP_KIND (desc_node, + GOMP_MAP_TO_PSET); + else + OMP_CLAUSE_SET_MAP_KIND (desc_node, map_kind); + OMP_CLAUSE_DECL (desc_node) = inner; + OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type); + if (openacc) + node2 = desc_node; + else + { + node2 = node; + node = desc_node; /* Put first. */ + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, + openacc + ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (inner); + /* Similar to gfc_trans_omp_array_section (details + there), we add/keep the cast for OpenMP to prevent + that an 'alloc:' gets added for node3 ('desc.data') + as that is part of the whole descriptor (node3). + TODO: Remove once the ME handles this properly. */ + if (!openacc) + OMP_CLAUSE_DECL (node3) + = fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)), + OMP_CLAUSE_DECL (node3)); + else + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + OMP_CLAUSE_SIZE (node3) = size_int (0); + } + else + OMP_CLAUSE_DECL (node) = inner; + } + else if (lastref->type == REF_ARRAY) + { + /* An array element or section. */ + bool element = lastref->u.ar.type == AR_ELEMENT; + gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); + gfc_trans_omp_array_section (block, n, inner, element, + kind, node, node2, node3, + node4); + } + else + gcc_unreachable (); + } + else + sorry ("unhandled expression"); + + finalize_map_clause: + + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + if (node2) + omp_clauses = gfc_trans_add_clause (node2, omp_clauses); + if (node3) + omp_clauses = gfc_trans_add_clause (node3, omp_clauses); + if (node4) + omp_clauses = gfc_trans_add_clause (node4, omp_clauses); + } + break; + case OMP_LIST_TO: + case OMP_LIST_FROM: + case OMP_LIST_CACHE: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.referenced) + continue; + + switch (list) + { + case OMP_LIST_TO: + clause_code = OMP_CLAUSE_TO; + break; + case OMP_LIST_FROM: + clause_code = OMP_CLAUSE_FROM; + break; + case OMP_LIST_CACHE: + clause_code = OMP_CLAUSE__CACHE_; + break; + default: + gcc_unreachable (); + } + tree node = build_omp_clause (input_location, clause_code); + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + { + tree decl = gfc_trans_omp_variable (n->sym, false); + if (gfc_omp_privatize_by_reference (decl)) + { + if (gfc_omp_is_allocatable_or_ptr (decl)) + decl = build_fold_indirect_ref (decl); + decl = build_fold_indirect_ref (decl); + } + else if (DECL_P (decl)) + TREE_ADDRESSABLE (decl) = 1; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, decl, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + else + { + OMP_CLAUSE_DECL (node) = decl; + if (gfc_omp_is_allocatable_or_ptr (decl)) + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl))); + } + } + else + { + tree ptr; + gfc_init_se (&se, NULL); + if (n->expr->ref->u.ar.type == AR_ELEMENT) + { + gfc_conv_expr_reference (&se, n->expr); + ptr = se.expr; + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gfc_add_block_to_block (block, &se.post); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + break; + default: + break; + } + } + + if (clauses->if_expr) + { + tree if_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->if_expr); + gfc_add_block_to_block (block, &se.pre); + if_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); + OMP_CLAUSE_IF_MODIFIER (c) = ERROR_MARK; + OMP_CLAUSE_IF_EXPR (c) = if_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + for (ifc = 0; ifc < OMP_IF_LAST; ifc++) + if (clauses->if_exprs[ifc]) + { + tree if_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->if_exprs[ifc]); + gfc_add_block_to_block (block, &se.pre); + if_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); + switch (ifc) + { + case OMP_IF_CANCEL: + OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST; + break; + case OMP_IF_PARALLEL: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL; + break; + case OMP_IF_SIMD: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD; + break; + case OMP_IF_TASK: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK; + break; + case OMP_IF_TASKLOOP: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASKLOOP; + break; + case OMP_IF_TARGET: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET; + break; + case OMP_IF_TARGET_DATA: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_DATA; + break; + case OMP_IF_TARGET_UPDATE: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_UPDATE; + break; + case OMP_IF_TARGET_ENTER_DATA: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_ENTER_DATA; + break; + case OMP_IF_TARGET_EXIT_DATA: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_TARGET_EXIT_DATA; + break; + default: + gcc_unreachable (); + } + OMP_CLAUSE_IF_EXPR (c) = if_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->final_expr) + { + tree final_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->final_expr); + gfc_add_block_to_block (block, &se.pre); + final_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINAL); + OMP_CLAUSE_FINAL_EXPR (c) = final_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->num_threads) + { + tree num_threads; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->num_threads); + gfc_add_block_to_block (block, &se.pre); + num_threads = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_THREADS); + OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + chunk_size = NULL_TREE; + if (clauses->chunk_size) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->chunk_size); + gfc_add_block_to_block (block, &se.pre); + chunk_size = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + + if (clauses->sched_kind != OMP_SCHED_NONE) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SCHEDULE); + OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size; + switch (clauses->sched_kind) + { + case OMP_SCHED_STATIC: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC; + break; + case OMP_SCHED_DYNAMIC: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC; + break; + case OMP_SCHED_GUIDED: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED; + break; + case OMP_SCHED_RUNTIME: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME; + break; + case OMP_SCHED_AUTO: + OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_AUTO; + break; + default: + gcc_unreachable (); + } + if (clauses->sched_monotonic) + OMP_CLAUSE_SCHEDULE_KIND (c) + = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) + | OMP_CLAUSE_SCHEDULE_MONOTONIC); + else if (clauses->sched_nonmonotonic) + OMP_CLAUSE_SCHEDULE_KIND (c) + = (omp_clause_schedule_kind) (OMP_CLAUSE_SCHEDULE_KIND (c) + | OMP_CLAUSE_SCHEDULE_NONMONOTONIC); + if (clauses->sched_simd) + OMP_CLAUSE_SCHEDULE_SIMD (c) = 1; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULT); + switch (clauses->default_sharing) + { + case OMP_DEFAULT_NONE: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE; + break; + case OMP_DEFAULT_SHARED: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED; + break; + case OMP_DEFAULT_PRIVATE: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE; + break; + case OMP_DEFAULT_FIRSTPRIVATE: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; + break; + case OMP_DEFAULT_PRESENT: + OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRESENT; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->nowait) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOWAIT); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->ordered) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDERED); + OMP_CLAUSE_ORDERED_EXPR (c) + = clauses->orderedc ? build_int_cst (integer_type_node, + clauses->orderedc) : NULL_TREE; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->order_concurrent) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER); + OMP_CLAUSE_ORDER_UNCONSTRAINED (c) = clauses->order_unconstrained; + OMP_CLAUSE_ORDER_REPRODUCIBLE (c) = clauses->order_reproducible; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->untied) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->mergeable) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_MERGEABLE); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->collapse) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_COLLAPSE); + OMP_CLAUSE_COLLAPSE_EXPR (c) + = build_int_cst (integer_type_node, clauses->collapse); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->inbranch) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INBRANCH); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->notinbranch) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOTINBRANCH); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + switch (clauses->cancel) + { + case OMP_CANCEL_UNKNOWN: + break; + case OMP_CANCEL_PARALLEL: + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PARALLEL); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + case OMP_CANCEL_SECTIONS: + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SECTIONS); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + case OMP_CANCEL_DO: + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FOR); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + case OMP_CANCEL_TASKGROUP: + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TASKGROUP); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + break; + } + + if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PROC_BIND); + switch (clauses->proc_bind) + { + case OMP_PROC_BIND_PRIMARY: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_PRIMARY; + break; + case OMP_PROC_BIND_MASTER: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER; + break; + case OMP_PROC_BIND_SPREAD: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD; + break; + case OMP_PROC_BIND_CLOSE: + OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->safelen_expr) + { + tree safelen_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->safelen_expr); + gfc_add_block_to_block (block, &se.pre); + safelen_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SAFELEN); + OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->simdlen_expr) + { + if (declare_simd) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN); + OMP_CLAUSE_SIMDLEN_EXPR (c) + = gfc_conv_constant_to_tree (clauses->simdlen_expr); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + else + { + tree simdlen_var; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->simdlen_expr); + gfc_add_block_to_block (block, &se.pre); + simdlen_var = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMDLEN); + OMP_CLAUSE_SIMDLEN_EXPR (c) = simdlen_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + } + + if (clauses->num_teams_upper) + { + tree num_teams_lower = NULL_TREE, num_teams_upper; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->num_teams_upper); + gfc_add_block_to_block (block, &se.pre); + num_teams_upper = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + if (clauses->num_teams_lower) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->num_teams_lower); + gfc_add_block_to_block (block, &se.pre); + num_teams_lower = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TEAMS); + OMP_CLAUSE_NUM_TEAMS_LOWER_EXPR (c) = num_teams_lower; + OMP_CLAUSE_NUM_TEAMS_UPPER_EXPR (c) = num_teams_upper; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->device) + { + tree device; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->device); + gfc_add_block_to_block (block, &se.pre); + device = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEVICE); + OMP_CLAUSE_DEVICE_ID (c) = device; + + if (clauses->ancestor) + OMP_CLAUSE_DEVICE_ANCESTOR (c) = 1; + + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->thread_limit) + { + tree thread_limit; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->thread_limit); + gfc_add_block_to_block (block, &se.pre); + thread_limit = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREAD_LIMIT); + OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + chunk_size = NULL_TREE; + if (clauses->dist_chunk_size) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->dist_chunk_size); + gfc_add_block_to_block (block, &se.pre); + chunk_size = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + + if (clauses->dist_sched_kind != OMP_SCHED_NONE) + { + c = build_omp_clause (gfc_get_location (&where), + OMP_CLAUSE_DIST_SCHEDULE); + OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->grainsize) + { + tree grainsize; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->grainsize); + gfc_add_block_to_block (block, &se.pre); + grainsize = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GRAINSIZE); + OMP_CLAUSE_GRAINSIZE_EXPR (c) = grainsize; + if (clauses->grainsize_strict) + OMP_CLAUSE_GRAINSIZE_STRICT (c) = 1; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->num_tasks) + { + tree num_tasks; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->num_tasks); + gfc_add_block_to_block (block, &se.pre); + num_tasks = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_TASKS); + OMP_CLAUSE_NUM_TASKS_EXPR (c) = num_tasks; + if (clauses->num_tasks_strict) + OMP_CLAUSE_NUM_TASKS_STRICT (c) = 1; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->priority) + { + tree priority; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->priority); + gfc_add_block_to_block (block, &se.pre); + priority = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_PRIORITY); + OMP_CLAUSE_PRIORITY_EXPR (c) = priority; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->detach) + { + tree detach; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->detach); + gfc_add_block_to_block (block, &se.pre); + detach = se.expr; + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DETACH); + TREE_ADDRESSABLE (detach) = 1; + OMP_CLAUSE_DECL (c) = detach; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->filter) + { + tree filter; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->filter); + gfc_add_block_to_block (block, &se.pre); + filter = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FILTER); + OMP_CLAUSE_FILTER_EXPR (c) = filter; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->hint) + { + tree hint; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->hint); + gfc_add_block_to_block (block, &se.pre); + hint = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_HINT); + OMP_CLAUSE_HINT_EXPR (c) = hint; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->simd) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SIMD); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->threads) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_THREADS); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->nogroup) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOGROUP); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) + { + if (clauses->defaultmap[i] == OMP_DEFAULTMAP_UNSET) + continue; + enum omp_clause_defaultmap_kind behavior, category; + switch ((gfc_omp_defaultmap_category) i) + { + case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; + break; + case OMP_DEFAULTMAP_CAT_SCALAR: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_SCALAR; + break; + case OMP_DEFAULTMAP_CAT_AGGREGATE: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_AGGREGATE; + break; + case OMP_DEFAULTMAP_CAT_ALLOCATABLE: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_ALLOCATABLE; + break; + case OMP_DEFAULTMAP_CAT_POINTER: + category = OMP_CLAUSE_DEFAULTMAP_CATEGORY_POINTER; + break; + default: gcc_unreachable (); + } + switch (clauses->defaultmap[i]) + { + case OMP_DEFAULTMAP_ALLOC: + behavior = OMP_CLAUSE_DEFAULTMAP_ALLOC; + break; + case OMP_DEFAULTMAP_TO: behavior = OMP_CLAUSE_DEFAULTMAP_TO; break; + case OMP_DEFAULTMAP_FROM: behavior = OMP_CLAUSE_DEFAULTMAP_FROM; break; + case OMP_DEFAULTMAP_TOFROM: + behavior = OMP_CLAUSE_DEFAULTMAP_TOFROM; + break; + case OMP_DEFAULTMAP_FIRSTPRIVATE: + behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE; + break; + case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break; + case OMP_DEFAULTMAP_DEFAULT: + behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT; + break; + default: gcc_unreachable (); + } + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEFAULTMAP); + OMP_CLAUSE_DEFAULTMAP_SET_KIND (c, behavior, category); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->depend_source) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_DEPEND); + OMP_CLAUSE_DEPEND_KIND (c) = OMP_CLAUSE_DEPEND_SOURCE; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->async) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ASYNC); + if (clauses->async_expr) + OMP_CLAUSE_ASYNC_EXPR (c) + = gfc_convert_expr_to_tree (block, clauses->async_expr); + else + OMP_CLAUSE_ASYNC_EXPR (c) = NULL; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->seq) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_SEQ); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->par_auto) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_AUTO); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->if_present) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF_PRESENT); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->finalize) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_FINALIZE); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->independent) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_INDEPENDENT); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->wait_list) + { + gfc_expr_list *el; + + for (el = clauses->wait_list; el; el = el->next) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WAIT); + OMP_CLAUSE_DECL (c) = gfc_convert_expr_to_tree (block, el->expr); + OMP_CLAUSE_CHAIN (c) = omp_clauses; + omp_clauses = c; + } + } + if (clauses->num_gangs_expr) + { + tree num_gangs_var + = gfc_convert_expr_to_tree (block, clauses->num_gangs_expr); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_GANGS); + OMP_CLAUSE_NUM_GANGS_EXPR (c) = num_gangs_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->num_workers_expr) + { + tree num_workers_var + = gfc_convert_expr_to_tree (block, clauses->num_workers_expr); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NUM_WORKERS); + OMP_CLAUSE_NUM_WORKERS_EXPR (c) = num_workers_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->vector_length_expr) + { + tree vector_length_var + = gfc_convert_expr_to_tree (block, clauses->vector_length_expr); + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR_LENGTH); + OMP_CLAUSE_VECTOR_LENGTH_EXPR (c) = vector_length_var; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->tile_list) + { + vec *tvec; + gfc_expr_list *el; + + vec_alloc (tvec, 4); + + for (el = clauses->tile_list; el; el = el->next) + vec_safe_push (tvec, gfc_convert_expr_to_tree (block, el->expr)); + + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_TILE); + OMP_CLAUSE_TILE_LIST (c) = build_tree_list_vec (tvec); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + tvec->truncate (0); + } + if (clauses->vector) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_VECTOR); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + + if (clauses->vector_expr) + { + tree vector_var + = gfc_convert_expr_to_tree (block, clauses->vector_expr); + OMP_CLAUSE_VECTOR_EXPR (c) = vector_var; + + /* TODO: We're not capturing location information for individual + clauses. However, if we have an expression attached to the + clause, that one provides better location information. */ + OMP_CLAUSE_LOCATION (c) + = gfc_get_location (&clauses->vector_expr->where); + } + } + if (clauses->worker) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_WORKER); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + + if (clauses->worker_expr) + { + tree worker_var + = gfc_convert_expr_to_tree (block, clauses->worker_expr); + OMP_CLAUSE_WORKER_EXPR (c) = worker_var; + + /* TODO: We're not capturing location information for individual + clauses. However, if we have an expression attached to the + clause, that one provides better location information. */ + OMP_CLAUSE_LOCATION (c) + = gfc_get_location (&clauses->worker_expr->where); + } + } + if (clauses->gang) + { + tree arg; + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_GANG); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + + if (clauses->gang_num_expr) + { + arg = gfc_convert_expr_to_tree (block, clauses->gang_num_expr); + OMP_CLAUSE_GANG_EXPR (c) = arg; + + /* TODO: We're not capturing location information for individual + clauses. However, if we have an expression attached to the + clause, that one provides better location information. */ + OMP_CLAUSE_LOCATION (c) + = gfc_get_location (&clauses->gang_num_expr->where); + } + + if (clauses->gang_static) + { + arg = clauses->gang_static_expr + ? gfc_convert_expr_to_tree (block, clauses->gang_static_expr) + : integer_minus_one_node; + OMP_CLAUSE_GANG_STATIC_EXPR (c) = arg; + } + } + if (clauses->bind != OMP_BIND_UNSET) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_BIND); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + switch (clauses->bind) + { + case OMP_BIND_TEAMS: + OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_TEAMS; + break; + case OMP_BIND_PARALLEL: + OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_PARALLEL; + break; + case OMP_BIND_THREAD: + OMP_CLAUSE_BIND_KIND (c) = OMP_CLAUSE_BIND_THREAD; + break; + default: + gcc_unreachable (); + } + } + /* OpenACC 'nohost' clauses cannot appear here. */ + gcc_checking_assert (!clauses->nohost); + + return nreverse (omp_clauses); +} + +/* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ + +static tree +gfc_trans_omp_code (gfc_code *code, bool force_empty) +{ + tree stmt; + + pushlevel (); + stmt = gfc_trans_code (code); + if (TREE_CODE (stmt) != BIND_EXPR) + { + if (!IS_EMPTY_STMT (stmt) || force_empty) + { + tree block = poplevel (1, 0); + stmt = build3_v (BIND_EXPR, NULL, stmt, block); + } + else + poplevel (0, 0); + } + else + poplevel (0, 0); + return stmt; +} + +/* Translate OpenACC 'parallel', 'kernels', 'serial', 'data', 'host_data' + construct. */ + +static tree +gfc_trans_oacc_construct (gfc_code *code) +{ + stmtblock_t block; + tree stmt, oacc_clauses; + enum tree_code construct_code; + + switch (code->op) + { + case EXEC_OACC_PARALLEL: + construct_code = OACC_PARALLEL; + break; + case EXEC_OACC_KERNELS: + construct_code = OACC_KERNELS; + break; + case EXEC_OACC_SERIAL: + construct_code = OACC_SERIAL; + break; + case EXEC_OACC_DATA: + construct_code = OACC_DATA; + break; + case EXEC_OACC_HOST_DATA: + construct_code = OACC_HOST_DATA; + break; + default: + gcc_unreachable (); + } + + gfc_start_block (&block); + oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc, false, true); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build2_loc (gfc_get_location (&code->loc), construct_code, + void_type_node, stmt, oacc_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +/* update, enter_data, exit_data, cache. */ +static tree +gfc_trans_oacc_executable_directive (gfc_code *code) +{ + stmtblock_t block; + tree stmt, oacc_clauses; + enum tree_code construct_code; + + switch (code->op) + { + case EXEC_OACC_UPDATE: + construct_code = OACC_UPDATE; + break; + case EXEC_OACC_ENTER_DATA: + construct_code = OACC_ENTER_DATA; + break; + case EXEC_OACC_EXIT_DATA: + construct_code = OACC_EXIT_DATA; + break; + case EXEC_OACC_CACHE: + construct_code = OACC_CACHE; + break; + default: + gcc_unreachable (); + } + + gfc_start_block (&block); + oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc, false, true); + stmt = build1_loc (input_location, construct_code, void_type_node, + oacc_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_oacc_wait_directive (gfc_code *code) +{ + stmtblock_t block; + tree stmt, t; + vec *args; + int nparms = 0; + gfc_expr_list *el; + gfc_omp_clauses *clauses = code->ext.omp_clauses; + location_t loc = input_location; + + for (el = clauses->wait_list; el; el = el->next) + nparms++; + + vec_alloc (args, nparms + 2); + stmt = builtin_decl_explicit (BUILT_IN_GOACC_WAIT); + + gfc_start_block (&block); + + if (clauses->async_expr) + t = gfc_convert_expr_to_tree (&block, clauses->async_expr); + else + t = build_int_cst (integer_type_node, -2); + + args->quick_push (t); + args->quick_push (build_int_cst (integer_type_node, nparms)); + + for (el = clauses->wait_list; el; el = el->next) + args->quick_push (gfc_convert_expr_to_tree (&block, el->expr)); + + stmt = build_call_expr_loc_vec (loc, stmt, args); + gfc_add_expr_to_block (&block, stmt); + + vec_free (args); + + return gfc_finish_block (&block); +} + +static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *); +static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); + +static tree +gfc_trans_omp_atomic (gfc_code *code) +{ + gfc_code *atomic_code = code->block; + gfc_se lse; + gfc_se rse; + gfc_se vse; + gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL; + gfc_symbol *var; + stmtblock_t block; + tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE; + enum tree_code op = ERROR_MARK; + enum tree_code aop = OMP_ATOMIC; + bool var_on_left = false, else_branch = false; + enum omp_memory_order mo, fail_mo; + switch (atomic_code->ext.omp_clauses->memorder) + { + case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break; + case OMP_MEMORDER_ACQ_REL: mo = OMP_MEMORY_ORDER_ACQ_REL; break; + case OMP_MEMORDER_ACQUIRE: mo = OMP_MEMORY_ORDER_ACQUIRE; break; + case OMP_MEMORDER_RELAXED: mo = OMP_MEMORY_ORDER_RELAXED; break; + case OMP_MEMORDER_RELEASE: mo = OMP_MEMORY_ORDER_RELEASE; break; + case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break; + default: gcc_unreachable (); + } + switch (atomic_code->ext.omp_clauses->fail) + { + case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break; + case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break; + case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break; + case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break; + default: gcc_unreachable (); + } + mo = (omp_memory_order) (mo | fail_mo); + + code = code->block->next; + if (atomic_code->ext.omp_clauses->compare) + { + gfc_expr *comp_expr; + if (code->op == EXEC_IF) + { + comp_expr = code->block->expr1; + gcc_assert (code->block->next->op == EXEC_ASSIGN); + expr1 = code->block->next->expr1; + expr2 = code->block->next->expr2; + if (code->block->block) + { + gcc_assert (atomic_code->ext.omp_clauses->capture + && code->block->block->next->op == EXEC_ASSIGN); + else_branch = true; + aop = OMP_ATOMIC_CAPTURE_OLD; + capture_expr1 = code->block->block->next->expr1; + capture_expr2 = code->block->block->next->expr2; + } + else if (atomic_code->ext.omp_clauses->capture) + { + gcc_assert (code->next->op == EXEC_ASSIGN); + aop = OMP_ATOMIC_CAPTURE_NEW; + capture_expr1 = code->next->expr1; + capture_expr2 = code->next->expr2; + } + } + else + { + gcc_assert (atomic_code->ext.omp_clauses->capture + && code->op == EXEC_ASSIGN + && code->next->op == EXEC_IF); + aop = OMP_ATOMIC_CAPTURE_OLD; + capture_expr1 = code->expr1; + capture_expr2 = code->expr2; + expr1 = code->next->block->next->expr1; + expr2 = code->next->block->next->expr2; + comp_expr = code->next->block->expr1; + } + gfc_init_se (&lse, NULL); + gfc_conv_expr (&lse, comp_expr->value.op.op2); + gfc_add_block_to_block (&block, &lse.pre); + compare = lse.expr; + var = expr1->symtree->n.sym; + } + else + { + gcc_assert (code->op == EXEC_ASSIGN); + expr1 = code->expr1; + expr2 = code->expr2; + if (atomic_code->ext.omp_clauses->capture + && (expr2->expr_type == EXPR_VARIABLE + || (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym + && expr2->value.function.isym->id == GFC_ISYM_CONVERSION + && (expr2->value.function.actual->expr->expr_type + == EXPR_VARIABLE)))) + { + capture_expr1 = expr1; + capture_expr2 = expr2; + expr1 = code->next->expr1; + expr2 = code->next->expr2; + aop = OMP_ATOMIC_CAPTURE_OLD; + } + else if (atomic_code->ext.omp_clauses->capture) + { + aop = OMP_ATOMIC_CAPTURE_NEW; + capture_expr1 = code->next->expr1; + capture_expr2 = code->next->expr2; + } + var = expr1->symtree->n.sym; + } + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + gfc_init_se (&vse, NULL); + gfc_start_block (&block); + + if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) + != GFC_OMP_ATOMIC_WRITE) + && expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym + && expr2->value.function.isym->id == GFC_ISYM_CONVERSION) + expr2 = expr2->value.function.actual->expr; + + if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) + == GFC_OMP_ATOMIC_READ) + { + gfc_conv_expr (&vse, expr1); + gfc_add_block_to_block (&block, &vse.pre); + + gfc_conv_expr (&lse, expr2); + gfc_add_block_to_block (&block, &lse.pre); + type = TREE_TYPE (lse.expr); + lhsaddr = gfc_build_addr_expr (NULL, lse.expr); + + x = build1 (OMP_ATOMIC_READ, type, lhsaddr); + OMP_ATOMIC_MEMORY_ORDER (x) = mo; + x = convert (TREE_TYPE (vse.expr), x); + gfc_add_modify (&block, vse.expr, x); + + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_block_to_block (&block, &rse.pre); + + return gfc_finish_block (&block); + } + + if (capture_expr2 + && capture_expr2->expr_type == EXPR_FUNCTION + && capture_expr2->value.function.isym + && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION) + capture_expr2 = capture_expr2->value.function.actual->expr; + gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE); + + if (aop == OMP_ATOMIC_CAPTURE_OLD) + { + gfc_conv_expr (&vse, capture_expr1); + gfc_add_block_to_block (&block, &vse.pre); + gfc_conv_expr (&lse, capture_expr2); + gfc_add_block_to_block (&block, &lse.pre); + gfc_init_se (&lse, NULL); + } + + gfc_conv_expr (&lse, expr1); + gfc_add_block_to_block (&block, &lse.pre); + type = TREE_TYPE (lse.expr); + lhsaddr = gfc_build_addr_expr (NULL, lse.expr); + + if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) + == GFC_OMP_ATOMIC_WRITE) + || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP) + || compare) + { + gfc_conv_expr (&rse, expr2); + gfc_add_block_to_block (&block, &rse.pre); + } + else if (expr2->expr_type == EXPR_OP) + { + gfc_expr *e; + switch (expr2->value.op.op) + { + case INTRINSIC_PLUS: + op = PLUS_EXPR; + break; + case INTRINSIC_TIMES: + op = MULT_EXPR; + break; + case INTRINSIC_MINUS: + op = MINUS_EXPR; + break; + case INTRINSIC_DIVIDE: + if (expr2->ts.type == BT_INTEGER) + op = TRUNC_DIV_EXPR; + else + op = RDIV_EXPR; + break; + case INTRINSIC_AND: + op = TRUTH_ANDIF_EXPR; + break; + case INTRINSIC_OR: + op = TRUTH_ORIF_EXPR; + break; + case INTRINSIC_EQV: + op = EQ_EXPR; + break; + case INTRINSIC_NEQV: + op = NE_EXPR; + break; + default: + gcc_unreachable (); + } + e = expr2->value.op.op1; + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CONVERSION) + e = e->value.function.actual->expr; + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + { + expr2 = expr2->value.op.op2; + var_on_left = true; + } + else + { + e = expr2->value.op.op2; + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CONVERSION) + e = e->value.function.actual->expr; + gcc_assert (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var); + expr2 = expr2->value.op.op1; + var_on_left = false; + } + gfc_conv_expr (&rse, expr2); + gfc_add_block_to_block (&block, &rse.pre); + } + else + { + gcc_assert (expr2->expr_type == EXPR_FUNCTION); + switch (expr2->value.function.isym->id) + { + case GFC_ISYM_MIN: + op = MIN_EXPR; + break; + case GFC_ISYM_MAX: + op = MAX_EXPR; + break; + case GFC_ISYM_IAND: + op = BIT_AND_EXPR; + break; + case GFC_ISYM_IOR: + op = BIT_IOR_EXPR; + break; + case GFC_ISYM_IEOR: + op = BIT_XOR_EXPR; + break; + default: + gcc_unreachable (); + } + e = expr2->value.function.actual->expr; + if (e->expr_type == EXPR_FUNCTION + && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CONVERSION) + e = e->value.function.actual->expr; + gcc_assert (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var); + + gfc_conv_expr (&rse, expr2->value.function.actual->next->expr); + gfc_add_block_to_block (&block, &rse.pre); + if (expr2->value.function.actual->next->next != NULL) + { + tree accum = gfc_create_var (TREE_TYPE (rse.expr), NULL); + gfc_actual_arglist *arg; + + gfc_add_modify (&block, accum, rse.expr); + for (arg = expr2->value.function.actual->next->next; arg; + arg = arg->next) + { + gfc_init_block (&rse.pre); + gfc_conv_expr (&rse, arg->expr); + gfc_add_block_to_block (&block, &rse.pre); + x = fold_build2_loc (input_location, op, TREE_TYPE (accum), + accum, rse.expr); + gfc_add_modify (&block, accum, x); + } + + rse.expr = accum; + } + + expr2 = expr2->value.function.actual->next->expr; + } + + lhsaddr = save_expr (lhsaddr); + if (TREE_CODE (lhsaddr) != SAVE_EXPR + && (TREE_CODE (lhsaddr) != ADDR_EXPR + || !VAR_P (TREE_OPERAND (lhsaddr, 0)))) + { + /* Make sure LHS is simple enough so that goa_lhs_expr_p can recognize + it even after unsharing function body. */ + tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr)); + DECL_CONTEXT (var) = current_function_decl; + lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, + NULL_TREE, NULL_TREE); + } + + if (compare) + { + tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr)); + DECL_CONTEXT (var) = current_function_decl; + lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL, + NULL); + lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr); + compare = convert (TREE_TYPE (lse.expr), compare); + compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + lse.expr, compare); + } + + if (expr2->expr_type == EXPR_VARIABLE || compare) + rhs = rse.expr; + else + rhs = gfc_evaluate_now (rse.expr, &block); + + if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK) + == GFC_OMP_ATOMIC_WRITE) + || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP) + || compare) + x = rhs; + else + { + x = convert (TREE_TYPE (rhs), + build_fold_indirect_ref_loc (input_location, lhsaddr)); + if (var_on_left) + x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), x, rhs); + else + x = fold_build2_loc (input_location, op, TREE_TYPE (rhs), rhs, x); + } + + if (TREE_CODE (TREE_TYPE (rhs)) == COMPLEX_TYPE + && TREE_CODE (type) != COMPLEX_TYPE) + x = fold_build1_loc (input_location, REALPART_EXPR, + TREE_TYPE (TREE_TYPE (rhs)), x); + + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_block_to_block (&block, &rse.pre); + + if (aop == OMP_ATOMIC_CAPTURE_NEW) + { + gfc_conv_expr (&vse, capture_expr1); + gfc_add_block_to_block (&block, &vse.pre); + gfc_add_block_to_block (&block, &lse.pre); + } + + if (compare && else_branch) + { + tree var2 = create_tmp_var_raw (boolean_type_node); + DECL_CONTEXT (var2) = current_function_decl; + comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2, + boolean_false_node, NULL, NULL); + compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2), + var2, compare); + TREE_OPERAND (compare, 0) = comp_tgt; + compare = omit_one_operand_loc (input_location, boolean_type_node, + compare, comp_tgt); + } + + if (compare) + x = build3_loc (input_location, COND_EXPR, type, compare, + convert (type, x), lse.expr); + + if (aop == OMP_ATOMIC) + { + x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); + OMP_ATOMIC_MEMORY_ORDER (x) = mo; + OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; + gfc_add_expr_to_block (&block, x); + } + else + { + x = build2 (aop, type, lhsaddr, convert (type, x)); + OMP_ATOMIC_MEMORY_ORDER (x) = mo; + OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; + if (compare && else_branch) + { + tree vtmp = create_tmp_var_raw (TREE_TYPE (x)); + DECL_CONTEXT (vtmp) = current_function_decl; + x = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (vtmp), vtmp, x); + vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp, + build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL); + TREE_OPERAND (x, 0) = vtmp; + tree x2 = convert (TREE_TYPE (vse.expr), vtmp); + x2 = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (vse.expr), vse.expr, x2); + x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt, + void_node, x2); + x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x); + gfc_add_expr_to_block (&block, x); + } + else + { + x = convert (TREE_TYPE (vse.expr), x); + gfc_add_modify (&block, vse.expr, x); + } + } + + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_barrier (void) +{ + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER); + return build_call_expr_loc (input_location, decl, 0); +} + +static tree +gfc_trans_omp_cancel (gfc_code *code) +{ + int mask = 0; + tree ifc = boolean_true_node; + stmtblock_t block; + switch (code->ext.omp_clauses->cancel) + { + case OMP_CANCEL_PARALLEL: mask = 1; break; + case OMP_CANCEL_DO: mask = 2; break; + case OMP_CANCEL_SECTIONS: mask = 4; break; + case OMP_CANCEL_TASKGROUP: mask = 8; break; + default: gcc_unreachable (); + } + gfc_start_block (&block); + if (code->ext.omp_clauses->if_expr + || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]) + { + gfc_se se; + tree if_var; + + gcc_assert ((code->ext.omp_clauses->if_expr == NULL) + ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL)); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL + ? code->ext.omp_clauses->if_expr + : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]); + gfc_add_block_to_block (&block, &se.pre); + if_var = gfc_evaluate_now (se.expr, &block); + gfc_add_block_to_block (&block, &se.post); + tree type = TREE_TYPE (if_var); + ifc = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, if_var, + build_zero_cst (type)); + } + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL); + tree c_bool_type = TREE_TYPE (TREE_TYPE (decl)); + ifc = fold_convert (c_bool_type, ifc); + gfc_add_expr_to_block (&block, + build_call_expr_loc (input_location, decl, 2, + build_int_cst (integer_type_node, + mask), ifc)); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_cancellation_point (gfc_code *code) +{ + int mask = 0; + switch (code->ext.omp_clauses->cancel) + { + case OMP_CANCEL_PARALLEL: mask = 1; break; + case OMP_CANCEL_DO: mask = 2; break; + case OMP_CANCEL_SECTIONS: mask = 4; break; + case OMP_CANCEL_TASKGROUP: mask = 8; break; + default: gcc_unreachable (); + } + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT); + return build_call_expr_loc (input_location, decl, 1, + build_int_cst (integer_type_node, mask)); +} + +static tree +gfc_trans_omp_critical (gfc_code *code) +{ + stmtblock_t block; + tree stmt, name = NULL_TREE; + if (code->ext.omp_clauses->critical_name != NULL) + name = get_identifier (code->ext.omp_clauses->critical_name); + gfc_start_block (&block); + stmt = make_node (OMP_CRITICAL); + TREE_TYPE (stmt) = void_type_node; + OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next); + OMP_CRITICAL_NAME (stmt) = name; + OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, + code->ext.omp_clauses, + code->loc); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +typedef struct dovar_init_d { + tree var; + tree init; +} dovar_init; + + +static tree +gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, + gfc_omp_clauses *do_clauses, tree par_clauses) +{ + gfc_se se; + tree dovar, stmt, from, to, step, type, init, cond, incr, orig_decls; + tree count = NULL_TREE, cycle_label, tmp, omp_clauses; + stmtblock_t block; + stmtblock_t body; + gfc_omp_clauses *clauses = code->ext.omp_clauses; + int i, collapse = clauses->collapse; + vec inits = vNULL; + dovar_init *di; + unsigned ix; + vec *saved_doacross_steps = doacross_steps; + gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list; + + /* Both collapsed and tiled loops are lowered the same way. In + OpenACC, those clauses are not compatible, so prioritize the tile + clause, if present. */ + if (tile) + { + collapse = 0; + for (gfc_expr_list *el = tile; el; el = el->next) + collapse++; + } + + doacross_steps = NULL; + if (clauses->orderedc) + collapse = clauses->orderedc; + if (collapse <= 0) + collapse = 1; + + code = code->block->next; + gcc_assert (code->op == EXEC_DO); + + init = make_tree_vec (collapse); + cond = make_tree_vec (collapse); + incr = make_tree_vec (collapse); + orig_decls = clauses->orderedc ? make_tree_vec (collapse) : NULL_TREE; + + if (pblock == NULL) + { + gfc_start_block (&block); + pblock = █ + } + + /* simd schedule modifier is only useful for composite do simd and other + constructs including that, where gfc_trans_omp_do is only called + on the simd construct and DO's clauses are translated elsewhere. */ + do_clauses->sched_simd = false; + + omp_clauses = gfc_trans_omp_clauses (pblock, do_clauses, code->loc); + + for (i = 0; i < collapse; i++) + { + int simple = 0; + int dovar_found = 0; + tree dovar_decl; + + if (clauses) + { + gfc_omp_namelist *n = NULL; + if (op == EXEC_OMP_SIMD && collapse == 1) + for (n = clauses->lists[OMP_LIST_LINEAR]; + n != NULL; n = n->next) + if (code->ext.iterator->var->symtree->n.sym == n->sym) + { + dovar_found = 3; + break; + } + if (n == NULL && op != EXEC_OMP_DISTRIBUTE) + for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; + n != NULL; n = n->next) + if (code->ext.iterator->var->symtree->n.sym == n->sym) + { + dovar_found = 2; + break; + } + if (n == NULL) + for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next) + if (code->ext.iterator->var->symtree->n.sym == n->sym) + { + dovar_found = 1; + break; + } + } + + /* Evaluate all the expressions in the iterator. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->ext.iterator->var); + gfc_add_block_to_block (pblock, &se.pre); + dovar = se.expr; + type = TREE_TYPE (dovar); + gcc_assert (TREE_CODE (type) == INTEGER_TYPE); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->start); + gfc_add_block_to_block (pblock, &se.pre); + from = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->end); + gfc_add_block_to_block (pblock, &se.pre); + to = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->step); + gfc_add_block_to_block (pblock, &se.pre); + step = gfc_evaluate_now (se.expr, pblock); + dovar_decl = dovar; + + /* Special case simple loops. */ + if (VAR_P (dovar)) + { + if (integer_onep (step)) + simple = 1; + else if (tree_int_cst_equal (step, integer_minus_one_node)) + simple = -1; + } + else + dovar_decl + = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym, + false); + + /* Loop body. */ + if (simple) + { + TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, dovar, from); + /* The condition should not be folded. */ + TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0 + ? LE_EXPR : GE_EXPR, + logical_type_node, dovar, to); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, + type, dovar, step); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, + MODIFY_EXPR, + type, dovar, + TREE_VEC_ELT (incr, i)); + } + else + { + /* STEP is not 1 or -1. Use: + for (count = 0; count < (to + step - from) / step; count++) + { + dovar = from + count * step; + body; + cycle_label:; + } */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, type, step, from); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, to, tmp); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, type, tmp, + step); + tmp = gfc_evaluate_now (tmp, pblock); + count = gfc_create_var (type, "count"); + TREE_VEC_ELT (init, i) = build2_v (MODIFY_EXPR, count, + build_int_cst (type, 0)); + /* The condition should not be folded. */ + TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR, + logical_type_node, + count, tmp); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, + type, count, + build_int_cst (type, 1)); + TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, + MODIFY_EXPR, type, count, + TREE_VEC_ELT (incr, i)); + + /* Initialize DOVAR. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, type, count, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, from, tmp); + dovar_init e = {dovar, tmp}; + inits.safe_push (e); + if (clauses->orderedc) + { + if (doacross_steps == NULL) + vec_safe_grow_cleared (doacross_steps, clauses->orderedc, true); + (*doacross_steps)[i] = step; + } + } + if (orig_decls) + TREE_VEC_ELT (orig_decls, i) = dovar_decl; + + if (dovar_found == 3 + && op == EXEC_OMP_SIMD + && collapse == 1 + && !simple) + { + for (tmp = omp_clauses; tmp; tmp = OMP_CLAUSE_CHAIN (tmp)) + if (OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_LINEAR + && OMP_CLAUSE_DECL (tmp) == dovar) + { + OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; + break; + } + } + if (!dovar_found && op == EXEC_OMP_SIMD) + { + if (collapse == 1) + { + tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); + OMP_CLAUSE_LINEAR_STEP (tmp) = step; + OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; + OMP_CLAUSE_DECL (tmp) = dovar_decl; + omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); + } + if (!simple) + dovar_found = 3; + } + else if (!dovar_found && !simple) + { + tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); + OMP_CLAUSE_DECL (tmp) = dovar_decl; + omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); + } + if (dovar_found > 1) + { + tree c = NULL; + + tmp = NULL; + if (!simple) + { + /* If dovar is lastprivate, but different counter is used, + dovar += step needs to be added to + OMP_CLAUSE_LASTPRIVATE_STMT, otherwise the copied dovar + will have the value on entry of the last loop, rather + than value after iterator increment. */ + if (clauses->orderedc) + { + if (clauses->collapse <= 1 || i >= clauses->collapse) + tmp = count; + else + tmp = fold_build2_loc (input_location, PLUS_EXPR, + type, count, build_one_cst (type)); + tmp = fold_build2_loc (input_location, MULT_EXPR, type, + tmp, step); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, + from, tmp); + } + else + { + tmp = gfc_evaluate_now (step, pblock); + tmp = fold_build2_loc (input_location, PLUS_EXPR, type, + dovar, tmp); + } + tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, + dovar, tmp); + for (c = omp_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) + if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE + && OMP_CLAUSE_DECL (c) == dovar_decl) + { + OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp; + break; + } + else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR + && OMP_CLAUSE_DECL (c) == dovar_decl) + { + OMP_CLAUSE_LINEAR_STMT (c) = tmp; + break; + } + } + if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL) + { + for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c)) + if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE + && OMP_CLAUSE_DECL (c) == dovar_decl) + { + tree l = build_omp_clause (input_location, + OMP_CLAUSE_LASTPRIVATE); + if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c)) + OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1; + OMP_CLAUSE_DECL (l) = dovar_decl; + OMP_CLAUSE_CHAIN (l) = omp_clauses; + OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; + omp_clauses = l; + OMP_CLAUSE_SET_CODE (c, OMP_CLAUSE_SHARED); + break; + } + } + gcc_assert (simple || c != NULL); + } + if (!simple) + { + if (op != EXEC_OMP_SIMD || dovar_found == 1) + tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); + else if (collapse == 1) + { + tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); + OMP_CLAUSE_LINEAR_STEP (tmp) = build_int_cst (type, 1); + OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; + OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1; + } + else + tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); + OMP_CLAUSE_DECL (tmp) = count; + omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); + } + + if (i + 1 < collapse) + code = code->block->next; + } + + if (pblock != &block) + { + pushlevel (); + gfc_start_block (&block); + } + + gfc_start_block (&body); + + FOR_EACH_VEC_ELT (inits, ix, di) + gfc_add_modify (&body, di->var, di->init); + inits.release (); + + /* Cycle statement is implemented with a goto. Exit statement must not be + present for this loop. */ + cycle_label = gfc_build_label_decl (NULL_TREE); + + /* Put these labels where they can be found later. */ + + code->cycle_label = cycle_label; + code->exit_label = NULL_TREE; + + /* Main loop body. */ + if (clauses->lists[OMP_LIST_REDUCTION_INSCAN]) + { + gcc_assert (code->block->next->next->op == EXEC_OMP_SCAN); + gcc_assert (code->block->next->next->next->next == NULL); + locus *cloc = &code->block->next->next->loc; + location_t loc = gfc_get_location (cloc); + + gfc_code code2 = *code->block->next; + code2.next = NULL; + tmp = gfc_trans_code (&code2); + tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE); + SET_EXPR_LOCATION (tmp, loc); + gfc_add_expr_to_block (&body, tmp); + input_location = loc; + tree c = gfc_trans_omp_clauses (&body, + code->block->next->next->ext.omp_clauses, + *cloc); + code2 = *code->block->next->next->next; + code2.next = NULL; + tmp = gfc_trans_code (&code2); + tmp = build2 (OMP_SCAN, void_type_node, tmp, c); + SET_EXPR_LOCATION (tmp, loc); + } + else + tmp = gfc_trans_omp_code (code->block->next, true); + gfc_add_expr_to_block (&body, tmp); + + /* Label for cycle statements (if needed). */ + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + /* End of loop body. */ + switch (op) + { + case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break; + case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break; + case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break; + case EXEC_OMP_LOOP: stmt = make_node (OMP_LOOP); break; + case EXEC_OMP_TASKLOOP: stmt = make_node (OMP_TASKLOOP); break; + case EXEC_OACC_LOOP: stmt = make_node (OACC_LOOP); break; + default: gcc_unreachable (); + } + + TREE_TYPE (stmt) = void_type_node; + OMP_FOR_BODY (stmt) = gfc_finish_block (&body); + OMP_FOR_CLAUSES (stmt) = omp_clauses; + OMP_FOR_INIT (stmt) = init; + OMP_FOR_COND (stmt) = cond; + OMP_FOR_INCR (stmt) = incr; + if (orig_decls) + OMP_FOR_ORIG_DECLS (stmt) = orig_decls; + gfc_add_expr_to_block (&block, stmt); + + vec_free (doacross_steps); + doacross_steps = saved_doacross_steps; + + return gfc_finish_block (&block); +} + +/* Translate combined OpenACC 'parallel loop', 'kernels loop', 'serial loop' + construct. */ + +static tree +gfc_trans_oacc_combined_directive (gfc_code *code) +{ + stmtblock_t block, *pblock = NULL; + gfc_omp_clauses construct_clauses, loop_clauses; + tree stmt, oacc_clauses = NULL_TREE; + enum tree_code construct_code; + location_t loc = input_location; + + switch (code->op) + { + case EXEC_OACC_PARALLEL_LOOP: + construct_code = OACC_PARALLEL; + break; + case EXEC_OACC_KERNELS_LOOP: + construct_code = OACC_KERNELS; + break; + case EXEC_OACC_SERIAL_LOOP: + construct_code = OACC_SERIAL; + break; + default: + gcc_unreachable (); + } + + gfc_start_block (&block); + + memset (&loop_clauses, 0, sizeof (loop_clauses)); + if (code->ext.omp_clauses != NULL) + { + memcpy (&construct_clauses, code->ext.omp_clauses, + sizeof (construct_clauses)); + loop_clauses.collapse = construct_clauses.collapse; + loop_clauses.gang = construct_clauses.gang; + loop_clauses.gang_static = construct_clauses.gang_static; + loop_clauses.gang_num_expr = construct_clauses.gang_num_expr; + loop_clauses.gang_static_expr = construct_clauses.gang_static_expr; + loop_clauses.vector = construct_clauses.vector; + loop_clauses.vector_expr = construct_clauses.vector_expr; + loop_clauses.worker = construct_clauses.worker; + loop_clauses.worker_expr = construct_clauses.worker_expr; + loop_clauses.seq = construct_clauses.seq; + loop_clauses.par_auto = construct_clauses.par_auto; + loop_clauses.independent = construct_clauses.independent; + loop_clauses.tile_list = construct_clauses.tile_list; + loop_clauses.lists[OMP_LIST_PRIVATE] + = construct_clauses.lists[OMP_LIST_PRIVATE]; + loop_clauses.lists[OMP_LIST_REDUCTION] + = construct_clauses.lists[OMP_LIST_REDUCTION]; + construct_clauses.gang = false; + construct_clauses.gang_static = false; + construct_clauses.gang_num_expr = NULL; + construct_clauses.gang_static_expr = NULL; + construct_clauses.vector = false; + construct_clauses.vector_expr = NULL; + construct_clauses.worker = false; + construct_clauses.worker_expr = NULL; + construct_clauses.seq = false; + construct_clauses.par_auto = false; + construct_clauses.independent = false; + construct_clauses.independent = false; + construct_clauses.tile_list = NULL; + construct_clauses.lists[OMP_LIST_PRIVATE] = NULL; + if (construct_code == OACC_KERNELS) + construct_clauses.lists[OMP_LIST_REDUCTION] = NULL; + oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses, + code->loc, false, true); + } + if (!loop_clauses.seq) + pblock = █ + else + pushlevel (); + stmt = gfc_trans_omp_do (code, EXEC_OACC_LOOP, pblock, &loop_clauses, NULL); + protected_set_expr_location (stmt, loc); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + stmt = build2_loc (loc, construct_code, void_type_node, stmt, oacc_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_depobj (gfc_code *code) +{ + stmtblock_t block; + gfc_se se; + gfc_init_se (&se, NULL); + gfc_init_block (&block); + gfc_conv_expr (&se, code->ext.omp_clauses->depobj); + gcc_assert (se.pre.head == NULL && se.post.head == NULL); + tree depobj = se.expr; + location_t loc = EXPR_LOCATION (depobj); + if (!POINTER_TYPE_P (TREE_TYPE (depobj))) + depobj = gfc_build_addr_expr (NULL, depobj); + depobj = fold_convert (build_pointer_type_for_mode (ptr_type_node, + TYPE_MODE (ptr_type_node), + true), depobj); + gfc_omp_namelist *n = code->ext.omp_clauses->lists[OMP_LIST_DEPEND]; + if (n) + { + tree var; + if (n->expr) + var = gfc_convert_expr_to_tree (&block, n->expr); + else + var = gfc_get_symbol_decl (n->sym); + if (!POINTER_TYPE_P (TREE_TYPE (var))) + var = gfc_build_addr_expr (NULL, var); + depobj = save_expr (depobj); + tree r = build_fold_indirect_ref_loc (loc, depobj); + gfc_add_expr_to_block (&block, + build2 (MODIFY_EXPR, void_type_node, r, var)); + } + + /* Only one may be set. */ + gcc_assert (((int)(n != NULL) + (int)(code->ext.omp_clauses->destroy) + + (int)(code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET)) + == 1); + int k = -1; /* omp_clauses->destroy */ + if (!code->ext.omp_clauses->destroy) + switch (code->ext.omp_clauses->depobj_update != OMP_DEPEND_UNSET + ? code->ext.omp_clauses->depobj_update : n->u.depend_op) + { + case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break; + case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break; + case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break; + case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break; + default: gcc_unreachable (); + } + tree t = build_int_cst (ptr_type_node, k); + depobj = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (depobj), depobj, + TYPE_SIZE_UNIT (ptr_type_node)); + depobj = build_fold_indirect_ref_loc (loc, depobj); + gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, void_type_node, depobj, t)); + + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_error (gfc_code *code) +{ + stmtblock_t block; + gfc_se se; + tree len, message; + bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL; + tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR + : BUILT_IN_GOMP_WARNING); + gfc_start_block (&block); + gfc_init_se (&se, NULL ); + if (!code->ext.omp_clauses->message) + { + message = null_pointer_node; + len = build_int_cst (size_type_node, 0); + } + else + { + gfc_conv_expr (&se, code->ext.omp_clauses->message); + message = se.expr; + if (!POINTER_TYPE_P (TREE_TYPE (message))) + /* To ensure an ARRAY_TYPE is not passed as such. */ + message = gfc_build_addr_expr (NULL, message); + len = se.string_length; + } + gfc_add_block_to_block (&block, &se.pre); + gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl, + 2, message, len)); + gfc_add_block_to_block (&block, &se.post); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_flush (gfc_code *code) +{ + tree call; + if (!code->ext.omp_clauses + || code->ext.omp_clauses->memorder == OMP_MEMORDER_UNSET + || code->ext.omp_clauses->memorder == OMP_MEMORDER_SEQ_CST) + { + call = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE); + call = build_call_expr_loc (input_location, call, 0); + } + else + { + enum memmodel mo = MEMMODEL_LAST; + switch (code->ext.omp_clauses->memorder) + { + case OMP_MEMORDER_ACQ_REL: mo = MEMMODEL_ACQ_REL; break; + case OMP_MEMORDER_RELEASE: mo = MEMMODEL_RELEASE; break; + case OMP_MEMORDER_ACQUIRE: mo = MEMMODEL_ACQUIRE; break; + default: gcc_unreachable (); break; + } + call = builtin_decl_explicit (BUILT_IN_ATOMIC_THREAD_FENCE); + call = build_call_expr_loc (input_location, call, 1, + build_int_cst (integer_type_node, mo)); + } + return call; +} + +static tree +gfc_trans_omp_master (gfc_code *code) +{ + tree stmt = gfc_trans_code (code->block->next); + if (IS_EMPTY_STMT (stmt)) + return stmt; + return build1_v (OMP_MASTER, stmt); +} + +static tree +gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses) +{ + stmtblock_t block; + tree body = gfc_trans_code (code->block->next); + if (IS_EMPTY_STMT (body)) + return body; + if (!clauses) + clauses = code->ext.omp_clauses; + gfc_start_block (&block); + tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); + tree stmt = make_node (OMP_MASKED); + TREE_TYPE (stmt) = void_type_node; + OMP_MASKED_BODY (stmt) = body; + OMP_MASKED_CLAUSES (stmt) = omp_clauses; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + + +static tree +gfc_trans_omp_ordered (gfc_code *code) +{ + if (!flag_openmp) + { + if (!code->ext.omp_clauses->simd) + return gfc_trans_code (code->block ? code->block->next : NULL); + code->ext.omp_clauses->threads = 0; + } + tree omp_clauses = gfc_trans_omp_clauses (NULL, code->ext.omp_clauses, + code->loc); + return build2_loc (input_location, OMP_ORDERED, void_type_node, + code->block ? gfc_trans_code (code->block->next) + : NULL_TREE, omp_clauses); +} + +static tree +gfc_trans_omp_parallel (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + pushlevel (); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +enum +{ + GFC_OMP_SPLIT_SIMD, + GFC_OMP_SPLIT_DO, + GFC_OMP_SPLIT_PARALLEL, + GFC_OMP_SPLIT_DISTRIBUTE, + GFC_OMP_SPLIT_TEAMS, + GFC_OMP_SPLIT_TARGET, + GFC_OMP_SPLIT_TASKLOOP, + GFC_OMP_SPLIT_MASKED, + GFC_OMP_SPLIT_NUM +}; + +enum +{ + GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD), + GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO), + GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL), + GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE), + GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS), + GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET), + GFC_OMP_MASK_TASKLOOP = (1 << GFC_OMP_SPLIT_TASKLOOP), + GFC_OMP_MASK_MASKED = (1 << GFC_OMP_SPLIT_MASKED) +}; + +/* If a var is in lastprivate/firstprivate/reduction but not in a + data mapping/sharing clause, add it to 'map(tofrom:' if is_target + and to 'shared' otherwise. */ +static void +gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out, + gfc_omp_clauses *clauses_in, + bool is_target, bool is_parallel_do) +{ + int clauselist_to_add = is_target ? OMP_LIST_MAP : OMP_LIST_SHARED; + gfc_omp_namelist *tail = NULL; + for (int i = 0; i < 5; ++i) + { + gfc_omp_namelist *n; + switch (i) + { + case 0: n = clauses_in->lists[OMP_LIST_FIRSTPRIVATE]; break; + case 1: n = clauses_in->lists[OMP_LIST_LASTPRIVATE]; break; + case 2: n = clauses_in->lists[OMP_LIST_REDUCTION]; break; + case 3: n = clauses_in->lists[OMP_LIST_REDUCTION_INSCAN]; break; + case 4: n = clauses_in->lists[OMP_LIST_REDUCTION_TASK]; break; + default: gcc_unreachable (); + } + for (; n != NULL; n = n->next) + { + gfc_omp_namelist *n2, **n_firstp = NULL, **n_lastp = NULL; + for (int j = 0; j < 6; ++j) + { + gfc_omp_namelist **n2ref = NULL, *prev2 = NULL; + switch (j) + { + case 0: + n2ref = &clauses_out->lists[clauselist_to_add]; + break; + case 1: + n2ref = &clauses_out->lists[OMP_LIST_FIRSTPRIVATE]; + break; + case 2: + if (is_target) + n2ref = &clauses_in->lists[OMP_LIST_LASTPRIVATE]; + else + n2ref = &clauses_out->lists[OMP_LIST_LASTPRIVATE]; + break; + case 3: n2ref = &clauses_out->lists[OMP_LIST_REDUCTION]; break; + case 4: + n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_INSCAN]; + break; + case 5: + n2ref = &clauses_out->lists[OMP_LIST_REDUCTION_TASK]; + break; + default: gcc_unreachable (); + } + for (n2 = *n2ref; n2 != NULL; prev2 = n2, n2 = n2->next) + if (n2->sym == n->sym) + break; + if (n2) + { + if (j == 0 /* clauselist_to_add */) + break; /* Already present. */ + if (j == 1 /* OMP_LIST_FIRSTPRIVATE */) + { + n_firstp = prev2 ? &prev2->next : n2ref; + continue; + } + if (j == 2 /* OMP_LIST_LASTPRIVATE */) + { + n_lastp = prev2 ? &prev2->next : n2ref; + continue; + } + break; + } + } + if (n_firstp && n_lastp) + { + /* For parallel do, GCC puts firstprivatee/lastprivate + on the parallel. */ + if (is_parallel_do) + continue; + *n_firstp = (*n_firstp)->next; + if (!is_target) + *n_lastp = (*n_lastp)->next; + } + else if (is_target && n_lastp) + ; + else if (n2 || n_firstp || n_lastp) + continue; + if (clauses_out->lists[clauselist_to_add] + && (clauses_out->lists[clauselist_to_add] + == clauses_in->lists[clauselist_to_add])) + { + gfc_omp_namelist *p = NULL; + for (n2 = clauses_in->lists[clauselist_to_add]; n2; n2 = n2->next) + { + if (p) + { + p->next = gfc_get_omp_namelist (); + p = p->next; + } + else + { + p = gfc_get_omp_namelist (); + clauses_out->lists[clauselist_to_add] = p; + } + *p = *n2; + } + } + if (!tail) + { + tail = clauses_out->lists[clauselist_to_add]; + for (; tail && tail->next; tail = tail->next) + ; + } + n2 = gfc_get_omp_namelist (); + n2->where = n->where; + n2->sym = n->sym; + if (is_target) + n2->u.map_op = OMP_MAP_TOFROM; + if (tail) + { + tail->next = n2; + tail = n2; + } + else + clauses_out->lists[clauselist_to_add] = n2; + } + } +} + +static void +gfc_free_split_omp_clauses (gfc_code *code, gfc_omp_clauses *clausesa) +{ + for (int i = 0; i < GFC_OMP_SPLIT_NUM; ++i) + for (int j = 0; j < OMP_LIST_NUM; ++j) + if (clausesa[i].lists[j] && clausesa[i].lists[j] != code->ext.omp_clauses->lists[j]) + for (gfc_omp_namelist *n = clausesa[i].lists[j]; n;) + { + gfc_omp_namelist *p = n; + n = n->next; + free (p); + } +} + +static void +gfc_split_omp_clauses (gfc_code *code, + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]) +{ + int mask = 0, innermost = 0; + bool is_loop = false; + memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses)); + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL + | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_DO: + case EXEC_OMP_LOOP: + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_DO_SIMD: + mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_PARALLEL: + innermost = GFC_OMP_SPLIT_PARALLEL; + break; + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_LOOP: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_PARALLEL_MASKED: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED; + innermost = GFC_OMP_SPLIT_MASKED; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED + | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); + innermost = GFC_OMP_SPLIT_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + mask = (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_MASKED + | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD); + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_SIMD: + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET: + innermost = GFC_OMP_SPLIT_TARGET; + break; + case EXEC_OMP_TARGET_PARALLEL: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL; + innermost = GFC_OMP_SPLIT_PARALLEL; + break; + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO + | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET_TEAMS: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS; + innermost = GFC_OMP_SPLIT_TEAMS; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS + | GFC_OMP_MASK_DISTRIBUTE; + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS + | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET_TEAMS_LOOP: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_MASKED_TASKLOOP: + mask = GFC_OMP_SPLIT_MASKED | GFC_OMP_SPLIT_TASKLOOP; + innermost = GFC_OMP_SPLIT_TASKLOOP; + break; + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_TASKLOOP: + innermost = GFC_OMP_SPLIT_TASKLOOP; + break; + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_TASKLOOP_SIMD: + mask = GFC_OMP_MASK_TASKLOOP | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TEAMS: + innermost = GFC_OMP_SPLIT_TEAMS; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE; + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TEAMS_LOOP: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + default: + gcc_unreachable (); + } + if (mask == 0) + { + clausesa[innermost] = *code->ext.omp_clauses; + return; + } + /* Loops are similar to DO but still a bit different. */ + switch (code->op) + { + case EXEC_OMP_LOOP: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_TEAMS_LOOP: + is_loop = true; + default: + break; + } + if (code->ext.omp_clauses != NULL) + { + if (mask & GFC_OMP_MASK_TARGET) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP] + = code->ext.omp_clauses->lists[OMP_LIST_MAP]; + clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IS_DEVICE_PTR] + = code->ext.omp_clauses->lists[OMP_LIST_IS_DEVICE_PTR]; + clausesa[GFC_OMP_SPLIT_TARGET].device + = code->ext.omp_clauses->device; + clausesa[GFC_OMP_SPLIT_TARGET].thread_limit + = code->ext.omp_clauses->thread_limit; + for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) + clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i] + = code->ext.omp_clauses->defaultmap[i]; + clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET] + = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET]; + /* And this is copied to all. */ + clausesa[GFC_OMP_SPLIT_TARGET].if_expr + = code->ext.omp_clauses->if_expr; + clausesa[GFC_OMP_SPLIT_TARGET].nowait + = code->ext.omp_clauses->nowait; + } + if (mask & GFC_OMP_MASK_TEAMS) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower + = code->ext.omp_clauses->num_teams_lower; + clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper + = code->ext.omp_clauses->num_teams_upper; + clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit + = code->ext.omp_clauses->thread_limit; + /* Shared and default clauses are allowed on parallel, teams + and taskloop. */ + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED] + = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; + clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing + = code->ext.omp_clauses->default_sharing; + } + if (mask & GFC_OMP_MASK_DISTRIBUTE) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind + = code->ext.omp_clauses->dist_sched_kind; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size + = code->ext.omp_clauses->dist_chunk_size; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse + = code->ext.omp_clauses->collapse; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent + = code->ext.omp_clauses->order_concurrent; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_unconstrained + = code->ext.omp_clauses->order_unconstrained; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_reproducible + = code->ext.omp_clauses->order_reproducible; + } + if (mask & GFC_OMP_MASK_PARALLEL) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN] + = code->ext.omp_clauses->lists[OMP_LIST_COPYIN]; + clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads + = code->ext.omp_clauses->num_threads; + clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind + = code->ext.omp_clauses->proc_bind; + /* Shared and default clauses are allowed on parallel, teams + and taskloop. */ + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED] + = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; + clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing + = code->ext.omp_clauses->default_sharing; + clausesa[GFC_OMP_SPLIT_PARALLEL].if_exprs[OMP_IF_PARALLEL] + = code->ext.omp_clauses->if_exprs[OMP_IF_PARALLEL]; + /* And this is copied to all. */ + clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr + = code->ext.omp_clauses->if_expr; + } + if (mask & GFC_OMP_MASK_MASKED) + clausesa[GFC_OMP_SPLIT_MASKED].filter = code->ext.omp_clauses->filter; + if ((mask & GFC_OMP_MASK_DO) && !is_loop) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_DO].ordered + = code->ext.omp_clauses->ordered; + clausesa[GFC_OMP_SPLIT_DO].orderedc + = code->ext.omp_clauses->orderedc; + clausesa[GFC_OMP_SPLIT_DO].sched_kind + = code->ext.omp_clauses->sched_kind; + if (innermost == GFC_OMP_SPLIT_SIMD) + clausesa[GFC_OMP_SPLIT_DO].sched_simd + = code->ext.omp_clauses->sched_simd; + clausesa[GFC_OMP_SPLIT_DO].sched_monotonic + = code->ext.omp_clauses->sched_monotonic; + clausesa[GFC_OMP_SPLIT_DO].sched_nonmonotonic + = code->ext.omp_clauses->sched_nonmonotonic; + clausesa[GFC_OMP_SPLIT_DO].chunk_size + = code->ext.omp_clauses->chunk_size; + clausesa[GFC_OMP_SPLIT_DO].nowait + = code->ext.omp_clauses->nowait; + } + if (mask & GFC_OMP_MASK_DO) + { + clausesa[GFC_OMP_SPLIT_DO].bind + = code->ext.omp_clauses->bind; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_DO].collapse + = code->ext.omp_clauses->collapse; + clausesa[GFC_OMP_SPLIT_DO].order_concurrent + = code->ext.omp_clauses->order_concurrent; + clausesa[GFC_OMP_SPLIT_DO].order_unconstrained + = code->ext.omp_clauses->order_unconstrained; + clausesa[GFC_OMP_SPLIT_DO].order_reproducible + = code->ext.omp_clauses->order_reproducible; + } + if (mask & GFC_OMP_MASK_SIMD) + { + clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr + = code->ext.omp_clauses->safelen_expr; + clausesa[GFC_OMP_SPLIT_SIMD].simdlen_expr + = code->ext.omp_clauses->simdlen_expr; + clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED] + = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED]; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_SIMD].collapse + = code->ext.omp_clauses->collapse; + clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD] + = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD]; + clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent + = code->ext.omp_clauses->order_concurrent; + clausesa[GFC_OMP_SPLIT_SIMD].order_unconstrained + = code->ext.omp_clauses->order_unconstrained; + clausesa[GFC_OMP_SPLIT_SIMD].order_reproducible + = code->ext.omp_clauses->order_reproducible; + /* And this is copied to all. */ + clausesa[GFC_OMP_SPLIT_SIMD].if_expr + = code->ext.omp_clauses->if_expr; + } + if (mask & GFC_OMP_MASK_TASKLOOP) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_TASKLOOP].nogroup + = code->ext.omp_clauses->nogroup; + clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize + = code->ext.omp_clauses->grainsize; + clausesa[GFC_OMP_SPLIT_TASKLOOP].grainsize_strict + = code->ext.omp_clauses->grainsize_strict; + clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks + = code->ext.omp_clauses->num_tasks; + clausesa[GFC_OMP_SPLIT_TASKLOOP].num_tasks_strict + = code->ext.omp_clauses->num_tasks_strict; + clausesa[GFC_OMP_SPLIT_TASKLOOP].priority + = code->ext.omp_clauses->priority; + clausesa[GFC_OMP_SPLIT_TASKLOOP].final_expr + = code->ext.omp_clauses->final_expr; + clausesa[GFC_OMP_SPLIT_TASKLOOP].untied + = code->ext.omp_clauses->untied; + clausesa[GFC_OMP_SPLIT_TASKLOOP].mergeable + = code->ext.omp_clauses->mergeable; + clausesa[GFC_OMP_SPLIT_TASKLOOP].if_exprs[OMP_IF_TASKLOOP] + = code->ext.omp_clauses->if_exprs[OMP_IF_TASKLOOP]; + /* And this is copied to all. */ + clausesa[GFC_OMP_SPLIT_TASKLOOP].if_expr + = code->ext.omp_clauses->if_expr; + /* Shared and default clauses are allowed on parallel, teams + and taskloop. */ + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_SHARED] + = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; + clausesa[GFC_OMP_SPLIT_TASKLOOP].default_sharing + = code->ext.omp_clauses->default_sharing; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_TASKLOOP].collapse + = code->ext.omp_clauses->collapse; + } + /* Private clause is supported on all constructs but master/masked, + it is enough to put it on the innermost one except for master/masked. For + !$ omp parallel do put it on parallel though, + as that's what we did for OpenMP 3.1. */ + clausesa[((innermost == GFC_OMP_SPLIT_DO && !is_loop) + || code->op == EXEC_OMP_PARALLEL_MASTER + || code->op == EXEC_OMP_PARALLEL_MASKED) + ? (int) GFC_OMP_SPLIT_PARALLEL + : innermost].lists[OMP_LIST_PRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE]; + /* Firstprivate clause is supported on all constructs but + simd and masked/master. Put it on the outermost of those and duplicate + on parallel and teams. */ + if (mask & GFC_OMP_MASK_TARGET) + clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + if (mask & GFC_OMP_MASK_TEAMS) + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + else if (mask & GFC_OMP_MASK_DISTRIBUTE) + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + if (mask & GFC_OMP_MASK_TASKLOOP) + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + if ((mask & GFC_OMP_MASK_PARALLEL) + && !(mask & GFC_OMP_MASK_TASKLOOP)) + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + else if ((mask & GFC_OMP_MASK_DO) && !is_loop) + clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + /* Lastprivate is allowed on distribute, do, simd, taskloop and loop. + In parallel do{, simd} we actually want to put it on + parallel rather than do. */ + if (mask & GFC_OMP_MASK_DISTRIBUTE) + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + if (mask & GFC_OMP_MASK_TASKLOOP) + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + if ((mask & GFC_OMP_MASK_PARALLEL) && !is_loop + && !(mask & GFC_OMP_MASK_TASKLOOP)) + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + else if (mask & GFC_OMP_MASK_DO) + clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + if (mask & GFC_OMP_MASK_SIMD) + clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE]; + /* Reduction is allowed on simd, do, parallel, teams, taskloop, and loop. + Duplicate it on all of them, but + - omit on do if parallel is present; + - omit on task and parallel if loop is present; + additionally, inscan applies to do/simd only. */ + for (int i = OMP_LIST_REDUCTION; i <= OMP_LIST_REDUCTION_TASK; i++) + { + if (mask & GFC_OMP_MASK_TASKLOOP + && i != OMP_LIST_REDUCTION_INSCAN) + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[i] + = code->ext.omp_clauses->lists[i]; + if (mask & GFC_OMP_MASK_TEAMS + && i != OMP_LIST_REDUCTION_INSCAN + && !is_loop) + clausesa[GFC_OMP_SPLIT_TEAMS].lists[i] + = code->ext.omp_clauses->lists[i]; + if (mask & GFC_OMP_MASK_PARALLEL + && i != OMP_LIST_REDUCTION_INSCAN + && !(mask & GFC_OMP_MASK_TASKLOOP) + && !is_loop) + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i] + = code->ext.omp_clauses->lists[i]; + else if (mask & GFC_OMP_MASK_DO) + clausesa[GFC_OMP_SPLIT_DO].lists[i] + = code->ext.omp_clauses->lists[i]; + if (mask & GFC_OMP_MASK_SIMD) + clausesa[GFC_OMP_SPLIT_SIMD].lists[i] + = code->ext.omp_clauses->lists[i]; + } + if (mask & GFC_OMP_MASK_TARGET) + clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_IN_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION]; + if (mask & GFC_OMP_MASK_TASKLOOP) + clausesa[GFC_OMP_SPLIT_TASKLOOP].lists[OMP_LIST_IN_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_IN_REDUCTION]; + /* Linear clause is supported on do and simd, + put it on the innermost one. */ + clausesa[innermost].lists[OMP_LIST_LINEAR] + = code->ext.omp_clauses->lists[OMP_LIST_LINEAR]; + } + /* Propagate firstprivate/lastprivate/reduction vars to + shared (parallel, teams) and map-tofrom (target). */ + if (mask & GFC_OMP_MASK_TARGET) + gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TARGET], + code->ext.omp_clauses, true, false); + if ((mask & GFC_OMP_MASK_PARALLEL) && innermost != GFC_OMP_MASK_PARALLEL) + gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_PARALLEL], + code->ext.omp_clauses, false, + mask & GFC_OMP_MASK_DO); + if (mask & GFC_OMP_MASK_TEAMS && innermost != GFC_OMP_MASK_TEAMS) + gfc_add_clause_implicitly (&clausesa[GFC_OMP_SPLIT_TEAMS], + code->ext.omp_clauses, false, false); + if (((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) + == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO)) + && !is_loop) + clausesa[GFC_OMP_SPLIT_DO].nowait = true; + + /* Distribute allocate clause to do, parallel, distribute, teams, target + and taskloop. The code below itereates over variables in the + allocate list and checks if that available is also in any + privatization clause on those construct. If yes, then we add it + to the list of 'allocate'ed variables for that construct. If a + variable is found in none of them then we issue an error. */ + + if (code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]) + { + gfc_omp_namelist *alloc_nl, *priv_nl; + gfc_omp_namelist *tails[GFC_OMP_SPLIT_NUM]; + for (alloc_nl = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; + alloc_nl; alloc_nl = alloc_nl->next) + { + bool found = false; + for (int i = GFC_OMP_SPLIT_DO; i <= GFC_OMP_SPLIT_TASKLOOP; i++) + { + gfc_omp_namelist *p; + int list; + for (list = 0; list < OMP_LIST_NUM; list++) + { + switch (list) + { + case OMP_LIST_PRIVATE: + case OMP_LIST_FIRSTPRIVATE: + case OMP_LIST_LASTPRIVATE: + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: + case OMP_LIST_IN_REDUCTION: + case OMP_LIST_TASK_REDUCTION: + case OMP_LIST_LINEAR: + for (priv_nl = clausesa[i].lists[list]; priv_nl; + priv_nl = priv_nl->next) + if (alloc_nl->sym == priv_nl->sym) + { + found = true; + p = gfc_get_omp_namelist (); + p->sym = alloc_nl->sym; + p->expr = alloc_nl->expr; + p->where = alloc_nl->where; + if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL) + { + clausesa[i].lists[OMP_LIST_ALLOCATE] = p; + tails[i] = p; + } + else + { + tails[i]->next = p; + tails[i] = tails[i]->next; + } + } + break; + default: + break; + } + } + } + if (!found) + gfc_error ("%qs specified in 'allocate' clause at %L but not " + "in an explicit privatization clause", + alloc_nl->sym->name, &alloc_nl->where); + } + } +} + +static tree +gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clausesa, tree omp_clauses) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, body, omp_do_clauses = NULL_TREE; + bool free_clausesa = false; + + if (pblock == NULL) + gfc_start_block (&block); + else + gfc_init_block (&block); + + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; + } + if (flag_openmp) + omp_do_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc); + body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block, + &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (body) != BIND_EXPR) + body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (body) != BIND_EXPR) + body = build3_v (BIND_EXPR, NULL, body, NULL_TREE); + if (flag_openmp) + { + stmt = make_node (OMP_FOR); + TREE_TYPE (stmt) = void_type_node; + OMP_FOR_BODY (stmt) = body; + OMP_FOR_CLAUSES (stmt) = omp_do_clauses; + } + else + stmt = body; + gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_do (gfc_code *code, bool is_loop, stmtblock_t *pblock, + gfc_omp_clauses *clausesa) +{ + stmtblock_t block, *new_pblock = pblock; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + bool free_clausesa = false; + + if (pblock == NULL) + gfc_start_block (&block); + else + gfc_init_block (&block); + + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; + } + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + if (pblock == NULL) + { + if (!clausesa[GFC_OMP_SPLIT_DO].ordered + && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC) + new_pblock = █ + else + pushlevel (); + } + stmt = gfc_trans_omp_do (code, is_loop ? EXEC_OMP_LOOP : EXEC_OMP_DO, + new_pblock, &clausesa[GFC_OMP_SPLIT_DO], + omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, + void_type_node, stmt, omp_clauses); + OMP_PARALLEL_COMBINED (stmt) = 1; + gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + bool free_clausesa = false; + + if (pblock == NULL) + gfc_start_block (&block); + else + gfc_init_block (&block); + + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; + } + if (flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + if (pblock == NULL) + pushlevel (); + stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); + if (flag_openmp) + { + stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, + void_type_node, stmt, omp_clauses); + OMP_PARALLEL_COMBINED (stmt) = 1; + } + gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_sections (gfc_code *code) +{ + stmtblock_t block; + gfc_omp_clauses section_clauses; + tree stmt, omp_clauses; + + memset (§ion_clauses, 0, sizeof (section_clauses)); + section_clauses.nowait = true; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + pushlevel (); + stmt = gfc_trans_omp_sections (code, §ion_clauses); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, + void_type_node, stmt, omp_clauses); + OMP_PARALLEL_COMBINED (stmt) = 1; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_workshare (gfc_code *code) +{ + stmtblock_t block; + gfc_omp_clauses workshare_clauses; + tree stmt, omp_clauses; + + memset (&workshare_clauses, 0, sizeof (workshare_clauses)); + workshare_clauses.nowait = true; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + pushlevel (); + stmt = gfc_trans_omp_workshare (code, &workshare_clauses); + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, + void_type_node, stmt, omp_clauses); + OMP_PARALLEL_COMBINED (stmt) = 1; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_scope (gfc_code *code) +{ + stmtblock_t block; + tree body = gfc_trans_code (code->block->next); + if (IS_EMPTY_STMT (body)) + return body; + gfc_start_block (&block); + tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + tree stmt = make_node (OMP_SCOPE); + TREE_TYPE (stmt) = void_type_node; + OMP_SCOPE_BODY (stmt) = body; + OMP_SCOPE_CLAUSES (stmt) = omp_clauses; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses) +{ + stmtblock_t block, body; + tree omp_clauses, stmt; + bool has_lastprivate = clauses->lists[OMP_LIST_LASTPRIVATE] != NULL; + location_t loc = gfc_get_location (&code->loc); + + gfc_start_block (&block); + + omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); + + gfc_init_block (&body); + for (code = code->block; code; code = code->block) + { + /* Last section is special because of lastprivate, so even if it + is empty, chain it in. */ + stmt = gfc_trans_omp_code (code->next, + has_lastprivate && code->block == NULL); + if (! IS_EMPTY_STMT (stmt)) + { + stmt = build1_v (OMP_SECTION, stmt); + gfc_add_expr_to_block (&body, stmt); + } + } + stmt = gfc_finish_block (&body); + + stmt = build2_loc (loc, OMP_SECTIONS, void_type_node, stmt, omp_clauses); + gfc_add_expr_to_block (&block, stmt); + + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) +{ + tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc); + tree stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node, + stmt, omp_clauses); + return stmt; +} + +static tree +gfc_trans_omp_task (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + pushlevel (); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_TASK, void_type_node, + stmt, omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_taskgroup (gfc_code *code) +{ + stmtblock_t block; + gfc_start_block (&block); + tree body = gfc_trans_code (code->block->next); + tree stmt = make_node (OMP_TASKGROUP); + TREE_TYPE (stmt) = void_type_node; + OMP_TASKGROUP_BODY (stmt) = body; + OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, + code->ext.omp_clauses, + code->loc); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_taskwait (gfc_code *code) +{ + if (!code->ext.omp_clauses) + { + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT); + return build_call_expr_loc (input_location, decl, 0); + } + stmtblock_t block; + gfc_start_block (&block); + tree stmt = make_node (OMP_TASK); + TREE_TYPE (stmt) = void_type_node; + OMP_TASK_BODY (stmt) = NULL_TREE; + OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, + code->ext.omp_clauses, + code->loc); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_taskyield (void) +{ + tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKYIELD); + return build_call_expr_loc (input_location, decl, 0); +} + +static tree +gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + bool free_clausesa = false; + + gfc_start_block (&block); + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; + } + if (flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], + code->loc); + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE: + /* This is handled in gfc_trans_omp_do. */ + gcc_unreachable (); + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + stmt = gfc_trans_omp_parallel_do (code, false, &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, + &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + default: + gcc_unreachable (); + } + if (flag_openmp) + { + tree distribute = make_node (OMP_DISTRIBUTE); + TREE_TYPE (distribute) = void_type_node; + OMP_FOR_BODY (distribute) = stmt; + OMP_FOR_CLAUSES (distribute) = omp_clauses; + stmt = distribute; + } + gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa, + tree omp_clauses) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt; + bool combined = true, free_clausesa = false; + + gfc_start_block (&block); + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + free_clausesa = true; + } + if (flag_openmp) + { + omp_clauses + = chainon (omp_clauses, + gfc_trans_omp_clauses (&block, + &clausesa[GFC_OMP_SPLIT_TEAMS], + code->loc)); + pushlevel (); + } + switch (code->op) + { + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TEAMS: + stmt = gfc_trans_omp_code (code->block->next, true); + combined = false; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE: + stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL, + &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], + NULL); + break; + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TEAMS_LOOP: + stmt = gfc_trans_omp_do (code, EXEC_OMP_LOOP, NULL, + &clausesa[GFC_OMP_SPLIT_DO], + NULL); + break; + default: + stmt = gfc_trans_omp_distribute (code, clausesa); + break; + } + if (flag_openmp) + { + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_TEAMS, + void_type_node, stmt, omp_clauses); + if (combined) + OMP_TEAMS_COMBINED (stmt) = 1; + } + gfc_add_expr_to_block (&block, stmt); + if (free_clausesa) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target (gfc_code *code) +{ + stmtblock_t block; + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + gfc_split_omp_clauses (code, clausesa); + if (flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET], + code->loc); + switch (code->op) + { + case EXEC_OMP_TARGET: + pushlevel (); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + break; + case EXEC_OMP_TARGET_PARALLEL: + { + stmtblock_t iblock; + + pushlevel (); + gfc_start_block (&iblock); + tree inner_clauses + = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, + inner_clauses); + gfc_add_expr_to_block (&iblock, stmt); + stmt = gfc_finish_block (&iblock); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } + break; + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + stmt = gfc_trans_omp_parallel_do (code, + (code->op + == EXEC_OMP_TARGET_PARALLEL_LOOP), + &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_TARGET_SIMD: + stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, + &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + default: + if (flag_openmp + && (clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper + || clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit)) + { + gfc_omp_clauses clausesb; + tree teams_clauses; + /* For combined !$omp target teams, the num_teams and + thread_limit clauses are evaluated before entering the + target construct. */ + memset (&clausesb, '\0', sizeof (clausesb)); + clausesb.num_teams_lower + = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower; + clausesb.num_teams_upper + = clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper; + clausesb.thread_limit = clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit; + clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_lower = NULL; + clausesa[GFC_OMP_SPLIT_TEAMS].num_teams_upper = NULL; + clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit = NULL; + teams_clauses + = gfc_trans_omp_clauses (&block, &clausesb, code->loc); + pushlevel (); + stmt = gfc_trans_omp_teams (code, clausesa, teams_clauses); + } + else + { + pushlevel (); + stmt = gfc_trans_omp_teams (code, clausesa, NULL_TREE); + } + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + } + if (flag_openmp) + { + stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET, + void_type_node, stmt, omp_clauses); + if (code->op != EXEC_OMP_TARGET) + OMP_TARGET_COMBINED (stmt) = 1; + cfun->has_omp_target = true; + } + gfc_add_expr_to_block (&block, stmt); + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op) +{ + stmtblock_t block; + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + gfc_split_omp_clauses (code, clausesa); + if (flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TASKLOOP], + code->loc); + switch (op) + { + case EXEC_OMP_TASKLOOP: + /* This is handled in gfc_trans_omp_do. */ + gcc_unreachable (); + break; + case EXEC_OMP_TASKLOOP_SIMD: + stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, + &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + default: + gcc_unreachable (); + } + if (flag_openmp) + { + tree taskloop = make_node (OMP_TASKLOOP); + TREE_TYPE (taskloop) = void_type_node; + OMP_FOR_BODY (taskloop) = stmt; + OMP_FOR_CLAUSES (taskloop) = omp_clauses; + stmt = taskloop; + } + gfc_add_expr_to_block (&block, stmt); + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op) +{ + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; + stmtblock_t block; + tree stmt; + + if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD + && code->op != EXEC_OMP_MASTER_TASKLOOP) + gfc_split_omp_clauses (code, clausesa); + + pushlevel (); + if (op == EXEC_OMP_MASKED_TASKLOOP_SIMD + || op == EXEC_OMP_MASTER_TASKLOOP_SIMD) + stmt = gfc_trans_omp_taskloop (code, EXEC_OMP_TASKLOOP_SIMD); + else + { + gcc_assert (op == EXEC_OMP_MASKED_TASKLOOP + || op == EXEC_OMP_MASTER_TASKLOOP); + stmt = gfc_trans_omp_do (code, EXEC_OMP_TASKLOOP, NULL, + code->op != EXEC_OMP_MASTER_TASKLOOP + ? &clausesa[GFC_OMP_SPLIT_TASKLOOP] + : code->ext.omp_clauses, NULL); + } + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + gfc_start_block (&block); + if (op == EXEC_OMP_MASKED_TASKLOOP || op == EXEC_OMP_MASKED_TASKLOOP_SIMD) + { + tree clauses = gfc_trans_omp_clauses (&block, + &clausesa[GFC_OMP_SPLIT_MASKED], + code->loc); + tree msk = make_node (OMP_MASKED); + TREE_TYPE (msk) = void_type_node; + OMP_MASKED_BODY (msk) = stmt; + OMP_MASKED_CLAUSES (msk) = clauses; + OMP_MASKED_COMBINED (msk) = 1; + gfc_add_expr_to_block (&block, msk); + } + else + { + gcc_assert (op == EXEC_OMP_MASTER_TASKLOOP + || op == EXEC_OMP_MASTER_TASKLOOP_SIMD); + stmt = build1_v (OMP_MASTER, stmt); + gfc_add_expr_to_block (&block, stmt); + } + if (op != EXEC_OMP_MASTER_TASKLOOP_SIMD + && code->op != EXEC_OMP_MASTER_TASKLOOP) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_master_masked (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]; + bool parallel_combined = false; + + if (code->op != EXEC_OMP_PARALLEL_MASTER) + gfc_split_omp_clauses (code, clausesa); + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, + code->op == EXEC_OMP_PARALLEL_MASTER + ? code->ext.omp_clauses + : &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + pushlevel (); + if (code->op == EXEC_OMP_PARALLEL_MASTER) + stmt = gfc_trans_omp_master (code); + else if (code->op == EXEC_OMP_PARALLEL_MASKED) + stmt = gfc_trans_omp_masked (code, &clausesa[GFC_OMP_SPLIT_MASKED]); + else + { + gfc_exec_op op; + switch (code->op) + { + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + op = EXEC_OMP_MASKED_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + op = EXEC_OMP_MASKED_TASKLOOP_SIMD; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + op = EXEC_OMP_MASTER_TASKLOOP; + break; + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + op = EXEC_OMP_MASTER_TASKLOOP_SIMD; + break; + default: + gcc_unreachable (); + } + stmt = gfc_trans_omp_master_masked_taskloop (code, op); + parallel_combined = true; + } + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_PARALLEL, + void_type_node, stmt, omp_clauses); + /* masked does have just filter clause, but during gimplification + isn't represented by a gimplification omp context, so for + !$omp parallel masked don't set OMP_PARALLEL_COMBINED, + so that + !$omp parallel masked + !$omp taskloop simd lastprivate (x) + isn't confused with + !$omp parallel masked taskloop simd lastprivate (x) */ + if (parallel_combined) + OMP_PARALLEL_COMBINED (stmt) = 1; + gfc_add_expr_to_block (&block, stmt); + if (code->op != EXEC_OMP_PARALLEL_MASTER) + gfc_free_split_omp_clauses (code, clausesa); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_data (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build2_loc (gfc_get_location (&code->loc), OMP_TARGET_DATA, + void_type_node, stmt, omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_enter_data (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + stmt = build1_loc (input_location, OMP_TARGET_ENTER_DATA, void_type_node, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_exit_data (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_update (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) +{ + tree res, tmp, stmt; + stmtblock_t block, *pblock = NULL; + stmtblock_t singleblock; + int saved_ompws_flags; + bool singleblock_in_progress = false; + /* True if previous gfc_code in workshare construct is not workshared. */ + bool prev_singleunit; + location_t loc = gfc_get_location (&code->loc); + + code = code->block->next; + + pushlevel (); + + gfc_start_block (&block); + pblock = █ + + ompws_flags = OMPWS_WORKSHARE_FLAG; + prev_singleunit = false; + + /* Translate statements one by one to trees until we reach + the end of the workshare construct. Adjacent gfc_codes that + are a single unit of work are clustered and encapsulated in a + single OMP_SINGLE construct. */ + for (; code; code = code->next) + { + if (code->here != 0) + { + res = gfc_trans_label_here (code); + gfc_add_expr_to_block (pblock, res); + } + + /* No dependence analysis, use for clauses with wait. + If this is the last gfc_code, use default omp_clauses. */ + if (code->next == NULL && clauses->nowait) + ompws_flags |= OMPWS_NOWAIT; + + /* By default, every gfc_code is a single unit of work. */ + ompws_flags |= OMPWS_CURR_SINGLEUNIT; + ompws_flags &= ~(OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY); + + switch (code->op) + { + case EXEC_NOP: + res = NULL_TREE; + break; + + case EXEC_ASSIGN: + res = gfc_trans_assign (code); + break; + + case EXEC_POINTER_ASSIGN: + res = gfc_trans_pointer_assign (code); + break; + + case EXEC_INIT_ASSIGN: + res = gfc_trans_init_assign (code); + break; + + case EXEC_FORALL: + res = gfc_trans_forall (code); + break; + + case EXEC_WHERE: + res = gfc_trans_where (code); + break; + + case EXEC_OMP_ATOMIC: + res = gfc_trans_omp_directive (code); + break; + + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_CRITICAL: + saved_ompws_flags = ompws_flags; + ompws_flags = 0; + res = gfc_trans_omp_directive (code); + ompws_flags = saved_ompws_flags; + break; + + case EXEC_BLOCK: + res = gfc_trans_block_construct (code); + break; + + default: + gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code"); + } + + gfc_set_backend_locus (&code->loc); + + if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) + { + if (prev_singleunit) + { + if (ompws_flags & OMPWS_CURR_SINGLEUNIT) + /* Add current gfc_code to single block. */ + gfc_add_expr_to_block (&singleblock, res); + else + { + /* Finish single block and add it to pblock. */ + tmp = gfc_finish_block (&singleblock); + tmp = build2_loc (loc, OMP_SINGLE, + void_type_node, tmp, NULL_TREE); + gfc_add_expr_to_block (pblock, tmp); + /* Add current gfc_code to pblock. */ + gfc_add_expr_to_block (pblock, res); + singleblock_in_progress = false; + } + } + else + { + if (ompws_flags & OMPWS_CURR_SINGLEUNIT) + { + /* Start single block. */ + gfc_init_block (&singleblock); + gfc_add_expr_to_block (&singleblock, res); + singleblock_in_progress = true; + loc = gfc_get_location (&code->loc); + } + else + /* Add the new statement to the block. */ + gfc_add_expr_to_block (pblock, res); + } + prev_singleunit = (ompws_flags & OMPWS_CURR_SINGLEUNIT) != 0; + } + } + + /* Finish remaining SINGLE block, if we were in the middle of one. */ + if (singleblock_in_progress) + { + /* Finish single block and add it to pblock. */ + tmp = gfc_finish_block (&singleblock); + tmp = build2_loc (loc, OMP_SINGLE, void_type_node, tmp, + clauses->nowait + ? build_omp_clause (input_location, OMP_CLAUSE_NOWAIT) + : NULL_TREE); + gfc_add_expr_to_block (pblock, tmp); + } + + stmt = gfc_finish_block (pblock); + if (TREE_CODE (stmt) != BIND_EXPR) + { + if (!IS_EMPTY_STMT (stmt)) + { + tree bindblock = poplevel (1, 0); + stmt = build3_v (BIND_EXPR, NULL, stmt, bindblock); + } + else + poplevel (0, 0); + } + else + poplevel (0, 0); + + if (IS_EMPTY_STMT (stmt) && !clauses->nowait) + stmt = gfc_trans_omp_barrier (); + + ompws_flags = 0; + return stmt; +} + +tree +gfc_trans_oacc_declare (gfc_code *code) +{ + stmtblock_t block; + tree stmt, oacc_clauses; + enum tree_code construct_code; + + construct_code = OACC_DATA; + + gfc_start_block (&block); + + oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses, + code->loc, false, true); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build2_loc (input_location, construct_code, void_type_node, stmt, + oacc_clauses); + gfc_add_expr_to_block (&block, stmt); + + return gfc_finish_block (&block); +} + +tree +gfc_trans_oacc_directive (gfc_code *code) +{ + switch (code->op) + { + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_SERIAL_LOOP: + return gfc_trans_oacc_combined_directive (code); + case EXEC_OACC_PARALLEL: + case EXEC_OACC_KERNELS: + case EXEC_OACC_SERIAL: + case EXEC_OACC_DATA: + case EXEC_OACC_HOST_DATA: + return gfc_trans_oacc_construct (code); + case EXEC_OACC_LOOP: + return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, + NULL); + case EXEC_OACC_UPDATE: + case EXEC_OACC_CACHE: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + return gfc_trans_oacc_executable_directive (code); + case EXEC_OACC_WAIT: + return gfc_trans_oacc_wait_directive (code); + case EXEC_OACC_ATOMIC: + return gfc_trans_omp_atomic (code); + case EXEC_OACC_DECLARE: + return gfc_trans_oacc_declare (code); + default: + gcc_unreachable (); + } +} + +tree +gfc_trans_omp_directive (gfc_code *code) +{ + switch (code->op) + { + case EXEC_OMP_ATOMIC: + return gfc_trans_omp_atomic (code); + case EXEC_OMP_BARRIER: + return gfc_trans_omp_barrier (); + case EXEC_OMP_CANCEL: + return gfc_trans_omp_cancel (code); + case EXEC_OMP_CANCELLATION_POINT: + return gfc_trans_omp_cancellation_point (code); + case EXEC_OMP_CRITICAL: + return gfc_trans_omp_critical (code); + case EXEC_OMP_DEPOBJ: + return gfc_trans_omp_depobj (code); + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DO: + case EXEC_OMP_LOOP: + case EXEC_OMP_SIMD: + case EXEC_OMP_TASKLOOP: + return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses, + NULL); + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + return gfc_trans_omp_distribute (code, NULL); + case EXEC_OMP_DO_SIMD: + return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE); + case EXEC_OMP_ERROR: + return gfc_trans_omp_error (code); + case EXEC_OMP_FLUSH: + return gfc_trans_omp_flush (code); + case EXEC_OMP_MASKED: + return gfc_trans_omp_masked (code, NULL); + case EXEC_OMP_MASTER: + return gfc_trans_omp_master (code); + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + return gfc_trans_omp_master_masked_taskloop (code, code->op); + case EXEC_OMP_ORDERED: + return gfc_trans_omp_ordered (code); + case EXEC_OMP_PARALLEL: + return gfc_trans_omp_parallel (code); + case EXEC_OMP_PARALLEL_DO: + return gfc_trans_omp_parallel_do (code, false, NULL, NULL); + case EXEC_OMP_PARALLEL_LOOP: + return gfc_trans_omp_parallel_do (code, true, NULL, NULL); + case EXEC_OMP_PARALLEL_DO_SIMD: + return gfc_trans_omp_parallel_do_simd (code, NULL, NULL); + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + return gfc_trans_omp_parallel_master_masked (code); + case EXEC_OMP_PARALLEL_SECTIONS: + return gfc_trans_omp_parallel_sections (code); + case EXEC_OMP_PARALLEL_WORKSHARE: + return gfc_trans_omp_parallel_workshare (code); + case EXEC_OMP_SCOPE: + return gfc_trans_omp_scope (code); + case EXEC_OMP_SECTIONS: + return gfc_trans_omp_sections (code, code->ext.omp_clauses); + case EXEC_OMP_SINGLE: + return gfc_trans_omp_single (code, code->ext.omp_clauses); + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + return gfc_trans_omp_target (code); + case EXEC_OMP_TARGET_DATA: + return gfc_trans_omp_target_data (code); + case EXEC_OMP_TARGET_ENTER_DATA: + return gfc_trans_omp_target_enter_data (code); + case EXEC_OMP_TARGET_EXIT_DATA: + return gfc_trans_omp_target_exit_data (code); + case EXEC_OMP_TARGET_UPDATE: + return gfc_trans_omp_target_update (code); + case EXEC_OMP_TASK: + return gfc_trans_omp_task (code); + case EXEC_OMP_TASKGROUP: + return gfc_trans_omp_taskgroup (code); + case EXEC_OMP_TASKLOOP_SIMD: + return gfc_trans_omp_taskloop (code, code->op); + case EXEC_OMP_TASKWAIT: + return gfc_trans_omp_taskwait (code); + case EXEC_OMP_TASKYIELD: + return gfc_trans_omp_taskyield (); + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + return gfc_trans_omp_teams (code, NULL, NULL_TREE); + case EXEC_OMP_WORKSHARE: + return gfc_trans_omp_workshare (code, code->ext.omp_clauses); + default: + gcc_unreachable (); + } +} + +void +gfc_trans_omp_declare_simd (gfc_namespace *ns) +{ + if (ns->entries) + return; + + gfc_omp_declare_simd *ods; + for (ods = ns->omp_declare_simd; ods; ods = ods->next) + { + tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true); + tree fndecl = ns->proc_name->backend_decl; + if (c != NULL_TREE) + c = tree_cons (NULL_TREE, c, NULL_TREE); + c = build_tree_list (get_identifier ("omp declare simd"), c); + TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl); + DECL_ATTRIBUTES (fndecl) = c; + } +} + +void +gfc_trans_omp_declare_variant (gfc_namespace *ns) +{ + tree base_fn_decl = ns->proc_name->backend_decl; + gfc_namespace *search_ns = ns; + gfc_omp_declare_variant *next; + + for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant; + search_ns; odv = next) + { + /* Look in the parent namespace if there are no more directives in the + current namespace. */ + if (!odv) + { + search_ns = search_ns->parent; + if (search_ns) + next = search_ns->omp_declare_variant; + continue; + } + + next = odv->next; + + if (odv->error_p) + continue; + + /* Check directive the first time it is encountered. */ + bool error_found = true; + + if (odv->checked_p) + error_found = false; + if (odv->base_proc_symtree == NULL) + { + if (!search_ns->proc_name->attr.function + && !search_ns->proc_name->attr.subroutine) + gfc_error ("The base name for 'declare variant' must be " + "specified at %L ", &odv->where); + else + error_found = false; + } + else + { + if (!search_ns->contained + && strcmp (odv->base_proc_symtree->name, + ns->proc_name->name)) + gfc_error ("The base name at %L does not match the name of the " + "current procedure", &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.entry) + gfc_error ("The base name at %L must not be an entry name", + &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.generic) + gfc_error ("The base name at %L must not be a generic name", + &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.proc_pointer) + gfc_error ("The base name at %L must not be a procedure pointer", + &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.implicit_type) + gfc_error ("The base procedure at %L must have an explicit " + "interface", &odv->where); + else + error_found = false; + } + + odv->checked_p = true; + if (error_found) + { + odv->error_p = true; + continue; + } + + /* Ignore directives that do not apply to the current procedure. */ + if ((odv->base_proc_symtree == NULL && search_ns != ns) + || (odv->base_proc_symtree != NULL + && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))) + continue; + + tree set_selectors = NULL_TREE; + gfc_omp_set_selector *oss; + + for (oss = odv->set_selectors; oss; oss = oss->next) + { + tree selectors = NULL_TREE; + gfc_omp_selector *os; + for (os = oss->trait_selectors; os; os = os->next) + { + tree properties = NULL_TREE; + gfc_omp_trait_property *otp; + + for (otp = os->properties; otp; otp = otp->next) + { + switch (otp->property_kind) + { + case CTX_PROPERTY_USER: + case CTX_PROPERTY_EXPR: + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, otp->expr); + properties = tree_cons (NULL_TREE, se.expr, + properties); + } + break; + case CTX_PROPERTY_ID: + properties = tree_cons (get_identifier (otp->name), + NULL_TREE, properties); + break; + case CTX_PROPERTY_NAME_LIST: + { + tree prop = NULL_TREE, value = NULL_TREE; + if (otp->is_name) + prop = get_identifier (otp->name); + else + value = gfc_conv_constant_to_tree (otp->expr); + + properties = tree_cons (prop, value, properties); + } + break; + case CTX_PROPERTY_SIMD: + properties = gfc_trans_omp_clauses (NULL, otp->clauses, + odv->where, true); + break; + default: + gcc_unreachable (); + } + } + + if (os->score) + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, os->score); + properties = tree_cons (get_identifier (" score"), + se.expr, properties); + } + + selectors = tree_cons (get_identifier (os->trait_selector_name), + properties, selectors); + } + + set_selectors + = tree_cons (get_identifier (oss->trait_set_selector_name), + selectors, set_selectors); + } + + const char *variant_proc_name = odv->variant_proc_symtree->name; + gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym; + if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type) + { + gfc_symtree *proc_st; + gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st); + variant_proc_sym = proc_st->n.sym; + } + if (variant_proc_sym == NULL) + { + gfc_error ("Cannot find symbol %qs", variant_proc_name); + continue; + } + set_selectors = omp_check_context_selector + (gfc_get_location (&odv->where), set_selectors); + if (set_selectors != error_mark_node) + { + if (!variant_proc_sym->attr.implicit_type + && !variant_proc_sym->attr.subroutine + && !variant_proc_sym->attr.function) + { + gfc_error ("variant %qs at %L is not a function or subroutine", + variant_proc_name, &odv->where); + variant_proc_sym = NULL; + } + else if (omp_get_context_selector (set_selectors, "construct", + "simd") == NULL_TREE) + { + char err[256]; + if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym, + variant_proc_sym->name, 0, 1, + err, sizeof (err), NULL, NULL)) + { + gfc_error ("variant %qs and base %qs at %L have " + "incompatible types: %s", + variant_proc_name, ns->proc_name->name, + &odv->where, err); + variant_proc_sym = NULL; + } + } + if (variant_proc_sym != NULL) + { + gfc_set_sym_referenced (variant_proc_sym); + tree construct = omp_get_context_selector (set_selectors, + "construct", NULL); + omp_mark_declare_variant (gfc_get_location (&odv->where), + gfc_get_symbol_decl (variant_proc_sym), + construct); + if (omp_context_selector_matches (set_selectors)) + { + tree id = get_identifier ("omp declare variant base"); + tree variant = gfc_get_symbol_decl (variant_proc_sym); + DECL_ATTRIBUTES (base_fn_decl) + = tree_cons (id, build_tree_list (variant, set_selectors), + DECL_ATTRIBUTES (base_fn_decl)); + } + } + } + } +} diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c deleted file mode 100644 index a9b463d..0000000 --- a/gcc/fortran/trans-stmt.c +++ /dev/null @@ -1,7468 +0,0 @@ -/* Statement translation -- generate GCC trees from gfc_code. - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - and Steven Bosscher - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "tree.h" -#include "gfortran.h" -#include "trans.h" -#include "stringpool.h" -#include "fold-const.h" -#include "trans-stmt.h" -#include "trans-types.h" -#include "trans-array.h" -#include "trans-const.h" -#include "dependency.h" - -typedef struct iter_info -{ - tree var; - tree start; - tree end; - tree step; - struct iter_info *next; -} -iter_info; - -typedef struct forall_info -{ - iter_info *this_loop; - tree mask; - tree maskindex; - int nvar; - tree size; - struct forall_info *prev_nest; - bool do_concurrent; -} -forall_info; - -static void gfc_trans_where_2 (gfc_code *, tree, bool, - forall_info *, stmtblock_t *); - -/* Translate a F95 label number to a LABEL_EXPR. */ - -tree -gfc_trans_label_here (gfc_code * code) -{ - return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); -} - - -/* Given a variable expression which has been ASSIGNed to, find the decl - containing the auxiliary variables. For variables in common blocks this - is a field_decl. */ - -void -gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) -{ - gcc_assert (expr->symtree->n.sym->attr.assign == 1); - gfc_conv_expr (se, expr); - /* Deals with variable in common block. Get the field declaration. */ - if (TREE_CODE (se->expr) == COMPONENT_REF) - se->expr = TREE_OPERAND (se->expr, 1); - /* Deals with dummy argument. Get the parameter declaration. */ - else if (TREE_CODE (se->expr) == INDIRECT_REF) - se->expr = TREE_OPERAND (se->expr, 0); -} - -/* Translate a label assignment statement. */ - -tree -gfc_trans_label_assign (gfc_code * code) -{ - tree label_tree; - gfc_se se; - tree len; - tree addr; - tree len_tree; - int label_len; - - /* Start a new block. */ - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - gfc_conv_label_variable (&se, code->expr1); - - len = GFC_DECL_STRING_LEN (se.expr); - addr = GFC_DECL_ASSIGN_ADDR (se.expr); - - label_tree = gfc_get_label_decl (code->label1); - - if (code->label1->defined == ST_LABEL_TARGET - || code->label1->defined == ST_LABEL_DO_TARGET) - { - label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); - len_tree = build_int_cst (gfc_charlen_type_node, -1); - } - else - { - gfc_expr *format = code->label1->format; - - label_len = format->value.character.length; - len_tree = build_int_cst (gfc_charlen_type_node, label_len); - label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1, - format->value.character.string); - label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); - } - - gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree)); - gfc_add_modify (&se.pre, addr, label_tree); - - return gfc_finish_block (&se.pre); -} - -/* Translate a GOTO statement. */ - -tree -gfc_trans_goto (gfc_code * code) -{ - locus loc = code->loc; - tree assigned_goto; - tree target; - tree tmp; - gfc_se se; - - if (code->label1 != NULL) - return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); - - /* ASSIGNED GOTO. */ - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - gfc_conv_label_variable (&se, code->expr1); - tmp = GFC_DECL_STRING_LEN (se.expr); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, - build_int_cst (TREE_TYPE (tmp), -1)); - gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc, - "Assigned label is not a target label"); - - assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); - - /* We're going to ignore a label list. It does not really change the - statement's semantics (because it is just a further restriction on - what's legal code); before, we were comparing label addresses here, but - that's a very fragile business and may break with optimization. So - just ignore it. */ - - target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node, - assigned_goto); - gfc_add_expr_to_block (&se.pre, target); - return gfc_finish_block (&se.pre); -} - - -/* Translate an ENTRY statement. Just adds a label for this entry point. */ -tree -gfc_trans_entry (gfc_code * code) -{ - return build1_v (LABEL_EXPR, code->ext.entry->label); -} - - -/* Replace a gfc_ss structure by another both in the gfc_se struct - and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies - to replace a variable ss by the corresponding temporary. */ - -static void -replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss) -{ - gfc_ss **sess, **loopss; - - /* The old_ss is a ss for a single variable. */ - gcc_assert (old_ss->info->type == GFC_SS_SECTION); - - for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next)) - if (*sess == old_ss) - break; - gcc_assert (*sess != gfc_ss_terminator); - - *sess = new_ss; - new_ss->next = old_ss->next; - - /* Make sure that trailing references are not lost. */ - if (old_ss->info - && old_ss->info->data.array.ref - && old_ss->info->data.array.ref->next - && !(new_ss->info->data.array.ref - && new_ss->info->data.array.ref->next)) - new_ss->info->data.array.ref = old_ss->info->data.array.ref; - - for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator; - loopss = &((*loopss)->loop_chain)) - if (*loopss == old_ss) - break; - gcc_assert (*loopss != gfc_ss_terminator); - - *loopss = new_ss; - new_ss->loop_chain = old_ss->loop_chain; - new_ss->loop = old_ss->loop; - - gfc_free_ss (old_ss); -} - - -/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of - elemental subroutines. Make temporaries for output arguments if any such - dependencies are found. Output arguments are chosen because internal_unpack - can be used, as is, to copy the result back to the variable. */ -static void -gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, - gfc_symbol * sym, gfc_actual_arglist * arg, - gfc_dep_check check_variable) -{ - gfc_actual_arglist *arg0; - gfc_expr *e; - gfc_formal_arglist *formal; - gfc_se parmse; - gfc_ss *ss; - gfc_symbol *fsym; - tree data; - tree size; - tree tmp; - - if (loopse->ss == NULL) - return; - - ss = loopse->ss; - arg0 = arg; - formal = gfc_sym_get_dummy_args (sym); - - /* Loop over all the arguments testing for dependencies. */ - for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) - { - e = arg->expr; - if (e == NULL) - continue; - - /* Obtain the info structure for the current argument. */ - for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) - if (ss->info->expr == e) - break; - - /* If there is a dependency, create a temporary and use it - instead of the variable. */ - fsym = formal ? formal->sym : NULL; - if (e->expr_type == EXPR_VARIABLE - && e->rank && fsym - && fsym->attr.intent != INTENT_IN - && gfc_check_fncall_dependency (e, fsym->attr.intent, - sym, arg0, check_variable)) - { - tree initial, temptype; - stmtblock_t temp_post; - gfc_ss *tmp_ss; - - tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen, - GFC_SS_SECTION); - gfc_mark_ss_chain_used (tmp_ss, 1); - tmp_ss->info->expr = ss->info->expr; - replace_ss (loopse, ss, tmp_ss); - - /* Obtain the argument descriptor for unpacking. */ - gfc_init_se (&parmse, NULL); - parmse.want_pointer = 1; - gfc_conv_expr_descriptor (&parmse, e); - gfc_add_block_to_block (&se->pre, &parmse.pre); - - /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), - initialize the array temporary with a copy of the values. */ - if (fsym->attr.intent == INTENT_INOUT - || (fsym->ts.type ==BT_DERIVED - && fsym->attr.intent == INTENT_OUT)) - initial = parmse.expr; - /* For class expressions, we always initialize with the copy of - the values. */ - else if (e->ts.type == BT_CLASS) - initial = parmse.expr; - else - initial = NULL_TREE; - - if (e->ts.type != BT_CLASS) - { - /* Find the type of the temporary to create; we don't use the type - of e itself as this breaks for subcomponent-references in e - (where the type of e is that of the final reference, but - parmse.expr's type corresponds to the full derived-type). */ - /* TODO: Fix this somehow so we don't need a temporary of the whole - array but instead only the components referenced. */ - temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ - gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); - temptype = TREE_TYPE (temptype); - temptype = gfc_get_element_type (temptype); - } - - else - /* For class arrays signal that the size of the dynamic type has to - be obtained from the vtable, using the 'initial' expression. */ - temptype = NULL_TREE; - - /* Generate the temporary. Cleaning up the temporary should be the - very last thing done, so we add the code to a new block and add it - to se->post as last instructions. */ - size = gfc_create_var (gfc_array_index_type, NULL); - data = gfc_create_var (pvoid_type_node, NULL); - gfc_init_block (&temp_post); - tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss, - temptype, initial, false, true, - false, &arg->expr->where); - gfc_add_modify (&se->pre, size, tmp); - tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data); - gfc_add_modify (&se->pre, data, tmp); - - /* Update other ss' delta. */ - gfc_set_delta (loopse->loop); - - /* Copy the result back using unpack..... */ - if (e->ts.type != BT_CLASS) - tmp = build_call_expr_loc (input_location, - gfor_fndecl_in_unpack, 2, parmse.expr, data); - else - { - /* ... except for class results where the copy is - unconditional. */ - tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_conv_descriptor_data_get (tmp); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), - 3, tmp, data, - fold_convert (size_type_node, size)); - } - gfc_add_expr_to_block (&se->post, tmp); - - /* parmse.pre is already added above. */ - gfc_add_block_to_block (&se->post, &parmse.post); - gfc_add_block_to_block (&se->post, &temp_post); - } - } -} - - -/* Given an executable statement referring to an intrinsic function call, - returns the intrinsic symbol. */ - -static gfc_intrinsic_sym * -get_intrinsic_for_code (gfc_code *code) -{ - if (code->op == EXEC_CALL) - { - gfc_intrinsic_sym * const isym = code->resolved_isym; - if (isym) - return isym; - else - return gfc_get_intrinsic_for_expr (code->expr1); - } - - return NULL; -} - - -/* Translate the CALL statement. Builds a call to an F95 subroutine. */ - -tree -gfc_trans_call (gfc_code * code, bool dependency_check, - tree mask, tree count1, bool invert) -{ - gfc_se se; - gfc_ss * ss; - int has_alternate_specifier; - gfc_dep_check check_variable; - tree index = NULL_TREE; - tree maskexpr = NULL_TREE; - tree tmp; - bool is_intrinsic_mvbits; - - /* A CALL starts a new block because the actual arguments may have to - be evaluated first. */ - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - - gcc_assert (code->resolved_sym); - - ss = gfc_ss_terminator; - if (code->resolved_sym->attr.elemental) - ss = gfc_walk_elemental_function_args (ss, code->ext.actual, - get_intrinsic_for_code (code), - GFC_SS_REFERENCE); - - /* MVBITS is inlined but needs the dependency checking found here. */ - is_intrinsic_mvbits = code->resolved_isym - && code->resolved_isym->id == GFC_ISYM_MVBITS; - - /* Is not an elemental subroutine call with array valued arguments. */ - if (ss == gfc_ss_terminator) - { - - if (is_intrinsic_mvbits) - { - has_alternate_specifier = 0; - gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL); - } - else - { - /* Translate the call. */ - has_alternate_specifier = - gfc_conv_procedure_call (&se, code->resolved_sym, - code->ext.actual, code->expr1, NULL); - - /* A subroutine without side-effect, by definition, does nothing! */ - TREE_SIDE_EFFECTS (se.expr) = 1; - } - - /* Chain the pieces together and return the block. */ - if (has_alternate_specifier) - { - gfc_code *select_code; - gfc_symbol *sym; - select_code = code->next; - gcc_assert(select_code->op == EXEC_SELECT); - sym = select_code->expr1->symtree->n.sym; - se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); - if (sym->backend_decl == NULL) - sym->backend_decl = gfc_get_symbol_decl (sym); - gfc_add_modify (&se.pre, sym->backend_decl, se.expr); - } - else - gfc_add_expr_to_block (&se.pre, se.expr); - - gfc_add_block_to_block (&se.pre, &se.post); - } - - else - { - /* An elemental subroutine call with array valued arguments has - to be scalarized. */ - gfc_loopinfo loop; - stmtblock_t body; - stmtblock_t block; - gfc_se loopse; - gfc_se depse; - - /* gfc_walk_elemental_function_args renders the ss chain in the - reverse order to the actual argument order. */ - ss = gfc_reverse_ss (ss); - - /* Initialize the loop. */ - gfc_init_se (&loopse, NULL); - gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, ss); - - gfc_conv_ss_startstride (&loop); - /* TODO: gfc_conv_loop_setup generates a temporary for vector - subscripts. This could be prevented in the elemental case - as temporaries are handled separatedly - (below in gfc_conv_elemental_dependencies). */ - if (code->expr1) - gfc_conv_loop_setup (&loop, &code->expr1->where); - else - gfc_conv_loop_setup (&loop, &code->loc); - - gfc_mark_ss_chain_used (ss, 1); - - /* Convert the arguments, checking for dependencies. */ - gfc_copy_loopinfo_to_se (&loopse, &loop); - loopse.ss = ss; - - /* For operator assignment, do dependency checking. */ - if (dependency_check) - check_variable = ELEM_CHECK_VARIABLE; - else - check_variable = ELEM_DONT_CHECK_VARIABLE; - - gfc_init_se (&depse, NULL); - gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym, - code->ext.actual, check_variable); - - gfc_add_block_to_block (&loop.pre, &depse.pre); - gfc_add_block_to_block (&loop.post, &depse.post); - - /* Generate the loop body. */ - gfc_start_scalarized_body (&loop, &body); - gfc_init_block (&block); - - if (mask && count1) - { - /* Form the mask expression according to the mask. */ - index = count1; - maskexpr = gfc_build_array_ref (mask, index, NULL); - if (invert) - maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - TREE_TYPE (maskexpr), maskexpr); - } - - if (is_intrinsic_mvbits) - { - has_alternate_specifier = 0; - gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop); - } - else - { - /* Add the subroutine call to the block. */ - gfc_conv_procedure_call (&loopse, code->resolved_sym, - code->ext.actual, code->expr1, - NULL); - } - - if (mask && count1) - { - tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&loopse.pre, tmp); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - count1, gfc_index_one_node); - gfc_add_modify (&loopse.pre, count1, tmp); - } - else - gfc_add_expr_to_block (&loopse.pre, loopse.expr); - - gfc_add_block_to_block (&block, &loopse.pre); - gfc_add_block_to_block (&block, &loopse.post); - - /* Finish up the loop block and the loop. */ - gfc_add_expr_to_block (&body, gfc_finish_block (&block)); - gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&se.pre, &loop.pre); - gfc_add_block_to_block (&se.pre, &loop.post); - gfc_add_block_to_block (&se.pre, &se.post); - gfc_cleanup_loop (&loop); - } - - return gfc_finish_block (&se.pre); -} - - -/* Translate the RETURN statement. */ - -tree -gfc_trans_return (gfc_code * code) -{ - if (code->expr1) - { - gfc_se se; - tree tmp; - tree result; - - /* If code->expr is not NULL, this return statement must appear - in a subroutine and current_fake_result_decl has already - been generated. */ - - result = gfc_get_fake_result_decl (NULL, 0); - if (!result) - { - gfc_warning (0, - "An alternate return at %L without a * dummy argument", - &code->expr1->where); - return gfc_generate_return (); - } - - /* Start a new block for this statement. */ - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - - gfc_conv_expr (&se, code->expr1); - - /* Note that the actually returned expression is a simple value and - does not depend on any pointers or such; thus we can clean-up with - se.post before returning. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result), - result, fold_convert (TREE_TYPE (result), - se.expr)); - gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_block_to_block (&se.pre, &se.post); - - tmp = gfc_generate_return (); - gfc_add_expr_to_block (&se.pre, tmp); - return gfc_finish_block (&se.pre); - } - - return gfc_generate_return (); -} - - -/* Translate the PAUSE statement. We have to translate this statement - to a runtime library call. */ - -tree -gfc_trans_pause (gfc_code * code) -{ - tree gfc_int8_type_node = gfc_get_int_type (8); - gfc_se se; - tree tmp; - - /* Start a new block for this statement. */ - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - - - if (code->expr1 == NULL) - { - tmp = build_int_cst (size_type_node, 0); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_pause_string, 2, - build_int_cst (pchar_type_node, 0), tmp); - } - else if (code->expr1->ts.type == BT_INTEGER) - { - gfc_conv_expr (&se, code->expr1); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_pause_numeric, 1, - fold_convert (gfc_int8_type_node, se.expr)); - } - else - { - gfc_conv_expr_reference (&se, code->expr1); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_pause_string, 2, - se.expr, fold_convert (size_type_node, - se.string_length)); - } - - gfc_add_expr_to_block (&se.pre, tmp); - - gfc_add_block_to_block (&se.pre, &se.post); - - return gfc_finish_block (&se.pre); -} - - -/* Translate the STOP statement. We have to translate this statement - to a runtime library call. */ - -tree -gfc_trans_stop (gfc_code *code, bool error_stop) -{ - gfc_se se; - tree tmp; - - /* Start a new block for this statement. */ - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - - if (code->expr1 == NULL) - { - tmp = build_int_cst (size_type_node, 0); - tmp = build_call_expr_loc (input_location, - error_stop - ? (flag_coarray == GFC_FCOARRAY_LIB - ? gfor_fndecl_caf_error_stop_str - : gfor_fndecl_error_stop_string) - : (flag_coarray == GFC_FCOARRAY_LIB - ? gfor_fndecl_caf_stop_str - : gfor_fndecl_stop_string), - 3, build_int_cst (pchar_type_node, 0), tmp, - boolean_false_node); - } - else if (code->expr1->ts.type == BT_INTEGER) - { - gfc_conv_expr (&se, code->expr1); - tmp = build_call_expr_loc (input_location, - error_stop - ? (flag_coarray == GFC_FCOARRAY_LIB - ? gfor_fndecl_caf_error_stop - : gfor_fndecl_error_stop_numeric) - : (flag_coarray == GFC_FCOARRAY_LIB - ? gfor_fndecl_caf_stop_numeric - : gfor_fndecl_stop_numeric), 2, - fold_convert (integer_type_node, se.expr), - boolean_false_node); - } - else - { - gfc_conv_expr_reference (&se, code->expr1); - tmp = build_call_expr_loc (input_location, - error_stop - ? (flag_coarray == GFC_FCOARRAY_LIB - ? gfor_fndecl_caf_error_stop_str - : gfor_fndecl_error_stop_string) - : (flag_coarray == GFC_FCOARRAY_LIB - ? gfor_fndecl_caf_stop_str - : gfor_fndecl_stop_string), - 3, se.expr, fold_convert (size_type_node, - se.string_length), - boolean_false_node); - } - - gfc_add_expr_to_block (&se.pre, tmp); - - gfc_add_block_to_block (&se.pre, &se.post); - - return gfc_finish_block (&se.pre); -} - -/* Translate the FAIL IMAGE statement. */ - -tree -gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) -{ - if (flag_coarray == GFC_FCOARRAY_LIB) - return build_call_expr_loc (input_location, - gfor_fndecl_caf_fail_image, 0); - else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } -} - -/* Translate the FORM TEAM statement. */ - -tree -gfc_trans_form_team (gfc_code *code) -{ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - gfc_se se; - gfc_se argse1, argse2; - tree team_id, team_type, tmp; - - gfc_init_se (&se, NULL); - gfc_init_se (&argse1, NULL); - gfc_init_se (&argse2, NULL); - gfc_start_block (&se.pre); - - gfc_conv_expr_val (&argse1, code->expr1); - gfc_conv_expr_val (&argse2, code->expr2); - team_id = fold_convert (integer_type_node, argse1.expr); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); - - gfc_add_block_to_block (&se.pre, &argse1.pre); - gfc_add_block_to_block (&se.pre, &argse2.pre); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_form_team, 3, - team_id, team_type, - build_int_cst (integer_type_node, 0)); - gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_block_to_block (&se.pre, &argse1.post); - gfc_add_block_to_block (&se.pre, &argse2.post); - return gfc_finish_block (&se.pre); - } - else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } -} - -/* Translate the CHANGE TEAM statement. */ - -tree -gfc_trans_change_team (gfc_code *code) -{ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - gfc_se argse; - tree team_type, tmp; - - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_change_team, 2, team_type, - build_int_cst (integer_type_node, 0)); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); - } - else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } -} - -/* Translate the END TEAM statement. */ - -tree -gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) -{ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - return build_call_expr_loc (input_location, - gfor_fndecl_caf_end_team, 1, - build_int_cst (pchar_type_node, 0)); - } - else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } -} - -/* Translate the SYNC TEAM statement. */ - -tree -gfc_trans_sync_team (gfc_code *code) -{ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - gfc_se argse; - tree team_type, tmp; - - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sync_team, 2, - team_type, - build_int_cst (integer_type_node, 0)); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); - } - else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } -} - -tree -gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) -{ - gfc_se se, argse; - tree stat = NULL_TREE, stat2 = NULL_TREE; - tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE; - - /* Short cut: For single images without STAT= or LOCK_ACQUIRED - return early. (ERRMSG= is always untouched for -fcoarray=single.) */ - if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB) - return NULL_TREE; - - if (code->expr2) - { - gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr2); - stat = argse.expr; - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - stat = null_pointer_node; - - if (code->expr4) - { - gcc_assert (code->expr4->expr_type == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr4); - lock_acquired = argse.expr; - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - lock_acquired = null_pointer_node; - - gfc_start_block (&se.pre); - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree tmp, token, image_index, errmsg, errmsg_len; - tree index = build_zero_cst (gfc_array_index_type); - tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); - - if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED - || code->expr1->symtree->n.sym->ts.u.derived->from_intmod - != INTMOD_ISO_FORTRAN_ENV - || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id - != ISOFORTRAN_LOCK_TYPE) - { - gfc_error ("Sorry, the lock component of derived type at %L is not " - "yet supported", &code->expr1->where); - return NULL_TREE; - } - - gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE, - code->expr1); - - if (gfc_is_coindexed (code->expr1)) - image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); - else - image_index = integer_zero_node; - - /* For arrays, obtain the array index. */ - if (gfc_expr_attr (code->expr1).dimension) - { - tree desc, tmp, extent, lbound, ubound; - gfc_array_ref *ar, ar2; - int i; - - /* TODO: Extend this, once DT components are supported. */ - ar = &code->expr1->ref->u.ar; - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; - - gfc_init_se (&argse, NULL); - argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, code->expr1); - gfc_add_block_to_block (&se.pre, &argse.pre); - desc = argse.expr; - *ar = ar2; - - extent = build_one_cst (gfc_array_index_type); - for (i = 0; i < ar->dimen; i++) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); - gfc_add_block_to_block (&argse.pre, &argse.pre); - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (lbound), argse.expr, lbound); - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), extent, tmp); - index = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (tmp), index, tmp); - if (i < ar->dimen - 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); - } - } - } - - /* errmsg. */ - if (code->expr3) - { - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->expr3); - gfc_add_block_to_block (&se.pre, &argse.pre); - errmsg = argse.expr; - errmsg_len = fold_convert (size_type_node, argse.string_length); - } - else - { - errmsg = null_pointer_node; - errmsg_len = build_zero_cst (size_type_node); - } - - if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) - { - stat2 = stat; - stat = gfc_create_var (integer_type_node, "stat"); - } - - if (lock_acquired != null_pointer_node - && TREE_TYPE (lock_acquired) != integer_type_node) - { - lock_acquired2 = lock_acquired; - lock_acquired = gfc_create_var (integer_type_node, "acquired"); - } - - index = fold_convert (size_type_node, index); - if (op == EXEC_LOCK) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, - token, index, image_index, - lock_acquired != null_pointer_node - ? gfc_build_addr_expr (NULL, lock_acquired) - : lock_acquired, - stat != null_pointer_node - ? gfc_build_addr_expr (NULL, stat) : stat, - errmsg, errmsg_len); - else - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, - token, index, image_index, - stat != null_pointer_node - ? gfc_build_addr_expr (NULL, stat) : stat, - errmsg, errmsg_len); - gfc_add_expr_to_block (&se.pre, tmp); - - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - - gfc_add_expr_to_block (&se.pre, tmp); - - if (stat2 != NULL_TREE) - gfc_add_modify (&se.pre, stat2, - fold_convert (TREE_TYPE (stat2), stat)); - - if (lock_acquired2 != NULL_TREE) - gfc_add_modify (&se.pre, lock_acquired2, - fold_convert (TREE_TYPE (lock_acquired2), - lock_acquired)); - - return gfc_finish_block (&se.pre); - } - - if (stat != NULL_TREE) - gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); - - if (lock_acquired != NULL_TREE) - gfc_add_modify (&se.pre, lock_acquired, - fold_convert (TREE_TYPE (lock_acquired), - boolean_true_node)); - - return gfc_finish_block (&se.pre); -} - -tree -gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op) -{ - gfc_se se, argse; - tree stat = NULL_TREE, stat2 = NULL_TREE; - tree until_count = NULL_TREE; - - if (code->expr2) - { - gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr2); - stat = argse.expr; - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - stat = null_pointer_node; - - if (code->expr4) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr4); - until_count = fold_convert (integer_type_node, argse.expr); - } - else - until_count = integer_one_node; - - if (flag_coarray != GFC_FCOARRAY_LIB) - { - gfc_start_block (&se.pre); - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - - if (op == EXEC_EVENT_POST) - gfc_add_modify (&se.pre, argse.expr, - fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (argse.expr), argse.expr, - build_int_cst (TREE_TYPE (argse.expr), 1))); - else - gfc_add_modify (&se.pre, argse.expr, - fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (argse.expr), argse.expr, - fold_convert (TREE_TYPE (argse.expr), - until_count))); - if (stat != NULL_TREE) - gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); - - return gfc_finish_block (&se.pre); - } - - gfc_start_block (&se.pre); - tree tmp, token, image_index, errmsg, errmsg_len; - tree index = build_zero_cst (gfc_array_index_type); - tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); - - if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED - || code->expr1->symtree->n.sym->ts.u.derived->from_intmod - != INTMOD_ISO_FORTRAN_ENV - || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id - != ISOFORTRAN_EVENT_TYPE) - { - gfc_error ("Sorry, the event component of derived type at %L is not " - "yet supported", &code->expr1->where); - return NULL_TREE; - } - - gfc_init_se (&argse, NULL); - gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE, - code->expr1); - gfc_add_block_to_block (&se.pre, &argse.pre); - - if (gfc_is_coindexed (code->expr1)) - image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); - else - image_index = integer_zero_node; - - /* For arrays, obtain the array index. */ - if (gfc_expr_attr (code->expr1).dimension) - { - tree desc, tmp, extent, lbound, ubound; - gfc_array_ref *ar, ar2; - int i; - - /* TODO: Extend this, once DT components are supported. */ - ar = &code->expr1->ref->u.ar; - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; - - gfc_init_se (&argse, NULL); - argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, code->expr1); - gfc_add_block_to_block (&se.pre, &argse.pre); - desc = argse.expr; - *ar = ar2; - - extent = build_one_cst (gfc_array_index_type); - for (i = 0; i < ar->dimen; i++) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); - gfc_add_block_to_block (&argse.pre, &argse.pre); - lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (lbound), argse.expr, lbound); - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), extent, tmp); - index = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (tmp), index, tmp); - if (i < ar->dimen - 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); - } - } - } - - /* errmsg. */ - if (code->expr3) - { - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->expr3); - gfc_add_block_to_block (&se.pre, &argse.pre); - errmsg = argse.expr; - errmsg_len = fold_convert (size_type_node, argse.string_length); - } - else - { - errmsg = null_pointer_node; - errmsg_len = build_zero_cst (size_type_node); - } - - if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) - { - stat2 = stat; - stat = gfc_create_var (integer_type_node, "stat"); - } - - index = fold_convert (size_type_node, index); - if (op == EXEC_EVENT_POST) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6, - token, index, image_index, - stat != null_pointer_node - ? gfc_build_addr_expr (NULL, stat) : stat, - errmsg, errmsg_len); - else - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6, - token, index, until_count, - stat != null_pointer_node - ? gfc_build_addr_expr (NULL, stat) : stat, - errmsg, errmsg_len); - gfc_add_expr_to_block (&se.pre, tmp); - - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&se.pre, tmp); - - if (stat2 != NULL_TREE) - gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat)); - - return gfc_finish_block (&se.pre); -} - -tree -gfc_trans_sync (gfc_code *code, gfc_exec_op type) -{ - gfc_se se, argse; - tree tmp; - tree images = NULL_TREE, stat = NULL_TREE, - errmsg = NULL_TREE, errmsglen = NULL_TREE; - - /* Short cut: For single images without bound checking or without STAT=, - return early. (ERRMSG= is always untouched for -fcoarray=single.) */ - if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - && flag_coarray != GFC_FCOARRAY_LIB) - return NULL_TREE; - - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - - if (code->expr1 && code->expr1->rank == 0) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - images = argse.expr; - } - - if (code->expr2) - { - gcc_assert (code->expr2->expr_type == EXPR_VARIABLE - || code->expr2->expr_type == EXPR_FUNCTION); - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr2); - stat = argse.expr; - } - else - stat = null_pointer_node; - - if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB) - { - gcc_assert (code->expr3->expr_type == EXPR_VARIABLE - || code->expr3->expr_type == EXPR_FUNCTION); - gfc_init_se (&argse, NULL); - argse.want_pointer = 1; - gfc_conv_expr (&argse, code->expr3); - gfc_conv_string_parameter (&argse); - errmsg = gfc_build_addr_expr (NULL, argse.expr); - errmsglen = fold_convert (size_type_node, argse.string_length); - } - else if (flag_coarray == GFC_FCOARRAY_LIB) - { - errmsg = null_pointer_node; - errmsglen = build_int_cst (size_type_node, 0); - } - - /* Check SYNC IMAGES(imageset) for valid image index. - FIXME: Add a check for image-set arrays. */ - if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) - && code->expr1->rank == 0) - { - tree images2 = fold_convert (integer_type_node, images); - tree cond; - if (flag_coarray != GFC_FCOARRAY_LIB) - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - images, build_int_cst (TREE_TYPE (images), 1)); - else - { - tree cond2; - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); - cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - images2, tmp); - cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - images, - build_int_cst (TREE_TYPE (images), 1)); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, cond2); - } - gfc_trans_runtime_check (true, false, cond, &se.pre, - &code->expr1->where, "Invalid image number " - "%d in SYNC IMAGES", images2); - } - - /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the - image control statements SYNC IMAGES and SYNC ALL. */ - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&se.pre, tmp); - } - - if (flag_coarray != GFC_FCOARRAY_LIB) - { - /* Set STAT to zero. */ - if (code->expr2) - gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); - } - else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY) - { - /* SYNC ALL => stat == null_pointer_node - SYNC ALL(stat=s) => stat has an integer type - - If "stat" has the wrong integer type, use a temp variable of - the right type and later cast the result back into "stat". */ - if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) - { - if (TREE_TYPE (stat) == integer_type_node) - stat = gfc_build_addr_expr (NULL, stat); - - if(type == EXEC_SYNC_MEMORY) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory, - 3, stat, errmsg, errmsglen); - else - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, - 3, stat, errmsg, errmsglen); - - gfc_add_expr_to_block (&se.pre, tmp); - } - else - { - tree tmp_stat = gfc_create_var (integer_type_node, "stat"); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, - 3, gfc_build_addr_expr (NULL, tmp_stat), - errmsg, errmsglen); - gfc_add_expr_to_block (&se.pre, tmp); - - gfc_add_modify (&se.pre, stat, - fold_convert (TREE_TYPE (stat), tmp_stat)); - } - } - else - { - tree len; - - gcc_assert (type == EXEC_SYNC_IMAGES); - - if (!code->expr1) - { - len = build_int_cst (integer_type_node, -1); - images = null_pointer_node; - } - else if (code->expr1->rank == 0) - { - len = build_int_cst (integer_type_node, 1); - images = gfc_build_addr_expr (NULL_TREE, images); - } - else - { - /* FIXME. */ - if (code->expr1->ts.kind != gfc_c_int_kind) - gfc_fatal_error ("Sorry, only support for integer kind %d " - "implemented for image-set at %L", - gfc_c_int_kind, &code->expr1->where); - - gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len); - images = se.expr; - - tmp = gfc_typenode_for_spec (&code->expr1->ts); - if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp)) - tmp = gfc_get_element_type (tmp); - - len = fold_build2_loc (input_location, TRUNC_DIV_EXPR, - TREE_TYPE (len), len, - fold_convert (TREE_TYPE (len), - TYPE_SIZE_UNIT (tmp))); - len = fold_convert (integer_type_node, len); - } - - /* SYNC IMAGES(imgs) => stat == null_pointer_node - SYNC IMAGES(imgs,stat=s) => stat has an integer type - - If "stat" has the wrong integer type, use a temp variable of - the right type and later cast the result back into "stat". */ - if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) - { - if (TREE_TYPE (stat) == integer_type_node) - stat = gfc_build_addr_expr (NULL, stat); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, - 5, fold_convert (integer_type_node, len), - images, stat, errmsg, errmsglen); - gfc_add_expr_to_block (&se.pre, tmp); - } - else - { - tree tmp_stat = gfc_create_var (integer_type_node, "stat"); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, - 5, fold_convert (integer_type_node, len), - images, gfc_build_addr_expr (NULL, tmp_stat), - errmsg, errmsglen); - gfc_add_expr_to_block (&se.pre, tmp); - - gfc_add_modify (&se.pre, stat, - fold_convert (TREE_TYPE (stat), tmp_stat)); - } - } - - return gfc_finish_block (&se.pre); -} - - -/* Generate GENERIC for the IF construct. This function also deals with - the simple IF statement, because the front end translates the IF - statement into an IF construct. - - We translate: - - IF (cond) THEN - then_clause - ELSEIF (cond2) - elseif_clause - ELSE - else_clause - ENDIF - - into: - - pre_cond_s; - if (cond_s) - { - then_clause; - } - else - { - pre_cond_s - if (cond_s) - { - elseif_clause - } - else - { - else_clause; - } - } - - where COND_S is the simplified version of the predicate. PRE_COND_S - are the pre side-effects produced by the translation of the - conditional. - We need to build the chain recursively otherwise we run into - problems with folding incomplete statements. */ - -static tree -gfc_trans_if_1 (gfc_code * code) -{ - gfc_se if_se; - tree stmt, elsestmt; - locus saved_loc; - location_t loc; - - /* Check for an unconditional ELSE clause. */ - if (!code->expr1) - return gfc_trans_code (code->next); - - /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ - gfc_init_se (&if_se, NULL); - gfc_start_block (&if_se.pre); - - /* Calculate the IF condition expression. */ - if (code->expr1->where.lb) - { - gfc_save_backend_locus (&saved_loc); - gfc_set_backend_locus (&code->expr1->where); - } - - gfc_conv_expr_val (&if_se, code->expr1); - - if (code->expr1->where.lb) - gfc_restore_backend_locus (&saved_loc); - - /* Translate the THEN clause. */ - stmt = gfc_trans_code (code->next); - - /* Translate the ELSE clause. */ - if (code->block) - elsestmt = gfc_trans_if_1 (code->block); - else - elsestmt = build_empty_stmt (input_location); - - /* Build the condition expression and add it to the condition block. */ - loc = code->expr1->where.lb ? gfc_get_location (&code->expr1->where) - : input_location; - stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt, - elsestmt); - - gfc_add_expr_to_block (&if_se.pre, stmt); - - /* Finish off this statement. */ - return gfc_finish_block (&if_se.pre); -} - -tree -gfc_trans_if (gfc_code * code) -{ - stmtblock_t body; - tree exit_label; - - /* Create exit label so it is available for trans'ing the body code. */ - exit_label = gfc_build_label_decl (NULL_TREE); - code->exit_label = exit_label; - - /* Translate the actual code in code->block. */ - gfc_init_block (&body); - gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block)); - - /* Add exit label. */ - gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); - - return gfc_finish_block (&body); -} - - -/* Translate an arithmetic IF expression. - - IF (cond) label1, label2, label3 translates to - - if (cond <= 0) - { - if (cond < 0) - goto label1; - else // cond == 0 - goto label2; - } - else // cond > 0 - goto label3; - - An optimized version can be generated in case of equal labels. - E.g., if label1 is equal to label2, we can translate it to - - if (cond <= 0) - goto label1; - else - goto label3; -*/ - -tree -gfc_trans_arithmetic_if (gfc_code * code) -{ - gfc_se se; - tree tmp; - tree branch1; - tree branch2; - tree zero; - - /* Start a new block. */ - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - - /* Pre-evaluate COND. */ - gfc_conv_expr_val (&se, code->expr1); - se.expr = gfc_evaluate_now (se.expr, &se.pre); - - /* Build something to compare with. */ - zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); - - if (code->label1->value != code->label2->value) - { - /* If (cond < 0) take branch1 else take branch2. - First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ - branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); - branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); - - if (code->label1->value != code->label3->value) - tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - se.expr, zero); - else - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - se.expr, zero); - - branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, - tmp, branch1, branch2); - } - else - branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); - - if (code->label1->value != code->label3->value - && code->label2->value != code->label3->value) - { - /* if (cond <= 0) take branch1 else take branch2. */ - branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); - tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - se.expr, zero); - branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, - tmp, branch1, branch2); - } - - /* Append the COND_EXPR to the evaluation of COND, and return. */ - gfc_add_expr_to_block (&se.pre, branch1); - return gfc_finish_block (&se.pre); -} - - -/* Translate a CRITICAL block. */ -tree -gfc_trans_critical (gfc_code *code) -{ - stmtblock_t block; - tree tmp, token = NULL_TREE; - - gfc_start_block (&block); - - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree zero_size = build_zero_cst (size_type_node); - token = gfc_get_symbol_decl (code->resolved_sym); - token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - null_pointer_node, zero_size); - gfc_add_expr_to_block (&block, tmp); - - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), - NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - - gfc_add_expr_to_block (&block, tmp); - } - - tmp = gfc_trans_code (code->block->next); - gfc_add_expr_to_block (&block, tmp); - - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree zero_size = build_zero_cst (size_type_node); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - zero_size); - gfc_add_expr_to_block (&block, tmp); - - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), - NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - - gfc_add_expr_to_block (&block, tmp); - } - - return gfc_finish_block (&block); -} - - -/* Return true, when the class has a _len component. */ - -static bool -class_has_len_component (gfc_symbol *sym) -{ - gfc_component *comp = sym->ts.u.derived->components; - while (comp) - { - if (strcmp (comp->name, "_len") == 0) - return true; - comp = comp->next; - } - return false; -} - - -static void -copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank) -{ - int n; - tree dim; - tree tmp; - tree tmp2; - tree size; - tree offset; - - offset = gfc_index_zero_node; - - /* Use memcpy to copy the descriptor. The size is the minimum of - the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */ - tmp = TYPE_SIZE_UNIT (TREE_TYPE (src)); - tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst)); - size = fold_build2_loc (input_location, MIN_EXPR, - TREE_TYPE (tmp), tmp, tmp2); - tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); - tmp = build_call_expr_loc (input_location, tmp, 3, - gfc_build_addr_expr (NULL_TREE, dst), - gfc_build_addr_expr (NULL_TREE, src), - fold_convert (size_type_node, size)); - gfc_add_expr_to_block (block, tmp); - - /* Set the offset correctly. */ - for (n = 0; n < rank; n++) - { - dim = gfc_rank_cst[n]; - tmp = gfc_conv_descriptor_lbound_get (src, dim); - tmp2 = gfc_conv_descriptor_stride_get (src, dim); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp, tmp2); - offset = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (offset), offset, tmp); - offset = gfc_evaluate_now (offset, block); - } - - gfc_conv_descriptor_offset_set (block, dst, offset); -} - - -/* Do proper initialization for ASSOCIATE names. */ - -static void -trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) -{ - gfc_expr *e; - tree tmp; - bool class_target; - bool unlimited; - tree desc; - tree offset; - tree dim; - int n; - tree charlen; - bool need_len_assign; - bool whole_array = true; - gfc_ref *ref; - gfc_symbol *sym2; - - gcc_assert (sym->assoc); - e = sym->assoc->target; - - class_target = (e->expr_type == EXPR_VARIABLE) - && (gfc_is_class_scalar_expr (e) - || gfc_is_class_array_ref (e, NULL)); - - unlimited = UNLIMITED_POLY (e); - - for (ref = e->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY - && ref->u.ar.type == AR_FULL - && ref->next) - { - whole_array = false; - break; - } - - /* Assignments to the string length need to be generated, when - ( sym is a char array or - sym has a _len component) - and the associated expression is unlimited polymorphic, which is - not (yet) correctly in 'unlimited', because for an already associated - BT_DERIVED the u-poly flag is not set, i.e., - __tmp_CHARACTER_0_1 => w => arg - ^ generated temp ^ from code, the w does not have the u-poly - flag set, where UNLIMITED_POLY(e) expects it. */ - need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED - && e->ts.u.derived->attr.unlimited_polymorphic)) - && (sym->ts.type == BT_CHARACTER - || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED) - && class_has_len_component (sym))) - && !sym->attr.select_rank_temporary); - - /* Do a `pointer assignment' with updated descriptor (or assign descriptor - to array temporary) for arrays with either unknown shape or if associating - to a variable. Select rank temporaries need somewhat different treatment - to other associate names and case temporaries. This because the selector - is assumed rank and so the offset in particular has to be changed. Also, - the case temporaries carry both allocatable and target attributes if - present in the selector. This means that an allocatation or change of - association can occur and so has to be dealt with. */ - if (sym->attr.select_rank_temporary) - { - gfc_se se; - tree class_decl = NULL_TREE; - int rank = 0; - bool class_ptr; - - sym2 = e->symtree->n.sym; - gfc_init_se (&se, NULL); - if (e->ts.type == BT_CLASS) - { - /* Go straight to the class data. */ - if (sym2->attr.dummy && !sym2->attr.optional) - { - class_decl = sym2->backend_decl; - if (DECL_LANG_SPECIFIC (class_decl) - && GFC_DECL_SAVED_DESCRIPTOR (class_decl)) - class_decl = GFC_DECL_SAVED_DESCRIPTOR (class_decl); - if (POINTER_TYPE_P (TREE_TYPE (class_decl))) - class_decl = build_fold_indirect_ref_loc (input_location, - class_decl); - gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl))); - se.expr = gfc_class_data_get (class_decl); - } - else - { - class_decl = sym2->backend_decl; - gfc_conv_expr_descriptor (&se, e); - if (POINTER_TYPE_P (TREE_TYPE (se.expr))) - se.expr = build_fold_indirect_ref_loc (input_location, - se.expr); - } - - if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0) - rank = CLASS_DATA (sym)->as->rank; - } - else - { - gfc_conv_expr_descriptor (&se, e); - if (sym->as && sym->as->rank > 0) - rank = sym->as->rank; - } - - desc = sym->backend_decl; - - /* The SELECT TYPE mechanisms turn class temporaries into pointers, which - point to the selector. */ - class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc)); - if (class_ptr) - { - tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class"); - tmp = gfc_build_addr_expr (NULL, tmp); - gfc_add_modify (&se.pre, desc, tmp); - - tmp = gfc_class_vptr_get (class_decl); - gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp); - if (UNLIMITED_POLY (sym)) - gfc_add_modify (&se.pre, gfc_class_len_get (desc), - gfc_class_len_get (class_decl)); - - desc = gfc_class_data_get (desc); - } - - /* SELECT RANK temporaries can carry the allocatable and pointer - attributes so the selector descriptor must be copied in and - copied out. */ - if (rank > 0) - copy_descriptor (&se.pre, desc, se.expr, rank); - else - { - tmp = gfc_conv_descriptor_data_get (se.expr); - gfc_add_modify (&se.pre, desc, - fold_convert (TREE_TYPE (desc), tmp)); - } - - /* Deal with associate_name => selector. Class associate names are - treated in the same way as in SELECT TYPE. */ - sym2 = sym->assoc->target->symtree->n.sym; - if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS) - { - sym2 = sym2->assoc->target->symtree->n.sym; - se.expr = sym2->backend_decl; - - if (POINTER_TYPE_P (TREE_TYPE (se.expr))) - se.expr = build_fold_indirect_ref_loc (input_location, - se.expr); - } - - /* There could have been reallocation. Copy descriptor back to the - selector and update the offset. */ - if (sym->attr.allocatable || sym->attr.pointer - || (sym->ts.type == BT_CLASS - && (CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.pointer))) - { - if (rank > 0) - copy_descriptor (&se.post, se.expr, desc, rank); - else - gfc_conv_descriptor_data_set (&se.post, se.expr, desc); - - /* The dynamic type could have changed too. */ - if (sym->ts.type == BT_CLASS) - { - tmp = sym->backend_decl; - if (class_ptr) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl), - gfc_class_vptr_get (tmp)); - if (UNLIMITED_POLY (sym)) - gfc_add_modify (&se.post, gfc_class_len_get (class_decl), - gfc_class_len_get (tmp)); - } - } - - tmp = gfc_finish_block (&se.post); - - gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp); - } - /* Now all the other kinds of associate variable. */ - else if (sym->attr.dimension && !class_target - && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) - { - gfc_se se; - tree desc; - bool cst_array_ctor; - - desc = sym->backend_decl; - cst_array_ctor = e->expr_type == EXPR_ARRAY - && gfc_constant_array_constructor_p (e->value.constructor) - && e->ts.type != BT_CHARACTER; - - /* If association is to an expression, evaluate it and create temporary. - Otherwise, get descriptor of target for pointer assignment. */ - gfc_init_se (&se, NULL); - - if (sym->assoc->variable || cst_array_ctor) - { - se.direct_byref = 1; - se.use_offset = 1; - se.expr = desc; - GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; - } - - gfc_conv_expr_descriptor (&se, e); - - if (sym->ts.type == BT_CHARACTER - && !se.direct_byref && sym->ts.deferred - && !sym->attr.select_type_temporary - && VAR_P (sym->ts.u.cl->backend_decl) - && se.string_length != sym->ts.u.cl->backend_decl) - { - gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, - fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), - se.string_length)); - } - - /* If we didn't already do the pointer assignment, set associate-name - descriptor to the one generated for the temporary. */ - if ((!sym->assoc->variable && !cst_array_ctor) - || !whole_array) - { - int dim; - - if (whole_array) - gfc_add_modify (&se.pre, desc, se.expr); - - /* The generated descriptor has lower bound zero (as array - temporary), shift bounds so we get lower bounds of 1. */ - for (dim = 0; dim < e->rank; ++dim) - gfc_conv_shift_descriptor_lbound (&se.pre, desc, - dim, gfc_index_one_node); - } - - /* If this is a subreference array pointer associate name use the - associate variable element size for the value of 'span'. */ - if (sym->attr.subref_array_pointer && !se.direct_byref) - { - gcc_assert (e->expr_type == EXPR_VARIABLE); - tmp = gfc_get_array_span (se.expr, e); - - gfc_conv_descriptor_span_set (&se.pre, desc, tmp); - } - - if (e->expr_type == EXPR_FUNCTION - && sym->ts.type == BT_DERIVED - && sym->ts.u.derived - && sym->ts.u.derived->attr.pdt_type) - { - tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr, - sym->as->rank); - gfc_add_expr_to_block (&se.post, tmp); - } - - /* Done, register stuff as init / cleanup code. */ - gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), - gfc_finish_block (&se.post)); - } - - /* Temporaries, arising from TYPE IS, just need the descriptor of class - arrays to be assigned directly. */ - else if (class_target && sym->attr.dimension - && (sym->ts.type == BT_DERIVED || unlimited)) - { - gfc_se se; - - gfc_init_se (&se, NULL); - se.descriptor_only = 1; - /* In a select type the (temporary) associate variable shall point to - a standard fortran array (lower bound == 1), but conv_expr () - just maps to the input array in the class object, whose lbound may - be arbitrary. conv_expr_descriptor solves this by inserting a - temporary array descriptor. */ - gfc_conv_expr_descriptor (&se, e); - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) - || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); - - if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))) - { - if (INDIRECT_REF_P (se.expr)) - tmp = TREE_OPERAND (se.expr, 0); - else - tmp = se.expr; - - gfc_add_modify (&se.pre, sym->backend_decl, - gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp))); - } - else - gfc_add_modify (&se.pre, sym->backend_decl, se.expr); - - if (unlimited) - { - /* Recover the dtype, which has been overwritten by the - assignment from an unlimited polymorphic object. */ - tmp = gfc_conv_descriptor_dtype (sym->backend_decl); - gfc_add_modify (&se.pre, tmp, - gfc_get_dtype (TREE_TYPE (sym->backend_decl))); - } - - gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), - gfc_finish_block (&se.post)); - } - - /* Do a scalar pointer assignment; this is for scalar variable targets. */ - else if (gfc_is_associate_pointer (sym)) - { - gfc_se se; - - gcc_assert (!sym->attr.dimension); - - gfc_init_se (&se, NULL); - - /* Class associate-names come this way because they are - unconditionally associate pointers and the symbol is scalar. */ - if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) - { - tree target_expr; - /* For a class array we need a descriptor for the selector. */ - gfc_conv_expr_descriptor (&se, e); - /* Needed to get/set the _len component below. */ - target_expr = se.expr; - - /* Obtain a temporary class container for the result. */ - gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false); - se.expr = build_fold_indirect_ref_loc (input_location, se.expr); - - /* Set the offset. */ - desc = gfc_class_data_get (se.expr); - offset = gfc_index_zero_node; - for (n = 0; n < e->rank; n++) - { - dim = gfc_rank_cst[n]; - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_stride_get (desc, dim), - gfc_conv_descriptor_lbound_get (desc, dim)); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp); - } - if (need_len_assign) - { - if (e->symtree - && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl) - && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl) - && TREE_CODE (target_expr) != COMPONENT_REF) - /* Use the original class descriptor stored in the saved - descriptor to get the target_expr. */ - target_expr = - GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl); - else - /* Strip the _data component from the target_expr. */ - target_expr = TREE_OPERAND (target_expr, 0); - /* Add a reference to the _len comp to the target expr. */ - tmp = gfc_class_len_get (target_expr); - /* Get the component-ref for the temp structure's _len comp. */ - charlen = gfc_class_len_get (se.expr); - /* Add the assign to the beginning of the block... */ - gfc_add_modify (&se.pre, charlen, - fold_convert (TREE_TYPE (charlen), tmp)); - /* and the oposite way at the end of the block, to hand changes - on the string length back. */ - gfc_add_modify (&se.post, tmp, - fold_convert (TREE_TYPE (tmp), charlen)); - /* Length assignment done, prevent adding it again below. */ - need_len_assign = false; - } - gfc_conv_descriptor_offset_set (&se.pre, desc, offset); - } - else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS - && CLASS_DATA (e)->attr.dimension) - { - /* This is bound to be a class array element. */ - gfc_conv_expr_reference (&se, e); - /* Get the _vptr component of the class object. */ - tmp = gfc_get_vptr_from_expr (se.expr); - /* Obtain a temporary class container for the result. */ - gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false); - se.expr = build_fold_indirect_ref_loc (input_location, se.expr); - need_len_assign = false; - } - else - { - /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign, - which has the string length included. For CHARACTERS it is still - needed and will be done at the end of this routine. */ - gfc_conv_expr (&se, e); - need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER; - } - - if (sym->ts.type == BT_CHARACTER - && !sym->attr.select_type_temporary - && VAR_P (sym->ts.u.cl->backend_decl) - && se.string_length != sym->ts.u.cl->backend_decl) - { - gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, - fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), - se.string_length)); - if (e->expr_type == EXPR_FUNCTION) - { - tmp = gfc_call_free (sym->backend_decl); - gfc_add_expr_to_block (&se.post, tmp); - } - } - - if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER - && POINTER_TYPE_P (TREE_TYPE (se.expr))) - { - /* These are pointer types already. */ - tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr); - } - else - { - tree ctree = gfc_get_class_from_expr (se.expr); - tmp = TREE_TYPE (sym->backend_decl); - - /* Coarray scalar component expressions can emerge from - the front end as array elements of the _data field. */ - if (sym->ts.type == BT_CLASS - && e->ts.type == BT_CLASS && e->rank == 0 - && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree) - { - tree stmp; - tree dtmp; - - se.expr = ctree; - dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl)); - ctree = gfc_create_var (dtmp, "class"); - - stmp = gfc_class_data_get (se.expr); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))); - - /* Set the fields of the target class variable. */ - stmp = gfc_conv_descriptor_data_get (stmp); - dtmp = gfc_class_data_get (ctree); - stmp = fold_convert (TREE_TYPE (dtmp), stmp); - gfc_add_modify (&se.pre, dtmp, stmp); - stmp = gfc_class_vptr_get (se.expr); - dtmp = gfc_class_vptr_get (ctree); - stmp = fold_convert (TREE_TYPE (dtmp), stmp); - gfc_add_modify (&se.pre, dtmp, stmp); - if (UNLIMITED_POLY (sym)) - { - stmp = gfc_class_len_get (se.expr); - dtmp = gfc_class_len_get (ctree); - stmp = fold_convert (TREE_TYPE (dtmp), stmp); - gfc_add_modify (&se.pre, dtmp, stmp); - } - se.expr = ctree; - } - tmp = gfc_build_addr_expr (tmp, se.expr); - } - - gfc_add_modify (&se.pre, sym->backend_decl, tmp); - - gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), - gfc_finish_block (&se.post)); - } - - /* Do a simple assignment. This is for scalar expressions, where we - can simply use expression assignment. */ - else - { - gfc_expr *lhs; - tree res; - gfc_se se; - - gfc_init_se (&se, NULL); - - /* resolve.c converts some associate names to allocatable so that - allocation can take place automatically in gfc_trans_assignment. - The frontend prevents them from being either allocated, - deallocated or reallocated. */ - if (sym->attr.allocatable) - { - tmp = sym->backend_decl; - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_conv_descriptor_data_get (tmp); - gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - } - - lhs = gfc_lval_expr_from_sym (sym); - res = gfc_trans_assignment (lhs, e, false, true); - gfc_add_expr_to_block (&se.pre, res); - - tmp = sym->backend_decl; - if (e->expr_type == EXPR_FUNCTION - && sym->ts.type == BT_DERIVED - && sym->ts.u.derived - && sym->ts.u.derived->attr.pdt_type) - { - tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp, - 0); - } - else if (e->expr_type == EXPR_FUNCTION - && sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->ts.u.derived - && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) - { - tmp = gfc_class_data_get (tmp); - tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived, - tmp, 0); - } - else if (sym->attr.allocatable) - { - tmp = sym->backend_decl; - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_conv_descriptor_data_get (tmp); - - /* A simple call to free suffices here. */ - tmp = gfc_call_free (tmp); - - /* Make sure that reallocation on assignment cannot occur. */ - sym->attr.allocatable = 0; - } - else - tmp = NULL_TREE; - - res = gfc_finish_block (&se.pre); - gfc_add_init_cleanup (block, res, tmp); - gfc_free_expr (lhs); - } - - /* Set the stringlength, when needed. */ - if (need_len_assign) - { - gfc_se se; - gfc_init_se (&se, NULL); - if (e->symtree->n.sym->ts.type == BT_CHARACTER) - { - /* Deferred strings are dealt with in the preceeding. */ - gcc_assert (!e->symtree->n.sym->ts.deferred); - tmp = e->symtree->n.sym->ts.u.cl->backend_decl; - } - else if (e->symtree->n.sym->attr.function - && e->symtree->n.sym == e->symtree->n.sym->result) - { - tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); - tmp = gfc_class_len_get (tmp); - } - else - tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym)); - gfc_get_symbol_decl (sym); - charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl - : gfc_class_len_get (sym->backend_decl); - /* Prevent adding a noop len= len. */ - if (tmp != charlen) - { - gfc_add_modify (&se.pre, charlen, - fold_convert (TREE_TYPE (charlen), tmp)); - gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), - gfc_finish_block (&se.post)); - } - } -} - - -/* Translate a BLOCK construct. This is basically what we would do for a - procedure body. */ - -tree -gfc_trans_block_construct (gfc_code* code) -{ - gfc_namespace* ns; - gfc_symbol* sym; - gfc_wrapped_block block; - tree exit_label; - stmtblock_t body; - gfc_association_list *ass; - - ns = code->ext.block.ns; - gcc_assert (ns); - sym = ns->proc_name; - gcc_assert (sym); - - /* Process local variables. */ - gcc_assert (!sym->tlink); - sym->tlink = sym; - gfc_process_block_locals (ns); - - /* Generate code including exit-label. */ - gfc_init_block (&body); - exit_label = gfc_build_label_decl (NULL_TREE); - code->exit_label = exit_label; - - finish_oacc_declare (ns, sym, true); - - gfc_add_expr_to_block (&body, gfc_trans_code (ns->code)); - gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); - - /* Finish everything. */ - gfc_start_wrapped_block (&block, gfc_finish_block (&body)); - gfc_trans_deferred_vars (sym, &block); - for (ass = code->ext.block.assoc; ass; ass = ass->next) - trans_associate_var (ass->st->n.sym, &block); - - return gfc_finish_wrapped_block (&block); -} - -/* Translate the simple DO construct in a C-style manner. - This is where the loop variable has integer type and step +-1. - Following code will generate infinite loop in case where TO is INT_MAX - (for +1 step) or INT_MIN (for -1 step) - - We translate a do loop from: - - DO dovar = from, to, step - body - END DO - - to: - - [Evaluate loop bounds and step] - dovar = from; - for (;;) - { - if (dovar > to) - goto end_label; - body; - cycle_label: - dovar += step; - } - end_label: - - This helps the optimizers by avoiding the extra pre-header condition and - we save a register as we just compare the updated IV (not a value in - previous step). */ - -static tree -gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, - tree from, tree to, tree step, tree exit_cond) -{ - stmtblock_t body; - tree type; - tree cond; - tree tmp; - tree saved_dovar = NULL; - tree cycle_label; - tree exit_label; - location_t loc; - type = TREE_TYPE (dovar); - bool is_step_positive = tree_int_cst_sgn (step) > 0; - - loc = gfc_get_location (&code->ext.iterator->start->where); - - /* Initialize the DO variable: dovar = from. */ - gfc_add_modify_loc (loc, pblock, dovar, - fold_convert (TREE_TYPE (dovar), from)); - - /* Save value for do-tinkering checking. */ - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - { - saved_dovar = gfc_create_var (type, ".saved_dovar"); - gfc_add_modify_loc (loc, pblock, saved_dovar, dovar); - } - - /* Cycle and exit statements are implemented with gotos. */ - cycle_label = gfc_build_label_decl (NULL_TREE); - exit_label = gfc_build_label_decl (NULL_TREE); - - /* Put the labels where they can be found later. See gfc_trans_do(). */ - code->cycle_label = cycle_label; - code->exit_label = exit_label; - - /* Loop body. */ - gfc_start_block (&body); - - /* Exit the loop if there is an I/O result condition or error. */ - if (exit_cond) - { - tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, - exit_cond, tmp, - build_empty_stmt (loc)); - gfc_add_expr_to_block (&body, tmp); - } - - /* Evaluate the loop condition. */ - if (is_step_positive) - cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar, - fold_convert (type, to)); - else - cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar, - fold_convert (type, to)); - - cond = gfc_evaluate_now_loc (loc, cond, &body); - if (code->ext.iterator->unroll && cond != error_mark_node) - cond - = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_unroll_kind), - build_int_cst (integer_type_node, code->ext.iterator->unroll)); - - if (code->ext.iterator->ivdep && cond != error_mark_node) - cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_ivdep_kind), - integer_zero_node); - if (code->ext.iterator->vector && cond != error_mark_node) - cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_vector_kind), - integer_zero_node); - if (code->ext.iterator->novector && cond != error_mark_node) - cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_no_vector_kind), - integer_zero_node); - - /* The loop exit. */ - tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); - TREE_USED (exit_label) = 1; - tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (loc)); - gfc_add_expr_to_block (&body, tmp); - - /* Check whether the induction variable is equal to INT_MAX - (respectively to INT_MIN). */ - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - { - tree boundary = is_step_positive ? TYPE_MAX_VALUE (type) - : TYPE_MIN_VALUE (type); - - tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node, - dovar, boundary); - gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, - "Loop iterates infinitely"); - } - - /* Main loop body. */ - tmp = gfc_trans_code_cond (code->block->next, exit_cond); - gfc_add_expr_to_block (&body, tmp); - - /* Label for cycle statements (if needed). */ - if (TREE_USED (cycle_label)) - { - tmp = build1_v (LABEL_EXPR, cycle_label); - gfc_add_expr_to_block (&body, tmp); - } - - /* Check whether someone has modified the loop variable. */ - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - { - tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, - dovar, saved_dovar); - gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, - "Loop variable has been modified"); - } - - /* Increment the loop variable. */ - tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); - gfc_add_modify_loc (loc, &body, dovar, tmp); - - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - gfc_add_modify_loc (loc, &body, saved_dovar, dovar); - - /* Finish the loop body. */ - tmp = gfc_finish_block (&body); - tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); - - gfc_add_expr_to_block (pblock, tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (pblock, tmp); - - return gfc_finish_block (pblock); -} - -/* Translate the DO construct. This obviously is one of the most - important ones to get right with any compiler, but especially - so for Fortran. - - We special case some loop forms as described in gfc_trans_simple_do. - For other cases we implement them with a separate loop count, - as described in the standard. - - We translate a do loop from: - - DO dovar = from, to, step - body - END DO - - to: - - [evaluate loop bounds and step] - empty = (step > 0 ? to < from : to > from); - countm1 = (to - from) / step; - dovar = from; - if (empty) goto exit_label; - for (;;) - { - body; -cycle_label: - dovar += step - countm1t = countm1; - countm1--; - if (countm1t == 0) goto exit_label; - } -exit_label: - - countm1 is an unsigned integer. It is equal to the loop count minus one, - because the loop count itself can overflow. */ - -tree -gfc_trans_do (gfc_code * code, tree exit_cond) -{ - gfc_se se; - tree dovar; - tree saved_dovar = NULL; - tree from; - tree to; - tree step; - tree countm1; - tree type; - tree utype; - tree cond; - tree cycle_label; - tree exit_label; - tree tmp; - stmtblock_t block; - stmtblock_t body; - location_t loc; - - gfc_start_block (&block); - - loc = gfc_get_location (&code->ext.iterator->start->where); - - /* Evaluate all the expressions in the iterator. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->ext.iterator->var); - gfc_add_block_to_block (&block, &se.pre); - dovar = se.expr; - type = TREE_TYPE (dovar); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->ext.iterator->start); - gfc_add_block_to_block (&block, &se.pre); - from = gfc_evaluate_now (se.expr, &block); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->ext.iterator->end); - gfc_add_block_to_block (&block, &se.pre); - to = gfc_evaluate_now (se.expr, &block); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->ext.iterator->step); - gfc_add_block_to_block (&block, &se.pre); - step = gfc_evaluate_now (se.expr, &block); - - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - { - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step, - build_zero_cst (type)); - gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, - "DO step value is zero"); - } - - /* Special case simple loops. */ - if (TREE_CODE (type) == INTEGER_TYPE - && (integer_onep (step) - || tree_int_cst_equal (step, integer_minus_one_node))) - return gfc_trans_simple_do (code, &block, dovar, from, to, step, - exit_cond); - - if (TREE_CODE (type) == INTEGER_TYPE) - utype = unsigned_type_for (type); - else - utype = unsigned_type_for (gfc_array_index_type); - countm1 = gfc_create_var (utype, "countm1"); - - /* Cycle and exit statements are implemented with gotos. */ - cycle_label = gfc_build_label_decl (NULL_TREE); - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - - /* Put these labels where they can be found later. */ - code->cycle_label = cycle_label; - code->exit_label = exit_label; - - /* Initialize the DO variable: dovar = from. */ - gfc_add_modify (&block, dovar, from); - - /* Save value for do-tinkering checking. */ - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - { - saved_dovar = gfc_create_var (type, ".saved_dovar"); - gfc_add_modify_loc (loc, &block, saved_dovar, dovar); - } - - /* Initialize loop count and jump to exit label if the loop is empty. - This code is executed before we enter the loop body. We generate: - if (step > 0) - { - countm1 = (to - from) / step; - if (to < from) - goto exit_label; - } - else - { - countm1 = (from - to) / -step; - if (to > from) - goto exit_label; - } - */ - - if (TREE_CODE (type) == INTEGER_TYPE) - { - tree pos, neg, tou, fromu, stepu, tmp2; - - /* The distance from FROM to TO cannot always be represented in a signed - type, thus use unsigned arithmetic, also to avoid any undefined - overflow issues. */ - tou = fold_convert (utype, to); - fromu = fold_convert (utype, from); - stepu = fold_convert (utype, step); - - /* For a positive step, when to < from, exit, otherwise compute - countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */ - tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from); - tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, - fold_build2_loc (loc, MINUS_EXPR, utype, - tou, fromu), - stepu); - pos = build2 (COMPOUND_EXPR, void_type_node, - fold_build2 (MODIFY_EXPR, void_type_node, - countm1, tmp2), - build3_loc (loc, COND_EXPR, void_type_node, - gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), - build1_loc (loc, GOTO_EXPR, void_type_node, - exit_label), NULL_TREE)); - - /* For a negative step, when to > from, exit, otherwise compute - countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */ - tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from); - tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, - fold_build2_loc (loc, MINUS_EXPR, utype, - fromu, tou), - fold_build1_loc (loc, NEGATE_EXPR, utype, stepu)); - neg = build2 (COMPOUND_EXPR, void_type_node, - fold_build2 (MODIFY_EXPR, void_type_node, - countm1, tmp2), - build3_loc (loc, COND_EXPR, void_type_node, - gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), - build1_loc (loc, GOTO_EXPR, void_type_node, - exit_label), NULL_TREE)); - - tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step, - build_int_cst (TREE_TYPE (step), 0)); - tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos); - - gfc_add_expr_to_block (&block, tmp); - } - else - { - tree pos_step; - - /* TODO: We could use the same width as the real type. - This would probably cause more problems that it solves - when we implement "long double" types. */ - - tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from); - tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step); - tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp); - gfc_add_modify (&block, countm1, tmp); - - /* We need a special check for empty loops: - empty = (step > 0 ? to < from : to > from); */ - pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step, - build_zero_cst (type)); - tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step, - fold_build2_loc (loc, LT_EXPR, - logical_type_node, to, from), - fold_build2_loc (loc, GT_EXPR, - logical_type_node, to, from)); - /* If the loop is empty, go directly to the exit label. */ - tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, - build1_v (GOTO_EXPR, exit_label), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - - /* Loop body. */ - gfc_start_block (&body); - - /* Main loop body. */ - tmp = gfc_trans_code_cond (code->block->next, exit_cond); - gfc_add_expr_to_block (&body, tmp); - - /* Label for cycle statements (if needed). */ - if (TREE_USED (cycle_label)) - { - tmp = build1_v (LABEL_EXPR, cycle_label); - gfc_add_expr_to_block (&body, tmp); - } - - /* Check whether someone has modified the loop variable. */ - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - { - tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar, - saved_dovar); - gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, - "Loop variable has been modified"); - } - - /* Exit the loop if there is an I/O result condition or error. */ - if (exit_cond) - { - tmp = build1_v (GOTO_EXPR, exit_label); - tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, - exit_cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&body, tmp); - } - - /* Increment the loop variable. */ - tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); - gfc_add_modify_loc (loc, &body, dovar, tmp); - - if (gfc_option.rtcheck & GFC_RTCHECK_DO) - gfc_add_modify_loc (loc, &body, saved_dovar, dovar); - - /* Initialize countm1t. */ - tree countm1t = gfc_create_var (utype, "countm1t"); - gfc_add_modify_loc (loc, &body, countm1t, countm1); - - /* Decrement the loop count. */ - tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1, - build_int_cst (utype, 1)); - gfc_add_modify_loc (loc, &body, countm1, tmp); - - /* End with the loop condition. Loop until countm1t == 0. */ - cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t, - build_int_cst (utype, 0)); - if (code->ext.iterator->unroll && cond != error_mark_node) - cond - = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_unroll_kind), - build_int_cst (integer_type_node, code->ext.iterator->unroll)); - - if (code->ext.iterator->ivdep && cond != error_mark_node) - cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_ivdep_kind), - integer_zero_node); - if (code->ext.iterator->vector && cond != error_mark_node) - cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_vector_kind), - integer_zero_node); - if (code->ext.iterator->novector && cond != error_mark_node) - cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, annot_expr_no_vector_kind), - integer_zero_node); - - tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); - tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, - cond, tmp, build_empty_stmt (loc)); - gfc_add_expr_to_block (&body, tmp); - - /* End of loop body. */ - tmp = gfc_finish_block (&body); - - /* The for loop itself. */ - tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); - gfc_add_expr_to_block (&block, tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -/* Translate the DO WHILE construct. - - We translate - - DO WHILE (cond) - body - END DO - - to: - - for ( ; ; ) - { - pre_cond; - if (! cond) goto exit_label; - body; -cycle_label: - } -exit_label: - - Because the evaluation of the exit condition `cond' may have side - effects, we can't do much for empty loop bodies. The backend optimizers - should be smart enough to eliminate any dead loops. */ - -tree -gfc_trans_do_while (gfc_code * code) -{ - gfc_se cond; - tree tmp; - tree cycle_label; - tree exit_label; - stmtblock_t block; - - /* Everything we build here is part of the loop body. */ - gfc_start_block (&block); - - /* Cycle and exit statements are implemented with gotos. */ - cycle_label = gfc_build_label_decl (NULL_TREE); - exit_label = gfc_build_label_decl (NULL_TREE); - - /* Put the labels where they can be found later. See gfc_trans_do(). */ - code->cycle_label = cycle_label; - code->exit_label = exit_label; - - /* Create a GIMPLE version of the exit condition. */ - gfc_init_se (&cond, NULL); - gfc_conv_expr_val (&cond, code->expr1); - gfc_add_block_to_block (&block, &cond.pre); - cond.expr = fold_build1_loc (gfc_get_location (&code->expr1->where), - TRUTH_NOT_EXPR, TREE_TYPE (cond.expr), - cond.expr); - - /* Build "IF (! cond) GOTO exit_label". */ - tmp = build1_v (GOTO_EXPR, exit_label); - TREE_USED (exit_label) = 1; - tmp = fold_build3_loc (gfc_get_location (&code->expr1->where), COND_EXPR, - void_type_node, cond.expr, tmp, - build_empty_stmt (gfc_get_location ( - &code->expr1->where))); - gfc_add_expr_to_block (&block, tmp); - - /* The main body of the loop. */ - tmp = gfc_trans_code (code->block->next); - gfc_add_expr_to_block (&block, tmp); - - /* Label for cycle statements (if needed). */ - if (TREE_USED (cycle_label)) - { - tmp = build1_v (LABEL_EXPR, cycle_label); - gfc_add_expr_to_block (&block, tmp); - } - - /* End of loop body. */ - tmp = gfc_finish_block (&block); - - gfc_init_block (&block); - /* Build the loop. */ - tmp = fold_build1_loc (gfc_get_location (&code->expr1->where), LOOP_EXPR, - void_type_node, tmp); - gfc_add_expr_to_block (&block, tmp); - - /* Add the exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -/* Deal with the particular case of SELECT_TYPE, where the vtable - addresses are used for the selection. Since these are not sorted, - the selection has to be made by a series of if statements. */ - -static tree -gfc_trans_select_type_cases (gfc_code * code) -{ - gfc_code *c; - gfc_case *cp; - tree tmp; - tree cond; - tree low; - tree high; - gfc_se se; - gfc_se cse; - stmtblock_t block; - stmtblock_t body; - bool def = false; - gfc_expr *e; - gfc_start_block (&block); - - /* Calculate the switch expression. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->expr1); - gfc_add_block_to_block (&block, &se.pre); - - /* Generate an expression for the selector hash value, for - use to resolve character cases. */ - e = gfc_copy_expr (code->expr1->value.function.actual->expr); - gfc_add_hash_component (e); - - TREE_USED (code->exit_label) = 0; - -repeat: - for (c = code->block; c; c = c->block) - { - cp = c->ext.block.case_list; - - /* Assume it's the default case. */ - low = NULL_TREE; - high = NULL_TREE; - tmp = NULL_TREE; - - /* Put the default case at the end. */ - if ((!def && !cp->low) || (def && cp->low)) - continue; - - if (cp->low && (cp->ts.type == BT_CLASS - || cp->ts.type == BT_DERIVED)) - { - gfc_init_se (&cse, NULL); - gfc_conv_expr_val (&cse, cp->low); - gfc_add_block_to_block (&block, &cse.pre); - low = cse.expr; - } - else if (cp->ts.type != BT_UNKNOWN) - { - gcc_assert (cp->high); - gfc_init_se (&cse, NULL); - gfc_conv_expr_val (&cse, cp->high); - gfc_add_block_to_block (&block, &cse.pre); - high = cse.expr; - } - - gfc_init_block (&body); - - /* Add the statements for this case. */ - tmp = gfc_trans_code (c->next); - gfc_add_expr_to_block (&body, tmp); - - /* Break to the end of the SELECT TYPE construct. The default - case just falls through. */ - if (!def) - { - TREE_USED (code->exit_label) = 1; - tmp = build1_v (GOTO_EXPR, code->exit_label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_finish_block (&body); - - if (low != NULL_TREE) - { - /* Compare vtable pointers. */ - cond = fold_build2_loc (input_location, EQ_EXPR, - TREE_TYPE (se.expr), se.expr, low); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, - build_empty_stmt (input_location)); - } - else if (high != NULL_TREE) - { - /* Compare hash values for character cases. */ - gfc_init_se (&cse, NULL); - gfc_conv_expr_val (&cse, e); - gfc_add_block_to_block (&block, &cse.pre); - - cond = fold_build2_loc (input_location, EQ_EXPR, - TREE_TYPE (se.expr), high, cse.expr); - 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); - } - - if (!def) - { - def = true; - goto repeat; - } - - gfc_free_expr (e); - - return gfc_finish_block (&block); -} - - -/* Translate the SELECT CASE construct for INTEGER case expressions, - without killing all potential optimizations. The problem is that - Fortran allows unbounded cases, but the back-end does not, so we - need to intercept those before we enter the equivalent SWITCH_EXPR - we can build. - - For example, we translate this, - - SELECT CASE (expr) - CASE (:100,101,105:115) - block_1 - CASE (190:199,200:) - block_2 - CASE (300) - block_3 - CASE DEFAULT - block_4 - END SELECT - - to the GENERIC equivalent, - - switch (expr) - { - case (minimum value for typeof(expr) ... 100: - case 101: - case 105 ... 114: - block1: - goto end_label; - - case 200 ... (maximum value for typeof(expr): - case 190 ... 199: - block2; - goto end_label; - - case 300: - block_3; - goto end_label; - - default: - block_4; - goto end_label; - } - - end_label: */ - -static tree -gfc_trans_integer_select (gfc_code * code) -{ - gfc_code *c; - gfc_case *cp; - tree end_label; - tree tmp; - gfc_se se; - stmtblock_t block; - stmtblock_t body; - - gfc_start_block (&block); - - /* Calculate the switch expression. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->expr1); - gfc_add_block_to_block (&block, &se.pre); - - end_label = gfc_build_label_decl (NULL_TREE); - - gfc_init_block (&body); - - for (c = code->block; c; c = c->block) - { - for (cp = c->ext.block.case_list; cp; cp = cp->next) - { - tree low, high; - tree label; - - /* Assume it's the default case. */ - low = high = NULL_TREE; - - if (cp->low) - { - low = gfc_conv_mpz_to_tree (cp->low->value.integer, - cp->low->ts.kind); - - /* If there's only a lower bound, set the high bound to the - maximum value of the case expression. */ - if (!cp->high) - high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); - } - - if (cp->high) - { - /* Three cases are possible here: - - 1) There is no lower bound, e.g. CASE (:N). - 2) There is a lower bound .NE. high bound, that is - a case range, e.g. CASE (N:M) where M>N (we make - sure that M>N during type resolution). - 3) There is a lower bound, and it has the same value - as the high bound, e.g. CASE (N:N). This is our - internal representation of CASE(N). - - In the first and second case, we need to set a value for - high. In the third case, we don't because the GCC middle - end represents a single case value by just letting high be - a NULL_TREE. We can't do that because we need to be able - to represent unbounded cases. */ - - if (!cp->low - || (mpz_cmp (cp->low->value.integer, - cp->high->value.integer) != 0)) - high = gfc_conv_mpz_to_tree (cp->high->value.integer, - cp->high->ts.kind); - - /* Unbounded case. */ - if (!cp->low) - low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); - } - - /* Build a label. */ - label = gfc_build_label_decl (NULL_TREE); - - /* Add this case label. - Add parameter 'label', make it match GCC backend. */ - tmp = build_case_label (low, high, label); - gfc_add_expr_to_block (&body, tmp); - } - - /* Add the statements for this case. */ - tmp = gfc_trans_code (c->next); - gfc_add_expr_to_block (&body, tmp); - - /* Break to the end of the construct. */ - tmp = build1_v (GOTO_EXPR, end_label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_finish_block (&body); - tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp); - gfc_add_expr_to_block (&block, tmp); - - tmp = build1_v (LABEL_EXPR, end_label); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -/* Translate the SELECT CASE construct for LOGICAL case expressions. - - There are only two cases possible here, even though the standard - does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., - .FALSE., and DEFAULT. - - We never generate more than two blocks here. Instead, we always - try to eliminate the DEFAULT case. This way, we can translate this - kind of SELECT construct to a simple - - if {} else {}; - - expression in GENERIC. */ - -static tree -gfc_trans_logical_select (gfc_code * code) -{ - gfc_code *c; - gfc_code *t, *f, *d; - gfc_case *cp; - gfc_se se; - stmtblock_t block; - - /* Assume we don't have any cases at all. */ - t = f = d = NULL; - - /* Now see which ones we actually do have. We can have at most two - cases in a single case list: one for .TRUE. and one for .FALSE. - The default case is always separate. If the cases for .TRUE. and - .FALSE. are in the same case list, the block for that case list - always executed, and we don't generate code a COND_EXPR. */ - for (c = code->block; c; c = c->block) - { - for (cp = c->ext.block.case_list; cp; cp = cp->next) - { - if (cp->low) - { - if (cp->low->value.logical == 0) /* .FALSE. */ - f = c; - else /* if (cp->value.logical != 0), thus .TRUE. */ - t = c; - } - else - d = c; - } - } - - /* Start a new block. */ - gfc_start_block (&block); - - /* Calculate the switch expression. We always need to do this - because it may have side effects. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->expr1); - gfc_add_block_to_block (&block, &se.pre); - - if (t == f && t != NULL) - { - /* Cases for .TRUE. and .FALSE. are in the same block. Just - translate the code for these cases, append it to the current - block. */ - gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); - } - else - { - tree true_tree, false_tree, stmt; - - true_tree = build_empty_stmt (input_location); - false_tree = build_empty_stmt (input_location); - - /* If we have a case for .TRUE. and for .FALSE., discard the default case. - Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, - make the missing case the default case. */ - if (t != NULL && f != NULL) - d = NULL; - else if (d != NULL) - { - if (t == NULL) - t = d; - else - f = d; - } - - /* Translate the code for each of these blocks, and append it to - the current block. */ - if (t != NULL) - true_tree = gfc_trans_code (t->next); - - if (f != NULL) - false_tree = gfc_trans_code (f->next); - - stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, - se.expr, true_tree, false_tree); - gfc_add_expr_to_block (&block, stmt); - } - - return gfc_finish_block (&block); -} - - -/* The jump table types are stored in static variables to avoid - constructing them from scratch every single time. */ -static GTY(()) tree select_struct[2]; - -/* Translate the SELECT CASE construct for CHARACTER case expressions. - Instead of generating compares and jumps, it is far simpler to - generate a data structure describing the cases in order and call a - library subroutine that locates the right case. - This is particularly true because this is the only case where we - might have to dispose of a temporary. - The library subroutine returns a pointer to jump to or NULL if no - branches are to be taken. */ - -static tree -gfc_trans_character_select (gfc_code *code) -{ - tree init, end_label, tmp, type, case_num, label, fndecl; - stmtblock_t block, body; - gfc_case *cp, *d; - gfc_code *c; - gfc_se se, expr1se; - int n, k; - vec *inits = NULL; - - tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); - - /* The jump table types are stored in static variables to avoid - constructing them from scratch every single time. */ - static tree ss_string1[2], ss_string1_len[2]; - static tree ss_string2[2], ss_string2_len[2]; - static tree ss_target[2]; - - cp = code->block->ext.block.case_list; - while (cp->left != NULL) - cp = cp->left; - - /* Generate the body */ - gfc_start_block (&block); - gfc_init_se (&expr1se, NULL); - gfc_conv_expr_reference (&expr1se, code->expr1); - - gfc_add_block_to_block (&block, &expr1se.pre); - - end_label = gfc_build_label_decl (NULL_TREE); - - gfc_init_block (&body); - - /* Attempt to optimize length 1 selects. */ - if (integer_onep (expr1se.string_length)) - { - for (d = cp; d; d = d->right) - { - gfc_charlen_t i; - if (d->low) - { - gcc_assert (d->low->expr_type == EXPR_CONSTANT - && d->low->ts.type == BT_CHARACTER); - if (d->low->value.character.length > 1) - { - for (i = 1; i < d->low->value.character.length; i++) - if (d->low->value.character.string[i] != ' ') - break; - if (i != d->low->value.character.length) - { - if (optimize && d->high && i == 1) - { - gcc_assert (d->high->expr_type == EXPR_CONSTANT - && d->high->ts.type == BT_CHARACTER); - if (d->high->value.character.length > 1 - && (d->low->value.character.string[0] - == d->high->value.character.string[0]) - && d->high->value.character.string[1] != ' ' - && ((d->low->value.character.string[1] < ' ') - == (d->high->value.character.string[1] - < ' '))) - continue; - } - break; - } - } - } - if (d->high) - { - gcc_assert (d->high->expr_type == EXPR_CONSTANT - && d->high->ts.type == BT_CHARACTER); - if (d->high->value.character.length > 1) - { - for (i = 1; i < d->high->value.character.length; i++) - if (d->high->value.character.string[i] != ' ') - break; - if (i != d->high->value.character.length) - break; - } - } - } - if (d == NULL) - { - tree ctype = gfc_get_char_type (code->expr1->ts.kind); - - for (c = code->block; c; c = c->block) - { - for (cp = c->ext.block.case_list; cp; cp = cp->next) - { - tree low, high; - tree label; - gfc_char_t r; - - /* Assume it's the default case. */ - low = high = NULL_TREE; - - if (cp->low) - { - /* CASE ('ab') or CASE ('ab':'az') will never match - any length 1 character. */ - if (cp->low->value.character.length > 1 - && cp->low->value.character.string[1] != ' ') - continue; - - if (cp->low->value.character.length > 0) - r = cp->low->value.character.string[0]; - else - r = ' '; - low = build_int_cst (ctype, r); - - /* If there's only a lower bound, set the high bound - to the maximum value of the case expression. */ - if (!cp->high) - high = TYPE_MAX_VALUE (ctype); - } - - if (cp->high) - { - if (!cp->low - || (cp->low->value.character.string[0] - != cp->high->value.character.string[0])) - { - if (cp->high->value.character.length > 0) - r = cp->high->value.character.string[0]; - else - r = ' '; - high = build_int_cst (ctype, r); - } - - /* Unbounded case. */ - if (!cp->low) - low = TYPE_MIN_VALUE (ctype); - } - - /* Build a label. */ - label = gfc_build_label_decl (NULL_TREE); - - /* Add this case label. - Add parameter 'label', make it match GCC backend. */ - tmp = build_case_label (low, high, label); - gfc_add_expr_to_block (&body, tmp); - } - - /* Add the statements for this case. */ - tmp = gfc_trans_code (c->next); - gfc_add_expr_to_block (&body, tmp); - - /* Break to the end of the construct. */ - tmp = build1_v (GOTO_EXPR, end_label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_string_to_single_character (expr1se.string_length, - expr1se.expr, - code->expr1->ts.kind); - case_num = gfc_create_var (ctype, "case_num"); - gfc_add_modify (&block, case_num, tmp); - - gfc_add_block_to_block (&block, &expr1se.post); - - tmp = gfc_finish_block (&body); - tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, - case_num, tmp); - gfc_add_expr_to_block (&block, tmp); - - tmp = build1_v (LABEL_EXPR, end_label); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); - } - } - - if (code->expr1->ts.kind == 1) - k = 0; - else if (code->expr1->ts.kind == 4) - k = 1; - else - gcc_unreachable (); - - if (select_struct[k] == NULL) - { - tree *chain = NULL; - select_struct[k] = make_node (RECORD_TYPE); - - if (code->expr1->ts.kind == 1) - TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1"); - else if (code->expr1->ts.kind == 4) - TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4"); - else - gcc_unreachable (); - -#undef ADD_FIELD -#define ADD_FIELD(NAME, TYPE) \ - ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \ - get_identifier (stringize(NAME)), \ - TYPE, \ - &chain) - - ADD_FIELD (string1, pchartype); - ADD_FIELD (string1_len, gfc_charlen_type_node); - - ADD_FIELD (string2, pchartype); - ADD_FIELD (string2_len, gfc_charlen_type_node); - - ADD_FIELD (target, integer_type_node); -#undef ADD_FIELD - - gfc_finish_type (select_struct[k]); - } - - n = 0; - for (d = cp; d; d = d->right) - d->n = n++; - - for (c = code->block; c; c = c->block) - { - for (d = c->ext.block.case_list; d; d = d->next) - { - label = gfc_build_label_decl (NULL_TREE); - tmp = build_case_label ((d->low == NULL && d->high == NULL) - ? NULL - : build_int_cst (integer_type_node, d->n), - NULL, label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_trans_code (c->next); - gfc_add_expr_to_block (&body, tmp); - - tmp = build1_v (GOTO_EXPR, end_label); - gfc_add_expr_to_block (&body, tmp); - } - - /* Generate the structure describing the branches */ - for (d = cp; d; d = d->right) - { - vec *node = NULL; - - gfc_init_se (&se, NULL); - - if (d->low == NULL) - { - CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); - CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node)); - } - else - { - gfc_conv_expr_reference (&se, d->low); - - CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr); - CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length); - } - - if (d->high == NULL) - { - CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); - CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node)); - } - else - { - gfc_init_se (&se, NULL); - gfc_conv_expr_reference (&se, d->high); - - CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr); - CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length); - } - - CONSTRUCTOR_APPEND_ELT (node, ss_target[k], - build_int_cst (integer_type_node, d->n)); - - tmp = build_constructor (select_struct[k], node); - CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp); - } - - type = build_array_type (select_struct[k], - build_index_type (size_int (n-1))); - - init = build_constructor (type, inits); - TREE_CONSTANT (init) = 1; - TREE_STATIC (init) = 1; - /* Create a static variable to hold the jump table. */ - tmp = gfc_create_var (type, "jumptable"); - TREE_CONSTANT (tmp) = 1; - TREE_STATIC (tmp) = 1; - TREE_READONLY (tmp) = 1; - DECL_INITIAL (tmp) = init; - init = tmp; - - /* Build the library call */ - init = gfc_build_addr_expr (pvoid_type_node, init); - - if (code->expr1->ts.kind == 1) - fndecl = gfor_fndecl_select_string; - else if (code->expr1->ts.kind == 4) - fndecl = gfor_fndecl_select_string_char4; - else - gcc_unreachable (); - - tmp = build_call_expr_loc (input_location, - fndecl, 4, init, - build_int_cst (gfc_charlen_type_node, n), - expr1se.expr, expr1se.string_length); - case_num = gfc_create_var (integer_type_node, "case_num"); - gfc_add_modify (&block, case_num, tmp); - - gfc_add_block_to_block (&block, &expr1se.post); - - tmp = gfc_finish_block (&body); - tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, - case_num, tmp); - gfc_add_expr_to_block (&block, tmp); - - tmp = build1_v (LABEL_EXPR, end_label); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -/* Translate the three variants of the SELECT CASE construct. - - SELECT CASEs with INTEGER case expressions can be translated to an - equivalent GENERIC switch statement, and for LOGICAL case - expressions we build one or two if-else compares. - - SELECT CASEs with CHARACTER case expressions are a whole different - story, because they don't exist in GENERIC. So we sort them and - do a binary search at runtime. - - Fortran has no BREAK statement, and it does not allow jumps from - one case block to another. That makes things a lot easier for - the optimizers. */ - -tree -gfc_trans_select (gfc_code * code) -{ - stmtblock_t block; - tree body; - tree exit_label; - - gcc_assert (code && code->expr1); - gfc_init_block (&block); - - /* Build the exit label and hang it in. */ - exit_label = gfc_build_label_decl (NULL_TREE); - code->exit_label = exit_label; - - /* Empty SELECT constructs are legal. */ - if (code->block == NULL) - body = build_empty_stmt (input_location); - - /* Select the correct translation function. */ - else - switch (code->expr1->ts.type) - { - case BT_LOGICAL: - body = gfc_trans_logical_select (code); - break; - - case BT_INTEGER: - body = gfc_trans_integer_select (code); - break; - - case BT_CHARACTER: - body = gfc_trans_character_select (code); - break; - - default: - gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); - /* Not reached */ - } - - /* Build everything together. */ - gfc_add_expr_to_block (&block, body); - gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); - - return gfc_finish_block (&block); -} - -tree -gfc_trans_select_type (gfc_code * code) -{ - stmtblock_t block; - tree body; - tree exit_label; - - gcc_assert (code && code->expr1); - gfc_init_block (&block); - - /* Build the exit label and hang it in. */ - exit_label = gfc_build_label_decl (NULL_TREE); - code->exit_label = exit_label; - - /* Empty SELECT constructs are legal. */ - if (code->block == NULL) - body = build_empty_stmt (input_location); - else - body = gfc_trans_select_type_cases (code); - - /* Build everything together. */ - gfc_add_expr_to_block (&block, body); - - if (TREE_USED (exit_label)) - gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); - - return gfc_finish_block (&block); -} - - -static tree -gfc_trans_select_rank_cases (gfc_code * code) -{ - gfc_code *c; - gfc_case *cp; - tree tmp; - tree cond; - tree low; - tree rank; - gfc_se se; - gfc_se cse; - stmtblock_t block; - stmtblock_t body; - bool def = false; - - gfc_start_block (&block); - - /* Calculate the switch expression. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_descriptor (&se, code->expr1); - rank = gfc_conv_descriptor_rank (se.expr); - rank = gfc_evaluate_now (rank, &block); - symbol_attribute attr = gfc_expr_attr (code->expr1); - if (!attr.pointer && !attr.allocatable) - { - /* Special case for assumed-rank ('rank(*)', internally -1): - rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */ - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - rank, build_int_cst (TREE_TYPE (rank), 0)); - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - fold_convert (gfc_array_index_type, rank), - gfc_index_one_node); - tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, build_int_cst (TREE_TYPE (tmp), -1)); - cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - logical_type_node, cond, tmp); - tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank), - cond, rank, build_int_cst (TREE_TYPE (rank), -1)); - rank = gfc_evaluate_now (tmp, &block); - } - TREE_USED (code->exit_label) = 0; - -repeat: - for (c = code->block; c; c = c->block) - { - cp = c->ext.block.case_list; - - /* Assume it's the default case. */ - low = NULL_TREE; - tmp = NULL_TREE; - - /* Put the default case at the end. */ - if ((!def && !cp->low) || (def && cp->low)) - continue; - - if (cp->low) - { - gfc_init_se (&cse, NULL); - gfc_conv_expr_val (&cse, cp->low); - gfc_add_block_to_block (&block, &cse.pre); - low = cse.expr; - } - - gfc_init_block (&body); - - /* Add the statements for this case. */ - tmp = gfc_trans_code (c->next); - gfc_add_expr_to_block (&body, tmp); - - /* Break to the end of the SELECT RANK construct. The default - case just falls through. */ - if (!def) - { - TREE_USED (code->exit_label) = 1; - tmp = build1_v (GOTO_EXPR, code->exit_label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_finish_block (&body); - - if (low != NULL_TREE) - { - cond = fold_build2_loc (input_location, EQ_EXPR, - TREE_TYPE (rank), rank, - fold_convert (TREE_TYPE (rank), low)); - 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); - } - - if (!def) - { - def = true; - goto repeat; - } - - return gfc_finish_block (&block); -} - - -tree -gfc_trans_select_rank (gfc_code * code) -{ - stmtblock_t block; - tree body; - tree exit_label; - - gcc_assert (code && code->expr1); - gfc_init_block (&block); - - /* Build the exit label and hang it in. */ - exit_label = gfc_build_label_decl (NULL_TREE); - code->exit_label = exit_label; - - /* Empty SELECT constructs are legal. */ - if (code->block == NULL) - body = build_empty_stmt (input_location); - else - body = gfc_trans_select_rank_cases (code); - - /* Build everything together. */ - gfc_add_expr_to_block (&block, body); - - if (TREE_USED (exit_label)) - gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); - - return gfc_finish_block (&block); -} - - -/* Traversal function to substitute a replacement symtree if the symbol - in the expression is the same as that passed. f == 2 signals that - that variable itself is not to be checked - only the references. - This group of functions is used when the variable expression in a - FORALL assignment has internal references. For example: - FORALL (i = 1:4) p(p(i)) = i - The only recourse here is to store a copy of 'p' for the index - expression. */ - -static gfc_symtree *new_symtree; -static gfc_symtree *old_symtree; - -static bool -forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f) -{ - if (expr->expr_type != EXPR_VARIABLE) - return false; - - if (*f == 2) - *f = 1; - else if (expr->symtree->n.sym == sym) - expr->symtree = new_symtree; - - return false; -} - -static void -forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f) -{ - gfc_traverse_expr (e, sym, forall_replace, f); -} - -static bool -forall_restore (gfc_expr *expr, - gfc_symbol *sym ATTRIBUTE_UNUSED, - int *f ATTRIBUTE_UNUSED) -{ - if (expr->expr_type != EXPR_VARIABLE) - return false; - - if (expr->symtree == new_symtree) - expr->symtree = old_symtree; - - return false; -} - -static void -forall_restore_symtree (gfc_expr *e) -{ - gfc_traverse_expr (e, NULL, forall_restore, 0); -} - -static void -forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) -{ - gfc_se tse; - gfc_se rse; - gfc_expr *e; - gfc_symbol *new_sym; - gfc_symbol *old_sym; - gfc_symtree *root; - tree tmp; - - /* Build a copy of the lvalue. */ - old_symtree = c->expr1->symtree; - old_sym = old_symtree->n.sym; - e = gfc_lval_expr_from_sym (old_sym); - if (old_sym->attr.dimension) - { - gfc_init_se (&tse, NULL); - gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false); - gfc_add_block_to_block (pre, &tse.pre); - gfc_add_block_to_block (post, &tse.post); - tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr); - - if (c->expr1->ref->u.ar.type != AR_SECTION) - { - /* Use the variable offset for the temporary. */ - tmp = gfc_conv_array_offset (old_sym->backend_decl); - gfc_conv_descriptor_offset_set (pre, tse.expr, tmp); - } - } - else - { - gfc_init_se (&tse, NULL); - gfc_init_se (&rse, NULL); - gfc_conv_expr (&rse, e); - if (e->ts.type == BT_CHARACTER) - { - tse.string_length = rse.string_length; - tmp = gfc_get_character_type_len (gfc_default_character_kind, - tse.string_length); - tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp), - rse.string_length); - gfc_add_block_to_block (pre, &tse.pre); - gfc_add_block_to_block (post, &tse.post); - } - else - { - tmp = gfc_typenode_for_spec (&e->ts); - tse.expr = gfc_create_var (tmp, "temp"); - } - - tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, - e->expr_type == EXPR_VARIABLE, false); - gfc_add_expr_to_block (pre, tmp); - } - gfc_free_expr (e); - - /* Create a new symbol to represent the lvalue. */ - new_sym = gfc_new_symbol (old_sym->name, NULL); - new_sym->ts = old_sym->ts; - new_sym->attr.referenced = 1; - new_sym->attr.temporary = 1; - new_sym->attr.dimension = old_sym->attr.dimension; - new_sym->attr.flavor = old_sym->attr.flavor; - - /* Use the temporary as the backend_decl. */ - new_sym->backend_decl = tse.expr; - - /* Create a fake symtree for it. */ - root = NULL; - new_symtree = gfc_new_symtree (&root, old_sym->name); - new_symtree->n.sym = new_sym; - gcc_assert (new_symtree == root); - - /* Go through the expression reference replacing the old_symtree - with the new. */ - forall_replace_symtree (c->expr1, old_sym, 2); - - /* Now we have made this temporary, we might as well use it for - the right hand side. */ - forall_replace_symtree (c->expr2, old_sym, 1); -} - - -/* Handles dependencies in forall assignments. */ -static int -check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) -{ - gfc_ref *lref; - gfc_ref *rref; - int need_temp; - gfc_symbol *lsym; - - lsym = c->expr1->symtree->n.sym; - need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); - - /* Now check for dependencies within the 'variable' - expression itself. These are treated by making a complete - copy of variable and changing all the references to it - point to the copy instead. Note that the shallow copy of - the variable will not suffice for derived types with - pointer components. We therefore leave these to their - own devices. Likewise for allocatable components. */ - if (lsym->ts.type == BT_DERIVED - && (lsym->ts.u.derived->attr.pointer_comp - || lsym->ts.u.derived->attr.alloc_comp)) - return need_temp; - - new_symtree = NULL; - if (find_forall_index (c->expr1, lsym, 2)) - { - forall_make_variable_temp (c, pre, post); - need_temp = 0; - } - - /* Substrings with dependencies are treated in the same - way. */ - if (c->expr1->ts.type == BT_CHARACTER - && c->expr1->ref - && c->expr2->expr_type == EXPR_VARIABLE - && lsym == c->expr2->symtree->n.sym) - { - for (lref = c->expr1->ref; lref; lref = lref->next) - if (lref->type == REF_SUBSTRING) - break; - for (rref = c->expr2->ref; rref; rref = rref->next) - if (rref->type == REF_SUBSTRING) - break; - - if (rref && lref - && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0) - { - forall_make_variable_temp (c, pre, post); - need_temp = 0; - } - } - return need_temp; -} - - -static void -cleanup_forall_symtrees (gfc_code *c) -{ - forall_restore_symtree (c->expr1); - forall_restore_symtree (c->expr2); - free (new_symtree->n.sym); - free (new_symtree); -} - - -/* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY - is the contents of the FORALL block/stmt to be iterated. MASK_FLAG - indicates whether we should generate code to test the FORALLs mask - array. OUTER is the loop header to be used for initializing mask - indices. - - The generated loop format is: - count = (end - start + step) / step - loopvar = start - while (1) - { - if (count <=0 ) - goto end_of_loop - - loopvar += step - count -- - } - end_of_loop: */ - -static tree -gfc_trans_forall_loop (forall_info *forall_tmp, tree body, - int mask_flag, stmtblock_t *outer) -{ - int n, nvar; - tree tmp; - tree cond; - stmtblock_t block; - tree exit_label; - tree count; - tree var, start, end, step; - iter_info *iter; - - /* Initialize the mask index outside the FORALL nest. */ - if (mask_flag && forall_tmp->mask) - gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node); - - iter = forall_tmp->this_loop; - nvar = forall_tmp->nvar; - for (n = 0; n < nvar; n++) - { - var = iter->var; - start = iter->start; - end = iter->end; - step = iter->step; - - exit_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (exit_label) = 1; - - /* The loop counter. */ - count = gfc_create_var (TREE_TYPE (var), "count"); - - /* The body of the loop. */ - gfc_init_block (&block); - - /* The exit condition. */ - cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, - count, build_int_cst (TREE_TYPE (count), 0)); - - /* PR 83064 means that we cannot use annot_expr_parallel_kind until - the autoparallelizer can hande this. */ - if (forall_tmp->do_concurrent) - cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, - build_int_cst (integer_type_node, - annot_expr_ivdep_kind), - integer_zero_node); - - 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 (&block, tmp); - - /* The main loop body. */ - gfc_add_expr_to_block (&block, body); - - /* Increment the loop variable. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, - step); - gfc_add_modify (&block, var, tmp); - - /* Advance to the next mask element. Only do this for the - innermost loop. */ - if (n == 0 && mask_flag && forall_tmp->mask) - { - tree maskindex = forall_tmp->maskindex; - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - maskindex, gfc_index_one_node); - gfc_add_modify (&block, maskindex, tmp); - } - - /* Decrement the loop counter. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count, - build_int_cst (TREE_TYPE (var), 1)); - gfc_add_modify (&block, count, tmp); - - body = gfc_finish_block (&block); - - /* Loop var initialization. */ - gfc_init_block (&block); - gfc_add_modify (&block, var, start); - - - /* Initialize the loop counter. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step, - start); - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end, - tmp); - tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var), - tmp, step); - gfc_add_modify (&block, count, tmp); - - /* The loop expression. */ - tmp = build1_v (LOOP_EXPR, body); - gfc_add_expr_to_block (&block, tmp); - - /* The exit label. */ - tmp = build1_v (LABEL_EXPR, exit_label); - gfc_add_expr_to_block (&block, tmp); - - body = gfc_finish_block (&block); - iter = iter->next; - } - return body; -} - - -/* Generate the body and loops according to MASK_FLAG. If MASK_FLAG - is nonzero, the body is controlled by all masks in the forall nest. - Otherwise, the innermost loop is not controlled by it's mask. This - is used for initializing that mask. */ - -static tree -gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, - int mask_flag) -{ - tree tmp; - stmtblock_t header; - forall_info *forall_tmp; - tree mask, maskindex; - - gfc_start_block (&header); - - forall_tmp = nested_forall_info; - while (forall_tmp != NULL) - { - /* Generate body with masks' control. */ - if (mask_flag) - { - mask = forall_tmp->mask; - maskindex = forall_tmp->maskindex; - - /* If a mask was specified make the assignment conditional. */ - if (mask) - { - tmp = gfc_build_array_ref (mask, maskindex, NULL); - body = build3_v (COND_EXPR, tmp, body, - build_empty_stmt (input_location)); - } - } - body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header); - forall_tmp = forall_tmp->prev_nest; - mask_flag = 1; - } - - gfc_add_expr_to_block (&header, body); - return gfc_finish_block (&header); -} - - -/* Allocate data for holding a temporary array. Returns either a local - temporary array or a pointer variable. */ - -static tree -gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, - tree elem_type) -{ - tree tmpvar; - tree type; - tree tmp; - - if (INTEGER_CST_P (size)) - tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - else - tmp = NULL_TREE; - - type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); - type = build_array_type (elem_type, type); - if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size)) - { - tmpvar = gfc_create_var (type, "temp"); - *pdata = NULL_TREE; - } - else - { - tmpvar = gfc_create_var (build_pointer_type (type), "temp"); - *pdata = convert (pvoid_type_node, tmpvar); - - tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize); - gfc_add_modify (pblock, tmpvar, tmp); - } - return tmpvar; -} - - -/* Generate codes to copy the temporary to the actual lhs. */ - -static tree -generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, - tree count1, - gfc_ss *lss, gfc_ss *rss, - tree wheremask, bool invert) -{ - stmtblock_t block, body1; - gfc_loopinfo loop; - gfc_se lse; - gfc_se rse; - tree tmp; - tree wheremaskexpr; - - (void) rss; /* TODO: unused. */ - - gfc_start_block (&block); - - gfc_init_se (&rse, NULL); - gfc_init_se (&lse, NULL); - - if (lss == gfc_ss_terminator) - { - gfc_init_block (&body1); - gfc_conv_expr (&lse, expr); - rse.expr = gfc_build_array_ref (tmp1, count1, NULL); - } - else - { - /* Initialize the loop. */ - gfc_init_loopinfo (&loop); - - /* We may need LSS to determine the shape of the expression. */ - gfc_add_ss_to_loop (&loop, lss); - - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr->where); - - gfc_mark_ss_chain_used (lss, 1); - /* Start the loop body. */ - gfc_start_scalarized_body (&loop, &body1); - - /* Translate the expression. */ - gfc_copy_loopinfo_to_se (&lse, &loop); - lse.ss = lss; - gfc_conv_expr (&lse, expr); - - /* Form the expression of the temporary. */ - rse.expr = gfc_build_array_ref (tmp1, count1, NULL); - } - - /* Use the scalar assignment. */ - rse.string_length = lse.string_length; - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, - expr->expr_type == EXPR_VARIABLE, false); - - /* Form the mask expression according to the mask tree list. */ - if (wheremask) - { - wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); - if (invert) - wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - TREE_TYPE (wheremaskexpr), - wheremaskexpr); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - wheremaskexpr, tmp, - build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&body1, tmp); - - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), - count1, gfc_index_one_node); - gfc_add_modify (&body1, count1, tmp); - - if (lss == gfc_ss_terminator) - gfc_add_block_to_block (&block, &body1); - else - { - /* Increment count3. */ - if (count3) - { - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - count3, gfc_index_one_node); - gfc_add_modify (&body1, count3, tmp); - } - - /* Generate the copying loops. */ - gfc_trans_scalarizing_loops (&loop, &body1); - - gfc_add_block_to_block (&block, &loop.pre); - gfc_add_block_to_block (&block, &loop.post); - - gfc_cleanup_loop (&loop); - /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful - as tree nodes in SS may not be valid in different scope. */ - } - - tmp = gfc_finish_block (&block); - return tmp; -} - - -/* Generate codes to copy rhs to the temporary. TMP1 is the address of - temporary, LSS and RSS are formed in function compute_inner_temp_size(), - and should not be freed. WHEREMASK is the conditional execution mask - whose sense may be inverted by INVERT. */ - -static tree -generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, - tree count1, gfc_ss *lss, gfc_ss *rss, - tree wheremask, bool invert) -{ - stmtblock_t block, body1; - gfc_loopinfo loop; - gfc_se lse; - gfc_se rse; - tree tmp; - tree wheremaskexpr; - - gfc_start_block (&block); - - gfc_init_se (&rse, NULL); - gfc_init_se (&lse, NULL); - - if (lss == gfc_ss_terminator) - { - gfc_init_block (&body1); - gfc_conv_expr (&rse, expr2); - lse.expr = gfc_build_array_ref (tmp1, count1, NULL); - } - else - { - /* Initialize the loop. */ - gfc_init_loopinfo (&loop); - - /* We may need LSS to determine the shape of the expression. */ - gfc_add_ss_to_loop (&loop, lss); - gfc_add_ss_to_loop (&loop, rss); - - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &expr2->where); - - gfc_mark_ss_chain_used (rss, 1); - /* Start the loop body. */ - gfc_start_scalarized_body (&loop, &body1); - - /* Translate the expression. */ - gfc_copy_loopinfo_to_se (&rse, &loop); - rse.ss = rss; - gfc_conv_expr (&rse, expr2); - - /* Form the expression of the temporary. */ - lse.expr = gfc_build_array_ref (tmp1, count1, NULL); - } - - /* Use the scalar assignment. */ - lse.string_length = rse.string_length; - tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, - expr2->expr_type == EXPR_VARIABLE, false); - - /* Form the mask expression according to the mask tree list. */ - if (wheremask) - { - wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); - if (invert) - wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - TREE_TYPE (wheremaskexpr), - wheremaskexpr); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - wheremaskexpr, tmp, - build_empty_stmt (input_location)); - } - - gfc_add_expr_to_block (&body1, tmp); - - if (lss == gfc_ss_terminator) - { - gfc_add_block_to_block (&block, &body1); - - /* Increment count1. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), - count1, gfc_index_one_node); - gfc_add_modify (&block, count1, tmp); - } - else - { - /* Increment count1. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); - gfc_add_modify (&body1, count1, tmp); - - /* Increment count3. */ - if (count3) - { - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - count3, gfc_index_one_node); - gfc_add_modify (&body1, count3, tmp); - } - - /* Generate the copying loops. */ - gfc_trans_scalarizing_loops (&loop, &body1); - - gfc_add_block_to_block (&block, &loop.pre); - gfc_add_block_to_block (&block, &loop.post); - - gfc_cleanup_loop (&loop); - /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful - as tree nodes in SS may not be valid in different scope. */ - } - - tmp = gfc_finish_block (&block); - return tmp; -} - - -/* Calculate the size of temporary needed in the assignment inside forall. - LSS and RSS are filled in this function. */ - -static tree -compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, - stmtblock_t * pblock, - gfc_ss **lss, gfc_ss **rss) -{ - gfc_loopinfo loop; - tree size; - int i; - int save_flag; - tree tmp; - - *lss = gfc_walk_expr (expr1); - *rss = NULL; - - size = gfc_index_one_node; - if (*lss != gfc_ss_terminator) - { - gfc_init_loopinfo (&loop); - - /* Walk the RHS of the expression. */ - *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); - - /* Associate the SS with the loop. */ - gfc_add_ss_to_loop (&loop, *lss); - /* We don't actually need to add the rhs at this point, but it might - make guessing the loop bounds a bit easier. */ - gfc_add_ss_to_loop (&loop, *rss); - - /* We only want the shape of the expression, not rest of the junk - generated by the scalarizer. */ - loop.array_parameter = 1; - - /* Calculate the bounds of the scalarization. */ - save_flag = gfc_option.rtcheck; - gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS; - gfc_conv_ss_startstride (&loop); - gfc_option.rtcheck = save_flag; - gfc_conv_loop_setup (&loop, &expr2->where); - - /* Figure out how many elements we need. */ - for (i = 0; i < loop.dimen; i++) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_index_one_node, loop.from[i]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, loop.to[i]); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, tmp); - } - gfc_add_block_to_block (pblock, &loop.pre); - size = gfc_evaluate_now (size, pblock); - gfc_add_block_to_block (pblock, &loop.post); - - /* TODO: write a function that cleans up a loopinfo without freeing - the SS chains. Currently a NOP. */ - } - - return size; -} - - -/* Calculate the overall iterator number of the nested forall construct. - This routine actually calculates the number of times the body of the - nested forall specified by NESTED_FORALL_INFO is executed and multiplies - that by the expression INNER_SIZE. The BLOCK argument specifies the - block in which to calculate the result, and the optional INNER_SIZE_BODY - argument contains any statements that need to executed (inside the loop) - to initialize or calculate INNER_SIZE. */ - -static tree -compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, - stmtblock_t *inner_size_body, stmtblock_t *block) -{ - forall_info *forall_tmp = nested_forall_info; - tree tmp, number; - stmtblock_t body; - - /* We can eliminate the innermost unconditional loops with constant - array bounds. */ - if (INTEGER_CST_P (inner_size)) - { - while (forall_tmp - && !forall_tmp->mask - && INTEGER_CST_P (forall_tmp->size)) - { - inner_size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - inner_size, forall_tmp->size); - forall_tmp = forall_tmp->prev_nest; - } - - /* If there are no loops left, we have our constant result. */ - if (!forall_tmp) - return inner_size; - } - - /* Otherwise, create a temporary variable to compute the result. */ - number = gfc_create_var (gfc_array_index_type, "num"); - gfc_add_modify (block, number, gfc_index_zero_node); - - gfc_start_block (&body); - if (inner_size_body) - gfc_add_block_to_block (&body, inner_size_body); - if (forall_tmp) - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, number, inner_size); - else - tmp = inner_size; - gfc_add_modify (&body, number, tmp); - tmp = gfc_finish_block (&body); - - /* Generate loops. */ - if (forall_tmp != NULL) - tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1); - - gfc_add_expr_to_block (block, tmp); - - return number; -} - - -/* Allocate temporary for forall construct. SIZE is the size of temporary - needed. PTEMP1 is returned for space free. */ - -static tree -allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, - tree * ptemp1) -{ - tree bytesize; - tree unit; - tree tmp; - - unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type)); - if (!integer_onep (unit)) - bytesize = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, unit); - else - bytesize = size; - - *ptemp1 = NULL; - tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type); - - if (*ptemp1) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - return tmp; -} - - -/* Allocate temporary for forall construct according to the information in - nested_forall_info. INNER_SIZE is the size of temporary needed in the - assignment inside forall. PTEMP1 is returned for space free. */ - -static tree -allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, - tree inner_size, stmtblock_t * inner_size_body, - stmtblock_t * block, tree * ptemp1) -{ - tree size; - - /* Calculate the total size of temporary needed in forall construct. */ - size = compute_overall_iter_number (nested_forall_info, inner_size, - inner_size_body, block); - - return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1); -} - - -/* Handle assignments inside forall which need temporary. - - forall (i=start:end:stride; maskexpr) - e = f - end forall - (where e,f are arbitrary expressions possibly involving i - and there is a dependency between e and f) - Translates to: - masktmp(:) = maskexpr(:) - - maskindex = 0; - count1 = 0; - num = 0; - for (i = start; i <= end; i += stride) - num += SIZE (f) - count1 = 0; - ALLOCATE (tmp(num)) - for (i = start; i <= end; i += stride) - { - if (masktmp[maskindex++]) - tmp[count1++] = f - } - maskindex = 0; - count1 = 0; - for (i = start; i <= end; i += stride) - { - if (masktmp[maskindex++]) - e = tmp[count1++] - } - DEALLOCATE (tmp) - */ -static void -gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, - tree wheremask, bool invert, - forall_info * nested_forall_info, - stmtblock_t * block) -{ - tree type; - tree inner_size; - gfc_ss *lss, *rss; - tree count, count1; - tree tmp, tmp1; - tree ptemp1; - stmtblock_t inner_size_body; - - /* Create vars. count1 is the current iterator number of the nested - forall. */ - count1 = gfc_create_var (gfc_array_index_type, "count1"); - - /* Count is the wheremask index. */ - if (wheremask) - { - count = gfc_create_var (gfc_array_index_type, "count"); - gfc_add_modify (block, count, gfc_index_zero_node); - } - else - count = NULL; - - /* Initialize count1. */ - gfc_add_modify (block, count1, gfc_index_zero_node); - - /* Calculate the size of temporary needed in the assignment. Return loop, lss - and rss which are used in function generate_loop_for_rhs_to_temp(). */ - /* The type of LHS. Used in function allocate_temp_for_forall_nest */ - if (expr1->ts.type == BT_CHARACTER) - { - type = NULL; - if (expr1->ref && expr1->ref->type == REF_SUBSTRING) - { - gfc_se ssse; - gfc_init_se (&ssse, NULL); - gfc_conv_expr (&ssse, expr1); - type = gfc_get_character_type_len (gfc_default_character_kind, - ssse.string_length); - } - else - { - if (!expr1->ts.u.cl->backend_decl) - { - gfc_se tse; - gcc_assert (expr1->ts.u.cl->length); - gfc_init_se (&tse, NULL); - gfc_conv_expr (&tse, expr1->ts.u.cl->length); - expr1->ts.u.cl->backend_decl = tse.expr; - } - type = gfc_get_character_type_len (gfc_default_character_kind, - expr1->ts.u.cl->backend_decl); - } - } - else - type = gfc_typenode_for_spec (&expr1->ts); - - gfc_init_block (&inner_size_body); - inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, - &lss, &rss); - - /* Allocate temporary for nested forall construct according to the - information in nested_forall_info and inner_size. */ - tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, - &inner_size_body, block, &ptemp1); - - /* Generate codes to copy rhs to the temporary . */ - tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, - wheremask, invert); - - /* Generate body and loops according to the information in - nested_forall_info. */ - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); - gfc_add_expr_to_block (block, tmp); - - /* Reset count1. */ - gfc_add_modify (block, count1, gfc_index_zero_node); - - /* Reset count. */ - if (wheremask) - gfc_add_modify (block, count, gfc_index_zero_node); - - /* TODO: Second call to compute_inner_temp_size to initialize lss and - rss; there must be a better way. */ - inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, - &lss, &rss); - - /* Generate codes to copy the temporary to lhs. */ - tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, - lss, rss, - wheremask, invert); - - /* Generate body and loops according to the information in - nested_forall_info. */ - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); - gfc_add_expr_to_block (block, tmp); - - if (ptemp1) - { - /* Free the temporary. */ - tmp = gfc_call_free (ptemp1); - gfc_add_expr_to_block (block, tmp); - } -} - - -/* Translate pointer assignment inside FORALL which need temporary. */ - -static void -gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, - forall_info * nested_forall_info, - stmtblock_t * block) -{ - tree type; - tree inner_size; - gfc_ss *lss, *rss; - gfc_se lse; - gfc_se rse; - gfc_array_info *info; - gfc_loopinfo loop; - tree desc; - tree parm; - tree parmtype; - stmtblock_t body; - tree count; - tree tmp, tmp1, ptemp1; - - count = gfc_create_var (gfc_array_index_type, "count"); - gfc_add_modify (block, count, gfc_index_zero_node); - - inner_size = gfc_index_one_node; - lss = gfc_walk_expr (expr1); - rss = gfc_walk_expr (expr2); - if (lss == gfc_ss_terminator) - { - type = gfc_typenode_for_spec (&expr1->ts); - type = build_pointer_type (type); - - /* Allocate temporary for nested forall construct according to the - information in nested_forall_info and inner_size. */ - tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, - inner_size, NULL, block, &ptemp1); - gfc_start_block (&body); - gfc_init_se (&lse, NULL); - lse.expr = gfc_build_array_ref (tmp1, count, NULL); - gfc_init_se (&rse, NULL); - rse.want_pointer = 1; - gfc_conv_expr (&rse, expr2); - gfc_add_block_to_block (&body, &rse.pre); - gfc_add_modify (&body, lse.expr, - fold_convert (TREE_TYPE (lse.expr), rse.expr)); - gfc_add_block_to_block (&body, &rse.post); - - /* Increment count. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); - gfc_add_modify (&body, count, tmp); - - tmp = gfc_finish_block (&body); - - /* Generate body and loops according to the information in - nested_forall_info. */ - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); - gfc_add_expr_to_block (block, tmp); - - /* Reset count. */ - gfc_add_modify (block, count, gfc_index_zero_node); - - gfc_start_block (&body); - gfc_init_se (&lse, NULL); - gfc_init_se (&rse, NULL); - rse.expr = gfc_build_array_ref (tmp1, count, NULL); - lse.want_pointer = 1; - gfc_conv_expr (&lse, expr1); - gfc_add_block_to_block (&body, &lse.pre); - gfc_add_modify (&body, lse.expr, rse.expr); - gfc_add_block_to_block (&body, &lse.post); - /* Increment count. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); - gfc_add_modify (&body, count, tmp); - tmp = gfc_finish_block (&body); - - /* Generate body and loops according to the information in - nested_forall_info. */ - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); - gfc_add_expr_to_block (block, tmp); - } - else - { - gfc_init_loopinfo (&loop); - - /* Associate the SS with the loop. */ - gfc_add_ss_to_loop (&loop, rss); - - /* Setup the scalarizing loops and bounds. */ - gfc_conv_ss_startstride (&loop); - - gfc_conv_loop_setup (&loop, &expr2->where); - - info = &rss->info->data.array; - desc = info->descriptor; - - /* Make a new descriptor. */ - parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, - loop.from, loop.to, 1, - GFC_ARRAY_UNKNOWN, true); - - /* Allocate temporary for nested forall construct. */ - tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, - inner_size, NULL, block, &ptemp1); - gfc_start_block (&body); - gfc_init_se (&lse, NULL); - lse.expr = gfc_build_array_ref (tmp1, count, NULL); - lse.direct_byref = 1; - gfc_conv_expr_descriptor (&lse, expr2); - - gfc_add_block_to_block (&body, &lse.pre); - gfc_add_block_to_block (&body, &lse.post); - - /* Increment count. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); - gfc_add_modify (&body, count, tmp); - - tmp = gfc_finish_block (&body); - - /* Generate body and loops according to the information in - nested_forall_info. */ - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); - gfc_add_expr_to_block (block, tmp); - - /* Reset count. */ - gfc_add_modify (block, count, gfc_index_zero_node); - - parm = gfc_build_array_ref (tmp1, count, NULL); - gfc_init_se (&lse, NULL); - gfc_conv_expr_descriptor (&lse, expr1); - gfc_add_modify (&lse.pre, lse.expr, parm); - gfc_start_block (&body); - gfc_add_block_to_block (&body, &lse.pre); - gfc_add_block_to_block (&body, &lse.post); - - /* Increment count. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); - gfc_add_modify (&body, count, tmp); - - tmp = gfc_finish_block (&body); - - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); - gfc_add_expr_to_block (block, tmp); - } - /* Free the temporary. */ - if (ptemp1) - { - tmp = gfc_call_free (ptemp1); - gfc_add_expr_to_block (block, tmp); - } -} - - -/* FORALL and WHERE statements are really nasty, especially when you nest - them. All the rhs of a forall assignment must be evaluated before the - actual assignments are performed. Presumably this also applies to all the - assignments in an inner where statement. */ - -/* Generate code for a FORALL statement. Any temporaries are allocated as a - linear array, relying on the fact that we process in the same order in all - loops. - - forall (i=start:end:stride; maskexpr) - e = f - g = h - end forall - (where e,f,g,h are arbitrary expressions possibly involving i) - Translates to: - count = ((end + 1 - start) / stride) - masktmp(:) = maskexpr(:) - - maskindex = 0; - for (i = start; i <= end; i += stride) - { - if (masktmp[maskindex++]) - e = f - } - maskindex = 0; - for (i = start; i <= end; i += stride) - { - if (masktmp[maskindex++]) - g = h - } - - Note that this code only works when there are no dependencies. - Forall loop with array assignments and data dependencies are a real pain, - because the size of the temporary cannot always be determined before the - loop is executed. This problem is compounded by the presence of nested - FORALL constructs. - */ - -static tree -gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) -{ - stmtblock_t pre; - stmtblock_t post; - stmtblock_t block; - stmtblock_t body; - tree *var; - tree *start; - tree *end; - tree *step; - gfc_expr **varexpr; - tree tmp; - tree assign; - tree size; - tree maskindex; - tree mask; - tree pmask; - tree cycle_label = NULL_TREE; - int n; - int nvar; - int need_temp; - gfc_forall_iterator *fa; - gfc_se se; - gfc_code *c; - gfc_saved_var *saved_vars; - iter_info *this_forall; - forall_info *info; - bool need_mask; - - /* Do nothing if the mask is false. */ - if (code->expr1 - && code->expr1->expr_type == EXPR_CONSTANT - && !code->expr1->value.logical) - return build_empty_stmt (input_location); - - n = 0; - /* Count the FORALL index number. */ - for (fa = code->ext.forall_iterator; fa; fa = fa->next) - n++; - nvar = n; - - /* Allocate the space for var, start, end, step, varexpr. */ - var = XCNEWVEC (tree, nvar); - start = XCNEWVEC (tree, nvar); - end = XCNEWVEC (tree, nvar); - step = XCNEWVEC (tree, nvar); - varexpr = XCNEWVEC (gfc_expr *, nvar); - saved_vars = XCNEWVEC (gfc_saved_var, nvar); - - /* Allocate the space for info. */ - info = XCNEW (forall_info); - - gfc_start_block (&pre); - gfc_init_block (&post); - gfc_init_block (&block); - - n = 0; - for (fa = code->ext.forall_iterator; fa; fa = fa->next) - { - gfc_symbol *sym = fa->var->symtree->n.sym; - - /* Allocate space for this_forall. */ - this_forall = XCNEW (iter_info); - - /* Create a temporary variable for the FORALL index. */ - tmp = gfc_typenode_for_spec (&sym->ts); - var[n] = gfc_create_var (tmp, sym->name); - gfc_shadow_sym (sym, var[n], &saved_vars[n]); - - /* Record it in this_forall. */ - this_forall->var = var[n]; - - /* Replace the index symbol's backend_decl with the temporary decl. */ - sym->backend_decl = var[n]; - - /* Work out the start, end and stride for the loop. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, fa->start); - /* Record it in this_forall. */ - this_forall->start = se.expr; - gfc_add_block_to_block (&block, &se.pre); - start[n] = se.expr; - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, fa->end); - /* Record it in this_forall. */ - this_forall->end = se.expr; - gfc_make_safe_expr (&se); - gfc_add_block_to_block (&block, &se.pre); - end[n] = se.expr; - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, fa->stride); - /* Record it in this_forall. */ - this_forall->step = se.expr; - gfc_make_safe_expr (&se); - gfc_add_block_to_block (&block, &se.pre); - step[n] = se.expr; - - /* Set the NEXT field of this_forall to NULL. */ - this_forall->next = NULL; - /* Link this_forall to the info construct. */ - if (info->this_loop) - { - iter_info *iter_tmp = info->this_loop; - while (iter_tmp->next != NULL) - iter_tmp = iter_tmp->next; - iter_tmp->next = this_forall; - } - else - info->this_loop = this_forall; - - n++; - } - nvar = n; - - /* Calculate the size needed for the current forall level. */ - size = gfc_index_one_node; - for (n = 0; n < nvar; n++) - { - /* size = (end + step - start) / step. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), - step[n], start[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), - end[n], tmp); - tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp), - tmp, step[n]); - tmp = convert (gfc_array_index_type, tmp); - - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, tmp); - } - - /* Record the nvar and size of current forall level. */ - info->nvar = nvar; - info->size = size; - - if (code->expr1) - { - /* If the mask is .true., consider the FORALL unconditional. */ - if (code->expr1->expr_type == EXPR_CONSTANT - && code->expr1->value.logical) - need_mask = false; - else - need_mask = true; - } - else - need_mask = false; - - /* First we need to allocate the mask. */ - if (need_mask) - { - /* As the mask array can be very big, prefer compact boolean types. */ - tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); - mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type, - size, NULL, &block, &pmask); - maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); - - /* Record them in the info structure. */ - info->maskindex = maskindex; - info->mask = mask; - } - else - { - /* No mask was specified. */ - maskindex = NULL_TREE; - mask = pmask = NULL_TREE; - } - - /* Link the current forall level to nested_forall_info. */ - info->prev_nest = nested_forall_info; - nested_forall_info = info; - - /* Copy the mask into a temporary variable if required. - For now we assume a mask temporary is needed. */ - if (need_mask) - { - /* As the mask array can be very big, prefer compact boolean types. */ - tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); - - gfc_add_modify (&block, maskindex, gfc_index_zero_node); - - /* Start of mask assignment loop body. */ - gfc_start_block (&body); - - /* Evaluate the mask expression. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, code->expr1); - gfc_add_block_to_block (&body, &se.pre); - - /* Store the mask. */ - se.expr = convert (mask_type, se.expr); - - tmp = gfc_build_array_ref (mask, maskindex, NULL); - gfc_add_modify (&body, tmp, se.expr); - - /* Advance to the next mask element. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - maskindex, gfc_index_one_node); - gfc_add_modify (&body, maskindex, tmp); - - /* Generate the loops. */ - tmp = gfc_finish_block (&body); - tmp = gfc_trans_nested_forall_loop (info, tmp, 0); - gfc_add_expr_to_block (&block, tmp); - } - - if (code->op == EXEC_DO_CONCURRENT) - { - gfc_init_block (&body); - cycle_label = gfc_build_label_decl (NULL_TREE); - code->cycle_label = cycle_label; - tmp = gfc_trans_code (code->block->next); - gfc_add_expr_to_block (&body, tmp); - - if (TREE_USED (cycle_label)) - { - tmp = build1_v (LABEL_EXPR, cycle_label); - gfc_add_expr_to_block (&body, tmp); - } - - tmp = gfc_finish_block (&body); - nested_forall_info->do_concurrent = true; - tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); - gfc_add_expr_to_block (&block, tmp); - goto done; - } - - c = code->block->next; - - /* TODO: loop merging in FORALL statements. */ - /* Now that we've got a copy of the mask, generate the assignment loops. */ - while (c) - { - switch (c->op) - { - case EXEC_ASSIGN: - /* A scalar or array assignment. DO the simple check for - lhs to rhs dependencies. These make a temporary for the - rhs and form a second forall block to copy to variable. */ - need_temp = check_forall_dependencies(c, &pre, &post); - - /* Temporaries due to array assignment data dependencies introduce - no end of problems. */ - if (need_temp || flag_test_forall_temp) - gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false, - nested_forall_info, &block); - else - { - /* Use the normal assignment copying routines. */ - assign = gfc_trans_assignment (c->expr1, c->expr2, false, true); - - /* Generate body and loops. */ - tmp = gfc_trans_nested_forall_loop (nested_forall_info, - assign, 1); - gfc_add_expr_to_block (&block, tmp); - } - - /* Cleanup any temporary symtrees that have been made to deal - with dependencies. */ - if (new_symtree) - cleanup_forall_symtrees (c); - - break; - - case EXEC_WHERE: - /* Translate WHERE or WHERE construct nested in FORALL. */ - gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block); - break; - - /* Pointer assignment inside FORALL. */ - case EXEC_POINTER_ASSIGN: - need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); - /* Avoid cases where a temporary would never be needed and where - the temp code is guaranteed to fail. */ - if (need_temp - || (flag_test_forall_temp - && c->expr2->expr_type != EXPR_CONSTANT - && c->expr2->expr_type != EXPR_NULL)) - gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2, - nested_forall_info, &block); - else - { - /* Use the normal assignment copying routines. */ - assign = gfc_trans_pointer_assignment (c->expr1, c->expr2); - - /* Generate body and loops. */ - tmp = gfc_trans_nested_forall_loop (nested_forall_info, - assign, 1); - gfc_add_expr_to_block (&block, tmp); - } - break; - - case EXEC_FORALL: - tmp = gfc_trans_forall_1 (c, nested_forall_info); - gfc_add_expr_to_block (&block, tmp); - break; - - /* Explicit subroutine calls are prevented by the frontend but interface - assignments can legitimately produce them. */ - case EXEC_ASSIGN_CALL: - assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false); - tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); - gfc_add_expr_to_block (&block, tmp); - break; - - default: - gcc_unreachable (); - } - - c = c->next; - } - -done: - /* Restore the original index variables. */ - for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) - gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); - - /* Free the space for var, start, end, step, varexpr. */ - free (var); - free (start); - free (end); - free (step); - free (varexpr); - free (saved_vars); - - for (this_forall = info->this_loop; this_forall;) - { - iter_info *next = this_forall->next; - free (this_forall); - this_forall = next; - } - - /* Free the space for this forall_info. */ - free (info); - - if (pmask) - { - /* Free the temporary for the mask. */ - tmp = gfc_call_free (pmask); - gfc_add_expr_to_block (&block, tmp); - } - if (maskindex) - pushdecl (maskindex); - - gfc_add_block_to_block (&pre, &block); - gfc_add_block_to_block (&pre, &post); - - return gfc_finish_block (&pre); -} - - -/* Translate the FORALL statement or construct. */ - -tree gfc_trans_forall (gfc_code * code) -{ - return gfc_trans_forall_1 (code, NULL); -} - - -/* Translate the DO CONCURRENT construct. */ - -tree gfc_trans_do_concurrent (gfc_code * code) -{ - return gfc_trans_forall_1 (code, NULL); -} - - -/* Evaluate the WHERE mask expression, copy its value to a temporary. - If the WHERE construct is nested in FORALL, compute the overall temporary - needed by the WHERE mask expression multiplied by the iterator number of - the nested forall. - ME is the WHERE mask expression. - MASK is the current execution mask upon input, whose sense may or may - not be inverted as specified by the INVERT argument. - CMASK is the updated execution mask on output, or NULL if not required. - PMASK is the pending execution mask on output, or NULL if not required. - BLOCK is the block in which to place the condition evaluation loops. */ - -static void -gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, - tree mask, bool invert, tree cmask, tree pmask, - tree mask_type, stmtblock_t * block) -{ - tree tmp, tmp1; - gfc_ss *lss, *rss; - gfc_loopinfo loop; - stmtblock_t body, body1; - tree count, cond, mtmp; - gfc_se lse, rse; - - gfc_init_loopinfo (&loop); - - lss = gfc_walk_expr (me); - rss = gfc_walk_expr (me); - - /* Variable to index the temporary. */ - count = gfc_create_var (gfc_array_index_type, "count"); - /* Initialize count. */ - gfc_add_modify (block, count, gfc_index_zero_node); - - gfc_start_block (&body); - - gfc_init_se (&rse, NULL); - gfc_init_se (&lse, NULL); - - if (lss == gfc_ss_terminator) - { - gfc_init_block (&body1); - } - else - { - /* Initialize the loop. */ - gfc_init_loopinfo (&loop); - - /* We may need LSS to determine the shape of the expression. */ - gfc_add_ss_to_loop (&loop, lss); - gfc_add_ss_to_loop (&loop, rss); - - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &me->where); - - gfc_mark_ss_chain_used (rss, 1); - /* Start the loop body. */ - gfc_start_scalarized_body (&loop, &body1); - - /* Translate the expression. */ - gfc_copy_loopinfo_to_se (&rse, &loop); - rse.ss = rss; - gfc_conv_expr (&rse, me); - } - - /* Variable to evaluate mask condition. */ - cond = gfc_create_var (mask_type, "cond"); - if (mask && (cmask || pmask)) - mtmp = gfc_create_var (mask_type, "mask"); - else mtmp = NULL_TREE; - - gfc_add_block_to_block (&body1, &lse.pre); - gfc_add_block_to_block (&body1, &rse.pre); - - gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr)); - - if (mask && (cmask || pmask)) - { - tmp = gfc_build_array_ref (mask, count, NULL); - if (invert) - tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp); - gfc_add_modify (&body1, mtmp, tmp); - } - - if (cmask) - { - tmp1 = gfc_build_array_ref (cmask, count, NULL); - tmp = cond; - if (mask) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, - mtmp, tmp); - gfc_add_modify (&body1, tmp1, tmp); - } - - if (pmask) - { - tmp1 = gfc_build_array_ref (pmask, count, NULL); - tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond); - if (mask) - tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp, - tmp); - gfc_add_modify (&body1, tmp1, tmp); - } - - gfc_add_block_to_block (&body1, &lse.post); - gfc_add_block_to_block (&body1, &rse.post); - - if (lss == gfc_ss_terminator) - { - gfc_add_block_to_block (&body, &body1); - } - else - { - /* Increment count. */ - tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - count, gfc_index_one_node); - gfc_add_modify (&body1, count, tmp1); - - /* Generate the copying loops. */ - gfc_trans_scalarizing_loops (&loop, &body1); - - gfc_add_block_to_block (&body, &loop.pre); - gfc_add_block_to_block (&body, &loop.post); - - gfc_cleanup_loop (&loop); - /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful - as tree nodes in SS may not be valid in different scope. */ - } - - tmp1 = gfc_finish_block (&body); - /* If the WHERE construct is inside FORALL, fill the full temporary. */ - if (nested_forall_info != NULL) - tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1); - - gfc_add_expr_to_block (block, tmp1); -} - - -/* Translate an assignment statement in a WHERE statement or construct - statement. The MASK expression is used to control which elements - of EXPR1 shall be assigned. The sense of MASK is specified by - INVERT. */ - -static tree -gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, - tree mask, bool invert, - tree count1, tree count2, - gfc_code *cnext) -{ - 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; - tree index, maskexpr; - - /* A defined assignment. */ - if (cnext && cnext->resolved_sym) - return gfc_trans_call (cnext, true, mask, count1, invert); - -#if 0 - /* TODO: handle this special case. - 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; - } -#endif - - /* 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); - rss = NULL; - - /* In each where-assign-stmt, the mask-expr and the variable being - defined shall be arrays of the same shape. */ - gcc_assert (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); - rss->info->where = 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); - - /* Resolve any data dependencies in the statement. */ - gfc_conv_resolve_dependencies (&loop, lss_section, 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); - } - - /* Start the scalarized loop body. */ - gfc_start_scalarized_body (&loop, &body); - - /* Translate the expression. */ - gfc_conv_expr (&rse, expr2); - if (lss != gfc_ss_terminator && loop.temp_ss != NULL) - gfc_conv_tmp_array_ref (&lse); - else - gfc_conv_expr (&lse, expr1); - - /* Form the mask expression according to the mask. */ - index = count1; - maskexpr = gfc_build_array_ref (mask, index, NULL); - if (invert) - maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - TREE_TYPE (maskexpr), maskexpr); - - /* Use the scalar assignment as is. */ - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - false, loop.temp_ss == NULL); - - tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&body, tmp); - - if (lss == gfc_ss_terminator) - { - /* Increment count1. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - count1, gfc_index_one_node); - gfc_add_modify (&body, count1, tmp); - - /* 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 (loop.temp_ss != NULL) - { - /* Increment count1 before finish the main body of a scalarized - expression. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, count1, gfc_index_one_node); - gfc_add_modify (&body, count1, tmp); - 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); - - /* Form the mask expression according to the mask tree list. */ - index = count2; - maskexpr = gfc_build_array_ref (mask, index, NULL); - if (invert) - maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - TREE_TYPE (maskexpr), maskexpr); - - /* Use the scalar assignment as is. */ - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true); - tmp = build3_v (COND_EXPR, maskexpr, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&body, tmp); - - /* Increment count2. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, count2, - gfc_index_one_node); - gfc_add_modify (&body, count2, tmp); - } - else - { - /* Increment count1. */ - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, count1, - gfc_index_one_node); - gfc_add_modify (&body, count1, tmp); - } - - /* 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); -} - - -/* Translate the WHERE construct or statement. - This function can be called iteratively to translate the nested WHERE - construct or statement. - MASK is the control mask. */ - -static void -gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, - forall_info * nested_forall_info, stmtblock_t * block) -{ - stmtblock_t inner_size_body; - tree inner_size, size; - gfc_ss *lss, *rss; - tree mask_type; - gfc_expr *expr1; - gfc_expr *expr2; - gfc_code *cblock; - gfc_code *cnext; - tree tmp; - tree cond; - tree count1, count2; - bool need_cmask; - bool need_pmask; - int need_temp; - tree pcmask = NULL_TREE; - tree ppmask = NULL_TREE; - tree cmask = NULL_TREE; - tree pmask = NULL_TREE; - gfc_actual_arglist *arg; - - /* the WHERE statement or the WHERE construct statement. */ - cblock = code->block; - - /* As the mask array can be very big, prefer compact boolean types. */ - mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); - - /* Determine which temporary masks are needed. */ - if (!cblock->block) - { - /* One clause: No ELSEWHEREs. */ - need_cmask = (cblock->next != 0); - need_pmask = false; - } - else if (cblock->block->block) - { - /* Three or more clauses: Conditional ELSEWHEREs. */ - need_cmask = true; - need_pmask = true; - } - else if (cblock->next) - { - /* Two clauses, the first non-empty. */ - need_cmask = true; - need_pmask = (mask != NULL_TREE - && cblock->block->next != 0); - } - else if (!cblock->block->next) - { - /* Two clauses, both empty. */ - need_cmask = false; - need_pmask = false; - } - /* Two clauses, the first empty, the second non-empty. */ - else if (mask) - { - need_cmask = (cblock->block->expr1 != 0); - need_pmask = true; - } - else - { - need_cmask = true; - need_pmask = false; - } - - if (need_cmask || need_pmask) - { - /* Calculate the size of temporary needed by the mask-expr. */ - gfc_init_block (&inner_size_body); - inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1, - &inner_size_body, &lss, &rss); - - gfc_free_ss_chain (lss); - gfc_free_ss_chain (rss); - - /* Calculate the total size of temporary needed. */ - size = compute_overall_iter_number (nested_forall_info, inner_size, - &inner_size_body, block); - - /* Check whether the size is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size, - gfc_index_zero_node); - size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, - cond, gfc_index_zero_node, size); - size = gfc_evaluate_now (size, block); - - /* Allocate temporary for WHERE mask if needed. */ - if (need_cmask) - cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, - &pcmask); - - /* Allocate temporary for !mask if needed. */ - if (need_pmask) - pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, - &ppmask); - } - - while (cblock) - { - /* Each time around this loop, the where clause is conditional - on the value of mask and invert, which are updated at the - bottom of the loop. */ - - /* Has mask-expr. */ - if (cblock->expr1) - { - /* Ensure that the WHERE mask will be evaluated exactly once. - If there are no statements in this WHERE/ELSEWHERE clause, - then we don't need to update the control mask (cmask). - If this is the last clause of the WHERE construct, then - we don't need to update the pending control mask (pmask). */ - if (mask) - gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, - mask, invert, - cblock->next ? cmask : NULL_TREE, - cblock->block ? pmask : NULL_TREE, - mask_type, block); - else - gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, - NULL_TREE, false, - (cblock->next || cblock->block) - ? cmask : NULL_TREE, - NULL_TREE, mask_type, block); - - invert = false; - } - /* It's a final elsewhere-stmt. No mask-expr is present. */ - else - cmask = mask; - - /* The body of this where clause are controlled by cmask with - sense specified by invert. */ - - /* Get the assignment statement of a WHERE statement, or the first - statement in where-body-construct of a WHERE construct. */ - cnext = cblock->next; - while (cnext) - { - switch (cnext->op) - { - /* WHERE assignment statement. */ - case EXEC_ASSIGN_CALL: - - arg = cnext->ext.actual; - expr1 = expr2 = NULL; - for (; arg; arg = arg->next) - { - if (!arg->expr) - continue; - if (expr1 == NULL) - expr1 = arg->expr; - else - expr2 = arg->expr; - } - goto evaluate; - - case EXEC_ASSIGN: - expr1 = cnext->expr1; - expr2 = cnext->expr2; - evaluate: - if (nested_forall_info != NULL) - { - need_temp = gfc_check_dependency (expr1, expr2, 0); - if ((need_temp || flag_test_forall_temp) - && cnext->op != EXEC_ASSIGN_CALL) - gfc_trans_assign_need_temp (expr1, expr2, - cmask, invert, - nested_forall_info, block); - else - { - /* Variables to control maskexpr. */ - count1 = gfc_create_var (gfc_array_index_type, "count1"); - count2 = gfc_create_var (gfc_array_index_type, "count2"); - gfc_add_modify (block, count1, gfc_index_zero_node); - gfc_add_modify (block, count2, gfc_index_zero_node); - - tmp = gfc_trans_where_assign (expr1, expr2, - cmask, invert, - count1, count2, - cnext); - - tmp = gfc_trans_nested_forall_loop (nested_forall_info, - tmp, 1); - gfc_add_expr_to_block (block, tmp); - } - } - else - { - /* Variables to control maskexpr. */ - count1 = gfc_create_var (gfc_array_index_type, "count1"); - count2 = gfc_create_var (gfc_array_index_type, "count2"); - gfc_add_modify (block, count1, gfc_index_zero_node); - gfc_add_modify (block, count2, gfc_index_zero_node); - - tmp = gfc_trans_where_assign (expr1, expr2, - cmask, invert, - count1, count2, - cnext); - gfc_add_expr_to_block (block, tmp); - - } - break; - - /* WHERE or WHERE construct is part of a where-body-construct. */ - case EXEC_WHERE: - gfc_trans_where_2 (cnext, cmask, invert, - nested_forall_info, block); - break; - - default: - gcc_unreachable (); - } - - /* The next statement within the same where-body-construct. */ - cnext = cnext->next; - } - /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ - cblock = cblock->block; - if (mask == NULL_TREE) - { - /* If we're the initial WHERE, we can simply invert the sense - of the current mask to obtain the "mask" for the remaining - ELSEWHEREs. */ - invert = true; - mask = cmask; - } - else - { - /* Otherwise, for nested WHERE's we need to use the pending mask. */ - invert = false; - mask = pmask; - } - } - - /* If we allocated a pending mask array, deallocate it now. */ - if (ppmask) - { - tmp = gfc_call_free (ppmask); - gfc_add_expr_to_block (block, tmp); - } - - /* If we allocated a current mask array, deallocate it now. */ - if (pcmask) - { - tmp = gfc_call_free (pcmask); - gfc_add_expr_to_block (block, tmp); - } -} - -/* Translate a simple WHERE construct or statement without dependencies. - CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR - is the mask condition, and EBLOCK if non-NULL is the "else" clause. - Currently both CBLOCK and EBLOCK are restricted to single assignments. */ - -static tree -gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) -{ - stmtblock_t block, body; - gfc_expr *cond, *tdst, *tsrc, *edst, *esrc; - tree tmp, cexpr, tstmt, estmt; - gfc_ss *css, *tdss, *tsss; - gfc_se cse, tdse, tsse, edse, esse; - gfc_loopinfo loop; - gfc_ss *edss = 0; - gfc_ss *esss = 0; - bool maybe_workshare = false; - - /* Allow the scalarizer to workshare simple where loops. */ - if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY)) - == OMPWS_WORKSHARE_FLAG) - { - maybe_workshare = true; - ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; - } - - cond = cblock->expr1; - tdst = cblock->next->expr1; - tsrc = cblock->next->expr2; - edst = eblock ? eblock->next->expr1 : NULL; - esrc = eblock ? eblock->next->expr2 : NULL; - - gfc_start_block (&block); - gfc_init_loopinfo (&loop); - - /* Handle the condition. */ - gfc_init_se (&cse, NULL); - css = gfc_walk_expr (cond); - gfc_add_ss_to_loop (&loop, css); - - /* Handle the then-clause. */ - gfc_init_se (&tdse, NULL); - gfc_init_se (&tsse, NULL); - tdss = gfc_walk_expr (tdst); - tsss = gfc_walk_expr (tsrc); - if (tsss == gfc_ss_terminator) - { - tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc); - tsss->info->where = 1; - } - gfc_add_ss_to_loop (&loop, tdss); - gfc_add_ss_to_loop (&loop, tsss); - - if (eblock) - { - /* Handle the else clause. */ - gfc_init_se (&edse, NULL); - gfc_init_se (&esse, NULL); - edss = gfc_walk_expr (edst); - esss = gfc_walk_expr (esrc); - if (esss == gfc_ss_terminator) - { - esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc); - esss->info->where = 1; - } - gfc_add_ss_to_loop (&loop, edss); - gfc_add_ss_to_loop (&loop, esss); - } - - gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &tdst->where); - - gfc_mark_ss_chain_used (css, 1); - gfc_mark_ss_chain_used (tdss, 1); - gfc_mark_ss_chain_used (tsss, 1); - if (eblock) - { - gfc_mark_ss_chain_used (edss, 1); - gfc_mark_ss_chain_used (esss, 1); - } - - gfc_start_scalarized_body (&loop, &body); - - gfc_copy_loopinfo_to_se (&cse, &loop); - gfc_copy_loopinfo_to_se (&tdse, &loop); - gfc_copy_loopinfo_to_se (&tsse, &loop); - cse.ss = css; - tdse.ss = tdss; - tsse.ss = tsss; - if (eblock) - { - gfc_copy_loopinfo_to_se (&edse, &loop); - gfc_copy_loopinfo_to_se (&esse, &loop); - edse.ss = edss; - esse.ss = esss; - } - - gfc_conv_expr (&cse, cond); - gfc_add_block_to_block (&body, &cse.pre); - cexpr = cse.expr; - - gfc_conv_expr (&tsse, tsrc); - if (tdss != gfc_ss_terminator && loop.temp_ss != NULL) - gfc_conv_tmp_array_ref (&tdse); - else - gfc_conv_expr (&tdse, tdst); - - if (eblock) - { - gfc_conv_expr (&esse, esrc); - if (edss != gfc_ss_terminator && loop.temp_ss != NULL) - gfc_conv_tmp_array_ref (&edse); - else - gfc_conv_expr (&edse, edst); - } - - tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true); - estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, - false, true) - : build_empty_stmt (input_location); - tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); - gfc_add_expr_to_block (&body, tmp); - gfc_add_block_to_block (&body, &cse.post); - - if (maybe_workshare) - ompws_flags &= ~OMPWS_SCALARIZER_BODY; - gfc_trans_scalarizing_loops (&loop, &body); - 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); -} - -/* As the WHERE or WHERE construct statement can be nested, we call - gfc_trans_where_2 to do the translation, and pass the initial - NULL values for both the control mask and the pending control mask. */ - -tree -gfc_trans_where (gfc_code * code) -{ - stmtblock_t block; - gfc_code *cblock; - gfc_code *eblock; - - cblock = code->block; - if (cblock->next - && cblock->next->op == EXEC_ASSIGN - && !cblock->next->next) - { - eblock = cblock->block; - if (!eblock) - { - /* A simple "WHERE (cond) x = y" statement or block is - dependence free if cond is not dependent upon writing x, - and the source y is unaffected by the destination x. */ - if (!gfc_check_dependency (cblock->next->expr1, - cblock->expr1, 0) - && !gfc_check_dependency (cblock->next->expr1, - cblock->next->expr2, 0)) - return gfc_trans_where_3 (cblock, NULL); - } - else if (!eblock->expr1 - && !eblock->block - && eblock->next - && eblock->next->op == EXEC_ASSIGN - && !eblock->next->next) - { - /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE" - block is dependence free if cond is not dependent on writes - to x1 and x2, y1 is not dependent on writes to x2, and y2 - is not dependent on writes to x1, and both y's are not - dependent upon their own x's. In addition to this, the - final two dependency checks below exclude all but the same - array reference if the where and elswhere destinations - are the same. In short, this is VERY conservative and this - is needed because the two loops, required by the standard - are coalesced in gfc_trans_where_3. */ - if (!gfc_check_dependency (cblock->next->expr1, - cblock->expr1, 0) - && !gfc_check_dependency (eblock->next->expr1, - cblock->expr1, 0) - && !gfc_check_dependency (cblock->next->expr1, - eblock->next->expr2, 1) - && !gfc_check_dependency (eblock->next->expr1, - cblock->next->expr2, 1) - && !gfc_check_dependency (cblock->next->expr1, - cblock->next->expr2, 1) - && !gfc_check_dependency (eblock->next->expr1, - eblock->next->expr2, 1) - && !gfc_check_dependency (cblock->next->expr1, - eblock->next->expr1, 0) - && !gfc_check_dependency (eblock->next->expr1, - cblock->next->expr1, 0)) - return gfc_trans_where_3 (cblock, eblock); - } - } - - gfc_start_block (&block); - - gfc_trans_where_2 (code, NULL, false, NULL, &block); - - return gfc_finish_block (&block); -} - - -/* CYCLE a DO loop. The label decl has already been created by - gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code - node at the head of the loop. We must mark the label as used. */ - -tree -gfc_trans_cycle (gfc_code * code) -{ - tree cycle_label; - - cycle_label = code->ext.which_construct->cycle_label; - gcc_assert (cycle_label); - - TREE_USED (cycle_label) = 1; - return build1_v (GOTO_EXPR, cycle_label); -} - - -/* EXIT a DO loop. Similar to CYCLE, but now the label is in - TREE_VALUE (backend_decl) of the gfc_code node at the head of the - loop. */ - -tree -gfc_trans_exit (gfc_code * code) -{ - tree exit_label; - - exit_label = code->ext.which_construct->exit_label; - gcc_assert (exit_label); - - TREE_USED (exit_label) = 1; - return build1_v (GOTO_EXPR, exit_label); -} - - -/* Get the initializer expression for the code and expr of an allocate. - When no initializer is needed return NULL. */ - -static gfc_expr * -allocate_get_initializer (gfc_code * code, gfc_expr * expr) -{ - if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS) - return NULL; - - /* An explicit type was given in allocate ( T:: object). */ - if (code->ext.alloc.ts.type == BT_DERIVED - && (code->ext.alloc.ts.u.derived->attr.alloc_comp - || gfc_has_default_initializer (code->ext.alloc.ts.u.derived))) - return gfc_default_initializer (&code->ext.alloc.ts); - - if (gfc_bt_struct (expr->ts.type) - && (expr->ts.u.derived->attr.alloc_comp - || gfc_has_default_initializer (expr->ts.u.derived))) - return gfc_default_initializer (&expr->ts); - - if (expr->ts.type == BT_CLASS - && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp - || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived))) - return gfc_default_initializer (&CLASS_DATA (expr)->ts); - - return NULL; -} - -/* Translate the ALLOCATE statement. */ - -tree -gfc_trans_allocate (gfc_code * code) -{ - gfc_alloc *al; - gfc_expr *expr, *e3rhs = NULL, *init_expr; - gfc_se se, se_sz; - tree tmp; - tree parm; - tree stat; - tree errmsg; - tree errlen; - tree label_errmsg; - tree label_finish; - tree memsz; - tree al_vptr, al_len; - /* If an expr3 is present, then store the tree for accessing its - _vptr, and _len components in the variables, respectively. The - element size, i.e. _vptr%size, is stored in expr3_esize. Any of - the trees may be the NULL_TREE indicating that this is not - available for expr3's type. */ - tree expr3, expr3_vptr, expr3_len, expr3_esize; - /* Classify what expr3 stores. */ - enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; - stmtblock_t block; - stmtblock_t post; - stmtblock_t final_block; - tree nelems; - bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray; - bool needs_caf_sync, caf_refs_comp; - bool e3_has_nodescriptor = false; - gfc_symtree *newsym = NULL; - symbol_attribute caf_attr; - gfc_actual_arglist *param_list; - - if (!code->ext.alloc.list) - return NULL_TREE; - - stat = tmp = memsz = al_vptr = al_len = NULL_TREE; - expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; - label_errmsg = label_finish = errmsg = errlen = NULL_TREE; - e3_is = E3_UNSET; - is_coarray = needs_caf_sync = false; - - gfc_init_block (&block); - gfc_init_block (&post); - gfc_init_block (&final_block); - - /* STAT= (and maybe ERRMSG=) is present. */ - if (code->expr1) - { - /* STAT=. */ - tree gfc_int4_type_node = gfc_get_int_type (4); - stat = gfc_create_var (gfc_int4_type_node, "stat"); - - /* ERRMSG= only makes sense with STAT=. */ - if (code->expr2) - { - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr_lhs (&se, code->expr2); - errmsg = se.expr; - errlen = se.string_length; - } - else - { - errmsg = null_pointer_node; - errlen = build_int_cst (gfc_charlen_type_node, 0); - } - - /* GOTO destinations. */ - label_errmsg = gfc_build_label_decl (NULL_TREE); - label_finish = gfc_build_label_decl (NULL_TREE); - TREE_USED (label_finish) = 0; - } - - /* When an expr3 is present evaluate it only once. The standards prevent a - dependency of expr3 on the objects in the allocate list. An expr3 can - be pre-evaluated in all cases. One just has to make sure, to use the - correct way, i.e., to get the descriptor or to get a reference - expression. */ - if (code->expr3) - { - bool vtab_needed = false, temp_var_needed = false, - temp_obj_created = false; - - is_coarray = gfc_is_coarray (code->expr3); - - if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold - && (gfc_is_class_array_function (code->expr3) - || gfc_is_alloc_class_scalar_function (code->expr3))) - code->expr3->must_finalize = 1; - - /* Figure whether we need the vtab from expr3. */ - for (al = code->ext.alloc.list; !vtab_needed && al != NULL; - al = al->next) - vtab_needed = (al->expr->ts.type == BT_CLASS); - - gfc_init_se (&se, NULL); - /* When expr3 is a variable, i.e., a very simple expression, - then convert it once here. */ - if (code->expr3->expr_type == EXPR_VARIABLE - || code->expr3->expr_type == EXPR_ARRAY - || code->expr3->expr_type == EXPR_CONSTANT) - { - if (!code->expr3->mold - || code->expr3->ts.type == BT_CHARACTER - || vtab_needed - || code->ext.alloc.arr_spec_from_expr3) - { - /* Convert expr3 to a tree. For all "simple" expression just - get the descriptor or the reference, respectively, depending - on the rank of the expr. */ - if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0) - gfc_conv_expr_descriptor (&se, code->expr3); - else - { - gfc_conv_expr_reference (&se, code->expr3); - - /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a - NOP_EXPR, which prevents gfortran from getting the vptr - from the source=-expression. Remove the NOP_EXPR and go - with the POINTER_PLUS_EXPR in this case. */ - if (code->expr3->ts.type == BT_CLASS - && TREE_CODE (se.expr) == NOP_EXPR - && (TREE_CODE (TREE_OPERAND (se.expr, 0)) - == POINTER_PLUS_EXPR - || is_coarray)) - se.expr = TREE_OPERAND (se.expr, 0); - } - /* Create a temp variable only for component refs to prevent - having to go through the full deref-chain each time and to - simplfy computation of array properties. */ - temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; - } - } - else - { - /* In all other cases evaluate the expr3. */ - symbol_attribute attr; - /* Get the descriptor for all arrays, that are not allocatable or - pointer, because the latter are descriptors already. - The exception are function calls returning a class object: - The descriptor is stored in their results _data component, which - is easier to access, when first a temporary variable for the - result is created and the descriptor retrieved from there. */ - attr = gfc_expr_attr (code->expr3); - if (code->expr3->rank != 0 - && ((!attr.allocatable && !attr.pointer) - || (code->expr3->expr_type == EXPR_FUNCTION - && (code->expr3->ts.type != BT_CLASS - || (code->expr3->value.function.isym - && code->expr3->value.function.isym - ->transformational))))) - gfc_conv_expr_descriptor (&se, code->expr3); - else - gfc_conv_expr_reference (&se, code->expr3); - if (code->expr3->ts.type == BT_CLASS) - gfc_conv_class_to_class (&se, code->expr3, - code->expr3->ts, - false, true, - false, false); - temp_obj_created = temp_var_needed = !VAR_P (se.expr); - } - gfc_add_block_to_block (&block, &se.pre); - if (code->expr3->must_finalize) - gfc_add_block_to_block (&final_block, &se.post); - else - gfc_add_block_to_block (&post, &se.post); - - /* Special case when string in expr3 is zero. */ - if (code->expr3->ts.type == BT_CHARACTER - && integer_zerop (se.string_length)) - { - gfc_init_se (&se, NULL); - temp_var_needed = false; - expr3_len = build_zero_cst (gfc_charlen_type_node); - e3_is = E3_MOLD; - } - /* Prevent aliasing, i.e., se.expr may be already a - variable declaration. */ - else if (se.expr != NULL_TREE && temp_var_needed) - { - tree var, desc; - tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) || is_coarray ? - se.expr - : build_fold_indirect_ref_loc (input_location, se.expr); - - /* Get the array descriptor and prepare it to be assigned to the - temporary variable var. For classes the array descriptor is - in the _data component and the object goes into the - GFC_DECL_SAVED_DESCRIPTOR. */ - if (code->expr3->ts.type == BT_CLASS - && code->expr3->rank != 0) - { - /* When an array_ref was in expr3, then the descriptor is the - first operand. */ - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) - { - desc = TREE_OPERAND (tmp, 0); - } - else - { - desc = tmp; - tmp = gfc_class_data_get (tmp); - } - if (code->ext.alloc.arr_spec_from_expr3) - e3_is = E3_DESC; - } - else - desc = !is_coarray ? se.expr - : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0); - /* We need a regular (non-UID) symbol here, therefore give a - prefix. */ - var = gfc_create_var (TREE_TYPE (tmp), "source"); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) - { - gfc_allocate_lang_decl (var); - GFC_DECL_SAVED_DESCRIPTOR (var) = desc; - } - gfc_add_modify_loc (input_location, &block, var, tmp); - - expr3 = var; - if (se.string_length) - /* Evaluate it assuming that it also is complicated like expr3. */ - expr3_len = gfc_evaluate_now (se.string_length, &block); - } - else - { - expr3 = se.expr; - expr3_len = se.string_length; - } - - /* Deallocate any allocatable components in expressions that use a - temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE. - E.g. temporaries of a function call need freeing of their components - here. */ - if ((code->expr3->ts.type == BT_DERIVED - || code->expr3->ts.type == BT_CLASS) - && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created) - && code->expr3->ts.u.derived->attr.alloc_comp - && !code->expr3->must_finalize) - { - tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, - expr3, code->expr3->rank); - gfc_prepend_expr_to_block (&post, tmp); - } - - /* Store what the expr3 is to be used for. */ - if (e3_is == E3_UNSET) - e3_is = expr3 != NULL_TREE ? - (code->ext.alloc.arr_spec_from_expr3 ? - E3_DESC - : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) - : E3_UNSET; - - /* Figure how to get the _vtab entry. This also obtains the tree - expression for accessing the _len component, because only - unlimited polymorphic objects, which are a subcategory of class - types, have a _len component. */ - if (code->expr3->ts.type == BT_CLASS) - { - gfc_expr *rhs; - tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ? - build_fold_indirect_ref (expr3): expr3; - /* Polymorphic SOURCE: VPTR must be determined at run time. - expr3 may be a temporary array declaration, therefore check for - GFC_CLASS_TYPE_P before trying to get the _vptr component. */ - if (tmp != NULL_TREE - && (e3_is == E3_DESC - || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) - && (VAR_P (tmp) || !code->expr3->ref)) - || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp)))) - tmp = gfc_class_vptr_get (expr3); - else - { - rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); - gfc_add_vptr_component (rhs); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, rhs); - tmp = se.expr; - gfc_free_expr (rhs); - } - /* Set the element size. */ - expr3_esize = gfc_vptr_size_get (tmp); - if (vtab_needed) - expr3_vptr = tmp; - /* Initialize the ref to the _len component. */ - if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3)) - { - /* Same like for retrieving the _vptr. */ - if (expr3 != NULL_TREE && !code->expr3->ref) - expr3_len = gfc_class_len_get (expr3); - else - { - rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); - gfc_add_len_component (rhs); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, rhs); - expr3_len = se.expr; - gfc_free_expr (rhs); - } - } - } - else - { - /* When the object to allocate is polymorphic type, then it - needs its vtab set correctly, so deduce the required _vtab - and _len from the source expression. */ - if (vtab_needed) - { - /* VPTR is fixed at compile time. */ - gfc_symbol *vtab; - - vtab = gfc_find_vtab (&code->expr3->ts); - gcc_assert (vtab); - expr3_vptr = gfc_get_symbol_decl (vtab); - expr3_vptr = gfc_build_addr_expr (NULL_TREE, - expr3_vptr); - } - /* _len component needs to be set, when ts is a character - array. */ - if (expr3_len == NULL_TREE - && code->expr3->ts.type == BT_CHARACTER) - { - if (code->expr3->ts.u.cl - && code->expr3->ts.u.cl->length) - { - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, code->expr3->ts.u.cl->length); - gfc_add_block_to_block (&block, &se.pre); - expr3_len = gfc_evaluate_now (se.expr, &block); - } - gcc_assert (expr3_len); - } - /* For character arrays only the kind's size is needed, because - the array mem_size is _len * (elem_size = kind_size). - For all other get the element size in the normal way. */ - if (code->expr3->ts.type == BT_CHARACTER) - expr3_esize = TYPE_SIZE_UNIT ( - gfc_get_char_type (code->expr3->ts.kind)); - else - expr3_esize = TYPE_SIZE_UNIT ( - gfc_typenode_for_spec (&code->expr3->ts)); - } - gcc_assert (expr3_esize); - expr3_esize = fold_convert (sizetype, expr3_esize); - if (e3_is == E3_MOLD) - /* The expr3 is no longer valid after this point. */ - expr3 = NULL_TREE; - } - else if (code->ext.alloc.ts.type != BT_UNKNOWN) - { - /* Compute the explicit typespec given only once for all objects - to allocate. */ - if (code->ext.alloc.ts.type != BT_CHARACTER) - expr3_esize = TYPE_SIZE_UNIT ( - gfc_typenode_for_spec (&code->ext.alloc.ts)); - else if (code->ext.alloc.ts.u.cl->length != NULL) - { - gfc_expr *sz; - sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length); - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, sz); - gfc_free_expr (sz); - tmp = gfc_get_char_type (code->ext.alloc.ts.kind); - tmp = TYPE_SIZE_UNIT (tmp); - tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp); - gfc_add_block_to_block (&block, &se_sz.pre); - expr3_esize = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (se_sz.expr), - tmp, se_sz.expr); - expr3_esize = gfc_evaluate_now (expr3_esize, &block); - } - else - expr3_esize = NULL_TREE; - } - - /* The routine gfc_trans_assignment () already implements all - techniques needed. Unfortunately we may have a temporary - variable for the source= expression here. When that is the - case convert this variable into a temporary gfc_expr of type - EXPR_VARIABLE and used it as rhs for the assignment. The - advantage is, that we get scalarizer support for free, - don't have to take care about scalar to array treatment and - will benefit of every enhancements gfc_trans_assignment () - gets. - No need to check whether e3_is is E3_UNSET, because that is - done by expr3 != NULL_TREE. - Exclude variables since the following block does not handle - array sections. In any case, there is no harm in sending - variables to gfc_trans_assignment because there is no - evaluation of variables. */ - if (code->expr3) - { - if (code->expr3->expr_type != EXPR_VARIABLE - && e3_is != E3_MOLD && expr3 != NULL_TREE - && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) - { - /* Build a temporary symtree and symbol. Do not add it to the current - namespace to prevent accidently modifying a colliding - symbol's as. */ - newsym = XCNEW (gfc_symtree); - /* The name of the symtree should be unique, because gfc_create_var () - took care about generating the identifier. */ - newsym->name - = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3))); - newsym->n.sym = gfc_new_symbol (newsym->name, NULL); - /* The backend_decl is known. It is expr3, which is inserted - here. */ - newsym->n.sym->backend_decl = expr3; - e3rhs = gfc_get_expr (); - e3rhs->rank = code->expr3->rank; - e3rhs->symtree = newsym; - /* Mark the symbol referenced or gfc_trans_assignment will bug. */ - newsym->n.sym->attr.referenced = 1; - e3rhs->expr_type = EXPR_VARIABLE; - e3rhs->where = code->expr3->where; - /* Set the symbols type, upto it was BT_UNKNOWN. */ - if (IS_CLASS_ARRAY (code->expr3) - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym - && code->expr3->value.function.isym->transformational) - { - e3rhs->ts = CLASS_DATA (code->expr3)->ts; - } - else if (code->expr3->ts.type == BT_CLASS - && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3))) - e3rhs->ts = CLASS_DATA (code->expr3)->ts; - else - e3rhs->ts = code->expr3->ts; - newsym->n.sym->ts = e3rhs->ts; - /* Check whether the expr3 is array valued. */ - if (e3rhs->rank) - { - gfc_array_spec *arr; - arr = gfc_get_array_spec (); - arr->rank = e3rhs->rank; - arr->type = AS_DEFERRED; - /* Set the dimension and pointer attribute for arrays - to be on the safe side. */ - newsym->n.sym->attr.dimension = 1; - newsym->n.sym->attr.pointer = 1; - newsym->n.sym->as = arr; - if (IS_CLASS_ARRAY (code->expr3) - && code->expr3->expr_type == EXPR_FUNCTION - && code->expr3->value.function.isym - && code->expr3->value.function.isym->transformational) - { - gfc_array_spec *tarr; - tarr = gfc_get_array_spec (); - *tarr = *arr; - e3rhs->ts.u.derived->as = tarr; - } - gfc_add_full_array_ref (e3rhs, arr); - } - else if (POINTER_TYPE_P (TREE_TYPE (expr3))) - newsym->n.sym->attr.pointer = 1; - /* The string length is known, too. Set it for char arrays. */ - if (e3rhs->ts.type == BT_CHARACTER) - newsym->n.sym->ts.u.cl->backend_decl = expr3_len; - gfc_commit_symbol (newsym->n.sym); - } - else - e3rhs = gfc_copy_expr (code->expr3); - - // We need to propagate the bounds of the expr3 for source=/mold=. - // However, for non-named arrays, the lbound has to be 1 and neither the - // bound used inside the called function even when returning an - // allocatable/pointer nor the zero used internally. - if (e3_is == E3_DESC - && code->expr3->expr_type != EXPR_VARIABLE) - e3_has_nodescriptor = true; - } - - /* Loop over all objects to allocate. */ - for (al = code->ext.alloc.list; al != NULL; al = al->next) - { - expr = gfc_copy_expr (al->expr); - /* UNLIMITED_POLY () needs the _data component to be set, when - expr is a unlimited polymorphic object. But the _data component - has not been set yet, so check the derived type's attr for the - unlimited polymorphic flag to be safe. */ - upoly_expr = UNLIMITED_POLY (expr) - || (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->attr.unlimited_polymorphic); - gfc_init_se (&se, NULL); - - /* For class types prepare the expressions to ref the _vptr - and the _len component. The latter for unlimited polymorphic - types only. */ - if (expr->ts.type == BT_CLASS) - { - gfc_expr *expr_ref_vptr, *expr_ref_len; - gfc_add_data_component (expr); - /* Prep the vptr handle. */ - expr_ref_vptr = gfc_copy_expr (al->expr); - gfc_add_vptr_component (expr_ref_vptr); - se.want_pointer = 1; - gfc_conv_expr (&se, expr_ref_vptr); - al_vptr = se.expr; - se.want_pointer = 0; - gfc_free_expr (expr_ref_vptr); - /* Allocated unlimited polymorphic objects always have a _len - component. */ - if (upoly_expr) - { - expr_ref_len = gfc_copy_expr (al->expr); - gfc_add_len_component (expr_ref_len); - gfc_conv_expr (&se, expr_ref_len); - al_len = se.expr; - gfc_free_expr (expr_ref_len); - } - else - /* In a loop ensure that all loop variable dependent variables - are initialized at the same spot in all execution paths. */ - al_len = NULL_TREE; - } - else - al_vptr = al_len = NULL_TREE; - - se.want_pointer = 1; - se.descriptor_only = 1; - - gfc_conv_expr (&se, expr); - if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) - /* se.string_length now stores the .string_length variable of expr - needed to allocate character(len=:) arrays. */ - al_len = se.string_length; - - al_len_needs_set = al_len != NULL_TREE; - /* When allocating an array one cannot use much of the - pre-evaluated expr3 expressions, because for most of them the - scalarizer is needed which is not available in the pre-evaluation - step. Therefore gfc_array_allocate () is responsible (and able) - to handle the complete array allocation. Only the element size - needs to be provided, which is done most of the time by the - pre-evaluation step. */ - nelems = NULL_TREE; - if (expr3_len && (code->expr3->ts.type == BT_CHARACTER - || code->expr3->ts.type == BT_CLASS)) - { - /* When al is an array, then the element size for each element - in the array is needed, which is the product of the len and - esize for char arrays. For unlimited polymorphics len can be - zero, therefore take the maximum of len and one. */ - tmp = fold_build2_loc (input_location, MAX_EXPR, - TREE_TYPE (expr3_len), - expr3_len, fold_convert (TREE_TYPE (expr3_len), - integer_one_node)); - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (expr3_esize), expr3_esize, - fold_convert (TREE_TYPE (expr3_esize), tmp)); - } - else - tmp = expr3_esize; - - if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, - label_finish, tmp, &nelems, - e3rhs ? e3rhs : code->expr3, - e3_is == E3_DESC ? expr3 : NULL_TREE, - e3_has_nodescriptor)) - { - /* A scalar or derived type. First compute the size to - allocate. - - expr3_len is set when expr3 is an unlimited polymorphic - object or a deferred length string. */ - if (expr3_len != NULL_TREE) - { - tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len); - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (expr3_esize), - expr3_esize, tmp); - if (code->expr3->ts.type != BT_CLASS) - /* expr3 is a deferred length string, i.e., we are - done. */ - memsz = tmp; - else - { - /* For unlimited polymorphic enties build - (len > 0) ? element_size * len : element_size - to compute the number of bytes to allocate. - This allows the allocation of unlimited polymorphic - objects from an expr3 that is also unlimited - polymorphic and stores a _len dependent object, - e.g., a string. */ - memsz = fold_build2_loc (input_location, GT_EXPR, - logical_type_node, expr3_len, - build_zero_cst - (TREE_TYPE (expr3_len))); - memsz = fold_build3_loc (input_location, COND_EXPR, - TREE_TYPE (expr3_esize), - memsz, tmp, expr3_esize); - } - } - else if (expr3_esize != NULL_TREE) - /* Any other object in expr3 just needs element size in - bytes. */ - memsz = expr3_esize; - else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred) - || (upoly_expr - && code->ext.alloc.ts.type == BT_CHARACTER)) - { - /* Allocating deferred length char arrays need the length - to allocate in the alloc_type_spec. But also unlimited - polymorphic objects may be allocated as char arrays. - Both are handled here. */ - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); - gfc_add_block_to_block (&se.pre, &se_sz.pre); - se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); - gfc_add_block_to_block (&se.pre, &se_sz.post); - expr3_len = se_sz.expr; - tmp_expr3_len_flag = true; - tmp = TYPE_SIZE_UNIT ( - gfc_get_char_type (code->ext.alloc.ts.kind)); - memsz = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), - fold_convert (TREE_TYPE (tmp), - expr3_len), - tmp); - } - else if (expr->ts.type == BT_CHARACTER) - { - /* Compute the number of bytes needed to allocate a fixed - length char array. */ - gcc_assert (se.string_length != NULL_TREE); - tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)); - memsz = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (tmp), tmp, - fold_convert (TREE_TYPE (tmp), - se.string_length)); - } - else if (code->ext.alloc.ts.type != BT_UNKNOWN) - /* Handle all types, where the alloc_type_spec is set. */ - memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); - else - /* Handle size computation of the type declared to alloc. */ - memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); - - /* Store the caf-attributes for latter use. */ - if (flag_coarray == GFC_FCOARRAY_LIB - && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) - .codimension) - { - /* Scalar allocatable components in coarray'ed derived types make - it here and are treated now. */ - tree caf_decl, token; - gfc_se caf_se; - - is_coarray = true; - /* Set flag, to add synchronize after the allocate. */ - needs_caf_sync = needs_caf_sync - || caf_attr.coarray_comp || !caf_refs_comp; - - gfc_init_se (&caf_se, NULL); - - caf_decl = gfc_get_tree_for_caf_expr (expr); - gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, - NULL_TREE, NULL); - gfc_add_block_to_block (&se.pre, &caf_se.pre); - gfc_allocate_allocatable (&se.pre, se.expr, memsz, - gfc_build_addr_expr (NULL_TREE, token), - NULL_TREE, NULL_TREE, NULL_TREE, - label_finish, expr, 1); - } - /* Allocate - for non-pointers with re-alloc checking. */ - else if (gfc_expr_attr (expr).allocatable) - gfc_allocate_allocatable (&se.pre, se.expr, memsz, - NULL_TREE, stat, errmsg, errlen, - label_finish, expr, 0); - else - gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); - } - else - { - /* Allocating coarrays needs a sync after the allocate executed. - Set the flag to add the sync after all objects are allocated. */ - if (flag_coarray == GFC_FCOARRAY_LIB - && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) - .codimension) - { - is_coarray = true; - needs_caf_sync = needs_caf_sync - || caf_attr.coarray_comp || !caf_refs_comp; - } - - if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE - && expr3_len != NULL_TREE) - { - /* Arrays need to have a _len set before the array - descriptor is filled. */ - gfc_add_modify (&block, al_len, - fold_convert (TREE_TYPE (al_len), expr3_len)); - /* Prevent setting the length twice. */ - al_len_needs_set = false; - } - else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE - && code->ext.alloc.ts.u.cl->length) - { - /* Cover the cases where a string length is explicitly - specified by a type spec for deferred length character - arrays or unlimited polymorphic objects without a - source= or mold= expression. */ - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); - gfc_add_block_to_block (&block, &se_sz.pre); - gfc_add_modify (&block, al_len, - fold_convert (TREE_TYPE (al_len), - se_sz.expr)); - al_len_needs_set = false; - } - } - - gfc_add_block_to_block (&block, &se.pre); - - /* Error checking -- Note: ERRMSG only makes sense with STAT. */ - if (code->expr1) - { - tmp = build1_v (GOTO_EXPR, label_errmsg); - parm = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, stat, - build_int_cst (TREE_TYPE (stat), 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC), - tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); - } - - /* Set the vptr only when no source= is set. When source= is set, then - the trans_assignment below will set the vptr. */ - if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold)) - { - if (expr3_vptr != NULL_TREE) - /* The vtab is already known, so just assign it. */ - gfc_add_modify (&block, al_vptr, - fold_convert (TREE_TYPE (al_vptr), expr3_vptr)); - else - { - /* VPTR is fixed at compile time. */ - gfc_symbol *vtab; - gfc_typespec *ts; - - if (code->expr3) - /* Although expr3 is pre-evaluated above, it may happen, - that for arrays or in mold= cases the pre-evaluation - was not successful. In these rare cases take the vtab - from the typespec of expr3 here. */ - ts = &code->expr3->ts; - else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr) - /* The alloc_type_spec gives the type to allocate or the - al is unlimited polymorphic, which enforces the use of - an alloc_type_spec that is not necessarily a BT_DERIVED. */ - ts = &code->ext.alloc.ts; - else - /* Prepare for setting the vtab as declared. */ - ts = &expr->ts; - - vtab = gfc_find_vtab (ts); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, - gfc_get_symbol_decl (vtab)); - gfc_add_modify (&block, al_vptr, - fold_convert (TREE_TYPE (al_vptr), tmp)); - } - } - - /* Add assignment for string length. */ - if (al_len != NULL_TREE && al_len_needs_set) - { - if (expr3_len != NULL_TREE) - { - gfc_add_modify (&block, al_len, - fold_convert (TREE_TYPE (al_len), - expr3_len)); - /* When tmp_expr3_len_flag is set, then expr3_len is - abused to carry the length information from the - alloc_type. Clear it to prevent setting incorrect len - information in future loop iterations. */ - if (tmp_expr3_len_flag) - /* No need to reset tmp_expr3_len_flag, because the - presence of an expr3 cannot change within in the - loop. */ - expr3_len = NULL_TREE; - } - else if (code->ext.alloc.ts.type == BT_CHARACTER - && code->ext.alloc.ts.u.cl->length) - { - /* Cover the cases where a string length is explicitly - specified by a type spec for deferred length character - arrays or unlimited polymorphic objects without a - source= or mold= expression. */ - if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1) - { - gfc_init_se (&se_sz, NULL); - gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); - gfc_add_block_to_block (&block, &se_sz.pre); - gfc_add_modify (&block, al_len, - fold_convert (TREE_TYPE (al_len), - se_sz.expr)); - } - else - gfc_add_modify (&block, al_len, - fold_convert (TREE_TYPE (al_len), - expr3_esize)); - } - else - /* No length information needed, because type to allocate - has no length. Set _len to 0. */ - gfc_add_modify (&block, al_len, - fold_convert (TREE_TYPE (al_len), - integer_zero_node)); - } - - init_expr = NULL; - if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) - { - /* Initialization via SOURCE block (or static default initializer). - Switch off automatic reallocation since we have just done the - ALLOCATE. */ - int realloc_lhs = flag_realloc_lhs; - gfc_expr *init_expr = gfc_expr_to_initialize (expr); - gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); - flag_realloc_lhs = 0; - tmp = gfc_trans_assignment (init_expr, rhs, true, false, true, - false); - flag_realloc_lhs = realloc_lhs; - /* Free the expression allocated for init_expr. */ - gfc_free_expr (init_expr); - if (rhs != e3rhs) - gfc_free_expr (rhs); - gfc_add_expr_to_block (&block, tmp); - } - /* Set KIND and LEN PDT components and allocate those that are - parameterized. */ - else if (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->attr.pdt_type) - { - if (code->expr3 && code->expr3->param_list) - param_list = code->expr3->param_list; - else if (expr->param_list) - param_list = expr->param_list; - else - param_list = expr->symtree->n.sym->param_list; - tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr, - expr->rank, param_list); - gfc_add_expr_to_block (&block, tmp); - } - /* Ditto for CLASS expressions. */ - else if (expr->ts.type == BT_CLASS - && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type) - { - if (code->expr3 && code->expr3->param_list) - param_list = code->expr3->param_list; - else if (expr->param_list) - param_list = expr->param_list; - else - param_list = expr->symtree->n.sym->param_list; - tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, - se.expr, expr->rank, param_list); - gfc_add_expr_to_block (&block, tmp); - } - else if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_CLASS) - { - /* Use class_init_assign to initialize expr. */ - gfc_code *ini; - ini = gfc_get_code (EXEC_INIT_ASSIGN); - ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true); - tmp = gfc_trans_class_init_assign (ini); - gfc_free_statements (ini); - gfc_add_expr_to_block (&block, tmp); - } - else if ((init_expr = allocate_get_initializer (code, expr))) - { - /* Use class_init_assign to initialize expr. */ - gfc_code *ini; - int realloc_lhs = flag_realloc_lhs; - ini = gfc_get_code (EXEC_INIT_ASSIGN); - ini->expr1 = gfc_expr_to_initialize (expr); - ini->expr2 = init_expr; - flag_realloc_lhs = 0; - tmp= gfc_trans_init_assign (ini); - flag_realloc_lhs = realloc_lhs; - gfc_free_statements (ini); - /* Init_expr is freeed by above free_statements, just need to null - it here. */ - init_expr = NULL; - gfc_add_expr_to_block (&block, tmp); - } - - /* Nullify all pointers in derived type coarrays. This registers a - token for them which allows their allocation. */ - if (is_coarray) - { - gfc_symbol *type = NULL; - symbol_attribute caf_attr; - int rank = 0; - if (code->ext.alloc.ts.type == BT_DERIVED - && code->ext.alloc.ts.u.derived->attr.pointer_comp) - { - type = code->ext.alloc.ts.u.derived; - rank = type->attr.dimension ? type->as->rank : 0; - gfc_clear_attr (&caf_attr); - } - else if (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->attr.pointer_comp) - { - type = expr->ts.u.derived; - rank = expr->rank; - caf_attr = gfc_caf_attr (expr, true); - } - - /* Initialize the tokens of pointer components in derived type - coarrays. */ - if (type) - { - tmp = (caf_attr.codimension && !caf_attr.dimension) - ? gfc_conv_descriptor_data_get (se.expr) : se.expr; - tmp = gfc_nullify_alloc_comp (type, tmp, rank, - GFC_STRUCTURE_CAF_MODE_IN_COARRAY); - gfc_add_expr_to_block (&block, tmp); - } - } - - gfc_free_expr (expr); - } // for-loop - - if (e3rhs) - { - if (newsym) - { - gfc_free_symbol (newsym->n.sym); - XDELETE (newsym); - } - gfc_free_expr (e3rhs); - } - /* STAT. */ - if (code->expr1) - { - tmp = build1_v (LABEL_EXPR, label_errmsg); - gfc_add_expr_to_block (&block, tmp); - } - - /* ERRMSG - only useful if STAT is present. */ - if (code->expr1 && code->expr2) - { - const char *msg = "Attempt to allocate an allocated object"; - tree slen, dlen, errmsg_str; - stmtblock_t errmsg_block; - - gfc_init_block (&errmsg_block); - - errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); - gfc_add_modify (&errmsg_block, errmsg_str, - gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const (msg))); - - slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); - dlen = gfc_get_expr_charlen (code->expr2); - slen = fold_build2_loc (input_location, MIN_EXPR, - TREE_TYPE (slen), dlen, slen); - - gfc_trans_string_copy (&errmsg_block, dlen, errmsg, - code->expr2->ts.kind, - slen, errmsg_str, - gfc_default_character_kind); - dlen = gfc_finish_block (&errmsg_block); - - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - stat, build_int_cst (TREE_TYPE (stat), 0)); - - tmp = build3_v (COND_EXPR, tmp, - dlen, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - } - - /* STAT block. */ - if (code->expr1) - { - if (TREE_USED (label_finish)) - { - tmp = build1_v (LABEL_EXPR, label_finish); - gfc_add_expr_to_block (&block, tmp); - } - - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr1); - tmp = convert (TREE_TYPE (se.expr), stat); - gfc_add_modify (&block, se.expr, tmp); - } - - if (needs_caf_sync) - { - /* Add a sync all after the allocation has been executed. */ - tree zero_size = build_zero_cst (size_type_node); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, - 3, null_pointer_node, null_pointer_node, - zero_size); - gfc_add_expr_to_block (&post, tmp); - } - - gfc_add_block_to_block (&block, &se.post); - gfc_add_block_to_block (&block, &post); - if (code->expr3 && code->expr3->must_finalize) - gfc_add_block_to_block (&block, &final_block); - - return gfc_finish_block (&block); -} - - -/* Translate a DEALLOCATE statement. */ - -tree -gfc_trans_deallocate (gfc_code *code) -{ - gfc_se se; - gfc_alloc *al; - tree apstat, pstat, stat, errmsg, errlen, tmp; - tree label_finish, label_errmsg; - stmtblock_t block; - - pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE; - label_finish = label_errmsg = NULL_TREE; - - gfc_start_block (&block); - - /* Count the number of failed deallocations. If deallocate() was - called with STAT= , then set STAT to the count. If deallocate - was called with ERRMSG, then set ERRMG to a string. */ - if (code->expr1) - { - tree gfc_int4_type_node = gfc_get_int_type (4); - - stat = gfc_create_var (gfc_int4_type_node, "stat"); - pstat = gfc_build_addr_expr (NULL_TREE, stat); - - /* GOTO destinations. */ - label_errmsg = gfc_build_label_decl (NULL_TREE); - label_finish = gfc_build_label_decl (NULL_TREE); - TREE_USED (label_finish) = 0; - } - - /* Set ERRMSG - only needed if STAT is available. */ - if (code->expr1 && code->expr2) - { - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr_lhs (&se, code->expr2); - errmsg = se.expr; - errlen = se.string_length; - } - - for (al = code->ext.alloc.list; al != NULL; al = al->next) - { - gfc_expr *expr = gfc_copy_expr (al->expr); - bool is_coarray = false, is_coarray_array = false; - int caf_mode = 0; - - gcc_assert (expr->expr_type == EXPR_VARIABLE); - - if (expr->ts.type == BT_CLASS) - gfc_add_data_component (expr); - - gfc_init_se (&se, NULL); - gfc_start_block (&se.pre); - - se.want_pointer = 1; - se.descriptor_only = 1; - gfc_conv_expr (&se, expr); - - /* Deallocate PDT components that are parameterized. */ - tmp = NULL; - if (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->attr.pdt_type - && expr->symtree->n.sym->param_list) - tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank); - else if (expr->ts.type == BT_CLASS - && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type - && expr->symtree->n.sym->param_list) - tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, - se.expr, expr->rank); - - if (tmp) - gfc_add_expr_to_block (&block, tmp); - - if (flag_coarray == GFC_FCOARRAY_LIB - || flag_coarray == GFC_FCOARRAY_SINGLE) - { - bool comp_ref; - symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref); - if (caf_attr.codimension) - { - is_coarray = true; - is_coarray_array = caf_attr.dimension || !comp_ref - || caf_attr.coarray_comp; - - if (flag_coarray == GFC_FCOARRAY_LIB) - /* When the expression to deallocate is referencing a - component, then only deallocate it, but do not - deregister. */ - caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY - | (comp_ref && !caf_attr.coarray_comp - ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0); - } - } - - if (expr->rank || is_coarray_array) - { - gfc_ref *ref; - - if (gfc_bt_struct (expr->ts.type) - && expr->ts.u.derived->attr.alloc_comp - && !gfc_is_finalizable (expr->ts.u.derived, NULL)) - { - gfc_ref *last = NULL; - - for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - last = ref; - - /* Do not deallocate the components of a derived type - ultimate pointer component. */ - if (!(last && last->u.c.component->attr.pointer) - && !(!last && expr->symtree->n.sym->attr.pointer)) - { - if (is_coarray && expr->rank == 0 - && (!last || !last->u.c.component->attr.dimension) - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) - { - /* Add the ref to the data member only, when this is not - a regular array or deallocate_alloc_comp will try to - add another one. */ - tmp = gfc_conv_descriptor_data_get (se.expr); - } - else - tmp = se.expr; - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, - expr->rank, caf_mode); - gfc_add_expr_to_block (&se.pre, tmp); - } - } - - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) - { - gfc_coarray_deregtype caf_dtype; - - if (is_coarray) - caf_dtype = gfc_caf_is_dealloc_only (caf_mode) - ? GFC_CAF_COARRAY_DEALLOCATE_ONLY - : GFC_CAF_COARRAY_DEREGISTER; - else - caf_dtype = GFC_CAF_COARRAY_NOCOARRAY; - tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen, - label_finish, false, expr, - caf_dtype); - gfc_add_expr_to_block (&se.pre, tmp); - } - else if (TREE_CODE (se.expr) == COMPONENT_REF - && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE - && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr))) - == RECORD_TYPE) - { - /* class.c(finalize_component) generates these, when a - finalizable entity has a non-allocatable derived type array - component, which has allocatable components. Obtain the - derived type of the array and deallocate the allocatable - components. */ - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->u.c.component->attr.dimension - && ref->u.c.component->ts.type == BT_DERIVED) - break; - } - - if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp - && !gfc_is_finalizable (ref->u.c.component->ts.u.derived, - NULL)) - { - tmp = gfc_deallocate_alloc_comp - (ref->u.c.component->ts.u.derived, - se.expr, expr->rank); - gfc_add_expr_to_block (&se.pre, tmp); - } - } - - if (al->expr->ts.type == BT_CLASS) - { - gfc_reset_vptr (&se.pre, al->expr); - if (UNLIMITED_POLY (al->expr) - || (al->expr->ts.type == BT_DERIVED - && al->expr->ts.u.derived->attr.unlimited_polymorphic)) - /* Clear _len, too. */ - gfc_reset_len (&se.pre, al->expr); - } - } - else - { - tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish, - false, al->expr, - al->expr->ts, is_coarray); - gfc_add_expr_to_block (&se.pre, tmp); - - /* Set to zero after deallocation. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, - se.expr, - build_int_cst (TREE_TYPE (se.expr), 0)); - gfc_add_expr_to_block (&se.pre, tmp); - - if (al->expr->ts.type == BT_CLASS) - { - gfc_reset_vptr (&se.pre, al->expr); - if (UNLIMITED_POLY (al->expr) - || (al->expr->ts.type == BT_DERIVED - && al->expr->ts.u.derived->attr.unlimited_polymorphic)) - /* Clear _len, too. */ - gfc_reset_len (&se.pre, al->expr); - } - } - - if (code->expr1) - { - tree cond; - - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, - build_int_cst (TREE_TYPE (stat), 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), - build1_v (GOTO_EXPR, label_errmsg), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se.pre, tmp); - } - - tmp = gfc_finish_block (&se.pre); - gfc_add_expr_to_block (&block, tmp); - gfc_free_expr (expr); - } - - if (code->expr1) - { - tmp = build1_v (LABEL_EXPR, label_errmsg); - gfc_add_expr_to_block (&block, tmp); - } - - /* Set ERRMSG - only needed if STAT is available. */ - if (code->expr1 && code->expr2) - { - const char *msg = "Attempt to deallocate an unallocated object"; - stmtblock_t errmsg_block; - tree errmsg_str, slen, dlen, cond; - - gfc_init_block (&errmsg_block); - - errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); - gfc_add_modify (&errmsg_block, errmsg_str, - gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const (msg))); - slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); - dlen = gfc_get_expr_charlen (code->expr2); - - gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, - slen, errmsg_str, gfc_default_character_kind); - tmp = gfc_finish_block (&errmsg_block); - - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, - build_int_cst (TREE_TYPE (stat), 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp, - build_empty_stmt (input_location)); - - gfc_add_expr_to_block (&block, tmp); - } - - if (code->expr1 && TREE_USED (label_finish)) - { - tmp = build1_v (LABEL_EXPR, label_finish); - gfc_add_expr_to_block (&block, tmp); - } - - /* Set STAT. */ - if (code->expr1) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr1); - tmp = convert (TREE_TYPE (se.expr), stat); - gfc_add_modify (&block, se.expr, tmp); - } - - return gfc_finish_block (&block); -} - -#include "gt-fortran-trans-stmt.h" diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc new file mode 100644 index 0000000..a9b463d --- /dev/null +++ b/gcc/fortran/trans-stmt.cc @@ -0,0 +1,7468 @@ +/* Statement translation -- generate GCC trees from gfc_code. + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + and Steven Bosscher + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "trans-stmt.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +#include "dependency.h" + +typedef struct iter_info +{ + tree var; + tree start; + tree end; + tree step; + struct iter_info *next; +} +iter_info; + +typedef struct forall_info +{ + iter_info *this_loop; + tree mask; + tree maskindex; + int nvar; + tree size; + struct forall_info *prev_nest; + bool do_concurrent; +} +forall_info; + +static void gfc_trans_where_2 (gfc_code *, tree, bool, + forall_info *, stmtblock_t *); + +/* Translate a F95 label number to a LABEL_EXPR. */ + +tree +gfc_trans_label_here (gfc_code * code) +{ + return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); +} + + +/* Given a variable expression which has been ASSIGNed to, find the decl + containing the auxiliary variables. For variables in common blocks this + is a field_decl. */ + +void +gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) +{ + gcc_assert (expr->symtree->n.sym->attr.assign == 1); + gfc_conv_expr (se, expr); + /* Deals with variable in common block. Get the field declaration. */ + if (TREE_CODE (se->expr) == COMPONENT_REF) + se->expr = TREE_OPERAND (se->expr, 1); + /* Deals with dummy argument. Get the parameter declaration. */ + else if (TREE_CODE (se->expr) == INDIRECT_REF) + se->expr = TREE_OPERAND (se->expr, 0); +} + +/* Translate a label assignment statement. */ + +tree +gfc_trans_label_assign (gfc_code * code) +{ + tree label_tree; + gfc_se se; + tree len; + tree addr; + tree len_tree; + int label_len; + + /* Start a new block. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + gfc_conv_label_variable (&se, code->expr1); + + len = GFC_DECL_STRING_LEN (se.expr); + addr = GFC_DECL_ASSIGN_ADDR (se.expr); + + label_tree = gfc_get_label_decl (code->label1); + + if (code->label1->defined == ST_LABEL_TARGET + || code->label1->defined == ST_LABEL_DO_TARGET) + { + label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); + len_tree = build_int_cst (gfc_charlen_type_node, -1); + } + else + { + gfc_expr *format = code->label1->format; + + label_len = format->value.character.length; + len_tree = build_int_cst (gfc_charlen_type_node, label_len); + label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1, + format->value.character.string); + label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); + } + + gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree)); + gfc_add_modify (&se.pre, addr, label_tree); + + return gfc_finish_block (&se.pre); +} + +/* Translate a GOTO statement. */ + +tree +gfc_trans_goto (gfc_code * code) +{ + locus loc = code->loc; + tree assigned_goto; + tree target; + tree tmp; + gfc_se se; + + if (code->label1 != NULL) + return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); + + /* ASSIGNED GOTO. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + gfc_conv_label_variable (&se, code->expr1); + tmp = GFC_DECL_STRING_LEN (se.expr); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), -1)); + gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc, + "Assigned label is not a target label"); + + assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); + + /* We're going to ignore a label list. It does not really change the + statement's semantics (because it is just a further restriction on + what's legal code); before, we were comparing label addresses here, but + that's a very fragile business and may break with optimization. So + just ignore it. */ + + target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node, + assigned_goto); + gfc_add_expr_to_block (&se.pre, target); + return gfc_finish_block (&se.pre); +} + + +/* Translate an ENTRY statement. Just adds a label for this entry point. */ +tree +gfc_trans_entry (gfc_code * code) +{ + return build1_v (LABEL_EXPR, code->ext.entry->label); +} + + +/* Replace a gfc_ss structure by another both in the gfc_se struct + and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies + to replace a variable ss by the corresponding temporary. */ + +static void +replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss) +{ + gfc_ss **sess, **loopss; + + /* The old_ss is a ss for a single variable. */ + gcc_assert (old_ss->info->type == GFC_SS_SECTION); + + for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next)) + if (*sess == old_ss) + break; + gcc_assert (*sess != gfc_ss_terminator); + + *sess = new_ss; + new_ss->next = old_ss->next; + + /* Make sure that trailing references are not lost. */ + if (old_ss->info + && old_ss->info->data.array.ref + && old_ss->info->data.array.ref->next + && !(new_ss->info->data.array.ref + && new_ss->info->data.array.ref->next)) + new_ss->info->data.array.ref = old_ss->info->data.array.ref; + + for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator; + loopss = &((*loopss)->loop_chain)) + if (*loopss == old_ss) + break; + gcc_assert (*loopss != gfc_ss_terminator); + + *loopss = new_ss; + new_ss->loop_chain = old_ss->loop_chain; + new_ss->loop = old_ss->loop; + + gfc_free_ss (old_ss); +} + + +/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of + elemental subroutines. Make temporaries for output arguments if any such + dependencies are found. Output arguments are chosen because internal_unpack + can be used, as is, to copy the result back to the variable. */ +static void +gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, + gfc_symbol * sym, gfc_actual_arglist * arg, + gfc_dep_check check_variable) +{ + gfc_actual_arglist *arg0; + gfc_expr *e; + gfc_formal_arglist *formal; + gfc_se parmse; + gfc_ss *ss; + gfc_symbol *fsym; + tree data; + tree size; + tree tmp; + + if (loopse->ss == NULL) + return; + + ss = loopse->ss; + arg0 = arg; + formal = gfc_sym_get_dummy_args (sym); + + /* Loop over all the arguments testing for dependencies. */ + for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + { + e = arg->expr; + if (e == NULL) + continue; + + /* Obtain the info structure for the current argument. */ + for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) + if (ss->info->expr == e) + break; + + /* If there is a dependency, create a temporary and use it + instead of the variable. */ + fsym = formal ? formal->sym : NULL; + if (e->expr_type == EXPR_VARIABLE + && e->rank && fsym + && fsym->attr.intent != INTENT_IN + && gfc_check_fncall_dependency (e, fsym->attr.intent, + sym, arg0, check_variable)) + { + tree initial, temptype; + stmtblock_t temp_post; + gfc_ss *tmp_ss; + + tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen, + GFC_SS_SECTION); + gfc_mark_ss_chain_used (tmp_ss, 1); + tmp_ss->info->expr = ss->info->expr; + replace_ss (loopse, ss, tmp_ss); + + /* Obtain the argument descriptor for unpacking. */ + gfc_init_se (&parmse, NULL); + parmse.want_pointer = 1; + gfc_conv_expr_descriptor (&parmse, e); + gfc_add_block_to_block (&se->pre, &parmse.pre); + + /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), + initialize the array temporary with a copy of the values. */ + if (fsym->attr.intent == INTENT_INOUT + || (fsym->ts.type ==BT_DERIVED + && fsym->attr.intent == INTENT_OUT)) + initial = parmse.expr; + /* For class expressions, we always initialize with the copy of + the values. */ + else if (e->ts.type == BT_CLASS) + initial = parmse.expr; + else + initial = NULL_TREE; + + if (e->ts.type != BT_CLASS) + { + /* Find the type of the temporary to create; we don't use the type + of e itself as this breaks for subcomponent-references in e + (where the type of e is that of the final reference, but + parmse.expr's type corresponds to the full derived-type). */ + /* TODO: Fix this somehow so we don't need a temporary of the whole + array but instead only the components referenced. */ + temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ + gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); + temptype = TREE_TYPE (temptype); + temptype = gfc_get_element_type (temptype); + } + + else + /* For class arrays signal that the size of the dynamic type has to + be obtained from the vtable, using the 'initial' expression. */ + temptype = NULL_TREE; + + /* Generate the temporary. Cleaning up the temporary should be the + very last thing done, so we add the code to a new block and add it + to se->post as last instructions. */ + size = gfc_create_var (gfc_array_index_type, NULL); + data = gfc_create_var (pvoid_type_node, NULL); + gfc_init_block (&temp_post); + tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss, + temptype, initial, false, true, + false, &arg->expr->where); + gfc_add_modify (&se->pre, size, tmp); + tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data); + gfc_add_modify (&se->pre, data, tmp); + + /* Update other ss' delta. */ + gfc_set_delta (loopse->loop); + + /* Copy the result back using unpack..... */ + if (e->ts.type != BT_CLASS) + tmp = build_call_expr_loc (input_location, + gfor_fndecl_in_unpack, 2, parmse.expr, data); + else + { + /* ... except for class results where the copy is + unconditional. */ + tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); + tmp = gfc_conv_descriptor_data_get (tmp); + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), + 3, tmp, data, + fold_convert (size_type_node, size)); + } + gfc_add_expr_to_block (&se->post, tmp); + + /* parmse.pre is already added above. */ + gfc_add_block_to_block (&se->post, &parmse.post); + gfc_add_block_to_block (&se->post, &temp_post); + } + } +} + + +/* Given an executable statement referring to an intrinsic function call, + returns the intrinsic symbol. */ + +static gfc_intrinsic_sym * +get_intrinsic_for_code (gfc_code *code) +{ + if (code->op == EXEC_CALL) + { + gfc_intrinsic_sym * const isym = code->resolved_isym; + if (isym) + return isym; + else + return gfc_get_intrinsic_for_expr (code->expr1); + } + + return NULL; +} + + +/* Translate the CALL statement. Builds a call to an F95 subroutine. */ + +tree +gfc_trans_call (gfc_code * code, bool dependency_check, + tree mask, tree count1, bool invert) +{ + gfc_se se; + gfc_ss * ss; + int has_alternate_specifier; + gfc_dep_check check_variable; + tree index = NULL_TREE; + tree maskexpr = NULL_TREE; + tree tmp; + bool is_intrinsic_mvbits; + + /* A CALL starts a new block because the actual arguments may have to + be evaluated first. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + gcc_assert (code->resolved_sym); + + ss = gfc_ss_terminator; + if (code->resolved_sym->attr.elemental) + ss = gfc_walk_elemental_function_args (ss, code->ext.actual, + get_intrinsic_for_code (code), + GFC_SS_REFERENCE); + + /* MVBITS is inlined but needs the dependency checking found here. */ + is_intrinsic_mvbits = code->resolved_isym + && code->resolved_isym->id == GFC_ISYM_MVBITS; + + /* Is not an elemental subroutine call with array valued arguments. */ + if (ss == gfc_ss_terminator) + { + + if (is_intrinsic_mvbits) + { + has_alternate_specifier = 0; + gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL); + } + else + { + /* Translate the call. */ + has_alternate_specifier = + gfc_conv_procedure_call (&se, code->resolved_sym, + code->ext.actual, code->expr1, NULL); + + /* A subroutine without side-effect, by definition, does nothing! */ + TREE_SIDE_EFFECTS (se.expr) = 1; + } + + /* Chain the pieces together and return the block. */ + if (has_alternate_specifier) + { + gfc_code *select_code; + gfc_symbol *sym; + select_code = code->next; + gcc_assert(select_code->op == EXEC_SELECT); + sym = select_code->expr1->symtree->n.sym; + se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); + if (sym->backend_decl == NULL) + sym->backend_decl = gfc_get_symbol_decl (sym); + gfc_add_modify (&se.pre, sym->backend_decl, se.expr); + } + else + gfc_add_expr_to_block (&se.pre, se.expr); + + gfc_add_block_to_block (&se.pre, &se.post); + } + + else + { + /* An elemental subroutine call with array valued arguments has + to be scalarized. */ + gfc_loopinfo loop; + stmtblock_t body; + stmtblock_t block; + gfc_se loopse; + gfc_se depse; + + /* gfc_walk_elemental_function_args renders the ss chain in the + reverse order to the actual argument order. */ + ss = gfc_reverse_ss (ss); + + /* Initialize the loop. */ + gfc_init_se (&loopse, NULL); + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + + gfc_conv_ss_startstride (&loop); + /* TODO: gfc_conv_loop_setup generates a temporary for vector + subscripts. This could be prevented in the elemental case + as temporaries are handled separatedly + (below in gfc_conv_elemental_dependencies). */ + if (code->expr1) + gfc_conv_loop_setup (&loop, &code->expr1->where); + else + gfc_conv_loop_setup (&loop, &code->loc); + + gfc_mark_ss_chain_used (ss, 1); + + /* Convert the arguments, checking for dependencies. */ + gfc_copy_loopinfo_to_se (&loopse, &loop); + loopse.ss = ss; + + /* For operator assignment, do dependency checking. */ + if (dependency_check) + check_variable = ELEM_CHECK_VARIABLE; + else + check_variable = ELEM_DONT_CHECK_VARIABLE; + + gfc_init_se (&depse, NULL); + gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym, + code->ext.actual, check_variable); + + gfc_add_block_to_block (&loop.pre, &depse.pre); + gfc_add_block_to_block (&loop.post, &depse.post); + + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + gfc_init_block (&block); + + if (mask && count1) + { + /* Form the mask expression according to the mask. */ + index = count1; + maskexpr = gfc_build_array_ref (mask, index, NULL); + if (invert) + maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (maskexpr), maskexpr); + } + + if (is_intrinsic_mvbits) + { + has_alternate_specifier = 0; + gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop); + } + else + { + /* Add the subroutine call to the block. */ + gfc_conv_procedure_call (&loopse, code->resolved_sym, + code->ext.actual, code->expr1, + NULL); + } + + if (mask && count1) + { + tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&loopse.pre, tmp); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + count1, gfc_index_one_node); + gfc_add_modify (&loopse.pre, count1, tmp); + } + else + gfc_add_expr_to_block (&loopse.pre, loopse.expr); + + gfc_add_block_to_block (&block, &loopse.pre); + gfc_add_block_to_block (&block, &loopse.post); + + /* Finish up the loop block and the loop. */ + gfc_add_expr_to_block (&body, gfc_finish_block (&block)); + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&se.pre, &loop.pre); + gfc_add_block_to_block (&se.pre, &loop.post); + gfc_add_block_to_block (&se.pre, &se.post); + gfc_cleanup_loop (&loop); + } + + return gfc_finish_block (&se.pre); +} + + +/* Translate the RETURN statement. */ + +tree +gfc_trans_return (gfc_code * code) +{ + if (code->expr1) + { + gfc_se se; + tree tmp; + tree result; + + /* If code->expr is not NULL, this return statement must appear + in a subroutine and current_fake_result_decl has already + been generated. */ + + result = gfc_get_fake_result_decl (NULL, 0); + if (!result) + { + gfc_warning (0, + "An alternate return at %L without a * dummy argument", + &code->expr1->where); + return gfc_generate_return (); + } + + /* Start a new block for this statement. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + gfc_conv_expr (&se, code->expr1); + + /* Note that the actually returned expression is a simple value and + does not depend on any pointers or such; thus we can clean-up with + se.post before returning. */ + tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result), + result, fold_convert (TREE_TYPE (result), + se.expr)); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + + tmp = gfc_generate_return (); + gfc_add_expr_to_block (&se.pre, tmp); + return gfc_finish_block (&se.pre); + } + + return gfc_generate_return (); +} + + +/* Translate the PAUSE statement. We have to translate this statement + to a runtime library call. */ + +tree +gfc_trans_pause (gfc_code * code) +{ + tree gfc_int8_type_node = gfc_get_int_type (8); + gfc_se se; + tree tmp; + + /* Start a new block for this statement. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + + if (code->expr1 == NULL) + { + tmp = build_int_cst (size_type_node, 0); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_pause_string, 2, + build_int_cst (pchar_type_node, 0), tmp); + } + else if (code->expr1->ts.type == BT_INTEGER) + { + gfc_conv_expr (&se, code->expr1); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_pause_numeric, 1, + fold_convert (gfc_int8_type_node, se.expr)); + } + else + { + gfc_conv_expr_reference (&se, code->expr1); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_pause_string, 2, + se.expr, fold_convert (size_type_node, + se.string_length)); + } + + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_block_to_block (&se.pre, &se.post); + + return gfc_finish_block (&se.pre); +} + + +/* Translate the STOP statement. We have to translate this statement + to a runtime library call. */ + +tree +gfc_trans_stop (gfc_code *code, bool error_stop) +{ + gfc_se se; + tree tmp; + + /* Start a new block for this statement. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + if (code->expr1 == NULL) + { + tmp = build_int_cst (size_type_node, 0); + tmp = build_call_expr_loc (input_location, + error_stop + ? (flag_coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop_str + : gfor_fndecl_error_stop_string) + : (flag_coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_stop_str + : gfor_fndecl_stop_string), + 3, build_int_cst (pchar_type_node, 0), tmp, + boolean_false_node); + } + else if (code->expr1->ts.type == BT_INTEGER) + { + gfc_conv_expr (&se, code->expr1); + tmp = build_call_expr_loc (input_location, + error_stop + ? (flag_coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop + : gfor_fndecl_error_stop_numeric) + : (flag_coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_stop_numeric + : gfor_fndecl_stop_numeric), 2, + fold_convert (integer_type_node, se.expr), + boolean_false_node); + } + else + { + gfc_conv_expr_reference (&se, code->expr1); + tmp = build_call_expr_loc (input_location, + error_stop + ? (flag_coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_error_stop_str + : gfor_fndecl_error_stop_string) + : (flag_coarray == GFC_FCOARRAY_LIB + ? gfor_fndecl_caf_stop_str + : gfor_fndecl_stop_string), + 3, se.expr, fold_convert (size_type_node, + se.string_length), + boolean_false_node); + } + + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_block_to_block (&se.pre, &se.post); + + return gfc_finish_block (&se.pre); +} + +/* Translate the FAIL IMAGE statement. */ + +tree +gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + return build_call_expr_loc (input_location, + gfor_fndecl_caf_fail_image, 0); + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +/* Translate the FORM TEAM statement. */ + +tree +gfc_trans_form_team (gfc_code *code) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se se; + gfc_se argse1, argse2; + tree team_id, team_type, tmp; + + gfc_init_se (&se, NULL); + gfc_init_se (&argse1, NULL); + gfc_init_se (&argse2, NULL); + gfc_start_block (&se.pre); + + gfc_conv_expr_val (&argse1, code->expr1); + gfc_conv_expr_val (&argse2, code->expr2); + team_id = fold_convert (integer_type_node, argse1.expr); + team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); + + gfc_add_block_to_block (&se.pre, &argse1.pre); + gfc_add_block_to_block (&se.pre, &argse2.pre); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_form_team, 3, + team_id, team_type, + build_int_cst (integer_type_node, 0)); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &argse1.post); + gfc_add_block_to_block (&se.pre, &argse2.post); + return gfc_finish_block (&se.pre); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +/* Translate the CHANGE TEAM statement. */ + +tree +gfc_trans_change_team (gfc_code *code) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se argse; + tree team_type, tmp; + + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_change_team, 2, team_type, + build_int_cst (integer_type_node, 0)); + gfc_add_expr_to_block (&argse.pre, tmp); + gfc_add_block_to_block (&argse.pre, &argse.post); + return gfc_finish_block (&argse.pre); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +/* Translate the END TEAM statement. */ + +tree +gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + return build_call_expr_loc (input_location, + gfor_fndecl_caf_end_team, 1, + build_int_cst (pchar_type_node, 0)); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +/* Translate the SYNC TEAM statement. */ + +tree +gfc_trans_sync_team (gfc_code *code) +{ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se argse; + tree team_type, tmp; + + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_sync_team, 2, + team_type, + build_int_cst (integer_type_node, 0)); + gfc_add_expr_to_block (&argse.pre, tmp); + gfc_add_block_to_block (&argse.pre, &argse.post); + return gfc_finish_block (&argse.pre); + } + else + { + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + } +} + +tree +gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) +{ + gfc_se se, argse; + tree stat = NULL_TREE, stat2 = NULL_TREE; + tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE; + + /* Short cut: For single images without STAT= or LOCK_ACQUIRED + return early. (ERRMSG= is always untouched for -fcoarray=single.) */ + if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB) + return NULL_TREE; + + if (code->expr2) + { + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + stat = argse.expr; + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + stat = null_pointer_node; + + if (code->expr4) + { + gcc_assert (code->expr4->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr4); + lock_acquired = argse.expr; + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + lock_acquired = null_pointer_node; + + gfc_start_block (&se.pre); + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree tmp, token, image_index, errmsg, errmsg_len; + tree index = build_zero_cst (gfc_array_index_type); + tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); + + if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED + || code->expr1->symtree->n.sym->ts.u.derived->from_intmod + != INTMOD_ISO_FORTRAN_ENV + || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id + != ISOFORTRAN_LOCK_TYPE) + { + gfc_error ("Sorry, the lock component of derived type at %L is not " + "yet supported", &code->expr1->where); + return NULL_TREE; + } + + gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE, + code->expr1); + + if (gfc_is_coindexed (code->expr1)) + image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); + else + image_index = integer_zero_node; + + /* For arrays, obtain the array index. */ + if (gfc_expr_attr (code->expr1).dimension) + { + tree desc, tmp, extent, lbound, ubound; + gfc_array_ref *ar, ar2; + int i; + + /* TODO: Extend this, once DT components are supported. */ + ar = &code->expr1->ref->u.ar; + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + + gfc_init_se (&argse, NULL); + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, code->expr1); + gfc_add_block_to_block (&se.pre, &argse.pre); + desc = argse.expr; + *ar = ar2; + + extent = build_one_cst (gfc_array_index_type); + for (i = 0; i < ar->dimen; i++) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); + gfc_add_block_to_block (&argse.pre, &argse.pre); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (lbound), argse.expr, lbound); + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), extent, tmp); + index = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (tmp), index, tmp); + if (i < ar->dimen - 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); + } + } + } + + /* errmsg. */ + if (code->expr3) + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->expr3); + gfc_add_block_to_block (&se.pre, &argse.pre); + errmsg = argse.expr; + errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + errmsg = null_pointer_node; + errmsg_len = build_zero_cst (size_type_node); + } + + if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) + { + stat2 = stat; + stat = gfc_create_var (integer_type_node, "stat"); + } + + if (lock_acquired != null_pointer_node + && TREE_TYPE (lock_acquired) != integer_type_node) + { + lock_acquired2 = lock_acquired; + lock_acquired = gfc_create_var (integer_type_node, "acquired"); + } + + index = fold_convert (size_type_node, index); + if (op == EXEC_LOCK) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, + token, index, image_index, + lock_acquired != null_pointer_node + ? gfc_build_addr_expr (NULL, lock_acquired) + : lock_acquired, + stat != null_pointer_node + ? gfc_build_addr_expr (NULL, stat) : stat, + errmsg, errmsg_len); + else + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, + token, index, image_index, + stat != null_pointer_node + ? gfc_build_addr_expr (NULL, stat) : stat, + errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + + gfc_add_expr_to_block (&se.pre, tmp); + + if (stat2 != NULL_TREE) + gfc_add_modify (&se.pre, stat2, + fold_convert (TREE_TYPE (stat2), stat)); + + if (lock_acquired2 != NULL_TREE) + gfc_add_modify (&se.pre, lock_acquired2, + fold_convert (TREE_TYPE (lock_acquired2), + lock_acquired)); + + return gfc_finish_block (&se.pre); + } + + if (stat != NULL_TREE) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); + + if (lock_acquired != NULL_TREE) + gfc_add_modify (&se.pre, lock_acquired, + fold_convert (TREE_TYPE (lock_acquired), + boolean_true_node)); + + return gfc_finish_block (&se.pre); +} + +tree +gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op) +{ + gfc_se se, argse; + tree stat = NULL_TREE, stat2 = NULL_TREE; + tree until_count = NULL_TREE; + + if (code->expr2) + { + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + stat = argse.expr; + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + stat = null_pointer_node; + + if (code->expr4) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr4); + until_count = fold_convert (integer_type_node, argse.expr); + } + else + until_count = integer_one_node; + + if (flag_coarray != GFC_FCOARRAY_LIB) + { + gfc_start_block (&se.pre); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + + if (op == EXEC_EVENT_POST) + gfc_add_modify (&se.pre, argse.expr, + fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (argse.expr), argse.expr, + build_int_cst (TREE_TYPE (argse.expr), 1))); + else + gfc_add_modify (&se.pre, argse.expr, + fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (argse.expr), argse.expr, + fold_convert (TREE_TYPE (argse.expr), + until_count))); + if (stat != NULL_TREE) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); + + return gfc_finish_block (&se.pre); + } + + gfc_start_block (&se.pre); + tree tmp, token, image_index, errmsg, errmsg_len; + tree index = build_zero_cst (gfc_array_index_type); + tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); + + if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED + || code->expr1->symtree->n.sym->ts.u.derived->from_intmod + != INTMOD_ISO_FORTRAN_ENV + || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id + != ISOFORTRAN_EVENT_TYPE) + { + gfc_error ("Sorry, the event component of derived type at %L is not " + "yet supported", &code->expr1->where); + return NULL_TREE; + } + + gfc_init_se (&argse, NULL); + gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE, + code->expr1); + gfc_add_block_to_block (&se.pre, &argse.pre); + + if (gfc_is_coindexed (code->expr1)) + image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); + else + image_index = integer_zero_node; + + /* For arrays, obtain the array index. */ + if (gfc_expr_attr (code->expr1).dimension) + { + tree desc, tmp, extent, lbound, ubound; + gfc_array_ref *ar, ar2; + int i; + + /* TODO: Extend this, once DT components are supported. */ + ar = &code->expr1->ref->u.ar; + ar2 = *ar; + memset (ar, '\0', sizeof (*ar)); + ar->as = ar2.as; + ar->type = AR_FULL; + + gfc_init_se (&argse, NULL); + argse.descriptor_only = 1; + gfc_conv_expr_descriptor (&argse, code->expr1); + gfc_add_block_to_block (&se.pre, &argse.pre); + desc = argse.expr; + *ar = ar2; + + extent = build_one_cst (gfc_array_index_type); + for (i = 0; i < ar->dimen; i++) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); + gfc_add_block_to_block (&argse.pre, &argse.pre); + lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (lbound), argse.expr, lbound); + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), extent, tmp); + index = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (tmp), index, tmp); + if (i < ar->dimen - 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); + } + } + } + + /* errmsg. */ + if (code->expr3) + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->expr3); + gfc_add_block_to_block (&se.pre, &argse.pre); + errmsg = argse.expr; + errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + errmsg = null_pointer_node; + errmsg_len = build_zero_cst (size_type_node); + } + + if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) + { + stat2 = stat; + stat = gfc_create_var (integer_type_node, "stat"); + } + + index = fold_convert (size_type_node, index); + if (op == EXEC_EVENT_POST) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6, + token, index, image_index, + stat != null_pointer_node + ? gfc_build_addr_expr (NULL, stat) : stat, + errmsg, errmsg_len); + else + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6, + token, index, until_count, + stat != null_pointer_node + ? gfc_build_addr_expr (NULL, stat) : stat, + errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&se.pre, tmp); + + if (stat2 != NULL_TREE) + gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat)); + + return gfc_finish_block (&se.pre); +} + +tree +gfc_trans_sync (gfc_code *code, gfc_exec_op type) +{ + gfc_se se, argse; + tree tmp; + tree images = NULL_TREE, stat = NULL_TREE, + errmsg = NULL_TREE, errmsglen = NULL_TREE; + + /* Short cut: For single images without bound checking or without STAT=, + return early. (ERRMSG= is always untouched for -fcoarray=single.) */ + if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && flag_coarray != GFC_FCOARRAY_LIB) + return NULL_TREE; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + if (code->expr1 && code->expr1->rank == 0) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr1); + images = argse.expr; + } + + if (code->expr2) + { + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE + || code->expr2->expr_type == EXPR_FUNCTION); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + stat = argse.expr; + } + else + stat = null_pointer_node; + + if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB) + { + gcc_assert (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_FUNCTION); + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, code->expr3); + gfc_conv_string_parameter (&argse); + errmsg = gfc_build_addr_expr (NULL, argse.expr); + errmsglen = fold_convert (size_type_node, argse.string_length); + } + else if (flag_coarray == GFC_FCOARRAY_LIB) + { + errmsg = null_pointer_node; + errmsglen = build_int_cst (size_type_node, 0); + } + + /* Check SYNC IMAGES(imageset) for valid image index. + FIXME: Add a check for image-set arrays. */ + if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && code->expr1->rank == 0) + { + tree images2 = fold_convert (integer_type_node, images); + tree cond; + if (flag_coarray != GFC_FCOARRAY_LIB) + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + images, build_int_cst (TREE_TYPE (images), 1)); + else + { + tree cond2; + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, + 2, integer_zero_node, + build_int_cst (integer_type_node, -1)); + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + images2, tmp); + cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + images, + build_int_cst (TREE_TYPE (images), 1)); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, cond, cond2); + } + gfc_trans_runtime_check (true, false, cond, &se.pre, + &code->expr1->where, "Invalid image number " + "%d in SYNC IMAGES", images2); + } + + /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the + image control statements SYNC IMAGES and SYNC ALL. */ + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&se.pre, tmp); + } + + if (flag_coarray != GFC_FCOARRAY_LIB) + { + /* Set STAT to zero. */ + if (code->expr2) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); + } + else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY) + { + /* SYNC ALL => stat == null_pointer_node + SYNC ALL(stat=s) => stat has an integer type + + If "stat" has the wrong integer type, use a temp variable of + the right type and later cast the result back into "stat". */ + if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) + { + if (TREE_TYPE (stat) == integer_type_node) + stat = gfc_build_addr_expr (NULL, stat); + + if(type == EXEC_SYNC_MEMORY) + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory, + 3, stat, errmsg, errmsglen); + else + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, stat, errmsg, errmsglen); + + gfc_add_expr_to_block (&se.pre, tmp); + } + else + { + tree tmp_stat = gfc_create_var (integer_type_node, "stat"); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, gfc_build_addr_expr (NULL, tmp_stat), + errmsg, errmsglen); + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_modify (&se.pre, stat, + fold_convert (TREE_TYPE (stat), tmp_stat)); + } + } + else + { + tree len; + + gcc_assert (type == EXEC_SYNC_IMAGES); + + if (!code->expr1) + { + len = build_int_cst (integer_type_node, -1); + images = null_pointer_node; + } + else if (code->expr1->rank == 0) + { + len = build_int_cst (integer_type_node, 1); + images = gfc_build_addr_expr (NULL_TREE, images); + } + else + { + /* FIXME. */ + if (code->expr1->ts.kind != gfc_c_int_kind) + gfc_fatal_error ("Sorry, only support for integer kind %d " + "implemented for image-set at %L", + gfc_c_int_kind, &code->expr1->where); + + gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len); + images = se.expr; + + tmp = gfc_typenode_for_spec (&code->expr1->ts); + if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp)) + tmp = gfc_get_element_type (tmp); + + len = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + TREE_TYPE (len), len, + fold_convert (TREE_TYPE (len), + TYPE_SIZE_UNIT (tmp))); + len = fold_convert (integer_type_node, len); + } + + /* SYNC IMAGES(imgs) => stat == null_pointer_node + SYNC IMAGES(imgs,stat=s) => stat has an integer type + + If "stat" has the wrong integer type, use a temp variable of + the right type and later cast the result back into "stat". */ + if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) + { + if (TREE_TYPE (stat) == integer_type_node) + stat = gfc_build_addr_expr (NULL, stat); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, + 5, fold_convert (integer_type_node, len), + images, stat, errmsg, errmsglen); + gfc_add_expr_to_block (&se.pre, tmp); + } + else + { + tree tmp_stat = gfc_create_var (integer_type_node, "stat"); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, + 5, fold_convert (integer_type_node, len), + images, gfc_build_addr_expr (NULL, tmp_stat), + errmsg, errmsglen); + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_modify (&se.pre, stat, + fold_convert (TREE_TYPE (stat), tmp_stat)); + } + } + + return gfc_finish_block (&se.pre); +} + + +/* Generate GENERIC for the IF construct. This function also deals with + the simple IF statement, because the front end translates the IF + statement into an IF construct. + + We translate: + + IF (cond) THEN + then_clause + ELSEIF (cond2) + elseif_clause + ELSE + else_clause + ENDIF + + into: + + pre_cond_s; + if (cond_s) + { + then_clause; + } + else + { + pre_cond_s + if (cond_s) + { + elseif_clause + } + else + { + else_clause; + } + } + + where COND_S is the simplified version of the predicate. PRE_COND_S + are the pre side-effects produced by the translation of the + conditional. + We need to build the chain recursively otherwise we run into + problems with folding incomplete statements. */ + +static tree +gfc_trans_if_1 (gfc_code * code) +{ + gfc_se if_se; + tree stmt, elsestmt; + locus saved_loc; + location_t loc; + + /* Check for an unconditional ELSE clause. */ + if (!code->expr1) + return gfc_trans_code (code->next); + + /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ + gfc_init_se (&if_se, NULL); + gfc_start_block (&if_se.pre); + + /* Calculate the IF condition expression. */ + if (code->expr1->where.lb) + { + gfc_save_backend_locus (&saved_loc); + gfc_set_backend_locus (&code->expr1->where); + } + + gfc_conv_expr_val (&if_se, code->expr1); + + if (code->expr1->where.lb) + gfc_restore_backend_locus (&saved_loc); + + /* Translate the THEN clause. */ + stmt = gfc_trans_code (code->next); + + /* Translate the ELSE clause. */ + if (code->block) + elsestmt = gfc_trans_if_1 (code->block); + else + elsestmt = build_empty_stmt (input_location); + + /* Build the condition expression and add it to the condition block. */ + loc = code->expr1->where.lb ? gfc_get_location (&code->expr1->where) + : input_location; + stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt, + elsestmt); + + gfc_add_expr_to_block (&if_se.pre, stmt); + + /* Finish off this statement. */ + return gfc_finish_block (&if_se.pre); +} + +tree +gfc_trans_if (gfc_code * code) +{ + stmtblock_t body; + tree exit_label; + + /* Create exit label so it is available for trans'ing the body code. */ + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + + /* Translate the actual code in code->block. */ + gfc_init_block (&body); + gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block)); + + /* Add exit label. */ + gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); + + return gfc_finish_block (&body); +} + + +/* Translate an arithmetic IF expression. + + IF (cond) label1, label2, label3 translates to + + if (cond <= 0) + { + if (cond < 0) + goto label1; + else // cond == 0 + goto label2; + } + else // cond > 0 + goto label3; + + An optimized version can be generated in case of equal labels. + E.g., if label1 is equal to label2, we can translate it to + + if (cond <= 0) + goto label1; + else + goto label3; +*/ + +tree +gfc_trans_arithmetic_if (gfc_code * code) +{ + gfc_se se; + tree tmp; + tree branch1; + tree branch2; + tree zero; + + /* Start a new block. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + /* Pre-evaluate COND. */ + gfc_conv_expr_val (&se, code->expr1); + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* Build something to compare with. */ + zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); + + if (code->label1->value != code->label2->value) + { + /* If (cond < 0) take branch1 else take branch2. + First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ + branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); + branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); + + if (code->label1->value != code->label3->value) + tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node, + se.expr, zero); + else + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se.expr, zero); + + branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, branch1, branch2); + } + else + branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); + + if (code->label1->value != code->label3->value + && code->label2->value != code->label3->value) + { + /* if (cond <= 0) take branch1 else take branch2. */ + branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + se.expr, zero); + branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, + tmp, branch1, branch2); + } + + /* Append the COND_EXPR to the evaluation of COND, and return. */ + gfc_add_expr_to_block (&se.pre, branch1); + return gfc_finish_block (&se.pre); +} + + +/* Translate a CRITICAL block. */ +tree +gfc_trans_critical (gfc_code *code) +{ + stmtblock_t block; + tree tmp, token = NULL_TREE; + + gfc_start_block (&block); + + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree zero_size = build_zero_cst (size_type_node); + token = gfc_get_symbol_decl (code->resolved_sym); + token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, + token, zero_size, integer_one_node, + null_pointer_node, null_pointer_node, + null_pointer_node, zero_size); + gfc_add_expr_to_block (&block, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), + NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), + NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + + gfc_add_expr_to_block (&block, tmp); + } + + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&block, tmp); + + if (flag_coarray == GFC_FCOARRAY_LIB) + { + tree zero_size = build_zero_cst (size_type_node); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, + token, zero_size, integer_one_node, + null_pointer_node, null_pointer_node, + zero_size); + gfc_add_expr_to_block (&block, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), + NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), + NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + + gfc_add_expr_to_block (&block, tmp); + } + + return gfc_finish_block (&block); +} + + +/* Return true, when the class has a _len component. */ + +static bool +class_has_len_component (gfc_symbol *sym) +{ + gfc_component *comp = sym->ts.u.derived->components; + while (comp) + { + if (strcmp (comp->name, "_len") == 0) + return true; + comp = comp->next; + } + return false; +} + + +static void +copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank) +{ + int n; + tree dim; + tree tmp; + tree tmp2; + tree size; + tree offset; + + offset = gfc_index_zero_node; + + /* Use memcpy to copy the descriptor. The size is the minimum of + the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */ + tmp = TYPE_SIZE_UNIT (TREE_TYPE (src)); + tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst)); + size = fold_build2_loc (input_location, MIN_EXPR, + TREE_TYPE (tmp), tmp, tmp2); + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, + gfc_build_addr_expr (NULL_TREE, dst), + gfc_build_addr_expr (NULL_TREE, src), + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (block, tmp); + + /* Set the offset correctly. */ + for (n = 0; n < rank; n++) + { + dim = gfc_rank_cst[n]; + tmp = gfc_conv_descriptor_lbound_get (src, dim); + tmp2 = gfc_conv_descriptor_stride_get (src, dim); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), + tmp, tmp2); + offset = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (offset), offset, tmp); + offset = gfc_evaluate_now (offset, block); + } + + gfc_conv_descriptor_offset_set (block, dst, offset); +} + + +/* Do proper initialization for ASSOCIATE names. */ + +static void +trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) +{ + gfc_expr *e; + tree tmp; + bool class_target; + bool unlimited; + tree desc; + tree offset; + tree dim; + int n; + tree charlen; + bool need_len_assign; + bool whole_array = true; + gfc_ref *ref; + gfc_symbol *sym2; + + gcc_assert (sym->assoc); + e = sym->assoc->target; + + class_target = (e->expr_type == EXPR_VARIABLE) + && (gfc_is_class_scalar_expr (e) + || gfc_is_class_array_ref (e, NULL)); + + unlimited = UNLIMITED_POLY (e); + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && ref->u.ar.type == AR_FULL + && ref->next) + { + whole_array = false; + break; + } + + /* Assignments to the string length need to be generated, when + ( sym is a char array or + sym has a _len component) + and the associated expression is unlimited polymorphic, which is + not (yet) correctly in 'unlimited', because for an already associated + BT_DERIVED the u-poly flag is not set, i.e., + __tmp_CHARACTER_0_1 => w => arg + ^ generated temp ^ from code, the w does not have the u-poly + flag set, where UNLIMITED_POLY(e) expects it. */ + need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED + && e->ts.u.derived->attr.unlimited_polymorphic)) + && (sym->ts.type == BT_CHARACTER + || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED) + && class_has_len_component (sym))) + && !sym->attr.select_rank_temporary); + + /* Do a `pointer assignment' with updated descriptor (or assign descriptor + to array temporary) for arrays with either unknown shape or if associating + to a variable. Select rank temporaries need somewhat different treatment + to other associate names and case temporaries. This because the selector + is assumed rank and so the offset in particular has to be changed. Also, + the case temporaries carry both allocatable and target attributes if + present in the selector. This means that an allocatation or change of + association can occur and so has to be dealt with. */ + if (sym->attr.select_rank_temporary) + { + gfc_se se; + tree class_decl = NULL_TREE; + int rank = 0; + bool class_ptr; + + sym2 = e->symtree->n.sym; + gfc_init_se (&se, NULL); + if (e->ts.type == BT_CLASS) + { + /* Go straight to the class data. */ + if (sym2->attr.dummy && !sym2->attr.optional) + { + class_decl = sym2->backend_decl; + if (DECL_LANG_SPECIFIC (class_decl) + && GFC_DECL_SAVED_DESCRIPTOR (class_decl)) + class_decl = GFC_DECL_SAVED_DESCRIPTOR (class_decl); + if (POINTER_TYPE_P (TREE_TYPE (class_decl))) + class_decl = build_fold_indirect_ref_loc (input_location, + class_decl); + gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl))); + se.expr = gfc_class_data_get (class_decl); + } + else + { + class_decl = sym2->backend_decl; + gfc_conv_expr_descriptor (&se, e); + if (POINTER_TYPE_P (TREE_TYPE (se.expr))) + se.expr = build_fold_indirect_ref_loc (input_location, + se.expr); + } + + if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0) + rank = CLASS_DATA (sym)->as->rank; + } + else + { + gfc_conv_expr_descriptor (&se, e); + if (sym->as && sym->as->rank > 0) + rank = sym->as->rank; + } + + desc = sym->backend_decl; + + /* The SELECT TYPE mechanisms turn class temporaries into pointers, which + point to the selector. */ + class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc)); + if (class_ptr) + { + tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class"); + tmp = gfc_build_addr_expr (NULL, tmp); + gfc_add_modify (&se.pre, desc, tmp); + + tmp = gfc_class_vptr_get (class_decl); + gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp); + if (UNLIMITED_POLY (sym)) + gfc_add_modify (&se.pre, gfc_class_len_get (desc), + gfc_class_len_get (class_decl)); + + desc = gfc_class_data_get (desc); + } + + /* SELECT RANK temporaries can carry the allocatable and pointer + attributes so the selector descriptor must be copied in and + copied out. */ + if (rank > 0) + copy_descriptor (&se.pre, desc, se.expr, rank); + else + { + tmp = gfc_conv_descriptor_data_get (se.expr); + gfc_add_modify (&se.pre, desc, + fold_convert (TREE_TYPE (desc), tmp)); + } + + /* Deal with associate_name => selector. Class associate names are + treated in the same way as in SELECT TYPE. */ + sym2 = sym->assoc->target->symtree->n.sym; + if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS) + { + sym2 = sym2->assoc->target->symtree->n.sym; + se.expr = sym2->backend_decl; + + if (POINTER_TYPE_P (TREE_TYPE (se.expr))) + se.expr = build_fold_indirect_ref_loc (input_location, + se.expr); + } + + /* There could have been reallocation. Copy descriptor back to the + selector and update the offset. */ + if (sym->attr.allocatable || sym->attr.pointer + || (sym->ts.type == BT_CLASS + && (CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.pointer))) + { + if (rank > 0) + copy_descriptor (&se.post, se.expr, desc, rank); + else + gfc_conv_descriptor_data_set (&se.post, se.expr, desc); + + /* The dynamic type could have changed too. */ + if (sym->ts.type == BT_CLASS) + { + tmp = sym->backend_decl; + if (class_ptr) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl), + gfc_class_vptr_get (tmp)); + if (UNLIMITED_POLY (sym)) + gfc_add_modify (&se.post, gfc_class_len_get (class_decl), + gfc_class_len_get (tmp)); + } + } + + tmp = gfc_finish_block (&se.post); + + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp); + } + /* Now all the other kinds of associate variable. */ + else if (sym->attr.dimension && !class_target + && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) + { + gfc_se se; + tree desc; + bool cst_array_ctor; + + desc = sym->backend_decl; + cst_array_ctor = e->expr_type == EXPR_ARRAY + && gfc_constant_array_constructor_p (e->value.constructor) + && e->ts.type != BT_CHARACTER; + + /* If association is to an expression, evaluate it and create temporary. + Otherwise, get descriptor of target for pointer assignment. */ + gfc_init_se (&se, NULL); + + if (sym->assoc->variable || cst_array_ctor) + { + se.direct_byref = 1; + se.use_offset = 1; + se.expr = desc; + GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; + } + + gfc_conv_expr_descriptor (&se, e); + + if (sym->ts.type == BT_CHARACTER + && !se.direct_byref && sym->ts.deferred + && !sym->attr.select_type_temporary + && VAR_P (sym->ts.u.cl->backend_decl) + && se.string_length != sym->ts.u.cl->backend_decl) + { + gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, + fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), + se.string_length)); + } + + /* If we didn't already do the pointer assignment, set associate-name + descriptor to the one generated for the temporary. */ + if ((!sym->assoc->variable && !cst_array_ctor) + || !whole_array) + { + int dim; + + if (whole_array) + gfc_add_modify (&se.pre, desc, se.expr); + + /* The generated descriptor has lower bound zero (as array + temporary), shift bounds so we get lower bounds of 1. */ + for (dim = 0; dim < e->rank; ++dim) + gfc_conv_shift_descriptor_lbound (&se.pre, desc, + dim, gfc_index_one_node); + } + + /* If this is a subreference array pointer associate name use the + associate variable element size for the value of 'span'. */ + if (sym->attr.subref_array_pointer && !se.direct_byref) + { + gcc_assert (e->expr_type == EXPR_VARIABLE); + tmp = gfc_get_array_span (se.expr, e); + + gfc_conv_descriptor_span_set (&se.pre, desc, tmp); + } + + if (e->expr_type == EXPR_FUNCTION + && sym->ts.type == BT_DERIVED + && sym->ts.u.derived + && sym->ts.u.derived->attr.pdt_type) + { + tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr, + sym->as->rank); + gfc_add_expr_to_block (&se.post, tmp); + } + + /* Done, register stuff as init / cleanup code. */ + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), + gfc_finish_block (&se.post)); + } + + /* Temporaries, arising from TYPE IS, just need the descriptor of class + arrays to be assigned directly. */ + else if (class_target && sym->attr.dimension + && (sym->ts.type == BT_DERIVED || unlimited)) + { + gfc_se se; + + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + /* In a select type the (temporary) associate variable shall point to + a standard fortran array (lower bound == 1), but conv_expr () + just maps to the input array in the class object, whose lbound may + be arbitrary. conv_expr_descriptor solves this by inserting a + temporary array descriptor. */ + gfc_conv_expr_descriptor (&se, e); + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) + || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); + + if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))) + { + if (INDIRECT_REF_P (se.expr)) + tmp = TREE_OPERAND (se.expr, 0); + else + tmp = se.expr; + + gfc_add_modify (&se.pre, sym->backend_decl, + gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp))); + } + else + gfc_add_modify (&se.pre, sym->backend_decl, se.expr); + + if (unlimited) + { + /* Recover the dtype, which has been overwritten by the + assignment from an unlimited polymorphic object. */ + tmp = gfc_conv_descriptor_dtype (sym->backend_decl); + gfc_add_modify (&se.pre, tmp, + gfc_get_dtype (TREE_TYPE (sym->backend_decl))); + } + + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a scalar pointer assignment; this is for scalar variable targets. */ + else if (gfc_is_associate_pointer (sym)) + { + gfc_se se; + + gcc_assert (!sym->attr.dimension); + + gfc_init_se (&se, NULL); + + /* Class associate-names come this way because they are + unconditionally associate pointers and the symbol is scalar. */ + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) + { + tree target_expr; + /* For a class array we need a descriptor for the selector. */ + gfc_conv_expr_descriptor (&se, e); + /* Needed to get/set the _len component below. */ + target_expr = se.expr; + + /* Obtain a temporary class container for the result. */ + gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false); + se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + + /* Set the offset. */ + desc = gfc_class_data_get (se.expr); + offset = gfc_index_zero_node; + for (n = 0; n < e->rank; n++) + { + dim = gfc_rank_cst[n]; + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + gfc_conv_descriptor_stride_get (desc, dim), + gfc_conv_descriptor_lbound_get (desc, dim)); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, tmp); + } + if (need_len_assign) + { + if (e->symtree + && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl) + && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl) + && TREE_CODE (target_expr) != COMPONENT_REF) + /* Use the original class descriptor stored in the saved + descriptor to get the target_expr. */ + target_expr = + GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl); + else + /* Strip the _data component from the target_expr. */ + target_expr = TREE_OPERAND (target_expr, 0); + /* Add a reference to the _len comp to the target expr. */ + tmp = gfc_class_len_get (target_expr); + /* Get the component-ref for the temp structure's _len comp. */ + charlen = gfc_class_len_get (se.expr); + /* Add the assign to the beginning of the block... */ + gfc_add_modify (&se.pre, charlen, + fold_convert (TREE_TYPE (charlen), tmp)); + /* and the oposite way at the end of the block, to hand changes + on the string length back. */ + gfc_add_modify (&se.post, tmp, + fold_convert (TREE_TYPE (tmp), charlen)); + /* Length assignment done, prevent adding it again below. */ + need_len_assign = false; + } + gfc_conv_descriptor_offset_set (&se.pre, desc, offset); + } + else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.dimension) + { + /* This is bound to be a class array element. */ + gfc_conv_expr_reference (&se, e); + /* Get the _vptr component of the class object. */ + tmp = gfc_get_vptr_from_expr (se.expr); + /* Obtain a temporary class container for the result. */ + gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false); + se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + need_len_assign = false; + } + else + { + /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign, + which has the string length included. For CHARACTERS it is still + needed and will be done at the end of this routine. */ + gfc_conv_expr (&se, e); + need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER; + } + + if (sym->ts.type == BT_CHARACTER + && !sym->attr.select_type_temporary + && VAR_P (sym->ts.u.cl->backend_decl) + && se.string_length != sym->ts.u.cl->backend_decl) + { + gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, + fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), + se.string_length)); + if (e->expr_type == EXPR_FUNCTION) + { + tmp = gfc_call_free (sym->backend_decl); + gfc_add_expr_to_block (&se.post, tmp); + } + } + + if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER + && POINTER_TYPE_P (TREE_TYPE (se.expr))) + { + /* These are pointer types already. */ + tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr); + } + else + { + tree ctree = gfc_get_class_from_expr (se.expr); + tmp = TREE_TYPE (sym->backend_decl); + + /* Coarray scalar component expressions can emerge from + the front end as array elements of the _data field. */ + if (sym->ts.type == BT_CLASS + && e->ts.type == BT_CLASS && e->rank == 0 + && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree) + { + tree stmp; + tree dtmp; + + se.expr = ctree; + dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl)); + ctree = gfc_create_var (dtmp, "class"); + + stmp = gfc_class_data_get (se.expr); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))); + + /* Set the fields of the target class variable. */ + stmp = gfc_conv_descriptor_data_get (stmp); + dtmp = gfc_class_data_get (ctree); + stmp = fold_convert (TREE_TYPE (dtmp), stmp); + gfc_add_modify (&se.pre, dtmp, stmp); + stmp = gfc_class_vptr_get (se.expr); + dtmp = gfc_class_vptr_get (ctree); + stmp = fold_convert (TREE_TYPE (dtmp), stmp); + gfc_add_modify (&se.pre, dtmp, stmp); + if (UNLIMITED_POLY (sym)) + { + stmp = gfc_class_len_get (se.expr); + dtmp = gfc_class_len_get (ctree); + stmp = fold_convert (TREE_TYPE (dtmp), stmp); + gfc_add_modify (&se.pre, dtmp, stmp); + } + se.expr = ctree; + } + tmp = gfc_build_addr_expr (tmp, se.expr); + } + + gfc_add_modify (&se.pre, sym->backend_decl, tmp); + + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_finish_block (&se.post)); + } + + /* Do a simple assignment. This is for scalar expressions, where we + can simply use expression assignment. */ + else + { + gfc_expr *lhs; + tree res; + gfc_se se; + + gfc_init_se (&se, NULL); + + /* resolve.c converts some associate names to allocatable so that + allocation can take place automatically in gfc_trans_assignment. + The frontend prevents them from being either allocated, + deallocated or reallocated. */ + if (sym->attr.allocatable) + { + tmp = sym->backend_decl; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } + + lhs = gfc_lval_expr_from_sym (sym); + res = gfc_trans_assignment (lhs, e, false, true); + gfc_add_expr_to_block (&se.pre, res); + + tmp = sym->backend_decl; + if (e->expr_type == EXPR_FUNCTION + && sym->ts.type == BT_DERIVED + && sym->ts.u.derived + && sym->ts.u.derived->attr.pdt_type) + { + tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp, + 0); + } + else if (e->expr_type == EXPR_FUNCTION + && sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived + && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) + { + tmp = gfc_class_data_get (tmp); + tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived, + tmp, 0); + } + else if (sym->attr.allocatable) + { + tmp = sym->backend_decl; + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + tmp = gfc_conv_descriptor_data_get (tmp); + + /* A simple call to free suffices here. */ + tmp = gfc_call_free (tmp); + + /* Make sure that reallocation on assignment cannot occur. */ + sym->attr.allocatable = 0; + } + else + tmp = NULL_TREE; + + res = gfc_finish_block (&se.pre); + gfc_add_init_cleanup (block, res, tmp); + gfc_free_expr (lhs); + } + + /* Set the stringlength, when needed. */ + if (need_len_assign) + { + gfc_se se; + gfc_init_se (&se, NULL); + if (e->symtree->n.sym->ts.type == BT_CHARACTER) + { + /* Deferred strings are dealt with in the preceeding. */ + gcc_assert (!e->symtree->n.sym->ts.deferred); + tmp = e->symtree->n.sym->ts.u.cl->backend_decl; + } + else if (e->symtree->n.sym->attr.function + && e->symtree->n.sym == e->symtree->n.sym->result) + { + tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); + tmp = gfc_class_len_get (tmp); + } + else + tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym)); + gfc_get_symbol_decl (sym); + charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl + : gfc_class_len_get (sym->backend_decl); + /* Prevent adding a noop len= len. */ + if (tmp != charlen) + { + gfc_add_modify (&se.pre, charlen, + fold_convert (TREE_TYPE (charlen), tmp)); + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), + gfc_finish_block (&se.post)); + } + } +} + + +/* Translate a BLOCK construct. This is basically what we would do for a + procedure body. */ + +tree +gfc_trans_block_construct (gfc_code* code) +{ + gfc_namespace* ns; + gfc_symbol* sym; + gfc_wrapped_block block; + tree exit_label; + stmtblock_t body; + gfc_association_list *ass; + + ns = code->ext.block.ns; + gcc_assert (ns); + sym = ns->proc_name; + gcc_assert (sym); + + /* Process local variables. */ + gcc_assert (!sym->tlink); + sym->tlink = sym; + gfc_process_block_locals (ns); + + /* Generate code including exit-label. */ + gfc_init_block (&body); + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + + finish_oacc_declare (ns, sym, true); + + gfc_add_expr_to_block (&body, gfc_trans_code (ns->code)); + gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); + + /* Finish everything. */ + gfc_start_wrapped_block (&block, gfc_finish_block (&body)); + gfc_trans_deferred_vars (sym, &block); + for (ass = code->ext.block.assoc; ass; ass = ass->next) + trans_associate_var (ass->st->n.sym, &block); + + return gfc_finish_wrapped_block (&block); +} + +/* Translate the simple DO construct in a C-style manner. + This is where the loop variable has integer type and step +-1. + Following code will generate infinite loop in case where TO is INT_MAX + (for +1 step) or INT_MIN (for -1 step) + + We translate a do loop from: + + DO dovar = from, to, step + body + END DO + + to: + + [Evaluate loop bounds and step] + dovar = from; + for (;;) + { + if (dovar > to) + goto end_label; + body; + cycle_label: + dovar += step; + } + end_label: + + This helps the optimizers by avoiding the extra pre-header condition and + we save a register as we just compare the updated IV (not a value in + previous step). */ + +static tree +gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, + tree from, tree to, tree step, tree exit_cond) +{ + stmtblock_t body; + tree type; + tree cond; + tree tmp; + tree saved_dovar = NULL; + tree cycle_label; + tree exit_label; + location_t loc; + type = TREE_TYPE (dovar); + bool is_step_positive = tree_int_cst_sgn (step) > 0; + + loc = gfc_get_location (&code->ext.iterator->start->where); + + /* Initialize the DO variable: dovar = from. */ + gfc_add_modify_loc (loc, pblock, dovar, + fold_convert (TREE_TYPE (dovar), from)); + + /* Save value for do-tinkering checking. */ + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + { + saved_dovar = gfc_create_var (type, ".saved_dovar"); + gfc_add_modify_loc (loc, pblock, saved_dovar, dovar); + } + + /* Cycle and exit statements are implemented with gotos. */ + cycle_label = gfc_build_label_decl (NULL_TREE); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Put the labels where they can be found later. See gfc_trans_do(). */ + code->cycle_label = cycle_label; + code->exit_label = exit_label; + + /* Loop body. */ + gfc_start_block (&body); + + /* Exit the loop if there is an I/O result condition or error. */ + if (exit_cond) + { + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, + exit_cond, tmp, + build_empty_stmt (loc)); + gfc_add_expr_to_block (&body, tmp); + } + + /* Evaluate the loop condition. */ + if (is_step_positive) + cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar, + fold_convert (type, to)); + else + cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar, + fold_convert (type, to)); + + cond = gfc_evaluate_now_loc (loc, cond, &body); + if (code->ext.iterator->unroll && cond != error_mark_node) + cond + = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_unroll_kind), + build_int_cst (integer_type_node, code->ext.iterator->unroll)); + + if (code->ext.iterator->ivdep && cond != error_mark_node) + cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_ivdep_kind), + integer_zero_node); + if (code->ext.iterator->vector && cond != error_mark_node) + cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_vector_kind), + integer_zero_node); + if (code->ext.iterator->novector && cond != error_mark_node) + cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_no_vector_kind), + integer_zero_node); + + /* The loop exit. */ + tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); + TREE_USED (exit_label) = 1; + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (loc)); + gfc_add_expr_to_block (&body, tmp); + + /* Check whether the induction variable is equal to INT_MAX + (respectively to INT_MIN). */ + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + { + tree boundary = is_step_positive ? TYPE_MAX_VALUE (type) + : TYPE_MIN_VALUE (type); + + tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node, + dovar, boundary); + gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, + "Loop iterates infinitely"); + } + + /* Main loop body. */ + tmp = gfc_trans_code_cond (code->block->next, exit_cond); + gfc_add_expr_to_block (&body, tmp); + + /* Label for cycle statements (if needed). */ + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Check whether someone has modified the loop variable. */ + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + { + tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, + dovar, saved_dovar); + gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, + "Loop variable has been modified"); + } + + /* Increment the loop variable. */ + tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); + gfc_add_modify_loc (loc, &body, dovar, tmp); + + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + gfc_add_modify_loc (loc, &body, saved_dovar, dovar); + + /* Finish the loop body. */ + tmp = gfc_finish_block (&body); + tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); + + gfc_add_expr_to_block (pblock, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (pblock, tmp); + + return gfc_finish_block (pblock); +} + +/* Translate the DO construct. This obviously is one of the most + important ones to get right with any compiler, but especially + so for Fortran. + + We special case some loop forms as described in gfc_trans_simple_do. + For other cases we implement them with a separate loop count, + as described in the standard. + + We translate a do loop from: + + DO dovar = from, to, step + body + END DO + + to: + + [evaluate loop bounds and step] + empty = (step > 0 ? to < from : to > from); + countm1 = (to - from) / step; + dovar = from; + if (empty) goto exit_label; + for (;;) + { + body; +cycle_label: + dovar += step + countm1t = countm1; + countm1--; + if (countm1t == 0) goto exit_label; + } +exit_label: + + countm1 is an unsigned integer. It is equal to the loop count minus one, + because the loop count itself can overflow. */ + +tree +gfc_trans_do (gfc_code * code, tree exit_cond) +{ + gfc_se se; + tree dovar; + tree saved_dovar = NULL; + tree from; + tree to; + tree step; + tree countm1; + tree type; + tree utype; + tree cond; + tree cycle_label; + tree exit_label; + tree tmp; + stmtblock_t block; + stmtblock_t body; + location_t loc; + + gfc_start_block (&block); + + loc = gfc_get_location (&code->ext.iterator->start->where); + + /* Evaluate all the expressions in the iterator. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->ext.iterator->var); + gfc_add_block_to_block (&block, &se.pre); + dovar = se.expr; + type = TREE_TYPE (dovar); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->start); + gfc_add_block_to_block (&block, &se.pre); + from = gfc_evaluate_now (se.expr, &block); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->end); + gfc_add_block_to_block (&block, &se.pre); + to = gfc_evaluate_now (se.expr, &block); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->ext.iterator->step); + gfc_add_block_to_block (&block, &se.pre); + step = gfc_evaluate_now (se.expr, &block); + + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + { + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step, + build_zero_cst (type)); + gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, + "DO step value is zero"); + } + + /* Special case simple loops. */ + if (TREE_CODE (type) == INTEGER_TYPE + && (integer_onep (step) + || tree_int_cst_equal (step, integer_minus_one_node))) + return gfc_trans_simple_do (code, &block, dovar, from, to, step, + exit_cond); + + if (TREE_CODE (type) == INTEGER_TYPE) + utype = unsigned_type_for (type); + else + utype = unsigned_type_for (gfc_array_index_type); + countm1 = gfc_create_var (utype, "countm1"); + + /* Cycle and exit statements are implemented with gotos. */ + cycle_label = gfc_build_label_decl (NULL_TREE); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + /* Put these labels where they can be found later. */ + code->cycle_label = cycle_label; + code->exit_label = exit_label; + + /* Initialize the DO variable: dovar = from. */ + gfc_add_modify (&block, dovar, from); + + /* Save value for do-tinkering checking. */ + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + { + saved_dovar = gfc_create_var (type, ".saved_dovar"); + gfc_add_modify_loc (loc, &block, saved_dovar, dovar); + } + + /* Initialize loop count and jump to exit label if the loop is empty. + This code is executed before we enter the loop body. We generate: + if (step > 0) + { + countm1 = (to - from) / step; + if (to < from) + goto exit_label; + } + else + { + countm1 = (from - to) / -step; + if (to > from) + goto exit_label; + } + */ + + if (TREE_CODE (type) == INTEGER_TYPE) + { + tree pos, neg, tou, fromu, stepu, tmp2; + + /* The distance from FROM to TO cannot always be represented in a signed + type, thus use unsigned arithmetic, also to avoid any undefined + overflow issues. */ + tou = fold_convert (utype, to); + fromu = fold_convert (utype, from); + stepu = fold_convert (utype, step); + + /* For a positive step, when to < from, exit, otherwise compute + countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */ + tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from); + tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, + fold_build2_loc (loc, MINUS_EXPR, utype, + tou, fromu), + stepu); + pos = build2 (COMPOUND_EXPR, void_type_node, + fold_build2 (MODIFY_EXPR, void_type_node, + countm1, tmp2), + build3_loc (loc, COND_EXPR, void_type_node, + gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), + build1_loc (loc, GOTO_EXPR, void_type_node, + exit_label), NULL_TREE)); + + /* For a negative step, when to > from, exit, otherwise compute + countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */ + tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from); + tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, + fold_build2_loc (loc, MINUS_EXPR, utype, + fromu, tou), + fold_build1_loc (loc, NEGATE_EXPR, utype, stepu)); + neg = build2 (COMPOUND_EXPR, void_type_node, + fold_build2 (MODIFY_EXPR, void_type_node, + countm1, tmp2), + build3_loc (loc, COND_EXPR, void_type_node, + gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), + build1_loc (loc, GOTO_EXPR, void_type_node, + exit_label), NULL_TREE)); + + tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step, + build_int_cst (TREE_TYPE (step), 0)); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos); + + gfc_add_expr_to_block (&block, tmp); + } + else + { + tree pos_step; + + /* TODO: We could use the same width as the real type. + This would probably cause more problems that it solves + when we implement "long double" types. */ + + tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from); + tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step); + tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp); + gfc_add_modify (&block, countm1, tmp); + + /* We need a special check for empty loops: + empty = (step > 0 ? to < from : to > from); */ + pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step, + build_zero_cst (type)); + tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step, + fold_build2_loc (loc, LT_EXPR, + logical_type_node, to, from), + fold_build2_loc (loc, GT_EXPR, + logical_type_node, to, from)); + /* If the loop is empty, go directly to the exit label. */ + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, + build1_v (GOTO_EXPR, exit_label), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + + /* Loop body. */ + gfc_start_block (&body); + + /* Main loop body. */ + tmp = gfc_trans_code_cond (code->block->next, exit_cond); + gfc_add_expr_to_block (&body, tmp); + + /* Label for cycle statements (if needed). */ + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Check whether someone has modified the loop variable. */ + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + { + tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar, + saved_dovar); + gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, + "Loop variable has been modified"); + } + + /* Exit the loop if there is an I/O result condition or error. */ + if (exit_cond) + { + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, + exit_cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + } + + /* Increment the loop variable. */ + tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); + gfc_add_modify_loc (loc, &body, dovar, tmp); + + if (gfc_option.rtcheck & GFC_RTCHECK_DO) + gfc_add_modify_loc (loc, &body, saved_dovar, dovar); + + /* Initialize countm1t. */ + tree countm1t = gfc_create_var (utype, "countm1t"); + gfc_add_modify_loc (loc, &body, countm1t, countm1); + + /* Decrement the loop count. */ + tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1, + build_int_cst (utype, 1)); + gfc_add_modify_loc (loc, &body, countm1, tmp); + + /* End with the loop condition. Loop until countm1t == 0. */ + cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t, + build_int_cst (utype, 0)); + if (code->ext.iterator->unroll && cond != error_mark_node) + cond + = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_unroll_kind), + build_int_cst (integer_type_node, code->ext.iterator->unroll)); + + if (code->ext.iterator->ivdep && cond != error_mark_node) + cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_ivdep_kind), + integer_zero_node); + if (code->ext.iterator->vector && cond != error_mark_node) + cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_vector_kind), + integer_zero_node); + if (code->ext.iterator->novector && cond != error_mark_node) + cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, annot_expr_no_vector_kind), + integer_zero_node); + + tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); + tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (loc)); + gfc_add_expr_to_block (&body, tmp); + + /* End of loop body. */ + tmp = gfc_finish_block (&body); + + /* The for loop itself. */ + tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate the DO WHILE construct. + + We translate + + DO WHILE (cond) + body + END DO + + to: + + for ( ; ; ) + { + pre_cond; + if (! cond) goto exit_label; + body; +cycle_label: + } +exit_label: + + Because the evaluation of the exit condition `cond' may have side + effects, we can't do much for empty loop bodies. The backend optimizers + should be smart enough to eliminate any dead loops. */ + +tree +gfc_trans_do_while (gfc_code * code) +{ + gfc_se cond; + tree tmp; + tree cycle_label; + tree exit_label; + stmtblock_t block; + + /* Everything we build here is part of the loop body. */ + gfc_start_block (&block); + + /* Cycle and exit statements are implemented with gotos. */ + cycle_label = gfc_build_label_decl (NULL_TREE); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Put the labels where they can be found later. See gfc_trans_do(). */ + code->cycle_label = cycle_label; + code->exit_label = exit_label; + + /* Create a GIMPLE version of the exit condition. */ + gfc_init_se (&cond, NULL); + gfc_conv_expr_val (&cond, code->expr1); + gfc_add_block_to_block (&block, &cond.pre); + cond.expr = fold_build1_loc (gfc_get_location (&code->expr1->where), + TRUTH_NOT_EXPR, TREE_TYPE (cond.expr), + cond.expr); + + /* Build "IF (! cond) GOTO exit_label". */ + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = fold_build3_loc (gfc_get_location (&code->expr1->where), COND_EXPR, + void_type_node, cond.expr, tmp, + build_empty_stmt (gfc_get_location ( + &code->expr1->where))); + gfc_add_expr_to_block (&block, tmp); + + /* The main body of the loop. */ + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&block, tmp); + + /* Label for cycle statements (if needed). */ + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&block, tmp); + } + + /* End of loop body. */ + tmp = gfc_finish_block (&block); + + gfc_init_block (&block); + /* Build the loop. */ + tmp = fold_build1_loc (gfc_get_location (&code->expr1->where), LOOP_EXPR, + void_type_node, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Deal with the particular case of SELECT_TYPE, where the vtable + addresses are used for the selection. Since these are not sorted, + the selection has to be made by a series of if statements. */ + +static tree +gfc_trans_select_type_cases (gfc_code * code) +{ + gfc_code *c; + gfc_case *cp; + tree tmp; + tree cond; + tree low; + tree high; + gfc_se se; + gfc_se cse; + stmtblock_t block; + stmtblock_t body; + bool def = false; + gfc_expr *e; + gfc_start_block (&block); + + /* Calculate the switch expression. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->expr1); + gfc_add_block_to_block (&block, &se.pre); + + /* Generate an expression for the selector hash value, for + use to resolve character cases. */ + e = gfc_copy_expr (code->expr1->value.function.actual->expr); + gfc_add_hash_component (e); + + TREE_USED (code->exit_label) = 0; + +repeat: + for (c = code->block; c; c = c->block) + { + cp = c->ext.block.case_list; + + /* Assume it's the default case. */ + low = NULL_TREE; + high = NULL_TREE; + tmp = NULL_TREE; + + /* Put the default case at the end. */ + if ((!def && !cp->low) || (def && cp->low)) + continue; + + if (cp->low && (cp->ts.type == BT_CLASS + || cp->ts.type == BT_DERIVED)) + { + gfc_init_se (&cse, NULL); + gfc_conv_expr_val (&cse, cp->low); + gfc_add_block_to_block (&block, &cse.pre); + low = cse.expr; + } + else if (cp->ts.type != BT_UNKNOWN) + { + gcc_assert (cp->high); + gfc_init_se (&cse, NULL); + gfc_conv_expr_val (&cse, cp->high); + gfc_add_block_to_block (&block, &cse.pre); + high = cse.expr; + } + + gfc_init_block (&body); + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the SELECT TYPE construct. The default + case just falls through. */ + if (!def) + { + TREE_USED (code->exit_label) = 1; + tmp = build1_v (GOTO_EXPR, code->exit_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + + if (low != NULL_TREE) + { + /* Compare vtable pointers. */ + cond = fold_build2_loc (input_location, EQ_EXPR, + TREE_TYPE (se.expr), se.expr, low); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, + build_empty_stmt (input_location)); + } + else if (high != NULL_TREE) + { + /* Compare hash values for character cases. */ + gfc_init_se (&cse, NULL); + gfc_conv_expr_val (&cse, e); + gfc_add_block_to_block (&block, &cse.pre); + + cond = fold_build2_loc (input_location, EQ_EXPR, + TREE_TYPE (se.expr), high, cse.expr); + 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); + } + + if (!def) + { + def = true; + goto repeat; + } + + gfc_free_expr (e); + + return gfc_finish_block (&block); +} + + +/* Translate the SELECT CASE construct for INTEGER case expressions, + without killing all potential optimizations. The problem is that + Fortran allows unbounded cases, but the back-end does not, so we + need to intercept those before we enter the equivalent SWITCH_EXPR + we can build. + + For example, we translate this, + + SELECT CASE (expr) + CASE (:100,101,105:115) + block_1 + CASE (190:199,200:) + block_2 + CASE (300) + block_3 + CASE DEFAULT + block_4 + END SELECT + + to the GENERIC equivalent, + + switch (expr) + { + case (minimum value for typeof(expr) ... 100: + case 101: + case 105 ... 114: + block1: + goto end_label; + + case 200 ... (maximum value for typeof(expr): + case 190 ... 199: + block2; + goto end_label; + + case 300: + block_3; + goto end_label; + + default: + block_4; + goto end_label; + } + + end_label: */ + +static tree +gfc_trans_integer_select (gfc_code * code) +{ + gfc_code *c; + gfc_case *cp; + tree end_label; + tree tmp; + gfc_se se; + stmtblock_t block; + stmtblock_t body; + + gfc_start_block (&block); + + /* Calculate the switch expression. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->expr1); + gfc_add_block_to_block (&block, &se.pre); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + for (c = code->block; c; c = c->block) + { + for (cp = c->ext.block.case_list; cp; cp = cp->next) + { + tree low, high; + tree label; + + /* Assume it's the default case. */ + low = high = NULL_TREE; + + if (cp->low) + { + low = gfc_conv_mpz_to_tree (cp->low->value.integer, + cp->low->ts.kind); + + /* If there's only a lower bound, set the high bound to the + maximum value of the case expression. */ + if (!cp->high) + high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); + } + + if (cp->high) + { + /* Three cases are possible here: + + 1) There is no lower bound, e.g. CASE (:N). + 2) There is a lower bound .NE. high bound, that is + a case range, e.g. CASE (N:M) where M>N (we make + sure that M>N during type resolution). + 3) There is a lower bound, and it has the same value + as the high bound, e.g. CASE (N:N). This is our + internal representation of CASE(N). + + In the first and second case, we need to set a value for + high. In the third case, we don't because the GCC middle + end represents a single case value by just letting high be + a NULL_TREE. We can't do that because we need to be able + to represent unbounded cases. */ + + if (!cp->low + || (mpz_cmp (cp->low->value.integer, + cp->high->value.integer) != 0)) + high = gfc_conv_mpz_to_tree (cp->high->value.integer, + cp->high->ts.kind); + + /* Unbounded case. */ + if (!cp->low) + low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); + } + + /* Build a label. */ + label = gfc_build_label_decl (NULL_TREE); + + /* Add this case label. + Add parameter 'label', make it match GCC backend. */ + tmp = build_case_label (low, high, label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp); + gfc_add_expr_to_block (&block, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate the SELECT CASE construct for LOGICAL case expressions. + + There are only two cases possible here, even though the standard + does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., + .FALSE., and DEFAULT. + + We never generate more than two blocks here. Instead, we always + try to eliminate the DEFAULT case. This way, we can translate this + kind of SELECT construct to a simple + + if {} else {}; + + expression in GENERIC. */ + +static tree +gfc_trans_logical_select (gfc_code * code) +{ + gfc_code *c; + gfc_code *t, *f, *d; + gfc_case *cp; + gfc_se se; + stmtblock_t block; + + /* Assume we don't have any cases at all. */ + t = f = d = NULL; + + /* Now see which ones we actually do have. We can have at most two + cases in a single case list: one for .TRUE. and one for .FALSE. + The default case is always separate. If the cases for .TRUE. and + .FALSE. are in the same case list, the block for that case list + always executed, and we don't generate code a COND_EXPR. */ + for (c = code->block; c; c = c->block) + { + for (cp = c->ext.block.case_list; cp; cp = cp->next) + { + if (cp->low) + { + if (cp->low->value.logical == 0) /* .FALSE. */ + f = c; + else /* if (cp->value.logical != 0), thus .TRUE. */ + t = c; + } + else + d = c; + } + } + + /* Start a new block. */ + gfc_start_block (&block); + + /* Calculate the switch expression. We always need to do this + because it may have side effects. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->expr1); + gfc_add_block_to_block (&block, &se.pre); + + if (t == f && t != NULL) + { + /* Cases for .TRUE. and .FALSE. are in the same block. Just + translate the code for these cases, append it to the current + block. */ + gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); + } + else + { + tree true_tree, false_tree, stmt; + + true_tree = build_empty_stmt (input_location); + false_tree = build_empty_stmt (input_location); + + /* If we have a case for .TRUE. and for .FALSE., discard the default case. + Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, + make the missing case the default case. */ + if (t != NULL && f != NULL) + d = NULL; + else if (d != NULL) + { + if (t == NULL) + t = d; + else + f = d; + } + + /* Translate the code for each of these blocks, and append it to + the current block. */ + if (t != NULL) + true_tree = gfc_trans_code (t->next); + + if (f != NULL) + false_tree = gfc_trans_code (f->next); + + stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, + se.expr, true_tree, false_tree); + gfc_add_expr_to_block (&block, stmt); + } + + return gfc_finish_block (&block); +} + + +/* The jump table types are stored in static variables to avoid + constructing them from scratch every single time. */ +static GTY(()) tree select_struct[2]; + +/* Translate the SELECT CASE construct for CHARACTER case expressions. + Instead of generating compares and jumps, it is far simpler to + generate a data structure describing the cases in order and call a + library subroutine that locates the right case. + This is particularly true because this is the only case where we + might have to dispose of a temporary. + The library subroutine returns a pointer to jump to or NULL if no + branches are to be taken. */ + +static tree +gfc_trans_character_select (gfc_code *code) +{ + tree init, end_label, tmp, type, case_num, label, fndecl; + stmtblock_t block, body; + gfc_case *cp, *d; + gfc_code *c; + gfc_se se, expr1se; + int n, k; + vec *inits = NULL; + + tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); + + /* The jump table types are stored in static variables to avoid + constructing them from scratch every single time. */ + static tree ss_string1[2], ss_string1_len[2]; + static tree ss_string2[2], ss_string2_len[2]; + static tree ss_target[2]; + + cp = code->block->ext.block.case_list; + while (cp->left != NULL) + cp = cp->left; + + /* Generate the body */ + gfc_start_block (&block); + gfc_init_se (&expr1se, NULL); + gfc_conv_expr_reference (&expr1se, code->expr1); + + gfc_add_block_to_block (&block, &expr1se.pre); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + /* Attempt to optimize length 1 selects. */ + if (integer_onep (expr1se.string_length)) + { + for (d = cp; d; d = d->right) + { + gfc_charlen_t i; + if (d->low) + { + gcc_assert (d->low->expr_type == EXPR_CONSTANT + && d->low->ts.type == BT_CHARACTER); + if (d->low->value.character.length > 1) + { + for (i = 1; i < d->low->value.character.length; i++) + if (d->low->value.character.string[i] != ' ') + break; + if (i != d->low->value.character.length) + { + if (optimize && d->high && i == 1) + { + gcc_assert (d->high->expr_type == EXPR_CONSTANT + && d->high->ts.type == BT_CHARACTER); + if (d->high->value.character.length > 1 + && (d->low->value.character.string[0] + == d->high->value.character.string[0]) + && d->high->value.character.string[1] != ' ' + && ((d->low->value.character.string[1] < ' ') + == (d->high->value.character.string[1] + < ' '))) + continue; + } + break; + } + } + } + if (d->high) + { + gcc_assert (d->high->expr_type == EXPR_CONSTANT + && d->high->ts.type == BT_CHARACTER); + if (d->high->value.character.length > 1) + { + for (i = 1; i < d->high->value.character.length; i++) + if (d->high->value.character.string[i] != ' ') + break; + if (i != d->high->value.character.length) + break; + } + } + } + if (d == NULL) + { + tree ctype = gfc_get_char_type (code->expr1->ts.kind); + + for (c = code->block; c; c = c->block) + { + for (cp = c->ext.block.case_list; cp; cp = cp->next) + { + tree low, high; + tree label; + gfc_char_t r; + + /* Assume it's the default case. */ + low = high = NULL_TREE; + + if (cp->low) + { + /* CASE ('ab') or CASE ('ab':'az') will never match + any length 1 character. */ + if (cp->low->value.character.length > 1 + && cp->low->value.character.string[1] != ' ') + continue; + + if (cp->low->value.character.length > 0) + r = cp->low->value.character.string[0]; + else + r = ' '; + low = build_int_cst (ctype, r); + + /* If there's only a lower bound, set the high bound + to the maximum value of the case expression. */ + if (!cp->high) + high = TYPE_MAX_VALUE (ctype); + } + + if (cp->high) + { + if (!cp->low + || (cp->low->value.character.string[0] + != cp->high->value.character.string[0])) + { + if (cp->high->value.character.length > 0) + r = cp->high->value.character.string[0]; + else + r = ' '; + high = build_int_cst (ctype, r); + } + + /* Unbounded case. */ + if (!cp->low) + low = TYPE_MIN_VALUE (ctype); + } + + /* Build a label. */ + label = gfc_build_label_decl (NULL_TREE); + + /* Add this case label. + Add parameter 'label', make it match GCC backend. */ + tmp = build_case_label (low, high, label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_string_to_single_character (expr1se.string_length, + expr1se.expr, + code->expr1->ts.kind); + case_num = gfc_create_var (ctype, "case_num"); + gfc_add_modify (&block, case_num, tmp); + + gfc_add_block_to_block (&block, &expr1se.post); + + tmp = gfc_finish_block (&body); + tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, + case_num, tmp); + gfc_add_expr_to_block (&block, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); + } + } + + if (code->expr1->ts.kind == 1) + k = 0; + else if (code->expr1->ts.kind == 4) + k = 1; + else + gcc_unreachable (); + + if (select_struct[k] == NULL) + { + tree *chain = NULL; + select_struct[k] = make_node (RECORD_TYPE); + + if (code->expr1->ts.kind == 1) + TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1"); + else if (code->expr1->ts.kind == 4) + TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4"); + else + gcc_unreachable (); + +#undef ADD_FIELD +#define ADD_FIELD(NAME, TYPE) \ + ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \ + get_identifier (stringize(NAME)), \ + TYPE, \ + &chain) + + ADD_FIELD (string1, pchartype); + ADD_FIELD (string1_len, gfc_charlen_type_node); + + ADD_FIELD (string2, pchartype); + ADD_FIELD (string2_len, gfc_charlen_type_node); + + ADD_FIELD (target, integer_type_node); +#undef ADD_FIELD + + gfc_finish_type (select_struct[k]); + } + + n = 0; + for (d = cp; d; d = d->right) + d->n = n++; + + for (c = code->block; c; c = c->block) + { + for (d = c->ext.block.case_list; d; d = d->next) + { + label = gfc_build_label_decl (NULL_TREE); + tmp = build_case_label ((d->low == NULL && d->high == NULL) + ? NULL + : build_int_cst (integer_type_node, d->n), + NULL, label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Generate the structure describing the branches */ + for (d = cp; d; d = d->right) + { + vec *node = NULL; + + gfc_init_se (&se, NULL); + + if (d->low == NULL) + { + CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); + CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node)); + } + else + { + gfc_conv_expr_reference (&se, d->low); + + CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr); + CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length); + } + + if (d->high == NULL) + { + CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); + CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node)); + } + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr_reference (&se, d->high); + + CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr); + CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length); + } + + CONSTRUCTOR_APPEND_ELT (node, ss_target[k], + build_int_cst (integer_type_node, d->n)); + + tmp = build_constructor (select_struct[k], node); + CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp); + } + + type = build_array_type (select_struct[k], + build_index_type (size_int (n-1))); + + init = build_constructor (type, inits); + TREE_CONSTANT (init) = 1; + TREE_STATIC (init) = 1; + /* Create a static variable to hold the jump table. */ + tmp = gfc_create_var (type, "jumptable"); + TREE_CONSTANT (tmp) = 1; + TREE_STATIC (tmp) = 1; + TREE_READONLY (tmp) = 1; + DECL_INITIAL (tmp) = init; + init = tmp; + + /* Build the library call */ + init = gfc_build_addr_expr (pvoid_type_node, init); + + if (code->expr1->ts.kind == 1) + fndecl = gfor_fndecl_select_string; + else if (code->expr1->ts.kind == 4) + fndecl = gfor_fndecl_select_string_char4; + else + gcc_unreachable (); + + tmp = build_call_expr_loc (input_location, + fndecl, 4, init, + build_int_cst (gfc_charlen_type_node, n), + expr1se.expr, expr1se.string_length); + case_num = gfc_create_var (integer_type_node, "case_num"); + gfc_add_modify (&block, case_num, tmp); + + gfc_add_block_to_block (&block, &expr1se.post); + + tmp = gfc_finish_block (&body); + tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, + case_num, tmp); + gfc_add_expr_to_block (&block, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate the three variants of the SELECT CASE construct. + + SELECT CASEs with INTEGER case expressions can be translated to an + equivalent GENERIC switch statement, and for LOGICAL case + expressions we build one or two if-else compares. + + SELECT CASEs with CHARACTER case expressions are a whole different + story, because they don't exist in GENERIC. So we sort them and + do a binary search at runtime. + + Fortran has no BREAK statement, and it does not allow jumps from + one case block to another. That makes things a lot easier for + the optimizers. */ + +tree +gfc_trans_select (gfc_code * code) +{ + stmtblock_t block; + tree body; + tree exit_label; + + gcc_assert (code && code->expr1); + gfc_init_block (&block); + + /* Build the exit label and hang it in. */ + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + + /* Empty SELECT constructs are legal. */ + if (code->block == NULL) + body = build_empty_stmt (input_location); + + /* Select the correct translation function. */ + else + switch (code->expr1->ts.type) + { + case BT_LOGICAL: + body = gfc_trans_logical_select (code); + break; + + case BT_INTEGER: + body = gfc_trans_integer_select (code); + break; + + case BT_CHARACTER: + body = gfc_trans_character_select (code); + break; + + default: + gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); + /* Not reached */ + } + + /* Build everything together. */ + gfc_add_expr_to_block (&block, body); + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); + + return gfc_finish_block (&block); +} + +tree +gfc_trans_select_type (gfc_code * code) +{ + stmtblock_t block; + tree body; + tree exit_label; + + gcc_assert (code && code->expr1); + gfc_init_block (&block); + + /* Build the exit label and hang it in. */ + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + + /* Empty SELECT constructs are legal. */ + if (code->block == NULL) + body = build_empty_stmt (input_location); + else + body = gfc_trans_select_type_cases (code); + + /* Build everything together. */ + gfc_add_expr_to_block (&block, body); + + if (TREE_USED (exit_label)) + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); + + return gfc_finish_block (&block); +} + + +static tree +gfc_trans_select_rank_cases (gfc_code * code) +{ + gfc_code *c; + gfc_case *cp; + tree tmp; + tree cond; + tree low; + tree rank; + gfc_se se; + gfc_se cse; + stmtblock_t block; + stmtblock_t body; + bool def = false; + + gfc_start_block (&block); + + /* Calculate the switch expression. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_descriptor (&se, code->expr1); + rank = gfc_conv_descriptor_rank (se.expr); + rank = gfc_evaluate_now (rank, &block); + symbol_attribute attr = gfc_expr_attr (code->expr1); + if (!attr.pointer && !attr.allocatable) + { + /* Special case for assumed-rank ('rank(*)', internally -1): + rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */ + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + rank, build_int_cst (TREE_TYPE (rank), 0)); + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, rank), + gfc_index_one_node); + tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp); + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), -1)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, cond, tmp); + tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank), + cond, rank, build_int_cst (TREE_TYPE (rank), -1)); + rank = gfc_evaluate_now (tmp, &block); + } + TREE_USED (code->exit_label) = 0; + +repeat: + for (c = code->block; c; c = c->block) + { + cp = c->ext.block.case_list; + + /* Assume it's the default case. */ + low = NULL_TREE; + tmp = NULL_TREE; + + /* Put the default case at the end. */ + if ((!def && !cp->low) || (def && cp->low)) + continue; + + if (cp->low) + { + gfc_init_se (&cse, NULL); + gfc_conv_expr_val (&cse, cp->low); + gfc_add_block_to_block (&block, &cse.pre); + low = cse.expr; + } + + gfc_init_block (&body); + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the SELECT RANK construct. The default + case just falls through. */ + if (!def) + { + TREE_USED (code->exit_label) = 1; + tmp = build1_v (GOTO_EXPR, code->exit_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + + if (low != NULL_TREE) + { + cond = fold_build2_loc (input_location, EQ_EXPR, + TREE_TYPE (rank), rank, + fold_convert (TREE_TYPE (rank), low)); + 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); + } + + if (!def) + { + def = true; + goto repeat; + } + + return gfc_finish_block (&block); +} + + +tree +gfc_trans_select_rank (gfc_code * code) +{ + stmtblock_t block; + tree body; + tree exit_label; + + gcc_assert (code && code->expr1); + gfc_init_block (&block); + + /* Build the exit label and hang it in. */ + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + + /* Empty SELECT constructs are legal. */ + if (code->block == NULL) + body = build_empty_stmt (input_location); + else + body = gfc_trans_select_rank_cases (code); + + /* Build everything together. */ + gfc_add_expr_to_block (&block, body); + + if (TREE_USED (exit_label)) + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); + + return gfc_finish_block (&block); +} + + +/* Traversal function to substitute a replacement symtree if the symbol + in the expression is the same as that passed. f == 2 signals that + that variable itself is not to be checked - only the references. + This group of functions is used when the variable expression in a + FORALL assignment has internal references. For example: + FORALL (i = 1:4) p(p(i)) = i + The only recourse here is to store a copy of 'p' for the index + expression. */ + +static gfc_symtree *new_symtree; +static gfc_symtree *old_symtree; + +static bool +forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f) +{ + if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (*f == 2) + *f = 1; + else if (expr->symtree->n.sym == sym) + expr->symtree = new_symtree; + + return false; +} + +static void +forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f) +{ + gfc_traverse_expr (e, sym, forall_replace, f); +} + +static bool +forall_restore (gfc_expr *expr, + gfc_symbol *sym ATTRIBUTE_UNUSED, + int *f ATTRIBUTE_UNUSED) +{ + if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (expr->symtree == new_symtree) + expr->symtree = old_symtree; + + return false; +} + +static void +forall_restore_symtree (gfc_expr *e) +{ + gfc_traverse_expr (e, NULL, forall_restore, 0); +} + +static void +forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) +{ + gfc_se tse; + gfc_se rse; + gfc_expr *e; + gfc_symbol *new_sym; + gfc_symbol *old_sym; + gfc_symtree *root; + tree tmp; + + /* Build a copy of the lvalue. */ + old_symtree = c->expr1->symtree; + old_sym = old_symtree->n.sym; + e = gfc_lval_expr_from_sym (old_sym); + if (old_sym->attr.dimension) + { + gfc_init_se (&tse, NULL); + gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false); + gfc_add_block_to_block (pre, &tse.pre); + gfc_add_block_to_block (post, &tse.post); + tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr); + + if (c->expr1->ref->u.ar.type != AR_SECTION) + { + /* Use the variable offset for the temporary. */ + tmp = gfc_conv_array_offset (old_sym->backend_decl); + gfc_conv_descriptor_offset_set (pre, tse.expr, tmp); + } + } + else + { + gfc_init_se (&tse, NULL); + gfc_init_se (&rse, NULL); + gfc_conv_expr (&rse, e); + if (e->ts.type == BT_CHARACTER) + { + tse.string_length = rse.string_length; + tmp = gfc_get_character_type_len (gfc_default_character_kind, + tse.string_length); + tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp), + rse.string_length); + gfc_add_block_to_block (pre, &tse.pre); + gfc_add_block_to_block (post, &tse.post); + } + else + { + tmp = gfc_typenode_for_spec (&e->ts); + tse.expr = gfc_create_var (tmp, "temp"); + } + + tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, + e->expr_type == EXPR_VARIABLE, false); + gfc_add_expr_to_block (pre, tmp); + } + gfc_free_expr (e); + + /* Create a new symbol to represent the lvalue. */ + new_sym = gfc_new_symbol (old_sym->name, NULL); + new_sym->ts = old_sym->ts; + new_sym->attr.referenced = 1; + new_sym->attr.temporary = 1; + new_sym->attr.dimension = old_sym->attr.dimension; + new_sym->attr.flavor = old_sym->attr.flavor; + + /* Use the temporary as the backend_decl. */ + new_sym->backend_decl = tse.expr; + + /* Create a fake symtree for it. */ + root = NULL; + new_symtree = gfc_new_symtree (&root, old_sym->name); + new_symtree->n.sym = new_sym; + gcc_assert (new_symtree == root); + + /* Go through the expression reference replacing the old_symtree + with the new. */ + forall_replace_symtree (c->expr1, old_sym, 2); + + /* Now we have made this temporary, we might as well use it for + the right hand side. */ + forall_replace_symtree (c->expr2, old_sym, 1); +} + + +/* Handles dependencies in forall assignments. */ +static int +check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) +{ + gfc_ref *lref; + gfc_ref *rref; + int need_temp; + gfc_symbol *lsym; + + lsym = c->expr1->symtree->n.sym; + need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); + + /* Now check for dependencies within the 'variable' + expression itself. These are treated by making a complete + copy of variable and changing all the references to it + point to the copy instead. Note that the shallow copy of + the variable will not suffice for derived types with + pointer components. We therefore leave these to their + own devices. Likewise for allocatable components. */ + if (lsym->ts.type == BT_DERIVED + && (lsym->ts.u.derived->attr.pointer_comp + || lsym->ts.u.derived->attr.alloc_comp)) + return need_temp; + + new_symtree = NULL; + if (find_forall_index (c->expr1, lsym, 2)) + { + forall_make_variable_temp (c, pre, post); + need_temp = 0; + } + + /* Substrings with dependencies are treated in the same + way. */ + if (c->expr1->ts.type == BT_CHARACTER + && c->expr1->ref + && c->expr2->expr_type == EXPR_VARIABLE + && lsym == c->expr2->symtree->n.sym) + { + for (lref = c->expr1->ref; lref; lref = lref->next) + if (lref->type == REF_SUBSTRING) + break; + for (rref = c->expr2->ref; rref; rref = rref->next) + if (rref->type == REF_SUBSTRING) + break; + + if (rref && lref + && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0) + { + forall_make_variable_temp (c, pre, post); + need_temp = 0; + } + } + return need_temp; +} + + +static void +cleanup_forall_symtrees (gfc_code *c) +{ + forall_restore_symtree (c->expr1); + forall_restore_symtree (c->expr2); + free (new_symtree->n.sym); + free (new_symtree); +} + + +/* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY + is the contents of the FORALL block/stmt to be iterated. MASK_FLAG + indicates whether we should generate code to test the FORALLs mask + array. OUTER is the loop header to be used for initializing mask + indices. + + The generated loop format is: + count = (end - start + step) / step + loopvar = start + while (1) + { + if (count <=0 ) + goto end_of_loop + + loopvar += step + count -- + } + end_of_loop: */ + +static tree +gfc_trans_forall_loop (forall_info *forall_tmp, tree body, + int mask_flag, stmtblock_t *outer) +{ + int n, nvar; + tree tmp; + tree cond; + stmtblock_t block; + tree exit_label; + tree count; + tree var, start, end, step; + iter_info *iter; + + /* Initialize the mask index outside the FORALL nest. */ + if (mask_flag && forall_tmp->mask) + gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node); + + iter = forall_tmp->this_loop; + nvar = forall_tmp->nvar; + for (n = 0; n < nvar; n++) + { + var = iter->var; + start = iter->start; + end = iter->end; + step = iter->step; + + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + /* The loop counter. */ + count = gfc_create_var (TREE_TYPE (var), "count"); + + /* The body of the loop. */ + gfc_init_block (&block); + + /* The exit condition. */ + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, + count, build_int_cst (TREE_TYPE (count), 0)); + + /* PR 83064 means that we cannot use annot_expr_parallel_kind until + the autoparallelizer can hande this. */ + if (forall_tmp->do_concurrent) + cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, + build_int_cst (integer_type_node, + annot_expr_ivdep_kind), + integer_zero_node); + + 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 (&block, tmp); + + /* The main loop body. */ + gfc_add_expr_to_block (&block, body); + + /* Increment the loop variable. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, + step); + gfc_add_modify (&block, var, tmp); + + /* Advance to the next mask element. Only do this for the + innermost loop. */ + if (n == 0 && mask_flag && forall_tmp->mask) + { + tree maskindex = forall_tmp->maskindex; + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + maskindex, gfc_index_one_node); + gfc_add_modify (&block, maskindex, tmp); + } + + /* Decrement the loop counter. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count, + build_int_cst (TREE_TYPE (var), 1)); + gfc_add_modify (&block, count, tmp); + + body = gfc_finish_block (&block); + + /* Loop var initialization. */ + gfc_init_block (&block); + gfc_add_modify (&block, var, start); + + + /* Initialize the loop counter. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step, + start); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end, + tmp); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var), + tmp, step); + gfc_add_modify (&block, count, tmp); + + /* The loop expression. */ + tmp = build1_v (LOOP_EXPR, body); + gfc_add_expr_to_block (&block, tmp); + + /* The exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + body = gfc_finish_block (&block); + iter = iter->next; + } + return body; +} + + +/* Generate the body and loops according to MASK_FLAG. If MASK_FLAG + is nonzero, the body is controlled by all masks in the forall nest. + Otherwise, the innermost loop is not controlled by it's mask. This + is used for initializing that mask. */ + +static tree +gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, + int mask_flag) +{ + tree tmp; + stmtblock_t header; + forall_info *forall_tmp; + tree mask, maskindex; + + gfc_start_block (&header); + + forall_tmp = nested_forall_info; + while (forall_tmp != NULL) + { + /* Generate body with masks' control. */ + if (mask_flag) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + + /* If a mask was specified make the assignment conditional. */ + if (mask) + { + tmp = gfc_build_array_ref (mask, maskindex, NULL); + body = build3_v (COND_EXPR, tmp, body, + build_empty_stmt (input_location)); + } + } + body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header); + forall_tmp = forall_tmp->prev_nest; + mask_flag = 1; + } + + gfc_add_expr_to_block (&header, body); + return gfc_finish_block (&header); +} + + +/* Allocate data for holding a temporary array. Returns either a local + temporary array or a pointer variable. */ + +static tree +gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, + tree elem_type) +{ + tree tmpvar; + tree type; + tree tmp; + + if (INTEGER_CST_P (size)) + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + else + tmp = NULL_TREE; + + type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); + type = build_array_type (elem_type, type); + if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size)) + { + tmpvar = gfc_create_var (type, "temp"); + *pdata = NULL_TREE; + } + else + { + tmpvar = gfc_create_var (build_pointer_type (type), "temp"); + *pdata = convert (pvoid_type_node, tmpvar); + + tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize); + gfc_add_modify (pblock, tmpvar, tmp); + } + return tmpvar; +} + + +/* Generate codes to copy the temporary to the actual lhs. */ + +static tree +generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, + tree count1, + gfc_ss *lss, gfc_ss *rss, + tree wheremask, bool invert) +{ + stmtblock_t block, body1; + gfc_loopinfo loop; + gfc_se lse; + gfc_se rse; + tree tmp; + tree wheremaskexpr; + + (void) rss; /* TODO: unused. */ + + gfc_start_block (&block); + + gfc_init_se (&rse, NULL); + gfc_init_se (&lse, NULL); + + if (lss == gfc_ss_terminator) + { + gfc_init_block (&body1); + gfc_conv_expr (&lse, expr); + rse.expr = gfc_build_array_ref (tmp1, count1, NULL); + } + else + { + /* Initialize the loop. */ + gfc_init_loopinfo (&loop); + + /* We may need LSS to determine the shape of the expression. */ + gfc_add_ss_to_loop (&loop, lss); + + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + gfc_mark_ss_chain_used (lss, 1); + /* Start the loop body. */ + gfc_start_scalarized_body (&loop, &body1); + + /* Translate the expression. */ + gfc_copy_loopinfo_to_se (&lse, &loop); + lse.ss = lss; + gfc_conv_expr (&lse, expr); + + /* Form the expression of the temporary. */ + rse.expr = gfc_build_array_ref (tmp1, count1, NULL); + } + + /* Use the scalar assignment. */ + rse.string_length = lse.string_length; + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, + expr->expr_type == EXPR_VARIABLE, false); + + /* Form the mask expression according to the mask tree list. */ + if (wheremask) + { + wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); + if (invert) + wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (wheremaskexpr), + wheremaskexpr); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + wheremaskexpr, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&body1, tmp); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), + count1, gfc_index_one_node); + gfc_add_modify (&body1, count1, tmp); + + if (lss == gfc_ss_terminator) + gfc_add_block_to_block (&block, &body1); + else + { + /* Increment count3. */ + if (count3) + { + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + count3, gfc_index_one_node); + gfc_add_modify (&body1, count3, tmp); + } + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &body1); + + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + + gfc_cleanup_loop (&loop); + /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful + as tree nodes in SS may not be valid in different scope. */ + } + + tmp = gfc_finish_block (&block); + return tmp; +} + + +/* Generate codes to copy rhs to the temporary. TMP1 is the address of + temporary, LSS and RSS are formed in function compute_inner_temp_size(), + and should not be freed. WHEREMASK is the conditional execution mask + whose sense may be inverted by INVERT. */ + +static tree +generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, + tree count1, gfc_ss *lss, gfc_ss *rss, + tree wheremask, bool invert) +{ + stmtblock_t block, body1; + gfc_loopinfo loop; + gfc_se lse; + gfc_se rse; + tree tmp; + tree wheremaskexpr; + + gfc_start_block (&block); + + gfc_init_se (&rse, NULL); + gfc_init_se (&lse, NULL); + + if (lss == gfc_ss_terminator) + { + gfc_init_block (&body1); + gfc_conv_expr (&rse, expr2); + lse.expr = gfc_build_array_ref (tmp1, count1, NULL); + } + else + { + /* Initialize the loop. */ + gfc_init_loopinfo (&loop); + + /* We may need LSS to determine the shape of the expression. */ + gfc_add_ss_to_loop (&loop, lss); + gfc_add_ss_to_loop (&loop, rss); + + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &expr2->where); + + gfc_mark_ss_chain_used (rss, 1); + /* Start the loop body. */ + gfc_start_scalarized_body (&loop, &body1); + + /* Translate the expression. */ + gfc_copy_loopinfo_to_se (&rse, &loop); + rse.ss = rss; + gfc_conv_expr (&rse, expr2); + + /* Form the expression of the temporary. */ + lse.expr = gfc_build_array_ref (tmp1, count1, NULL); + } + + /* Use the scalar assignment. */ + lse.string_length = rse.string_length; + tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, + expr2->expr_type == EXPR_VARIABLE, false); + + /* Form the mask expression according to the mask tree list. */ + if (wheremask) + { + wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); + if (invert) + wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (wheremaskexpr), + wheremaskexpr); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + wheremaskexpr, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&body1, tmp); + + if (lss == gfc_ss_terminator) + { + gfc_add_block_to_block (&block, &body1); + + /* Increment count1. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), + count1, gfc_index_one_node); + gfc_add_modify (&block, count1, tmp); + } + else + { + /* Increment count1. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count1, gfc_index_one_node); + gfc_add_modify (&body1, count1, tmp); + + /* Increment count3. */ + if (count3) + { + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + count3, gfc_index_one_node); + gfc_add_modify (&body1, count3, tmp); + } + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &body1); + + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + + gfc_cleanup_loop (&loop); + /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful + as tree nodes in SS may not be valid in different scope. */ + } + + tmp = gfc_finish_block (&block); + return tmp; +} + + +/* Calculate the size of temporary needed in the assignment inside forall. + LSS and RSS are filled in this function. */ + +static tree +compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, + stmtblock_t * pblock, + gfc_ss **lss, gfc_ss **rss) +{ + gfc_loopinfo loop; + tree size; + int i; + int save_flag; + tree tmp; + + *lss = gfc_walk_expr (expr1); + *rss = NULL; + + size = gfc_index_one_node; + if (*lss != gfc_ss_terminator) + { + gfc_init_loopinfo (&loop); + + /* Walk the RHS of the expression. */ + *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); + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, *lss); + /* We don't actually need to add the rhs at this point, but it might + make guessing the loop bounds a bit easier. */ + gfc_add_ss_to_loop (&loop, *rss); + + /* We only want the shape of the expression, not rest of the junk + generated by the scalarizer. */ + loop.array_parameter = 1; + + /* Calculate the bounds of the scalarization. */ + save_flag = gfc_option.rtcheck; + gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS; + gfc_conv_ss_startstride (&loop); + gfc_option.rtcheck = save_flag; + gfc_conv_loop_setup (&loop, &expr2->where); + + /* Figure out how many elements we need. */ + for (i = 0; i < loop.dimen; i++) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + gfc_index_one_node, loop.from[i]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, loop.to[i]); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + } + gfc_add_block_to_block (pblock, &loop.pre); + size = gfc_evaluate_now (size, pblock); + gfc_add_block_to_block (pblock, &loop.post); + + /* TODO: write a function that cleans up a loopinfo without freeing + the SS chains. Currently a NOP. */ + } + + return size; +} + + +/* Calculate the overall iterator number of the nested forall construct. + This routine actually calculates the number of times the body of the + nested forall specified by NESTED_FORALL_INFO is executed and multiplies + that by the expression INNER_SIZE. The BLOCK argument specifies the + block in which to calculate the result, and the optional INNER_SIZE_BODY + argument contains any statements that need to executed (inside the loop) + to initialize or calculate INNER_SIZE. */ + +static tree +compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, + stmtblock_t *inner_size_body, stmtblock_t *block) +{ + forall_info *forall_tmp = nested_forall_info; + tree tmp, number; + stmtblock_t body; + + /* We can eliminate the innermost unconditional loops with constant + array bounds. */ + if (INTEGER_CST_P (inner_size)) + { + while (forall_tmp + && !forall_tmp->mask + && INTEGER_CST_P (forall_tmp->size)) + { + inner_size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + inner_size, forall_tmp->size); + forall_tmp = forall_tmp->prev_nest; + } + + /* If there are no loops left, we have our constant result. */ + if (!forall_tmp) + return inner_size; + } + + /* Otherwise, create a temporary variable to compute the result. */ + number = gfc_create_var (gfc_array_index_type, "num"); + gfc_add_modify (block, number, gfc_index_zero_node); + + gfc_start_block (&body); + if (inner_size_body) + gfc_add_block_to_block (&body, inner_size_body); + if (forall_tmp) + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, number, inner_size); + else + tmp = inner_size; + gfc_add_modify (&body, number, tmp); + tmp = gfc_finish_block (&body); + + /* Generate loops. */ + if (forall_tmp != NULL) + tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1); + + gfc_add_expr_to_block (block, tmp); + + return number; +} + + +/* Allocate temporary for forall construct. SIZE is the size of temporary + needed. PTEMP1 is returned for space free. */ + +static tree +allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, + tree * ptemp1) +{ + tree bytesize; + tree unit; + tree tmp; + + unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type)); + if (!integer_onep (unit)) + bytesize = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, unit); + else + bytesize = size; + + *ptemp1 = NULL; + tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type); + + if (*ptemp1) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + return tmp; +} + + +/* Allocate temporary for forall construct according to the information in + nested_forall_info. INNER_SIZE is the size of temporary needed in the + assignment inside forall. PTEMP1 is returned for space free. */ + +static tree +allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, + tree inner_size, stmtblock_t * inner_size_body, + stmtblock_t * block, tree * ptemp1) +{ + tree size; + + /* Calculate the total size of temporary needed in forall construct. */ + size = compute_overall_iter_number (nested_forall_info, inner_size, + inner_size_body, block); + + return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1); +} + + +/* Handle assignments inside forall which need temporary. + + forall (i=start:end:stride; maskexpr) + e = f + end forall + (where e,f are arbitrary expressions possibly involving i + and there is a dependency between e and f) + Translates to: + masktmp(:) = maskexpr(:) + + maskindex = 0; + count1 = 0; + num = 0; + for (i = start; i <= end; i += stride) + num += SIZE (f) + count1 = 0; + ALLOCATE (tmp(num)) + for (i = start; i <= end; i += stride) + { + if (masktmp[maskindex++]) + tmp[count1++] = f + } + maskindex = 0; + count1 = 0; + for (i = start; i <= end; i += stride) + { + if (masktmp[maskindex++]) + e = tmp[count1++] + } + DEALLOCATE (tmp) + */ +static void +gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, + tree wheremask, bool invert, + forall_info * nested_forall_info, + stmtblock_t * block) +{ + tree type; + tree inner_size; + gfc_ss *lss, *rss; + tree count, count1; + tree tmp, tmp1; + tree ptemp1; + stmtblock_t inner_size_body; + + /* Create vars. count1 is the current iterator number of the nested + forall. */ + count1 = gfc_create_var (gfc_array_index_type, "count1"); + + /* Count is the wheremask index. */ + if (wheremask) + { + count = gfc_create_var (gfc_array_index_type, "count"); + gfc_add_modify (block, count, gfc_index_zero_node); + } + else + count = NULL; + + /* Initialize count1. */ + gfc_add_modify (block, count1, gfc_index_zero_node); + + /* Calculate the size of temporary needed in the assignment. Return loop, lss + and rss which are used in function generate_loop_for_rhs_to_temp(). */ + /* The type of LHS. Used in function allocate_temp_for_forall_nest */ + if (expr1->ts.type == BT_CHARACTER) + { + type = NULL; + if (expr1->ref && expr1->ref->type == REF_SUBSTRING) + { + gfc_se ssse; + gfc_init_se (&ssse, NULL); + gfc_conv_expr (&ssse, expr1); + type = gfc_get_character_type_len (gfc_default_character_kind, + ssse.string_length); + } + else + { + if (!expr1->ts.u.cl->backend_decl) + { + gfc_se tse; + gcc_assert (expr1->ts.u.cl->length); + gfc_init_se (&tse, NULL); + gfc_conv_expr (&tse, expr1->ts.u.cl->length); + expr1->ts.u.cl->backend_decl = tse.expr; + } + type = gfc_get_character_type_len (gfc_default_character_kind, + expr1->ts.u.cl->backend_decl); + } + } + else + type = gfc_typenode_for_spec (&expr1->ts); + + gfc_init_block (&inner_size_body); + inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, + &lss, &rss); + + /* Allocate temporary for nested forall construct according to the + information in nested_forall_info and inner_size. */ + tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, + &inner_size_body, block, &ptemp1); + + /* Generate codes to copy rhs to the temporary . */ + tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, + wheremask, invert); + + /* Generate body and loops according to the information in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (block, tmp); + + /* Reset count1. */ + gfc_add_modify (block, count1, gfc_index_zero_node); + + /* Reset count. */ + if (wheremask) + gfc_add_modify (block, count, gfc_index_zero_node); + + /* TODO: Second call to compute_inner_temp_size to initialize lss and + rss; there must be a better way. */ + inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, + &lss, &rss); + + /* Generate codes to copy the temporary to lhs. */ + tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, + lss, rss, + wheremask, invert); + + /* Generate body and loops according to the information in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (block, tmp); + + if (ptemp1) + { + /* Free the temporary. */ + tmp = gfc_call_free (ptemp1); + gfc_add_expr_to_block (block, tmp); + } +} + + +/* Translate pointer assignment inside FORALL which need temporary. */ + +static void +gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, + forall_info * nested_forall_info, + stmtblock_t * block) +{ + tree type; + tree inner_size; + gfc_ss *lss, *rss; + gfc_se lse; + gfc_se rse; + gfc_array_info *info; + gfc_loopinfo loop; + tree desc; + tree parm; + tree parmtype; + stmtblock_t body; + tree count; + tree tmp, tmp1, ptemp1; + + count = gfc_create_var (gfc_array_index_type, "count"); + gfc_add_modify (block, count, gfc_index_zero_node); + + inner_size = gfc_index_one_node; + lss = gfc_walk_expr (expr1); + rss = gfc_walk_expr (expr2); + if (lss == gfc_ss_terminator) + { + type = gfc_typenode_for_spec (&expr1->ts); + type = build_pointer_type (type); + + /* Allocate temporary for nested forall construct according to the + information in nested_forall_info and inner_size. */ + tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, + inner_size, NULL, block, &ptemp1); + gfc_start_block (&body); + gfc_init_se (&lse, NULL); + lse.expr = gfc_build_array_ref (tmp1, count, NULL); + gfc_init_se (&rse, NULL); + rse.want_pointer = 1; + gfc_conv_expr (&rse, expr2); + gfc_add_block_to_block (&body, &rse.pre); + gfc_add_modify (&body, lse.expr, + fold_convert (TREE_TYPE (lse.expr), rse.expr)); + gfc_add_block_to_block (&body, &rse.post); + + /* Increment count. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); + gfc_add_modify (&body, count, tmp); + + tmp = gfc_finish_block (&body); + + /* Generate body and loops according to the information in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (block, tmp); + + /* Reset count. */ + gfc_add_modify (block, count, gfc_index_zero_node); + + gfc_start_block (&body); + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + rse.expr = gfc_build_array_ref (tmp1, count, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, expr1); + gfc_add_block_to_block (&body, &lse.pre); + gfc_add_modify (&body, lse.expr, rse.expr); + gfc_add_block_to_block (&body, &lse.post); + /* Increment count. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); + gfc_add_modify (&body, count, tmp); + tmp = gfc_finish_block (&body); + + /* Generate body and loops according to the information in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (block, tmp); + } + else + { + gfc_init_loopinfo (&loop); + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, rss); + + /* Setup the scalarizing loops and bounds. */ + gfc_conv_ss_startstride (&loop); + + gfc_conv_loop_setup (&loop, &expr2->where); + + info = &rss->info->data.array; + desc = info->descriptor; + + /* Make a new descriptor. */ + parmtype = gfc_get_element_type (TREE_TYPE (desc)); + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, + loop.from, loop.to, 1, + GFC_ARRAY_UNKNOWN, true); + + /* Allocate temporary for nested forall construct. */ + tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, + inner_size, NULL, block, &ptemp1); + gfc_start_block (&body); + gfc_init_se (&lse, NULL); + lse.expr = gfc_build_array_ref (tmp1, count, NULL); + lse.direct_byref = 1; + gfc_conv_expr_descriptor (&lse, expr2); + + gfc_add_block_to_block (&body, &lse.pre); + gfc_add_block_to_block (&body, &lse.post); + + /* Increment count. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); + gfc_add_modify (&body, count, tmp); + + tmp = gfc_finish_block (&body); + + /* Generate body and loops according to the information in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (block, tmp); + + /* Reset count. */ + gfc_add_modify (block, count, gfc_index_zero_node); + + parm = gfc_build_array_ref (tmp1, count, NULL); + gfc_init_se (&lse, NULL); + gfc_conv_expr_descriptor (&lse, expr1); + gfc_add_modify (&lse.pre, lse.expr, parm); + gfc_start_block (&body); + gfc_add_block_to_block (&body, &lse.pre); + gfc_add_block_to_block (&body, &lse.post); + + /* Increment count. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); + gfc_add_modify (&body, count, tmp); + + tmp = gfc_finish_block (&body); + + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (block, tmp); + } + /* Free the temporary. */ + if (ptemp1) + { + tmp = gfc_call_free (ptemp1); + gfc_add_expr_to_block (block, tmp); + } +} + + +/* FORALL and WHERE statements are really nasty, especially when you nest + them. All the rhs of a forall assignment must be evaluated before the + actual assignments are performed. Presumably this also applies to all the + assignments in an inner where statement. */ + +/* Generate code for a FORALL statement. Any temporaries are allocated as a + linear array, relying on the fact that we process in the same order in all + loops. + + forall (i=start:end:stride; maskexpr) + e = f + g = h + end forall + (where e,f,g,h are arbitrary expressions possibly involving i) + Translates to: + count = ((end + 1 - start) / stride) + masktmp(:) = maskexpr(:) + + maskindex = 0; + for (i = start; i <= end; i += stride) + { + if (masktmp[maskindex++]) + e = f + } + maskindex = 0; + for (i = start; i <= end; i += stride) + { + if (masktmp[maskindex++]) + g = h + } + + Note that this code only works when there are no dependencies. + Forall loop with array assignments and data dependencies are a real pain, + because the size of the temporary cannot always be determined before the + loop is executed. This problem is compounded by the presence of nested + FORALL constructs. + */ + +static tree +gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) +{ + stmtblock_t pre; + stmtblock_t post; + stmtblock_t block; + stmtblock_t body; + tree *var; + tree *start; + tree *end; + tree *step; + gfc_expr **varexpr; + tree tmp; + tree assign; + tree size; + tree maskindex; + tree mask; + tree pmask; + tree cycle_label = NULL_TREE; + int n; + int nvar; + int need_temp; + gfc_forall_iterator *fa; + gfc_se se; + gfc_code *c; + gfc_saved_var *saved_vars; + iter_info *this_forall; + forall_info *info; + bool need_mask; + + /* Do nothing if the mask is false. */ + if (code->expr1 + && code->expr1->expr_type == EXPR_CONSTANT + && !code->expr1->value.logical) + return build_empty_stmt (input_location); + + n = 0; + /* Count the FORALL index number. */ + for (fa = code->ext.forall_iterator; fa; fa = fa->next) + n++; + nvar = n; + + /* Allocate the space for var, start, end, step, varexpr. */ + var = XCNEWVEC (tree, nvar); + start = XCNEWVEC (tree, nvar); + end = XCNEWVEC (tree, nvar); + step = XCNEWVEC (tree, nvar); + varexpr = XCNEWVEC (gfc_expr *, nvar); + saved_vars = XCNEWVEC (gfc_saved_var, nvar); + + /* Allocate the space for info. */ + info = XCNEW (forall_info); + + gfc_start_block (&pre); + gfc_init_block (&post); + gfc_init_block (&block); + + n = 0; + for (fa = code->ext.forall_iterator; fa; fa = fa->next) + { + gfc_symbol *sym = fa->var->symtree->n.sym; + + /* Allocate space for this_forall. */ + this_forall = XCNEW (iter_info); + + /* Create a temporary variable for the FORALL index. */ + tmp = gfc_typenode_for_spec (&sym->ts); + var[n] = gfc_create_var (tmp, sym->name); + gfc_shadow_sym (sym, var[n], &saved_vars[n]); + + /* Record it in this_forall. */ + this_forall->var = var[n]; + + /* Replace the index symbol's backend_decl with the temporary decl. */ + sym->backend_decl = var[n]; + + /* Work out the start, end and stride for the loop. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, fa->start); + /* Record it in this_forall. */ + this_forall->start = se.expr; + gfc_add_block_to_block (&block, &se.pre); + start[n] = se.expr; + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, fa->end); + /* Record it in this_forall. */ + this_forall->end = se.expr; + gfc_make_safe_expr (&se); + gfc_add_block_to_block (&block, &se.pre); + end[n] = se.expr; + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, fa->stride); + /* Record it in this_forall. */ + this_forall->step = se.expr; + gfc_make_safe_expr (&se); + gfc_add_block_to_block (&block, &se.pre); + step[n] = se.expr; + + /* Set the NEXT field of this_forall to NULL. */ + this_forall->next = NULL; + /* Link this_forall to the info construct. */ + if (info->this_loop) + { + iter_info *iter_tmp = info->this_loop; + while (iter_tmp->next != NULL) + iter_tmp = iter_tmp->next; + iter_tmp->next = this_forall; + } + else + info->this_loop = this_forall; + + n++; + } + nvar = n; + + /* Calculate the size needed for the current forall level. */ + size = gfc_index_one_node; + for (n = 0; n < nvar; n++) + { + /* size = (end + step - start) / step. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), + step[n], start[n]); + tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), + end[n], tmp); + tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp), + tmp, step[n]); + tmp = convert (gfc_array_index_type, tmp); + + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, tmp); + } + + /* Record the nvar and size of current forall level. */ + info->nvar = nvar; + info->size = size; + + if (code->expr1) + { + /* If the mask is .true., consider the FORALL unconditional. */ + if (code->expr1->expr_type == EXPR_CONSTANT + && code->expr1->value.logical) + need_mask = false; + else + need_mask = true; + } + else + need_mask = false; + + /* First we need to allocate the mask. */ + if (need_mask) + { + /* As the mask array can be very big, prefer compact boolean types. */ + tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); + mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type, + size, NULL, &block, &pmask); + maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); + + /* Record them in the info structure. */ + info->maskindex = maskindex; + info->mask = mask; + } + else + { + /* No mask was specified. */ + maskindex = NULL_TREE; + mask = pmask = NULL_TREE; + } + + /* Link the current forall level to nested_forall_info. */ + info->prev_nest = nested_forall_info; + nested_forall_info = info; + + /* Copy the mask into a temporary variable if required. + For now we assume a mask temporary is needed. */ + if (need_mask) + { + /* As the mask array can be very big, prefer compact boolean types. */ + tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); + + gfc_add_modify (&block, maskindex, gfc_index_zero_node); + + /* Start of mask assignment loop body. */ + gfc_start_block (&body); + + /* Evaluate the mask expression. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->expr1); + gfc_add_block_to_block (&body, &se.pre); + + /* Store the mask. */ + se.expr = convert (mask_type, se.expr); + + tmp = gfc_build_array_ref (mask, maskindex, NULL); + gfc_add_modify (&body, tmp, se.expr); + + /* Advance to the next mask element. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + maskindex, gfc_index_one_node); + gfc_add_modify (&body, maskindex, tmp); + + /* Generate the loops. */ + tmp = gfc_finish_block (&body); + tmp = gfc_trans_nested_forall_loop (info, tmp, 0); + gfc_add_expr_to_block (&block, tmp); + } + + if (code->op == EXEC_DO_CONCURRENT) + { + gfc_init_block (&body); + cycle_label = gfc_build_label_decl (NULL_TREE); + code->cycle_label = cycle_label; + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&body, tmp); + + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + nested_forall_info->do_concurrent = true; + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (&block, tmp); + goto done; + } + + c = code->block->next; + + /* TODO: loop merging in FORALL statements. */ + /* Now that we've got a copy of the mask, generate the assignment loops. */ + while (c) + { + switch (c->op) + { + case EXEC_ASSIGN: + /* A scalar or array assignment. DO the simple check for + lhs to rhs dependencies. These make a temporary for the + rhs and form a second forall block to copy to variable. */ + need_temp = check_forall_dependencies(c, &pre, &post); + + /* Temporaries due to array assignment data dependencies introduce + no end of problems. */ + if (need_temp || flag_test_forall_temp) + gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false, + nested_forall_info, &block); + else + { + /* Use the normal assignment copying routines. */ + assign = gfc_trans_assignment (c->expr1, c->expr2, false, true); + + /* Generate body and loops. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, + assign, 1); + gfc_add_expr_to_block (&block, tmp); + } + + /* Cleanup any temporary symtrees that have been made to deal + with dependencies. */ + if (new_symtree) + cleanup_forall_symtrees (c); + + break; + + case EXEC_WHERE: + /* Translate WHERE or WHERE construct nested in FORALL. */ + gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block); + break; + + /* Pointer assignment inside FORALL. */ + case EXEC_POINTER_ASSIGN: + need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); + /* Avoid cases where a temporary would never be needed and where + the temp code is guaranteed to fail. */ + if (need_temp + || (flag_test_forall_temp + && c->expr2->expr_type != EXPR_CONSTANT + && c->expr2->expr_type != EXPR_NULL)) + gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2, + nested_forall_info, &block); + else + { + /* Use the normal assignment copying routines. */ + assign = gfc_trans_pointer_assignment (c->expr1, c->expr2); + + /* Generate body and loops. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, + assign, 1); + gfc_add_expr_to_block (&block, tmp); + } + break; + + case EXEC_FORALL: + tmp = gfc_trans_forall_1 (c, nested_forall_info); + gfc_add_expr_to_block (&block, tmp); + break; + + /* Explicit subroutine calls are prevented by the frontend but interface + assignments can legitimately produce them. */ + case EXEC_ASSIGN_CALL: + assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false); + tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); + gfc_add_expr_to_block (&block, tmp); + break; + + default: + gcc_unreachable (); + } + + c = c->next; + } + +done: + /* Restore the original index variables. */ + for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) + gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); + + /* Free the space for var, start, end, step, varexpr. */ + free (var); + free (start); + free (end); + free (step); + free (varexpr); + free (saved_vars); + + for (this_forall = info->this_loop; this_forall;) + { + iter_info *next = this_forall->next; + free (this_forall); + this_forall = next; + } + + /* Free the space for this forall_info. */ + free (info); + + if (pmask) + { + /* Free the temporary for the mask. */ + tmp = gfc_call_free (pmask); + gfc_add_expr_to_block (&block, tmp); + } + if (maskindex) + pushdecl (maskindex); + + gfc_add_block_to_block (&pre, &block); + gfc_add_block_to_block (&pre, &post); + + return gfc_finish_block (&pre); +} + + +/* Translate the FORALL statement or construct. */ + +tree gfc_trans_forall (gfc_code * code) +{ + return gfc_trans_forall_1 (code, NULL); +} + + +/* Translate the DO CONCURRENT construct. */ + +tree gfc_trans_do_concurrent (gfc_code * code) +{ + return gfc_trans_forall_1 (code, NULL); +} + + +/* Evaluate the WHERE mask expression, copy its value to a temporary. + If the WHERE construct is nested in FORALL, compute the overall temporary + needed by the WHERE mask expression multiplied by the iterator number of + the nested forall. + ME is the WHERE mask expression. + MASK is the current execution mask upon input, whose sense may or may + not be inverted as specified by the INVERT argument. + CMASK is the updated execution mask on output, or NULL if not required. + PMASK is the pending execution mask on output, or NULL if not required. + BLOCK is the block in which to place the condition evaluation loops. */ + +static void +gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, + tree mask, bool invert, tree cmask, tree pmask, + tree mask_type, stmtblock_t * block) +{ + tree tmp, tmp1; + gfc_ss *lss, *rss; + gfc_loopinfo loop; + stmtblock_t body, body1; + tree count, cond, mtmp; + gfc_se lse, rse; + + gfc_init_loopinfo (&loop); + + lss = gfc_walk_expr (me); + rss = gfc_walk_expr (me); + + /* Variable to index the temporary. */ + count = gfc_create_var (gfc_array_index_type, "count"); + /* Initialize count. */ + gfc_add_modify (block, count, gfc_index_zero_node); + + gfc_start_block (&body); + + gfc_init_se (&rse, NULL); + gfc_init_se (&lse, NULL); + + if (lss == gfc_ss_terminator) + { + gfc_init_block (&body1); + } + else + { + /* Initialize the loop. */ + gfc_init_loopinfo (&loop); + + /* We may need LSS to determine the shape of the expression. */ + gfc_add_ss_to_loop (&loop, lss); + gfc_add_ss_to_loop (&loop, rss); + + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &me->where); + + gfc_mark_ss_chain_used (rss, 1); + /* Start the loop body. */ + gfc_start_scalarized_body (&loop, &body1); + + /* Translate the expression. */ + gfc_copy_loopinfo_to_se (&rse, &loop); + rse.ss = rss; + gfc_conv_expr (&rse, me); + } + + /* Variable to evaluate mask condition. */ + cond = gfc_create_var (mask_type, "cond"); + if (mask && (cmask || pmask)) + mtmp = gfc_create_var (mask_type, "mask"); + else mtmp = NULL_TREE; + + gfc_add_block_to_block (&body1, &lse.pre); + gfc_add_block_to_block (&body1, &rse.pre); + + gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr)); + + if (mask && (cmask || pmask)) + { + tmp = gfc_build_array_ref (mask, count, NULL); + if (invert) + tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp); + gfc_add_modify (&body1, mtmp, tmp); + } + + if (cmask) + { + tmp1 = gfc_build_array_ref (cmask, count, NULL); + tmp = cond; + if (mask) + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, + mtmp, tmp); + gfc_add_modify (&body1, tmp1, tmp); + } + + if (pmask) + { + tmp1 = gfc_build_array_ref (pmask, count, NULL); + tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond); + if (mask) + tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp, + tmp); + gfc_add_modify (&body1, tmp1, tmp); + } + + gfc_add_block_to_block (&body1, &lse.post); + gfc_add_block_to_block (&body1, &rse.post); + + if (lss == gfc_ss_terminator) + { + gfc_add_block_to_block (&body, &body1); + } + else + { + /* Increment count. */ + tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count, gfc_index_one_node); + gfc_add_modify (&body1, count, tmp1); + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &body1); + + gfc_add_block_to_block (&body, &loop.pre); + gfc_add_block_to_block (&body, &loop.post); + + gfc_cleanup_loop (&loop); + /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful + as tree nodes in SS may not be valid in different scope. */ + } + + tmp1 = gfc_finish_block (&body); + /* If the WHERE construct is inside FORALL, fill the full temporary. */ + if (nested_forall_info != NULL) + tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1); + + gfc_add_expr_to_block (block, tmp1); +} + + +/* Translate an assignment statement in a WHERE statement or construct + statement. The MASK expression is used to control which elements + of EXPR1 shall be assigned. The sense of MASK is specified by + INVERT. */ + +static tree +gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, + tree mask, bool invert, + tree count1, tree count2, + gfc_code *cnext) +{ + 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; + tree index, maskexpr; + + /* A defined assignment. */ + if (cnext && cnext->resolved_sym) + return gfc_trans_call (cnext, true, mask, count1, invert); + +#if 0 + /* TODO: handle this special case. + 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; + } +#endif + + /* 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); + rss = NULL; + + /* In each where-assign-stmt, the mask-expr and the variable being + defined shall be arrays of the same shape. */ + gcc_assert (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); + rss->info->where = 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); + + /* Resolve any data dependencies in the statement. */ + gfc_conv_resolve_dependencies (&loop, lss_section, 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); + } + + /* Start the scalarized loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* Translate the expression. */ + gfc_conv_expr (&rse, expr2); + if (lss != gfc_ss_terminator && loop.temp_ss != NULL) + gfc_conv_tmp_array_ref (&lse); + else + gfc_conv_expr (&lse, expr1); + + /* Form the mask expression according to the mask. */ + index = count1; + maskexpr = gfc_build_array_ref (mask, index, NULL); + if (invert) + maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (maskexpr), maskexpr); + + /* Use the scalar assignment as is. */ + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + false, loop.temp_ss == NULL); + + tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&body, tmp); + + if (lss == gfc_ss_terminator) + { + /* Increment count1. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + count1, gfc_index_one_node); + gfc_add_modify (&body, count1, tmp); + + /* 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 (loop.temp_ss != NULL) + { + /* Increment count1 before finish the main body of a scalarized + expression. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, count1, gfc_index_one_node); + gfc_add_modify (&body, count1, tmp); + 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); + + /* Form the mask expression according to the mask tree list. */ + index = count2; + maskexpr = gfc_build_array_ref (mask, index, NULL); + if (invert) + maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + TREE_TYPE (maskexpr), maskexpr); + + /* Use the scalar assignment as is. */ + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true); + tmp = build3_v (COND_EXPR, maskexpr, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + + /* Increment count2. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, count2, + gfc_index_one_node); + gfc_add_modify (&body, count2, tmp); + } + else + { + /* Increment count1. */ + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, count1, + gfc_index_one_node); + gfc_add_modify (&body, count1, tmp); + } + + /* 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); +} + + +/* Translate the WHERE construct or statement. + This function can be called iteratively to translate the nested WHERE + construct or statement. + MASK is the control mask. */ + +static void +gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, + forall_info * nested_forall_info, stmtblock_t * block) +{ + stmtblock_t inner_size_body; + tree inner_size, size; + gfc_ss *lss, *rss; + tree mask_type; + gfc_expr *expr1; + gfc_expr *expr2; + gfc_code *cblock; + gfc_code *cnext; + tree tmp; + tree cond; + tree count1, count2; + bool need_cmask; + bool need_pmask; + int need_temp; + tree pcmask = NULL_TREE; + tree ppmask = NULL_TREE; + tree cmask = NULL_TREE; + tree pmask = NULL_TREE; + gfc_actual_arglist *arg; + + /* the WHERE statement or the WHERE construct statement. */ + cblock = code->block; + + /* As the mask array can be very big, prefer compact boolean types. */ + mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); + + /* Determine which temporary masks are needed. */ + if (!cblock->block) + { + /* One clause: No ELSEWHEREs. */ + need_cmask = (cblock->next != 0); + need_pmask = false; + } + else if (cblock->block->block) + { + /* Three or more clauses: Conditional ELSEWHEREs. */ + need_cmask = true; + need_pmask = true; + } + else if (cblock->next) + { + /* Two clauses, the first non-empty. */ + need_cmask = true; + need_pmask = (mask != NULL_TREE + && cblock->block->next != 0); + } + else if (!cblock->block->next) + { + /* Two clauses, both empty. */ + need_cmask = false; + need_pmask = false; + } + /* Two clauses, the first empty, the second non-empty. */ + else if (mask) + { + need_cmask = (cblock->block->expr1 != 0); + need_pmask = true; + } + else + { + need_cmask = true; + need_pmask = false; + } + + if (need_cmask || need_pmask) + { + /* Calculate the size of temporary needed by the mask-expr. */ + gfc_init_block (&inner_size_body); + inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1, + &inner_size_body, &lss, &rss); + + gfc_free_ss_chain (lss); + gfc_free_ss_chain (rss); + + /* Calculate the total size of temporary needed. */ + size = compute_overall_iter_number (nested_forall_info, inner_size, + &inner_size_body, block); + + /* Check whether the size is negative. */ + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size, + gfc_index_zero_node); + size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, + cond, gfc_index_zero_node, size); + size = gfc_evaluate_now (size, block); + + /* Allocate temporary for WHERE mask if needed. */ + if (need_cmask) + cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, + &pcmask); + + /* Allocate temporary for !mask if needed. */ + if (need_pmask) + pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, + &ppmask); + } + + while (cblock) + { + /* Each time around this loop, the where clause is conditional + on the value of mask and invert, which are updated at the + bottom of the loop. */ + + /* Has mask-expr. */ + if (cblock->expr1) + { + /* Ensure that the WHERE mask will be evaluated exactly once. + If there are no statements in this WHERE/ELSEWHERE clause, + then we don't need to update the control mask (cmask). + If this is the last clause of the WHERE construct, then + we don't need to update the pending control mask (pmask). */ + if (mask) + gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, + mask, invert, + cblock->next ? cmask : NULL_TREE, + cblock->block ? pmask : NULL_TREE, + mask_type, block); + else + gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, + NULL_TREE, false, + (cblock->next || cblock->block) + ? cmask : NULL_TREE, + NULL_TREE, mask_type, block); + + invert = false; + } + /* It's a final elsewhere-stmt. No mask-expr is present. */ + else + cmask = mask; + + /* The body of this where clause are controlled by cmask with + sense specified by invert. */ + + /* Get the assignment statement of a WHERE statement, or the first + statement in where-body-construct of a WHERE construct. */ + cnext = cblock->next; + while (cnext) + { + switch (cnext->op) + { + /* WHERE assignment statement. */ + case EXEC_ASSIGN_CALL: + + arg = cnext->ext.actual; + expr1 = expr2 = NULL; + for (; arg; arg = arg->next) + { + if (!arg->expr) + continue; + if (expr1 == NULL) + expr1 = arg->expr; + else + expr2 = arg->expr; + } + goto evaluate; + + case EXEC_ASSIGN: + expr1 = cnext->expr1; + expr2 = cnext->expr2; + evaluate: + if (nested_forall_info != NULL) + { + need_temp = gfc_check_dependency (expr1, expr2, 0); + if ((need_temp || flag_test_forall_temp) + && cnext->op != EXEC_ASSIGN_CALL) + gfc_trans_assign_need_temp (expr1, expr2, + cmask, invert, + nested_forall_info, block); + else + { + /* Variables to control maskexpr. */ + count1 = gfc_create_var (gfc_array_index_type, "count1"); + count2 = gfc_create_var (gfc_array_index_type, "count2"); + gfc_add_modify (block, count1, gfc_index_zero_node); + gfc_add_modify (block, count2, gfc_index_zero_node); + + tmp = gfc_trans_where_assign (expr1, expr2, + cmask, invert, + count1, count2, + cnext); + + tmp = gfc_trans_nested_forall_loop (nested_forall_info, + tmp, 1); + gfc_add_expr_to_block (block, tmp); + } + } + else + { + /* Variables to control maskexpr. */ + count1 = gfc_create_var (gfc_array_index_type, "count1"); + count2 = gfc_create_var (gfc_array_index_type, "count2"); + gfc_add_modify (block, count1, gfc_index_zero_node); + gfc_add_modify (block, count2, gfc_index_zero_node); + + tmp = gfc_trans_where_assign (expr1, expr2, + cmask, invert, + count1, count2, + cnext); + gfc_add_expr_to_block (block, tmp); + + } + break; + + /* WHERE or WHERE construct is part of a where-body-construct. */ + case EXEC_WHERE: + gfc_trans_where_2 (cnext, cmask, invert, + nested_forall_info, block); + break; + + default: + gcc_unreachable (); + } + + /* The next statement within the same where-body-construct. */ + cnext = cnext->next; + } + /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ + cblock = cblock->block; + if (mask == NULL_TREE) + { + /* If we're the initial WHERE, we can simply invert the sense + of the current mask to obtain the "mask" for the remaining + ELSEWHEREs. */ + invert = true; + mask = cmask; + } + else + { + /* Otherwise, for nested WHERE's we need to use the pending mask. */ + invert = false; + mask = pmask; + } + } + + /* If we allocated a pending mask array, deallocate it now. */ + if (ppmask) + { + tmp = gfc_call_free (ppmask); + gfc_add_expr_to_block (block, tmp); + } + + /* If we allocated a current mask array, deallocate it now. */ + if (pcmask) + { + tmp = gfc_call_free (pcmask); + gfc_add_expr_to_block (block, tmp); + } +} + +/* Translate a simple WHERE construct or statement without dependencies. + CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR + is the mask condition, and EBLOCK if non-NULL is the "else" clause. + Currently both CBLOCK and EBLOCK are restricted to single assignments. */ + +static tree +gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) +{ + stmtblock_t block, body; + gfc_expr *cond, *tdst, *tsrc, *edst, *esrc; + tree tmp, cexpr, tstmt, estmt; + gfc_ss *css, *tdss, *tsss; + gfc_se cse, tdse, tsse, edse, esse; + gfc_loopinfo loop; + gfc_ss *edss = 0; + gfc_ss *esss = 0; + bool maybe_workshare = false; + + /* Allow the scalarizer to workshare simple where loops. */ + if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY)) + == OMPWS_WORKSHARE_FLAG) + { + maybe_workshare = true; + ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; + } + + cond = cblock->expr1; + tdst = cblock->next->expr1; + tsrc = cblock->next->expr2; + edst = eblock ? eblock->next->expr1 : NULL; + esrc = eblock ? eblock->next->expr2 : NULL; + + gfc_start_block (&block); + gfc_init_loopinfo (&loop); + + /* Handle the condition. */ + gfc_init_se (&cse, NULL); + css = gfc_walk_expr (cond); + gfc_add_ss_to_loop (&loop, css); + + /* Handle the then-clause. */ + gfc_init_se (&tdse, NULL); + gfc_init_se (&tsse, NULL); + tdss = gfc_walk_expr (tdst); + tsss = gfc_walk_expr (tsrc); + if (tsss == gfc_ss_terminator) + { + tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc); + tsss->info->where = 1; + } + gfc_add_ss_to_loop (&loop, tdss); + gfc_add_ss_to_loop (&loop, tsss); + + if (eblock) + { + /* Handle the else clause. */ + gfc_init_se (&edse, NULL); + gfc_init_se (&esse, NULL); + edss = gfc_walk_expr (edst); + esss = gfc_walk_expr (esrc); + if (esss == gfc_ss_terminator) + { + esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc); + esss->info->where = 1; + } + gfc_add_ss_to_loop (&loop, edss); + gfc_add_ss_to_loop (&loop, esss); + } + + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &tdst->where); + + gfc_mark_ss_chain_used (css, 1); + gfc_mark_ss_chain_used (tdss, 1); + gfc_mark_ss_chain_used (tsss, 1); + if (eblock) + { + gfc_mark_ss_chain_used (edss, 1); + gfc_mark_ss_chain_used (esss, 1); + } + + gfc_start_scalarized_body (&loop, &body); + + gfc_copy_loopinfo_to_se (&cse, &loop); + gfc_copy_loopinfo_to_se (&tdse, &loop); + gfc_copy_loopinfo_to_se (&tsse, &loop); + cse.ss = css; + tdse.ss = tdss; + tsse.ss = tsss; + if (eblock) + { + gfc_copy_loopinfo_to_se (&edse, &loop); + gfc_copy_loopinfo_to_se (&esse, &loop); + edse.ss = edss; + esse.ss = esss; + } + + gfc_conv_expr (&cse, cond); + gfc_add_block_to_block (&body, &cse.pre); + cexpr = cse.expr; + + gfc_conv_expr (&tsse, tsrc); + if (tdss != gfc_ss_terminator && loop.temp_ss != NULL) + gfc_conv_tmp_array_ref (&tdse); + else + gfc_conv_expr (&tdse, tdst); + + if (eblock) + { + gfc_conv_expr (&esse, esrc); + if (edss != gfc_ss_terminator && loop.temp_ss != NULL) + gfc_conv_tmp_array_ref (&edse); + else + gfc_conv_expr (&edse, edst); + } + + tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true); + estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, + false, true) + : build_empty_stmt (input_location); + tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); + gfc_add_expr_to_block (&body, tmp); + gfc_add_block_to_block (&body, &cse.post); + + if (maybe_workshare) + ompws_flags &= ~OMPWS_SCALARIZER_BODY; + gfc_trans_scalarizing_loops (&loop, &body); + 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); +} + +/* As the WHERE or WHERE construct statement can be nested, we call + gfc_trans_where_2 to do the translation, and pass the initial + NULL values for both the control mask and the pending control mask. */ + +tree +gfc_trans_where (gfc_code * code) +{ + stmtblock_t block; + gfc_code *cblock; + gfc_code *eblock; + + cblock = code->block; + if (cblock->next + && cblock->next->op == EXEC_ASSIGN + && !cblock->next->next) + { + eblock = cblock->block; + if (!eblock) + { + /* A simple "WHERE (cond) x = y" statement or block is + dependence free if cond is not dependent upon writing x, + and the source y is unaffected by the destination x. */ + if (!gfc_check_dependency (cblock->next->expr1, + cblock->expr1, 0) + && !gfc_check_dependency (cblock->next->expr1, + cblock->next->expr2, 0)) + return gfc_trans_where_3 (cblock, NULL); + } + else if (!eblock->expr1 + && !eblock->block + && eblock->next + && eblock->next->op == EXEC_ASSIGN + && !eblock->next->next) + { + /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE" + block is dependence free if cond is not dependent on writes + to x1 and x2, y1 is not dependent on writes to x2, and y2 + is not dependent on writes to x1, and both y's are not + dependent upon their own x's. In addition to this, the + final two dependency checks below exclude all but the same + array reference if the where and elswhere destinations + are the same. In short, this is VERY conservative and this + is needed because the two loops, required by the standard + are coalesced in gfc_trans_where_3. */ + if (!gfc_check_dependency (cblock->next->expr1, + cblock->expr1, 0) + && !gfc_check_dependency (eblock->next->expr1, + cblock->expr1, 0) + && !gfc_check_dependency (cblock->next->expr1, + eblock->next->expr2, 1) + && !gfc_check_dependency (eblock->next->expr1, + cblock->next->expr2, 1) + && !gfc_check_dependency (cblock->next->expr1, + cblock->next->expr2, 1) + && !gfc_check_dependency (eblock->next->expr1, + eblock->next->expr2, 1) + && !gfc_check_dependency (cblock->next->expr1, + eblock->next->expr1, 0) + && !gfc_check_dependency (eblock->next->expr1, + cblock->next->expr1, 0)) + return gfc_trans_where_3 (cblock, eblock); + } + } + + gfc_start_block (&block); + + gfc_trans_where_2 (code, NULL, false, NULL, &block); + + return gfc_finish_block (&block); +} + + +/* CYCLE a DO loop. The label decl has already been created by + gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code + node at the head of the loop. We must mark the label as used. */ + +tree +gfc_trans_cycle (gfc_code * code) +{ + tree cycle_label; + + cycle_label = code->ext.which_construct->cycle_label; + gcc_assert (cycle_label); + + TREE_USED (cycle_label) = 1; + return build1_v (GOTO_EXPR, cycle_label); +} + + +/* EXIT a DO loop. Similar to CYCLE, but now the label is in + TREE_VALUE (backend_decl) of the gfc_code node at the head of the + loop. */ + +tree +gfc_trans_exit (gfc_code * code) +{ + tree exit_label; + + exit_label = code->ext.which_construct->exit_label; + gcc_assert (exit_label); + + TREE_USED (exit_label) = 1; + return build1_v (GOTO_EXPR, exit_label); +} + + +/* Get the initializer expression for the code and expr of an allocate. + When no initializer is needed return NULL. */ + +static gfc_expr * +allocate_get_initializer (gfc_code * code, gfc_expr * expr) +{ + if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS) + return NULL; + + /* An explicit type was given in allocate ( T:: object). */ + if (code->ext.alloc.ts.type == BT_DERIVED + && (code->ext.alloc.ts.u.derived->attr.alloc_comp + || gfc_has_default_initializer (code->ext.alloc.ts.u.derived))) + return gfc_default_initializer (&code->ext.alloc.ts); + + if (gfc_bt_struct (expr->ts.type) + && (expr->ts.u.derived->attr.alloc_comp + || gfc_has_default_initializer (expr->ts.u.derived))) + return gfc_default_initializer (&expr->ts); + + if (expr->ts.type == BT_CLASS + && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp + || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived))) + return gfc_default_initializer (&CLASS_DATA (expr)->ts); + + return NULL; +} + +/* Translate the ALLOCATE statement. */ + +tree +gfc_trans_allocate (gfc_code * code) +{ + gfc_alloc *al; + gfc_expr *expr, *e3rhs = NULL, *init_expr; + gfc_se se, se_sz; + tree tmp; + tree parm; + tree stat; + tree errmsg; + tree errlen; + tree label_errmsg; + tree label_finish; + tree memsz; + tree al_vptr, al_len; + /* If an expr3 is present, then store the tree for accessing its + _vptr, and _len components in the variables, respectively. The + element size, i.e. _vptr%size, is stored in expr3_esize. Any of + the trees may be the NULL_TREE indicating that this is not + available for expr3's type. */ + tree expr3, expr3_vptr, expr3_len, expr3_esize; + /* Classify what expr3 stores. */ + enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; + stmtblock_t block; + stmtblock_t post; + stmtblock_t final_block; + tree nelems; + bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray; + bool needs_caf_sync, caf_refs_comp; + bool e3_has_nodescriptor = false; + gfc_symtree *newsym = NULL; + symbol_attribute caf_attr; + gfc_actual_arglist *param_list; + + if (!code->ext.alloc.list) + return NULL_TREE; + + stat = tmp = memsz = al_vptr = al_len = NULL_TREE; + expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; + label_errmsg = label_finish = errmsg = errlen = NULL_TREE; + e3_is = E3_UNSET; + is_coarray = needs_caf_sync = false; + + gfc_init_block (&block); + gfc_init_block (&post); + gfc_init_block (&final_block); + + /* STAT= (and maybe ERRMSG=) is present. */ + if (code->expr1) + { + /* STAT=. */ + tree gfc_int4_type_node = gfc_get_int_type (4); + stat = gfc_create_var (gfc_int4_type_node, "stat"); + + /* ERRMSG= only makes sense with STAT=. */ + if (code->expr2) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr_lhs (&se, code->expr2); + errmsg = se.expr; + errlen = se.string_length; + } + else + { + errmsg = null_pointer_node; + errlen = build_int_cst (gfc_charlen_type_node, 0); + } + + /* GOTO destinations. */ + label_errmsg = gfc_build_label_decl (NULL_TREE); + label_finish = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_finish) = 0; + } + + /* When an expr3 is present evaluate it only once. The standards prevent a + dependency of expr3 on the objects in the allocate list. An expr3 can + be pre-evaluated in all cases. One just has to make sure, to use the + correct way, i.e., to get the descriptor or to get a reference + expression. */ + if (code->expr3) + { + bool vtab_needed = false, temp_var_needed = false, + temp_obj_created = false; + + is_coarray = gfc_is_coarray (code->expr3); + + if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold + && (gfc_is_class_array_function (code->expr3) + || gfc_is_alloc_class_scalar_function (code->expr3))) + code->expr3->must_finalize = 1; + + /* Figure whether we need the vtab from expr3. */ + for (al = code->ext.alloc.list; !vtab_needed && al != NULL; + al = al->next) + vtab_needed = (al->expr->ts.type == BT_CLASS); + + gfc_init_se (&se, NULL); + /* When expr3 is a variable, i.e., a very simple expression, + then convert it once here. */ + if (code->expr3->expr_type == EXPR_VARIABLE + || code->expr3->expr_type == EXPR_ARRAY + || code->expr3->expr_type == EXPR_CONSTANT) + { + if (!code->expr3->mold + || code->expr3->ts.type == BT_CHARACTER + || vtab_needed + || code->ext.alloc.arr_spec_from_expr3) + { + /* Convert expr3 to a tree. For all "simple" expression just + get the descriptor or the reference, respectively, depending + on the rank of the expr. */ + if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0) + gfc_conv_expr_descriptor (&se, code->expr3); + else + { + gfc_conv_expr_reference (&se, code->expr3); + + /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a + NOP_EXPR, which prevents gfortran from getting the vptr + from the source=-expression. Remove the NOP_EXPR and go + with the POINTER_PLUS_EXPR in this case. */ + if (code->expr3->ts.type == BT_CLASS + && TREE_CODE (se.expr) == NOP_EXPR + && (TREE_CODE (TREE_OPERAND (se.expr, 0)) + == POINTER_PLUS_EXPR + || is_coarray)) + se.expr = TREE_OPERAND (se.expr, 0); + } + /* Create a temp variable only for component refs to prevent + having to go through the full deref-chain each time and to + simplfy computation of array properties. */ + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; + } + } + else + { + /* In all other cases evaluate the expr3. */ + symbol_attribute attr; + /* Get the descriptor for all arrays, that are not allocatable or + pointer, because the latter are descriptors already. + The exception are function calls returning a class object: + The descriptor is stored in their results _data component, which + is easier to access, when first a temporary variable for the + result is created and the descriptor retrieved from there. */ + attr = gfc_expr_attr (code->expr3); + if (code->expr3->rank != 0 + && ((!attr.allocatable && !attr.pointer) + || (code->expr3->expr_type == EXPR_FUNCTION + && (code->expr3->ts.type != BT_CLASS + || (code->expr3->value.function.isym + && code->expr3->value.function.isym + ->transformational))))) + gfc_conv_expr_descriptor (&se, code->expr3); + else + gfc_conv_expr_reference (&se, code->expr3); + if (code->expr3->ts.type == BT_CLASS) + gfc_conv_class_to_class (&se, code->expr3, + code->expr3->ts, + false, true, + false, false); + temp_obj_created = temp_var_needed = !VAR_P (se.expr); + } + gfc_add_block_to_block (&block, &se.pre); + if (code->expr3->must_finalize) + gfc_add_block_to_block (&final_block, &se.post); + else + gfc_add_block_to_block (&post, &se.post); + + /* Special case when string in expr3 is zero. */ + if (code->expr3->ts.type == BT_CHARACTER + && integer_zerop (se.string_length)) + { + gfc_init_se (&se, NULL); + temp_var_needed = false; + expr3_len = build_zero_cst (gfc_charlen_type_node); + e3_is = E3_MOLD; + } + /* Prevent aliasing, i.e., se.expr may be already a + variable declaration. */ + else if (se.expr != NULL_TREE && temp_var_needed) + { + tree var, desc; + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) || is_coarray ? + se.expr + : build_fold_indirect_ref_loc (input_location, se.expr); + + /* Get the array descriptor and prepare it to be assigned to the + temporary variable var. For classes the array descriptor is + in the _data component and the object goes into the + GFC_DECL_SAVED_DESCRIPTOR. */ + if (code->expr3->ts.type == BT_CLASS + && code->expr3->rank != 0) + { + /* When an array_ref was in expr3, then the descriptor is the + first operand. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) + { + desc = TREE_OPERAND (tmp, 0); + } + else + { + desc = tmp; + tmp = gfc_class_data_get (tmp); + } + if (code->ext.alloc.arr_spec_from_expr3) + e3_is = E3_DESC; + } + else + desc = !is_coarray ? se.expr + : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0); + /* We need a regular (non-UID) symbol here, therefore give a + prefix. */ + var = gfc_create_var (TREE_TYPE (tmp), "source"); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) + { + gfc_allocate_lang_decl (var); + GFC_DECL_SAVED_DESCRIPTOR (var) = desc; + } + gfc_add_modify_loc (input_location, &block, var, tmp); + + expr3 = var; + if (se.string_length) + /* Evaluate it assuming that it also is complicated like expr3. */ + expr3_len = gfc_evaluate_now (se.string_length, &block); + } + else + { + expr3 = se.expr; + expr3_len = se.string_length; + } + + /* Deallocate any allocatable components in expressions that use a + temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE. + E.g. temporaries of a function call need freeing of their components + here. */ + if ((code->expr3->ts.type == BT_DERIVED + || code->expr3->ts.type == BT_CLASS) + && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created) + && code->expr3->ts.u.derived->attr.alloc_comp + && !code->expr3->must_finalize) + { + tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, + expr3, code->expr3->rank); + gfc_prepend_expr_to_block (&post, tmp); + } + + /* Store what the expr3 is to be used for. */ + if (e3_is == E3_UNSET) + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; + + /* Figure how to get the _vtab entry. This also obtains the tree + expression for accessing the _len component, because only + unlimited polymorphic objects, which are a subcategory of class + types, have a _len component. */ + if (code->expr3->ts.type == BT_CLASS) + { + gfc_expr *rhs; + tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ? + build_fold_indirect_ref (expr3): expr3; + /* Polymorphic SOURCE: VPTR must be determined at run time. + expr3 may be a temporary array declaration, therefore check for + GFC_CLASS_TYPE_P before trying to get the _vptr component. */ + if (tmp != NULL_TREE + && (e3_is == E3_DESC + || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) + && (VAR_P (tmp) || !code->expr3->ref)) + || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp)))) + tmp = gfc_class_vptr_get (expr3); + else + { + rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); + gfc_add_vptr_component (rhs); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, rhs); + tmp = se.expr; + gfc_free_expr (rhs); + } + /* Set the element size. */ + expr3_esize = gfc_vptr_size_get (tmp); + if (vtab_needed) + expr3_vptr = tmp; + /* Initialize the ref to the _len component. */ + if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3)) + { + /* Same like for retrieving the _vptr. */ + if (expr3 != NULL_TREE && !code->expr3->ref) + expr3_len = gfc_class_len_get (expr3); + else + { + rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); + gfc_add_len_component (rhs); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, rhs); + expr3_len = se.expr; + gfc_free_expr (rhs); + } + } + } + else + { + /* When the object to allocate is polymorphic type, then it + needs its vtab set correctly, so deduce the required _vtab + and _len from the source expression. */ + if (vtab_needed) + { + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + + vtab = gfc_find_vtab (&code->expr3->ts); + gcc_assert (vtab); + expr3_vptr = gfc_get_symbol_decl (vtab); + expr3_vptr = gfc_build_addr_expr (NULL_TREE, + expr3_vptr); + } + /* _len component needs to be set, when ts is a character + array. */ + if (expr3_len == NULL_TREE + && code->expr3->ts.type == BT_CHARACTER) + { + if (code->expr3->ts.u.cl + && code->expr3->ts.u.cl->length) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, code->expr3->ts.u.cl->length); + gfc_add_block_to_block (&block, &se.pre); + expr3_len = gfc_evaluate_now (se.expr, &block); + } + gcc_assert (expr3_len); + } + /* For character arrays only the kind's size is needed, because + the array mem_size is _len * (elem_size = kind_size). + For all other get the element size in the normal way. */ + if (code->expr3->ts.type == BT_CHARACTER) + expr3_esize = TYPE_SIZE_UNIT ( + gfc_get_char_type (code->expr3->ts.kind)); + else + expr3_esize = TYPE_SIZE_UNIT ( + gfc_typenode_for_spec (&code->expr3->ts)); + } + gcc_assert (expr3_esize); + expr3_esize = fold_convert (sizetype, expr3_esize); + if (e3_is == E3_MOLD) + /* The expr3 is no longer valid after this point. */ + expr3 = NULL_TREE; + } + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + { + /* Compute the explicit typespec given only once for all objects + to allocate. */ + if (code->ext.alloc.ts.type != BT_CHARACTER) + expr3_esize = TYPE_SIZE_UNIT ( + gfc_typenode_for_spec (&code->ext.alloc.ts)); + else if (code->ext.alloc.ts.u.cl->length != NULL) + { + gfc_expr *sz; + sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length); + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, sz); + gfc_free_expr (sz); + tmp = gfc_get_char_type (code->ext.alloc.ts.kind); + tmp = TYPE_SIZE_UNIT (tmp); + tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp); + gfc_add_block_to_block (&block, &se_sz.pre); + expr3_esize = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (se_sz.expr), + tmp, se_sz.expr); + expr3_esize = gfc_evaluate_now (expr3_esize, &block); + } + else + expr3_esize = NULL_TREE; + } + + /* The routine gfc_trans_assignment () already implements all + techniques needed. Unfortunately we may have a temporary + variable for the source= expression here. When that is the + case convert this variable into a temporary gfc_expr of type + EXPR_VARIABLE and used it as rhs for the assignment. The + advantage is, that we get scalarizer support for free, + don't have to take care about scalar to array treatment and + will benefit of every enhancements gfc_trans_assignment () + gets. + No need to check whether e3_is is E3_UNSET, because that is + done by expr3 != NULL_TREE. + Exclude variables since the following block does not handle + array sections. In any case, there is no harm in sending + variables to gfc_trans_assignment because there is no + evaluation of variables. */ + if (code->expr3) + { + if (code->expr3->expr_type != EXPR_VARIABLE + && e3_is != E3_MOLD && expr3 != NULL_TREE + && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) + { + /* Build a temporary symtree and symbol. Do not add it to the current + namespace to prevent accidently modifying a colliding + symbol's as. */ + newsym = XCNEW (gfc_symtree); + /* The name of the symtree should be unique, because gfc_create_var () + took care about generating the identifier. */ + newsym->name + = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3))); + newsym->n.sym = gfc_new_symbol (newsym->name, NULL); + /* The backend_decl is known. It is expr3, which is inserted + here. */ + newsym->n.sym->backend_decl = expr3; + e3rhs = gfc_get_expr (); + e3rhs->rank = code->expr3->rank; + e3rhs->symtree = newsym; + /* Mark the symbol referenced or gfc_trans_assignment will bug. */ + newsym->n.sym->attr.referenced = 1; + e3rhs->expr_type = EXPR_VARIABLE; + e3rhs->where = code->expr3->where; + /* Set the symbols type, upto it was BT_UNKNOWN. */ + if (IS_CLASS_ARRAY (code->expr3) + && code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->value.function.isym + && code->expr3->value.function.isym->transformational) + { + e3rhs->ts = CLASS_DATA (code->expr3)->ts; + } + else if (code->expr3->ts.type == BT_CLASS + && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3))) + e3rhs->ts = CLASS_DATA (code->expr3)->ts; + else + e3rhs->ts = code->expr3->ts; + newsym->n.sym->ts = e3rhs->ts; + /* Check whether the expr3 is array valued. */ + if (e3rhs->rank) + { + gfc_array_spec *arr; + arr = gfc_get_array_spec (); + arr->rank = e3rhs->rank; + arr->type = AS_DEFERRED; + /* Set the dimension and pointer attribute for arrays + to be on the safe side. */ + newsym->n.sym->attr.dimension = 1; + newsym->n.sym->attr.pointer = 1; + newsym->n.sym->as = arr; + if (IS_CLASS_ARRAY (code->expr3) + && code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->value.function.isym + && code->expr3->value.function.isym->transformational) + { + gfc_array_spec *tarr; + tarr = gfc_get_array_spec (); + *tarr = *arr; + e3rhs->ts.u.derived->as = tarr; + } + gfc_add_full_array_ref (e3rhs, arr); + } + else if (POINTER_TYPE_P (TREE_TYPE (expr3))) + newsym->n.sym->attr.pointer = 1; + /* The string length is known, too. Set it for char arrays. */ + if (e3rhs->ts.type == BT_CHARACTER) + newsym->n.sym->ts.u.cl->backend_decl = expr3_len; + gfc_commit_symbol (newsym->n.sym); + } + else + e3rhs = gfc_copy_expr (code->expr3); + + // We need to propagate the bounds of the expr3 for source=/mold=. + // However, for non-named arrays, the lbound has to be 1 and neither the + // bound used inside the called function even when returning an + // allocatable/pointer nor the zero used internally. + if (e3_is == E3_DESC + && code->expr3->expr_type != EXPR_VARIABLE) + e3_has_nodescriptor = true; + } + + /* Loop over all objects to allocate. */ + for (al = code->ext.alloc.list; al != NULL; al = al->next) + { + expr = gfc_copy_expr (al->expr); + /* UNLIMITED_POLY () needs the _data component to be set, when + expr is a unlimited polymorphic object. But the _data component + has not been set yet, so check the derived type's attr for the + unlimited polymorphic flag to be safe. */ + upoly_expr = UNLIMITED_POLY (expr) + || (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.unlimited_polymorphic); + gfc_init_se (&se, NULL); + + /* For class types prepare the expressions to ref the _vptr + and the _len component. The latter for unlimited polymorphic + types only. */ + if (expr->ts.type == BT_CLASS) + { + gfc_expr *expr_ref_vptr, *expr_ref_len; + gfc_add_data_component (expr); + /* Prep the vptr handle. */ + expr_ref_vptr = gfc_copy_expr (al->expr); + gfc_add_vptr_component (expr_ref_vptr); + se.want_pointer = 1; + gfc_conv_expr (&se, expr_ref_vptr); + al_vptr = se.expr; + se.want_pointer = 0; + gfc_free_expr (expr_ref_vptr); + /* Allocated unlimited polymorphic objects always have a _len + component. */ + if (upoly_expr) + { + expr_ref_len = gfc_copy_expr (al->expr); + gfc_add_len_component (expr_ref_len); + gfc_conv_expr (&se, expr_ref_len); + al_len = se.expr; + gfc_free_expr (expr_ref_len); + } + else + /* In a loop ensure that all loop variable dependent variables + are initialized at the same spot in all execution paths. */ + al_len = NULL_TREE; + } + else + al_vptr = al_len = NULL_TREE; + + se.want_pointer = 1; + se.descriptor_only = 1; + + gfc_conv_expr (&se, expr); + if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) + /* se.string_length now stores the .string_length variable of expr + needed to allocate character(len=:) arrays. */ + al_len = se.string_length; + + al_len_needs_set = al_len != NULL_TREE; + /* When allocating an array one cannot use much of the + pre-evaluated expr3 expressions, because for most of them the + scalarizer is needed which is not available in the pre-evaluation + step. Therefore gfc_array_allocate () is responsible (and able) + to handle the complete array allocation. Only the element size + needs to be provided, which is done most of the time by the + pre-evaluation step. */ + nelems = NULL_TREE; + if (expr3_len && (code->expr3->ts.type == BT_CHARACTER + || code->expr3->ts.type == BT_CLASS)) + { + /* When al is an array, then the element size for each element + in the array is needed, which is the product of the len and + esize for char arrays. For unlimited polymorphics len can be + zero, therefore take the maximum of len and one. */ + tmp = fold_build2_loc (input_location, MAX_EXPR, + TREE_TYPE (expr3_len), + expr3_len, fold_convert (TREE_TYPE (expr3_len), + integer_one_node)); + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (expr3_esize), expr3_esize, + fold_convert (TREE_TYPE (expr3_esize), tmp)); + } + else + tmp = expr3_esize; + + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, + label_finish, tmp, &nelems, + e3rhs ? e3rhs : code->expr3, + e3_is == E3_DESC ? expr3 : NULL_TREE, + e3_has_nodescriptor)) + { + /* A scalar or derived type. First compute the size to + allocate. + + expr3_len is set when expr3 is an unlimited polymorphic + object or a deferred length string. */ + if (expr3_len != NULL_TREE) + { + tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len); + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (expr3_esize), + expr3_esize, tmp); + if (code->expr3->ts.type != BT_CLASS) + /* expr3 is a deferred length string, i.e., we are + done. */ + memsz = tmp; + else + { + /* For unlimited polymorphic enties build + (len > 0) ? element_size * len : element_size + to compute the number of bytes to allocate. + This allows the allocation of unlimited polymorphic + objects from an expr3 that is also unlimited + polymorphic and stores a _len dependent object, + e.g., a string. */ + memsz = fold_build2_loc (input_location, GT_EXPR, + logical_type_node, expr3_len, + build_zero_cst + (TREE_TYPE (expr3_len))); + memsz = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (expr3_esize), + memsz, tmp, expr3_esize); + } + } + else if (expr3_esize != NULL_TREE) + /* Any other object in expr3 just needs element size in + bytes. */ + memsz = expr3_esize; + else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred) + || (upoly_expr + && code->ext.alloc.ts.type == BT_CHARACTER)) + { + /* Allocating deferred length char arrays need the length + to allocate in the alloc_type_spec. But also unlimited + polymorphic objects may be allocated as char arrays. + Both are handled here. */ + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + gfc_add_block_to_block (&se.pre, &se_sz.pre); + se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); + gfc_add_block_to_block (&se.pre, &se_sz.post); + expr3_len = se_sz.expr; + tmp_expr3_len_flag = true; + tmp = TYPE_SIZE_UNIT ( + gfc_get_char_type (code->ext.alloc.ts.kind)); + memsz = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), + fold_convert (TREE_TYPE (tmp), + expr3_len), + tmp); + } + else if (expr->ts.type == BT_CHARACTER) + { + /* Compute the number of bytes needed to allocate a fixed + length char array. */ + gcc_assert (se.string_length != NULL_TREE); + tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)); + memsz = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (tmp), tmp, + fold_convert (TREE_TYPE (tmp), + se.string_length)); + } + else if (code->ext.alloc.ts.type != BT_UNKNOWN) + /* Handle all types, where the alloc_type_spec is set. */ + memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); + else + /* Handle size computation of the type declared to alloc. */ + memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + + /* Store the caf-attributes for latter use. */ + if (flag_coarray == GFC_FCOARRAY_LIB + && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) + .codimension) + { + /* Scalar allocatable components in coarray'ed derived types make + it here and are treated now. */ + tree caf_decl, token; + gfc_se caf_se; + + is_coarray = true; + /* Set flag, to add synchronize after the allocate. */ + needs_caf_sync = needs_caf_sync + || caf_attr.coarray_comp || !caf_refs_comp; + + gfc_init_se (&caf_se, NULL); + + caf_decl = gfc_get_tree_for_caf_expr (expr); + gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, + NULL_TREE, NULL); + gfc_add_block_to_block (&se.pre, &caf_se.pre); + gfc_allocate_allocatable (&se.pre, se.expr, memsz, + gfc_build_addr_expr (NULL_TREE, token), + NULL_TREE, NULL_TREE, NULL_TREE, + label_finish, expr, 1); + } + /* Allocate - for non-pointers with re-alloc checking. */ + else if (gfc_expr_attr (expr).allocatable) + gfc_allocate_allocatable (&se.pre, se.expr, memsz, + NULL_TREE, stat, errmsg, errlen, + label_finish, expr, 0); + else + gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); + } + else + { + /* Allocating coarrays needs a sync after the allocate executed. + Set the flag to add the sync after all objects are allocated. */ + if (flag_coarray == GFC_FCOARRAY_LIB + && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) + .codimension) + { + is_coarray = true; + needs_caf_sync = needs_caf_sync + || caf_attr.coarray_comp || !caf_refs_comp; + } + + if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE + && expr3_len != NULL_TREE) + { + /* Arrays need to have a _len set before the array + descriptor is filled. */ + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), expr3_len)); + /* Prevent setting the length twice. */ + al_len_needs_set = false; + } + else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE + && code->ext.alloc.ts.u.cl->length) + { + /* Cover the cases where a string length is explicitly + specified by a type spec for deferred length character + arrays or unlimited polymorphic objects without a + source= or mold= expression. */ + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + gfc_add_block_to_block (&block, &se_sz.pre); + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + se_sz.expr)); + al_len_needs_set = false; + } + } + + gfc_add_block_to_block (&block, &se.pre); + + /* Error checking -- Note: ERRMSG only makes sense with STAT. */ + if (code->expr1) + { + tmp = build1_v (GOTO_EXPR, label_errmsg); + parm = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + + /* Set the vptr only when no source= is set. When source= is set, then + the trans_assignment below will set the vptr. */ + if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold)) + { + if (expr3_vptr != NULL_TREE) + /* The vtab is already known, so just assign it. */ + gfc_add_modify (&block, al_vptr, + fold_convert (TREE_TYPE (al_vptr), expr3_vptr)); + else + { + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + gfc_typespec *ts; + + if (code->expr3) + /* Although expr3 is pre-evaluated above, it may happen, + that for arrays or in mold= cases the pre-evaluation + was not successful. In these rare cases take the vtab + from the typespec of expr3 here. */ + ts = &code->expr3->ts; + else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr) + /* The alloc_type_spec gives the type to allocate or the + al is unlimited polymorphic, which enforces the use of + an alloc_type_spec that is not necessarily a BT_DERIVED. */ + ts = &code->ext.alloc.ts; + else + /* Prepare for setting the vtab as declared. */ + ts = &expr->ts; + + vtab = gfc_find_vtab (ts); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + gfc_add_modify (&block, al_vptr, + fold_convert (TREE_TYPE (al_vptr), tmp)); + } + } + + /* Add assignment for string length. */ + if (al_len != NULL_TREE && al_len_needs_set) + { + if (expr3_len != NULL_TREE) + { + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + expr3_len)); + /* When tmp_expr3_len_flag is set, then expr3_len is + abused to carry the length information from the + alloc_type. Clear it to prevent setting incorrect len + information in future loop iterations. */ + if (tmp_expr3_len_flag) + /* No need to reset tmp_expr3_len_flag, because the + presence of an expr3 cannot change within in the + loop. */ + expr3_len = NULL_TREE; + } + else if (code->ext.alloc.ts.type == BT_CHARACTER + && code->ext.alloc.ts.u.cl->length) + { + /* Cover the cases where a string length is explicitly + specified by a type spec for deferred length character + arrays or unlimited polymorphic objects without a + source= or mold= expression. */ + if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1) + { + gfc_init_se (&se_sz, NULL); + gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); + gfc_add_block_to_block (&block, &se_sz.pre); + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + se_sz.expr)); + } + else + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + expr3_esize)); + } + else + /* No length information needed, because type to allocate + has no length. Set _len to 0. */ + gfc_add_modify (&block, al_len, + fold_convert (TREE_TYPE (al_len), + integer_zero_node)); + } + + init_expr = NULL; + if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) + { + /* Initialization via SOURCE block (or static default initializer). + Switch off automatic reallocation since we have just done the + ALLOCATE. */ + int realloc_lhs = flag_realloc_lhs; + gfc_expr *init_expr = gfc_expr_to_initialize (expr); + gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); + flag_realloc_lhs = 0; + tmp = gfc_trans_assignment (init_expr, rhs, true, false, true, + false); + flag_realloc_lhs = realloc_lhs; + /* Free the expression allocated for init_expr. */ + gfc_free_expr (init_expr); + if (rhs != e3rhs) + gfc_free_expr (rhs); + gfc_add_expr_to_block (&block, tmp); + } + /* Set KIND and LEN PDT components and allocate those that are + parameterized. */ + else if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.pdt_type) + { + if (code->expr3 && code->expr3->param_list) + param_list = code->expr3->param_list; + else if (expr->param_list) + param_list = expr->param_list; + else + param_list = expr->symtree->n.sym->param_list; + tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr, + expr->rank, param_list); + gfc_add_expr_to_block (&block, tmp); + } + /* Ditto for CLASS expressions. */ + else if (expr->ts.type == BT_CLASS + && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type) + { + if (code->expr3 && code->expr3->param_list) + param_list = code->expr3->param_list; + else if (expr->param_list) + param_list = expr->param_list; + else + param_list = expr->symtree->n.sym->param_list; + tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, + se.expr, expr->rank, param_list); + gfc_add_expr_to_block (&block, tmp); + } + else if (code->expr3 && code->expr3->mold + && code->expr3->ts.type == BT_CLASS) + { + /* Use class_init_assign to initialize expr. */ + gfc_code *ini; + ini = gfc_get_code (EXEC_INIT_ASSIGN); + ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true); + tmp = gfc_trans_class_init_assign (ini); + gfc_free_statements (ini); + gfc_add_expr_to_block (&block, tmp); + } + else if ((init_expr = allocate_get_initializer (code, expr))) + { + /* Use class_init_assign to initialize expr. */ + gfc_code *ini; + int realloc_lhs = flag_realloc_lhs; + ini = gfc_get_code (EXEC_INIT_ASSIGN); + ini->expr1 = gfc_expr_to_initialize (expr); + ini->expr2 = init_expr; + flag_realloc_lhs = 0; + tmp= gfc_trans_init_assign (ini); + flag_realloc_lhs = realloc_lhs; + gfc_free_statements (ini); + /* Init_expr is freeed by above free_statements, just need to null + it here. */ + init_expr = NULL; + gfc_add_expr_to_block (&block, tmp); + } + + /* Nullify all pointers in derived type coarrays. This registers a + token for them which allows their allocation. */ + if (is_coarray) + { + gfc_symbol *type = NULL; + symbol_attribute caf_attr; + int rank = 0; + if (code->ext.alloc.ts.type == BT_DERIVED + && code->ext.alloc.ts.u.derived->attr.pointer_comp) + { + type = code->ext.alloc.ts.u.derived; + rank = type->attr.dimension ? type->as->rank : 0; + gfc_clear_attr (&caf_attr); + } + else if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.pointer_comp) + { + type = expr->ts.u.derived; + rank = expr->rank; + caf_attr = gfc_caf_attr (expr, true); + } + + /* Initialize the tokens of pointer components in derived type + coarrays. */ + if (type) + { + tmp = (caf_attr.codimension && !caf_attr.dimension) + ? gfc_conv_descriptor_data_get (se.expr) : se.expr; + tmp = gfc_nullify_alloc_comp (type, tmp, rank, + GFC_STRUCTURE_CAF_MODE_IN_COARRAY); + gfc_add_expr_to_block (&block, tmp); + } + } + + gfc_free_expr (expr); + } // for-loop + + if (e3rhs) + { + if (newsym) + { + gfc_free_symbol (newsym->n.sym); + XDELETE (newsym); + } + gfc_free_expr (e3rhs); + } + /* STAT. */ + if (code->expr1) + { + tmp = build1_v (LABEL_EXPR, label_errmsg); + gfc_add_expr_to_block (&block, tmp); + } + + /* ERRMSG - only useful if STAT is present. */ + if (code->expr1 && code->expr2) + { + const char *msg = "Attempt to allocate an allocated object"; + tree slen, dlen, errmsg_str; + stmtblock_t errmsg_block; + + gfc_init_block (&errmsg_block); + + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, + gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (msg))); + + slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); + dlen = gfc_get_expr_charlen (code->expr2); + slen = fold_build2_loc (input_location, MIN_EXPR, + TREE_TYPE (slen), dlen, slen); + + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, + code->expr2->ts.kind, + slen, errmsg_str, + gfc_default_character_kind); + dlen = gfc_finish_block (&errmsg_block); + + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + stat, build_int_cst (TREE_TYPE (stat), 0)); + + tmp = build3_v (COND_EXPR, tmp, + dlen, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&block, tmp); + } + + /* STAT block. */ + if (code->expr1) + { + if (TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); + gfc_add_expr_to_block (&block, tmp); + } + + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr1); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify (&block, se.expr, tmp); + } + + if (needs_caf_sync) + { + /* Add a sync all after the allocation has been executed. */ + tree zero_size = build_zero_cst (size_type_node); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, + 3, null_pointer_node, null_pointer_node, + zero_size); + gfc_add_expr_to_block (&post, tmp); + } + + gfc_add_block_to_block (&block, &se.post); + gfc_add_block_to_block (&block, &post); + if (code->expr3 && code->expr3->must_finalize) + gfc_add_block_to_block (&block, &final_block); + + return gfc_finish_block (&block); +} + + +/* Translate a DEALLOCATE statement. */ + +tree +gfc_trans_deallocate (gfc_code *code) +{ + gfc_se se; + gfc_alloc *al; + tree apstat, pstat, stat, errmsg, errlen, tmp; + tree label_finish, label_errmsg; + stmtblock_t block; + + pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE; + label_finish = label_errmsg = NULL_TREE; + + gfc_start_block (&block); + + /* Count the number of failed deallocations. If deallocate() was + called with STAT= , then set STAT to the count. If deallocate + was called with ERRMSG, then set ERRMG to a string. */ + if (code->expr1) + { + tree gfc_int4_type_node = gfc_get_int_type (4); + + stat = gfc_create_var (gfc_int4_type_node, "stat"); + pstat = gfc_build_addr_expr (NULL_TREE, stat); + + /* GOTO destinations. */ + label_errmsg = gfc_build_label_decl (NULL_TREE); + label_finish = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_finish) = 0; + } + + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) + { + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr_lhs (&se, code->expr2); + errmsg = se.expr; + errlen = se.string_length; + } + + for (al = code->ext.alloc.list; al != NULL; al = al->next) + { + gfc_expr *expr = gfc_copy_expr (al->expr); + bool is_coarray = false, is_coarray_array = false; + int caf_mode = 0; + + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + if (expr->ts.type == BT_CLASS) + gfc_add_data_component (expr); + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + se.want_pointer = 1; + se.descriptor_only = 1; + gfc_conv_expr (&se, expr); + + /* Deallocate PDT components that are parameterized. */ + tmp = NULL; + if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.pdt_type + && expr->symtree->n.sym->param_list) + tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank); + else if (expr->ts.type == BT_CLASS + && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type + && expr->symtree->n.sym->param_list) + tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, + se.expr, expr->rank); + + if (tmp) + gfc_add_expr_to_block (&block, tmp); + + if (flag_coarray == GFC_FCOARRAY_LIB + || flag_coarray == GFC_FCOARRAY_SINGLE) + { + bool comp_ref; + symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref); + if (caf_attr.codimension) + { + is_coarray = true; + is_coarray_array = caf_attr.dimension || !comp_ref + || caf_attr.coarray_comp; + + if (flag_coarray == GFC_FCOARRAY_LIB) + /* When the expression to deallocate is referencing a + component, then only deallocate it, but do not + deregister. */ + caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY + | (comp_ref && !caf_attr.coarray_comp + ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0); + } + } + + if (expr->rank || is_coarray_array) + { + gfc_ref *ref; + + if (gfc_bt_struct (expr->ts.type) + && expr->ts.u.derived->attr.alloc_comp + && !gfc_is_finalizable (expr->ts.u.derived, NULL)) + { + gfc_ref *last = NULL; + + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + /* Do not deallocate the components of a derived type + ultimate pointer component. */ + if (!(last && last->u.c.component->attr.pointer) + && !(!last && expr->symtree->n.sym->attr.pointer)) + { + if (is_coarray && expr->rank == 0 + && (!last || !last->u.c.component->attr.dimension) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + /* Add the ref to the data member only, when this is not + a regular array or deallocate_alloc_comp will try to + add another one. */ + tmp = gfc_conv_descriptor_data_get (se.expr); + } + else + tmp = se.expr; + tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, + expr->rank, caf_mode); + gfc_add_expr_to_block (&se.pre, tmp); + } + } + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + { + gfc_coarray_deregtype caf_dtype; + + if (is_coarray) + caf_dtype = gfc_caf_is_dealloc_only (caf_mode) + ? GFC_CAF_COARRAY_DEALLOCATE_ONLY + : GFC_CAF_COARRAY_DEREGISTER; + else + caf_dtype = GFC_CAF_COARRAY_NOCOARRAY; + tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen, + label_finish, false, expr, + caf_dtype); + gfc_add_expr_to_block (&se.pre, tmp); + } + else if (TREE_CODE (se.expr) == COMPONENT_REF + && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr))) + == RECORD_TYPE) + { + /* class.c(finalize_component) generates these, when a + finalizable entity has a non-allocatable derived type array + component, which has allocatable components. Obtain the + derived type of the array and deallocate the allocatable + components. */ + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->u.c.component->attr.dimension + && ref->u.c.component->ts.type == BT_DERIVED) + break; + } + + if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp + && !gfc_is_finalizable (ref->u.c.component->ts.u.derived, + NULL)) + { + tmp = gfc_deallocate_alloc_comp + (ref->u.c.component->ts.u.derived, + se.expr, expr->rank); + gfc_add_expr_to_block (&se.pre, tmp); + } + } + + if (al->expr->ts.type == BT_CLASS) + { + gfc_reset_vptr (&se.pre, al->expr); + if (UNLIMITED_POLY (al->expr) + || (al->expr->ts.type == BT_DERIVED + && al->expr->ts.u.derived->attr.unlimited_polymorphic)) + /* Clear _len, too. */ + gfc_reset_len (&se.pre, al->expr); + } + } + else + { + tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish, + false, al->expr, + al->expr->ts, is_coarray); + gfc_add_expr_to_block (&se.pre, tmp); + + /* Set to zero after deallocation. */ + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + se.expr, + build_int_cst (TREE_TYPE (se.expr), 0)); + gfc_add_expr_to_block (&se.pre, tmp); + + if (al->expr->ts.type == BT_CLASS) + { + gfc_reset_vptr (&se.pre, al->expr); + if (UNLIMITED_POLY (al->expr) + || (al->expr->ts.type == BT_DERIVED + && al->expr->ts.u.derived->attr.unlimited_polymorphic)) + /* Clear _len, too. */ + gfc_reset_len (&se.pre, al->expr); + } + } + + if (code->expr1) + { + tree cond; + + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), + build1_v (GOTO_EXPR, label_errmsg), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, tmp); + } + + tmp = gfc_finish_block (&se.pre); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (expr); + } + + if (code->expr1) + { + tmp = build1_v (LABEL_EXPR, label_errmsg); + gfc_add_expr_to_block (&block, tmp); + } + + /* Set ERRMSG - only needed if STAT is available. */ + if (code->expr1 && code->expr2) + { + const char *msg = "Attempt to deallocate an unallocated object"; + stmtblock_t errmsg_block; + tree errmsg_str, slen, dlen, cond; + + gfc_init_block (&errmsg_block); + + errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); + gfc_add_modify (&errmsg_block, errmsg_str, + gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (msg))); + slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); + dlen = gfc_get_expr_charlen (code->expr2); + + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, + slen, errmsg_str, gfc_default_character_kind); + tmp = gfc_finish_block (&errmsg_block); + + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, + build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp, + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&block, tmp); + } + + if (code->expr1 && TREE_USED (label_finish)) + { + tmp = build1_v (LABEL_EXPR, label_finish); + gfc_add_expr_to_block (&block, tmp); + } + + /* Set STAT. */ + if (code->expr1) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr1); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify (&block, se.expr, tmp); + } + + return gfc_finish_block (&block); +} + +#include "gt-fortran-trans-stmt.h" diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c deleted file mode 100644 index 5de43bb..0000000 --- a/gcc/fortran/trans-types.c +++ /dev/null @@ -1,3838 +0,0 @@ -/* Backend support for Fortran 95 basic types and derived types. - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - and Steven Bosscher - -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 -. */ - -/* trans-types.c -- gfortran backend types */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "target.h" -#include "tree.h" -#include "gfortran.h" -#include "trans.h" -#include "stringpool.h" -#include "fold-const.h" -#include "stor-layout.h" -#include "langhooks.h" /* For iso-c-bindings.def. */ -#include "toplev.h" /* For rest_of_decl_compilation. */ -#include "trans-types.h" -#include "trans-const.h" -#include "trans-array.h" -#include "dwarf2out.h" /* For struct array_descr_info. */ -#include "attribs.h" -#include "alias.h" - - -#if (GFC_MAX_DIMENSIONS < 10) -#define GFC_RANK_DIGITS 1 -#define GFC_RANK_PRINTF_FORMAT "%01d" -#elif (GFC_MAX_DIMENSIONS < 100) -#define GFC_RANK_DIGITS 2 -#define GFC_RANK_PRINTF_FORMAT "%02d" -#else -#error If you really need >99 dimensions, continue the sequence above... -#endif - -/* array of structs so we don't have to worry about xmalloc or free */ -CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER]; - -tree gfc_array_index_type; -tree gfc_array_range_type; -tree gfc_character1_type_node; -tree pvoid_type_node; -tree prvoid_type_node; -tree ppvoid_type_node; -tree pchar_type_node; -static tree pfunc_type_node; - -tree logical_type_node; -tree logical_true_node; -tree logical_false_node; -tree gfc_charlen_type_node; - -tree gfc_float128_type_node = NULL_TREE; -tree gfc_complex_float128_type_node = NULL_TREE; - -bool gfc_real16_is_float128 = false; - -static GTY(()) tree gfc_desc_dim_type; -static GTY(()) tree gfc_max_array_element_size; -static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)]; -static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)]; -static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)]; - -/* Arrays for all integral and real kinds. We'll fill this in at runtime - after the target has a chance to process command-line options. */ - -#define MAX_INT_KINDS 5 -gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1]; -gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1]; -static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1]; -static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1]; - -#define MAX_REAL_KINDS 5 -gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1]; -static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1]; -static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1]; - -#define MAX_CHARACTER_KINDS 2 -gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1]; -static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1]; -static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1]; - -static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **); - -/* The integer kind to use for array indices. This will be set to the - proper value based on target information from the backend. */ - -int gfc_index_integer_kind; - -/* The default kinds of the various types. */ - -int gfc_default_integer_kind; -int gfc_max_integer_kind; -int gfc_default_real_kind; -int gfc_default_double_kind; -int gfc_default_character_kind; -int gfc_default_logical_kind; -int gfc_default_complex_kind; -int gfc_c_int_kind; -int gfc_c_intptr_kind; -int gfc_atomic_int_kind; -int gfc_atomic_logical_kind; - -/* The kind size used for record offsets. If the target system supports - kind=8, this will be set to 8, otherwise it is set to 4. */ -int gfc_intio_kind; - -/* The integer kind used to store character lengths. */ -int gfc_charlen_int_kind; - -/* Kind of internal integer for storing object sizes. */ -int gfc_size_kind; - -/* The size of the numeric storage unit and character storage unit. */ -int gfc_numeric_storage_size; -int gfc_character_storage_size; - -static tree dtype_type_node = NULL_TREE; - - -/* Build the dtype_type_node if necessary. */ -tree get_dtype_type_node (void) -{ - tree field; - tree dtype_node; - tree *dtype_chain = NULL; - - if (dtype_type_node == NULL_TREE) - { - dtype_node = make_node (RECORD_TYPE); - TYPE_NAME (dtype_node) = get_identifier ("dtype_type"); - TYPE_NAMELESS (dtype_node) = 1; - field = gfc_add_field_to_struct_1 (dtype_node, - get_identifier ("elem_len"), - size_type_node, &dtype_chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (dtype_node, - get_identifier ("version"), - integer_type_node, &dtype_chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (dtype_node, - get_identifier ("rank"), - signed_char_type_node, &dtype_chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (dtype_node, - get_identifier ("type"), - signed_char_type_node, &dtype_chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (dtype_node, - get_identifier ("attribute"), - short_integer_type_node, &dtype_chain); - suppress_warning (field); - gfc_finish_type (dtype_node); - TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1; - dtype_type_node = dtype_node; - } - return dtype_type_node; -} - -static int -get_real_kind_from_node (tree type) -{ - int i; - - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type)) - return gfc_real_kinds[i].kind; - - return -4; -} - -static int -get_int_kind_from_node (tree type) -{ - int i; - - if (!type) - return -2; - - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type)) - return gfc_integer_kinds[i].kind; - - return -1; -} - -static int -get_int_kind_from_name (const char *name) -{ - return get_int_kind_from_node (get_typenode_from_name (name)); -} - - -/* Get the kind number corresponding to an integer of given size, - following the required return values for ISO_FORTRAN_ENV INT* constants: - -2 is returned if we support a kind of larger size, -1 otherwise. */ -int -gfc_get_int_kind_from_width_isofortranenv (int size) -{ - int i; - - /* Look for a kind with matching storage size. */ - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].bit_size == size) - return gfc_integer_kinds[i].kind; - - /* Look for a kind with larger storage size. */ - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].bit_size > size) - return -2; - - return -1; -} - - -/* Get the kind number corresponding to a real of a given storage size. - If two real's have the same storage size, then choose the real with - the largest precision. If a kind type is unavailable and a real - exists with wider storage, then return -2; otherwise, return -1. */ - -int -gfc_get_real_kind_from_width_isofortranenv (int size) -{ - int digits, i, kind; - - size /= 8; - - kind = -1; - digits = 0; - - /* Look for a kind with matching storage size. */ - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size) - { - if (gfc_real_kinds[i].digits > digits) - { - digits = gfc_real_kinds[i].digits; - kind = gfc_real_kinds[i].kind; - } - } - - if (kind != -1) - return kind; - - /* Look for a kind with larger storage size. */ - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size) - kind = -2; - - return kind; -} - - - -static int -get_int_kind_from_width (int size) -{ - int i; - - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].bit_size == size) - return gfc_integer_kinds[i].kind; - - return -2; -} - -static int -get_int_kind_from_minimal_width (int size) -{ - int i; - - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].bit_size >= size) - return gfc_integer_kinds[i].kind; - - return -2; -} - - -/* Generate the CInteropKind_t objects for the C interoperable - kinds. */ - -void -gfc_init_c_interop_kinds (void) -{ - int i; - - /* init all pointers in the list to NULL */ - for (i = 0; i < ISOCBINDING_NUMBER; i++) - { - /* Initialize the name and value fields. */ - c_interop_kinds_table[i].name[0] = '\0'; - c_interop_kinds_table[i].value = -100; - c_interop_kinds_table[i].f90_type = BT_UNKNOWN; - } - -#define NAMED_INTCST(a,b,c,d) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_INTEGER; \ - c_interop_kinds_table[a].value = c; -#define NAMED_REALCST(a,b,c,d) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_REAL; \ - c_interop_kinds_table[a].value = c; -#define NAMED_CMPXCST(a,b,c,d) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_COMPLEX; \ - c_interop_kinds_table[a].value = c; -#define NAMED_LOGCST(a,b,c) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_LOGICAL; \ - c_interop_kinds_table[a].value = c; -#define NAMED_CHARKNDCST(a,b,c) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ - c_interop_kinds_table[a].value = c; -#define NAMED_CHARCST(a,b,c) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ - c_interop_kinds_table[a].value = c; -#define DERIVED_TYPE(a,b,c) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_DERIVED; \ - c_interop_kinds_table[a].value = c; -#define NAMED_FUNCTION(a,b,c,d) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \ - c_interop_kinds_table[a].value = c; -#define NAMED_SUBROUTINE(a,b,c,d) \ - strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ - c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \ - c_interop_kinds_table[a].value = c; -#include "iso-c-binding.def" -} - - -/* Query the target to determine which machine modes are available for - computation. Choose KIND numbers for them. */ - -void -gfc_init_kinds (void) -{ - opt_scalar_int_mode int_mode_iter; - opt_scalar_float_mode float_mode_iter; - int i_index, r_index, kind; - bool saw_i4 = false, saw_i8 = false; - bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false; - scalar_mode r16_mode = QImode; - scalar_mode composite_mode = QImode; - - i_index = 0; - FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT) - { - scalar_int_mode mode = int_mode_iter.require (); - int kind, bitsize; - - if (!targetm.scalar_mode_supported_p (mode)) - continue; - - /* The middle end doesn't support constants larger than 2*HWI. - Perhaps the target hook shouldn't have accepted these either, - but just to be safe... */ - bitsize = GET_MODE_BITSIZE (mode); - if (bitsize > 2*HOST_BITS_PER_WIDE_INT) - continue; - - gcc_assert (i_index != MAX_INT_KINDS); - - /* Let the kind equal the bit size divided by 8. This insulates the - programmer from the underlying byte size. */ - kind = bitsize / 8; - - if (kind == 4) - saw_i4 = true; - if (kind == 8) - saw_i8 = true; - - gfc_integer_kinds[i_index].kind = kind; - gfc_integer_kinds[i_index].radix = 2; - gfc_integer_kinds[i_index].digits = bitsize - 1; - gfc_integer_kinds[i_index].bit_size = bitsize; - - gfc_logical_kinds[i_index].kind = kind; - gfc_logical_kinds[i_index].bit_size = bitsize; - - i_index += 1; - } - - /* Set the kind used to match GFC_INT_IO in libgfortran. This is - used for large file access. */ - - if (saw_i8) - gfc_intio_kind = 8; - else - gfc_intio_kind = 4; - - /* If we do not at least have kind = 4, everything is pointless. */ - gcc_assert(saw_i4); - - /* Set the maximum integer kind. Used with at least BOZ constants. */ - gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind; - - r_index = 0; - FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT) - { - scalar_float_mode mode = float_mode_iter.require (); - const struct real_format *fmt = REAL_MODE_FORMAT (mode); - int kind; - - if (fmt == NULL) - continue; - if (!targetm.scalar_mode_supported_p (mode)) - continue; - - if (MODE_COMPOSITE_P (mode) - && (GET_MODE_PRECISION (mode) + 7) / 8 == 16) - composite_mode = mode; - - /* Only let float, double, long double and TFmode go through. - Runtime support for others is not provided, so they would be - useless. */ - if (!targetm.libgcc_floating_mode_supported_p (mode)) - continue; - if (mode != TYPE_MODE (float_type_node) - && (mode != TYPE_MODE (double_type_node)) - && (mode != TYPE_MODE (long_double_type_node)) -#if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT) - && (mode != TFmode) -#endif - ) - continue; - - /* Let the kind equal the precision divided by 8, rounding up. Again, - this insulates the programmer from the underlying byte size. - - Also, it effectively deals with IEEE extended formats. There, the - total size of the type may equal 16, but it's got 6 bytes of padding - and the increased size can get in the way of a real IEEE quad format - which may also be supported by the target. - - We round up so as to handle IA-64 __floatreg (RFmode), which is an - 82 bit type. Not to be confused with __float80 (XFmode), which is - an 80 bit type also supported by IA-64. So XFmode should come out - to be kind=10, and RFmode should come out to be kind=11. Egads. - - TODO: The kind calculation has to be modified to support all - three 128-bit floating-point modes on PowerPC as IFmode, KFmode, - and TFmode since the following line would all map to kind=16. - However, currently only float, double, long double, and TFmode - reach this code. - */ - - kind = (GET_MODE_PRECISION (mode) + 7) / 8; - - if (kind == 4) - saw_r4 = true; - if (kind == 8) - saw_r8 = true; - if (kind == 10) - saw_r10 = true; - if (kind == 16) - { - saw_r16 = true; - r16_mode = mode; - } - - /* Careful we don't stumble a weird internal mode. */ - gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind); - /* Or have too many modes for the allocated space. */ - gcc_assert (r_index != MAX_REAL_KINDS); - - gfc_real_kinds[r_index].kind = kind; - gfc_real_kinds[r_index].abi_kind = kind; - gfc_real_kinds[r_index].radix = fmt->b; - gfc_real_kinds[r_index].digits = fmt->p; - gfc_real_kinds[r_index].min_exponent = fmt->emin; - gfc_real_kinds[r_index].max_exponent = fmt->emax; - if (fmt->pnan < fmt->p) - /* This is an IBM extended double format (or the MIPS variant) - made up of two IEEE doubles. The value of the long double is - the sum of the values of the two parts. The most significant - part is required to be the value of the long double rounded - to the nearest double. If we use emax of 1024 then we can't - represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because - rounding will make the most significant part overflow. */ - gfc_real_kinds[r_index].max_exponent = fmt->emax - 1; - gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode); - r_index += 1; - } - - /* Detect the powerpc64le-linux case with -mabi=ieeelongdouble, where - the long double type is non-MODE_COMPOSITE_P TFmode but one can use - -mabi=ibmlongdouble too and get MODE_COMPOSITE_P TFmode with the same - precision. For libgfortran calls pretend the IEEE 754 quad TFmode has - kind 17 rather than 16 and use kind 16 for the IBM extended format - TFmode. */ - if (composite_mode != QImode && saw_r16 && !MODE_COMPOSITE_P (r16_mode)) - { - for (int i = 0; i < r_index; ++i) - if (gfc_real_kinds[i].kind == 16) - { - gfc_real_kinds[i].abi_kind = 17; - if (flag_building_libgfortran - && (TARGET_GLIBC_MAJOR < 2 - || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR < 32))) - { - gfc_real16_is_float128 = true; - gfc_real_kinds[i].c_float128 = 1; - } - } - } - - /* Choose the default integer kind. We choose 4 unless the user directs us - otherwise. Even if the user specified that the default integer kind is 8, - the numeric storage size is not 64 bits. In this case, a warning will be - issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */ - - gfc_numeric_storage_size = 4 * 8; - - if (flag_default_integer) - { - if (!saw_i8) - gfc_fatal_error ("INTEGER(KIND=8) is not available for " - "%<-fdefault-integer-8%> option"); - - gfc_default_integer_kind = 8; - - } - else if (flag_integer4_kind == 8) - { - if (!saw_i8) - gfc_fatal_error ("INTEGER(KIND=8) is not available for " - "%<-finteger-4-integer-8%> option"); - - gfc_default_integer_kind = 8; - } - else if (saw_i4) - { - gfc_default_integer_kind = 4; - } - else - { - gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind; - gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size; - } - - /* Choose the default real kind. Again, we choose 4 when possible. */ - if (flag_default_real_8) - { - if (!saw_r8) - gfc_fatal_error ("REAL(KIND=8) is not available for " - "%<-fdefault-real-8%> option"); - - gfc_default_real_kind = 8; - } - else if (flag_default_real_10) - { - if (!saw_r10) - gfc_fatal_error ("REAL(KIND=10) is not available for " - "%<-fdefault-real-10%> option"); - - gfc_default_real_kind = 10; - } - else if (flag_default_real_16) - { - if (!saw_r16) - gfc_fatal_error ("REAL(KIND=16) is not available for " - "%<-fdefault-real-16%> option"); - - gfc_default_real_kind = 16; - } - else if (flag_real4_kind == 8) - { - if (!saw_r8) - gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> " - "option"); - - gfc_default_real_kind = 8; - } - else if (flag_real4_kind == 10) - { - if (!saw_r10) - gfc_fatal_error ("REAL(KIND=10) is not available for " - "%<-freal-4-real-10%> option"); - - gfc_default_real_kind = 10; - } - else if (flag_real4_kind == 16) - { - if (!saw_r16) - gfc_fatal_error ("REAL(KIND=16) is not available for " - "%<-freal-4-real-16%> option"); - - gfc_default_real_kind = 16; - } - else if (saw_r4) - gfc_default_real_kind = 4; - else - gfc_default_real_kind = gfc_real_kinds[0].kind; - - /* Choose the default double kind. If -fdefault-real and -fdefault-double - are specified, we use kind=8, if it's available. If -fdefault-real is - specified without -fdefault-double, we use kind=16, if it's available. - Otherwise we do not change anything. */ - if (flag_default_double && saw_r8) - gfc_default_double_kind = 8; - else if (flag_default_real_8 || flag_default_real_10 || flag_default_real_16) - { - /* Use largest available kind. */ - if (saw_r16) - gfc_default_double_kind = 16; - else if (saw_r10) - gfc_default_double_kind = 10; - else if (saw_r8) - gfc_default_double_kind = 8; - else - gfc_default_double_kind = gfc_default_real_kind; - } - else if (flag_real8_kind == 4) - { - if (!saw_r4) - gfc_fatal_error ("REAL(KIND=4) is not available for " - "%<-freal-8-real-4%> option"); - - gfc_default_double_kind = 4; - } - else if (flag_real8_kind == 10 ) - { - if (!saw_r10) - gfc_fatal_error ("REAL(KIND=10) is not available for " - "%<-freal-8-real-10%> option"); - - gfc_default_double_kind = 10; - } - else if (flag_real8_kind == 16 ) - { - if (!saw_r16) - gfc_fatal_error ("REAL(KIND=10) is not available for " - "%<-freal-8-real-16%> option"); - - gfc_default_double_kind = 16; - } - else if (saw_r4 && saw_r8) - gfc_default_double_kind = 8; - else - { - /* F95 14.6.3.1: A nonpointer scalar object of type double precision - real ... occupies two contiguous numeric storage units. - - Therefore we must be supplied a kind twice as large as we chose - for single precision. There are loopholes, in that double - precision must *occupy* two storage units, though it doesn't have - to *use* two storage units. Which means that you can make this - kind artificially wide by padding it. But at present there are - no GCC targets for which a two-word type does not exist, so we - just let gfc_validate_kind abort and tell us if something breaks. */ - - gfc_default_double_kind - = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false); - } - - /* The default logical kind is constrained to be the same as the - default integer kind. Similarly with complex and real. */ - gfc_default_logical_kind = gfc_default_integer_kind; - gfc_default_complex_kind = gfc_default_real_kind; - - /* We only have two character kinds: ASCII and UCS-4. - ASCII corresponds to a 8-bit integer type, if one is available. - UCS-4 corresponds to a 32-bit integer type, if one is available. */ - i_index = 0; - if ((kind = get_int_kind_from_width (8)) > 0) - { - gfc_character_kinds[i_index].kind = kind; - gfc_character_kinds[i_index].bit_size = 8; - gfc_character_kinds[i_index].name = "ascii"; - i_index++; - } - if ((kind = get_int_kind_from_width (32)) > 0) - { - gfc_character_kinds[i_index].kind = kind; - gfc_character_kinds[i_index].bit_size = 32; - gfc_character_kinds[i_index].name = "iso_10646"; - i_index++; - } - - /* Choose the smallest integer kind for our default character. */ - gfc_default_character_kind = gfc_character_kinds[0].kind; - gfc_character_storage_size = gfc_default_character_kind * 8; - - gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE); - - /* Pick a kind the same size as the C "int" type. */ - gfc_c_int_kind = INT_TYPE_SIZE / 8; - - /* Choose atomic kinds to match C's int. */ - gfc_atomic_int_kind = gfc_c_int_kind; - gfc_atomic_logical_kind = gfc_c_int_kind; - - gfc_c_intptr_kind = POINTER_SIZE / 8; -} - - -/* Make sure that a valid kind is present. Returns an index into the - associated kinds array, -1 if the kind is not present. */ - -static int -validate_integer (int kind) -{ - int i; - - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) - if (gfc_integer_kinds[i].kind == kind) - return i; - - return -1; -} - -static int -validate_real (int kind) -{ - int i; - - for (i = 0; gfc_real_kinds[i].kind != 0; i++) - if (gfc_real_kinds[i].kind == kind) - return i; - - return -1; -} - -static int -validate_logical (int kind) -{ - int i; - - for (i = 0; gfc_logical_kinds[i].kind; i++) - if (gfc_logical_kinds[i].kind == kind) - return i; - - return -1; -} - -static int -validate_character (int kind) -{ - int i; - - for (i = 0; gfc_character_kinds[i].kind; i++) - if (gfc_character_kinds[i].kind == kind) - return i; - - return -1; -} - -/* Validate a kind given a basic type. The return value is the same - for the child functions, with -1 indicating nonexistence of the - type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */ - -int -gfc_validate_kind (bt type, int kind, bool may_fail) -{ - int rc; - - switch (type) - { - case BT_REAL: /* Fall through */ - case BT_COMPLEX: - rc = validate_real (kind); - break; - case BT_INTEGER: - rc = validate_integer (kind); - break; - case BT_LOGICAL: - rc = validate_logical (kind); - break; - case BT_CHARACTER: - rc = validate_character (kind); - break; - - default: - gfc_internal_error ("gfc_validate_kind(): Got bad type"); - } - - if (rc < 0 && !may_fail) - gfc_internal_error ("gfc_validate_kind(): Got bad kind"); - - return rc; -} - - -/* Four subroutines of gfc_init_types. Create type nodes for the given kind. - Reuse common type nodes where possible. Recognize if the kind matches up - with a C type. This will be used later in determining which routines may - be scarfed from libm. */ - -static tree -gfc_build_int_type (gfc_integer_info *info) -{ - int mode_precision = info->bit_size; - - if (mode_precision == CHAR_TYPE_SIZE) - info->c_char = 1; - if (mode_precision == SHORT_TYPE_SIZE) - info->c_short = 1; - if (mode_precision == INT_TYPE_SIZE) - info->c_int = 1; - if (mode_precision == LONG_TYPE_SIZE) - info->c_long = 1; - if (mode_precision == LONG_LONG_TYPE_SIZE) - info->c_long_long = 1; - - if (TYPE_PRECISION (intQI_type_node) == mode_precision) - return intQI_type_node; - if (TYPE_PRECISION (intHI_type_node) == mode_precision) - return intHI_type_node; - if (TYPE_PRECISION (intSI_type_node) == mode_precision) - return intSI_type_node; - if (TYPE_PRECISION (intDI_type_node) == mode_precision) - return intDI_type_node; - if (TYPE_PRECISION (intTI_type_node) == mode_precision) - return intTI_type_node; - - return make_signed_type (mode_precision); -} - -tree -gfc_build_uint_type (int size) -{ - if (size == CHAR_TYPE_SIZE) - return unsigned_char_type_node; - if (size == SHORT_TYPE_SIZE) - return short_unsigned_type_node; - if (size == INT_TYPE_SIZE) - return unsigned_type_node; - if (size == LONG_TYPE_SIZE) - return long_unsigned_type_node; - if (size == LONG_LONG_TYPE_SIZE) - return long_long_unsigned_type_node; - - return make_unsigned_type (size); -} - - -static tree -gfc_build_real_type (gfc_real_info *info) -{ - int mode_precision = info->mode_precision; - tree new_type; - - if (mode_precision == FLOAT_TYPE_SIZE) - info->c_float = 1; - if (mode_precision == DOUBLE_TYPE_SIZE) - info->c_double = 1; - if (mode_precision == LONG_DOUBLE_TYPE_SIZE && !info->c_float128) - info->c_long_double = 1; - if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128) - { - /* TODO: see PR101835. */ - info->c_float128 = 1; - gfc_real16_is_float128 = true; - } - - if (TYPE_PRECISION (float_type_node) == mode_precision) - return float_type_node; - if (TYPE_PRECISION (double_type_node) == mode_precision) - return double_type_node; - if (TYPE_PRECISION (long_double_type_node) == mode_precision) - return long_double_type_node; - - new_type = make_node (REAL_TYPE); - TYPE_PRECISION (new_type) = mode_precision; - layout_type (new_type); - return new_type; -} - -static tree -gfc_build_complex_type (tree scalar_type) -{ - tree new_type; - - if (scalar_type == NULL) - return NULL; - if (scalar_type == float_type_node) - return complex_float_type_node; - if (scalar_type == double_type_node) - return complex_double_type_node; - if (scalar_type == long_double_type_node) - return complex_long_double_type_node; - - new_type = make_node (COMPLEX_TYPE); - TREE_TYPE (new_type) = scalar_type; - layout_type (new_type); - return new_type; -} - -static tree -gfc_build_logical_type (gfc_logical_info *info) -{ - int bit_size = info->bit_size; - tree new_type; - - if (bit_size == BOOL_TYPE_SIZE) - { - info->c_bool = 1; - return boolean_type_node; - } - - new_type = make_unsigned_type (bit_size); - TREE_SET_CODE (new_type, BOOLEAN_TYPE); - TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1); - TYPE_PRECISION (new_type) = 1; - - return new_type; -} - - -/* Create the backend type nodes. We map them to their - equivalent C type, at least for now. We also give - names to the types here, and we push them in the - global binding level context.*/ - -void -gfc_init_types (void) -{ - char name_buf[26]; - int index; - tree type; - unsigned n; - - /* Create and name the types. */ -#define PUSH_TYPE(name, node) \ - pushdecl (build_decl (input_location, \ - TYPE_DECL, get_identifier (name), node)) - - for (index = 0; gfc_integer_kinds[index].kind != 0; ++index) - { - type = gfc_build_int_type (&gfc_integer_kinds[index]); - /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */ - if (TYPE_STRING_FLAG (type)) - type = make_signed_type (gfc_integer_kinds[index].bit_size); - gfc_integer_types[index] = type; - snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)", - gfc_integer_kinds[index].kind); - PUSH_TYPE (name_buf, type); - } - - for (index = 0; gfc_logical_kinds[index].kind != 0; ++index) - { - type = gfc_build_logical_type (&gfc_logical_kinds[index]); - gfc_logical_types[index] = type; - snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)", - gfc_logical_kinds[index].kind); - PUSH_TYPE (name_buf, type); - } - - for (index = 0; gfc_real_kinds[index].kind != 0; index++) - { - type = gfc_build_real_type (&gfc_real_kinds[index]); - gfc_real_types[index] = type; - snprintf (name_buf, sizeof(name_buf), "real(kind=%d)", - gfc_real_kinds[index].kind); - PUSH_TYPE (name_buf, type); - - if (gfc_real_kinds[index].c_float128) - gfc_float128_type_node = type; - - type = gfc_build_complex_type (type); - gfc_complex_types[index] = type; - snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)", - gfc_real_kinds[index].kind); - PUSH_TYPE (name_buf, type); - - if (gfc_real_kinds[index].c_float128) - gfc_complex_float128_type_node = type; - } - - for (index = 0; gfc_character_kinds[index].kind != 0; ++index) - { - type = gfc_build_uint_type (gfc_character_kinds[index].bit_size); - type = build_qualified_type (type, TYPE_UNQUALIFIED); - snprintf (name_buf, sizeof(name_buf), "character(kind=%d)", - gfc_character_kinds[index].kind); - PUSH_TYPE (name_buf, type); - gfc_character_types[index] = type; - gfc_pcharacter_types[index] = build_pointer_type (type); - } - gfc_character1_type_node = gfc_character_types[0]; - - PUSH_TYPE ("byte", unsigned_char_type_node); - PUSH_TYPE ("void", void_type_node); - - /* DBX debugging output gets upset if these aren't set. */ - if (!TYPE_NAME (integer_type_node)) - PUSH_TYPE ("c_integer", integer_type_node); - if (!TYPE_NAME (char_type_node)) - PUSH_TYPE ("c_char", char_type_node); - -#undef PUSH_TYPE - - pvoid_type_node = build_pointer_type (void_type_node); - prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT); - ppvoid_type_node = build_pointer_type (pvoid_type_node); - pchar_type_node = build_pointer_type (gfc_character1_type_node); - pfunc_type_node - = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)); - - gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind); - /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type, - since this function is called before gfc_init_constants. */ - gfc_array_range_type - = build_range_type (gfc_array_index_type, - build_int_cst (gfc_array_index_type, 0), - NULL_TREE); - - /* The maximum array element size that can be handled is determined - by the number of bits available to store this field in the array - descriptor. */ - - n = TYPE_PRECISION (size_type_node); - gfc_max_array_element_size - = wide_int_to_tree (size_type_node, - wi::mask (n, UNSIGNED, - TYPE_PRECISION (size_type_node))); - - logical_type_node = gfc_get_logical_type (gfc_default_logical_kind); - logical_true_node = build_int_cst (logical_type_node, 1); - logical_false_node = build_int_cst (logical_type_node, 0); - - /* Character lengths are of type size_t, except signed. */ - gfc_charlen_int_kind = get_int_kind_from_node (size_type_node); - gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind); - - /* Fortran kind number of size_type_node (size_t). This is used for - the _size member in vtables. */ - gfc_size_kind = get_int_kind_from_node (size_type_node); -} - -/* Get the type node for the given type and kind. */ - -tree -gfc_get_int_type (int kind) -{ - int index = gfc_validate_kind (BT_INTEGER, kind, true); - return index < 0 ? 0 : gfc_integer_types[index]; -} - -tree -gfc_get_real_type (int kind) -{ - int index = gfc_validate_kind (BT_REAL, kind, true); - return index < 0 ? 0 : gfc_real_types[index]; -} - -tree -gfc_get_complex_type (int kind) -{ - int index = gfc_validate_kind (BT_COMPLEX, kind, true); - return index < 0 ? 0 : gfc_complex_types[index]; -} - -tree -gfc_get_logical_type (int kind) -{ - int index = gfc_validate_kind (BT_LOGICAL, kind, true); - return index < 0 ? 0 : gfc_logical_types[index]; -} - -tree -gfc_get_char_type (int kind) -{ - int index = gfc_validate_kind (BT_CHARACTER, kind, true); - return index < 0 ? 0 : gfc_character_types[index]; -} - -tree -gfc_get_pchar_type (int kind) -{ - int index = gfc_validate_kind (BT_CHARACTER, kind, true); - return index < 0 ? 0 : gfc_pcharacter_types[index]; -} - - -/* Create a character type with the given kind and length. */ - -tree -gfc_get_character_type_len_for_eltype (tree eltype, tree len) -{ - tree bounds, type; - - bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len); - type = build_array_type (eltype, bounds); - TYPE_STRING_FLAG (type) = 1; - - return type; -} - -tree -gfc_get_character_type_len (int kind, tree len) -{ - gfc_validate_kind (BT_CHARACTER, kind, false); - return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len); -} - - -/* Get a type node for a character kind. */ - -tree -gfc_get_character_type (int kind, gfc_charlen * cl) -{ - tree len; - - len = (cl == NULL) ? NULL_TREE : cl->backend_decl; - if (len && POINTER_TYPE_P (TREE_TYPE (len))) - len = build_fold_indirect_ref (len); - - return gfc_get_character_type_len (kind, len); -} - -/* Convert a basic type. This will be an array for character types. */ - -tree -gfc_typenode_for_spec (gfc_typespec * spec, int codim) -{ - tree basetype; - - switch (spec->type) - { - case BT_UNKNOWN: - gcc_unreachable (); - - case BT_INTEGER: - /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol - has been resolved. This is done so we can convert C_PTR and - C_FUNPTR to simple variables that get translated to (void *). */ - if (spec->f90_type == BT_VOID) - { - if (spec->u.derived - && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) - basetype = ptr_type_node; - else - basetype = pfunc_type_node; - } - else - basetype = gfc_get_int_type (spec->kind); - break; - - case BT_REAL: - basetype = gfc_get_real_type (spec->kind); - break; - - case BT_COMPLEX: - basetype = gfc_get_complex_type (spec->kind); - break; - - case BT_LOGICAL: - basetype = gfc_get_logical_type (spec->kind); - break; - - case BT_CHARACTER: - basetype = gfc_get_character_type (spec->kind, spec->u.cl); - break; - - case BT_HOLLERITH: - /* Since this cannot be used, return a length one character. */ - basetype = gfc_get_character_type_len (gfc_default_character_kind, - gfc_index_one_node); - break; - - case BT_UNION: - basetype = gfc_get_union_type (spec->u.derived); - break; - - case BT_DERIVED: - case BT_CLASS: - basetype = gfc_get_derived_type (spec->u.derived, codim); - - if (spec->type == BT_CLASS) - GFC_CLASS_TYPE_P (basetype) = 1; - - /* If we're dealing with either C_PTR or C_FUNPTR, we modified the - type and kind to fit a (void *) and the basetype returned was a - ptr_type_node. We need to pass up this new information to the - symbol that was declared of type C_PTR or C_FUNPTR. */ - if (spec->u.derived->ts.f90_type == BT_VOID) - { - spec->type = BT_INTEGER; - spec->kind = gfc_index_integer_kind; - spec->f90_type = BT_VOID; - spec->is_c_interop = 1; /* Mark as escaping later. */ - } - break; - case BT_VOID: - case BT_ASSUMED: - /* This is for the second arg to c_f_pointer and c_f_procpointer - of the iso_c_binding module, to accept any ptr type. */ - basetype = ptr_type_node; - if (spec->f90_type == BT_VOID) - { - if (spec->u.derived - && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) - basetype = ptr_type_node; - else - basetype = pfunc_type_node; - } - break; - case BT_PROCEDURE: - basetype = pfunc_type_node; - break; - default: - gcc_unreachable (); - } - return basetype; -} - -/* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */ - -static tree -gfc_conv_array_bound (gfc_expr * expr) -{ - /* If expr is an integer constant, return that. */ - if (expr != NULL && expr->expr_type == EXPR_CONSTANT) - return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); - - /* Otherwise return NULL. */ - return NULL_TREE; -} - -/* Return the type of an element of the array. Note that scalar coarrays - are special. In particular, for GFC_ARRAY_TYPE_P, the original argument - (with POINTER_TYPE stripped) is returned. */ - -tree -gfc_get_element_type (tree type) -{ - tree element; - - if (GFC_ARRAY_TYPE_P (type)) - { - if (TREE_CODE (type) == POINTER_TYPE) - type = TREE_TYPE (type); - if (GFC_TYPE_ARRAY_RANK (type) == 0) - { - gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); - element = type; - } - else - { - gcc_assert (TREE_CODE (type) == ARRAY_TYPE); - element = TREE_TYPE (type); - } - } - else - { - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); - - gcc_assert (TREE_CODE (element) == POINTER_TYPE); - element = TREE_TYPE (element); - - /* For arrays, which are not scalar coarrays. */ - if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element)) - element = TREE_TYPE (element); - } - - return element; -} - -/* Build an array. This function is called from gfc_sym_type(). - Actually returns array descriptor type. - - Format of array descriptors is as follows: - - struct gfc_array_descriptor - { - array *data; - index offset; - struct dtype_type dtype; - struct descriptor_dimension dimension[N_DIM]; - } - - struct dtype_type - { - size_t elem_len; - int version; - signed char rank; - signed char type; - signed short attribute; - } - - struct descriptor_dimension - { - index stride; - index lbound; - index ubound; - } - - Translation code should use gfc_conv_descriptor_* rather than - accessing the descriptor directly. Any changes to the array - descriptor type will require changes in gfc_conv_descriptor_* and - gfc_build_array_initializer. - - This is represented internally as a RECORD_TYPE. The index nodes - are gfc_array_index_type and the data node is a pointer to the - data. See below for the handling of character types. - - I originally used nested ARRAY_TYPE nodes to represent arrays, but - this generated poor code for assumed/deferred size arrays. These - require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part - of the GENERIC grammar. Also, there is no way to explicitly set - the array stride, so all data must be packed(1). I've tried to - mark all the functions which would require modification with a GCC - ARRAYS comment. - - The data component points to the first element in the array. The - offset field is the position of the origin of the array (i.e. element - (0, 0 ...)). This may be outside the bounds of the array. - - An element is accessed by - data[offset + index0*stride0 + index1*stride1 + index2*stride2] - This gives good performance as the computation does not involve the - bounds of the array. For packed arrays, this is optimized further - by substituting the known strides. - - This system has one problem: all array bounds must be within 2^31 - elements of the origin (2^63 on 64-bit machines). For example - integer, dimension (80000:90000, 80000:90000, 2) :: array - may not work properly on 32-bit machines because 80000*80000 > - 2^31, so the calculation for stride2 would overflow. This may - still work, but I haven't checked, and it relies on the overflow - doing the right thing. - - The way to fix this problem is to access elements as follows: - data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1] - Obviously this is much slower. I will make this a compile time - option, something like -fsmall-array-offsets. Mixing code compiled - with and without this switch will work. - - (1) This can be worked around by modifying the upper bound of the - previous dimension. This requires extra fields in the descriptor - (both real_ubound and fake_ubound). */ - - -/* Returns true if the array sym does not require a descriptor. */ - -int -gfc_is_nodesc_array (gfc_symbol * sym) -{ - symbol_attribute *array_attr; - gfc_array_spec *as; - bool is_classarray = IS_CLASS_ARRAY (sym); - - array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; - as = is_classarray ? CLASS_DATA (sym)->as : sym->as; - - gcc_assert (array_attr->dimension || array_attr->codimension); - - /* We only want local arrays. */ - if ((sym->ts.type != BT_CLASS && sym->attr.pointer) - || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) - || array_attr->allocatable) - return 0; - - /* We want a descriptor for associate-name arrays that do not have an - explicitly known shape already. */ - if (sym->assoc && as->type != AS_EXPLICIT) - return 0; - - /* The dummy is stored in sym and not in the component. */ - if (sym->attr.dummy) - return as->type != AS_ASSUMED_SHAPE - && as->type != AS_ASSUMED_RANK; - - if (sym->attr.result || sym->attr.function) - return 0; - - gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed); - - return 1; -} - - -/* Create an array descriptor type. */ - -static tree -gfc_build_array_type (tree type, gfc_array_spec * as, - enum gfc_array_kind akind, bool restricted, - bool contiguous, int codim) -{ - tree lbound[GFC_MAX_DIMENSIONS]; - tree ubound[GFC_MAX_DIMENSIONS]; - int n, corank; - - /* Assumed-shape arrays do not have codimension information stored in the - descriptor. */ - corank = MAX (as->corank, codim); - if (as->type == AS_ASSUMED_SHAPE || - (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE)) - corank = codim; - - if (as->type == AS_ASSUMED_RANK) - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - { - lbound[n] = NULL_TREE; - ubound[n] = NULL_TREE; - } - - for (n = 0; n < as->rank; n++) - { - /* Create expressions for the known bounds of the array. */ - if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL) - lbound[n] = gfc_index_one_node; - else - lbound[n] = gfc_conv_array_bound (as->lower[n]); - ubound[n] = gfc_conv_array_bound (as->upper[n]); - } - - for (n = as->rank; n < as->rank + corank; n++) - { - if (as->type != AS_DEFERRED && as->lower[n] == NULL) - lbound[n] = gfc_index_one_node; - else - lbound[n] = gfc_conv_array_bound (as->lower[n]); - - if (n < as->rank + corank - 1) - ubound[n] = gfc_conv_array_bound (as->upper[n]); - } - - if (as->type == AS_ASSUMED_SHAPE) - akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT - : GFC_ARRAY_ASSUMED_SHAPE; - else if (as->type == AS_ASSUMED_RANK) - akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT - : GFC_ARRAY_ASSUMED_RANK; - return gfc_get_array_type_bounds (type, as->rank == -1 - ? GFC_MAX_DIMENSIONS : as->rank, - corank, lbound, ubound, 0, akind, - restricted); -} - -/* Returns the struct descriptor_dimension type. */ - -static tree -gfc_get_desc_dim_type (void) -{ - tree type; - tree decl, *chain = NULL; - - if (gfc_desc_dim_type) - return gfc_desc_dim_type; - - /* Build the type node. */ - type = make_node (RECORD_TYPE); - - TYPE_NAME (type) = get_identifier ("descriptor_dimension"); - TYPE_PACKED (type) = 1; - - /* Consists of the stride, lbound and ubound members. */ - decl = gfc_add_field_to_struct_1 (type, - get_identifier ("stride"), - gfc_array_index_type, &chain); - suppress_warning (decl); - - decl = gfc_add_field_to_struct_1 (type, - get_identifier ("lbound"), - gfc_array_index_type, &chain); - suppress_warning (decl); - - decl = gfc_add_field_to_struct_1 (type, - get_identifier ("ubound"), - gfc_array_index_type, &chain); - suppress_warning (decl); - - /* Finish off the type. */ - gfc_finish_type (type); - TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; - - gfc_desc_dim_type = type; - return type; -} - - -/* Return the DTYPE for an array. This describes the type and type parameters - of the array. */ -/* TODO: Only call this when the value is actually used, and make all the - unknown cases abort. */ - -tree -gfc_get_dtype_rank_type (int rank, tree etype) -{ - tree ptype; - tree size; - int n; - tree tmp; - tree dtype; - tree field; - vec *v = NULL; - - ptype = etype; - while (TREE_CODE (etype) == POINTER_TYPE - || TREE_CODE (etype) == ARRAY_TYPE) - { - ptype = etype; - etype = TREE_TYPE (etype); - } - - gcc_assert (etype); - - switch (TREE_CODE (etype)) - { - case INTEGER_TYPE: - if (TREE_CODE (ptype) == ARRAY_TYPE - && TYPE_STRING_FLAG (ptype)) - n = BT_CHARACTER; - else - n = BT_INTEGER; - break; - - case BOOLEAN_TYPE: - n = BT_LOGICAL; - break; - - case REAL_TYPE: - n = BT_REAL; - break; - - case COMPLEX_TYPE: - n = BT_COMPLEX; - break; - - case RECORD_TYPE: - if (GFC_CLASS_TYPE_P (etype)) - n = BT_CLASS; - else - n = BT_DERIVED; - break; - - case FUNCTION_TYPE: - case VOID_TYPE: - n = BT_VOID; - break; - - default: - /* TODO: Don't do dtype for temporary descriptorless arrays. */ - /* We can encounter strange array types for temporary arrays. */ - gcc_unreachable (); - } - - switch (n) - { - case BT_CHARACTER: - gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE); - size = gfc_get_character_len_in_bytes (ptype); - break; - case BT_VOID: - gcc_assert (TREE_CODE (ptype) == POINTER_TYPE); - size = size_in_bytes (ptype); - break; - default: - size = size_in_bytes (etype); - break; - } - - gcc_assert (size); - - STRIP_NOPS (size); - size = fold_convert (size_type_node, size); - tmp = get_dtype_type_node (); - field = gfc_advance_chain (TYPE_FIELDS (tmp), - GFC_DTYPE_ELEM_LEN); - CONSTRUCTOR_APPEND_ELT (v, field, - fold_convert (TREE_TYPE (field), size)); - - field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), - GFC_DTYPE_RANK); - if (rank >= 0) - CONSTRUCTOR_APPEND_ELT (v, field, - build_int_cst (TREE_TYPE (field), rank)); - - field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), - GFC_DTYPE_TYPE); - CONSTRUCTOR_APPEND_ELT (v, field, - build_int_cst (TREE_TYPE (field), n)); - - dtype = build_constructor (tmp, v); - - return dtype; -} - - -tree -gfc_get_dtype (tree type, int * rank) -{ - tree dtype; - tree etype; - int irnk; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); - - irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type)); - etype = gfc_get_element_type (type); - dtype = gfc_get_dtype_rank_type (irnk, etype); - - GFC_TYPE_ARRAY_DTYPE (type) = dtype; - return dtype; -} - - -/* Build an array type for use without a descriptor, packed according - to the value of PACKED. */ - -tree -gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, - bool restricted) -{ - tree range; - tree type; - tree tmp; - int n; - int known_stride; - int known_offset; - mpz_t offset; - mpz_t stride; - mpz_t delta; - gfc_expr *expr; - - mpz_init_set_ui (offset, 0); - mpz_init_set_ui (stride, 1); - mpz_init (delta); - - /* We don't use build_array_type because this does not include - lang-specific information (i.e. the bounds of the array) when checking - for duplicates. */ - if (as->rank) - type = make_node (ARRAY_TYPE); - else - type = build_variant_type_copy (etype); - - GFC_ARRAY_TYPE_P (type) = 1; - TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc (); - - known_stride = (packed != PACKED_NO); - known_offset = 1; - for (n = 0; n < as->rank; n++) - { - /* Fill in the stride and bound components of the type. */ - if (known_stride) - tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); - else - tmp = NULL_TREE; - GFC_TYPE_ARRAY_STRIDE (type, n) = tmp; - - expr = as->lower[n]; - if (expr && expr->expr_type == EXPR_CONSTANT) - { - tmp = gfc_conv_mpz_to_tree (expr->value.integer, - gfc_index_integer_kind); - } - else - { - known_stride = 0; - tmp = NULL_TREE; - } - GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; - - if (known_stride) - { - /* Calculate the offset. */ - mpz_mul (delta, stride, as->lower[n]->value.integer); - mpz_sub (offset, offset, delta); - } - else - known_offset = 0; - - expr = as->upper[n]; - if (expr && expr->expr_type == EXPR_CONSTANT) - { - tmp = gfc_conv_mpz_to_tree (expr->value.integer, - gfc_index_integer_kind); - } - else - { - tmp = NULL_TREE; - known_stride = 0; - } - GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; - - if (known_stride) - { - /* Calculate the stride. */ - mpz_sub (delta, as->upper[n]->value.integer, - as->lower[n]->value.integer); - mpz_add_ui (delta, delta, 1); - mpz_mul (stride, stride, delta); - } - - /* Only the first stride is known for partial packed arrays. */ - if (packed == PACKED_NO || packed == PACKED_PARTIAL) - known_stride = 0; - } - for (n = as->rank; n < as->rank + as->corank; n++) - { - expr = as->lower[n]; - if (expr && expr->expr_type == EXPR_CONSTANT) - tmp = gfc_conv_mpz_to_tree (expr->value.integer, - gfc_index_integer_kind); - else - tmp = NULL_TREE; - GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; - - expr = as->upper[n]; - if (expr && expr->expr_type == EXPR_CONSTANT) - tmp = gfc_conv_mpz_to_tree (expr->value.integer, - gfc_index_integer_kind); - else - tmp = NULL_TREE; - if (n < as->rank + as->corank - 1) - GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; - } - - if (known_offset) - { - GFC_TYPE_ARRAY_OFFSET (type) = - gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); - } - else - GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE; - - if (known_stride) - { - GFC_TYPE_ARRAY_SIZE (type) = - gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); - } - else - GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE; - - GFC_TYPE_ARRAY_RANK (type) = as->rank; - GFC_TYPE_ARRAY_CORANK (type) = as->corank; - GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE; - range = build_range_type (gfc_array_index_type, gfc_index_zero_node, - NULL_TREE); - /* TODO: use main type if it is unbounded. */ - GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = - build_pointer_type (build_array_type (etype, range)); - if (restricted) - GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = - build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), - TYPE_QUAL_RESTRICT); - - if (as->rank == 0) - { - if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB) - { - type = build_pointer_type (type); - - if (restricted) - type = build_qualified_type (type, TYPE_QUAL_RESTRICT); - - GFC_ARRAY_TYPE_P (type) = 1; - TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); - } - - return type; - } - - if (known_stride) - { - mpz_sub_ui (stride, stride, 1); - range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); - } - else - range = NULL_TREE; - - range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range); - TYPE_DOMAIN (type) = range; - - build_pointer_type (etype); - TREE_TYPE (type) = etype; - - layout_type (type); - - mpz_clear (offset); - mpz_clear (stride); - mpz_clear (delta); - - /* Represent packed arrays as multi-dimensional if they have rank > - 1 and with proper bounds, instead of flat arrays. This makes for - better debug info. */ - if (known_offset) - { - tree gtype = etype, rtype, type_decl; - - for (n = as->rank - 1; n >= 0; n--) - { - rtype = build_range_type (gfc_array_index_type, - GFC_TYPE_ARRAY_LBOUND (type, n), - GFC_TYPE_ARRAY_UBOUND (type, n)); - gtype = build_array_type (gtype, rtype); - } - TYPE_NAME (type) = type_decl = build_decl (input_location, - TYPE_DECL, NULL, gtype); - DECL_ORIGINAL_TYPE (type_decl) = gtype; - } - - if (packed != PACKED_STATIC || !known_stride - || (as->corank && flag_coarray == GFC_FCOARRAY_LIB)) - { - /* For dummy arrays and automatic (heap allocated) arrays we - want a pointer to the array. */ - type = build_pointer_type (type); - if (restricted) - type = build_qualified_type (type, TYPE_QUAL_RESTRICT); - GFC_ARRAY_TYPE_P (type) = 1; - TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); - } - return type; -} - - -/* Return or create the base type for an array descriptor. */ - -static tree -gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) -{ - tree fat_type, decl, arraytype, *chain = NULL; - char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; - int idx; - - /* Assumed-rank array. */ - if (dimen == -1) - dimen = GFC_MAX_DIMENSIONS; - - idx = 2 * (codimen + dimen) + restricted; - - gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS); - - if (flag_coarray == GFC_FCOARRAY_LIB && codimen) - { - if (gfc_array_descriptor_base_caf[idx]) - return gfc_array_descriptor_base_caf[idx]; - } - else if (gfc_array_descriptor_base[idx]) - return gfc_array_descriptor_base[idx]; - - /* Build the type node. */ - fat_type = make_node (RECORD_TYPE); - - sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen); - TYPE_NAME (fat_type) = get_identifier (name); - TYPE_NAMELESS (fat_type) = 1; - - /* Add the data member as the first element of the descriptor. */ - gfc_add_field_to_struct_1 (fat_type, - get_identifier ("data"), - (restricted - ? prvoid_type_node - : ptr_type_node), &chain); - - /* Add the base component. */ - decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("offset"), - gfc_array_index_type, &chain); - suppress_warning (decl); - - /* Add the dtype component. */ - decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("dtype"), - get_dtype_type_node (), &chain); - suppress_warning (decl); - - /* Add the span component. */ - decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("span"), - gfc_array_index_type, &chain); - suppress_warning (decl); - - /* Build the array type for the stride and bound components. */ - if (dimen + codimen > 0) - { - arraytype = - build_array_type (gfc_get_desc_dim_type (), - build_range_type (gfc_array_index_type, - gfc_index_zero_node, - gfc_rank_cst[codimen + dimen - 1])); - - decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"), - arraytype, &chain); - suppress_warning (decl); - } - - if (flag_coarray == GFC_FCOARRAY_LIB) - { - decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("token"), - prvoid_type_node, &chain); - suppress_warning (decl); - } - - /* Finish off the type. */ - gfc_finish_type (fat_type); - TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1; - - if (flag_coarray == GFC_FCOARRAY_LIB && codimen) - gfc_array_descriptor_base_caf[idx] = fat_type; - else - gfc_array_descriptor_base[idx] = fat_type; - - return fat_type; -} - - -/* Build an array (descriptor) type with given bounds. */ - -tree -gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, - tree * ubound, int packed, - enum gfc_array_kind akind, bool restricted) -{ - char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN]; - tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype; - const char *type_name; - int n; - - base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted); - fat_type = build_distinct_type_copy (base_type); - /* Unshare TYPE_FIELDs. */ - for (tree *tp = &TYPE_FIELDS (fat_type); *tp; tp = &DECL_CHAIN (*tp)) - { - tree next = DECL_CHAIN (*tp); - *tp = copy_node (*tp); - DECL_CONTEXT (*tp) = fat_type; - DECL_CHAIN (*tp) = next; - } - /* Make sure that nontarget and target array type have the same canonical - type (and same stub decl for debug info). */ - base_type = gfc_get_array_descriptor_base (dimen, codimen, false); - TYPE_CANONICAL (fat_type) = base_type; - TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type); - /* Arrays of unknown type must alias with all array descriptors. */ - TYPE_TYPELESS_STORAGE (base_type) = 1; - TYPE_TYPELESS_STORAGE (fat_type) = 1; - gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type)); - - tmp = etype; - if (TREE_CODE (tmp) == ARRAY_TYPE - && TYPE_STRING_FLAG (tmp)) - tmp = TREE_TYPE (etype); - tmp = TYPE_NAME (tmp); - if (tmp && TREE_CODE (tmp) == TYPE_DECL) - tmp = DECL_NAME (tmp); - if (tmp) - type_name = IDENTIFIER_POINTER (tmp); - else - type_name = "unknown"; - sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen, - GFC_MAX_SYMBOL_LEN, type_name); - TYPE_NAME (fat_type) = get_identifier (name); - TYPE_NAMELESS (fat_type) = 1; - - GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; - TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc (); - - GFC_TYPE_ARRAY_RANK (fat_type) = dimen; - GFC_TYPE_ARRAY_CORANK (fat_type) = codimen; - GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE; - GFC_TYPE_ARRAY_AKIND (fat_type) = akind; - - /* Build an array descriptor record type. */ - if (packed != 0) - stride = gfc_index_one_node; - else - stride = NULL_TREE; - for (n = 0; n < dimen + codimen; n++) - { - if (n < dimen) - GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; - - if (lbound) - lower = lbound[n]; - else - lower = NULL_TREE; - - if (lower != NULL_TREE) - { - if (INTEGER_CST_P (lower)) - GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower; - else - lower = NULL_TREE; - } - - if (codimen && n == dimen + codimen - 1) - break; - - upper = ubound[n]; - if (upper != NULL_TREE) - { - if (INTEGER_CST_P (upper)) - GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper; - else - upper = NULL_TREE; - } - - if (n >= dimen) - continue; - - if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, - gfc_index_one_node); - stride = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, stride); - /* Check the folding worked. */ - gcc_assert (INTEGER_CST_P (stride)); - } - else - stride = NULL_TREE; - } - GFC_TYPE_ARRAY_SIZE (fat_type) = stride; - - /* TODO: known offsets for descriptors. */ - GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE; - - if (dimen == 0) - { - arraytype = build_pointer_type (etype); - if (restricted) - arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); - - GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; - return fat_type; - } - - /* We define data as an array with the correct size if possible. - Much better than doing pointer arithmetic. */ - if (stride) - rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node, - int_const_binop (MINUS_EXPR, stride, - build_int_cst (TREE_TYPE (stride), 1))); - else - rtype = gfc_array_range_type; - arraytype = build_array_type (etype, rtype); - arraytype = build_pointer_type (arraytype); - if (restricted) - arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); - GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; - - /* This will generate the base declarations we need to emit debug - information for this type. FIXME: there must be a better way to - avoid divergence between compilations with and without debug - information. */ - { - struct array_descr_info info; - gfc_get_array_descr_info (fat_type, &info); - gfc_get_array_descr_info (build_pointer_type (fat_type), &info); - } - - return fat_type; -} - -/* Build a pointer type. This function is called from gfc_sym_type(). */ - -static tree -gfc_build_pointer_type (gfc_symbol * sym, tree type) -{ - /* Array pointer types aren't actually pointers. */ - if (sym->attr.dimension) - return type; - else - return build_pointer_type (type); -} - -static tree gfc_nonrestricted_type (tree t); -/* Given two record or union type nodes TO and FROM, ensure - that all fields in FROM have a corresponding field in TO, - their type being nonrestrict variants. This accepts a TO - node that already has a prefix of the fields in FROM. */ -static void -mirror_fields (tree to, tree from) -{ - tree fto, ffrom; - tree *chain; - - /* Forward to the end of TOs fields. */ - fto = TYPE_FIELDS (to); - ffrom = TYPE_FIELDS (from); - chain = &TYPE_FIELDS (to); - while (fto) - { - gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom)); - chain = &DECL_CHAIN (fto); - fto = DECL_CHAIN (fto); - ffrom = DECL_CHAIN (ffrom); - } - - /* Now add all fields remaining in FROM (starting with ffrom). */ - for (; ffrom; ffrom = DECL_CHAIN (ffrom)) - { - tree newfield = copy_node (ffrom); - DECL_CONTEXT (newfield) = to; - /* The store to DECL_CHAIN might seem redundant with the - stores to *chain, but not clearing it here would mean - leaving a chain into the old fields. If ever - our called functions would look at them confusion - will arise. */ - DECL_CHAIN (newfield) = NULL_TREE; - *chain = newfield; - chain = &DECL_CHAIN (newfield); - - if (TREE_CODE (ffrom) == FIELD_DECL) - { - tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom)); - TREE_TYPE (newfield) = elemtype; - } - } - *chain = NULL_TREE; -} - -/* Given a type T, returns a different type of the same structure, - except that all types it refers to (recursively) are always - non-restrict qualified types. */ -static tree -gfc_nonrestricted_type (tree t) -{ - tree ret = t; - - /* If the type isn't laid out yet, don't copy it. If something - needs it for real it should wait until the type got finished. */ - if (!TYPE_SIZE (t)) - return t; - - if (!TYPE_LANG_SPECIFIC (t)) - TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc (); - /* If we're dealing with this very node already further up - the call chain (recursion via pointers and struct members) - we haven't yet determined if we really need a new type node. - Assume we don't, return T itself. */ - if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node) - return t; - - /* If we have calculated this all already, just return it. */ - if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type) - return TYPE_LANG_SPECIFIC (t)->nonrestricted_type; - - /* Mark this type. */ - TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node; - - switch (TREE_CODE (t)) - { - default: - break; - - case POINTER_TYPE: - case REFERENCE_TYPE: - { - tree totype = gfc_nonrestricted_type (TREE_TYPE (t)); - if (totype == TREE_TYPE (t)) - ret = t; - else if (TREE_CODE (t) == POINTER_TYPE) - ret = build_pointer_type (totype); - else - ret = build_reference_type (totype); - ret = build_qualified_type (ret, - TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT); - } - break; - - case ARRAY_TYPE: - { - tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t)); - if (elemtype == TREE_TYPE (t)) - ret = t; - else - { - ret = build_variant_type_copy (t); - TREE_TYPE (ret) = elemtype; - if (TYPE_LANG_SPECIFIC (t) - && GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) - { - tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t); - dataptr_type = gfc_nonrestricted_type (dataptr_type); - if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) - { - TYPE_LANG_SPECIFIC (ret) - = ggc_cleared_alloc (); - *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t); - GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type; - } - } - } - } - break; - - case RECORD_TYPE: - case UNION_TYPE: - case QUAL_UNION_TYPE: - { - tree field; - /* First determine if we need a new type at all. - Careful, the two calls to gfc_nonrestricted_type per field - might return different values. That happens exactly when - one of the fields reaches back to this very record type - (via pointers). The first calls will assume that we don't - need to copy T (see the error_mark_node marking). If there - are any reasons for copying T apart from having to copy T, - we'll indeed copy it, and the second calls to - gfc_nonrestricted_type will use that new node if they - reach back to T. */ - for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field)) - if (TREE_CODE (field) == FIELD_DECL) - { - tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field)); - if (elemtype != TREE_TYPE (field)) - break; - } - if (!field) - break; - ret = build_variant_type_copy (t); - TYPE_FIELDS (ret) = NULL_TREE; - - /* Here we make sure that as soon as we know we have to copy - T, that also fields reaching back to us will use the new - copy. It's okay if that copy still contains the old fields, - we won't look at them. */ - TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; - mirror_fields (ret, t); - } - break; - } - - TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; - return ret; -} - - -/* Return the type for a symbol. Special handling is required for character - types to get the correct level of indirection. - For functions return the return type. - For subroutines return void_type_node. - Calling this multiple times for the same symbol should be avoided, - especially for character and array types. */ - -tree -gfc_sym_type (gfc_symbol * sym, bool is_bind_c) -{ - tree type; - int byref; - bool restricted; - - /* Procedure Pointers inside COMMON blocks. */ - if (sym->attr.proc_pointer && sym->attr.in_common) - { - /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ - sym->attr.proc_pointer = 0; - type = build_pointer_type (gfc_get_function_type (sym)); - sym->attr.proc_pointer = 1; - return type; - } - - if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) - return void_type_node; - - /* In the case of a function the fake result variable may have a - type different from the function type, so don't return early in - that case. */ - if (sym->backend_decl && !sym->attr.function) - return TREE_TYPE (sym->backend_decl); - - if (sym->attr.result - && sym->ts.type == BT_CHARACTER - && sym->ts.u.cl->backend_decl == NULL_TREE - && sym->ns->proc_name - && sym->ns->proc_name->ts.u.cl - && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE) - sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl; - - if (sym->ts.type == BT_CHARACTER - && ((sym->attr.function && sym->attr.is_bind_c) - || ((sym->attr.result || sym->attr.value) - && sym->ns->proc_name - && sym->ns->proc_name->attr.is_bind_c) - || (sym->ts.deferred && (!sym->ts.u.cl - || !sym->ts.u.cl->backend_decl)))) - type = gfc_character1_type_node; - else - type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension); - - if (sym->attr.dummy && !sym->attr.function && !sym->attr.value - && !sym->pass_as_value) - byref = 1; - else - byref = 0; - - restricted = !sym->attr.target && !sym->attr.pointer - && !sym->attr.proc_pointer && !sym->attr.cray_pointee; - if (!restricted) - type = gfc_nonrestricted_type (type); - - /* Dummy argument to a bind(C) procedure. */ - if (is_bind_c && is_CFI_desc (sym, NULL)) - type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0, - /* restricted = */ false); - else if (sym->attr.dimension || sym->attr.codimension) - { - if (gfc_is_nodesc_array (sym)) - { - /* If this is a character argument of unknown length, just use the - base type. */ - if (sym->ts.type != BT_CHARACTER - || !(sym->attr.dummy || sym->attr.function) - || sym->ts.u.cl->backend_decl) - { - type = gfc_get_nodesc_array_type (type, sym->as, - byref ? PACKED_FULL - : PACKED_STATIC, - restricted); - byref = 0; - } - } - else - { - enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN; - if (sym->attr.pointer) - akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT - : GFC_ARRAY_POINTER; - else if (sym->attr.allocatable) - akind = GFC_ARRAY_ALLOCATABLE; - type = gfc_build_array_type (type, sym->as, akind, restricted, - sym->attr.contiguous, false); - } - } - else - { - if (sym->attr.allocatable || sym->attr.pointer - || gfc_is_associate_pointer (sym)) - type = gfc_build_pointer_type (sym, type); - } - - /* We currently pass all parameters by reference. - See f95_get_function_decl. For dummy function parameters return the - function type. */ - if (byref) - { - /* We must use pointer types for potentially absent variables. The - optimizers assume a reference type argument is never NULL. */ - if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) - || sym->attr.optional - || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master)) - type = build_pointer_type (type); - else - { - type = build_reference_type (type); - if (restricted) - type = build_qualified_type (type, TYPE_QUAL_RESTRICT); - } - } - - return (type); -} - -/* Layout and output debug info for a record type. */ - -void -gfc_finish_type (tree type) -{ - tree decl; - - decl = build_decl (input_location, - TYPE_DECL, NULL_TREE, type); - TYPE_STUB_DECL (type) = decl; - layout_type (type); - rest_of_type_compilation (type, 1); - rest_of_decl_compilation (decl, 1, 0); -} - -/* Add a field of given NAME and TYPE to the context of a UNION_TYPE - or RECORD_TYPE pointed to by CONTEXT. The new field is chained - to the end of the field list pointed to by *CHAIN. - - Returns a pointer to the new field. */ - -static tree -gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain) -{ - tree decl = build_decl (input_location, FIELD_DECL, name, type); - - DECL_CONTEXT (decl) = context; - DECL_CHAIN (decl) = NULL_TREE; - if (TYPE_FIELDS (context) == NULL_TREE) - TYPE_FIELDS (context) = decl; - if (chain != NULL) - { - if (*chain != NULL) - **chain = decl; - *chain = &DECL_CHAIN (decl); - } - - return decl; -} - -/* Like `gfc_add_field_to_struct_1', but adds alignment - information. */ - -tree -gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain) -{ - tree decl = gfc_add_field_to_struct_1 (context, name, type, chain); - - DECL_INITIAL (decl) = 0; - SET_DECL_ALIGN (decl, 0); - DECL_USER_ALIGN (decl) = 0; - - return decl; -} - - -/* Copy the backend_decl and component backend_decls if - the two derived type symbols are "equal", as described - in 4.4.2 and resolved by gfc_compare_derived_types. */ - -int -gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, - bool from_gsym) -{ - gfc_component *to_cm; - gfc_component *from_cm; - - if (from == to) - return 1; - - if (from->backend_decl == NULL - || !gfc_compare_derived_types (from, to)) - return 0; - - to->backend_decl = from->backend_decl; - - to_cm = to->components; - from_cm = from->components; - - /* Copy the component declarations. If a component is itself - a derived type, we need a copy of its component declarations. - This is done by recursing into gfc_get_derived_type and - ensures that the component's component declarations have - been built. If it is a character, we need the character - length, as well. */ - for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) - { - to_cm->backend_decl = from_cm->backend_decl; - to_cm->caf_token = from_cm->caf_token; - if (from_cm->ts.type == BT_UNION) - gfc_get_union_type (to_cm->ts.u.derived); - else if (from_cm->ts.type == BT_DERIVED - && (!from_cm->attr.pointer || from_gsym)) - gfc_get_derived_type (to_cm->ts.u.derived); - else if (from_cm->ts.type == BT_CLASS - && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym)) - gfc_get_derived_type (to_cm->ts.u.derived); - else if (from_cm->ts.type == BT_CHARACTER) - to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl; - } - - return 1; -} - - -/* Build a tree node for a procedure pointer component. */ - -static tree -gfc_get_ppc_type (gfc_component* c) -{ - tree t; - - /* Explicit interface. */ - if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface) - return build_pointer_type (gfc_get_function_type (c->ts.interface)); - - /* Implicit interface (only return value may be known). */ - if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER) - t = gfc_typenode_for_spec (&c->ts); - else - t = void_type_node; - - /* FIXME: it would be better to provide explicit interfaces in all - cases, since they should be known by the compiler. */ - return build_pointer_type (build_function_type (t, NULL_TREE)); -} - - -/* Build a tree node for a union type. Requires building each map - structure which is an element of the union. */ - -tree -gfc_get_union_type (gfc_symbol *un) -{ - gfc_component *map = NULL; - tree typenode = NULL, map_type = NULL, map_field = NULL; - tree *chain = NULL; - - if (un->backend_decl) - { - if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp) - return un->backend_decl; - else - typenode = un->backend_decl; - } - else - { - typenode = make_node (UNION_TYPE); - TYPE_NAME (typenode) = get_identifier (un->name); - } - - /* Add each contained MAP as a field. */ - for (map = un->components; map; map = map->next) - { - gcc_assert (map->ts.type == BT_DERIVED); - - /* The map's type node, which is defined within this union's context. */ - map_type = gfc_get_derived_type (map->ts.u.derived); - TYPE_CONTEXT (map_type) = typenode; - - /* The map field's declaration. */ - map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name), - map_type, &chain); - if (map->loc.lb) - gfc_set_decl_location (map_field, &map->loc); - else if (un->declared_at.lb) - gfc_set_decl_location (map_field, &un->declared_at); - - DECL_PACKED (map_field) |= TYPE_PACKED (typenode); - DECL_NAMELESS(map_field) = true; - - /* We should never clobber another backend declaration for this map, - because each map component is unique. */ - if (!map->backend_decl) - map->backend_decl = map_field; - } - - un->backend_decl = typenode; - gfc_finish_type (typenode); - - return typenode; -} - - -/* Build a tree node for a derived type. If there are equal - derived types, with different local names, these are built - at the same time. If an equal derived type has been built - in a parent namespace, this is used. */ - -tree -gfc_get_derived_type (gfc_symbol * derived, int codimen) -{ - tree typenode = NULL, field = NULL, field_type = NULL; - tree canonical = NULL_TREE; - tree *chain = NULL; - bool got_canonical = false; - bool unlimited_entity = false; - gfc_component *c; - gfc_namespace *ns; - tree tmp; - bool coarray_flag; - - coarray_flag = flag_coarray == GFC_FCOARRAY_LIB - && derived->module && !derived->attr.vtype; - - gcc_assert (!derived->attr.pdt_template); - - if (derived->attr.unlimited_polymorphic - || (flag_coarray == GFC_FCOARRAY_LIB - && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE - || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE - || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))) - return ptr_type_node; - - if (flag_coarray != GFC_FCOARRAY_LIB - && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE - || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)) - return gfc_get_int_type (gfc_default_integer_kind); - - if (derived && derived->attr.flavor == FL_PROCEDURE - && derived->attr.generic) - derived = gfc_find_dt_in_generic (derived); - - /* See if it's one of the iso_c_binding derived types. */ - if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID) - { - if (derived->backend_decl) - return derived->backend_decl; - - if (derived->intmod_sym_id == ISOCBINDING_PTR) - derived->backend_decl = ptr_type_node; - else - derived->backend_decl = pfunc_type_node; - - derived->ts.kind = gfc_index_integer_kind; - derived->ts.type = BT_INTEGER; - /* Set the f90_type to BT_VOID as a way to recognize something of type - BT_INTEGER that needs to fit a void * for the purpose of the - iso_c_binding derived types. */ - derived->ts.f90_type = BT_VOID; - - return derived->backend_decl; - } - - /* If use associated, use the module type for this one. */ - if (derived->backend_decl == NULL - && (derived->attr.use_assoc || derived->attr.used_in_submodule) - && derived->module - && gfc_get_module_backend_decl (derived)) - goto copy_derived_types; - - /* The derived types from an earlier namespace can be used as the - canonical type. */ - if (derived->backend_decl == NULL - && !derived->attr.use_assoc - && !derived->attr.used_in_submodule - && gfc_global_ns_list) - { - for (ns = gfc_global_ns_list; - ns->translated && !got_canonical; - ns = ns->sibling) - { - if (ns->derived_types) - { - for (gfc_symbol *dt = ns->derived_types; dt && !got_canonical; - dt = dt->dt_next) - { - gfc_copy_dt_decls_ifequal (dt, derived, true); - if (derived->backend_decl) - got_canonical = true; - if (dt->dt_next == ns->derived_types) - break; - } - } - } - } - - /* Store up the canonical type to be added to this one. */ - if (got_canonical) - { - if (TYPE_CANONICAL (derived->backend_decl)) - canonical = TYPE_CANONICAL (derived->backend_decl); - else - canonical = derived->backend_decl; - - derived->backend_decl = NULL_TREE; - } - - /* derived->backend_decl != 0 means we saw it before, but its - components' backend_decl may have not been built. */ - if (derived->backend_decl) - { - /* Its components' backend_decl have been built or we are - seeing recursion through the formal arglist of a procedure - pointer component. */ - if (TYPE_FIELDS (derived->backend_decl)) - return derived->backend_decl; - else if (derived->attr.abstract - && derived->attr.proc_pointer_comp) - { - /* If an abstract derived type with procedure pointer - components has no other type of component, return the - backend_decl. Otherwise build the components if any of the - non-procedure pointer components have no backend_decl. */ - for (c = derived->components; c; c = c->next) - { - bool same_alloc_type = c->attr.allocatable - && derived == c->ts.u.derived; - if (!c->attr.proc_pointer - && !same_alloc_type - && c->backend_decl == NULL) - break; - else if (c->next == NULL) - return derived->backend_decl; - } - typenode = derived->backend_decl; - } - else - typenode = derived->backend_decl; - } - else - { - /* We see this derived type first time, so build the type node. */ - typenode = make_node (RECORD_TYPE); - TYPE_NAME (typenode) = get_identifier (derived->name); - TYPE_PACKED (typenode) = flag_pack_derived; - derived->backend_decl = typenode; - } - - if (derived->components - && derived->components->ts.type == BT_DERIVED - && strcmp (derived->components->name, "_data") == 0 - && derived->components->ts.u.derived->attr.unlimited_polymorphic) - unlimited_entity = true; - - /* Go through the derived type components, building them as - necessary. The reason for doing this now is that it is - possible to recurse back to this derived type through a - pointer component (PR24092). If this happens, the fields - will be built and so we can return the type. */ - for (c = derived->components; c; c = c->next) - { - bool same_alloc_type = c->attr.allocatable - && derived == c->ts.u.derived; - - if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL) - c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived); - - if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) - continue; - - if ((!c->attr.pointer && !c->attr.proc_pointer - && !same_alloc_type) - || c->ts.u.derived->backend_decl == NULL) - { - int local_codim = c->attr.codimension ? c->as->corank: codimen; - c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived, - local_codim); - } - - if (c->ts.u.derived->attr.is_iso_c) - { - /* Need to copy the modified ts from the derived type. The - typespec was modified because C_PTR/C_FUNPTR are translated - into (void *) from derived types. */ - c->ts.type = c->ts.u.derived->ts.type; - c->ts.kind = c->ts.u.derived->ts.kind; - c->ts.f90_type = c->ts.u.derived->ts.f90_type; - if (c->initializer) - { - c->initializer->ts.type = c->ts.type; - c->initializer->ts.kind = c->ts.kind; - c->initializer->ts.f90_type = c->ts.f90_type; - c->initializer->expr_type = EXPR_NULL; - } - } - } - - if (TYPE_FIELDS (derived->backend_decl)) - return derived->backend_decl; - - /* Build the type member list. Install the newly created RECORD_TYPE - node as DECL_CONTEXT of each FIELD_DECL. In this case we must go - through only the top-level linked list of components so we correctly - build UNION_TYPE nodes for BT_UNION components. MAPs and other nested - types are built as part of gfc_get_union_type. */ - for (c = derived->components; c; c = c->next) - { - bool same_alloc_type = c->attr.allocatable - && derived == c->ts.u.derived; - /* Prevent infinite recursion, when the procedure pointer type is - the same as derived, by forcing the procedure pointer component to - be built as if the explicit interface does not exist. */ - if (c->attr.proc_pointer - && (c->ts.type != BT_DERIVED || (c->ts.u.derived - && !gfc_compare_derived_types (derived, c->ts.u.derived))) - && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived - && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived)))) - field_type = gfc_get_ppc_type (c); - else if (c->attr.proc_pointer && derived->backend_decl) - { - tmp = build_function_type (derived->backend_decl, NULL_TREE); - field_type = build_pointer_type (tmp); - } - else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - field_type = c->ts.u.derived->backend_decl; - else if (c->attr.caf_token) - field_type = pvoid_type_node; - else - { - if (c->ts.type == BT_CHARACTER - && !c->ts.deferred && !c->attr.pdt_string) - { - /* Evaluate the string length. */ - gfc_conv_const_charlen (c->ts.u.cl); - gcc_assert (c->ts.u.cl->backend_decl); - } - else if (c->ts.type == BT_CHARACTER) - c->ts.u.cl->backend_decl - = build_int_cst (gfc_charlen_type_node, 0); - - field_type = gfc_typenode_for_spec (&c->ts, codimen); - } - - /* This returns an array descriptor type. Initialization may be - required. */ - if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer ) - { - if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array) - { - enum gfc_array_kind akind; - if (c->attr.pointer) - akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT - : GFC_ARRAY_POINTER; - else - akind = GFC_ARRAY_ALLOCATABLE; - /* Pointers to arrays aren't actually pointer types. The - descriptors are separate, but the data is common. */ - field_type = gfc_build_array_type (field_type, c->as, akind, - !c->attr.target - && !c->attr.pointer, - c->attr.contiguous, - codimen); - } - else - field_type = gfc_get_nodesc_array_type (field_type, c->as, - PACKED_STATIC, - !c->attr.target); - } - else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string) - && !c->attr.proc_pointer - && !(unlimited_entity && c == derived->components)) - field_type = build_pointer_type (field_type); - - if (c->attr.pointer || same_alloc_type) - field_type = gfc_nonrestricted_type (field_type); - - /* vtype fields can point to different types to the base type. */ - if (c->ts.type == BT_DERIVED - && c->ts.u.derived && c->ts.u.derived->attr.vtype) - field_type = build_pointer_type_for_mode (TREE_TYPE (field_type), - ptr_mode, true); - - /* Ensure that the CLASS language specific flag is set. */ - if (c->ts.type == BT_CLASS) - { - if (POINTER_TYPE_P (field_type)) - GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1; - else - GFC_CLASS_TYPE_P (field_type) = 1; - } - - field = gfc_add_field_to_struct (typenode, - get_identifier (c->name), - field_type, &chain); - if (c->loc.lb) - gfc_set_decl_location (field, &c->loc); - else if (derived->declared_at.lb) - gfc_set_decl_location (field, &derived->declared_at); - - gfc_finish_decl_attrs (field, &c->attr); - - DECL_PACKED (field) |= TYPE_PACKED (typenode); - - gcc_assert (field); - if (!c->backend_decl) - c->backend_decl = field; - - if (c->attr.pointer && c->attr.dimension - && !(c->ts.type == BT_DERIVED - && strcmp (c->name, "_data") == 0)) - GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1; - } - - /* Now lay out the derived type, including the fields. */ - if (canonical) - TYPE_CANONICAL (typenode) = canonical; - - gfc_finish_type (typenode); - gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at); - if (derived->module && derived->ns->proc_name - && derived->ns->proc_name->attr.flavor == FL_MODULE) - { - if (derived->ns->proc_name->backend_decl - && TREE_CODE (derived->ns->proc_name->backend_decl) - == NAMESPACE_DECL) - { - TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl; - DECL_CONTEXT (TYPE_STUB_DECL (typenode)) - = derived->ns->proc_name->backend_decl; - } - } - - derived->backend_decl = typenode; - -copy_derived_types: - - for (c = derived->components; c; c = c->next) - { - /* Do not add a caf_token field for class container components. */ - if ((codimen || coarray_flag) - && !c->attr.dimension && !c->attr.codimension - && (c->attr.allocatable || c->attr.pointer) - && !derived->attr.is_class) - { - /* Provide sufficient space to hold "_caf_symbol". */ - char caf_name[GFC_MAX_SYMBOL_LEN + 6]; - gfc_component *token; - snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name); - token = gfc_find_component (derived, caf_name, true, true, NULL); - gcc_assert (token); - c->caf_token = token->backend_decl; - suppress_warning (c->caf_token); - } - } - - for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next) - { - gfc_copy_dt_decls_ifequal (derived, dt, false); - if (dt->dt_next == gfc_derived_types) - break; - } - - return derived->backend_decl; -} - - -int -gfc_return_by_reference (gfc_symbol * sym) -{ - if (!sym->attr.function) - return 0; - - if (sym->attr.dimension) - return 1; - - if (sym->ts.type == BT_CHARACTER - && !sym->attr.is_bind_c - && (!sym->attr.result - || !sym->ns->proc_name - || !sym->ns->proc_name->attr.is_bind_c)) - return 1; - - /* Possibly return complex numbers by reference for g77 compatibility. - We don't do this for calls to intrinsics (as the library uses the - -fno-f2c calling convention), nor for calls to functions which always - require an explicit interface, as no compatibility problems can - arise there. */ - if (flag_f2c && sym->ts.type == BT_COMPLEX - && !sym->attr.intrinsic && !sym->attr.always_explicit) - return 1; - - return 0; -} - -static tree -gfc_get_mixed_entry_union (gfc_namespace *ns) -{ - tree type; - tree *chain = NULL; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_entry_list *el, *el2; - - gcc_assert (ns->proc_name->attr.mixed_entry_master); - gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0); - - snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7); - - /* Build the type node. */ - type = make_node (UNION_TYPE); - - TYPE_NAME (type) = get_identifier (name); - - for (el = ns->entries; el; el = el->next) - { - /* Search for duplicates. */ - for (el2 = ns->entries; el2 != el; el2 = el2->next) - if (el2->sym->result == el->sym->result) - break; - - if (el == el2) - gfc_add_field_to_struct_1 (type, - get_identifier (el->sym->result->name), - gfc_sym_type (el->sym->result), &chain); - } - - /* Finish off the type. */ - gfc_finish_type (type); - TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; - return type; -} - -/* Create a "fn spec" based on the formal arguments; - cf. create_function_arglist. */ - -static tree -create_fn_spec (gfc_symbol *sym, tree fntype) -{ - char spec[150]; - size_t spec_len; - gfc_formal_arglist *f; - tree tmp; - - memset (&spec, 0, sizeof (spec)); - spec[0] = '.'; - spec[1] = ' '; - spec_len = 2; - - if (sym->attr.entry_master) - { - spec[spec_len++] = 'R'; - spec[spec_len++] = ' '; - } - if (gfc_return_by_reference (sym)) - { - gfc_symbol *result = sym->result ? sym->result : sym; - - if (result->attr.pointer || sym->attr.proc_pointer) - { - spec[spec_len++] = '.'; - spec[spec_len++] = ' '; - } - else - { - spec[spec_len++] = 'w'; - spec[spec_len++] = ' '; - } - if (sym->ts.type == BT_CHARACTER) - { - if (!sym->ts.u.cl->length - && (sym->attr.allocatable || sym->attr.pointer)) - spec[spec_len++] = 'w'; - else - spec[spec_len++] = 'R'; - spec[spec_len++] = ' '; - } - } - - for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) - if (spec_len < sizeof (spec)) - { - if (!f->sym || f->sym->attr.pointer || f->sym->attr.target - || f->sym->attr.external || f->sym->attr.cray_pointer - || (f->sym->ts.type == BT_DERIVED - && (f->sym->ts.u.derived->attr.proc_pointer_comp - || f->sym->ts.u.derived->attr.pointer_comp)) - || (f->sym->ts.type == BT_CLASS - && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp - || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp)) - || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop)) - { - spec[spec_len++] = '.'; - spec[spec_len++] = ' '; - } - else if (f->sym->attr.intent == INTENT_IN) - { - spec[spec_len++] = 'r'; - spec[spec_len++] = ' '; - } - else if (f->sym) - { - spec[spec_len++] = 'w'; - spec[spec_len++] = ' '; - } - } - - tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec)); - tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype)); - return build_type_attribute_variant (fntype, tmp); -} - - -/* NOTE: The returned function type must match the argument list created by - create_function_arglist. */ - -tree -gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, - const char *fnspec) -{ - tree type; - vec *typelist = NULL; - gfc_formal_arglist *f; - gfc_symbol *arg; - int alternate_return = 0; - bool is_varargs = true; - - /* Make sure this symbol is a function, a subroutine or the main - program. */ - gcc_assert (sym->attr.flavor == FL_PROCEDURE - || sym->attr.flavor == FL_PROGRAM); - - /* To avoid recursing infinitely on recursive types, we use error_mark_node - so that they can be detected here and handled further down. */ - if (sym->backend_decl == NULL) - sym->backend_decl = error_mark_node; - else if (sym->backend_decl == error_mark_node) - goto arg_type_list_done; - else if (sym->attr.proc_pointer) - return TREE_TYPE (TREE_TYPE (sym->backend_decl)); - else - return TREE_TYPE (sym->backend_decl); - - if (sym->attr.entry_master) - /* Additional parameter for selecting an entry point. */ - vec_safe_push (typelist, gfc_array_index_type); - - if (sym->result) - arg = sym->result; - else - arg = sym; - - if (arg->ts.type == BT_CHARACTER) - gfc_conv_const_charlen (arg->ts.u.cl); - - /* Some functions we use an extra parameter for the return value. */ - if (gfc_return_by_reference (sym)) - { - type = gfc_sym_type (arg); - if (arg->ts.type == BT_COMPLEX - || arg->attr.dimension - || arg->ts.type == BT_CHARACTER) - type = build_reference_type (type); - - vec_safe_push (typelist, type); - if (arg->ts.type == BT_CHARACTER) - { - if (!arg->ts.deferred) - /* Transfer by value. */ - vec_safe_push (typelist, gfc_charlen_type_node); - else - /* Deferred character lengths are transferred by reference - so that the value can be returned. */ - vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node)); - } - } - if (sym->backend_decl == error_mark_node && actual_args != NULL - && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL - || sym->attr.proc == PROC_UNKNOWN)) - gfc_get_formal_from_actual_arglist (sym, actual_args); - - /* Build the argument types for the function. */ - for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) - { - arg = f->sym; - if (arg) - { - /* Evaluate constant character lengths here so that they can be - included in the type. */ - if (arg->ts.type == BT_CHARACTER) - gfc_conv_const_charlen (arg->ts.u.cl); - - if (arg->attr.flavor == FL_PROCEDURE) - { - type = gfc_get_function_type (arg); - type = build_pointer_type (type); - } - else - type = gfc_sym_type (arg, sym->attr.is_bind_c); - - /* Parameter Passing Convention - - We currently pass all parameters by reference. - Parameters with INTENT(IN) could be passed by value. - The problem arises if a function is called via an implicit - prototype. In this situation the INTENT is not known. - For this reason all parameters to global functions must be - passed by reference. Passing by value would potentially - generate bad code. Worse there would be no way of telling that - this code was bad, except that it would give incorrect results. - - Contained procedures could pass by value as these are never - used without an explicit interface, and cannot be passed as - actual parameters for a dummy procedure. */ - - vec_safe_push (typelist, type); - } - else - { - if (sym->attr.subroutine) - alternate_return = 1; - } - } - - /* Add hidden arguments. */ - for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) - { - arg = f->sym; - /* Add hidden string length parameters. */ - if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c) - { - if (!arg->ts.deferred) - /* Transfer by value. */ - type = gfc_charlen_type_node; - else - /* Deferred character lengths are transferred by reference - so that the value can be returned. */ - type = build_pointer_type (gfc_charlen_type_node); - - vec_safe_push (typelist, type); - } - /* For noncharacter scalar intrinsic types, VALUE passes the value, - hence, the optional status cannot be transferred via a NULL pointer. - Thus, we will use a hidden argument in that case. */ - else if (arg - && arg->attr.optional - && arg->attr.value - && !arg->attr.dimension - && arg->ts.type != BT_CLASS - && !gfc_bt_struct (arg->ts.type)) - vec_safe_push (typelist, boolean_type_node); - /* Coarrays which are descriptorless or assumed-shape pass with - -fcoarray=lib the token and the offset as hidden arguments. */ - if (arg - && flag_coarray == GFC_FCOARRAY_LIB - && ((arg->ts.type != BT_CLASS - && arg->attr.codimension - && !arg->attr.allocatable) - || (arg->ts.type == BT_CLASS - && CLASS_DATA (arg)->attr.codimension - && !CLASS_DATA (arg)->attr.allocatable))) - { - vec_safe_push (typelist, pvoid_type_node); /* caf_token. */ - vec_safe_push (typelist, gfc_array_index_type); /* caf_offset. */ - } - } - - if (!vec_safe_is_empty (typelist) - || sym->attr.is_main_program - || sym->attr.if_source != IFSRC_UNKNOWN) - is_varargs = false; - - if (sym->backend_decl == error_mark_node) - sym->backend_decl = NULL_TREE; - -arg_type_list_done: - - if (alternate_return) - type = integer_type_node; - else if (!sym->attr.function || gfc_return_by_reference (sym)) - type = void_type_node; - else if (sym->attr.mixed_entry_master) - type = gfc_get_mixed_entry_union (sym->ns); - else if (flag_f2c && sym->ts.type == BT_REAL - && sym->ts.kind == gfc_default_real_kind - && !sym->attr.always_explicit) - { - /* Special case: f2c calling conventions require that (scalar) - default REAL functions return the C type double instead. f2c - compatibility is only an issue with functions that don't - require an explicit interface, as only these could be - implemented in Fortran 77. */ - sym->ts.kind = gfc_default_double_kind; - type = gfc_typenode_for_spec (&sym->ts); - sym->ts.kind = gfc_default_real_kind; - } - else if (sym->result && sym->result->attr.proc_pointer) - /* Procedure pointer return values. */ - { - if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0) - { - /* Unset proc_pointer as gfc_get_function_type - is called recursively. */ - sym->result->attr.proc_pointer = 0; - type = build_pointer_type (gfc_get_function_type (sym->result)); - sym->result->attr.proc_pointer = 1; - } - else - type = gfc_sym_type (sym->result); - } - else - type = gfc_sym_type (sym); - - if (is_varargs) - type = build_varargs_function_type_vec (type, typelist); - else - type = build_function_type_vec (type, typelist); - - /* If we were passed an fn spec, add it here, otherwise determine it from - the formal arguments. */ - if (fnspec) - { - tree tmp; - int spec_len = strlen (fnspec); - tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec)); - tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type)); - type = build_type_attribute_variant (type, tmp); - } - else - type = create_fn_spec (sym, type); - - return type; -} - -/* Language hooks for middle-end access to type nodes. */ - -/* Return an integer type with BITS bits of precision, - that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ - -tree -gfc_type_for_size (unsigned bits, int unsignedp) -{ - if (!unsignedp) - { - int i; - for (i = 0; i <= MAX_INT_KINDS; ++i) - { - tree type = gfc_integer_types[i]; - if (type && bits == TYPE_PRECISION (type)) - return type; - } - - /* Handle TImode as a special case because it is used by some backends - (e.g. ARM) even though it is not available for normal use. */ -#if HOST_BITS_PER_WIDE_INT >= 64 - if (bits == TYPE_PRECISION (intTI_type_node)) - return intTI_type_node; -#endif - - if (bits <= TYPE_PRECISION (intQI_type_node)) - return intQI_type_node; - if (bits <= TYPE_PRECISION (intHI_type_node)) - return intHI_type_node; - if (bits <= TYPE_PRECISION (intSI_type_node)) - return intSI_type_node; - if (bits <= TYPE_PRECISION (intDI_type_node)) - return intDI_type_node; - if (bits <= TYPE_PRECISION (intTI_type_node)) - return intTI_type_node; - } - else - { - if (bits <= TYPE_PRECISION (unsigned_intQI_type_node)) - return unsigned_intQI_type_node; - if (bits <= TYPE_PRECISION (unsigned_intHI_type_node)) - return unsigned_intHI_type_node; - if (bits <= TYPE_PRECISION (unsigned_intSI_type_node)) - return unsigned_intSI_type_node; - if (bits <= TYPE_PRECISION (unsigned_intDI_type_node)) - return unsigned_intDI_type_node; - if (bits <= TYPE_PRECISION (unsigned_intTI_type_node)) - return unsigned_intTI_type_node; - } - - return NULL_TREE; -} - -/* Return a data type that has machine mode MODE. If the mode is an - integer, then UNSIGNEDP selects between signed and unsigned types. */ - -tree -gfc_type_for_mode (machine_mode mode, int unsignedp) -{ - int i; - tree *base; - scalar_int_mode int_mode; - - if (GET_MODE_CLASS (mode) == MODE_FLOAT) - base = gfc_real_types; - else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT) - base = gfc_complex_types; - else if (is_a (mode, &int_mode)) - { - tree type = gfc_type_for_size (GET_MODE_PRECISION (int_mode), unsignedp); - return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE; - } - else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL - && valid_vector_subparts_p (GET_MODE_NUNITS (mode))) - { - unsigned int elem_bits = vector_element_size (GET_MODE_BITSIZE (mode), - GET_MODE_NUNITS (mode)); - tree bool_type = build_nonstandard_boolean_type (elem_bits); - return build_vector_type_for_mode (bool_type, mode); - } - else if (VECTOR_MODE_P (mode) - && valid_vector_subparts_p (GET_MODE_NUNITS (mode))) - { - machine_mode inner_mode = GET_MODE_INNER (mode); - tree inner_type = gfc_type_for_mode (inner_mode, unsignedp); - if (inner_type != NULL_TREE) - return build_vector_type_for_mode (inner_type, mode); - return NULL_TREE; - } - else - return NULL_TREE; - - for (i = 0; i <= MAX_REAL_KINDS; ++i) - { - tree type = base[i]; - if (type && mode == TYPE_MODE (type)) - return type; - } - - return NULL_TREE; -} - -/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO - in that case. */ - -bool -gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) -{ - int rank, dim; - bool indirect = false; - tree etype, ptype, t, base_decl; - tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size; - tree lower_suboff, upper_suboff, stride_suboff; - tree dtype, field, rank_off; - - if (! GFC_DESCRIPTOR_TYPE_P (type)) - { - if (! POINTER_TYPE_P (type)) - return false; - type = TREE_TYPE (type); - if (! GFC_DESCRIPTOR_TYPE_P (type)) - return false; - indirect = true; - } - - rank = GFC_TYPE_ARRAY_RANK (type); - if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0]))) - return false; - - etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); - gcc_assert (POINTER_TYPE_P (etype)); - etype = TREE_TYPE (etype); - - /* If the type is not a scalar coarray. */ - if (TREE_CODE (etype) == ARRAY_TYPE) - etype = TREE_TYPE (etype); - - /* Can't handle variable sized elements yet. */ - if (int_size_in_bytes (etype) <= 0) - return false; - /* Nor non-constant lower bounds in assumed shape arrays. */ - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE - || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) - { - for (dim = 0; dim < rank; dim++) - if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE - || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST) - return false; - } - - memset (info, '\0', sizeof (*info)); - info->ndimensions = rank; - info->ordering = array_descr_ordering_column_major; - info->element_type = etype; - ptype = build_pointer_type (gfc_array_index_type); - base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect); - if (!base_decl) - { - base_decl = build_debug_expr_decl (indirect - ? build_pointer_type (ptype) : ptype); - GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl; - } - info->base_decl = base_decl; - if (indirect) - base_decl = build1 (INDIRECT_REF, ptype, base_decl); - - gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off, - &dim_off, &dim_size, &stride_suboff, - &lower_suboff, &upper_suboff); - - t = fold_build_pointer_plus (base_decl, span_off); - elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t); - - t = base_decl; - if (!integer_zerop (data_off)) - t = fold_build_pointer_plus (t, data_off); - t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t); - info->data_location = build1 (INDIRECT_REF, ptr_type_node, t); - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) - info->allocated = build2 (NE_EXPR, logical_type_node, - info->data_location, null_pointer_node); - else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER - || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) - info->associated = build2 (NE_EXPR, logical_type_node, - info->data_location, null_pointer_node); - if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK - || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT) - && dwarf_version >= 5) - { - rank = 1; - info->ndimensions = 1; - t = base_decl; - if (!integer_zerop (dtype_off)) - t = fold_build_pointer_plus (t, dtype_off); - dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ()); - field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK); - rank_off = byte_position (field); - if (!integer_zerop (dtype_off)) - t = fold_build_pointer_plus (t, rank_off); - - t = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (field)), t); - t = build1 (INDIRECT_REF, TREE_TYPE (field), t); - info->rank = t; - t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off)); - t = size_binop (MULT_EXPR, t, dim_size); - dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off); - } - - for (dim = 0; dim < rank; dim++) - { - t = fold_build_pointer_plus (base_decl, - size_binop (PLUS_EXPR, - dim_off, lower_suboff)); - t = build1 (INDIRECT_REF, gfc_array_index_type, t); - info->dimen[dim].lower_bound = t; - t = fold_build_pointer_plus (base_decl, - size_binop (PLUS_EXPR, - dim_off, upper_suboff)); - t = build1 (INDIRECT_REF, gfc_array_index_type, t); - info->dimen[dim].upper_bound = t; - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE - || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) - { - /* Assumed shape arrays have known lower bounds. */ - info->dimen[dim].upper_bound - = build2 (MINUS_EXPR, gfc_array_index_type, - info->dimen[dim].upper_bound, - info->dimen[dim].lower_bound); - info->dimen[dim].lower_bound - = fold_convert (gfc_array_index_type, - GFC_TYPE_ARRAY_LBOUND (type, dim)); - info->dimen[dim].upper_bound - = build2 (PLUS_EXPR, gfc_array_index_type, - info->dimen[dim].lower_bound, - info->dimen[dim].upper_bound); - } - t = fold_build_pointer_plus (base_decl, - size_binop (PLUS_EXPR, - dim_off, stride_suboff)); - t = build1 (INDIRECT_REF, gfc_array_index_type, t); - t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size); - info->dimen[dim].stride = t; - if (dim + 1 < rank) - dim_off = size_binop (PLUS_EXPR, dim_off, dim_size); - } - - return true; -} - - -/* Create a type to handle vector subscripts for coarray library calls. It - has the form: - struct caf_vector_t { - size_t nvec; // size of the vector - union { - struct { - void *vector; - int kind; - } v; - struct { - ptrdiff_t lower_bound; - ptrdiff_t upper_bound; - ptrdiff_t stride; - } triplet; - } u; - } - where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector - size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */ - -tree -gfc_get_caf_vector_type (int dim) -{ - static tree vector_types[GFC_MAX_DIMENSIONS]; - static tree vec_type = NULL_TREE; - tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain; - - if (vector_types[dim-1] != NULL_TREE) - return vector_types[dim-1]; - - if (vec_type == NULL_TREE) - { - chain = 0; - vect_struct_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (vect_struct_type, - get_identifier ("vector"), - pvoid_type_node, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (vect_struct_type, - get_identifier ("kind"), - integer_type_node, &chain); - suppress_warning (tmp); - gfc_finish_type (vect_struct_type); - - chain = 0; - triplet_struct_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (triplet_struct_type, - get_identifier ("lower_bound"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (triplet_struct_type, - get_identifier ("upper_bound"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - gfc_finish_type (triplet_struct_type); - - chain = 0; - union_type = make_node (UNION_TYPE); - tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"), - vect_struct_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"), - triplet_struct_type, &chain); - suppress_warning (tmp); - gfc_finish_type (union_type); - - chain = 0; - vec_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"), - size_type_node, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"), - union_type, &chain); - suppress_warning (tmp); - gfc_finish_type (vec_type); - TYPE_NAME (vec_type) = get_identifier ("caf_vector_t"); - } - - tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, - gfc_rank_cst[dim-1]); - vector_types[dim-1] = build_array_type (vec_type, tmp); - return vector_types[dim-1]; -} - - -tree -gfc_get_caf_reference_type () -{ - static tree reference_type = NULL_TREE; - tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type, - a_struct_type, u_union_type, tmp, *chain; - - if (reference_type != NULL_TREE) - return reference_type; - - chain = 0; - c_struct_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (c_struct_type, - get_identifier ("offset"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (c_struct_type, - get_identifier ("caf_token_offset"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - gfc_finish_type (c_struct_type); - - chain = 0; - s_struct_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (s_struct_type, - get_identifier ("start"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (s_struct_type, - get_identifier ("end"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (s_struct_type, - get_identifier ("stride"), - gfc_array_index_type, &chain); - suppress_warning (tmp); - gfc_finish_type (s_struct_type); - - chain = 0; - v_struct_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (v_struct_type, - get_identifier ("vector"), - pvoid_type_node, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (v_struct_type, - get_identifier ("nvec"), - size_type_node, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (v_struct_type, - get_identifier ("kind"), - integer_type_node, &chain); - suppress_warning (tmp); - gfc_finish_type (v_struct_type); - - chain = 0; - union_type = make_node (UNION_TYPE); - tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"), - s_struct_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"), - v_struct_type, &chain); - suppress_warning (tmp); - gfc_finish_type (union_type); - - tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, - gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]); - dim_union_type = build_array_type (union_type, tmp); - - chain = 0; - a_struct_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"), - build_array_type (unsigned_char_type_node, - build_range_type (gfc_array_index_type, - gfc_index_zero_node, - gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])), - &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (a_struct_type, - get_identifier ("static_array_type"), - integer_type_node, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"), - dim_union_type, &chain); - suppress_warning (tmp); - gfc_finish_type (a_struct_type); - - chain = 0; - u_union_type = make_node (UNION_TYPE); - tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"), - c_struct_type, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"), - a_struct_type, &chain); - suppress_warning (tmp); - gfc_finish_type (u_union_type); - - chain = 0; - reference_type = make_node (RECORD_TYPE); - tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"), - build_pointer_type (reference_type), &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"), - integer_type_node, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"), - size_type_node, &chain); - suppress_warning (tmp); - tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"), - u_union_type, &chain); - suppress_warning (tmp); - gfc_finish_type (reference_type); - TYPE_NAME (reference_type) = get_identifier ("caf_reference_t"); - - return reference_type; -} - -static tree -gfc_get_cfi_dim_type () -{ - static tree CFI_dim_t = NULL; - - if (CFI_dim_t) - return CFI_dim_t; - - CFI_dim_t = make_node (RECORD_TYPE); - TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t"); - TYPE_NAMELESS (CFI_dim_t) = 1; - tree field; - tree *chain = NULL; - field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"), - gfc_array_index_type, &chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"), - gfc_array_index_type, &chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"), - gfc_array_index_type, &chain); - suppress_warning (field); - gfc_finish_type (CFI_dim_t); - TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1; - return CFI_dim_t; -} - - -/* Return the CFI type; use dimen == -1 for dim[] (only for pointers); - otherwise dim[dimen] is used. */ - -tree -gfc_get_cfi_type (int dimen, bool restricted) -{ - gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK); - - int idx = 2*(dimen + 1) + restricted; - - if (gfc_cfi_descriptor_base[idx]) - return gfc_cfi_descriptor_base[idx]; - - /* Build the type node. */ - tree CFI_cdesc_t = make_node (RECORD_TYPE); - char name[GFC_MAX_SYMBOL_LEN + 1]; - if (dimen != -1) - sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen); - TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name); - TYPE_NAMELESS (CFI_cdesc_t) = 1; - - tree field; - tree *chain = NULL; - field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"), - (restricted ? prvoid_type_node - : ptr_type_node), &chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"), - size_type_node, &chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"), - integer_type_node, &chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"), - signed_char_type_node, &chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"), - signed_char_type_node, &chain); - suppress_warning (field); - field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"), - get_typenode_from_name (INT16_TYPE), - &chain); - suppress_warning (field); - - if (dimen != 0) - { - tree range = NULL_TREE; - if (dimen > 0) - range = gfc_rank_cst[dimen - 1]; - range = build_range_type (gfc_array_index_type, gfc_index_zero_node, - range); - tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range); - field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"), - CFI_dim_t, &chain); - suppress_warning (field); - } - - TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1; - gfc_finish_type (CFI_cdesc_t); - gfc_cfi_descriptor_base[idx] = CFI_cdesc_t; - return CFI_cdesc_t; -} - -#include "gt-fortran-trans-types.h" diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc new file mode 100644 index 0000000..5de43bb --- /dev/null +++ b/gcc/fortran/trans-types.cc @@ -0,0 +1,3838 @@ +/* Backend support for Fortran 95 basic types and derived types. + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + and Steven Bosscher + +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 +. */ + +/* trans-types.c -- gfortran backend types */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "target.h" +#include "tree.h" +#include "gfortran.h" +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "stor-layout.h" +#include "langhooks.h" /* For iso-c-bindings.def. */ +#include "toplev.h" /* For rest_of_decl_compilation. */ +#include "trans-types.h" +#include "trans-const.h" +#include "trans-array.h" +#include "dwarf2out.h" /* For struct array_descr_info. */ +#include "attribs.h" +#include "alias.h" + + +#if (GFC_MAX_DIMENSIONS < 10) +#define GFC_RANK_DIGITS 1 +#define GFC_RANK_PRINTF_FORMAT "%01d" +#elif (GFC_MAX_DIMENSIONS < 100) +#define GFC_RANK_DIGITS 2 +#define GFC_RANK_PRINTF_FORMAT "%02d" +#else +#error If you really need >99 dimensions, continue the sequence above... +#endif + +/* array of structs so we don't have to worry about xmalloc or free */ +CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER]; + +tree gfc_array_index_type; +tree gfc_array_range_type; +tree gfc_character1_type_node; +tree pvoid_type_node; +tree prvoid_type_node; +tree ppvoid_type_node; +tree pchar_type_node; +static tree pfunc_type_node; + +tree logical_type_node; +tree logical_true_node; +tree logical_false_node; +tree gfc_charlen_type_node; + +tree gfc_float128_type_node = NULL_TREE; +tree gfc_complex_float128_type_node = NULL_TREE; + +bool gfc_real16_is_float128 = false; + +static GTY(()) tree gfc_desc_dim_type; +static GTY(()) tree gfc_max_array_element_size; +static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)]; +static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)]; +static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)]; + +/* Arrays for all integral and real kinds. We'll fill this in at runtime + after the target has a chance to process command-line options. */ + +#define MAX_INT_KINDS 5 +gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1]; +gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1]; +static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1]; +static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1]; + +#define MAX_REAL_KINDS 5 +gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1]; +static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1]; +static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1]; + +#define MAX_CHARACTER_KINDS 2 +gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1]; +static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1]; +static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1]; + +static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **); + +/* The integer kind to use for array indices. This will be set to the + proper value based on target information from the backend. */ + +int gfc_index_integer_kind; + +/* The default kinds of the various types. */ + +int gfc_default_integer_kind; +int gfc_max_integer_kind; +int gfc_default_real_kind; +int gfc_default_double_kind; +int gfc_default_character_kind; +int gfc_default_logical_kind; +int gfc_default_complex_kind; +int gfc_c_int_kind; +int gfc_c_intptr_kind; +int gfc_atomic_int_kind; +int gfc_atomic_logical_kind; + +/* The kind size used for record offsets. If the target system supports + kind=8, this will be set to 8, otherwise it is set to 4. */ +int gfc_intio_kind; + +/* The integer kind used to store character lengths. */ +int gfc_charlen_int_kind; + +/* Kind of internal integer for storing object sizes. */ +int gfc_size_kind; + +/* The size of the numeric storage unit and character storage unit. */ +int gfc_numeric_storage_size; +int gfc_character_storage_size; + +static tree dtype_type_node = NULL_TREE; + + +/* Build the dtype_type_node if necessary. */ +tree get_dtype_type_node (void) +{ + tree field; + tree dtype_node; + tree *dtype_chain = NULL; + + if (dtype_type_node == NULL_TREE) + { + dtype_node = make_node (RECORD_TYPE); + TYPE_NAME (dtype_node) = get_identifier ("dtype_type"); + TYPE_NAMELESS (dtype_node) = 1; + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("elem_len"), + size_type_node, &dtype_chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("version"), + integer_type_node, &dtype_chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("rank"), + signed_char_type_node, &dtype_chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("type"), + signed_char_type_node, &dtype_chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (dtype_node, + get_identifier ("attribute"), + short_integer_type_node, &dtype_chain); + suppress_warning (field); + gfc_finish_type (dtype_node); + TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1; + dtype_type_node = dtype_node; + } + return dtype_type_node; +} + +static int +get_real_kind_from_node (tree type) +{ + int i; + + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type)) + return gfc_real_kinds[i].kind; + + return -4; +} + +static int +get_int_kind_from_node (tree type) +{ + int i; + + if (!type) + return -2; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type)) + return gfc_integer_kinds[i].kind; + + return -1; +} + +static int +get_int_kind_from_name (const char *name) +{ + return get_int_kind_from_node (get_typenode_from_name (name)); +} + + +/* Get the kind number corresponding to an integer of given size, + following the required return values for ISO_FORTRAN_ENV INT* constants: + -2 is returned if we support a kind of larger size, -1 otherwise. */ +int +gfc_get_int_kind_from_width_isofortranenv (int size) +{ + int i; + + /* Look for a kind with matching storage size. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size == size) + return gfc_integer_kinds[i].kind; + + /* Look for a kind with larger storage size. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size > size) + return -2; + + return -1; +} + + +/* Get the kind number corresponding to a real of a given storage size. + If two real's have the same storage size, then choose the real with + the largest precision. If a kind type is unavailable and a real + exists with wider storage, then return -2; otherwise, return -1. */ + +int +gfc_get_real_kind_from_width_isofortranenv (int size) +{ + int digits, i, kind; + + size /= 8; + + kind = -1; + digits = 0; + + /* Look for a kind with matching storage size. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size) + { + if (gfc_real_kinds[i].digits > digits) + { + digits = gfc_real_kinds[i].digits; + kind = gfc_real_kinds[i].kind; + } + } + + if (kind != -1) + return kind; + + /* Look for a kind with larger storage size. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size) + kind = -2; + + return kind; +} + + + +static int +get_int_kind_from_width (int size) +{ + int i; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size == size) + return gfc_integer_kinds[i].kind; + + return -2; +} + +static int +get_int_kind_from_minimal_width (int size) +{ + int i; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].bit_size >= size) + return gfc_integer_kinds[i].kind; + + return -2; +} + + +/* Generate the CInteropKind_t objects for the C interoperable + kinds. */ + +void +gfc_init_c_interop_kinds (void) +{ + int i; + + /* init all pointers in the list to NULL */ + for (i = 0; i < ISOCBINDING_NUMBER; i++) + { + /* Initialize the name and value fields. */ + c_interop_kinds_table[i].name[0] = '\0'; + c_interop_kinds_table[i].value = -100; + c_interop_kinds_table[i].f90_type = BT_UNKNOWN; + } + +#define NAMED_INTCST(a,b,c,d) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_INTEGER; \ + c_interop_kinds_table[a].value = c; +#define NAMED_REALCST(a,b,c,d) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_REAL; \ + c_interop_kinds_table[a].value = c; +#define NAMED_CMPXCST(a,b,c,d) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_COMPLEX; \ + c_interop_kinds_table[a].value = c; +#define NAMED_LOGCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_LOGICAL; \ + c_interop_kinds_table[a].value = c; +#define NAMED_CHARKNDCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ + c_interop_kinds_table[a].value = c; +#define NAMED_CHARCST(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ + c_interop_kinds_table[a].value = c; +#define DERIVED_TYPE(a,b,c) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_DERIVED; \ + c_interop_kinds_table[a].value = c; +#define NAMED_FUNCTION(a,b,c,d) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \ + c_interop_kinds_table[a].value = c; +#define NAMED_SUBROUTINE(a,b,c,d) \ + strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ + c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \ + c_interop_kinds_table[a].value = c; +#include "iso-c-binding.def" +} + + +/* Query the target to determine which machine modes are available for + computation. Choose KIND numbers for them. */ + +void +gfc_init_kinds (void) +{ + opt_scalar_int_mode int_mode_iter; + opt_scalar_float_mode float_mode_iter; + int i_index, r_index, kind; + bool saw_i4 = false, saw_i8 = false; + bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false; + scalar_mode r16_mode = QImode; + scalar_mode composite_mode = QImode; + + i_index = 0; + FOR_EACH_MODE_IN_CLASS (int_mode_iter, MODE_INT) + { + scalar_int_mode mode = int_mode_iter.require (); + int kind, bitsize; + + if (!targetm.scalar_mode_supported_p (mode)) + continue; + + /* The middle end doesn't support constants larger than 2*HWI. + Perhaps the target hook shouldn't have accepted these either, + but just to be safe... */ + bitsize = GET_MODE_BITSIZE (mode); + if (bitsize > 2*HOST_BITS_PER_WIDE_INT) + continue; + + gcc_assert (i_index != MAX_INT_KINDS); + + /* Let the kind equal the bit size divided by 8. This insulates the + programmer from the underlying byte size. */ + kind = bitsize / 8; + + if (kind == 4) + saw_i4 = true; + if (kind == 8) + saw_i8 = true; + + gfc_integer_kinds[i_index].kind = kind; + gfc_integer_kinds[i_index].radix = 2; + gfc_integer_kinds[i_index].digits = bitsize - 1; + gfc_integer_kinds[i_index].bit_size = bitsize; + + gfc_logical_kinds[i_index].kind = kind; + gfc_logical_kinds[i_index].bit_size = bitsize; + + i_index += 1; + } + + /* Set the kind used to match GFC_INT_IO in libgfortran. This is + used for large file access. */ + + if (saw_i8) + gfc_intio_kind = 8; + else + gfc_intio_kind = 4; + + /* If we do not at least have kind = 4, everything is pointless. */ + gcc_assert(saw_i4); + + /* Set the maximum integer kind. Used with at least BOZ constants. */ + gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind; + + r_index = 0; + FOR_EACH_MODE_IN_CLASS (float_mode_iter, MODE_FLOAT) + { + scalar_float_mode mode = float_mode_iter.require (); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + int kind; + + if (fmt == NULL) + continue; + if (!targetm.scalar_mode_supported_p (mode)) + continue; + + if (MODE_COMPOSITE_P (mode) + && (GET_MODE_PRECISION (mode) + 7) / 8 == 16) + composite_mode = mode; + + /* Only let float, double, long double and TFmode go through. + Runtime support for others is not provided, so they would be + useless. */ + if (!targetm.libgcc_floating_mode_supported_p (mode)) + continue; + if (mode != TYPE_MODE (float_type_node) + && (mode != TYPE_MODE (double_type_node)) + && (mode != TYPE_MODE (long_double_type_node)) +#if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT) + && (mode != TFmode) +#endif + ) + continue; + + /* Let the kind equal the precision divided by 8, rounding up. Again, + this insulates the programmer from the underlying byte size. + + Also, it effectively deals with IEEE extended formats. There, the + total size of the type may equal 16, but it's got 6 bytes of padding + and the increased size can get in the way of a real IEEE quad format + which may also be supported by the target. + + We round up so as to handle IA-64 __floatreg (RFmode), which is an + 82 bit type. Not to be confused with __float80 (XFmode), which is + an 80 bit type also supported by IA-64. So XFmode should come out + to be kind=10, and RFmode should come out to be kind=11. Egads. + + TODO: The kind calculation has to be modified to support all + three 128-bit floating-point modes on PowerPC as IFmode, KFmode, + and TFmode since the following line would all map to kind=16. + However, currently only float, double, long double, and TFmode + reach this code. + */ + + kind = (GET_MODE_PRECISION (mode) + 7) / 8; + + if (kind == 4) + saw_r4 = true; + if (kind == 8) + saw_r8 = true; + if (kind == 10) + saw_r10 = true; + if (kind == 16) + { + saw_r16 = true; + r16_mode = mode; + } + + /* Careful we don't stumble a weird internal mode. */ + gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind); + /* Or have too many modes for the allocated space. */ + gcc_assert (r_index != MAX_REAL_KINDS); + + gfc_real_kinds[r_index].kind = kind; + gfc_real_kinds[r_index].abi_kind = kind; + gfc_real_kinds[r_index].radix = fmt->b; + gfc_real_kinds[r_index].digits = fmt->p; + gfc_real_kinds[r_index].min_exponent = fmt->emin; + gfc_real_kinds[r_index].max_exponent = fmt->emax; + if (fmt->pnan < fmt->p) + /* This is an IBM extended double format (or the MIPS variant) + made up of two IEEE doubles. The value of the long double is + the sum of the values of the two parts. The most significant + part is required to be the value of the long double rounded + to the nearest double. If we use emax of 1024 then we can't + represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because + rounding will make the most significant part overflow. */ + gfc_real_kinds[r_index].max_exponent = fmt->emax - 1; + gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode); + r_index += 1; + } + + /* Detect the powerpc64le-linux case with -mabi=ieeelongdouble, where + the long double type is non-MODE_COMPOSITE_P TFmode but one can use + -mabi=ibmlongdouble too and get MODE_COMPOSITE_P TFmode with the same + precision. For libgfortran calls pretend the IEEE 754 quad TFmode has + kind 17 rather than 16 and use kind 16 for the IBM extended format + TFmode. */ + if (composite_mode != QImode && saw_r16 && !MODE_COMPOSITE_P (r16_mode)) + { + for (int i = 0; i < r_index; ++i) + if (gfc_real_kinds[i].kind == 16) + { + gfc_real_kinds[i].abi_kind = 17; + if (flag_building_libgfortran + && (TARGET_GLIBC_MAJOR < 2 + || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR < 32))) + { + gfc_real16_is_float128 = true; + gfc_real_kinds[i].c_float128 = 1; + } + } + } + + /* Choose the default integer kind. We choose 4 unless the user directs us + otherwise. Even if the user specified that the default integer kind is 8, + the numeric storage size is not 64 bits. In this case, a warning will be + issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */ + + gfc_numeric_storage_size = 4 * 8; + + if (flag_default_integer) + { + if (!saw_i8) + gfc_fatal_error ("INTEGER(KIND=8) is not available for " + "%<-fdefault-integer-8%> option"); + + gfc_default_integer_kind = 8; + + } + else if (flag_integer4_kind == 8) + { + if (!saw_i8) + gfc_fatal_error ("INTEGER(KIND=8) is not available for " + "%<-finteger-4-integer-8%> option"); + + gfc_default_integer_kind = 8; + } + else if (saw_i4) + { + gfc_default_integer_kind = 4; + } + else + { + gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind; + gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size; + } + + /* Choose the default real kind. Again, we choose 4 when possible. */ + if (flag_default_real_8) + { + if (!saw_r8) + gfc_fatal_error ("REAL(KIND=8) is not available for " + "%<-fdefault-real-8%> option"); + + gfc_default_real_kind = 8; + } + else if (flag_default_real_10) + { + if (!saw_r10) + gfc_fatal_error ("REAL(KIND=10) is not available for " + "%<-fdefault-real-10%> option"); + + gfc_default_real_kind = 10; + } + else if (flag_default_real_16) + { + if (!saw_r16) + gfc_fatal_error ("REAL(KIND=16) is not available for " + "%<-fdefault-real-16%> option"); + + gfc_default_real_kind = 16; + } + else if (flag_real4_kind == 8) + { + if (!saw_r8) + gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> " + "option"); + + gfc_default_real_kind = 8; + } + else if (flag_real4_kind == 10) + { + if (!saw_r10) + gfc_fatal_error ("REAL(KIND=10) is not available for " + "%<-freal-4-real-10%> option"); + + gfc_default_real_kind = 10; + } + else if (flag_real4_kind == 16) + { + if (!saw_r16) + gfc_fatal_error ("REAL(KIND=16) is not available for " + "%<-freal-4-real-16%> option"); + + gfc_default_real_kind = 16; + } + else if (saw_r4) + gfc_default_real_kind = 4; + else + gfc_default_real_kind = gfc_real_kinds[0].kind; + + /* Choose the default double kind. If -fdefault-real and -fdefault-double + are specified, we use kind=8, if it's available. If -fdefault-real is + specified without -fdefault-double, we use kind=16, if it's available. + Otherwise we do not change anything. */ + if (flag_default_double && saw_r8) + gfc_default_double_kind = 8; + else if (flag_default_real_8 || flag_default_real_10 || flag_default_real_16) + { + /* Use largest available kind. */ + if (saw_r16) + gfc_default_double_kind = 16; + else if (saw_r10) + gfc_default_double_kind = 10; + else if (saw_r8) + gfc_default_double_kind = 8; + else + gfc_default_double_kind = gfc_default_real_kind; + } + else if (flag_real8_kind == 4) + { + if (!saw_r4) + gfc_fatal_error ("REAL(KIND=4) is not available for " + "%<-freal-8-real-4%> option"); + + gfc_default_double_kind = 4; + } + else if (flag_real8_kind == 10 ) + { + if (!saw_r10) + gfc_fatal_error ("REAL(KIND=10) is not available for " + "%<-freal-8-real-10%> option"); + + gfc_default_double_kind = 10; + } + else if (flag_real8_kind == 16 ) + { + if (!saw_r16) + gfc_fatal_error ("REAL(KIND=10) is not available for " + "%<-freal-8-real-16%> option"); + + gfc_default_double_kind = 16; + } + else if (saw_r4 && saw_r8) + gfc_default_double_kind = 8; + else + { + /* F95 14.6.3.1: A nonpointer scalar object of type double precision + real ... occupies two contiguous numeric storage units. + + Therefore we must be supplied a kind twice as large as we chose + for single precision. There are loopholes, in that double + precision must *occupy* two storage units, though it doesn't have + to *use* two storage units. Which means that you can make this + kind artificially wide by padding it. But at present there are + no GCC targets for which a two-word type does not exist, so we + just let gfc_validate_kind abort and tell us if something breaks. */ + + gfc_default_double_kind + = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false); + } + + /* The default logical kind is constrained to be the same as the + default integer kind. Similarly with complex and real. */ + gfc_default_logical_kind = gfc_default_integer_kind; + gfc_default_complex_kind = gfc_default_real_kind; + + /* We only have two character kinds: ASCII and UCS-4. + ASCII corresponds to a 8-bit integer type, if one is available. + UCS-4 corresponds to a 32-bit integer type, if one is available. */ + i_index = 0; + if ((kind = get_int_kind_from_width (8)) > 0) + { + gfc_character_kinds[i_index].kind = kind; + gfc_character_kinds[i_index].bit_size = 8; + gfc_character_kinds[i_index].name = "ascii"; + i_index++; + } + if ((kind = get_int_kind_from_width (32)) > 0) + { + gfc_character_kinds[i_index].kind = kind; + gfc_character_kinds[i_index].bit_size = 32; + gfc_character_kinds[i_index].name = "iso_10646"; + i_index++; + } + + /* Choose the smallest integer kind for our default character. */ + gfc_default_character_kind = gfc_character_kinds[0].kind; + gfc_character_storage_size = gfc_default_character_kind * 8; + + gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE); + + /* Pick a kind the same size as the C "int" type. */ + gfc_c_int_kind = INT_TYPE_SIZE / 8; + + /* Choose atomic kinds to match C's int. */ + gfc_atomic_int_kind = gfc_c_int_kind; + gfc_atomic_logical_kind = gfc_c_int_kind; + + gfc_c_intptr_kind = POINTER_SIZE / 8; +} + + +/* Make sure that a valid kind is present. Returns an index into the + associated kinds array, -1 if the kind is not present. */ + +static int +validate_integer (int kind) +{ + int i; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].kind == kind) + return i; + + return -1; +} + +static int +validate_real (int kind) +{ + int i; + + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + if (gfc_real_kinds[i].kind == kind) + return i; + + return -1; +} + +static int +validate_logical (int kind) +{ + int i; + + for (i = 0; gfc_logical_kinds[i].kind; i++) + if (gfc_logical_kinds[i].kind == kind) + return i; + + return -1; +} + +static int +validate_character (int kind) +{ + int i; + + for (i = 0; gfc_character_kinds[i].kind; i++) + if (gfc_character_kinds[i].kind == kind) + return i; + + return -1; +} + +/* Validate a kind given a basic type. The return value is the same + for the child functions, with -1 indicating nonexistence of the + type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */ + +int +gfc_validate_kind (bt type, int kind, bool may_fail) +{ + int rc; + + switch (type) + { + case BT_REAL: /* Fall through */ + case BT_COMPLEX: + rc = validate_real (kind); + break; + case BT_INTEGER: + rc = validate_integer (kind); + break; + case BT_LOGICAL: + rc = validate_logical (kind); + break; + case BT_CHARACTER: + rc = validate_character (kind); + break; + + default: + gfc_internal_error ("gfc_validate_kind(): Got bad type"); + } + + if (rc < 0 && !may_fail) + gfc_internal_error ("gfc_validate_kind(): Got bad kind"); + + return rc; +} + + +/* Four subroutines of gfc_init_types. Create type nodes for the given kind. + Reuse common type nodes where possible. Recognize if the kind matches up + with a C type. This will be used later in determining which routines may + be scarfed from libm. */ + +static tree +gfc_build_int_type (gfc_integer_info *info) +{ + int mode_precision = info->bit_size; + + if (mode_precision == CHAR_TYPE_SIZE) + info->c_char = 1; + if (mode_precision == SHORT_TYPE_SIZE) + info->c_short = 1; + if (mode_precision == INT_TYPE_SIZE) + info->c_int = 1; + if (mode_precision == LONG_TYPE_SIZE) + info->c_long = 1; + if (mode_precision == LONG_LONG_TYPE_SIZE) + info->c_long_long = 1; + + if (TYPE_PRECISION (intQI_type_node) == mode_precision) + return intQI_type_node; + if (TYPE_PRECISION (intHI_type_node) == mode_precision) + return intHI_type_node; + if (TYPE_PRECISION (intSI_type_node) == mode_precision) + return intSI_type_node; + if (TYPE_PRECISION (intDI_type_node) == mode_precision) + return intDI_type_node; + if (TYPE_PRECISION (intTI_type_node) == mode_precision) + return intTI_type_node; + + return make_signed_type (mode_precision); +} + +tree +gfc_build_uint_type (int size) +{ + if (size == CHAR_TYPE_SIZE) + return unsigned_char_type_node; + if (size == SHORT_TYPE_SIZE) + return short_unsigned_type_node; + if (size == INT_TYPE_SIZE) + return unsigned_type_node; + if (size == LONG_TYPE_SIZE) + return long_unsigned_type_node; + if (size == LONG_LONG_TYPE_SIZE) + return long_long_unsigned_type_node; + + return make_unsigned_type (size); +} + + +static tree +gfc_build_real_type (gfc_real_info *info) +{ + int mode_precision = info->mode_precision; + tree new_type; + + if (mode_precision == FLOAT_TYPE_SIZE) + info->c_float = 1; + if (mode_precision == DOUBLE_TYPE_SIZE) + info->c_double = 1; + if (mode_precision == LONG_DOUBLE_TYPE_SIZE && !info->c_float128) + info->c_long_double = 1; + if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128) + { + /* TODO: see PR101835. */ + info->c_float128 = 1; + gfc_real16_is_float128 = true; + } + + if (TYPE_PRECISION (float_type_node) == mode_precision) + return float_type_node; + if (TYPE_PRECISION (double_type_node) == mode_precision) + return double_type_node; + if (TYPE_PRECISION (long_double_type_node) == mode_precision) + return long_double_type_node; + + new_type = make_node (REAL_TYPE); + TYPE_PRECISION (new_type) = mode_precision; + layout_type (new_type); + return new_type; +} + +static tree +gfc_build_complex_type (tree scalar_type) +{ + tree new_type; + + if (scalar_type == NULL) + return NULL; + if (scalar_type == float_type_node) + return complex_float_type_node; + if (scalar_type == double_type_node) + return complex_double_type_node; + if (scalar_type == long_double_type_node) + return complex_long_double_type_node; + + new_type = make_node (COMPLEX_TYPE); + TREE_TYPE (new_type) = scalar_type; + layout_type (new_type); + return new_type; +} + +static tree +gfc_build_logical_type (gfc_logical_info *info) +{ + int bit_size = info->bit_size; + tree new_type; + + if (bit_size == BOOL_TYPE_SIZE) + { + info->c_bool = 1; + return boolean_type_node; + } + + new_type = make_unsigned_type (bit_size); + TREE_SET_CODE (new_type, BOOLEAN_TYPE); + TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1); + TYPE_PRECISION (new_type) = 1; + + return new_type; +} + + +/* Create the backend type nodes. We map them to their + equivalent C type, at least for now. We also give + names to the types here, and we push them in the + global binding level context.*/ + +void +gfc_init_types (void) +{ + char name_buf[26]; + int index; + tree type; + unsigned n; + + /* Create and name the types. */ +#define PUSH_TYPE(name, node) \ + pushdecl (build_decl (input_location, \ + TYPE_DECL, get_identifier (name), node)) + + for (index = 0; gfc_integer_kinds[index].kind != 0; ++index) + { + type = gfc_build_int_type (&gfc_integer_kinds[index]); + /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */ + if (TYPE_STRING_FLAG (type)) + type = make_signed_type (gfc_integer_kinds[index].bit_size); + gfc_integer_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)", + gfc_integer_kinds[index].kind); + PUSH_TYPE (name_buf, type); + } + + for (index = 0; gfc_logical_kinds[index].kind != 0; ++index) + { + type = gfc_build_logical_type (&gfc_logical_kinds[index]); + gfc_logical_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)", + gfc_logical_kinds[index].kind); + PUSH_TYPE (name_buf, type); + } + + for (index = 0; gfc_real_kinds[index].kind != 0; index++) + { + type = gfc_build_real_type (&gfc_real_kinds[index]); + gfc_real_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "real(kind=%d)", + gfc_real_kinds[index].kind); + PUSH_TYPE (name_buf, type); + + if (gfc_real_kinds[index].c_float128) + gfc_float128_type_node = type; + + type = gfc_build_complex_type (type); + gfc_complex_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)", + gfc_real_kinds[index].kind); + PUSH_TYPE (name_buf, type); + + if (gfc_real_kinds[index].c_float128) + gfc_complex_float128_type_node = type; + } + + for (index = 0; gfc_character_kinds[index].kind != 0; ++index) + { + type = gfc_build_uint_type (gfc_character_kinds[index].bit_size); + type = build_qualified_type (type, TYPE_UNQUALIFIED); + snprintf (name_buf, sizeof(name_buf), "character(kind=%d)", + gfc_character_kinds[index].kind); + PUSH_TYPE (name_buf, type); + gfc_character_types[index] = type; + gfc_pcharacter_types[index] = build_pointer_type (type); + } + gfc_character1_type_node = gfc_character_types[0]; + + PUSH_TYPE ("byte", unsigned_char_type_node); + PUSH_TYPE ("void", void_type_node); + + /* DBX debugging output gets upset if these aren't set. */ + if (!TYPE_NAME (integer_type_node)) + PUSH_TYPE ("c_integer", integer_type_node); + if (!TYPE_NAME (char_type_node)) + PUSH_TYPE ("c_char", char_type_node); + +#undef PUSH_TYPE + + pvoid_type_node = build_pointer_type (void_type_node); + prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT); + ppvoid_type_node = build_pointer_type (pvoid_type_node); + pchar_type_node = build_pointer_type (gfc_character1_type_node); + pfunc_type_node + = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)); + + gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind); + /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type, + since this function is called before gfc_init_constants. */ + gfc_array_range_type + = build_range_type (gfc_array_index_type, + build_int_cst (gfc_array_index_type, 0), + NULL_TREE); + + /* The maximum array element size that can be handled is determined + by the number of bits available to store this field in the array + descriptor. */ + + n = TYPE_PRECISION (size_type_node); + gfc_max_array_element_size + = wide_int_to_tree (size_type_node, + wi::mask (n, UNSIGNED, + TYPE_PRECISION (size_type_node))); + + logical_type_node = gfc_get_logical_type (gfc_default_logical_kind); + logical_true_node = build_int_cst (logical_type_node, 1); + logical_false_node = build_int_cst (logical_type_node, 0); + + /* Character lengths are of type size_t, except signed. */ + gfc_charlen_int_kind = get_int_kind_from_node (size_type_node); + gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind); + + /* Fortran kind number of size_type_node (size_t). This is used for + the _size member in vtables. */ + gfc_size_kind = get_int_kind_from_node (size_type_node); +} + +/* Get the type node for the given type and kind. */ + +tree +gfc_get_int_type (int kind) +{ + int index = gfc_validate_kind (BT_INTEGER, kind, true); + return index < 0 ? 0 : gfc_integer_types[index]; +} + +tree +gfc_get_real_type (int kind) +{ + int index = gfc_validate_kind (BT_REAL, kind, true); + return index < 0 ? 0 : gfc_real_types[index]; +} + +tree +gfc_get_complex_type (int kind) +{ + int index = gfc_validate_kind (BT_COMPLEX, kind, true); + return index < 0 ? 0 : gfc_complex_types[index]; +} + +tree +gfc_get_logical_type (int kind) +{ + int index = gfc_validate_kind (BT_LOGICAL, kind, true); + return index < 0 ? 0 : gfc_logical_types[index]; +} + +tree +gfc_get_char_type (int kind) +{ + int index = gfc_validate_kind (BT_CHARACTER, kind, true); + return index < 0 ? 0 : gfc_character_types[index]; +} + +tree +gfc_get_pchar_type (int kind) +{ + int index = gfc_validate_kind (BT_CHARACTER, kind, true); + return index < 0 ? 0 : gfc_pcharacter_types[index]; +} + + +/* Create a character type with the given kind and length. */ + +tree +gfc_get_character_type_len_for_eltype (tree eltype, tree len) +{ + tree bounds, type; + + bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len); + type = build_array_type (eltype, bounds); + TYPE_STRING_FLAG (type) = 1; + + return type; +} + +tree +gfc_get_character_type_len (int kind, tree len) +{ + gfc_validate_kind (BT_CHARACTER, kind, false); + return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len); +} + + +/* Get a type node for a character kind. */ + +tree +gfc_get_character_type (int kind, gfc_charlen * cl) +{ + tree len; + + len = (cl == NULL) ? NULL_TREE : cl->backend_decl; + if (len && POINTER_TYPE_P (TREE_TYPE (len))) + len = build_fold_indirect_ref (len); + + return gfc_get_character_type_len (kind, len); +} + +/* Convert a basic type. This will be an array for character types. */ + +tree +gfc_typenode_for_spec (gfc_typespec * spec, int codim) +{ + tree basetype; + + switch (spec->type) + { + case BT_UNKNOWN: + gcc_unreachable (); + + case BT_INTEGER: + /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol + has been resolved. This is done so we can convert C_PTR and + C_FUNPTR to simple variables that get translated to (void *). */ + if (spec->f90_type == BT_VOID) + { + if (spec->u.derived + && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) + basetype = ptr_type_node; + else + basetype = pfunc_type_node; + } + else + basetype = gfc_get_int_type (spec->kind); + break; + + case BT_REAL: + basetype = gfc_get_real_type (spec->kind); + break; + + case BT_COMPLEX: + basetype = gfc_get_complex_type (spec->kind); + break; + + case BT_LOGICAL: + basetype = gfc_get_logical_type (spec->kind); + break; + + case BT_CHARACTER: + basetype = gfc_get_character_type (spec->kind, spec->u.cl); + break; + + case BT_HOLLERITH: + /* Since this cannot be used, return a length one character. */ + basetype = gfc_get_character_type_len (gfc_default_character_kind, + gfc_index_one_node); + break; + + case BT_UNION: + basetype = gfc_get_union_type (spec->u.derived); + break; + + case BT_DERIVED: + case BT_CLASS: + basetype = gfc_get_derived_type (spec->u.derived, codim); + + if (spec->type == BT_CLASS) + GFC_CLASS_TYPE_P (basetype) = 1; + + /* If we're dealing with either C_PTR or C_FUNPTR, we modified the + type and kind to fit a (void *) and the basetype returned was a + ptr_type_node. We need to pass up this new information to the + symbol that was declared of type C_PTR or C_FUNPTR. */ + if (spec->u.derived->ts.f90_type == BT_VOID) + { + spec->type = BT_INTEGER; + spec->kind = gfc_index_integer_kind; + spec->f90_type = BT_VOID; + spec->is_c_interop = 1; /* Mark as escaping later. */ + } + break; + case BT_VOID: + case BT_ASSUMED: + /* This is for the second arg to c_f_pointer and c_f_procpointer + of the iso_c_binding module, to accept any ptr type. */ + basetype = ptr_type_node; + if (spec->f90_type == BT_VOID) + { + if (spec->u.derived + && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) + basetype = ptr_type_node; + else + basetype = pfunc_type_node; + } + break; + case BT_PROCEDURE: + basetype = pfunc_type_node; + break; + default: + gcc_unreachable (); + } + return basetype; +} + +/* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */ + +static tree +gfc_conv_array_bound (gfc_expr * expr) +{ + /* If expr is an integer constant, return that. */ + if (expr != NULL && expr->expr_type == EXPR_CONSTANT) + return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); + + /* Otherwise return NULL. */ + return NULL_TREE; +} + +/* Return the type of an element of the array. Note that scalar coarrays + are special. In particular, for GFC_ARRAY_TYPE_P, the original argument + (with POINTER_TYPE stripped) is returned. */ + +tree +gfc_get_element_type (tree type) +{ + tree element; + + if (GFC_ARRAY_TYPE_P (type)) + { + if (TREE_CODE (type) == POINTER_TYPE) + type = TREE_TYPE (type); + if (GFC_TYPE_ARRAY_RANK (type) == 0) + { + gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); + element = type; + } + else + { + gcc_assert (TREE_CODE (type) == ARRAY_TYPE); + element = TREE_TYPE (type); + } + } + else + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); + + gcc_assert (TREE_CODE (element) == POINTER_TYPE); + element = TREE_TYPE (element); + + /* For arrays, which are not scalar coarrays. */ + if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element)) + element = TREE_TYPE (element); + } + + return element; +} + +/* Build an array. This function is called from gfc_sym_type(). + Actually returns array descriptor type. + + Format of array descriptors is as follows: + + struct gfc_array_descriptor + { + array *data; + index offset; + struct dtype_type dtype; + struct descriptor_dimension dimension[N_DIM]; + } + + struct dtype_type + { + size_t elem_len; + int version; + signed char rank; + signed char type; + signed short attribute; + } + + struct descriptor_dimension + { + index stride; + index lbound; + index ubound; + } + + Translation code should use gfc_conv_descriptor_* rather than + accessing the descriptor directly. Any changes to the array + descriptor type will require changes in gfc_conv_descriptor_* and + gfc_build_array_initializer. + + This is represented internally as a RECORD_TYPE. The index nodes + are gfc_array_index_type and the data node is a pointer to the + data. See below for the handling of character types. + + I originally used nested ARRAY_TYPE nodes to represent arrays, but + this generated poor code for assumed/deferred size arrays. These + require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part + of the GENERIC grammar. Also, there is no way to explicitly set + the array stride, so all data must be packed(1). I've tried to + mark all the functions which would require modification with a GCC + ARRAYS comment. + + The data component points to the first element in the array. The + offset field is the position of the origin of the array (i.e. element + (0, 0 ...)). This may be outside the bounds of the array. + + An element is accessed by + data[offset + index0*stride0 + index1*stride1 + index2*stride2] + This gives good performance as the computation does not involve the + bounds of the array. For packed arrays, this is optimized further + by substituting the known strides. + + This system has one problem: all array bounds must be within 2^31 + elements of the origin (2^63 on 64-bit machines). For example + integer, dimension (80000:90000, 80000:90000, 2) :: array + may not work properly on 32-bit machines because 80000*80000 > + 2^31, so the calculation for stride2 would overflow. This may + still work, but I haven't checked, and it relies on the overflow + doing the right thing. + + The way to fix this problem is to access elements as follows: + data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1] + Obviously this is much slower. I will make this a compile time + option, something like -fsmall-array-offsets. Mixing code compiled + with and without this switch will work. + + (1) This can be worked around by modifying the upper bound of the + previous dimension. This requires extra fields in the descriptor + (both real_ubound and fake_ubound). */ + + +/* Returns true if the array sym does not require a descriptor. */ + +int +gfc_is_nodesc_array (gfc_symbol * sym) +{ + symbol_attribute *array_attr; + gfc_array_spec *as; + bool is_classarray = IS_CLASS_ARRAY (sym); + + array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; + as = is_classarray ? CLASS_DATA (sym)->as : sym->as; + + gcc_assert (array_attr->dimension || array_attr->codimension); + + /* We only want local arrays. */ + if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) + || array_attr->allocatable) + return 0; + + /* We want a descriptor for associate-name arrays that do not have an + explicitly known shape already. */ + if (sym->assoc && as->type != AS_EXPLICIT) + return 0; + + /* The dummy is stored in sym and not in the component. */ + if (sym->attr.dummy) + return as->type != AS_ASSUMED_SHAPE + && as->type != AS_ASSUMED_RANK; + + if (sym->attr.result || sym->attr.function) + return 0; + + gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed); + + return 1; +} + + +/* Create an array descriptor type. */ + +static tree +gfc_build_array_type (tree type, gfc_array_spec * as, + enum gfc_array_kind akind, bool restricted, + bool contiguous, int codim) +{ + tree lbound[GFC_MAX_DIMENSIONS]; + tree ubound[GFC_MAX_DIMENSIONS]; + int n, corank; + + /* Assumed-shape arrays do not have codimension information stored in the + descriptor. */ + corank = MAX (as->corank, codim); + if (as->type == AS_ASSUMED_SHAPE || + (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE)) + corank = codim; + + if (as->type == AS_ASSUMED_RANK) + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + { + lbound[n] = NULL_TREE; + ubound[n] = NULL_TREE; + } + + for (n = 0; n < as->rank; n++) + { + /* Create expressions for the known bounds of the array. */ + if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL) + lbound[n] = gfc_index_one_node; + else + lbound[n] = gfc_conv_array_bound (as->lower[n]); + ubound[n] = gfc_conv_array_bound (as->upper[n]); + } + + for (n = as->rank; n < as->rank + corank; n++) + { + if (as->type != AS_DEFERRED && as->lower[n] == NULL) + lbound[n] = gfc_index_one_node; + else + lbound[n] = gfc_conv_array_bound (as->lower[n]); + + if (n < as->rank + corank - 1) + ubound[n] = gfc_conv_array_bound (as->upper[n]); + } + + if (as->type == AS_ASSUMED_SHAPE) + akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT + : GFC_ARRAY_ASSUMED_SHAPE; + else if (as->type == AS_ASSUMED_RANK) + akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT + : GFC_ARRAY_ASSUMED_RANK; + return gfc_get_array_type_bounds (type, as->rank == -1 + ? GFC_MAX_DIMENSIONS : as->rank, + corank, lbound, ubound, 0, akind, + restricted); +} + +/* Returns the struct descriptor_dimension type. */ + +static tree +gfc_get_desc_dim_type (void) +{ + tree type; + tree decl, *chain = NULL; + + if (gfc_desc_dim_type) + return gfc_desc_dim_type; + + /* Build the type node. */ + type = make_node (RECORD_TYPE); + + TYPE_NAME (type) = get_identifier ("descriptor_dimension"); + TYPE_PACKED (type) = 1; + + /* Consists of the stride, lbound and ubound members. */ + decl = gfc_add_field_to_struct_1 (type, + get_identifier ("stride"), + gfc_array_index_type, &chain); + suppress_warning (decl); + + decl = gfc_add_field_to_struct_1 (type, + get_identifier ("lbound"), + gfc_array_index_type, &chain); + suppress_warning (decl); + + decl = gfc_add_field_to_struct_1 (type, + get_identifier ("ubound"), + gfc_array_index_type, &chain); + suppress_warning (decl); + + /* Finish off the type. */ + gfc_finish_type (type); + TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; + + gfc_desc_dim_type = type; + return type; +} + + +/* Return the DTYPE for an array. This describes the type and type parameters + of the array. */ +/* TODO: Only call this when the value is actually used, and make all the + unknown cases abort. */ + +tree +gfc_get_dtype_rank_type (int rank, tree etype) +{ + tree ptype; + tree size; + int n; + tree tmp; + tree dtype; + tree field; + vec *v = NULL; + + ptype = etype; + while (TREE_CODE (etype) == POINTER_TYPE + || TREE_CODE (etype) == ARRAY_TYPE) + { + ptype = etype; + etype = TREE_TYPE (etype); + } + + gcc_assert (etype); + + switch (TREE_CODE (etype)) + { + case INTEGER_TYPE: + if (TREE_CODE (ptype) == ARRAY_TYPE + && TYPE_STRING_FLAG (ptype)) + n = BT_CHARACTER; + else + n = BT_INTEGER; + break; + + case BOOLEAN_TYPE: + n = BT_LOGICAL; + break; + + case REAL_TYPE: + n = BT_REAL; + break; + + case COMPLEX_TYPE: + n = BT_COMPLEX; + break; + + case RECORD_TYPE: + if (GFC_CLASS_TYPE_P (etype)) + n = BT_CLASS; + else + n = BT_DERIVED; + break; + + case FUNCTION_TYPE: + case VOID_TYPE: + n = BT_VOID; + break; + + default: + /* TODO: Don't do dtype for temporary descriptorless arrays. */ + /* We can encounter strange array types for temporary arrays. */ + gcc_unreachable (); + } + + switch (n) + { + case BT_CHARACTER: + gcc_assert (TREE_CODE (ptype) == ARRAY_TYPE); + size = gfc_get_character_len_in_bytes (ptype); + break; + case BT_VOID: + gcc_assert (TREE_CODE (ptype) == POINTER_TYPE); + size = size_in_bytes (ptype); + break; + default: + size = size_in_bytes (etype); + break; + } + + gcc_assert (size); + + STRIP_NOPS (size); + size = fold_convert (size_type_node, size); + tmp = get_dtype_type_node (); + field = gfc_advance_chain (TYPE_FIELDS (tmp), + GFC_DTYPE_ELEM_LEN); + CONSTRUCTOR_APPEND_ELT (v, field, + fold_convert (TREE_TYPE (field), size)); + + field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), + GFC_DTYPE_RANK); + if (rank >= 0) + CONSTRUCTOR_APPEND_ELT (v, field, + build_int_cst (TREE_TYPE (field), rank)); + + field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), + GFC_DTYPE_TYPE); + CONSTRUCTOR_APPEND_ELT (v, field, + build_int_cst (TREE_TYPE (field), n)); + + dtype = build_constructor (tmp, v); + + return dtype; +} + + +tree +gfc_get_dtype (tree type, int * rank) +{ + tree dtype; + tree etype; + int irnk; + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); + + irnk = (rank) ? (*rank) : (GFC_TYPE_ARRAY_RANK (type)); + etype = gfc_get_element_type (type); + dtype = gfc_get_dtype_rank_type (irnk, etype); + + GFC_TYPE_ARRAY_DTYPE (type) = dtype; + return dtype; +} + + +/* Build an array type for use without a descriptor, packed according + to the value of PACKED. */ + +tree +gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, + bool restricted) +{ + tree range; + tree type; + tree tmp; + int n; + int known_stride; + int known_offset; + mpz_t offset; + mpz_t stride; + mpz_t delta; + gfc_expr *expr; + + mpz_init_set_ui (offset, 0); + mpz_init_set_ui (stride, 1); + mpz_init (delta); + + /* We don't use build_array_type because this does not include + lang-specific information (i.e. the bounds of the array) when checking + for duplicates. */ + if (as->rank) + type = make_node (ARRAY_TYPE); + else + type = build_variant_type_copy (etype); + + GFC_ARRAY_TYPE_P (type) = 1; + TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc (); + + known_stride = (packed != PACKED_NO); + known_offset = 1; + for (n = 0; n < as->rank; n++) + { + /* Fill in the stride and bound components of the type. */ + if (known_stride) + tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); + else + tmp = NULL_TREE; + GFC_TYPE_ARRAY_STRIDE (type, n) = tmp; + + expr = as->lower[n]; + if (expr && expr->expr_type == EXPR_CONSTANT) + { + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + } + else + { + known_stride = 0; + tmp = NULL_TREE; + } + GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; + + if (known_stride) + { + /* Calculate the offset. */ + mpz_mul (delta, stride, as->lower[n]->value.integer); + mpz_sub (offset, offset, delta); + } + else + known_offset = 0; + + expr = as->upper[n]; + if (expr && expr->expr_type == EXPR_CONSTANT) + { + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + } + else + { + tmp = NULL_TREE; + known_stride = 0; + } + GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; + + if (known_stride) + { + /* Calculate the stride. */ + mpz_sub (delta, as->upper[n]->value.integer, + as->lower[n]->value.integer); + mpz_add_ui (delta, delta, 1); + mpz_mul (stride, stride, delta); + } + + /* Only the first stride is known for partial packed arrays. */ + if (packed == PACKED_NO || packed == PACKED_PARTIAL) + known_stride = 0; + } + for (n = as->rank; n < as->rank + as->corank; n++) + { + expr = as->lower[n]; + if (expr && expr->expr_type == EXPR_CONSTANT) + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + else + tmp = NULL_TREE; + GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; + + expr = as->upper[n]; + if (expr && expr->expr_type == EXPR_CONSTANT) + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + else + tmp = NULL_TREE; + if (n < as->rank + as->corank - 1) + GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; + } + + if (known_offset) + { + GFC_TYPE_ARRAY_OFFSET (type) = + gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); + } + else + GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE; + + if (known_stride) + { + GFC_TYPE_ARRAY_SIZE (type) = + gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); + } + else + GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE; + + GFC_TYPE_ARRAY_RANK (type) = as->rank; + GFC_TYPE_ARRAY_CORANK (type) = as->corank; + GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE; + range = build_range_type (gfc_array_index_type, gfc_index_zero_node, + NULL_TREE); + /* TODO: use main type if it is unbounded. */ + GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = + build_pointer_type (build_array_type (etype, range)); + if (restricted) + GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = + build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), + TYPE_QUAL_RESTRICT); + + if (as->rank == 0) + { + if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB) + { + type = build_pointer_type (type); + + if (restricted) + type = build_qualified_type (type, TYPE_QUAL_RESTRICT); + + GFC_ARRAY_TYPE_P (type) = 1; + TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); + } + + return type; + } + + if (known_stride) + { + mpz_sub_ui (stride, stride, 1); + range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); + } + else + range = NULL_TREE; + + range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range); + TYPE_DOMAIN (type) = range; + + build_pointer_type (etype); + TREE_TYPE (type) = etype; + + layout_type (type); + + mpz_clear (offset); + mpz_clear (stride); + mpz_clear (delta); + + /* Represent packed arrays as multi-dimensional if they have rank > + 1 and with proper bounds, instead of flat arrays. This makes for + better debug info. */ + if (known_offset) + { + tree gtype = etype, rtype, type_decl; + + for (n = as->rank - 1; n >= 0; n--) + { + rtype = build_range_type (gfc_array_index_type, + GFC_TYPE_ARRAY_LBOUND (type, n), + GFC_TYPE_ARRAY_UBOUND (type, n)); + gtype = build_array_type (gtype, rtype); + } + TYPE_NAME (type) = type_decl = build_decl (input_location, + TYPE_DECL, NULL, gtype); + DECL_ORIGINAL_TYPE (type_decl) = gtype; + } + + if (packed != PACKED_STATIC || !known_stride + || (as->corank && flag_coarray == GFC_FCOARRAY_LIB)) + { + /* For dummy arrays and automatic (heap allocated) arrays we + want a pointer to the array. */ + type = build_pointer_type (type); + if (restricted) + type = build_qualified_type (type, TYPE_QUAL_RESTRICT); + GFC_ARRAY_TYPE_P (type) = 1; + TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); + } + return type; +} + + +/* Return or create the base type for an array descriptor. */ + +static tree +gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) +{ + tree fat_type, decl, arraytype, *chain = NULL; + char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; + int idx; + + /* Assumed-rank array. */ + if (dimen == -1) + dimen = GFC_MAX_DIMENSIONS; + + idx = 2 * (codimen + dimen) + restricted; + + gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS); + + if (flag_coarray == GFC_FCOARRAY_LIB && codimen) + { + if (gfc_array_descriptor_base_caf[idx]) + return gfc_array_descriptor_base_caf[idx]; + } + else if (gfc_array_descriptor_base[idx]) + return gfc_array_descriptor_base[idx]; + + /* Build the type node. */ + fat_type = make_node (RECORD_TYPE); + + sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen); + TYPE_NAME (fat_type) = get_identifier (name); + TYPE_NAMELESS (fat_type) = 1; + + /* Add the data member as the first element of the descriptor. */ + gfc_add_field_to_struct_1 (fat_type, + get_identifier ("data"), + (restricted + ? prvoid_type_node + : ptr_type_node), &chain); + + /* Add the base component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("offset"), + gfc_array_index_type, &chain); + suppress_warning (decl); + + /* Add the dtype component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("dtype"), + get_dtype_type_node (), &chain); + suppress_warning (decl); + + /* Add the span component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("span"), + gfc_array_index_type, &chain); + suppress_warning (decl); + + /* Build the array type for the stride and bound components. */ + if (dimen + codimen > 0) + { + arraytype = + build_array_type (gfc_get_desc_dim_type (), + build_range_type (gfc_array_index_type, + gfc_index_zero_node, + gfc_rank_cst[codimen + dimen - 1])); + + decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"), + arraytype, &chain); + suppress_warning (decl); + } + + if (flag_coarray == GFC_FCOARRAY_LIB) + { + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("token"), + prvoid_type_node, &chain); + suppress_warning (decl); + } + + /* Finish off the type. */ + gfc_finish_type (fat_type); + TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1; + + if (flag_coarray == GFC_FCOARRAY_LIB && codimen) + gfc_array_descriptor_base_caf[idx] = fat_type; + else + gfc_array_descriptor_base[idx] = fat_type; + + return fat_type; +} + + +/* Build an array (descriptor) type with given bounds. */ + +tree +gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, + tree * ubound, int packed, + enum gfc_array_kind akind, bool restricted) +{ + char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN]; + tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype; + const char *type_name; + int n; + + base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted); + fat_type = build_distinct_type_copy (base_type); + /* Unshare TYPE_FIELDs. */ + for (tree *tp = &TYPE_FIELDS (fat_type); *tp; tp = &DECL_CHAIN (*tp)) + { + tree next = DECL_CHAIN (*tp); + *tp = copy_node (*tp); + DECL_CONTEXT (*tp) = fat_type; + DECL_CHAIN (*tp) = next; + } + /* Make sure that nontarget and target array type have the same canonical + type (and same stub decl for debug info). */ + base_type = gfc_get_array_descriptor_base (dimen, codimen, false); + TYPE_CANONICAL (fat_type) = base_type; + TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type); + /* Arrays of unknown type must alias with all array descriptors. */ + TYPE_TYPELESS_STORAGE (base_type) = 1; + TYPE_TYPELESS_STORAGE (fat_type) = 1; + gcc_checking_assert (!get_alias_set (base_type) && !get_alias_set (fat_type)); + + tmp = etype; + if (TREE_CODE (tmp) == ARRAY_TYPE + && TYPE_STRING_FLAG (tmp)) + tmp = TREE_TYPE (etype); + tmp = TYPE_NAME (tmp); + if (tmp && TREE_CODE (tmp) == TYPE_DECL) + tmp = DECL_NAME (tmp); + if (tmp) + type_name = IDENTIFIER_POINTER (tmp); + else + type_name = "unknown"; + sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen, + GFC_MAX_SYMBOL_LEN, type_name); + TYPE_NAME (fat_type) = get_identifier (name); + TYPE_NAMELESS (fat_type) = 1; + + GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; + TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc (); + + GFC_TYPE_ARRAY_RANK (fat_type) = dimen; + GFC_TYPE_ARRAY_CORANK (fat_type) = codimen; + GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE; + GFC_TYPE_ARRAY_AKIND (fat_type) = akind; + + /* Build an array descriptor record type. */ + if (packed != 0) + stride = gfc_index_one_node; + else + stride = NULL_TREE; + for (n = 0; n < dimen + codimen; n++) + { + if (n < dimen) + GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; + + if (lbound) + lower = lbound[n]; + else + lower = NULL_TREE; + + if (lower != NULL_TREE) + { + if (INTEGER_CST_P (lower)) + GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower; + else + lower = NULL_TREE; + } + + if (codimen && n == dimen + codimen - 1) + break; + + upper = ubound[n]; + if (upper != NULL_TREE) + { + if (INTEGER_CST_P (upper)) + GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper; + else + upper = NULL_TREE; + } + + if (n >= dimen) + continue; + + if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, + gfc_index_one_node); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, stride); + /* Check the folding worked. */ + gcc_assert (INTEGER_CST_P (stride)); + } + else + stride = NULL_TREE; + } + GFC_TYPE_ARRAY_SIZE (fat_type) = stride; + + /* TODO: known offsets for descriptors. */ + GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE; + + if (dimen == 0) + { + arraytype = build_pointer_type (etype); + if (restricted) + arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); + + GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; + return fat_type; + } + + /* We define data as an array with the correct size if possible. + Much better than doing pointer arithmetic. */ + if (stride) + rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node, + int_const_binop (MINUS_EXPR, stride, + build_int_cst (TREE_TYPE (stride), 1))); + else + rtype = gfc_array_range_type; + arraytype = build_array_type (etype, rtype); + arraytype = build_pointer_type (arraytype); + if (restricted) + arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); + GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; + + /* This will generate the base declarations we need to emit debug + information for this type. FIXME: there must be a better way to + avoid divergence between compilations with and without debug + information. */ + { + struct array_descr_info info; + gfc_get_array_descr_info (fat_type, &info); + gfc_get_array_descr_info (build_pointer_type (fat_type), &info); + } + + return fat_type; +} + +/* Build a pointer type. This function is called from gfc_sym_type(). */ + +static tree +gfc_build_pointer_type (gfc_symbol * sym, tree type) +{ + /* Array pointer types aren't actually pointers. */ + if (sym->attr.dimension) + return type; + else + return build_pointer_type (type); +} + +static tree gfc_nonrestricted_type (tree t); +/* Given two record or union type nodes TO and FROM, ensure + that all fields in FROM have a corresponding field in TO, + their type being nonrestrict variants. This accepts a TO + node that already has a prefix of the fields in FROM. */ +static void +mirror_fields (tree to, tree from) +{ + tree fto, ffrom; + tree *chain; + + /* Forward to the end of TOs fields. */ + fto = TYPE_FIELDS (to); + ffrom = TYPE_FIELDS (from); + chain = &TYPE_FIELDS (to); + while (fto) + { + gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom)); + chain = &DECL_CHAIN (fto); + fto = DECL_CHAIN (fto); + ffrom = DECL_CHAIN (ffrom); + } + + /* Now add all fields remaining in FROM (starting with ffrom). */ + for (; ffrom; ffrom = DECL_CHAIN (ffrom)) + { + tree newfield = copy_node (ffrom); + DECL_CONTEXT (newfield) = to; + /* The store to DECL_CHAIN might seem redundant with the + stores to *chain, but not clearing it here would mean + leaving a chain into the old fields. If ever + our called functions would look at them confusion + will arise. */ + DECL_CHAIN (newfield) = NULL_TREE; + *chain = newfield; + chain = &DECL_CHAIN (newfield); + + if (TREE_CODE (ffrom) == FIELD_DECL) + { + tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom)); + TREE_TYPE (newfield) = elemtype; + } + } + *chain = NULL_TREE; +} + +/* Given a type T, returns a different type of the same structure, + except that all types it refers to (recursively) are always + non-restrict qualified types. */ +static tree +gfc_nonrestricted_type (tree t) +{ + tree ret = t; + + /* If the type isn't laid out yet, don't copy it. If something + needs it for real it should wait until the type got finished. */ + if (!TYPE_SIZE (t)) + return t; + + if (!TYPE_LANG_SPECIFIC (t)) + TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc (); + /* If we're dealing with this very node already further up + the call chain (recursion via pointers and struct members) + we haven't yet determined if we really need a new type node. + Assume we don't, return T itself. */ + if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node) + return t; + + /* If we have calculated this all already, just return it. */ + if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type) + return TYPE_LANG_SPECIFIC (t)->nonrestricted_type; + + /* Mark this type. */ + TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node; + + switch (TREE_CODE (t)) + { + default: + break; + + case POINTER_TYPE: + case REFERENCE_TYPE: + { + tree totype = gfc_nonrestricted_type (TREE_TYPE (t)); + if (totype == TREE_TYPE (t)) + ret = t; + else if (TREE_CODE (t) == POINTER_TYPE) + ret = build_pointer_type (totype); + else + ret = build_reference_type (totype); + ret = build_qualified_type (ret, + TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT); + } + break; + + case ARRAY_TYPE: + { + tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t)); + if (elemtype == TREE_TYPE (t)) + ret = t; + else + { + ret = build_variant_type_copy (t); + TREE_TYPE (ret) = elemtype; + if (TYPE_LANG_SPECIFIC (t) + && GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) + { + tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t); + dataptr_type = gfc_nonrestricted_type (dataptr_type); + if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) + { + TYPE_LANG_SPECIFIC (ret) + = ggc_cleared_alloc (); + *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t); + GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type; + } + } + } + } + break; + + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + { + tree field; + /* First determine if we need a new type at all. + Careful, the two calls to gfc_nonrestricted_type per field + might return different values. That happens exactly when + one of the fields reaches back to this very record type + (via pointers). The first calls will assume that we don't + need to copy T (see the error_mark_node marking). If there + are any reasons for copying T apart from having to copy T, + we'll indeed copy it, and the second calls to + gfc_nonrestricted_type will use that new node if they + reach back to T. */ + for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field)) + if (TREE_CODE (field) == FIELD_DECL) + { + tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field)); + if (elemtype != TREE_TYPE (field)) + break; + } + if (!field) + break; + ret = build_variant_type_copy (t); + TYPE_FIELDS (ret) = NULL_TREE; + + /* Here we make sure that as soon as we know we have to copy + T, that also fields reaching back to us will use the new + copy. It's okay if that copy still contains the old fields, + we won't look at them. */ + TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; + mirror_fields (ret, t); + } + break; + } + + TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; + return ret; +} + + +/* Return the type for a symbol. Special handling is required for character + types to get the correct level of indirection. + For functions return the return type. + For subroutines return void_type_node. + Calling this multiple times for the same symbol should be avoided, + especially for character and array types. */ + +tree +gfc_sym_type (gfc_symbol * sym, bool is_bind_c) +{ + tree type; + int byref; + bool restricted; + + /* Procedure Pointers inside COMMON blocks. */ + if (sym->attr.proc_pointer && sym->attr.in_common) + { + /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ + sym->attr.proc_pointer = 0; + type = build_pointer_type (gfc_get_function_type (sym)); + sym->attr.proc_pointer = 1; + return type; + } + + if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) + return void_type_node; + + /* In the case of a function the fake result variable may have a + type different from the function type, so don't return early in + that case. */ + if (sym->backend_decl && !sym->attr.function) + return TREE_TYPE (sym->backend_decl); + + if (sym->attr.result + && sym->ts.type == BT_CHARACTER + && sym->ts.u.cl->backend_decl == NULL_TREE + && sym->ns->proc_name + && sym->ns->proc_name->ts.u.cl + && sym->ns->proc_name->ts.u.cl->backend_decl != NULL_TREE) + sym->ts.u.cl->backend_decl = sym->ns->proc_name->ts.u.cl->backend_decl; + + if (sym->ts.type == BT_CHARACTER + && ((sym->attr.function && sym->attr.is_bind_c) + || ((sym->attr.result || sym->attr.value) + && sym->ns->proc_name + && sym->ns->proc_name->attr.is_bind_c) + || (sym->ts.deferred && (!sym->ts.u.cl + || !sym->ts.u.cl->backend_decl)))) + type = gfc_character1_type_node; + else + type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension); + + if (sym->attr.dummy && !sym->attr.function && !sym->attr.value + && !sym->pass_as_value) + byref = 1; + else + byref = 0; + + restricted = !sym->attr.target && !sym->attr.pointer + && !sym->attr.proc_pointer && !sym->attr.cray_pointee; + if (!restricted) + type = gfc_nonrestricted_type (type); + + /* Dummy argument to a bind(C) procedure. */ + if (is_bind_c && is_CFI_desc (sym, NULL)) + type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0, + /* restricted = */ false); + else if (sym->attr.dimension || sym->attr.codimension) + { + if (gfc_is_nodesc_array (sym)) + { + /* If this is a character argument of unknown length, just use the + base type. */ + if (sym->ts.type != BT_CHARACTER + || !(sym->attr.dummy || sym->attr.function) + || sym->ts.u.cl->backend_decl) + { + type = gfc_get_nodesc_array_type (type, sym->as, + byref ? PACKED_FULL + : PACKED_STATIC, + restricted); + byref = 0; + } + } + else + { + enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN; + if (sym->attr.pointer) + akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; + else if (sym->attr.allocatable) + akind = GFC_ARRAY_ALLOCATABLE; + type = gfc_build_array_type (type, sym->as, akind, restricted, + sym->attr.contiguous, false); + } + } + else + { + if (sym->attr.allocatable || sym->attr.pointer + || gfc_is_associate_pointer (sym)) + type = gfc_build_pointer_type (sym, type); + } + + /* We currently pass all parameters by reference. + See f95_get_function_decl. For dummy function parameters return the + function type. */ + if (byref) + { + /* We must use pointer types for potentially absent variables. The + optimizers assume a reference type argument is never NULL. */ + if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) + || sym->attr.optional + || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master)) + type = build_pointer_type (type); + else + { + type = build_reference_type (type); + if (restricted) + type = build_qualified_type (type, TYPE_QUAL_RESTRICT); + } + } + + return (type); +} + +/* Layout and output debug info for a record type. */ + +void +gfc_finish_type (tree type) +{ + tree decl; + + decl = build_decl (input_location, + TYPE_DECL, NULL_TREE, type); + TYPE_STUB_DECL (type) = decl; + layout_type (type); + rest_of_type_compilation (type, 1); + rest_of_decl_compilation (decl, 1, 0); +} + +/* Add a field of given NAME and TYPE to the context of a UNION_TYPE + or RECORD_TYPE pointed to by CONTEXT. The new field is chained + to the end of the field list pointed to by *CHAIN. + + Returns a pointer to the new field. */ + +static tree +gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain) +{ + tree decl = build_decl (input_location, FIELD_DECL, name, type); + + DECL_CONTEXT (decl) = context; + DECL_CHAIN (decl) = NULL_TREE; + if (TYPE_FIELDS (context) == NULL_TREE) + TYPE_FIELDS (context) = decl; + if (chain != NULL) + { + if (*chain != NULL) + **chain = decl; + *chain = &DECL_CHAIN (decl); + } + + return decl; +} + +/* Like `gfc_add_field_to_struct_1', but adds alignment + information. */ + +tree +gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain) +{ + tree decl = gfc_add_field_to_struct_1 (context, name, type, chain); + + DECL_INITIAL (decl) = 0; + SET_DECL_ALIGN (decl, 0); + DECL_USER_ALIGN (decl) = 0; + + return decl; +} + + +/* Copy the backend_decl and component backend_decls if + the two derived type symbols are "equal", as described + in 4.4.2 and resolved by gfc_compare_derived_types. */ + +int +gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, + bool from_gsym) +{ + gfc_component *to_cm; + gfc_component *from_cm; + + if (from == to) + return 1; + + if (from->backend_decl == NULL + || !gfc_compare_derived_types (from, to)) + return 0; + + to->backend_decl = from->backend_decl; + + to_cm = to->components; + from_cm = from->components; + + /* Copy the component declarations. If a component is itself + a derived type, we need a copy of its component declarations. + This is done by recursing into gfc_get_derived_type and + ensures that the component's component declarations have + been built. If it is a character, we need the character + length, as well. */ + for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) + { + to_cm->backend_decl = from_cm->backend_decl; + to_cm->caf_token = from_cm->caf_token; + if (from_cm->ts.type == BT_UNION) + gfc_get_union_type (to_cm->ts.u.derived); + else if (from_cm->ts.type == BT_DERIVED + && (!from_cm->attr.pointer || from_gsym)) + gfc_get_derived_type (to_cm->ts.u.derived); + else if (from_cm->ts.type == BT_CLASS + && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym)) + gfc_get_derived_type (to_cm->ts.u.derived); + else if (from_cm->ts.type == BT_CHARACTER) + to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl; + } + + return 1; +} + + +/* Build a tree node for a procedure pointer component. */ + +static tree +gfc_get_ppc_type (gfc_component* c) +{ + tree t; + + /* Explicit interface. */ + if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface) + return build_pointer_type (gfc_get_function_type (c->ts.interface)); + + /* Implicit interface (only return value may be known). */ + if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER) + t = gfc_typenode_for_spec (&c->ts); + else + t = void_type_node; + + /* FIXME: it would be better to provide explicit interfaces in all + cases, since they should be known by the compiler. */ + return build_pointer_type (build_function_type (t, NULL_TREE)); +} + + +/* Build a tree node for a union type. Requires building each map + structure which is an element of the union. */ + +tree +gfc_get_union_type (gfc_symbol *un) +{ + gfc_component *map = NULL; + tree typenode = NULL, map_type = NULL, map_field = NULL; + tree *chain = NULL; + + if (un->backend_decl) + { + if (TYPE_FIELDS (un->backend_decl) || un->attr.proc_pointer_comp) + return un->backend_decl; + else + typenode = un->backend_decl; + } + else + { + typenode = make_node (UNION_TYPE); + TYPE_NAME (typenode) = get_identifier (un->name); + } + + /* Add each contained MAP as a field. */ + for (map = un->components; map; map = map->next) + { + gcc_assert (map->ts.type == BT_DERIVED); + + /* The map's type node, which is defined within this union's context. */ + map_type = gfc_get_derived_type (map->ts.u.derived); + TYPE_CONTEXT (map_type) = typenode; + + /* The map field's declaration. */ + map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name), + map_type, &chain); + if (map->loc.lb) + gfc_set_decl_location (map_field, &map->loc); + else if (un->declared_at.lb) + gfc_set_decl_location (map_field, &un->declared_at); + + DECL_PACKED (map_field) |= TYPE_PACKED (typenode); + DECL_NAMELESS(map_field) = true; + + /* We should never clobber another backend declaration for this map, + because each map component is unique. */ + if (!map->backend_decl) + map->backend_decl = map_field; + } + + un->backend_decl = typenode; + gfc_finish_type (typenode); + + return typenode; +} + + +/* Build a tree node for a derived type. If there are equal + derived types, with different local names, these are built + at the same time. If an equal derived type has been built + in a parent namespace, this is used. */ + +tree +gfc_get_derived_type (gfc_symbol * derived, int codimen) +{ + tree typenode = NULL, field = NULL, field_type = NULL; + tree canonical = NULL_TREE; + tree *chain = NULL; + bool got_canonical = false; + bool unlimited_entity = false; + gfc_component *c; + gfc_namespace *ns; + tree tmp; + bool coarray_flag; + + coarray_flag = flag_coarray == GFC_FCOARRAY_LIB + && derived->module && !derived->attr.vtype; + + gcc_assert (!derived->attr.pdt_template); + + if (derived->attr.unlimited_polymorphic + || (flag_coarray == GFC_FCOARRAY_LIB + && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE + || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE + || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE))) + return ptr_type_node; + + if (flag_coarray != GFC_FCOARRAY_LIB + && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && (derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE + || derived->intmod_sym_id == ISOFORTRAN_TEAM_TYPE)) + return gfc_get_int_type (gfc_default_integer_kind); + + if (derived && derived->attr.flavor == FL_PROCEDURE + && derived->attr.generic) + derived = gfc_find_dt_in_generic (derived); + + /* See if it's one of the iso_c_binding derived types. */ + if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID) + { + if (derived->backend_decl) + return derived->backend_decl; + + if (derived->intmod_sym_id == ISOCBINDING_PTR) + derived->backend_decl = ptr_type_node; + else + derived->backend_decl = pfunc_type_node; + + derived->ts.kind = gfc_index_integer_kind; + derived->ts.type = BT_INTEGER; + /* Set the f90_type to BT_VOID as a way to recognize something of type + BT_INTEGER that needs to fit a void * for the purpose of the + iso_c_binding derived types. */ + derived->ts.f90_type = BT_VOID; + + return derived->backend_decl; + } + + /* If use associated, use the module type for this one. */ + if (derived->backend_decl == NULL + && (derived->attr.use_assoc || derived->attr.used_in_submodule) + && derived->module + && gfc_get_module_backend_decl (derived)) + goto copy_derived_types; + + /* The derived types from an earlier namespace can be used as the + canonical type. */ + if (derived->backend_decl == NULL + && !derived->attr.use_assoc + && !derived->attr.used_in_submodule + && gfc_global_ns_list) + { + for (ns = gfc_global_ns_list; + ns->translated && !got_canonical; + ns = ns->sibling) + { + if (ns->derived_types) + { + for (gfc_symbol *dt = ns->derived_types; dt && !got_canonical; + dt = dt->dt_next) + { + gfc_copy_dt_decls_ifequal (dt, derived, true); + if (derived->backend_decl) + got_canonical = true; + if (dt->dt_next == ns->derived_types) + break; + } + } + } + } + + /* Store up the canonical type to be added to this one. */ + if (got_canonical) + { + if (TYPE_CANONICAL (derived->backend_decl)) + canonical = TYPE_CANONICAL (derived->backend_decl); + else + canonical = derived->backend_decl; + + derived->backend_decl = NULL_TREE; + } + + /* derived->backend_decl != 0 means we saw it before, but its + components' backend_decl may have not been built. */ + if (derived->backend_decl) + { + /* Its components' backend_decl have been built or we are + seeing recursion through the formal arglist of a procedure + pointer component. */ + if (TYPE_FIELDS (derived->backend_decl)) + return derived->backend_decl; + else if (derived->attr.abstract + && derived->attr.proc_pointer_comp) + { + /* If an abstract derived type with procedure pointer + components has no other type of component, return the + backend_decl. Otherwise build the components if any of the + non-procedure pointer components have no backend_decl. */ + for (c = derived->components; c; c = c->next) + { + bool same_alloc_type = c->attr.allocatable + && derived == c->ts.u.derived; + if (!c->attr.proc_pointer + && !same_alloc_type + && c->backend_decl == NULL) + break; + else if (c->next == NULL) + return derived->backend_decl; + } + typenode = derived->backend_decl; + } + else + typenode = derived->backend_decl; + } + else + { + /* We see this derived type first time, so build the type node. */ + typenode = make_node (RECORD_TYPE); + TYPE_NAME (typenode) = get_identifier (derived->name); + TYPE_PACKED (typenode) = flag_pack_derived; + derived->backend_decl = typenode; + } + + if (derived->components + && derived->components->ts.type == BT_DERIVED + && strcmp (derived->components->name, "_data") == 0 + && derived->components->ts.u.derived->attr.unlimited_polymorphic) + unlimited_entity = true; + + /* Go through the derived type components, building them as + necessary. The reason for doing this now is that it is + possible to recurse back to this derived type through a + pointer component (PR24092). If this happens, the fields + will be built and so we can return the type. */ + for (c = derived->components; c; c = c->next) + { + bool same_alloc_type = c->attr.allocatable + && derived == c->ts.u.derived; + + if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL) + c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived); + + if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) + continue; + + if ((!c->attr.pointer && !c->attr.proc_pointer + && !same_alloc_type) + || c->ts.u.derived->backend_decl == NULL) + { + int local_codim = c->attr.codimension ? c->as->corank: codimen; + c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived, + local_codim); + } + + if (c->ts.u.derived->attr.is_iso_c) + { + /* Need to copy the modified ts from the derived type. The + typespec was modified because C_PTR/C_FUNPTR are translated + into (void *) from derived types. */ + c->ts.type = c->ts.u.derived->ts.type; + c->ts.kind = c->ts.u.derived->ts.kind; + c->ts.f90_type = c->ts.u.derived->ts.f90_type; + if (c->initializer) + { + c->initializer->ts.type = c->ts.type; + c->initializer->ts.kind = c->ts.kind; + c->initializer->ts.f90_type = c->ts.f90_type; + c->initializer->expr_type = EXPR_NULL; + } + } + } + + if (TYPE_FIELDS (derived->backend_decl)) + return derived->backend_decl; + + /* Build the type member list. Install the newly created RECORD_TYPE + node as DECL_CONTEXT of each FIELD_DECL. In this case we must go + through only the top-level linked list of components so we correctly + build UNION_TYPE nodes for BT_UNION components. MAPs and other nested + types are built as part of gfc_get_union_type. */ + for (c = derived->components; c; c = c->next) + { + bool same_alloc_type = c->attr.allocatable + && derived == c->ts.u.derived; + /* Prevent infinite recursion, when the procedure pointer type is + the same as derived, by forcing the procedure pointer component to + be built as if the explicit interface does not exist. */ + if (c->attr.proc_pointer + && (c->ts.type != BT_DERIVED || (c->ts.u.derived + && !gfc_compare_derived_types (derived, c->ts.u.derived))) + && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived + && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived)))) + field_type = gfc_get_ppc_type (c); + else if (c->attr.proc_pointer && derived->backend_decl) + { + tmp = build_function_type (derived->backend_decl, NULL_TREE); + field_type = build_pointer_type (tmp); + } + else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + field_type = c->ts.u.derived->backend_decl; + else if (c->attr.caf_token) + field_type = pvoid_type_node; + else + { + if (c->ts.type == BT_CHARACTER + && !c->ts.deferred && !c->attr.pdt_string) + { + /* Evaluate the string length. */ + gfc_conv_const_charlen (c->ts.u.cl); + gcc_assert (c->ts.u.cl->backend_decl); + } + else if (c->ts.type == BT_CHARACTER) + c->ts.u.cl->backend_decl + = build_int_cst (gfc_charlen_type_node, 0); + + field_type = gfc_typenode_for_spec (&c->ts, codimen); + } + + /* This returns an array descriptor type. Initialization may be + required. */ + if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer ) + { + if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array) + { + enum gfc_array_kind akind; + if (c->attr.pointer) + akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; + else + akind = GFC_ARRAY_ALLOCATABLE; + /* Pointers to arrays aren't actually pointer types. The + descriptors are separate, but the data is common. */ + field_type = gfc_build_array_type (field_type, c->as, akind, + !c->attr.target + && !c->attr.pointer, + c->attr.contiguous, + codimen); + } + else + field_type = gfc_get_nodesc_array_type (field_type, c->as, + PACKED_STATIC, + !c->attr.target); + } + else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string) + && !c->attr.proc_pointer + && !(unlimited_entity && c == derived->components)) + field_type = build_pointer_type (field_type); + + if (c->attr.pointer || same_alloc_type) + field_type = gfc_nonrestricted_type (field_type); + + /* vtype fields can point to different types to the base type. */ + if (c->ts.type == BT_DERIVED + && c->ts.u.derived && c->ts.u.derived->attr.vtype) + field_type = build_pointer_type_for_mode (TREE_TYPE (field_type), + ptr_mode, true); + + /* Ensure that the CLASS language specific flag is set. */ + if (c->ts.type == BT_CLASS) + { + if (POINTER_TYPE_P (field_type)) + GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1; + else + GFC_CLASS_TYPE_P (field_type) = 1; + } + + field = gfc_add_field_to_struct (typenode, + get_identifier (c->name), + field_type, &chain); + if (c->loc.lb) + gfc_set_decl_location (field, &c->loc); + else if (derived->declared_at.lb) + gfc_set_decl_location (field, &derived->declared_at); + + gfc_finish_decl_attrs (field, &c->attr); + + DECL_PACKED (field) |= TYPE_PACKED (typenode); + + gcc_assert (field); + if (!c->backend_decl) + c->backend_decl = field; + + if (c->attr.pointer && c->attr.dimension + && !(c->ts.type == BT_DERIVED + && strcmp (c->name, "_data") == 0)) + GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1; + } + + /* Now lay out the derived type, including the fields. */ + if (canonical) + TYPE_CANONICAL (typenode) = canonical; + + gfc_finish_type (typenode); + gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at); + if (derived->module && derived->ns->proc_name + && derived->ns->proc_name->attr.flavor == FL_MODULE) + { + if (derived->ns->proc_name->backend_decl + && TREE_CODE (derived->ns->proc_name->backend_decl) + == NAMESPACE_DECL) + { + TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl; + DECL_CONTEXT (TYPE_STUB_DECL (typenode)) + = derived->ns->proc_name->backend_decl; + } + } + + derived->backend_decl = typenode; + +copy_derived_types: + + for (c = derived->components; c; c = c->next) + { + /* Do not add a caf_token field for class container components. */ + if ((codimen || coarray_flag) + && !c->attr.dimension && !c->attr.codimension + && (c->attr.allocatable || c->attr.pointer) + && !derived->attr.is_class) + { + /* Provide sufficient space to hold "_caf_symbol". */ + char caf_name[GFC_MAX_SYMBOL_LEN + 6]; + gfc_component *token; + snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name); + token = gfc_find_component (derived, caf_name, true, true, NULL); + gcc_assert (token); + c->caf_token = token->backend_decl; + suppress_warning (c->caf_token); + } + } + + for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next) + { + gfc_copy_dt_decls_ifequal (derived, dt, false); + if (dt->dt_next == gfc_derived_types) + break; + } + + return derived->backend_decl; +} + + +int +gfc_return_by_reference (gfc_symbol * sym) +{ + if (!sym->attr.function) + return 0; + + if (sym->attr.dimension) + return 1; + + if (sym->ts.type == BT_CHARACTER + && !sym->attr.is_bind_c + && (!sym->attr.result + || !sym->ns->proc_name + || !sym->ns->proc_name->attr.is_bind_c)) + return 1; + + /* Possibly return complex numbers by reference for g77 compatibility. + We don't do this for calls to intrinsics (as the library uses the + -fno-f2c calling convention), nor for calls to functions which always + require an explicit interface, as no compatibility problems can + arise there. */ + if (flag_f2c && sym->ts.type == BT_COMPLEX + && !sym->attr.intrinsic && !sym->attr.always_explicit) + return 1; + + return 0; +} + +static tree +gfc_get_mixed_entry_union (gfc_namespace *ns) +{ + tree type; + tree *chain = NULL; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_entry_list *el, *el2; + + gcc_assert (ns->proc_name->attr.mixed_entry_master); + gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0); + + snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7); + + /* Build the type node. */ + type = make_node (UNION_TYPE); + + TYPE_NAME (type) = get_identifier (name); + + for (el = ns->entries; el; el = el->next) + { + /* Search for duplicates. */ + for (el2 = ns->entries; el2 != el; el2 = el2->next) + if (el2->sym->result == el->sym->result) + break; + + if (el == el2) + gfc_add_field_to_struct_1 (type, + get_identifier (el->sym->result->name), + gfc_sym_type (el->sym->result), &chain); + } + + /* Finish off the type. */ + gfc_finish_type (type); + TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; + return type; +} + +/* Create a "fn spec" based on the formal arguments; + cf. create_function_arglist. */ + +static tree +create_fn_spec (gfc_symbol *sym, tree fntype) +{ + char spec[150]; + size_t spec_len; + gfc_formal_arglist *f; + tree tmp; + + memset (&spec, 0, sizeof (spec)); + spec[0] = '.'; + spec[1] = ' '; + spec_len = 2; + + if (sym->attr.entry_master) + { + spec[spec_len++] = 'R'; + spec[spec_len++] = ' '; + } + if (gfc_return_by_reference (sym)) + { + gfc_symbol *result = sym->result ? sym->result : sym; + + if (result->attr.pointer || sym->attr.proc_pointer) + { + spec[spec_len++] = '.'; + spec[spec_len++] = ' '; + } + else + { + spec[spec_len++] = 'w'; + spec[spec_len++] = ' '; + } + if (sym->ts.type == BT_CHARACTER) + { + if (!sym->ts.u.cl->length + && (sym->attr.allocatable || sym->attr.pointer)) + spec[spec_len++] = 'w'; + else + spec[spec_len++] = 'R'; + spec[spec_len++] = ' '; + } + } + + for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) + if (spec_len < sizeof (spec)) + { + if (!f->sym || f->sym->attr.pointer || f->sym->attr.target + || f->sym->attr.external || f->sym->attr.cray_pointer + || (f->sym->ts.type == BT_DERIVED + && (f->sym->ts.u.derived->attr.proc_pointer_comp + || f->sym->ts.u.derived->attr.pointer_comp)) + || (f->sym->ts.type == BT_CLASS + && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp + || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp)) + || (f->sym->ts.type == BT_INTEGER && f->sym->ts.is_c_interop)) + { + spec[spec_len++] = '.'; + spec[spec_len++] = ' '; + } + else if (f->sym->attr.intent == INTENT_IN) + { + spec[spec_len++] = 'r'; + spec[spec_len++] = ' '; + } + else if (f->sym) + { + spec[spec_len++] = 'w'; + spec[spec_len++] = ' '; + } + } + + tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec)); + tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype)); + return build_type_attribute_variant (fntype, tmp); +} + + +/* NOTE: The returned function type must match the argument list created by + create_function_arglist. */ + +tree +gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) +{ + tree type; + vec *typelist = NULL; + gfc_formal_arglist *f; + gfc_symbol *arg; + int alternate_return = 0; + bool is_varargs = true; + + /* Make sure this symbol is a function, a subroutine or the main + program. */ + gcc_assert (sym->attr.flavor == FL_PROCEDURE + || sym->attr.flavor == FL_PROGRAM); + + /* To avoid recursing infinitely on recursive types, we use error_mark_node + so that they can be detected here and handled further down. */ + if (sym->backend_decl == NULL) + sym->backend_decl = error_mark_node; + else if (sym->backend_decl == error_mark_node) + goto arg_type_list_done; + else if (sym->attr.proc_pointer) + return TREE_TYPE (TREE_TYPE (sym->backend_decl)); + else + return TREE_TYPE (sym->backend_decl); + + if (sym->attr.entry_master) + /* Additional parameter for selecting an entry point. */ + vec_safe_push (typelist, gfc_array_index_type); + + if (sym->result) + arg = sym->result; + else + arg = sym; + + if (arg->ts.type == BT_CHARACTER) + gfc_conv_const_charlen (arg->ts.u.cl); + + /* Some functions we use an extra parameter for the return value. */ + if (gfc_return_by_reference (sym)) + { + type = gfc_sym_type (arg); + if (arg->ts.type == BT_COMPLEX + || arg->attr.dimension + || arg->ts.type == BT_CHARACTER) + type = build_reference_type (type); + + vec_safe_push (typelist, type); + if (arg->ts.type == BT_CHARACTER) + { + if (!arg->ts.deferred) + /* Transfer by value. */ + vec_safe_push (typelist, gfc_charlen_type_node); + else + /* Deferred character lengths are transferred by reference + so that the value can be returned. */ + vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node)); + } + } + if (sym->backend_decl == error_mark_node && actual_args != NULL + && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL + || sym->attr.proc == PROC_UNKNOWN)) + gfc_get_formal_from_actual_arglist (sym, actual_args); + + /* Build the argument types for the function. */ + for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) + { + arg = f->sym; + if (arg) + { + /* Evaluate constant character lengths here so that they can be + included in the type. */ + if (arg->ts.type == BT_CHARACTER) + gfc_conv_const_charlen (arg->ts.u.cl); + + if (arg->attr.flavor == FL_PROCEDURE) + { + type = gfc_get_function_type (arg); + type = build_pointer_type (type); + } + else + type = gfc_sym_type (arg, sym->attr.is_bind_c); + + /* Parameter Passing Convention + + We currently pass all parameters by reference. + Parameters with INTENT(IN) could be passed by value. + The problem arises if a function is called via an implicit + prototype. In this situation the INTENT is not known. + For this reason all parameters to global functions must be + passed by reference. Passing by value would potentially + generate bad code. Worse there would be no way of telling that + this code was bad, except that it would give incorrect results. + + Contained procedures could pass by value as these are never + used without an explicit interface, and cannot be passed as + actual parameters for a dummy procedure. */ + + vec_safe_push (typelist, type); + } + else + { + if (sym->attr.subroutine) + alternate_return = 1; + } + } + + /* Add hidden arguments. */ + for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) + { + arg = f->sym; + /* Add hidden string length parameters. */ + if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c) + { + if (!arg->ts.deferred) + /* Transfer by value. */ + type = gfc_charlen_type_node; + else + /* Deferred character lengths are transferred by reference + so that the value can be returned. */ + type = build_pointer_type (gfc_charlen_type_node); + + vec_safe_push (typelist, type); + } + /* For noncharacter scalar intrinsic types, VALUE passes the value, + hence, the optional status cannot be transferred via a NULL pointer. + Thus, we will use a hidden argument in that case. */ + else if (arg + && arg->attr.optional + && arg->attr.value + && !arg->attr.dimension + && arg->ts.type != BT_CLASS + && !gfc_bt_struct (arg->ts.type)) + vec_safe_push (typelist, boolean_type_node); + /* Coarrays which are descriptorless or assumed-shape pass with + -fcoarray=lib the token and the offset as hidden arguments. */ + if (arg + && flag_coarray == GFC_FCOARRAY_LIB + && ((arg->ts.type != BT_CLASS + && arg->attr.codimension + && !arg->attr.allocatable) + || (arg->ts.type == BT_CLASS + && CLASS_DATA (arg)->attr.codimension + && !CLASS_DATA (arg)->attr.allocatable))) + { + vec_safe_push (typelist, pvoid_type_node); /* caf_token. */ + vec_safe_push (typelist, gfc_array_index_type); /* caf_offset. */ + } + } + + if (!vec_safe_is_empty (typelist) + || sym->attr.is_main_program + || sym->attr.if_source != IFSRC_UNKNOWN) + is_varargs = false; + + if (sym->backend_decl == error_mark_node) + sym->backend_decl = NULL_TREE; + +arg_type_list_done: + + if (alternate_return) + type = integer_type_node; + else if (!sym->attr.function || gfc_return_by_reference (sym)) + type = void_type_node; + else if (sym->attr.mixed_entry_master) + type = gfc_get_mixed_entry_union (sym->ns); + else if (flag_f2c && sym->ts.type == BT_REAL + && sym->ts.kind == gfc_default_real_kind + && !sym->attr.always_explicit) + { + /* Special case: f2c calling conventions require that (scalar) + default REAL functions return the C type double instead. f2c + compatibility is only an issue with functions that don't + require an explicit interface, as only these could be + implemented in Fortran 77. */ + sym->ts.kind = gfc_default_double_kind; + type = gfc_typenode_for_spec (&sym->ts); + sym->ts.kind = gfc_default_real_kind; + } + else if (sym->result && sym->result->attr.proc_pointer) + /* Procedure pointer return values. */ + { + if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0) + { + /* Unset proc_pointer as gfc_get_function_type + is called recursively. */ + sym->result->attr.proc_pointer = 0; + type = build_pointer_type (gfc_get_function_type (sym->result)); + sym->result->attr.proc_pointer = 1; + } + else + type = gfc_sym_type (sym->result); + } + else + type = gfc_sym_type (sym); + + if (is_varargs) + type = build_varargs_function_type_vec (type, typelist); + else + type = build_function_type_vec (type, typelist); + + /* If we were passed an fn spec, add it here, otherwise determine it from + the formal arguments. */ + if (fnspec) + { + tree tmp; + int spec_len = strlen (fnspec); + tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec)); + tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type)); + type = build_type_attribute_variant (type, tmp); + } + else + type = create_fn_spec (sym, type); + + return type; +} + +/* Language hooks for middle-end access to type nodes. */ + +/* Return an integer type with BITS bits of precision, + that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ + +tree +gfc_type_for_size (unsigned bits, int unsignedp) +{ + if (!unsignedp) + { + int i; + for (i = 0; i <= MAX_INT_KINDS; ++i) + { + tree type = gfc_integer_types[i]; + if (type && bits == TYPE_PRECISION (type)) + return type; + } + + /* Handle TImode as a special case because it is used by some backends + (e.g. ARM) even though it is not available for normal use. */ +#if HOST_BITS_PER_WIDE_INT >= 64 + if (bits == TYPE_PRECISION (intTI_type_node)) + return intTI_type_node; +#endif + + if (bits <= TYPE_PRECISION (intQI_type_node)) + return intQI_type_node; + if (bits <= TYPE_PRECISION (intHI_type_node)) + return intHI_type_node; + if (bits <= TYPE_PRECISION (intSI_type_node)) + return intSI_type_node; + if (bits <= TYPE_PRECISION (intDI_type_node)) + return intDI_type_node; + if (bits <= TYPE_PRECISION (intTI_type_node)) + return intTI_type_node; + } + else + { + if (bits <= TYPE_PRECISION (unsigned_intQI_type_node)) + return unsigned_intQI_type_node; + if (bits <= TYPE_PRECISION (unsigned_intHI_type_node)) + return unsigned_intHI_type_node; + if (bits <= TYPE_PRECISION (unsigned_intSI_type_node)) + return unsigned_intSI_type_node; + if (bits <= TYPE_PRECISION (unsigned_intDI_type_node)) + return unsigned_intDI_type_node; + if (bits <= TYPE_PRECISION (unsigned_intTI_type_node)) + return unsigned_intTI_type_node; + } + + return NULL_TREE; +} + +/* Return a data type that has machine mode MODE. If the mode is an + integer, then UNSIGNEDP selects between signed and unsigned types. */ + +tree +gfc_type_for_mode (machine_mode mode, int unsignedp) +{ + int i; + tree *base; + scalar_int_mode int_mode; + + if (GET_MODE_CLASS (mode) == MODE_FLOAT) + base = gfc_real_types; + else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT) + base = gfc_complex_types; + else if (is_a (mode, &int_mode)) + { + tree type = gfc_type_for_size (GET_MODE_PRECISION (int_mode), unsignedp); + return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE; + } + else if (GET_MODE_CLASS (mode) == MODE_VECTOR_BOOL + && valid_vector_subparts_p (GET_MODE_NUNITS (mode))) + { + unsigned int elem_bits = vector_element_size (GET_MODE_BITSIZE (mode), + GET_MODE_NUNITS (mode)); + tree bool_type = build_nonstandard_boolean_type (elem_bits); + return build_vector_type_for_mode (bool_type, mode); + } + else if (VECTOR_MODE_P (mode) + && valid_vector_subparts_p (GET_MODE_NUNITS (mode))) + { + machine_mode inner_mode = GET_MODE_INNER (mode); + tree inner_type = gfc_type_for_mode (inner_mode, unsignedp); + if (inner_type != NULL_TREE) + return build_vector_type_for_mode (inner_type, mode); + return NULL_TREE; + } + else + return NULL_TREE; + + for (i = 0; i <= MAX_REAL_KINDS; ++i) + { + tree type = base[i]; + if (type && mode == TYPE_MODE (type)) + return type; + } + + return NULL_TREE; +} + +/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO + in that case. */ + +bool +gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) +{ + int rank, dim; + bool indirect = false; + tree etype, ptype, t, base_decl; + tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size; + tree lower_suboff, upper_suboff, stride_suboff; + tree dtype, field, rank_off; + + if (! GFC_DESCRIPTOR_TYPE_P (type)) + { + if (! POINTER_TYPE_P (type)) + return false; + type = TREE_TYPE (type); + if (! GFC_DESCRIPTOR_TYPE_P (type)) + return false; + indirect = true; + } + + rank = GFC_TYPE_ARRAY_RANK (type); + if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0]))) + return false; + + etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); + gcc_assert (POINTER_TYPE_P (etype)); + etype = TREE_TYPE (etype); + + /* If the type is not a scalar coarray. */ + if (TREE_CODE (etype) == ARRAY_TYPE) + etype = TREE_TYPE (etype); + + /* Can't handle variable sized elements yet. */ + if (int_size_in_bytes (etype) <= 0) + return false; + /* Nor non-constant lower bounds in assumed shape arrays. */ + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) + { + for (dim = 0; dim < rank; dim++) + if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE + || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST) + return false; + } + + memset (info, '\0', sizeof (*info)); + info->ndimensions = rank; + info->ordering = array_descr_ordering_column_major; + info->element_type = etype; + ptype = build_pointer_type (gfc_array_index_type); + base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect); + if (!base_decl) + { + base_decl = build_debug_expr_decl (indirect + ? build_pointer_type (ptype) : ptype); + GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl; + } + info->base_decl = base_decl; + if (indirect) + base_decl = build1 (INDIRECT_REF, ptype, base_decl); + + gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off, + &dim_off, &dim_size, &stride_suboff, + &lower_suboff, &upper_suboff); + + t = fold_build_pointer_plus (base_decl, span_off); + elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t); + + t = base_decl; + if (!integer_zerop (data_off)) + t = fold_build_pointer_plus (t, data_off); + t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t); + info->data_location = build1 (INDIRECT_REF, ptr_type_node, t); + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + info->allocated = build2 (NE_EXPR, logical_type_node, + info->data_location, null_pointer_node); + else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) + info->associated = build2 (NE_EXPR, logical_type_node, + info->data_location, null_pointer_node); + if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT) + && dwarf_version >= 5) + { + rank = 1; + info->ndimensions = 1; + t = base_decl; + if (!integer_zerop (dtype_off)) + t = fold_build_pointer_plus (t, dtype_off); + dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ()); + field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK); + rank_off = byte_position (field); + if (!integer_zerop (dtype_off)) + t = fold_build_pointer_plus (t, rank_off); + + t = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (field)), t); + t = build1 (INDIRECT_REF, TREE_TYPE (field), t); + info->rank = t; + t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off)); + t = size_binop (MULT_EXPR, t, dim_size); + dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off); + } + + for (dim = 0; dim < rank; dim++) + { + t = fold_build_pointer_plus (base_decl, + size_binop (PLUS_EXPR, + dim_off, lower_suboff)); + t = build1 (INDIRECT_REF, gfc_array_index_type, t); + info->dimen[dim].lower_bound = t; + t = fold_build_pointer_plus (base_decl, + size_binop (PLUS_EXPR, + dim_off, upper_suboff)); + t = build1 (INDIRECT_REF, gfc_array_index_type, t); + info->dimen[dim].upper_bound = t; + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) + { + /* Assumed shape arrays have known lower bounds. */ + info->dimen[dim].upper_bound + = build2 (MINUS_EXPR, gfc_array_index_type, + info->dimen[dim].upper_bound, + info->dimen[dim].lower_bound); + info->dimen[dim].lower_bound + = fold_convert (gfc_array_index_type, + GFC_TYPE_ARRAY_LBOUND (type, dim)); + info->dimen[dim].upper_bound + = build2 (PLUS_EXPR, gfc_array_index_type, + info->dimen[dim].lower_bound, + info->dimen[dim].upper_bound); + } + t = fold_build_pointer_plus (base_decl, + size_binop (PLUS_EXPR, + dim_off, stride_suboff)); + t = build1 (INDIRECT_REF, gfc_array_index_type, t); + t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size); + info->dimen[dim].stride = t; + if (dim + 1 < rank) + dim_off = size_binop (PLUS_EXPR, dim_off, dim_size); + } + + return true; +} + + +/* Create a type to handle vector subscripts for coarray library calls. It + has the form: + struct caf_vector_t { + size_t nvec; // size of the vector + union { + struct { + void *vector; + int kind; + } v; + struct { + ptrdiff_t lower_bound; + ptrdiff_t upper_bound; + ptrdiff_t stride; + } triplet; + } u; + } + where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector + size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */ + +tree +gfc_get_caf_vector_type (int dim) +{ + static tree vector_types[GFC_MAX_DIMENSIONS]; + static tree vec_type = NULL_TREE; + tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain; + + if (vector_types[dim-1] != NULL_TREE) + return vector_types[dim-1]; + + if (vec_type == NULL_TREE) + { + chain = 0; + vect_struct_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (vect_struct_type, + get_identifier ("vector"), + pvoid_type_node, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (vect_struct_type, + get_identifier ("kind"), + integer_type_node, &chain); + suppress_warning (tmp); + gfc_finish_type (vect_struct_type); + + chain = 0; + triplet_struct_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (triplet_struct_type, + get_identifier ("lower_bound"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (triplet_struct_type, + get_identifier ("upper_bound"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + gfc_finish_type (triplet_struct_type); + + chain = 0; + union_type = make_node (UNION_TYPE); + tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"), + vect_struct_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"), + triplet_struct_type, &chain); + suppress_warning (tmp); + gfc_finish_type (union_type); + + chain = 0; + vec_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"), + size_type_node, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"), + union_type, &chain); + suppress_warning (tmp); + gfc_finish_type (vec_type); + TYPE_NAME (vec_type) = get_identifier ("caf_vector_t"); + } + + tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, + gfc_rank_cst[dim-1]); + vector_types[dim-1] = build_array_type (vec_type, tmp); + return vector_types[dim-1]; +} + + +tree +gfc_get_caf_reference_type () +{ + static tree reference_type = NULL_TREE; + tree c_struct_type, s_struct_type, v_struct_type, union_type, dim_union_type, + a_struct_type, u_union_type, tmp, *chain; + + if (reference_type != NULL_TREE) + return reference_type; + + chain = 0; + c_struct_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (c_struct_type, + get_identifier ("offset"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (c_struct_type, + get_identifier ("caf_token_offset"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + gfc_finish_type (c_struct_type); + + chain = 0; + s_struct_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (s_struct_type, + get_identifier ("start"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (s_struct_type, + get_identifier ("end"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (s_struct_type, + get_identifier ("stride"), + gfc_array_index_type, &chain); + suppress_warning (tmp); + gfc_finish_type (s_struct_type); + + chain = 0; + v_struct_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (v_struct_type, + get_identifier ("vector"), + pvoid_type_node, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (v_struct_type, + get_identifier ("nvec"), + size_type_node, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (v_struct_type, + get_identifier ("kind"), + integer_type_node, &chain); + suppress_warning (tmp); + gfc_finish_type (v_struct_type); + + chain = 0; + union_type = make_node (UNION_TYPE); + tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("s"), + s_struct_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"), + v_struct_type, &chain); + suppress_warning (tmp); + gfc_finish_type (union_type); + + tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, + gfc_rank_cst[GFC_MAX_DIMENSIONS - 1]); + dim_union_type = build_array_type (union_type, tmp); + + chain = 0; + a_struct_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("mode"), + build_array_type (unsigned_char_type_node, + build_range_type (gfc_array_index_type, + gfc_index_zero_node, + gfc_rank_cst[GFC_MAX_DIMENSIONS - 1])), + &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (a_struct_type, + get_identifier ("static_array_type"), + integer_type_node, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (a_struct_type, get_identifier ("dim"), + dim_union_type, &chain); + suppress_warning (tmp); + gfc_finish_type (a_struct_type); + + chain = 0; + u_union_type = make_node (UNION_TYPE); + tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("c"), + c_struct_type, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (u_union_type, get_identifier ("a"), + a_struct_type, &chain); + suppress_warning (tmp); + gfc_finish_type (u_union_type); + + chain = 0; + reference_type = make_node (RECORD_TYPE); + tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("next"), + build_pointer_type (reference_type), &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("type"), + integer_type_node, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("item_size"), + size_type_node, &chain); + suppress_warning (tmp); + tmp = gfc_add_field_to_struct_1 (reference_type, get_identifier ("u"), + u_union_type, &chain); + suppress_warning (tmp); + gfc_finish_type (reference_type); + TYPE_NAME (reference_type) = get_identifier ("caf_reference_t"); + + return reference_type; +} + +static tree +gfc_get_cfi_dim_type () +{ + static tree CFI_dim_t = NULL; + + if (CFI_dim_t) + return CFI_dim_t; + + CFI_dim_t = make_node (RECORD_TYPE); + TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t"); + TYPE_NAMELESS (CFI_dim_t) = 1; + tree field; + tree *chain = NULL; + field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"), + gfc_array_index_type, &chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"), + gfc_array_index_type, &chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"), + gfc_array_index_type, &chain); + suppress_warning (field); + gfc_finish_type (CFI_dim_t); + TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1; + return CFI_dim_t; +} + + +/* Return the CFI type; use dimen == -1 for dim[] (only for pointers); + otherwise dim[dimen] is used. */ + +tree +gfc_get_cfi_type (int dimen, bool restricted) +{ + gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK); + + int idx = 2*(dimen + 1) + restricted; + + if (gfc_cfi_descriptor_base[idx]) + return gfc_cfi_descriptor_base[idx]; + + /* Build the type node. */ + tree CFI_cdesc_t = make_node (RECORD_TYPE); + char name[GFC_MAX_SYMBOL_LEN + 1]; + if (dimen != -1) + sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen); + TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name); + TYPE_NAMELESS (CFI_cdesc_t) = 1; + + tree field; + tree *chain = NULL; + field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"), + (restricted ? prvoid_type_node + : ptr_type_node), &chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"), + size_type_node, &chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"), + integer_type_node, &chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"), + signed_char_type_node, &chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"), + signed_char_type_node, &chain); + suppress_warning (field); + field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"), + get_typenode_from_name (INT16_TYPE), + &chain); + suppress_warning (field); + + if (dimen != 0) + { + tree range = NULL_TREE; + if (dimen > 0) + range = gfc_rank_cst[dimen - 1]; + range = build_range_type (gfc_array_index_type, gfc_index_zero_node, + range); + tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range); + field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"), + CFI_dim_t, &chain); + suppress_warning (field); + } + + TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1; + gfc_finish_type (CFI_cdesc_t); + gfc_cfi_descriptor_base[idx] = CFI_cdesc_t; + return CFI_cdesc_t; +} + +#include "gt-fortran-trans-types.h" diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c deleted file mode 100644 index 26f0815..0000000 --- a/gcc/fortran/trans.c +++ /dev/null @@ -1,2452 +0,0 @@ -/* Code translation -- generate GCC trees from gfc_code. - Copyright (C) 2002-2022 Free Software Foundation, Inc. - Contributed by Paul Brook - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -. */ - -#include "config.h" -#include "system.h" -#include "coretypes.h" -#include "options.h" -#include "tree.h" -#include "gfortran.h" -#include "gimple-expr.h" /* For create_tmp_var_raw. */ -#include "trans.h" -#include "stringpool.h" -#include "fold-const.h" -#include "tree-iterator.h" -#include "trans-stmt.h" -#include "trans-array.h" -#include "trans-types.h" -#include "trans-const.h" - -/* Naming convention for backend interface code: - - gfc_trans_* translate gfc_code into STMT trees. - - gfc_conv_* expression conversion - - gfc_get_* get a backend tree representation of a decl or type */ - -static gfc_file *gfc_current_backend_file; - -const char gfc_msg_fault[] = N_("Array reference out of bounds"); - - -/* Return a location_t suitable for 'tree' for a gfortran locus. The way the - parser works in gfortran, loc->lb->location contains only the line number - and LOCATION_COLUMN is 0; hence, the column has to be added when generating - locations for 'tree'. Cf. error.c's gfc_format_decoder. */ - -location_t -gfc_get_location (locus *loc) -{ - return linemap_position_for_loc_and_offset (line_table, loc->lb->location, - loc->nextc - loc->lb->line); -} - -/* Advance along TREE_CHAIN n times. */ - -tree -gfc_advance_chain (tree t, int n) -{ - for (; n > 0; n--) - { - gcc_assert (t != NULL_TREE); - t = DECL_CHAIN (t); - } - return t; -} - -static int num_var; - -#define MAX_PREFIX_LEN 20 - -static tree -create_var_debug_raw (tree type, const char *prefix) -{ - /* Space for prefix + "_" + 10-digit-number + \0. */ - char name_buf[MAX_PREFIX_LEN + 1 + 10 + 1]; - tree t; - int i; - - if (prefix == NULL) - prefix = "gfc"; - else - gcc_assert (strlen (prefix) <= MAX_PREFIX_LEN); - - for (i = 0; prefix[i] != 0; i++) - name_buf[i] = gfc_wide_toupper (prefix[i]); - - snprintf (name_buf + i, sizeof (name_buf) - i, "_%d", num_var++); - - t = build_decl (input_location, VAR_DECL, get_identifier (name_buf), type); - - /* Not setting this causes some regressions. */ - DECL_ARTIFICIAL (t) = 1; - - /* We want debug info for it. */ - DECL_IGNORED_P (t) = 0; - /* It should not be nameless. */ - DECL_NAMELESS (t) = 0; - - /* Make the variable writable. */ - TREE_READONLY (t) = 0; - - DECL_EXTERNAL (t) = 0; - TREE_STATIC (t) = 0; - TREE_USED (t) = 1; - - return t; -} - -/* Creates a variable declaration with a given TYPE. */ - -tree -gfc_create_var_np (tree type, const char *prefix) -{ - tree t; - - if (flag_debug_aux_vars) - return create_var_debug_raw (type, prefix); - - t = create_tmp_var_raw (type, prefix); - - /* No warnings for anonymous variables. */ - if (prefix == NULL) - suppress_warning (t); - - return t; -} - - -/* Like above, but also adds it to the current scope. */ - -tree -gfc_create_var (tree type, const char *prefix) -{ - tree tmp; - - tmp = gfc_create_var_np (type, prefix); - - pushdecl (tmp); - - return tmp; -} - - -/* If the expression is not constant, evaluate it now. We assign the - result of the expression to an artificially created variable VAR, and - return a pointer to the VAR_DECL node for this variable. */ - -tree -gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock) -{ - tree var; - - if (CONSTANT_CLASS_P (expr)) - return expr; - - var = gfc_create_var (TREE_TYPE (expr), NULL); - gfc_add_modify_loc (loc, pblock, var, expr); - - return var; -} - - -tree -gfc_evaluate_now (tree expr, stmtblock_t * pblock) -{ - return gfc_evaluate_now_loc (input_location, expr, pblock); -} - -/* Like gfc_evaluate_now, but add the created variable to the - function scope. */ - -tree -gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock) -{ - tree var; - var = gfc_create_var_np (TREE_TYPE (expr), NULL); - gfc_add_decl_to_function (var); - gfc_add_modify (pblock, var, expr); - - return var; -} - -/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. - A MODIFY_EXPR is an assignment: - LHS <- RHS. */ - -void -gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs) -{ - tree tmp; - - tree t1, t2; - t1 = TREE_TYPE (rhs); - t2 = TREE_TYPE (lhs); - /* Make sure that the types of the rhs and the lhs are compatible - for scalar assignments. We should probably have something - similar for aggregates, but right now removing that check just - breaks everything. */ - gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2) - || AGGREGATE_TYPE_P (TREE_TYPE (lhs))); - - tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs, - rhs); - gfc_add_expr_to_block (pblock, tmp); -} - - -void -gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs) -{ - gfc_add_modify_loc (input_location, pblock, lhs, rhs); -} - - -/* Create a new scope/binding level and initialize a block. Care must be - taken when translating expressions as any temporaries will be placed in - the innermost scope. */ - -void -gfc_start_block (stmtblock_t * block) -{ - /* Start a new binding level. */ - pushlevel (); - block->has_scope = 1; - - /* The block is empty. */ - block->head = NULL_TREE; -} - - -/* Initialize a block without creating a new scope. */ - -void -gfc_init_block (stmtblock_t * block) -{ - block->head = NULL_TREE; - block->has_scope = 0; -} - - -/* Sometimes we create a scope but it turns out that we don't actually - need it. This function merges the scope of BLOCK with its parent. - Only variable decls will be merged, you still need to add the code. */ - -void -gfc_merge_block_scope (stmtblock_t * block) -{ - tree decl; - tree next; - - gcc_assert (block->has_scope); - block->has_scope = 0; - - /* Remember the decls in this scope. */ - decl = getdecls (); - poplevel (0, 0); - - /* Add them to the parent scope. */ - while (decl != NULL_TREE) - { - next = DECL_CHAIN (decl); - DECL_CHAIN (decl) = NULL_TREE; - - pushdecl (decl); - decl = next; - } -} - - -/* Finish a scope containing a block of statements. */ - -tree -gfc_finish_block (stmtblock_t * stmtblock) -{ - tree decl; - tree expr; - tree block; - - expr = stmtblock->head; - if (!expr) - expr = build_empty_stmt (input_location); - - stmtblock->head = NULL_TREE; - - if (stmtblock->has_scope) - { - decl = getdecls (); - - if (decl) - { - block = poplevel (1, 0); - expr = build3_v (BIND_EXPR, decl, expr, block); - } - else - poplevel (0, 0); - } - - return expr; -} - - -/* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the - natural type is used. */ - -tree -gfc_build_addr_expr (tree type, tree t) -{ - tree base_type = TREE_TYPE (t); - tree natural_type; - - if (type && POINTER_TYPE_P (type) - && TREE_CODE (base_type) == ARRAY_TYPE - && TYPE_MAIN_VARIANT (TREE_TYPE (type)) - == TYPE_MAIN_VARIANT (TREE_TYPE (base_type))) - { - tree min_val = size_zero_node; - tree type_domain = TYPE_DOMAIN (base_type); - if (type_domain && TYPE_MIN_VALUE (type_domain)) - min_val = TYPE_MIN_VALUE (type_domain); - t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type), - t, min_val, NULL_TREE, NULL_TREE)); - natural_type = type; - } - else - natural_type = build_pointer_type (base_type); - - if (TREE_CODE (t) == INDIRECT_REF) - { - if (!type) - type = natural_type; - t = TREE_OPERAND (t, 0); - natural_type = TREE_TYPE (t); - } - else - { - tree base = get_base_address (t); - if (base && DECL_P (base)) - TREE_ADDRESSABLE (base) = 1; - t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t); - } - - if (type && natural_type != type) - t = convert (type, t); - - return t; -} - - -static tree -get_array_span (tree type, tree decl) -{ - tree span; - - /* Component references are guaranteed to have a reliable value for - 'span'. Likewise indirect references since they emerge from the - conversion of a CFI descriptor or the hidden dummy descriptor. */ - if (TREE_CODE (decl) == COMPONENT_REF - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - return gfc_conv_descriptor_span_get (decl); - else if (TREE_CODE (decl) == INDIRECT_REF - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - return gfc_conv_descriptor_span_get (decl); - - /* Return the span for deferred character length array references. */ - if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type)) - { - if (TREE_CODE (decl) == PARM_DECL) - decl = build_fold_indirect_ref_loc (input_location, decl); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) - span = gfc_conv_descriptor_span_get (decl); - else - span = gfc_get_character_len_in_bytes (type); - span = (span && !integer_zerop (span)) - ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE); - } - /* Likewise for class array or pointer array references. */ - else if (TREE_CODE (decl) == FIELD_DECL - || VAR_OR_FUNCTION_DECL_P (decl) - || TREE_CODE (decl) == PARM_DECL) - { - if (GFC_DECL_CLASS (decl)) - { - /* When a temporary is in place for the class array, then the - original class' declaration is stored in the saved - descriptor. */ - if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - else - { - /* Allow for dummy arguments and other good things. */ - if (POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref_loc (input_location, decl); - - /* Check if '_data' is an array descriptor. If it is not, - the array must be one of the components of the class - object, so return a null span. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( - gfc_class_data_get (decl)))) - return NULL_TREE; - } - span = gfc_class_vtab_size_get (decl); - /* For unlimited polymorphic entities then _len component needs - to be multiplied with the size. */ - span = gfc_resize_class_size_with_len (NULL, decl, span); - } - else if (GFC_DECL_PTR_ARRAY_P (decl)) - { - if (TREE_CODE (decl) == PARM_DECL) - decl = build_fold_indirect_ref_loc (input_location, decl); - span = gfc_conv_descriptor_span_get (decl); - } - else - span = NULL_TREE; - } - else - span = NULL_TREE; - - return span; -} - - -tree -gfc_build_spanned_array_ref (tree base, tree offset, tree span) -{ - tree type; - tree tmp; - type = TREE_TYPE (TREE_TYPE (base)); - offset = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - offset, span); - tmp = gfc_build_addr_expr (pvoid_type_node, base); - tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); - tmp = fold_convert (build_pointer_type (type), tmp); - if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) - || !TYPE_STRING_FLAG (type)) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - return tmp; -} - - -/* Build an ARRAY_REF with its natural type. */ - -tree -gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) -{ - tree type = TREE_TYPE (base); - tree span = NULL_TREE; - - if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) - { - gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); - - return fold_convert (TYPE_MAIN_VARIANT (type), base); - } - - /* Scalar coarray, there is nothing to do. */ - if (TREE_CODE (type) != ARRAY_TYPE) - { - gcc_assert (decl == NULL_TREE); - gcc_assert (integer_zerop (offset)); - return base; - } - - type = TREE_TYPE (type); - - if (DECL_P (base)) - TREE_ADDRESSABLE (base) = 1; - - /* Strip NON_LVALUE_EXPR nodes. */ - STRIP_TYPE_NOPS (offset); - - /* If decl or vptr are non-null, pointer arithmetic for the array reference - is likely. Generate the 'span' for the array reference. */ - if (vptr) - { - span = gfc_vptr_size_get (vptr); - - /* Check if this is an unlimited polymorphic object carrying a character - payload. In this case, the 'len' field is non-zero. */ - if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) - span = gfc_resize_class_size_with_len (NULL, decl, span); - } - else if (decl) - span = get_array_span (type, decl); - - /* If a non-null span has been generated reference the element with - pointer arithmetic. */ - if (span != NULL_TREE) - return gfc_build_spanned_array_ref (base, offset, span); - /* Otherwise use a straightforward array reference. */ - else - return build4_loc (input_location, ARRAY_REF, type, base, offset, - NULL_TREE, NULL_TREE); -} - - -/* Generate a call to print a runtime error possibly including multiple - arguments and a locus. */ - -static tree -trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid, - va_list ap) -{ - stmtblock_t block; - tree tmp; - tree arg, arg2; - tree *argarray; - tree fntype; - char *message; - const char *p; - int line, nargs, i; - location_t loc; - - /* Compute the number of extra arguments from the format string. */ - for (p = msgid, nargs = 0; *p; p++) - if (*p == '%') - { - p++; - if (*p != '%') - nargs++; - } - - /* The code to generate the error. */ - gfc_start_block (&block); - - if (where) - { - line = LOCATION_LINE (where->lb->location); - message = xasprintf ("At line %d of file %s", line, - where->lb->file->filename); - } - else - message = xasprintf ("In file '%s', around line %d", - gfc_source_file, LOCATION_LINE (input_location) + 1); - - arg = gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const (message)); - free (message); - - message = xasprintf ("%s", _(msgid)); - arg2 = gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const (message)); - free (message); - - /* Build the argument array. */ - argarray = XALLOCAVEC (tree, nargs + 2); - argarray[0] = arg; - argarray[1] = arg2; - for (i = 0; i < nargs; i++) - argarray[2 + i] = va_arg (ap, tree); - - /* Build the function call to runtime_(warning,error)_at; because of the - variable number of arguments, we can't use build_call_expr_loc dinput_location, - irectly. */ - fntype = TREE_TYPE (errorfunc); - - loc = where ? gfc_get_location (where) : input_location; - tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype), - fold_build1_loc (loc, ADDR_EXPR, - build_pointer_type (fntype), - errorfunc), - nargs + 2, argarray); - gfc_add_expr_to_block (&block, tmp); - - return gfc_finish_block (&block); -} - - -tree -gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...) -{ - va_list ap; - tree result; - - va_start (ap, msgid); - result = trans_runtime_error_vararg (error - ? gfor_fndecl_runtime_error_at - : gfor_fndecl_runtime_warning_at, - where, msgid, ap); - va_end (ap); - return result; -} - - -/* Generate a runtime error if COND is true. */ - -void -gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, - locus * where, const char * msgid, ...) -{ - va_list ap; - stmtblock_t block; - tree body; - tree tmp; - tree tmpvar = NULL; - - if (integer_zerop (cond)) - return; - - if (once) - { - tmpvar = gfc_create_var (boolean_type_node, "print_warning"); - TREE_STATIC (tmpvar) = 1; - DECL_INITIAL (tmpvar) = boolean_true_node; - gfc_add_expr_to_block (pblock, tmpvar); - } - - gfc_start_block (&block); - - /* For error, runtime_error_at already implies PRED_NORETURN. */ - if (!error && once) - gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE, - NOT_TAKEN)); - - /* The code to generate the error. */ - va_start (ap, msgid); - gfc_add_expr_to_block (&block, - trans_runtime_error_vararg - (error ? gfor_fndecl_runtime_error_at - : gfor_fndecl_runtime_warning_at, - where, msgid, ap)); - va_end (ap); - - if (once) - gfc_add_modify (&block, tmpvar, boolean_false_node); - - body = gfc_finish_block (&block); - - if (integer_onep (cond)) - { - gfc_add_expr_to_block (pblock, body); - } - else - { - if (once) - cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR, - boolean_type_node, tmpvar, - fold_convert (boolean_type_node, cond)); - - tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node, - cond, body, - build_empty_stmt (gfc_get_location (where))); - gfc_add_expr_to_block (pblock, tmp); - } -} - - -static tree -trans_os_error_at (locus* where, const char* msgid, ...) -{ - va_list ap; - tree result; - - va_start (ap, msgid); - result = trans_runtime_error_vararg (gfor_fndecl_os_error_at, - where, msgid, ap); - va_end (ap); - return result; -} - - - -/* Call malloc to allocate size bytes of memory, with special conditions: - + if size == 0, return a malloced area of size 1, - + if malloc returns NULL, issue a runtime error. */ -tree -gfc_call_malloc (stmtblock_t * block, tree type, tree size) -{ - tree tmp, malloc_result, null_result, res, malloc_tree; - stmtblock_t block2; - - /* Create a variable to hold the result. */ - res = gfc_create_var (prvoid_type_node, NULL); - - /* Call malloc. */ - gfc_start_block (&block2); - - if (size == NULL_TREE) - size = build_int_cst (size_type_node, 1); - - size = fold_convert (size_type_node, size); - size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1)); - - malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC); - gfc_add_modify (&block2, res, - fold_convert (prvoid_type_node, - build_call_expr_loc (input_location, - malloc_tree, 1, size))); - - /* Optionally check whether malloc was successful. */ - if (gfc_option.rtcheck & GFC_RTCHECK_MEM) - { - null_result = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, res, - build_int_cst (pvoid_type_node, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - null_result, - trans_os_error_at (NULL, - "Error allocating %lu bytes", - fold_convert - (long_unsigned_type_node, - size)), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block2, tmp); - } - - malloc_result = gfc_finish_block (&block2); - gfc_add_expr_to_block (block, malloc_result); - - if (type != NULL) - res = fold_convert (type, res); - return res; -} - - -/* Allocate memory, using an optional status argument. - - This function follows the following pseudo-code: - - void * - allocate (size_t size, integer_type stat) - { - void *newmem; - - if (stat requested) - stat = 0; - - newmem = malloc (MAX (size, 1)); - if (newmem == NULL) - { - if (stat) - *stat = LIBERROR_ALLOCATION; - else - runtime_error ("Allocation would exceed memory limit"); - } - return newmem; - } */ -void -gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, - tree size, tree status) -{ - tree tmp, error_cond; - stmtblock_t on_error; - tree status_type = status ? TREE_TYPE (status) : NULL_TREE; - - /* If successful and stat= is given, set status to 0. */ - if (status != NULL_TREE) - gfc_add_expr_to_block (block, - fold_build2_loc (input_location, MODIFY_EXPR, status_type, - status, build_int_cst (status_type, 0))); - - /* The allocation itself. */ - size = fold_convert (size_type_node, size); - gfc_add_modify (block, pointer, - fold_convert (TREE_TYPE (pointer), - build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), 1, - fold_build2_loc (input_location, - MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1))))); - - /* What to do in case of error. */ - gfc_start_block (&on_error); - if (status != NULL_TREE) - { - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, - build_int_cst (status_type, LIBERROR_ALLOCATION)); - gfc_add_expr_to_block (&on_error, tmp); - } - else - { - /* Here, os_error_at already implies PRED_NORETURN. */ - tree lusize = fold_convert (long_unsigned_type_node, size); - tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize); - gfc_add_expr_to_block (&on_error, tmp); - } - - error_cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, pointer, - build_int_cst (prvoid_type_node, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), - gfc_finish_block (&on_error), - build_empty_stmt (input_location)); - - gfc_add_expr_to_block (block, tmp); -} - - -/* Allocate memory, using an optional status argument. - - This function follows the following pseudo-code: - - void * - allocate (size_t size, void** token, int *stat, char* errmsg, int errlen) - { - void *newmem; - - newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen); - return newmem; - } */ -void -gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size, - tree token, tree status, tree errmsg, tree errlen, - gfc_coarray_regtype alloc_type) -{ - tree tmp, pstat; - - gcc_assert (token != NULL_TREE); - - /* The allocation itself. */ - if (status == NULL_TREE) - pstat = null_pointer_node; - else - pstat = gfc_build_addr_expr (NULL_TREE, status); - - if (errmsg == NULL_TREE) - { - gcc_assert(errlen == NULL_TREE); - errmsg = null_pointer_node; - errlen = build_int_cst (integer_type_node, 0); - } - - size = fold_convert (size_type_node, size); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_register, 7, - fold_build2_loc (input_location, - MAX_EXPR, size_type_node, size, size_one_node), - build_int_cst (integer_type_node, alloc_type), - token, gfc_build_addr_expr (pvoid_type_node, pointer), - pstat, errmsg, errlen); - - gfc_add_expr_to_block (block, tmp); - - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (block, tmp); -} - - -/* Generate code for an ALLOCATE statement when the argument is an - allocatable variable. If the variable is currently allocated, it is an - error to allocate it again. - - This function follows the following pseudo-code: - - void * - allocate_allocatable (void *mem, size_t size, integer_type stat) - { - if (mem == NULL) - return allocate (size, stat); - else - { - if (stat) - stat = LIBERROR_ALLOCATION; - else - runtime_error ("Attempting to allocate already allocated variable"); - } - } - - expr must be set to the original expression being allocated for its locus - and variable name in case a runtime error has to be printed. */ -void -gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, - tree token, tree status, tree errmsg, tree errlen, - tree label_finish, gfc_expr* expr, int corank) -{ - stmtblock_t alloc_block; - tree tmp, null_mem, alloc, error; - tree type = TREE_TYPE (mem); - symbol_attribute caf_attr; - bool need_assign = false, refs_comp = false; - gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC; - - size = fold_convert (size_type_node, size); - null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, - logical_type_node, mem, - build_int_cst (type, 0)), - PRED_FORTRAN_REALLOC); - - /* If mem is NULL, we call gfc_allocate_using_malloc or - gfc_allocate_using_lib. */ - gfc_start_block (&alloc_block); - - if (flag_coarray == GFC_FCOARRAY_LIB) - caf_attr = gfc_caf_attr (expr, true, &refs_comp); - - if (flag_coarray == GFC_FCOARRAY_LIB - && (corank > 0 || caf_attr.codimension)) - { - tree cond, sub_caf_tree; - gfc_se se; - bool compute_special_caf_types_size = false; - - if (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) - { - compute_special_caf_types_size = true; - caf_alloc_type = GFC_CAF_LOCK_ALLOC; - } - else if (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV - && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) - { - compute_special_caf_types_size = true; - caf_alloc_type = GFC_CAF_EVENT_ALLOC; - } - else if (!caf_attr.coarray_comp && refs_comp) - /* Only allocatable components in a derived type coarray can be - allocate only. */ - caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY; - - gfc_init_se (&se, NULL); - sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); - if (sub_caf_tree == NULL_TREE) - sub_caf_tree = token; - - /* When mem is an array ref, then strip the .data-ref. */ - if (TREE_CODE (mem) == COMPONENT_REF - && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem)))) - tmp = TREE_OPERAND (mem, 0); - else - tmp = mem; - - if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp)) - && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0) - && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) - { - symbol_attribute attr; - - gfc_clear_attr (&attr); - tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr); - need_assign = true; - } - gfc_add_block_to_block (&alloc_block, &se.pre); - - /* In the front end, we represent the lock variable as pointer. However, - the FE only passes the pointer around and leaves the actual - representation to the library. Hence, we have to convert back to the - number of elements. */ - if (compute_special_caf_types_size) - size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, - size, TYPE_SIZE_UNIT (ptr_type_node)); - - gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree, - status, errmsg, errlen, caf_alloc_type); - if (need_assign) - gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem), - gfc_conv_descriptor_data_get (tmp))); - if (status != NULL_TREE) - { - TREE_USED (label_finish) = 1; - tmp = build1_v (GOTO_EXPR, label_finish); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - status, build_zero_cst (TREE_TYPE (status))); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), - tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&alloc_block, tmp); - } - } - else - gfc_allocate_using_malloc (&alloc_block, mem, size, status); - - alloc = gfc_finish_block (&alloc_block); - - /* If mem is not NULL, we issue a runtime error or set the - status variable. */ - if (expr) - { - tree varname; - - gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree); - varname = gfc_build_cstring_const (expr->symtree->name); - varname = gfc_build_addr_expr (pchar_type_node, varname); - - error = gfc_trans_runtime_error (true, &expr->where, - "Attempting to allocate already" - " allocated variable '%s'", - varname); - } - else - error = gfc_trans_runtime_error (true, NULL, - "Attempting to allocate already allocated" - " variable"); - - if (status != NULL_TREE) - { - tree status_type = TREE_TYPE (status); - - error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - status, build_int_cst (status_type, LIBERROR_ALLOCATION)); - } - - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, - error, alloc); - gfc_add_expr_to_block (block, tmp); -} - - -/* Free a given variable. */ - -tree -gfc_call_free (tree var) -{ - return build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_FREE), - 1, fold_convert (pvoid_type_node, var)); -} - - -/* Build a call to a FINAL procedure, which finalizes "var". */ - -static tree -gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, - bool fini_coarray, gfc_expr *class_size) -{ - stmtblock_t block; - gfc_se se; - tree final_fndecl, array, size, tmp; - symbol_attribute attr; - - gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); - gcc_assert (var); - - gfc_start_block (&block); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, final_wrapper); - final_fndecl = se.expr; - if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) - final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); - - if (ts.type == BT_DERIVED) - { - tree elem_size; - - gcc_assert (!class_size); - elem_size = gfc_typenode_for_spec (&ts); - elem_size = TYPE_SIZE_UNIT (elem_size); - size = fold_convert (gfc_array_index_type, elem_size); - - gfc_init_se (&se, NULL); - se.want_pointer = 1; - if (var->rank) - { - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, var); - array = se.expr; - } - else - { - gfc_conv_expr (&se, var); - gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); - array = se.expr; - - /* No copy back needed, hence set attr's allocatable/pointer - to zero. */ - gfc_clear_attr (&attr); - gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); - gcc_assert (se.post.head == NULL_TREE); - } - } - else - { - gfc_expr *array_expr; - gcc_assert (class_size); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, class_size); - gfc_add_block_to_block (&block, &se.pre); - gcc_assert (se.post.head == NULL_TREE); - size = se.expr; - - array_expr = gfc_copy_expr (var); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - if (array_expr->rank) - { - gfc_add_class_array_ref (array_expr); - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, array_expr); - array = se.expr; - } - else - { - gfc_add_data_component (array_expr); - gfc_conv_expr (&se, array_expr); - gfc_add_block_to_block (&block, &se.pre); - gcc_assert (se.post.head == NULL_TREE); - array = se.expr; - - if (!gfc_is_coarray (array_expr)) - { - /* No copy back needed, hence set attr's allocatable/pointer - to zero. */ - gfc_clear_attr (&attr); - gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); - } - gcc_assert (se.post.head == NULL_TREE); - } - gfc_free_expr (array_expr); - } - - if (!POINTER_TYPE_P (TREE_TYPE (array))) - array = gfc_build_addr_expr (NULL, array); - - gfc_add_block_to_block (&block, &se.pre); - tmp = build_call_expr_loc (input_location, - final_fndecl, 3, array, - size, fini_coarray ? boolean_true_node - : boolean_false_node); - gfc_add_block_to_block (&block, &se.post); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); -} - - -bool -gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, - bool fini_coarray) -{ - gfc_se se; - stmtblock_t block2; - tree final_fndecl, size, array, tmp, cond; - symbol_attribute attr; - gfc_expr *final_expr = NULL; - - if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS) - return false; - - gfc_init_block (&block2); - - if (comp->ts.type == BT_DERIVED) - { - if (comp->attr.pointer) - return false; - - gfc_is_finalizable (comp->ts.u.derived, &final_expr); - if (!final_expr) - return false; - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, final_expr); - final_fndecl = se.expr; - size = gfc_typenode_for_spec (&comp->ts); - size = TYPE_SIZE_UNIT (size); - size = fold_convert (gfc_array_index_type, size); - - array = decl; - } - else /* comp->ts.type == BT_CLASS. */ - { - if (CLASS_DATA (comp)->attr.class_pointer) - return false; - - gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr); - final_fndecl = gfc_class_vtab_final_get (decl); - size = gfc_class_vtab_size_get (decl); - array = gfc_class_data_get (decl); - } - - if (comp->attr.allocatable - || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) - { - tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)) - ? gfc_conv_descriptor_data_get (array) : array; - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - tmp, fold_convert (TREE_TYPE (tmp), - null_pointer_node)); - } - else - cond = logical_true_node; - - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))) - { - gfc_clear_attr (&attr); - gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); - gfc_add_block_to_block (&block2, &se.pre); - gcc_assert (se.post.head == NULL_TREE); - } - - if (!POINTER_TYPE_P (TREE_TYPE (array))) - array = gfc_build_addr_expr (NULL, array); - - if (!final_expr) - { - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - final_fndecl, - fold_convert (TREE_TYPE (final_fndecl), - null_pointer_node)); - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - logical_type_node, cond, tmp); - } - - if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) - final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); - - tmp = build_call_expr_loc (input_location, - final_fndecl, 3, array, - size, fini_coarray ? boolean_true_node - : boolean_false_node); - gfc_add_expr_to_block (&block2, tmp); - tmp = gfc_finish_block (&block2); - - 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); - - return true; -} - - -/* Add a call to the finalizer, using the passed *expr. Returns - true when a finalizer call has been inserted. */ - -bool -gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) -{ - tree tmp; - gfc_ref *ref; - gfc_expr *expr; - gfc_expr *final_expr = NULL; - gfc_expr *elem_size = NULL; - bool has_finalizer = false; - - if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS)) - return false; - - if (expr2->ts.type == BT_DERIVED) - { - gfc_is_finalizable (expr2->ts.u.derived, &final_expr); - if (!final_expr) - return false; - } - - /* If we have a class array, we need go back to the class - container. */ - expr = gfc_copy_expr (expr2); - - if (expr->ref && expr->ref->next && !expr->ref->next->next - && expr->ref->next->type == REF_ARRAY - && expr->ref->type == REF_COMPONENT - && strcmp (expr->ref->u.c.component->name, "_data") == 0) - { - gfc_free_ref_list (expr->ref); - expr->ref = NULL; - } - else - for (ref = expr->ref; ref; ref = ref->next) - if (ref->next && ref->next->next && !ref->next->next->next - && ref->next->next->type == REF_ARRAY - && ref->next->type == REF_COMPONENT - && strcmp (ref->next->u.c.component->name, "_data") == 0) - { - gfc_free_ref_list (ref->next); - ref->next = NULL; - } - - if (expr->ts.type == BT_CLASS) - { - has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL); - - if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as) - expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank; - - final_expr = gfc_copy_expr (expr); - gfc_add_vptr_component (final_expr); - gfc_add_final_component (final_expr); - - elem_size = gfc_copy_expr (expr); - gfc_add_vptr_component (elem_size); - gfc_add_size_component (elem_size); - } - - gcc_assert (final_expr->expr_type == EXPR_VARIABLE); - - tmp = gfc_build_final_call (expr->ts, final_expr, expr, - false, elem_size); - - if (expr->ts.type == BT_CLASS && !has_finalizer) - { - tree cond; - gfc_se se; - - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, final_expr); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); - - /* For CLASS(*) not only sym->_vtab->_final can be NULL - but already sym->_vtab itself. */ - if (UNLIMITED_POLY (expr)) - { - tree cond2; - gfc_expr *vptr_expr; - - vptr_expr = gfc_copy_expr (expr); - gfc_add_vptr_component (vptr_expr); - - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, vptr_expr); - gfc_free_expr (vptr_expr); - - cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - se.expr, - build_int_cst (TREE_TYPE (se.expr), 0)); - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - logical_type_node, cond2, cond); - } - - 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); - - return true; -} - - -/* User-deallocate; we emit the code directly from the front-end, and the - logic is the same as the previous library function: - - void - deallocate (void *pointer, GFC_INTEGER_4 * stat) - { - if (!pointer) - { - if (stat) - *stat = 1; - else - runtime_error ("Attempt to DEALLOCATE unallocated memory."); - } - else - { - free (pointer); - if (stat) - *stat = 0; - } - } - - In this front-end version, status doesn't have to be GFC_INTEGER_4. - Moreover, if CAN_FAIL is true, then we will not emit a runtime error, - even when no status variable is passed to us (this is used for - unconditional deallocation generated by the front-end at end of - each procedure). - - If a runtime-message is possible, `expr' must point to the original - expression being deallocated for its locus and variable name. - - For coarrays, "pointer" must be the array descriptor and not its - "data" component. - - COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are - the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be - analyzed and set by this routine, and -2 to indicate that a non-coarray is to - be deallocated. */ -tree -gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, - tree errlen, tree label_finish, - bool can_fail, gfc_expr* expr, - int coarray_dealloc_mode, tree add_when_allocated, - tree caf_token) -{ - stmtblock_t null, non_null; - tree cond, tmp, error; - tree status_type = NULL_TREE; - tree token = NULL_TREE; - gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; - - if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) - { - if (flag_coarray == GFC_FCOARRAY_LIB) - { - if (caf_token) - token = caf_token; - else - { - tree caf_type, caf_decl = pointer; - pointer = gfc_conv_descriptor_data_get (caf_decl); - caf_type = TREE_TYPE (caf_decl); - STRIP_NOPS (pointer); - if (GFC_DESCRIPTOR_TYPE_P (caf_type)) - 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 (caf_type) - && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) - != NULL_TREE); - token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); - } - } - - if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) - { - bool comp_ref; - if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp - && comp_ref) - caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; - // else do a deregister as set by default. - } - else - caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; - } - else if (flag_coarray == GFC_FCOARRAY_SINGLE) - pointer = gfc_conv_descriptor_data_get (pointer); - } - else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) - pointer = gfc_conv_descriptor_data_get (pointer); - - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, - build_int_cst (TREE_TYPE (pointer), 0)); - - /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise - we emit a runtime error. */ - gfc_start_block (&null); - if (!can_fail) - { - tree varname; - - gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); - - varname = gfc_build_cstring_const (expr->symtree->name); - varname = gfc_build_addr_expr (pchar_type_node, varname); - - error = gfc_trans_runtime_error (true, &expr->where, - "Attempt to DEALLOCATE unallocated '%s'", - varname); - } - else - error = build_empty_stmt (input_location); - - if (status != NULL_TREE && !integer_zerop (status)) - { - tree cond2; - - status_type = TREE_TYPE (TREE_TYPE (status)); - cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - status, build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 1)); - error = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond2, tmp, error); - } - - gfc_add_expr_to_block (&null, error); - - /* When POINTER is not NULL, we free it. */ - gfc_start_block (&non_null); - if (add_when_allocated) - gfc_add_expr_to_block (&non_null, add_when_allocated); - gfc_add_finalizer_call (&non_null, expr); - if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY - || flag_coarray != GFC_FCOARRAY_LIB) - { - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_FREE), 1, - fold_convert (pvoid_type_node, pointer)); - gfc_add_expr_to_block (&non_null, tmp); - gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), - 0)); - - if (status != NULL_TREE && !integer_zerop (status)) - { - /* We set STATUS to zero if it is present. */ - tree status_type = TREE_TYPE (TREE_TYPE (status)); - tree cond2; - - cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - status, - build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC), - tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&non_null, tmp); - } - } - else - { - tree cond2, pstat = null_pointer_node; - - if (errmsg == NULL_TREE) - { - gcc_assert (errlen == NULL_TREE); - errmsg = null_pointer_node; - errlen = build_zero_cst (integer_type_node); - } - else - { - gcc_assert (errlen != NULL_TREE); - if (!POINTER_TYPE_P (TREE_TYPE (errmsg))) - errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); - } - - if (status != NULL_TREE && !integer_zerop (status)) - { - gcc_assert (status_type == integer_type_node); - pstat = status; - } - - token = gfc_build_addr_expr (NULL_TREE, token); - gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), - pstat, errmsg, errlen); - gfc_add_expr_to_block (&non_null, tmp); - - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&non_null, tmp); - - if (status != NULL_TREE) - { - tree stat = build_fold_indirect_ref_loc (input_location, status); - tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, pointer, - build_int_cst (TREE_TYPE (pointer), - 0)); - - TREE_USED (label_finish) = 1; - tmp = build1_v (GOTO_EXPR, label_finish); - cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - stat, build_zero_cst (TREE_TYPE (stat))); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), - tmp, nullify); - gfc_add_expr_to_block (&non_null, tmp); - } - else - gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), - 0)); - } - - return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - gfc_finish_block (&null), - gfc_finish_block (&non_null)); -} - - -/* Generate code for deallocation of allocatable scalars (variables or - components). Before the object itself is freed, any allocatable - subcomponents are being deallocated. */ - -tree -gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, - bool can_fail, gfc_expr* expr, - gfc_typespec ts, bool coarray) -{ - stmtblock_t null, non_null; - tree cond, tmp, error; - bool finalizable, comp_ref; - gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; - - if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp - && comp_ref) - caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; - - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, - build_int_cst (TREE_TYPE (pointer), 0)); - - /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise - we emit a runtime error. */ - gfc_start_block (&null); - if (!can_fail) - { - tree varname; - - gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); - - varname = gfc_build_cstring_const (expr->symtree->name); - varname = gfc_build_addr_expr (pchar_type_node, varname); - - error = gfc_trans_runtime_error (true, &expr->where, - "Attempt to DEALLOCATE unallocated '%s'", - varname); - } - else - error = build_empty_stmt (input_location); - - if (status != NULL_TREE && !integer_zerop (status)) - { - tree status_type = TREE_TYPE (TREE_TYPE (status)); - tree cond2; - - cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - status, build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 1)); - error = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond2, tmp, error); - } - gfc_add_expr_to_block (&null, error); - - /* When POINTER is not NULL, we free it. */ - gfc_start_block (&non_null); - - /* Free allocatable components. */ - finalizable = gfc_add_finalizer_call (&non_null, expr); - if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) - { - int caf_mode = coarray - ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY - ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0) - | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY - | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) - : 0; - if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) - tmp = gfc_conv_descriptor_data_get (pointer); - else - tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode); - gfc_add_expr_to_block (&non_null, tmp); - } - - if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE) - { - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_FREE), 1, - fold_convert (pvoid_type_node, pointer)); - gfc_add_expr_to_block (&non_null, tmp); - - if (status != NULL_TREE && !integer_zerop (status)) - { - /* We set STATUS to zero if it is present. */ - tree status_type = TREE_TYPE (TREE_TYPE (status)); - tree cond2; - - cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - status, - build_int_cst (TREE_TYPE (status), 0)); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - cond2, tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&non_null, tmp); - } - } - else - { - tree token; - tree pstat = null_pointer_node; - gfc_se se; - - gfc_init_se (&se, NULL); - token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); - gcc_assert (token != NULL_TREE); - - if (status != NULL_TREE && !integer_zerop (status)) - { - gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node); - pstat = status; - } - - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), - pstat, null_pointer_node, integer_zero_node); - gfc_add_expr_to_block (&non_null, tmp); - - /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"); - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&non_null, tmp); - - if (status != NULL_TREE) - { - tree stat = build_fold_indirect_ref_loc (input_location, status); - tree cond2; - - TREE_USED (label_finish) = 1; - tmp = build1_v (GOTO_EXPR, label_finish); - cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - stat, build_zero_cst (TREE_TYPE (stat))); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), - tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&non_null, tmp); - } - } - - return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - gfc_finish_block (&null), - gfc_finish_block (&non_null)); -} - -/* Reallocate MEM so it has SIZE bytes of data. This behaves like the - following pseudo-code: - -void * -internal_realloc (void *mem, size_t size) -{ - res = realloc (mem, size); - if (!res && size != 0) - _gfortran_os_error ("Allocation would exceed memory limit"); - - return res; -} */ -tree -gfc_call_realloc (stmtblock_t * block, tree mem, tree size) -{ - tree res, nonzero, null_result, tmp; - tree type = TREE_TYPE (mem); - - /* Only evaluate the size once. */ - size = save_expr (fold_convert (size_type_node, size)); - - /* Create a variable to hold the result. */ - res = gfc_create_var (type, NULL); - - /* Call realloc and check the result. */ - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_REALLOC), 2, - fold_convert (pvoid_type_node, mem), size); - gfc_add_modify (block, res, fold_convert (type, tmp)); - null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - res, build_int_cst (pvoid_type_node, 0)); - nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size, - build_int_cst (size_type_node, 0)); - null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, - null_result, nonzero); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - null_result, - trans_os_error_at (NULL, - "Error reallocating to %lu bytes", - fold_convert - (long_unsigned_type_node, size)), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (block, tmp); - - return res; -} - - -/* Add an expression to another one, either at the front or the back. */ - -static void -add_expr_to_chain (tree* chain, tree expr, bool front) -{ - if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) - return; - - if (*chain) - { - if (TREE_CODE (*chain) != STATEMENT_LIST) - { - tree tmp; - - tmp = *chain; - *chain = NULL_TREE; - append_to_statement_list (tmp, chain); - } - - if (front) - { - tree_stmt_iterator i; - - i = tsi_start (*chain); - tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); - } - else - append_to_statement_list (expr, chain); - } - else - *chain = expr; -} - - -/* Add a statement at the end of a block. */ - -void -gfc_add_expr_to_block (stmtblock_t * block, tree expr) -{ - gcc_assert (block); - add_expr_to_chain (&block->head, expr, false); -} - - -/* Add a statement at the beginning of a block. */ - -void -gfc_prepend_expr_to_block (stmtblock_t * block, tree expr) -{ - gcc_assert (block); - add_expr_to_chain (&block->head, expr, true); -} - - -/* Add a block the end of a block. */ - -void -gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append) -{ - gcc_assert (append); - gcc_assert (!append->has_scope); - - gfc_add_expr_to_block (block, append->head); - append->head = NULL_TREE; -} - - -/* Save the current locus. The structure may not be complete, and should - only be used with gfc_restore_backend_locus. */ - -void -gfc_save_backend_locus (locus * loc) -{ - loc->lb = XCNEW (gfc_linebuf); - loc->lb->location = input_location; - loc->lb->file = gfc_current_backend_file; -} - - -/* Set the current locus. */ - -void -gfc_set_backend_locus (locus * loc) -{ - gfc_current_backend_file = loc->lb->file; - input_location = gfc_get_location (loc); -} - - -/* Restore the saved locus. Only used in conjunction with - gfc_save_backend_locus, to free the memory when we are done. */ - -void -gfc_restore_backend_locus (locus * loc) -{ - /* This only restores the information captured by gfc_save_backend_locus, - intentionally does not use gfc_get_location. */ - input_location = loc->lb->location; - gfc_current_backend_file = loc->lb->file; - free (loc->lb); -} - - -/* Translate an executable statement. The tree cond is used by gfc_trans_do. - This static function is wrapped by gfc_trans_code_cond and - gfc_trans_code. */ - -static tree -trans_code (gfc_code * code, tree cond) -{ - stmtblock_t block; - tree res; - - if (!code) - return build_empty_stmt (input_location); - - gfc_start_block (&block); - - /* Translate statements one by one into GENERIC trees until we reach - the end of this gfc_code branch. */ - for (; code; code = code->next) - { - if (code->here != 0) - { - res = gfc_trans_label_here (code); - gfc_add_expr_to_block (&block, res); - } - - gfc_current_locus = code->loc; - gfc_set_backend_locus (&code->loc); - - switch (code->op) - { - case EXEC_NOP: - case EXEC_END_BLOCK: - case EXEC_END_NESTED_BLOCK: - case EXEC_END_PROCEDURE: - res = NULL_TREE; - break; - - case EXEC_ASSIGN: - res = gfc_trans_assign (code); - break; - - case EXEC_LABEL_ASSIGN: - res = gfc_trans_label_assign (code); - break; - - case EXEC_POINTER_ASSIGN: - res = gfc_trans_pointer_assign (code); - break; - - case EXEC_INIT_ASSIGN: - if (code->expr1->ts.type == BT_CLASS) - res = gfc_trans_class_init_assign (code); - else - res = gfc_trans_init_assign (code); - break; - - case EXEC_CONTINUE: - res = NULL_TREE; - break; - - case EXEC_CRITICAL: - res = gfc_trans_critical (code); - break; - - case EXEC_CYCLE: - res = gfc_trans_cycle (code); - break; - - case EXEC_EXIT: - res = gfc_trans_exit (code); - break; - - case EXEC_GOTO: - res = gfc_trans_goto (code); - break; - - case EXEC_ENTRY: - res = gfc_trans_entry (code); - break; - - case EXEC_PAUSE: - res = gfc_trans_pause (code); - break; - - case EXEC_STOP: - case EXEC_ERROR_STOP: - res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP); - break; - - case EXEC_CALL: - /* For MVBITS we've got the special exception that we need a - dependency check, too. */ - { - bool is_mvbits = false; - - if (code->resolved_isym) - { - res = gfc_conv_intrinsic_subroutine (code); - if (res != NULL_TREE) - break; - } - - if (code->resolved_isym - && code->resolved_isym->id == GFC_ISYM_MVBITS) - is_mvbits = true; - - res = gfc_trans_call (code, is_mvbits, NULL_TREE, - NULL_TREE, false); - } - break; - - case EXEC_CALL_PPC: - res = gfc_trans_call (code, false, NULL_TREE, - NULL_TREE, false); - break; - - case EXEC_ASSIGN_CALL: - res = gfc_trans_call (code, true, NULL_TREE, - NULL_TREE, false); - break; - - case EXEC_RETURN: - res = gfc_trans_return (code); - break; - - case EXEC_IF: - res = gfc_trans_if (code); - break; - - case EXEC_ARITHMETIC_IF: - res = gfc_trans_arithmetic_if (code); - break; - - case EXEC_BLOCK: - res = gfc_trans_block_construct (code); - break; - - case EXEC_DO: - res = gfc_trans_do (code, cond); - break; - - case EXEC_DO_CONCURRENT: - res = gfc_trans_do_concurrent (code); - break; - - case EXEC_DO_WHILE: - res = gfc_trans_do_while (code); - break; - - case EXEC_SELECT: - res = gfc_trans_select (code); - break; - - case EXEC_SELECT_TYPE: - res = gfc_trans_select_type (code); - break; - - case EXEC_SELECT_RANK: - res = gfc_trans_select_rank (code); - break; - - case EXEC_FLUSH: - res = gfc_trans_flush (code); - break; - - case EXEC_SYNC_ALL: - case EXEC_SYNC_IMAGES: - case EXEC_SYNC_MEMORY: - res = gfc_trans_sync (code, code->op); - break; - - case EXEC_LOCK: - case EXEC_UNLOCK: - res = gfc_trans_lock_unlock (code, code->op); - break; - - case EXEC_EVENT_POST: - case EXEC_EVENT_WAIT: - res = gfc_trans_event_post_wait (code, code->op); - break; - - case EXEC_FAIL_IMAGE: - res = gfc_trans_fail_image (code); - break; - - case EXEC_FORALL: - res = gfc_trans_forall (code); - break; - - case EXEC_FORM_TEAM: - res = gfc_trans_form_team (code); - break; - - case EXEC_CHANGE_TEAM: - res = gfc_trans_change_team (code); - break; - - case EXEC_END_TEAM: - res = gfc_trans_end_team (code); - break; - - case EXEC_SYNC_TEAM: - res = gfc_trans_sync_team (code); - break; - - case EXEC_WHERE: - res = gfc_trans_where (code); - break; - - case EXEC_ALLOCATE: - res = gfc_trans_allocate (code); - break; - - case EXEC_DEALLOCATE: - res = gfc_trans_deallocate (code); - break; - - case EXEC_OPEN: - res = gfc_trans_open (code); - break; - - case EXEC_CLOSE: - res = gfc_trans_close (code); - break; - - case EXEC_READ: - res = gfc_trans_read (code); - break; - - case EXEC_WRITE: - res = gfc_trans_write (code); - break; - - case EXEC_IOLENGTH: - res = gfc_trans_iolength (code); - break; - - case EXEC_BACKSPACE: - res = gfc_trans_backspace (code); - break; - - case EXEC_ENDFILE: - res = gfc_trans_endfile (code); - break; - - case EXEC_INQUIRE: - res = gfc_trans_inquire (code); - break; - - case EXEC_WAIT: - res = gfc_trans_wait (code); - break; - - case EXEC_REWIND: - res = gfc_trans_rewind (code); - break; - - case EXEC_TRANSFER: - res = gfc_trans_transfer (code); - break; - - case EXEC_DT_END: - res = gfc_trans_dt_end (code); - break; - - case EXEC_OMP_ATOMIC: - case EXEC_OMP_BARRIER: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DEPOBJ: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DO: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_LOOP: - case EXEC_OMP_ERROR: - case EXEC_OMP_FLUSH: - case EXEC_OMP_MASKED: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASTER: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_ORDERED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SCOPE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SIMD: - case EXEC_OMP_SINGLE: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - case EXEC_OMP_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_WORKSHARE: - res = gfc_trans_omp_directive (code); - break; - - case EXEC_OACC_CACHE: - case EXEC_OACC_WAIT: - case EXEC_OACC_UPDATE: - case EXEC_OACC_LOOP: - case EXEC_OACC_HOST_DATA: - case EXEC_OACC_DATA: - case EXEC_OACC_KERNELS: - case EXEC_OACC_KERNELS_LOOP: - case EXEC_OACC_PARALLEL: - case EXEC_OACC_PARALLEL_LOOP: - case EXEC_OACC_SERIAL: - case EXEC_OACC_SERIAL_LOOP: - case EXEC_OACC_ENTER_DATA: - case EXEC_OACC_EXIT_DATA: - case EXEC_OACC_ATOMIC: - case EXEC_OACC_DECLARE: - res = gfc_trans_oacc_directive (code); - break; - - default: - gfc_internal_error ("gfc_trans_code(): Bad statement code"); - } - - gfc_set_backend_locus (&code->loc); - - if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) - { - if (TREE_CODE (res) != STATEMENT_LIST) - SET_EXPR_LOCATION (res, input_location); - - /* Add the new statement to the block. */ - gfc_add_expr_to_block (&block, res); - } - } - - /* Return the finished block. */ - return gfc_finish_block (&block); -} - - -/* Translate an executable statement with condition, cond. The condition is - used by gfc_trans_do to test for IO result conditions inside implied - DO loops of READ and WRITE statements. See build_dt in trans-io.c. */ - -tree -gfc_trans_code_cond (gfc_code * code, tree cond) -{ - return trans_code (code, cond); -} - -/* Translate an executable statement without condition. */ - -tree -gfc_trans_code (gfc_code * code) -{ - return trans_code (code, NULL_TREE); -} - - -/* This function is called after a complete program unit has been parsed - and resolved. */ - -void -gfc_generate_code (gfc_namespace * ns) -{ - ompws_flags = 0; - if (ns->is_block_data) - { - gfc_generate_block_data (ns); - return; - } - - gfc_generate_function_code (ns); -} - - -/* This function is called after a complete module has been parsed - and resolved. */ - -void -gfc_generate_module_code (gfc_namespace * ns) -{ - gfc_namespace *n; - struct module_htab_entry *entry; - - gcc_assert (ns->proc_name->backend_decl == NULL); - ns->proc_name->backend_decl - = build_decl (gfc_get_location (&ns->proc_name->declared_at), - NAMESPACE_DECL, get_identifier (ns->proc_name->name), - void_type_node); - entry = gfc_find_module (ns->proc_name->name); - if (entry->namespace_decl) - /* Buggy sourcecode, using a module before defining it? */ - entry->decls->empty (); - entry->namespace_decl = ns->proc_name->backend_decl; - - gfc_generate_module_vars (ns); - - /* We need to generate all module function prototypes first, to allow - sibling calls. */ - for (n = ns->contained; n; n = n->sibling) - { - gfc_entry_list *el; - - if (!n->proc_name) - continue; - - gfc_create_function_decl (n, false); - DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; - gfc_module_add_decl (entry, n->proc_name->backend_decl); - for (el = ns->entries; el; el = el->next) - { - DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl; - gfc_module_add_decl (entry, el->sym->backend_decl); - } - } - - for (n = ns->contained; n; n = n->sibling) - { - if (!n->proc_name) - continue; - - gfc_generate_function_code (n); - } -} - - -/* Initialize an init/cleanup block with existing code. */ - -void -gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) -{ - gcc_assert (block); - - block->init = NULL_TREE; - block->code = code; - block->cleanup = NULL_TREE; -} - - -/* Add a new pair of initializers/clean-up code. */ - -void -gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) -{ - gcc_assert (block); - - /* The new pair of init/cleanup should be "wrapped around" the existing - block of code, thus the initialization is added to the front and the - cleanup to the back. */ - add_expr_to_chain (&block->init, init, true); - add_expr_to_chain (&block->cleanup, cleanup, false); -} - - -/* Finish up a wrapped block by building a corresponding try-finally expr. */ - -tree -gfc_finish_wrapped_block (gfc_wrapped_block* block) -{ - tree result; - - gcc_assert (block); - - /* Build the final expression. For this, just add init and body together, - and put clean-up with that into a TRY_FINALLY_EXPR. */ - result = block->init; - add_expr_to_chain (&result, block->code, false); - if (block->cleanup) - result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, - result, block->cleanup); - - /* Clear the block. */ - block->init = NULL_TREE; - block->code = NULL_TREE; - block->cleanup = NULL_TREE; - - return result; -} - - -/* Helper function for marking a boolean expression tree as unlikely. */ - -tree -gfc_unlikely (tree cond, enum br_predictor predictor) -{ - tree tmp; - - if (optimize) - { - cond = fold_convert (long_integer_type_node, cond); - tmp = build_zero_cst (long_integer_type_node); - cond = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_EXPECT), - 3, cond, tmp, - build_int_cst (integer_type_node, - predictor)); - } - return cond; -} - - -/* Helper function for marking a boolean expression tree as likely. */ - -tree -gfc_likely (tree cond, enum br_predictor predictor) -{ - tree tmp; - - if (optimize) - { - cond = fold_convert (long_integer_type_node, cond); - tmp = build_one_cst (long_integer_type_node); - cond = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_EXPECT), - 3, cond, tmp, - build_int_cst (integer_type_node, - predictor)); - } - return cond; -} - - -/* Get the string length for a deferred character length component. */ - -bool -gfc_deferred_strlen (gfc_component *c, tree *decl) -{ - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *strlen; - if (!(c->ts.type == BT_CHARACTER - && (c->ts.deferred || c->attr.pdt_string))) - return false; - sprintf (name, "_%s_length", c->name); - for (strlen = c; strlen; strlen = strlen->next) - if (strcmp (strlen->name, name) == 0) - break; - *decl = strlen ? strlen->backend_decl : NULL_TREE; - return strlen != NULL; -} diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc new file mode 100644 index 0000000..26f0815 --- /dev/null +++ b/gcc/fortran/trans.cc @@ -0,0 +1,2452 @@ +/* Code translation -- generate GCC trees from gfc_code. + Copyright (C) 2002-2022 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "gimple-expr.h" /* For create_tmp_var_raw. */ +#include "trans.h" +#include "stringpool.h" +#include "fold-const.h" +#include "tree-iterator.h" +#include "trans-stmt.h" +#include "trans-array.h" +#include "trans-types.h" +#include "trans-const.h" + +/* Naming convention for backend interface code: + + gfc_trans_* translate gfc_code into STMT trees. + + gfc_conv_* expression conversion + + gfc_get_* get a backend tree representation of a decl or type */ + +static gfc_file *gfc_current_backend_file; + +const char gfc_msg_fault[] = N_("Array reference out of bounds"); + + +/* Return a location_t suitable for 'tree' for a gfortran locus. The way the + parser works in gfortran, loc->lb->location contains only the line number + and LOCATION_COLUMN is 0; hence, the column has to be added when generating + locations for 'tree'. Cf. error.c's gfc_format_decoder. */ + +location_t +gfc_get_location (locus *loc) +{ + return linemap_position_for_loc_and_offset (line_table, loc->lb->location, + loc->nextc - loc->lb->line); +} + +/* Advance along TREE_CHAIN n times. */ + +tree +gfc_advance_chain (tree t, int n) +{ + for (; n > 0; n--) + { + gcc_assert (t != NULL_TREE); + t = DECL_CHAIN (t); + } + return t; +} + +static int num_var; + +#define MAX_PREFIX_LEN 20 + +static tree +create_var_debug_raw (tree type, const char *prefix) +{ + /* Space for prefix + "_" + 10-digit-number + \0. */ + char name_buf[MAX_PREFIX_LEN + 1 + 10 + 1]; + tree t; + int i; + + if (prefix == NULL) + prefix = "gfc"; + else + gcc_assert (strlen (prefix) <= MAX_PREFIX_LEN); + + for (i = 0; prefix[i] != 0; i++) + name_buf[i] = gfc_wide_toupper (prefix[i]); + + snprintf (name_buf + i, sizeof (name_buf) - i, "_%d", num_var++); + + t = build_decl (input_location, VAR_DECL, get_identifier (name_buf), type); + + /* Not setting this causes some regressions. */ + DECL_ARTIFICIAL (t) = 1; + + /* We want debug info for it. */ + DECL_IGNORED_P (t) = 0; + /* It should not be nameless. */ + DECL_NAMELESS (t) = 0; + + /* Make the variable writable. */ + TREE_READONLY (t) = 0; + + DECL_EXTERNAL (t) = 0; + TREE_STATIC (t) = 0; + TREE_USED (t) = 1; + + return t; +} + +/* Creates a variable declaration with a given TYPE. */ + +tree +gfc_create_var_np (tree type, const char *prefix) +{ + tree t; + + if (flag_debug_aux_vars) + return create_var_debug_raw (type, prefix); + + t = create_tmp_var_raw (type, prefix); + + /* No warnings for anonymous variables. */ + if (prefix == NULL) + suppress_warning (t); + + return t; +} + + +/* Like above, but also adds it to the current scope. */ + +tree +gfc_create_var (tree type, const char *prefix) +{ + tree tmp; + + tmp = gfc_create_var_np (type, prefix); + + pushdecl (tmp); + + return tmp; +} + + +/* If the expression is not constant, evaluate it now. We assign the + result of the expression to an artificially created variable VAR, and + return a pointer to the VAR_DECL node for this variable. */ + +tree +gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock) +{ + tree var; + + if (CONSTANT_CLASS_P (expr)) + return expr; + + var = gfc_create_var (TREE_TYPE (expr), NULL); + gfc_add_modify_loc (loc, pblock, var, expr); + + return var; +} + + +tree +gfc_evaluate_now (tree expr, stmtblock_t * pblock) +{ + return gfc_evaluate_now_loc (input_location, expr, pblock); +} + +/* Like gfc_evaluate_now, but add the created variable to the + function scope. */ + +tree +gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock) +{ + tree var; + var = gfc_create_var_np (TREE_TYPE (expr), NULL); + gfc_add_decl_to_function (var); + gfc_add_modify (pblock, var, expr); + + return var; +} + +/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. + A MODIFY_EXPR is an assignment: + LHS <- RHS. */ + +void +gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs) +{ + tree tmp; + + tree t1, t2; + t1 = TREE_TYPE (rhs); + t2 = TREE_TYPE (lhs); + /* Make sure that the types of the rhs and the lhs are compatible + for scalar assignments. We should probably have something + similar for aggregates, but right now removing that check just + breaks everything. */ + gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2) + || AGGREGATE_TYPE_P (TREE_TYPE (lhs))); + + tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs, + rhs); + gfc_add_expr_to_block (pblock, tmp); +} + + +void +gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs) +{ + gfc_add_modify_loc (input_location, pblock, lhs, rhs); +} + + +/* Create a new scope/binding level and initialize a block. Care must be + taken when translating expressions as any temporaries will be placed in + the innermost scope. */ + +void +gfc_start_block (stmtblock_t * block) +{ + /* Start a new binding level. */ + pushlevel (); + block->has_scope = 1; + + /* The block is empty. */ + block->head = NULL_TREE; +} + + +/* Initialize a block without creating a new scope. */ + +void +gfc_init_block (stmtblock_t * block) +{ + block->head = NULL_TREE; + block->has_scope = 0; +} + + +/* Sometimes we create a scope but it turns out that we don't actually + need it. This function merges the scope of BLOCK with its parent. + Only variable decls will be merged, you still need to add the code. */ + +void +gfc_merge_block_scope (stmtblock_t * block) +{ + tree decl; + tree next; + + gcc_assert (block->has_scope); + block->has_scope = 0; + + /* Remember the decls in this scope. */ + decl = getdecls (); + poplevel (0, 0); + + /* Add them to the parent scope. */ + while (decl != NULL_TREE) + { + next = DECL_CHAIN (decl); + DECL_CHAIN (decl) = NULL_TREE; + + pushdecl (decl); + decl = next; + } +} + + +/* Finish a scope containing a block of statements. */ + +tree +gfc_finish_block (stmtblock_t * stmtblock) +{ + tree decl; + tree expr; + tree block; + + expr = stmtblock->head; + if (!expr) + expr = build_empty_stmt (input_location); + + stmtblock->head = NULL_TREE; + + if (stmtblock->has_scope) + { + decl = getdecls (); + + if (decl) + { + block = poplevel (1, 0); + expr = build3_v (BIND_EXPR, decl, expr, block); + } + else + poplevel (0, 0); + } + + return expr; +} + + +/* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the + natural type is used. */ + +tree +gfc_build_addr_expr (tree type, tree t) +{ + tree base_type = TREE_TYPE (t); + tree natural_type; + + if (type && POINTER_TYPE_P (type) + && TREE_CODE (base_type) == ARRAY_TYPE + && TYPE_MAIN_VARIANT (TREE_TYPE (type)) + == TYPE_MAIN_VARIANT (TREE_TYPE (base_type))) + { + tree min_val = size_zero_node; + tree type_domain = TYPE_DOMAIN (base_type); + if (type_domain && TYPE_MIN_VALUE (type_domain)) + min_val = TYPE_MIN_VALUE (type_domain); + t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type), + t, min_val, NULL_TREE, NULL_TREE)); + natural_type = type; + } + else + natural_type = build_pointer_type (base_type); + + if (TREE_CODE (t) == INDIRECT_REF) + { + if (!type) + type = natural_type; + t = TREE_OPERAND (t, 0); + natural_type = TREE_TYPE (t); + } + else + { + tree base = get_base_address (t); + if (base && DECL_P (base)) + TREE_ADDRESSABLE (base) = 1; + t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t); + } + + if (type && natural_type != type) + t = convert (type, t); + + return t; +} + + +static tree +get_array_span (tree type, tree decl) +{ + tree span; + + /* Component references are guaranteed to have a reliable value for + 'span'. Likewise indirect references since they emerge from the + conversion of a CFI descriptor or the hidden dummy descriptor. */ + if (TREE_CODE (decl) == COMPONENT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + return gfc_conv_descriptor_span_get (decl); + else if (TREE_CODE (decl) == INDIRECT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + return gfc_conv_descriptor_span_get (decl); + + /* Return the span for deferred character length array references. */ + if (type && TREE_CODE (type) == ARRAY_TYPE && TYPE_STRING_FLAG (type)) + { + if (TREE_CODE (decl) == PARM_DECL) + decl = build_fold_indirect_ref_loc (input_location, decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + span = gfc_conv_descriptor_span_get (decl); + else + span = gfc_get_character_len_in_bytes (type); + span = (span && !integer_zerop (span)) + ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE); + } + /* Likewise for class array or pointer array references. */ + else if (TREE_CODE (decl) == FIELD_DECL + || VAR_OR_FUNCTION_DECL_P (decl) + || TREE_CODE (decl) == PARM_DECL) + { + if (GFC_DECL_CLASS (decl)) + { + /* When a temporary is in place for the class array, then the + original class' declaration is stored in the saved + descriptor. */ + if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + else + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class + object, so return a null span. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( + gfc_class_data_get (decl)))) + return NULL_TREE; + } + span = gfc_class_vtab_size_get (decl); + /* For unlimited polymorphic entities then _len component needs + to be multiplied with the size. */ + span = gfc_resize_class_size_with_len (NULL, decl, span); + } + else if (GFC_DECL_PTR_ARRAY_P (decl)) + { + if (TREE_CODE (decl) == PARM_DECL) + decl = build_fold_indirect_ref_loc (input_location, decl); + span = gfc_conv_descriptor_span_get (decl); + } + else + span = NULL_TREE; + } + else + span = NULL_TREE; + + return span; +} + + +tree +gfc_build_spanned_array_ref (tree base, tree offset, tree span) +{ + tree type; + tree tmp; + type = TREE_TYPE (TREE_TYPE (base)); + offset = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + offset, span); + tmp = gfc_build_addr_expr (pvoid_type_node, base); + tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); + tmp = fold_convert (build_pointer_type (type), tmp); + if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) + || !TYPE_STRING_FLAG (type)) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + return tmp; +} + + +/* Build an ARRAY_REF with its natural type. */ + +tree +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) +{ + tree type = TREE_TYPE (base); + tree span = NULL_TREE; + + if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) + { + gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); + + return fold_convert (TYPE_MAIN_VARIANT (type), base); + } + + /* Scalar coarray, there is nothing to do. */ + if (TREE_CODE (type) != ARRAY_TYPE) + { + gcc_assert (decl == NULL_TREE); + gcc_assert (integer_zerop (offset)); + return base; + } + + type = TREE_TYPE (type); + + if (DECL_P (base)) + TREE_ADDRESSABLE (base) = 1; + + /* Strip NON_LVALUE_EXPR nodes. */ + STRIP_TYPE_NOPS (offset); + + /* If decl or vptr are non-null, pointer arithmetic for the array reference + is likely. Generate the 'span' for the array reference. */ + if (vptr) + { + span = gfc_vptr_size_get (vptr); + + /* Check if this is an unlimited polymorphic object carrying a character + payload. In this case, the 'len' field is non-zero. */ + if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) + span = gfc_resize_class_size_with_len (NULL, decl, span); + } + else if (decl) + span = get_array_span (type, decl); + + /* If a non-null span has been generated reference the element with + pointer arithmetic. */ + if (span != NULL_TREE) + return gfc_build_spanned_array_ref (base, offset, span); + /* Otherwise use a straightforward array reference. */ + else + return build4_loc (input_location, ARRAY_REF, type, base, offset, + NULL_TREE, NULL_TREE); +} + + +/* Generate a call to print a runtime error possibly including multiple + arguments and a locus. */ + +static tree +trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid, + va_list ap) +{ + stmtblock_t block; + tree tmp; + tree arg, arg2; + tree *argarray; + tree fntype; + char *message; + const char *p; + int line, nargs, i; + location_t loc; + + /* Compute the number of extra arguments from the format string. */ + for (p = msgid, nargs = 0; *p; p++) + if (*p == '%') + { + p++; + if (*p != '%') + nargs++; + } + + /* The code to generate the error. */ + gfc_start_block (&block); + + if (where) + { + line = LOCATION_LINE (where->lb->location); + message = xasprintf ("At line %d of file %s", line, + where->lb->file->filename); + } + else + message = xasprintf ("In file '%s', around line %d", + gfc_source_file, LOCATION_LINE (input_location) + 1); + + arg = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (message)); + free (message); + + message = xasprintf ("%s", _(msgid)); + arg2 = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const (message)); + free (message); + + /* Build the argument array. */ + argarray = XALLOCAVEC (tree, nargs + 2); + argarray[0] = arg; + argarray[1] = arg2; + for (i = 0; i < nargs; i++) + argarray[2 + i] = va_arg (ap, tree); + + /* Build the function call to runtime_(warning,error)_at; because of the + variable number of arguments, we can't use build_call_expr_loc dinput_location, + irectly. */ + fntype = TREE_TYPE (errorfunc); + + loc = where ? gfc_get_location (where) : input_location; + tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype), + fold_build1_loc (loc, ADDR_EXPR, + build_pointer_type (fntype), + errorfunc), + nargs + 2, argarray); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +tree +gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...) +{ + va_list ap; + tree result; + + va_start (ap, msgid); + result = trans_runtime_error_vararg (error + ? gfor_fndecl_runtime_error_at + : gfor_fndecl_runtime_warning_at, + where, msgid, ap); + va_end (ap); + return result; +} + + +/* Generate a runtime error if COND is true. */ + +void +gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, + locus * where, const char * msgid, ...) +{ + va_list ap; + stmtblock_t block; + tree body; + tree tmp; + tree tmpvar = NULL; + + if (integer_zerop (cond)) + return; + + if (once) + { + tmpvar = gfc_create_var (boolean_type_node, "print_warning"); + TREE_STATIC (tmpvar) = 1; + DECL_INITIAL (tmpvar) = boolean_true_node; + gfc_add_expr_to_block (pblock, tmpvar); + } + + gfc_start_block (&block); + + /* For error, runtime_error_at already implies PRED_NORETURN. */ + if (!error && once) + gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE, + NOT_TAKEN)); + + /* The code to generate the error. */ + va_start (ap, msgid); + gfc_add_expr_to_block (&block, + trans_runtime_error_vararg + (error ? gfor_fndecl_runtime_error_at + : gfor_fndecl_runtime_warning_at, + where, msgid, ap)); + va_end (ap); + + if (once) + gfc_add_modify (&block, tmpvar, boolean_false_node); + + body = gfc_finish_block (&block); + + if (integer_onep (cond)) + { + gfc_add_expr_to_block (pblock, body); + } + else + { + if (once) + cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR, + boolean_type_node, tmpvar, + fold_convert (boolean_type_node, cond)); + + tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node, + cond, body, + build_empty_stmt (gfc_get_location (where))); + gfc_add_expr_to_block (pblock, tmp); + } +} + + +static tree +trans_os_error_at (locus* where, const char* msgid, ...) +{ + va_list ap; + tree result; + + va_start (ap, msgid); + result = trans_runtime_error_vararg (gfor_fndecl_os_error_at, + where, msgid, ap); + va_end (ap); + return result; +} + + + +/* Call malloc to allocate size bytes of memory, with special conditions: + + if size == 0, return a malloced area of size 1, + + if malloc returns NULL, issue a runtime error. */ +tree +gfc_call_malloc (stmtblock_t * block, tree type, tree size) +{ + tree tmp, malloc_result, null_result, res, malloc_tree; + stmtblock_t block2; + + /* Create a variable to hold the result. */ + res = gfc_create_var (prvoid_type_node, NULL); + + /* Call malloc. */ + gfc_start_block (&block2); + + if (size == NULL_TREE) + size = build_int_cst (size_type_node, 1); + + size = fold_convert (size_type_node, size); + size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1)); + + malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC); + gfc_add_modify (&block2, res, + fold_convert (prvoid_type_node, + build_call_expr_loc (input_location, + malloc_tree, 1, size))); + + /* Optionally check whether malloc was successful. */ + if (gfc_option.rtcheck & GFC_RTCHECK_MEM) + { + null_result = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, res, + build_int_cst (pvoid_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + null_result, + trans_os_error_at (NULL, + "Error allocating %lu bytes", + fold_convert + (long_unsigned_type_node, + size)), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block2, tmp); + } + + malloc_result = gfc_finish_block (&block2); + gfc_add_expr_to_block (block, malloc_result); + + if (type != NULL) + res = fold_convert (type, res); + return res; +} + + +/* Allocate memory, using an optional status argument. + + This function follows the following pseudo-code: + + void * + allocate (size_t size, integer_type stat) + { + void *newmem; + + if (stat requested) + stat = 0; + + newmem = malloc (MAX (size, 1)); + if (newmem == NULL) + { + if (stat) + *stat = LIBERROR_ALLOCATION; + else + runtime_error ("Allocation would exceed memory limit"); + } + return newmem; + } */ +void +gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, + tree size, tree status) +{ + tree tmp, error_cond; + stmtblock_t on_error; + tree status_type = status ? TREE_TYPE (status) : NULL_TREE; + + /* If successful and stat= is given, set status to 0. */ + if (status != NULL_TREE) + gfc_add_expr_to_block (block, + fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, 0))); + + /* The allocation itself. */ + size = fold_convert (size_type_node, size); + gfc_add_modify (block, pointer, + fold_convert (TREE_TYPE (pointer), + build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), 1, + fold_build2_loc (input_location, + MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1))))); + + /* What to do in case of error. */ + gfc_start_block (&on_error); + if (status != NULL_TREE) + { + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, + build_int_cst (status_type, LIBERROR_ALLOCATION)); + gfc_add_expr_to_block (&on_error, tmp); + } + else + { + /* Here, os_error_at already implies PRED_NORETURN. */ + tree lusize = fold_convert (long_unsigned_type_node, size); + tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize); + gfc_add_expr_to_block (&on_error, tmp); + } + + error_cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, pointer, + build_int_cst (prvoid_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), + gfc_finish_block (&on_error), + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (block, tmp); +} + + +/* Allocate memory, using an optional status argument. + + This function follows the following pseudo-code: + + void * + allocate (size_t size, void** token, int *stat, char* errmsg, int errlen) + { + void *newmem; + + newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen); + return newmem; + } */ +void +gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size, + tree token, tree status, tree errmsg, tree errlen, + gfc_coarray_regtype alloc_type) +{ + tree tmp, pstat; + + gcc_assert (token != NULL_TREE); + + /* The allocation itself. */ + if (status == NULL_TREE) + pstat = null_pointer_node; + else + pstat = gfc_build_addr_expr (NULL_TREE, status); + + if (errmsg == NULL_TREE) + { + gcc_assert(errlen == NULL_TREE); + errmsg = null_pointer_node; + errlen = build_int_cst (integer_type_node, 0); + } + + size = fold_convert (size_type_node, size); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_register, 7, + fold_build2_loc (input_location, + MAX_EXPR, size_type_node, size, size_one_node), + build_int_cst (integer_type_node, alloc_type), + token, gfc_build_addr_expr (pvoid_type_node, pointer), + pstat, errmsg, errlen); + + gfc_add_expr_to_block (block, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (block, tmp); +} + + +/* Generate code for an ALLOCATE statement when the argument is an + allocatable variable. If the variable is currently allocated, it is an + error to allocate it again. + + This function follows the following pseudo-code: + + void * + allocate_allocatable (void *mem, size_t size, integer_type stat) + { + if (mem == NULL) + return allocate (size, stat); + else + { + if (stat) + stat = LIBERROR_ALLOCATION; + else + runtime_error ("Attempting to allocate already allocated variable"); + } + } + + expr must be set to the original expression being allocated for its locus + and variable name in case a runtime error has to be printed. */ +void +gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, + tree token, tree status, tree errmsg, tree errlen, + tree label_finish, gfc_expr* expr, int corank) +{ + stmtblock_t alloc_block; + tree tmp, null_mem, alloc, error; + tree type = TREE_TYPE (mem); + symbol_attribute caf_attr; + bool need_assign = false, refs_comp = false; + gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC; + + size = fold_convert (size_type_node, size); + null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, + logical_type_node, mem, + build_int_cst (type, 0)), + PRED_FORTRAN_REALLOC); + + /* If mem is NULL, we call gfc_allocate_using_malloc or + gfc_allocate_using_lib. */ + gfc_start_block (&alloc_block); + + if (flag_coarray == GFC_FCOARRAY_LIB) + caf_attr = gfc_caf_attr (expr, true, &refs_comp); + + if (flag_coarray == GFC_FCOARRAY_LIB + && (corank > 0 || caf_attr.codimension)) + { + tree cond, sub_caf_tree; + gfc_se se; + bool compute_special_caf_types_size = false; + + if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) + { + compute_special_caf_types_size = true; + caf_alloc_type = GFC_CAF_LOCK_ALLOC; + } + else if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) + { + compute_special_caf_types_size = true; + caf_alloc_type = GFC_CAF_EVENT_ALLOC; + } + else if (!caf_attr.coarray_comp && refs_comp) + /* Only allocatable components in a derived type coarray can be + allocate only. */ + caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY; + + gfc_init_se (&se, NULL); + sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); + if (sub_caf_tree == NULL_TREE) + sub_caf_tree = token; + + /* When mem is an array ref, then strip the .data-ref. */ + if (TREE_CODE (mem) == COMPONENT_REF + && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem)))) + tmp = TREE_OPERAND (mem, 0); + else + tmp = mem; + + if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp)) + && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0) + && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + { + symbol_attribute attr; + + gfc_clear_attr (&attr); + tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr); + need_assign = true; + } + gfc_add_block_to_block (&alloc_block, &se.pre); + + /* In the front end, we represent the lock variable as pointer. However, + the FE only passes the pointer around and leaves the actual + representation to the library. Hence, we have to convert back to the + number of elements. */ + if (compute_special_caf_types_size) + size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, + size, TYPE_SIZE_UNIT (ptr_type_node)); + + gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree, + status, errmsg, errlen, caf_alloc_type); + if (need_assign) + gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem), + gfc_conv_descriptor_data_get (tmp))); + if (status != NULL_TREE) + { + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_zero_cst (TREE_TYPE (status))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&alloc_block, tmp); + } + } + else + gfc_allocate_using_malloc (&alloc_block, mem, size, status); + + alloc = gfc_finish_block (&alloc_block); + + /* If mem is not NULL, we issue a runtime error or set the + status variable. */ + if (expr) + { + tree varname; + + gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree); + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempting to allocate already" + " allocated variable '%s'", + varname); + } + else + error = gfc_trans_runtime_error (true, NULL, + "Attempting to allocate already allocated" + " variable"); + + if (status != NULL_TREE) + { + tree status_type = TREE_TYPE (status); + + error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, LIBERROR_ALLOCATION)); + } + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, + error, alloc); + gfc_add_expr_to_block (block, tmp); +} + + +/* Free a given variable. */ + +tree +gfc_call_free (tree var) +{ + return build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), + 1, fold_convert (pvoid_type_node, var)); +} + + +/* Build a call to a FINAL procedure, which finalizes "var". */ + +static tree +gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, + bool fini_coarray, gfc_expr *class_size) +{ + stmtblock_t block; + gfc_se se; + tree final_fndecl, array, size, tmp; + symbol_attribute attr; + + gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); + gcc_assert (var); + + gfc_start_block (&block); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, final_wrapper); + final_fndecl = se.expr; + if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) + final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); + + if (ts.type == BT_DERIVED) + { + tree elem_size; + + gcc_assert (!class_size); + elem_size = gfc_typenode_for_spec (&ts); + elem_size = TYPE_SIZE_UNIT (elem_size); + size = fold_convert (gfc_array_index_type, elem_size); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (var->rank) + { + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, var); + array = se.expr; + } + else + { + gfc_conv_expr (&se, var); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + array = se.expr; + + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + gcc_assert (se.post.head == NULL_TREE); + } + } + else + { + gfc_expr *array_expr; + gcc_assert (class_size); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, class_size); + gfc_add_block_to_block (&block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + size = se.expr; + + array_expr = gfc_copy_expr (var); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (array_expr->rank) + { + gfc_add_class_array_ref (array_expr); + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, array_expr); + array = se.expr; + } + else + { + gfc_add_data_component (array_expr); + gfc_conv_expr (&se, array_expr); + gfc_add_block_to_block (&block, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + array = se.expr; + + if (!gfc_is_coarray (array_expr)) + { + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + } + gcc_assert (se.post.head == NULL_TREE); + } + gfc_free_expr (array_expr); + } + + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + + gfc_add_block_to_block (&block, &se.pre); + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, array, + size, fini_coarray ? boolean_true_node + : boolean_false_node); + gfc_add_block_to_block (&block, &se.post); + gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); +} + + +bool +gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, + bool fini_coarray) +{ + gfc_se se; + stmtblock_t block2; + tree final_fndecl, size, array, tmp, cond; + symbol_attribute attr; + gfc_expr *final_expr = NULL; + + if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS) + return false; + + gfc_init_block (&block2); + + if (comp->ts.type == BT_DERIVED) + { + if (comp->attr.pointer) + return false; + + gfc_is_finalizable (comp->ts.u.derived, &final_expr); + if (!final_expr) + return false; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, final_expr); + final_fndecl = se.expr; + size = gfc_typenode_for_spec (&comp->ts); + size = TYPE_SIZE_UNIT (size); + size = fold_convert (gfc_array_index_type, size); + + array = decl; + } + else /* comp->ts.type == BT_CLASS. */ + { + if (CLASS_DATA (comp)->attr.class_pointer) + return false; + + gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr); + final_fndecl = gfc_class_vtab_final_get (decl); + size = gfc_class_vtab_size_get (decl); + array = gfc_class_data_get (decl); + } + + if (comp->attr.allocatable + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) + { + tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)) + ? gfc_conv_descriptor_data_get (array) : array; + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tmp, fold_convert (TREE_TYPE (tmp), + null_pointer_node)); + } + else + cond = logical_true_node; + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))) + { + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + gfc_add_block_to_block (&block2, &se.pre); + gcc_assert (se.post.head == NULL_TREE); + } + + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + + if (!final_expr) + { + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + final_fndecl, + fold_convert (TREE_TYPE (final_fndecl), + null_pointer_node)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, cond, tmp); + } + + if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) + final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); + + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, array, + size, fini_coarray ? boolean_true_node + : boolean_false_node); + gfc_add_expr_to_block (&block2, tmp); + tmp = gfc_finish_block (&block2); + + 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); + + return true; +} + + +/* Add a call to the finalizer, using the passed *expr. Returns + true when a finalizer call has been inserted. */ + +bool +gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) +{ + tree tmp; + gfc_ref *ref; + gfc_expr *expr; + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + + if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS)) + return false; + + if (expr2->ts.type == BT_DERIVED) + { + gfc_is_finalizable (expr2->ts.u.derived, &final_expr); + if (!final_expr) + return false; + } + + /* If we have a class array, we need go back to the class + container. */ + expr = gfc_copy_expr (expr2); + + if (expr->ref && expr->ref->next && !expr->ref->next->next + && expr->ref->next->type == REF_ARRAY + && expr->ref->type == REF_COMPONENT + && strcmp (expr->ref->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (expr->ref); + expr->ref = NULL; + } + else + for (ref = expr->ref; ref; ref = ref->next) + if (ref->next && ref->next->next && !ref->next->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + + if (expr->ts.type == BT_CLASS) + { + has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL); + + if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as) + expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank; + + final_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (final_expr); + gfc_add_final_component (final_expr); + + elem_size = gfc_copy_expr (expr); + gfc_add_vptr_component (elem_size); + gfc_add_size_component (elem_size); + } + + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + tmp = gfc_build_final_call (expr->ts, final_expr, expr, + false, elem_size); + + if (expr->ts.type == BT_CLASS && !has_finalizer) + { + tree cond; + gfc_se se; + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, final_expr); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + + /* For CLASS(*) not only sym->_vtab->_final can be NULL + but already sym->_vtab itself. */ + if (UNLIMITED_POLY (expr)) + { + tree cond2; + gfc_expr *vptr_expr; + + vptr_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (vptr_expr); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + se.expr, + build_int_cst (TREE_TYPE (se.expr), 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, cond2, cond); + } + + 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); + + return true; +} + + +/* User-deallocate; we emit the code directly from the front-end, and the + logic is the same as the previous library function: + + void + deallocate (void *pointer, GFC_INTEGER_4 * stat) + { + if (!pointer) + { + if (stat) + *stat = 1; + else + runtime_error ("Attempt to DEALLOCATE unallocated memory."); + } + else + { + free (pointer); + if (stat) + *stat = 0; + } + } + + In this front-end version, status doesn't have to be GFC_INTEGER_4. + Moreover, if CAN_FAIL is true, then we will not emit a runtime error, + even when no status variable is passed to us (this is used for + unconditional deallocation generated by the front-end at end of + each procedure). + + If a runtime-message is possible, `expr' must point to the original + expression being deallocated for its locus and variable name. + + For coarrays, "pointer" must be the array descriptor and not its + "data" component. + + COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are + the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be + analyzed and set by this routine, and -2 to indicate that a non-coarray is to + be deallocated. */ +tree +gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, + tree errlen, tree label_finish, + bool can_fail, gfc_expr* expr, + int coarray_dealloc_mode, tree add_when_allocated, + tree caf_token) +{ + stmtblock_t null, non_null; + tree cond, tmp, error; + tree status_type = NULL_TREE; + tree token = NULL_TREE; + gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; + + if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) + { + if (flag_coarray == GFC_FCOARRAY_LIB) + { + if (caf_token) + token = caf_token; + else + { + tree caf_type, caf_decl = pointer; + pointer = gfc_conv_descriptor_data_get (caf_decl); + caf_type = TREE_TYPE (caf_decl); + STRIP_NOPS (pointer); + if (GFC_DESCRIPTOR_TYPE_P (caf_type)) + 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 (caf_type) + && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) + != NULL_TREE); + token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); + } + } + + if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) + { + bool comp_ref; + if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp + && comp_ref) + caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; + // else do a deregister as set by default. + } + else + caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; + } + else if (flag_coarray == GFC_FCOARRAY_SINGLE) + pointer = gfc_conv_descriptor_data_get (pointer); + } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + pointer = gfc_conv_descriptor_data_get (pointer); + + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), 0)); + + /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise + we emit a runtime error. */ + gfc_start_block (&null); + if (!can_fail) + { + tree varname; + + gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); + + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempt to DEALLOCATE unallocated '%s'", + varname); + } + else + error = build_empty_stmt (input_location); + + if (status != NULL_TREE && !integer_zerop (status)) + { + tree cond2; + + status_type = TREE_TYPE (TREE_TYPE (status)); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 1)); + error = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, error); + } + + gfc_add_expr_to_block (&null, error); + + /* When POINTER is not NULL, we free it. */ + gfc_start_block (&non_null); + if (add_when_allocated) + gfc_add_expr_to_block (&non_null, add_when_allocated); + gfc_add_finalizer_call (&non_null, expr); + if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY + || flag_coarray != GFC_FCOARRAY_LIB) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, + fold_convert (pvoid_type_node, pointer)); + gfc_add_expr_to_block (&non_null, tmp); + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); + + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + else + { + tree cond2, pstat = null_pointer_node; + + if (errmsg == NULL_TREE) + { + gcc_assert (errlen == NULL_TREE); + errmsg = null_pointer_node; + errlen = build_zero_cst (integer_type_node); + } + else + { + gcc_assert (errlen != NULL_TREE); + if (!POINTER_TYPE_P (TREE_TYPE (errmsg))) + errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); + } + + if (status != NULL_TREE && !integer_zerop (status)) + { + gcc_assert (status_type == integer_type_node); + pstat = status; + } + + token = gfc_build_addr_expr (NULL_TREE, token); + gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 5, + token, build_int_cst (integer_type_node, + caf_dereg_type), + pstat, errmsg, errlen); + gfc_add_expr_to_block (&non_null, tmp); + + /* It guarantees memory consistency within the same segment */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE) + { + tree stat = build_fold_indirect_ref_loc (input_location, status); + tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), + 0)); + + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + stat, build_zero_cst (TREE_TYPE (stat))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), + tmp, nullify); + gfc_add_expr_to_block (&non_null, tmp); + } + else + gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), + 0)); + } + + return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + gfc_finish_block (&null), + gfc_finish_block (&non_null)); +} + + +/* Generate code for deallocation of allocatable scalars (variables or + components). Before the object itself is freed, any allocatable + subcomponents are being deallocated. */ + +tree +gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, + bool can_fail, gfc_expr* expr, + gfc_typespec ts, bool coarray) +{ + stmtblock_t null, non_null; + tree cond, tmp, error; + bool finalizable, comp_ref; + gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; + + if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp + && comp_ref) + caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; + + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), 0)); + + /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise + we emit a runtime error. */ + gfc_start_block (&null); + if (!can_fail) + { + tree varname; + + gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); + + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempt to DEALLOCATE unallocated '%s'", + varname); + } + else + error = build_empty_stmt (input_location); + + if (status != NULL_TREE && !integer_zerop (status)) + { + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 1)); + error = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, error); + } + gfc_add_expr_to_block (&null, error); + + /* When POINTER is not NULL, we free it. */ + gfc_start_block (&non_null); + + /* Free allocatable components. */ + finalizable = gfc_add_finalizer_call (&non_null, expr); + if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) + { + int caf_mode = coarray + ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY + ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0) + | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + : 0; + if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + tmp = gfc_conv_descriptor_data_get (pointer); + else + tmp = build_fold_indirect_ref_loc (input_location, pointer); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode); + gfc_add_expr_to_block (&non_null, tmp); + } + + if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE) + { + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_FREE), 1, + fold_convert (pvoid_type_node, pointer)); + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + fold_build1_loc (input_location, INDIRECT_REF, + status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond2, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + else + { + tree token; + tree pstat = null_pointer_node; + gfc_se se; + + gfc_init_se (&se, NULL); + token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); + gcc_assert (token != NULL_TREE); + + if (status != NULL_TREE && !integer_zerop (status)) + { + gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node); + pstat = status; + } + + tmp = build_call_expr_loc (input_location, + gfor_fndecl_caf_deregister, 5, + token, build_int_cst (integer_type_node, + caf_dereg_type), + pstat, null_pointer_node, integer_zero_node); + gfc_add_expr_to_block (&non_null, tmp); + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory")+1, "memory"); + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE) + { + tree stat = build_fold_indirect_ref_loc (input_location, status); + tree cond2; + + TREE_USED (label_finish) = 1; + tmp = build1_v (GOTO_EXPR, label_finish); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + stat, build_zero_cst (TREE_TYPE (stat))); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), + tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&non_null, tmp); + } + } + + return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + gfc_finish_block (&null), + gfc_finish_block (&non_null)); +} + +/* Reallocate MEM so it has SIZE bytes of data. This behaves like the + following pseudo-code: + +void * +internal_realloc (void *mem, size_t size) +{ + res = realloc (mem, size); + if (!res && size != 0) + _gfortran_os_error ("Allocation would exceed memory limit"); + + return res; +} */ +tree +gfc_call_realloc (stmtblock_t * block, tree mem, tree size) +{ + tree res, nonzero, null_result, tmp; + tree type = TREE_TYPE (mem); + + /* Only evaluate the size once. */ + size = save_expr (fold_convert (size_type_node, size)); + + /* Create a variable to hold the result. */ + res = gfc_create_var (type, NULL); + + /* Call realloc and check the result. */ + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_REALLOC), 2, + fold_convert (pvoid_type_node, mem), size); + gfc_add_modify (block, res, fold_convert (type, tmp)); + null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + res, build_int_cst (pvoid_type_node, 0)); + nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size, + build_int_cst (size_type_node, 0)); + null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, + null_result, nonzero); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + null_result, + trans_os_error_at (NULL, + "Error reallocating to %lu bytes", + fold_convert + (long_unsigned_type_node, size)), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (block, tmp); + + return res; +} + + +/* Add an expression to another one, either at the front or the back. */ + +static void +add_expr_to_chain (tree* chain, tree expr, bool front) +{ + if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) + return; + + if (*chain) + { + if (TREE_CODE (*chain) != STATEMENT_LIST) + { + tree tmp; + + tmp = *chain; + *chain = NULL_TREE; + append_to_statement_list (tmp, chain); + } + + if (front) + { + tree_stmt_iterator i; + + i = tsi_start (*chain); + tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); + } + else + append_to_statement_list (expr, chain); + } + else + *chain = expr; +} + + +/* Add a statement at the end of a block. */ + +void +gfc_add_expr_to_block (stmtblock_t * block, tree expr) +{ + gcc_assert (block); + add_expr_to_chain (&block->head, expr, false); +} + + +/* Add a statement at the beginning of a block. */ + +void +gfc_prepend_expr_to_block (stmtblock_t * block, tree expr) +{ + gcc_assert (block); + add_expr_to_chain (&block->head, expr, true); +} + + +/* Add a block the end of a block. */ + +void +gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append) +{ + gcc_assert (append); + gcc_assert (!append->has_scope); + + gfc_add_expr_to_block (block, append->head); + append->head = NULL_TREE; +} + + +/* Save the current locus. The structure may not be complete, and should + only be used with gfc_restore_backend_locus. */ + +void +gfc_save_backend_locus (locus * loc) +{ + loc->lb = XCNEW (gfc_linebuf); + loc->lb->location = input_location; + loc->lb->file = gfc_current_backend_file; +} + + +/* Set the current locus. */ + +void +gfc_set_backend_locus (locus * loc) +{ + gfc_current_backend_file = loc->lb->file; + input_location = gfc_get_location (loc); +} + + +/* Restore the saved locus. Only used in conjunction with + gfc_save_backend_locus, to free the memory when we are done. */ + +void +gfc_restore_backend_locus (locus * loc) +{ + /* This only restores the information captured by gfc_save_backend_locus, + intentionally does not use gfc_get_location. */ + input_location = loc->lb->location; + gfc_current_backend_file = loc->lb->file; + free (loc->lb); +} + + +/* Translate an executable statement. The tree cond is used by gfc_trans_do. + This static function is wrapped by gfc_trans_code_cond and + gfc_trans_code. */ + +static tree +trans_code (gfc_code * code, tree cond) +{ + stmtblock_t block; + tree res; + + if (!code) + return build_empty_stmt (input_location); + + gfc_start_block (&block); + + /* Translate statements one by one into GENERIC trees until we reach + the end of this gfc_code branch. */ + for (; code; code = code->next) + { + if (code->here != 0) + { + res = gfc_trans_label_here (code); + gfc_add_expr_to_block (&block, res); + } + + gfc_current_locus = code->loc; + gfc_set_backend_locus (&code->loc); + + switch (code->op) + { + case EXEC_NOP: + case EXEC_END_BLOCK: + case EXEC_END_NESTED_BLOCK: + case EXEC_END_PROCEDURE: + res = NULL_TREE; + break; + + case EXEC_ASSIGN: + res = gfc_trans_assign (code); + break; + + case EXEC_LABEL_ASSIGN: + res = gfc_trans_label_assign (code); + break; + + case EXEC_POINTER_ASSIGN: + res = gfc_trans_pointer_assign (code); + break; + + case EXEC_INIT_ASSIGN: + if (code->expr1->ts.type == BT_CLASS) + res = gfc_trans_class_init_assign (code); + else + res = gfc_trans_init_assign (code); + break; + + case EXEC_CONTINUE: + res = NULL_TREE; + break; + + case EXEC_CRITICAL: + res = gfc_trans_critical (code); + break; + + case EXEC_CYCLE: + res = gfc_trans_cycle (code); + break; + + case EXEC_EXIT: + res = gfc_trans_exit (code); + break; + + case EXEC_GOTO: + res = gfc_trans_goto (code); + break; + + case EXEC_ENTRY: + res = gfc_trans_entry (code); + break; + + case EXEC_PAUSE: + res = gfc_trans_pause (code); + break; + + case EXEC_STOP: + case EXEC_ERROR_STOP: + res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP); + break; + + case EXEC_CALL: + /* For MVBITS we've got the special exception that we need a + dependency check, too. */ + { + bool is_mvbits = false; + + if (code->resolved_isym) + { + res = gfc_conv_intrinsic_subroutine (code); + if (res != NULL_TREE) + break; + } + + if (code->resolved_isym + && code->resolved_isym->id == GFC_ISYM_MVBITS) + is_mvbits = true; + + res = gfc_trans_call (code, is_mvbits, NULL_TREE, + NULL_TREE, false); + } + break; + + case EXEC_CALL_PPC: + res = gfc_trans_call (code, false, NULL_TREE, + NULL_TREE, false); + break; + + case EXEC_ASSIGN_CALL: + res = gfc_trans_call (code, true, NULL_TREE, + NULL_TREE, false); + break; + + case EXEC_RETURN: + res = gfc_trans_return (code); + break; + + case EXEC_IF: + res = gfc_trans_if (code); + break; + + case EXEC_ARITHMETIC_IF: + res = gfc_trans_arithmetic_if (code); + break; + + case EXEC_BLOCK: + res = gfc_trans_block_construct (code); + break; + + case EXEC_DO: + res = gfc_trans_do (code, cond); + break; + + case EXEC_DO_CONCURRENT: + res = gfc_trans_do_concurrent (code); + break; + + case EXEC_DO_WHILE: + res = gfc_trans_do_while (code); + break; + + case EXEC_SELECT: + res = gfc_trans_select (code); + break; + + case EXEC_SELECT_TYPE: + res = gfc_trans_select_type (code); + break; + + case EXEC_SELECT_RANK: + res = gfc_trans_select_rank (code); + break; + + case EXEC_FLUSH: + res = gfc_trans_flush (code); + break; + + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: + res = gfc_trans_sync (code, code->op); + break; + + case EXEC_LOCK: + case EXEC_UNLOCK: + res = gfc_trans_lock_unlock (code, code->op); + break; + + case EXEC_EVENT_POST: + case EXEC_EVENT_WAIT: + res = gfc_trans_event_post_wait (code, code->op); + break; + + case EXEC_FAIL_IMAGE: + res = gfc_trans_fail_image (code); + break; + + case EXEC_FORALL: + res = gfc_trans_forall (code); + break; + + case EXEC_FORM_TEAM: + res = gfc_trans_form_team (code); + break; + + case EXEC_CHANGE_TEAM: + res = gfc_trans_change_team (code); + break; + + case EXEC_END_TEAM: + res = gfc_trans_end_team (code); + break; + + case EXEC_SYNC_TEAM: + res = gfc_trans_sync_team (code); + break; + + case EXEC_WHERE: + res = gfc_trans_where (code); + break; + + case EXEC_ALLOCATE: + res = gfc_trans_allocate (code); + break; + + case EXEC_DEALLOCATE: + res = gfc_trans_deallocate (code); + break; + + case EXEC_OPEN: + res = gfc_trans_open (code); + break; + + case EXEC_CLOSE: + res = gfc_trans_close (code); + break; + + case EXEC_READ: + res = gfc_trans_read (code); + break; + + case EXEC_WRITE: + res = gfc_trans_write (code); + break; + + case EXEC_IOLENGTH: + res = gfc_trans_iolength (code); + break; + + case EXEC_BACKSPACE: + res = gfc_trans_backspace (code); + break; + + case EXEC_ENDFILE: + res = gfc_trans_endfile (code); + break; + + case EXEC_INQUIRE: + res = gfc_trans_inquire (code); + break; + + case EXEC_WAIT: + res = gfc_trans_wait (code); + break; + + case EXEC_REWIND: + res = gfc_trans_rewind (code); + break; + + case EXEC_TRANSFER: + res = gfc_trans_transfer (code); + break; + + case EXEC_DT_END: + res = gfc_trans_dt_end (code); + break; + + case EXEC_OMP_ATOMIC: + case EXEC_OMP_BARRIER: + case EXEC_OMP_CANCEL: + case EXEC_OMP_CANCELLATION_POINT: + case EXEC_OMP_CRITICAL: + case EXEC_OMP_DEPOBJ: + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DO: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_LOOP: + case EXEC_OMP_ERROR: + case EXEC_OMP_FLUSH: + case EXEC_OMP_MASKED: + case EXEC_OMP_MASKED_TASKLOOP: + case EXEC_OMP_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASTER: + case EXEC_OMP_MASTER_TASKLOOP: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_ORDERED: + case EXEC_OMP_PARALLEL: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_PARALLEL_MASKED: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASTER: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_SECTIONS: + case EXEC_OMP_PARALLEL_WORKSHARE: + case EXEC_OMP_SCOPE: + case EXEC_OMP_SECTIONS: + case EXEC_OMP_SIMD: + case EXEC_OMP_SINGLE: + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_DATA: + case EXEC_OMP_TARGET_ENTER_DATA: + case EXEC_OMP_TARGET_EXIT_DATA: + case EXEC_OMP_TARGET_PARALLEL: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_TARGET_UPDATE: + case EXEC_OMP_TASK: + case EXEC_OMP_TASKGROUP: + case EXEC_OMP_TASKLOOP: + case EXEC_OMP_TASKLOOP_SIMD: + case EXEC_OMP_TASKWAIT: + case EXEC_OMP_TASKYIELD: + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_WORKSHARE: + res = gfc_trans_omp_directive (code); + break; + + case EXEC_OACC_CACHE: + case EXEC_OACC_WAIT: + case EXEC_OACC_UPDATE: + case EXEC_OACC_LOOP: + case EXEC_OACC_HOST_DATA: + case EXEC_OACC_DATA: + case EXEC_OACC_KERNELS: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_PARALLEL: + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_SERIAL: + case EXEC_OACC_SERIAL_LOOP: + case EXEC_OACC_ENTER_DATA: + case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ATOMIC: + case EXEC_OACC_DECLARE: + res = gfc_trans_oacc_directive (code); + break; + + default: + gfc_internal_error ("gfc_trans_code(): Bad statement code"); + } + + gfc_set_backend_locus (&code->loc); + + if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) + { + if (TREE_CODE (res) != STATEMENT_LIST) + SET_EXPR_LOCATION (res, input_location); + + /* Add the new statement to the block. */ + gfc_add_expr_to_block (&block, res); + } + } + + /* Return the finished block. */ + return gfc_finish_block (&block); +} + + +/* Translate an executable statement with condition, cond. The condition is + used by gfc_trans_do to test for IO result conditions inside implied + DO loops of READ and WRITE statements. See build_dt in trans-io.c. */ + +tree +gfc_trans_code_cond (gfc_code * code, tree cond) +{ + return trans_code (code, cond); +} + +/* Translate an executable statement without condition. */ + +tree +gfc_trans_code (gfc_code * code) +{ + return trans_code (code, NULL_TREE); +} + + +/* This function is called after a complete program unit has been parsed + and resolved. */ + +void +gfc_generate_code (gfc_namespace * ns) +{ + ompws_flags = 0; + if (ns->is_block_data) + { + gfc_generate_block_data (ns); + return; + } + + gfc_generate_function_code (ns); +} + + +/* This function is called after a complete module has been parsed + and resolved. */ + +void +gfc_generate_module_code (gfc_namespace * ns) +{ + gfc_namespace *n; + struct module_htab_entry *entry; + + gcc_assert (ns->proc_name->backend_decl == NULL); + ns->proc_name->backend_decl + = build_decl (gfc_get_location (&ns->proc_name->declared_at), + NAMESPACE_DECL, get_identifier (ns->proc_name->name), + void_type_node); + entry = gfc_find_module (ns->proc_name->name); + if (entry->namespace_decl) + /* Buggy sourcecode, using a module before defining it? */ + entry->decls->empty (); + entry->namespace_decl = ns->proc_name->backend_decl; + + gfc_generate_module_vars (ns); + + /* We need to generate all module function prototypes first, to allow + sibling calls. */ + for (n = ns->contained; n; n = n->sibling) + { + gfc_entry_list *el; + + if (!n->proc_name) + continue; + + gfc_create_function_decl (n, false); + DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; + gfc_module_add_decl (entry, n->proc_name->backend_decl); + for (el = ns->entries; el; el = el->next) + { + DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl; + gfc_module_add_decl (entry, el->sym->backend_decl); + } + } + + for (n = ns->contained; n; n = n->sibling) + { + if (!n->proc_name) + continue; + + gfc_generate_function_code (n); + } +} + + +/* Initialize an init/cleanup block with existing code. */ + +void +gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) +{ + gcc_assert (block); + + block->init = NULL_TREE; + block->code = code; + block->cleanup = NULL_TREE; +} + + +/* Add a new pair of initializers/clean-up code. */ + +void +gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) +{ + gcc_assert (block); + + /* The new pair of init/cleanup should be "wrapped around" the existing + block of code, thus the initialization is added to the front and the + cleanup to the back. */ + add_expr_to_chain (&block->init, init, true); + add_expr_to_chain (&block->cleanup, cleanup, false); +} + + +/* Finish up a wrapped block by building a corresponding try-finally expr. */ + +tree +gfc_finish_wrapped_block (gfc_wrapped_block* block) +{ + tree result; + + gcc_assert (block); + + /* Build the final expression. For this, just add init and body together, + and put clean-up with that into a TRY_FINALLY_EXPR. */ + result = block->init; + add_expr_to_chain (&result, block->code, false); + if (block->cleanup) + result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, + result, block->cleanup); + + /* Clear the block. */ + block->init = NULL_TREE; + block->code = NULL_TREE; + block->cleanup = NULL_TREE; + + return result; +} + + +/* Helper function for marking a boolean expression tree as unlikely. */ + +tree +gfc_unlikely (tree cond, enum br_predictor predictor) +{ + tree tmp; + + if (optimize) + { + cond = fold_convert (long_integer_type_node, cond); + tmp = build_zero_cst (long_integer_type_node); + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_EXPECT), + 3, cond, tmp, + build_int_cst (integer_type_node, + predictor)); + } + return cond; +} + + +/* Helper function for marking a boolean expression tree as likely. */ + +tree +gfc_likely (tree cond, enum br_predictor predictor) +{ + tree tmp; + + if (optimize) + { + cond = fold_convert (long_integer_type_node, cond); + tmp = build_one_cst (long_integer_type_node); + cond = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_EXPECT), + 3, cond, tmp, + build_int_cst (integer_type_node, + predictor)); + } + return cond; +} + + +/* Get the string length for a deferred character length component. */ + +bool +gfc_deferred_strlen (gfc_component *c, tree *decl) +{ + char name[GFC_MAX_SYMBOL_LEN+9]; + gfc_component *strlen; + if (!(c->ts.type == BT_CHARACTER + && (c->ts.deferred || c->attr.pdt_string))) + return false; + sprintf (name, "_%s_length", c->name); + for (strlen = c; strlen; strlen = strlen->next) + if (strcmp (strlen->name, name) == 0) + break; + *decl = strlen ? strlen->backend_decl : NULL_TREE; + return strlen != NULL; +} -- cgit v1.1